1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
10 * Copyright (C) 1992-2003, 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 * Extensive contributions were provided by Ada Core Technologies Inc. *
26 ****************************************************************************/
30 #include "coretypes.h"
60 struct Node
*Nodes_Ptr
;
61 Node_Id
*Next_Node_Ptr
;
62 Node_Id
*Prev_Node_Ptr
;
63 struct Elist_Header
*Elists_Ptr
;
64 struct Elmt_Item
*Elmts_Ptr
;
65 struct String_Entry
*Strings_Ptr
;
66 Char_Code
*String_Chars_Ptr
;
67 struct List_Header
*List_Headers_Ptr
;
69 /* Current filename without path. */
70 const char *ref_filename
;
72 /* Flag indicating whether file names are discarded in exception messages */
73 int discard_file_names
;
75 /* If true, then gigi is being called on an analyzed but unexpanded
76 tree, and the only purpose of the call is to properly annotate
77 types with representation information. */
78 int type_annotate_only
;
80 /* List of TREE_LIST nodes representing a block stack. TREE_VALUE
81 of each gives the variable used for the setjmp buffer in the current
82 block, if any. TREE_PURPOSE gives the bottom condition for a loop,
83 if this block is for a loop. The latter is only used to save the tree
87 /* List of TREE_LIST nodes representing a stack of exception pointer
88 variables. TREE_VALUE is the VAR_DECL that stores the address of
89 the raised exception. Nonzero means we are in an exception
90 handler. Not used in the zero-cost case. */
91 static GTY(()) tree gnu_except_ptr_stack
;
93 /* List of TREE_LIST nodes containing pending elaborations lists.
94 used to prevent the elaborations being reclaimed by GC. */
95 static GTY(()) tree gnu_pending_elaboration_lists
;
97 /* Map GNAT tree codes to GCC tree codes for simple expressions. */
98 static enum tree_code gnu_codes
[Number_Node_Kinds
];
100 /* Current node being treated, in case gigi_abort called. */
101 Node_Id error_gnat_node
;
103 /* Variable that stores a list of labels to be used as a goto target instead of
104 a return in some functions. See processing for N_Subprogram_Body. */
105 static GTY(()) tree gnu_return_label_stack
;
107 static tree tree_transform
PARAMS((Node_Id
));
108 static void elaborate_all_entities
PARAMS((Node_Id
));
109 static void process_freeze_entity
PARAMS((Node_Id
));
110 static void process_inlined_subprograms
PARAMS((Node_Id
));
111 static void process_decls
PARAMS((List_Id
, List_Id
, Node_Id
,
113 static tree emit_access_check
PARAMS((tree
));
114 static tree emit_discriminant_check
PARAMS((tree
, Node_Id
));
115 static tree emit_range_check
PARAMS((tree
, Node_Id
));
116 static tree emit_index_check
PARAMS((tree
, tree
, tree
, tree
));
117 static tree emit_check
PARAMS((tree
, tree
, int));
118 static tree convert_with_check
PARAMS((Entity_Id
, tree
,
120 static int addressable_p
PARAMS((tree
));
121 static tree assoc_to_constructor
PARAMS((Node_Id
, tree
));
122 static tree extract_values
PARAMS((tree
, tree
));
123 static tree pos_to_constructor
PARAMS((Node_Id
, tree
, Entity_Id
));
124 static tree maybe_implicit_deref
PARAMS((tree
));
125 static tree gnat_stabilize_reference_1
PARAMS((tree
, int));
126 static int build_unit_elab
PARAMS((Entity_Id
, int, tree
));
128 /* Constants for +0.5 and -0.5 for float-to-integer rounding. */
129 static REAL_VALUE_TYPE dconstp5
;
130 static REAL_VALUE_TYPE dconstmp5
;
132 /* This is the main program of the back-end. It sets up all the table
133 structures and then generates code. */
136 gigi (gnat_root
, max_gnat_node
, number_name
, nodes_ptr
, next_node_ptr
,
137 prev_node_ptr
, elists_ptr
, elmts_ptr
, strings_ptr
, string_chars_ptr
,
138 list_headers_ptr
, number_units
, file_info_ptr
, standard_integer
,
139 standard_long_long_float
, standard_exception_type
, gigi_operating_mode
)
143 struct Node
*nodes_ptr
;
144 Node_Id
*next_node_ptr
;
145 Node_Id
*prev_node_ptr
;
146 struct Elist_Header
*elists_ptr
;
147 struct Elmt_Item
*elmts_ptr
;
148 struct String_Entry
*strings_ptr
;
149 Char_Code
*string_chars_ptr
;
150 struct List_Header
*list_headers_ptr
;
151 Int number_units ATTRIBUTE_UNUSED
;
152 char *file_info_ptr ATTRIBUTE_UNUSED
;
153 Entity_Id standard_integer
;
154 Entity_Id standard_long_long_float
;
155 Entity_Id standard_exception_type
;
156 Int gigi_operating_mode
;
158 tree gnu_standard_long_long_float
;
159 tree gnu_standard_exception_type
;
161 max_gnat_nodes
= max_gnat_node
;
162 number_names
= number_name
;
163 Nodes_Ptr
= nodes_ptr
;
164 Next_Node_Ptr
= next_node_ptr
;
165 Prev_Node_Ptr
= prev_node_ptr
;
166 Elists_Ptr
= elists_ptr
;
167 Elmts_Ptr
= elmts_ptr
;
168 Strings_Ptr
= strings_ptr
;
169 String_Chars_Ptr
= string_chars_ptr
;
170 List_Headers_Ptr
= list_headers_ptr
;
172 type_annotate_only
= (gigi_operating_mode
== 1);
174 /* See if we should discard file names in exception messages. */
175 discard_file_names
= (Global_Discard_Names
|| Debug_Flag_NN
);
177 if (Nkind (gnat_root
) != N_Compilation_Unit
)
180 set_lineno (gnat_root
, 0);
182 /* Initialize ourselves. */
187 /* Enable GNAT stack checking method if needed */
188 if (!Stack_Check_Probes_On_Target
)
189 set_stack_check_libfunc (gen_rtx (SYMBOL_REF
, Pmode
, "_gnat_stack_check"));
191 /* Save the type we made for integer as the type for Standard.Integer.
192 Then make the rest of the standard types. Note that some of these
194 save_gnu_tree (Base_Type (standard_integer
),
195 TYPE_NAME (integer_type_node
), 0);
197 gnu_except_ptr_stack
= tree_cons (NULL_TREE
, NULL_TREE
, NULL_TREE
);
199 dconstp5
= REAL_VALUE_ATOF ("0.5", DFmode
);
200 dconstmp5
= REAL_VALUE_ATOF ("-0.5", DFmode
);
202 gnu_standard_long_long_float
203 = gnat_to_gnu_entity (Base_Type (standard_long_long_float
), NULL_TREE
, 0);
204 gnu_standard_exception_type
205 = gnat_to_gnu_entity (Base_Type (standard_exception_type
), NULL_TREE
, 0);
207 init_gigi_decls (gnu_standard_long_long_float
, gnu_standard_exception_type
);
209 /* Process any Pragma Ident for the main unit. */
210 #ifdef ASM_OUTPUT_IDENT
211 if (Present (Ident_String (Main_Unit
)))
214 TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit
))));
217 /* If we are using the GCC exception mechanism, let GCC know. */
218 if (Exception_Mechanism
== GCC_ZCX
)
221 gnat_to_code (gnat_root
);
225 /* This function is the driver of the GNAT to GCC tree transformation process.
226 GNAT_NODE is the root of some gnat tree. It generates code for that
230 gnat_to_code (gnat_node
)
235 /* Save node number in case error */
236 error_gnat_node
= gnat_node
;
238 gnu_root
= tree_transform (gnat_node
);
240 /* This should just generate code, not return a value. If it returns
241 a value, something is wrong. */
242 if (gnu_root
!= error_mark_node
)
246 /* GNAT_NODE is the root of some GNAT tree. Return the root of the GCC
247 tree corresponding to that GNAT tree. Normally, no code is generated.
248 We just return an equivalent tree which is used elsewhere to generate
252 gnat_to_gnu (gnat_node
)
257 /* Save node number in case error */
258 error_gnat_node
= gnat_node
;
260 gnu_root
= tree_transform (gnat_node
);
262 /* If we got no code as a result, something is wrong. */
263 if (gnu_root
== error_mark_node
&& ! type_annotate_only
)
269 /* This function is the driver of the GNAT to GCC tree transformation process.
270 It is the entry point of the tree transformer. GNAT_NODE is the root of
271 some GNAT tree. Return the root of the corresponding GCC tree or
272 error_mark_node to signal that there is no GCC tree to return.
274 The latter is the case if only code generation actions have to be performed
275 like in the case of if statements, loops, etc. This routine is wrapped
276 in the above two routines for most purposes. */
279 tree_transform (gnat_node
)
282 tree gnu_result
= error_mark_node
; /* Default to no value. */
283 tree gnu_result_type
= void_type_node
;
285 tree gnu_lhs
, gnu_rhs
;
287 Entity_Id gnat_temp_type
;
289 /* Set input_file_name and lineno from the Sloc in the GNAT tree. */
290 set_lineno (gnat_node
, 0);
292 /* If this is a Statement and we are at top level, we add the statement
293 as an elaboration for a null tree. That will cause it to be placed
294 in the elaboration procedure. */
295 if (global_bindings_p ()
296 && ((IN (Nkind (gnat_node
), N_Statement_Other_Than_Procedure_Call
)
297 && Nkind (gnat_node
) != N_Null_Statement
)
298 || Nkind (gnat_node
) == N_Procedure_Call_Statement
299 || Nkind (gnat_node
) == N_Label
300 || (Nkind (gnat_node
) == N_Handled_Sequence_Of_Statements
301 && (Present (Exception_Handlers (gnat_node
))
302 || Present (At_End_Proc (gnat_node
))))
303 || ((Nkind (gnat_node
) == N_Raise_Constraint_Error
304 || Nkind (gnat_node
) == N_Raise_Storage_Error
305 || Nkind (gnat_node
) == N_Raise_Program_Error
)
306 && (Ekind (Etype (gnat_node
)) == E_Void
))))
308 add_pending_elaborations (NULL_TREE
, make_transform_expr (gnat_node
));
310 return error_mark_node
;
313 /* If this node is a non-static subexpression and we are only
314 annotating types, make this into a NULL_EXPR for non-VOID types
315 and error_mark_node for void return types. But allow
316 N_Identifier since we use it for lots of things, including
317 getting trees for discriminants. */
319 if (type_annotate_only
320 && IN (Nkind (gnat_node
), N_Subexpr
)
321 && Nkind (gnat_node
) != N_Identifier
322 && ! Compile_Time_Known_Value (gnat_node
))
324 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
326 if (TREE_CODE (gnu_result_type
) == VOID_TYPE
)
327 return error_mark_node
;
329 return build1 (NULL_EXPR
, gnu_result_type
,
330 build_call_raise (CE_Range_Check_Failed
));
333 switch (Nkind (gnat_node
))
335 /********************************/
336 /* Chapter 2: Lexical Elements: */
337 /********************************/
340 case N_Expanded_Name
:
341 case N_Operator_Symbol
:
342 case N_Defining_Identifier
:
344 /* If the Etype of this node does not equal the Etype of the
345 Entity, something is wrong with the entity map, probably in
346 generic instantiation. However, this does not apply to
347 types. Since we sometime have strange Ekind's, just do
348 this test for objects. Also, if the Etype of the Entity
349 is private, the Etype of the N_Identifier is allowed to be the
350 full type and also we consider a packed array type to be the
351 same as the original type. Finally, if the types are Itypes,
352 one may be a copy of the other, which is also legal. */
354 gnat_temp
= (Nkind (gnat_node
) == N_Defining_Identifier
355 ? gnat_node
: Entity (gnat_node
));
356 gnat_temp_type
= Etype (gnat_temp
);
358 if (Etype (gnat_node
) != gnat_temp_type
359 && ! (Is_Packed (gnat_temp_type
)
360 && Etype (gnat_node
) == Packed_Array_Type (gnat_temp_type
))
361 && ! (IN (Ekind (gnat_temp_type
), Private_Kind
)
362 && Present (Full_View (gnat_temp_type
))
363 && ((Etype (gnat_node
) == Full_View (gnat_temp_type
))
364 || (Is_Packed (Full_View (gnat_temp_type
))
365 && Etype (gnat_node
) ==
366 Packed_Array_Type (Full_View (gnat_temp_type
)))))
367 && (!Is_Itype (Etype (gnat_node
)) || !Is_Itype (gnat_temp_type
))
368 && (Ekind (gnat_temp
) == E_Variable
369 || Ekind (gnat_temp
) == E_Component
370 || Ekind (gnat_temp
) == E_Constant
371 || Ekind (gnat_temp
) == E_Loop_Parameter
372 || IN (Ekind (gnat_temp
), Formal_Kind
)))
375 /* If this is a reference to a deferred constant whose partial view
376 is an unconstrained private type, the proper type is on the full
377 view of the constant, not on the full view of the type, which may
380 This may be a reference to a type, for example in the prefix of the
381 attribute Position, generated for dispatching code (see Make_DT in
382 exp_disp,adb). In that case we need the type itself, not is parent,
383 in particular if it is a derived type */
385 if (Is_Private_Type (gnat_temp_type
)
386 && Has_Unknown_Discriminants (gnat_temp_type
)
387 && Present (Full_View (gnat_temp
))
388 && ! Is_Type (gnat_temp
))
390 gnat_temp
= Full_View (gnat_temp
);
391 gnat_temp_type
= Etype (gnat_temp
);
392 gnu_result_type
= get_unpadded_type (gnat_temp_type
);
396 /* Expand the type of this identitier first, in case it is
397 an enumeral literal, which only get made when the type
398 is expanded. There is no order-of-elaboration issue here.
399 We want to use the Actual_Subtype if it has already been
400 elaborated, otherwise the Etype. Avoid using Actual_Subtype
401 for packed arrays to simplify things. */
402 if ((Ekind (gnat_temp
) == E_Constant
403 || Ekind (gnat_temp
) == E_Variable
|| Is_Formal (gnat_temp
))
404 && ! (Is_Array_Type (Etype (gnat_temp
))
405 && Present (Packed_Array_Type (Etype (gnat_temp
))))
406 && Present (Actual_Subtype (gnat_temp
))
407 && present_gnu_tree (Actual_Subtype (gnat_temp
)))
408 gnat_temp_type
= Actual_Subtype (gnat_temp
);
410 gnat_temp_type
= Etype (gnat_node
);
412 gnu_result_type
= get_unpadded_type (gnat_temp_type
);
415 gnu_result
= gnat_to_gnu_entity (gnat_temp
, NULL_TREE
, 0);
417 /* If we are in an exception handler, force this variable into memory
418 to ensure optimization does not remove stores that appear
419 redundant but are actually needed in case an exception occurs.
421 ??? Note that we need not do this if the variable is declared within
422 the handler, only if it is referenced in the handler and declared
423 in an enclosing block, but we have no way of testing that
425 if (TREE_VALUE (gnu_except_ptr_stack
) != 0)
427 gnat_mark_addressable (gnu_result
);
428 flush_addressof (gnu_result
);
431 /* Some objects (such as parameters passed by reference, globals of
432 variable size, and renamed objects) actually represent the address
433 of the object. In that case, we must do the dereference. Likewise,
434 deal with parameters to foreign convention subprograms. Call fold
435 here since GNU_RESULT may be a CONST_DECL. */
436 if (DECL_P (gnu_result
)
437 && (DECL_BY_REF_P (gnu_result
)
438 || (TREE_CODE (gnu_result
) == PARM_DECL
439 && DECL_BY_COMPONENT_PTR_P (gnu_result
))))
441 int ro
= DECL_POINTS_TO_READONLY_P (gnu_result
);
443 if (TREE_CODE (gnu_result
) == PARM_DECL
444 && DECL_BY_COMPONENT_PTR_P (gnu_result
))
445 gnu_result
= convert (build_pointer_type (gnu_result_type
),
448 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
,
450 TREE_READONLY (gnu_result
) = TREE_STATIC (gnu_result
) = ro
;
453 /* The GNAT tree has the type of a function as the type of its result.
454 Also use the type of the result if the Etype is a subtype which
455 is nominally unconstrained. But remove any padding from the
457 if (TREE_CODE (TREE_TYPE (gnu_result
)) == FUNCTION_TYPE
458 || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type
))
460 gnu_result_type
= TREE_TYPE (gnu_result
);
461 if (TREE_CODE (gnu_result_type
) == RECORD_TYPE
462 && TYPE_IS_PADDING_P (gnu_result_type
))
463 gnu_result_type
= TREE_TYPE (TYPE_FIELDS (gnu_result_type
));
466 /* We always want to return the underlying INTEGER_CST for an
467 enumeration literal to avoid the need to call fold in lots
468 of places. But don't do this is the parent will be taking
469 the address of this object. */
470 if (TREE_CODE (gnu_result
) == CONST_DECL
)
472 gnat_temp
= Parent (gnat_node
);
473 if (DECL_CONST_CORRESPONDING_VAR (gnu_result
) == 0
474 || (Nkind (gnat_temp
) != N_Reference
475 && ! (Nkind (gnat_temp
) == N_Attribute_Reference
476 && ((Get_Attribute_Id (Attribute_Name (gnat_temp
))
478 || (Get_Attribute_Id (Attribute_Name (gnat_temp
))
480 || (Get_Attribute_Id (Attribute_Name (gnat_temp
))
481 == Attr_Unchecked_Access
)
482 || (Get_Attribute_Id (Attribute_Name (gnat_temp
))
483 == Attr_Unrestricted_Access
)))))
484 gnu_result
= DECL_INITIAL (gnu_result
);
488 case N_Integer_Literal
:
492 /* Get the type of the result, looking inside any padding and
493 left-justified modular types. Then get the value in that type. */
494 gnu_type
= gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
496 if (TREE_CODE (gnu_type
) == RECORD_TYPE
497 && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_type
))
498 gnu_type
= TREE_TYPE (TYPE_FIELDS (gnu_type
));
500 gnu_result
= UI_To_gnu (Intval (gnat_node
), gnu_type
);
502 /* If the result overflows (meaning it doesn't fit in its base type),
503 abort. We would like to check that the value is within the range
504 of the subtype, but that causes problems with subtypes whose usage
505 will raise Constraint_Error and with biased representation, so
507 if (TREE_CONSTANT_OVERFLOW (gnu_result
))
512 case N_Character_Literal
:
513 /* If a Entity is present, it means that this was one of the
514 literals in a user-defined character type. In that case,
515 just return the value in the CONST_DECL. Otherwise, use the
516 character code. In that case, the base type should be an
517 INTEGER_TYPE, but we won't bother checking for that. */
518 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
519 if (Present (Entity (gnat_node
)))
520 gnu_result
= DECL_INITIAL (get_gnu_tree (Entity (gnat_node
)));
522 gnu_result
= convert (gnu_result_type
,
523 build_int_2 (Char_Literal_Value (gnat_node
), 0));
527 /* If this is of a fixed-point type, the value we want is the
528 value of the corresponding integer. */
529 if (IN (Ekind (Underlying_Type (Etype (gnat_node
))), Fixed_Point_Kind
))
531 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
532 gnu_result
= UI_To_gnu (Corresponding_Integer_Value (gnat_node
),
534 if (TREE_CONSTANT_OVERFLOW (gnu_result
)
538 /* We should never see a Vax_Float type literal, since the front end
539 is supposed to transform these using appropriate conversions */
540 else if (Vax_Float (Underlying_Type (Etype (gnat_node
))))
545 Ureal ur_realval
= Realval (gnat_node
);
547 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
549 /* If the real value is zero, so is the result. Otherwise,
550 convert it to a machine number if it isn't already. That
551 forces BASE to 0 or 2 and simplifies the rest of our logic. */
552 if (UR_Is_Zero (ur_realval
))
553 gnu_result
= convert (gnu_result_type
, integer_zero_node
);
556 if (! Is_Machine_Number (gnat_node
))
558 = Machine (Base_Type (Underlying_Type (Etype (gnat_node
))),
559 ur_realval
, Round_Even
);
562 = UI_To_gnu (Numerator (ur_realval
), gnu_result_type
);
564 /* If we have a base of zero, divide by the denominator.
565 Otherwise, the base must be 2 and we scale the value, which
566 we know can fit in the mantissa of the type (hence the use
567 of that type above). */
568 if (Rbase (ur_realval
) == 0)
570 = build_binary_op (RDIV_EXPR
,
571 get_base_type (gnu_result_type
),
573 UI_To_gnu (Denominator (ur_realval
),
575 else if (Rbase (ur_realval
) != 2)
582 real_ldexp (&tmp
, &TREE_REAL_CST (gnu_result
),
583 - UI_To_Int (Denominator (ur_realval
)));
584 gnu_result
= build_real (gnu_result_type
, tmp
);
588 /* Now see if we need to negate the result. Do it this way to
589 properly handle -0. */
590 if (UR_Is_Negative (Realval (gnat_node
)))
592 = build_unary_op (NEGATE_EXPR
, get_base_type (gnu_result_type
),
598 case N_String_Literal
:
599 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
600 if (TYPE_PRECISION (TREE_TYPE (gnu_result_type
)) == HOST_BITS_PER_CHAR
)
602 /* We assume here that all strings are of type standard.string.
603 "Weird" types of string have been converted to an aggregate
605 String_Id gnat_string
= Strval (gnat_node
);
606 int length
= String_Length (gnat_string
);
607 char *string
= (char *) alloca (length
+ 1);
610 /* Build the string with the characters in the literal. Note
611 that Ada strings are 1-origin. */
612 for (i
= 0; i
< length
; i
++)
613 string
[i
] = Get_String_Char (gnat_string
, i
+ 1);
615 /* Put a null at the end of the string in case it's in a context
616 where GCC will want to treat it as a C string. */
619 gnu_result
= build_string (length
, string
);
621 /* Strings in GCC don't normally have types, but we want
622 this to not be converted to the array type. */
623 TREE_TYPE (gnu_result
) = gnu_result_type
;
627 /* Build a list consisting of each character, then make
629 String_Id gnat_string
= Strval (gnat_node
);
630 int length
= String_Length (gnat_string
);
632 tree gnu_list
= NULL_TREE
;
634 for (i
= 0; i
< length
; i
++)
636 = tree_cons (NULL_TREE
,
637 convert (TREE_TYPE (gnu_result_type
),
638 build_int_2 (Get_String_Char (gnat_string
,
644 = gnat_build_constructor (gnu_result_type
, nreverse (gnu_list
));
649 if (type_annotate_only
)
652 /* Check for (and ignore) unrecognized pragma */
653 if (! Is_Pragma_Name (Chars (gnat_node
)))
656 switch (Get_Pragma_Id (Chars (gnat_node
)))
658 case Pragma_Inspection_Point
:
659 /* Do nothing at top level: all such variables are already
661 if (global_bindings_p ())
664 set_lineno (gnat_node
, 1);
665 for (gnat_temp
= First (Pragma_Argument_Associations (gnat_node
));
667 gnat_temp
= Next (gnat_temp
))
669 gnu_expr
= gnat_to_gnu (Expression (gnat_temp
));
670 if (TREE_CODE (gnu_expr
) == UNCONSTRAINED_ARRAY_REF
)
671 gnu_expr
= TREE_OPERAND (gnu_expr
, 0);
673 gnu_expr
= build1 (USE_EXPR
, void_type_node
, gnu_expr
);
674 TREE_SIDE_EFFECTS (gnu_expr
) = 1;
675 expand_expr_stmt (gnu_expr
);
679 case Pragma_Optimize
:
680 switch (Chars (Expression
681 (First (Pragma_Argument_Associations (gnat_node
)))))
683 case Name_Time
: case Name_Space
:
685 post_error ("insufficient -O value?", gnat_node
);
690 post_error ("must specify -O0?", gnat_node
);
699 case Pragma_Reviewable
:
700 if (write_symbols
== NO_DEBUG
)
701 post_error ("must specify -g?", gnat_node
);
706 /**************************************/
707 /* Chapter 3: Declarations and Types: */
708 /**************************************/
710 case N_Subtype_Declaration
:
711 case N_Full_Type_Declaration
:
712 case N_Incomplete_Type_Declaration
:
713 case N_Private_Type_Declaration
:
714 case N_Private_Extension_Declaration
:
715 case N_Task_Type_Declaration
:
716 process_type (Defining_Entity (gnat_node
));
719 case N_Object_Declaration
:
720 case N_Exception_Declaration
:
721 gnat_temp
= Defining_Entity (gnat_node
);
723 /* If we are just annotating types and this object has an unconstrained
724 or task type, don't elaborate it. */
725 if (type_annotate_only
726 && (((Is_Array_Type (Etype (gnat_temp
))
727 || Is_Record_Type (Etype (gnat_temp
)))
728 && ! Is_Constrained (Etype (gnat_temp
)))
729 || Is_Concurrent_Type (Etype (gnat_temp
))))
732 if (Present (Expression (gnat_node
))
733 && ! (Nkind (gnat_node
) == N_Object_Declaration
734 && No_Initialization (gnat_node
))
735 && (! type_annotate_only
736 || Compile_Time_Known_Value (Expression (gnat_node
))))
738 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
739 if (Do_Range_Check (Expression (gnat_node
)))
740 gnu_expr
= emit_range_check (gnu_expr
, Etype (gnat_temp
));
742 /* If this object has its elaboration delayed, we must force
743 evaluation of GNU_EXPR right now and save it for when the object
745 if (Present (Freeze_Node (gnat_temp
)))
747 if ((Is_Public (gnat_temp
) || global_bindings_p ())
748 && ! TREE_CONSTANT (gnu_expr
))
750 = create_var_decl (create_concat_name (gnat_temp
, "init"),
751 NULL_TREE
, TREE_TYPE (gnu_expr
), gnu_expr
,
752 0, Is_Public (gnat_temp
), 0, 0, 0);
754 gnu_expr
= maybe_variable (gnu_expr
, Expression (gnat_node
));
756 save_gnu_tree (gnat_node
, gnu_expr
, 1);
762 if (type_annotate_only
&& gnu_expr
!= 0
763 && TREE_CODE (gnu_expr
) == ERROR_MARK
)
766 if (No (Freeze_Node (gnat_temp
)))
767 gnat_to_gnu_entity (gnat_temp
, gnu_expr
, 1);
770 case N_Object_Renaming_Declaration
:
772 gnat_temp
= Defining_Entity (gnat_node
);
774 /* Don't do anything if this renaming is handled by the front end.
775 or if we are just annotating types and this object has a
776 composite or task type, don't elaborate it. */
777 if (! Is_Renaming_Of_Object (gnat_temp
)
778 && ! (type_annotate_only
779 && (Is_Array_Type (Etype (gnat_temp
))
780 || Is_Record_Type (Etype (gnat_temp
))
781 || Is_Concurrent_Type (Etype (gnat_temp
)))))
783 gnu_expr
= gnat_to_gnu (Renamed_Object (gnat_temp
));
784 gnat_to_gnu_entity (gnat_temp
, gnu_expr
, 1);
788 case N_Implicit_Label_Declaration
:
789 gnat_to_gnu_entity (Defining_Entity (gnat_node
), NULL_TREE
, 1);
792 case N_Subprogram_Renaming_Declaration
:
793 case N_Package_Renaming_Declaration
:
794 case N_Exception_Renaming_Declaration
:
795 case N_Number_Declaration
:
796 /* These are fully handled in the front end. */
799 /*************************************/
800 /* Chapter 4: Names and Expressions: */
801 /*************************************/
803 case N_Explicit_Dereference
:
804 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
805 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
807 /* Emit access check if necessary */
808 if (Do_Access_Check (gnat_node
))
809 gnu_result
= emit_access_check (gnu_result
);
811 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_result
);
814 case N_Indexed_Component
:
816 tree gnu_array_object
= gnat_to_gnu (Prefix (gnat_node
));
820 Node_Id
*gnat_expr_array
;
822 /* Emit access check if necessary */
823 if (Do_Access_Check (gnat_node
))
824 gnu_array_object
= emit_access_check (gnu_array_object
);
826 gnu_array_object
= maybe_implicit_deref (gnu_array_object
);
827 gnu_array_object
= maybe_unconstrained_array (gnu_array_object
);
829 /* If we got a padded type, remove it too. */
830 if (TREE_CODE (TREE_TYPE (gnu_array_object
)) == RECORD_TYPE
831 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object
)))
833 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object
))),
836 gnu_result
= gnu_array_object
;
838 /* First compute the number of dimensions of the array, then
839 fill the expression array, the order depending on whether
840 this is a Convention_Fortran array or not. */
841 for (ndim
= 1, gnu_type
= TREE_TYPE (gnu_array_object
);
842 TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
843 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
));
844 ndim
++, gnu_type
= TREE_TYPE (gnu_type
))
847 gnat_expr_array
= (Node_Id
*) alloca (ndim
* sizeof (Node_Id
));
849 if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object
)))
850 for (i
= ndim
- 1, gnat_temp
= First (Expressions (gnat_node
));
852 i
--, gnat_temp
= Next (gnat_temp
))
853 gnat_expr_array
[i
] = gnat_temp
;
855 for (i
= 0, gnat_temp
= First (Expressions (gnat_node
));
857 i
++, gnat_temp
= Next (gnat_temp
))
858 gnat_expr_array
[i
] = gnat_temp
;
860 for (i
= 0, gnu_type
= TREE_TYPE (gnu_array_object
);
861 i
< ndim
; i
++, gnu_type
= TREE_TYPE (gnu_type
))
863 if (TREE_CODE (gnu_type
) != ARRAY_TYPE
)
866 gnat_temp
= gnat_expr_array
[i
];
867 gnu_expr
= gnat_to_gnu (gnat_temp
);
869 if (Do_Range_Check (gnat_temp
))
872 (gnu_array_object
, gnu_expr
,
873 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))),
874 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))));
876 gnu_result
= build_binary_op (ARRAY_REF
, NULL_TREE
,
877 gnu_result
, gnu_expr
);
881 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
887 Node_Id gnat_range_node
= Discrete_Range (gnat_node
);
889 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
890 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
892 /* Emit access check if necessary */
893 if (Do_Access_Check (gnat_node
))
894 gnu_result
= emit_access_check (gnu_result
);
896 /* Do any implicit dereferences of the prefix and do any needed
898 gnu_result
= maybe_implicit_deref (gnu_result
);
899 gnu_result
= maybe_unconstrained_array (gnu_result
);
900 gnu_type
= TREE_TYPE (gnu_result
);
901 if (Do_Range_Check (gnat_range_node
))
903 /* Get the bounds of the slice. */
905 = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_result_type
));
906 tree gnu_min_expr
= TYPE_MIN_VALUE (gnu_index_type
);
907 tree gnu_max_expr
= TYPE_MAX_VALUE (gnu_index_type
);
908 tree gnu_expr_l
, gnu_expr_h
, gnu_expr_type
;
910 /* Check to see that the minimum slice value is in range */
913 (gnu_result
, gnu_min_expr
,
914 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))),
915 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))));
917 /* Check to see that the maximum slice value is in range */
920 (gnu_result
, gnu_max_expr
,
921 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))),
922 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))));
924 /* Derive a good type to convert everything too */
925 gnu_expr_type
= get_base_type (TREE_TYPE (gnu_expr_l
));
927 /* Build a compound expression that does the range checks */
929 = build_binary_op (COMPOUND_EXPR
, gnu_expr_type
,
930 convert (gnu_expr_type
, gnu_expr_h
),
931 convert (gnu_expr_type
, gnu_expr_l
));
933 /* Build a conditional expression that returns the range checks
934 expression if the slice range is not null (max >= min) or
935 returns the min if the slice range is null */
937 = fold (build (COND_EXPR
, gnu_expr_type
,
938 build_binary_op (GE_EXPR
, gnu_expr_type
,
939 convert (gnu_expr_type
,
941 convert (gnu_expr_type
,
943 gnu_expr
, gnu_min_expr
));
946 gnu_expr
= TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type
));
948 gnu_result
= build_binary_op (ARRAY_RANGE_REF
, gnu_result_type
,
949 gnu_result
, gnu_expr
);
953 case N_Selected_Component
:
955 tree gnu_prefix
= gnat_to_gnu (Prefix (gnat_node
));
956 Entity_Id gnat_field
= Entity (Selector_Name (gnat_node
));
957 Entity_Id gnat_pref_type
= Etype (Prefix (gnat_node
));
960 while (IN (Ekind (gnat_pref_type
), Incomplete_Or_Private_Kind
)
961 || IN (Ekind (gnat_pref_type
), Access_Kind
))
963 if (IN (Ekind (gnat_pref_type
), Incomplete_Or_Private_Kind
))
964 gnat_pref_type
= Underlying_Type (gnat_pref_type
);
965 else if (IN (Ekind (gnat_pref_type
), Access_Kind
))
966 gnat_pref_type
= Designated_Type (gnat_pref_type
);
969 if (Do_Access_Check (gnat_node
))
970 gnu_prefix
= emit_access_check (gnu_prefix
);
972 gnu_prefix
= maybe_implicit_deref (gnu_prefix
);
974 /* For discriminant references in tagged types always substitute the
975 corresponding discriminant as the actual selected component. */
977 if (Is_Tagged_Type (gnat_pref_type
))
978 while (Present (Corresponding_Discriminant (gnat_field
)))
979 gnat_field
= Corresponding_Discriminant (gnat_field
);
981 /* For discriminant references of untagged types always substitute the
982 corresponding girder discriminant. */
984 else if (Present (Corresponding_Discriminant (gnat_field
)))
985 gnat_field
= Original_Record_Component (gnat_field
);
987 /* Handle extracting the real or imaginary part of a complex.
988 The real part is the first field and the imaginary the last. */
990 if (TREE_CODE (TREE_TYPE (gnu_prefix
)) == COMPLEX_TYPE
)
991 gnu_result
= build_unary_op (Present (Next_Entity (gnat_field
))
992 ? REALPART_EXPR
: IMAGPART_EXPR
,
993 NULL_TREE
, gnu_prefix
);
996 gnu_field
= gnat_to_gnu_entity (gnat_field
, NULL_TREE
, 0);
998 /* If there are discriminants, the prefix might be
999 evaluated more than once, which is a problem if it has
1001 if (Has_Discriminants (Is_Access_Type (Etype (Prefix (gnat_node
)))
1002 ? Designated_Type (Etype
1003 (Prefix (gnat_node
)))
1004 : Etype (Prefix (gnat_node
))))
1005 gnu_prefix
= gnat_stabilize_reference (gnu_prefix
, 0);
1007 /* Emit discriminant check if necessary. */
1008 if (Do_Discriminant_Check (gnat_node
))
1009 gnu_prefix
= emit_discriminant_check (gnu_prefix
, gnat_node
);
1011 = build_component_ref (gnu_prefix
, NULL_TREE
, gnu_field
);
1014 if (gnu_result
== 0)
1017 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1021 case N_Attribute_Reference
:
1023 /* The attribute designator (like an enumeration value). */
1024 int attribute
= Get_Attribute_Id (Attribute_Name (gnat_node
));
1025 int prefix_unused
= 0;
1029 /* The Elab_Spec and Elab_Body attributes are special in that
1030 Prefix is a unit, not an object with a GCC equivalent. Similarly
1031 for Elaborated, since that variable isn't otherwise known. */
1032 if (attribute
== Attr_Elab_Body
|| attribute
== Attr_Elab_Spec
)
1035 = create_subprog_decl
1036 (create_concat_name (Entity (Prefix (gnat_node
)),
1037 attribute
== Attr_Elab_Body
1038 ? "elabb" : "elabs"),
1039 NULL_TREE
, void_ftype
, NULL_TREE
, 0, 1, 1, 0);
1043 gnu_prefix
= gnat_to_gnu (Prefix (gnat_node
));
1044 gnu_type
= TREE_TYPE (gnu_prefix
);
1046 /* If the input is a NULL_EXPR, make a new one. */
1047 if (TREE_CODE (gnu_prefix
) == NULL_EXPR
)
1049 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1050 gnu_result
= build1 (NULL_EXPR
, gnu_result_type
,
1051 TREE_OPERAND (gnu_prefix
, 0));
1059 /* These are just conversions until since representation
1060 clauses for enumerations are handled in the front end. */
1062 int check_p
= Do_Range_Check (First (Expressions (gnat_node
)));
1064 gnu_result
= gnat_to_gnu (First (Expressions (gnat_node
)));
1065 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1066 gnu_result
= convert_with_check (Etype (gnat_node
), gnu_result
,
1067 check_p
, check_p
, 1);
1073 /* These just add or subject the constant 1. Representation
1074 clauses for enumerations are handled in the front-end. */
1075 gnu_expr
= gnat_to_gnu (First (Expressions (gnat_node
)));
1076 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1078 if (Do_Range_Check (First (Expressions (gnat_node
))))
1080 gnu_expr
= protect_multiple_eval (gnu_expr
);
1083 (build_binary_op (EQ_EXPR
, integer_type_node
,
1085 attribute
== Attr_Pred
1086 ? TYPE_MIN_VALUE (gnu_result_type
)
1087 : TYPE_MAX_VALUE (gnu_result_type
)),
1088 gnu_expr
, CE_Range_Check_Failed
);
1092 = build_binary_op (attribute
== Attr_Pred
1093 ? MINUS_EXPR
: PLUS_EXPR
,
1094 gnu_result_type
, gnu_expr
,
1095 convert (gnu_result_type
, integer_one_node
));
1099 case Attr_Unrestricted_Access
:
1101 /* Conversions don't change something's address but can cause
1102 us to miss the COMPONENT_REF case below, so strip them off. */
1104 = remove_conversions (gnu_prefix
,
1105 ! Must_Be_Byte_Aligned (gnat_node
));
1107 /* If we are taking 'Address of an unconstrained object,
1108 this is the pointer to the underlying array. */
1109 gnu_prefix
= maybe_unconstrained_array (gnu_prefix
);
1111 /* ... fall through ... */
1114 case Attr_Unchecked_Access
:
1115 case Attr_Code_Address
:
1117 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1119 = build_unary_op (((attribute
== Attr_Address
1120 || attribute
== Attr_Unrestricted_Access
)
1121 && ! Must_Be_Byte_Aligned (gnat_node
))
1122 ? ATTR_ADDR_EXPR
: ADDR_EXPR
,
1123 gnu_result_type
, gnu_prefix
);
1125 /* For 'Code_Address, find an inner ADDR_EXPR and mark it
1126 so that we don't try to build a trampoline. */
1127 if (attribute
== Attr_Code_Address
)
1129 for (gnu_expr
= gnu_result
;
1130 TREE_CODE (gnu_expr
) == NOP_EXPR
1131 || TREE_CODE (gnu_expr
) == CONVERT_EXPR
;
1132 gnu_expr
= TREE_OPERAND (gnu_expr
, 0))
1133 TREE_CONSTANT (gnu_expr
) = 1;
1136 if (TREE_CODE (gnu_expr
) == ADDR_EXPR
)
1137 TREE_STATIC (gnu_expr
) = TREE_CONSTANT (gnu_expr
) = 1;
1143 case Attr_Object_Size
:
1144 case Attr_Value_Size
:
1145 case Attr_Max_Size_In_Storage_Elements
:
1147 gnu_expr
= gnu_prefix
;
1149 /* Remove NOPS from gnu_expr and conversions from gnu_prefix.
1150 We only use GNU_EXPR to see if a COMPONENT_REF was involved. */
1151 while (TREE_CODE (gnu_expr
) == NOP_EXPR
)
1152 gnu_expr
= TREE_OPERAND (gnu_expr
, 0);
1154 gnu_prefix
= remove_conversions (gnu_prefix
, 1);
1156 gnu_type
= TREE_TYPE (gnu_prefix
);
1158 /* Replace an unconstrained array type with the type of the
1159 underlying array. We can't do this with a call to
1160 maybe_unconstrained_array since we may have a TYPE_DECL.
1161 For 'Max_Size_In_Storage_Elements, use the record type
1162 that will be used to allocate the object and its template. */
1164 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
1166 gnu_type
= TYPE_OBJECT_RECORD_TYPE (gnu_type
);
1167 if (attribute
!= Attr_Max_Size_In_Storage_Elements
)
1168 gnu_type
= TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type
)));
1171 /* If we are looking for the size of a field, return the
1172 field size. Otherwise, if the prefix is an object,
1173 or if 'Object_Size or 'Max_Size_In_Storage_Elements has
1174 been specified, the result is the GCC size of the type.
1175 Otherwise, the result is the RM_Size of the type. */
1176 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
1177 gnu_result
= DECL_SIZE (TREE_OPERAND (gnu_prefix
, 1));
1178 else if (TREE_CODE (gnu_prefix
) != TYPE_DECL
1179 || attribute
== Attr_Object_Size
1180 || attribute
== Attr_Max_Size_In_Storage_Elements
)
1182 /* If this is a padded type, the GCC size isn't relevant
1183 to the programmer. Normally, what we want is the RM_Size,
1184 which was set from the specified size, but if it was not
1185 set, we want the size of the relevant field. Using the MAX
1186 of those two produces the right result in all case. Don't
1187 use the size of the field if it's a self-referential type,
1188 since that's never what's wanted. */
1189 if (TREE_CODE (gnu_type
) == RECORD_TYPE
1190 && TYPE_IS_PADDING_P (gnu_type
)
1191 && TREE_CODE (gnu_expr
) == COMPONENT_REF
)
1193 gnu_result
= rm_size (gnu_type
);
1194 if (! (contains_placeholder_p
1195 (DECL_SIZE (TREE_OPERAND (gnu_expr
, 1)))))
1197 = size_binop (MAX_EXPR
, gnu_result
,
1198 DECL_SIZE (TREE_OPERAND (gnu_expr
, 1)));
1201 gnu_result
= TYPE_SIZE (gnu_type
);
1204 gnu_result
= rm_size (gnu_type
);
1206 if (gnu_result
== 0)
1209 /* Deal with a self-referential size by returning the maximum
1210 size for a type and by qualifying the size with
1211 the object for 'Size of an object. */
1213 if (TREE_CODE (gnu_result
) != INTEGER_CST
1214 && contains_placeholder_p (gnu_result
))
1216 if (TREE_CODE (gnu_prefix
) != TYPE_DECL
)
1217 gnu_result
= build (WITH_RECORD_EXPR
, TREE_TYPE (gnu_result
),
1218 gnu_result
, gnu_prefix
);
1220 gnu_result
= max_size (gnu_result
, 1);
1223 /* If the type contains a template, subtract the size of the
1225 if (TREE_CODE (gnu_type
) == RECORD_TYPE
1226 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
1227 gnu_result
= size_binop (MINUS_EXPR
, gnu_result
,
1228 DECL_SIZE (TYPE_FIELDS (gnu_type
)));
1230 /* If the type contains a template, subtract the size of the
1232 if (TREE_CODE (gnu_type
) == RECORD_TYPE
1233 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
1234 gnu_result
= size_binop (MINUS_EXPR
, gnu_result
,
1235 DECL_SIZE (TYPE_FIELDS (gnu_type
)));
1237 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1239 /* Always perform division using unsigned arithmetic as the
1240 size cannot be negative, but may be an overflowed positive
1241 value. This provides correct results for sizes up to 512 MB.
1242 ??? Size should be calculated in storage elements directly. */
1244 if (attribute
== Attr_Max_Size_In_Storage_Elements
)
1245 gnu_result
= convert (sizetype
,
1246 fold (build (CEIL_DIV_EXPR
, bitsizetype
,
1248 bitsize_unit_node
)));
1251 case Attr_Alignment
:
1252 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
1253 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))
1255 && (TYPE_IS_PADDING_P
1256 (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))))
1257 gnu_prefix
= TREE_OPERAND (gnu_prefix
, 0);
1259 gnu_type
= TREE_TYPE (gnu_prefix
);
1260 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1263 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
1265 = size_int (DECL_ALIGN (TREE_OPERAND (gnu_prefix
, 1)));
1267 gnu_result
= size_int (TYPE_ALIGN (gnu_type
) / BITS_PER_UNIT
);
1272 case Attr_Range_Length
:
1275 if (INTEGRAL_TYPE_P (gnu_type
)
1276 || TREE_CODE (gnu_type
) == REAL_TYPE
)
1278 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1280 if (attribute
== Attr_First
)
1281 gnu_result
= TYPE_MIN_VALUE (gnu_type
);
1282 else if (attribute
== Attr_Last
)
1283 gnu_result
= TYPE_MAX_VALUE (gnu_type
);
1287 (MAX_EXPR
, get_base_type (gnu_result_type
),
1289 (PLUS_EXPR
, get_base_type (gnu_result_type
),
1290 build_binary_op (MINUS_EXPR
,
1291 get_base_type (gnu_result_type
),
1292 convert (gnu_result_type
,
1293 TYPE_MAX_VALUE (gnu_type
)),
1294 convert (gnu_result_type
,
1295 TYPE_MIN_VALUE (gnu_type
))),
1296 convert (gnu_result_type
, integer_one_node
)),
1297 convert (gnu_result_type
, integer_zero_node
));
1301 /* ... fall through ... */
1305 = (Present (Expressions (gnat_node
))
1306 ? UI_To_Int (Intval (First (Expressions (gnat_node
))))
1309 /* Emit access check if necessary */
1310 if (Do_Access_Check (gnat_node
))
1311 gnu_prefix
= emit_access_check (gnu_prefix
);
1313 /* Make sure any implicit dereference gets done. */
1314 gnu_prefix
= maybe_implicit_deref (gnu_prefix
);
1315 gnu_prefix
= maybe_unconstrained_array (gnu_prefix
);
1316 gnu_type
= TREE_TYPE (gnu_prefix
);
1318 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1320 if (TYPE_CONVENTION_FORTRAN_P (gnu_type
))
1325 for (ndim
= 1, gnu_type_temp
= gnu_type
;
1326 TREE_CODE (TREE_TYPE (gnu_type_temp
)) == ARRAY_TYPE
1327 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp
));
1328 ndim
++, gnu_type_temp
= TREE_TYPE (gnu_type_temp
))
1331 Dimension
= ndim
+ 1 - Dimension
;
1334 for (; Dimension
> 1; Dimension
--)
1335 gnu_type
= TREE_TYPE (gnu_type
);
1337 if (TREE_CODE (gnu_type
) != ARRAY_TYPE
)
1340 if (attribute
== Attr_First
)
1342 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)));
1343 else if (attribute
== Attr_Last
)
1345 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)));
1347 /* 'Length or 'Range_Length. */
1349 tree gnu_compute_type
1350 = gnat_signed_or_unsigned_type
1351 (0, get_base_type (gnu_result_type
));
1355 (MAX_EXPR
, gnu_compute_type
,
1357 (PLUS_EXPR
, gnu_compute_type
,
1359 (MINUS_EXPR
, gnu_compute_type
,
1360 convert (gnu_compute_type
,
1362 (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)))),
1363 convert (gnu_compute_type
,
1365 (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))))),
1366 convert (gnu_compute_type
, integer_one_node
)),
1367 convert (gnu_compute_type
, integer_zero_node
));
1370 /* If this has a PLACEHOLDER_EXPR, qualify it by the object
1371 we are handling. Note that these attributes could not
1372 have been used on an unconstrained array type. */
1373 if (TREE_CODE (gnu_result
) != INTEGER_CST
1374 && contains_placeholder_p (gnu_result
))
1375 gnu_result
= build (WITH_RECORD_EXPR
, TREE_TYPE (gnu_result
),
1376 gnu_result
, gnu_prefix
);
1381 case Attr_Bit_Position
:
1383 case Attr_First_Bit
:
1387 HOST_WIDE_INT bitsize
;
1388 HOST_WIDE_INT bitpos
;
1390 tree gnu_field_bitpos
;
1391 tree gnu_field_offset
;
1393 enum machine_mode mode
;
1394 int unsignedp
, volatilep
;
1396 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1397 gnu_prefix
= remove_conversions (gnu_prefix
, 1);
1400 /* We can have 'Bit on any object, but if it isn't a
1401 COMPONENT_REF, the result is zero. Do not allow
1402 'Bit on a bare component, though. */
1403 if (attribute
== Attr_Bit
1404 && TREE_CODE (gnu_prefix
) != COMPONENT_REF
1405 && TREE_CODE (gnu_prefix
) != FIELD_DECL
)
1407 gnu_result
= integer_zero_node
;
1411 else if (TREE_CODE (gnu_prefix
) != COMPONENT_REF
1412 && ! (attribute
== Attr_Bit_Position
1413 && TREE_CODE (gnu_prefix
) == FIELD_DECL
))
1416 get_inner_reference (gnu_prefix
, &bitsize
, &bitpos
, &gnu_offset
,
1417 &mode
, &unsignedp
, &volatilep
);
1419 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
1422 = bit_position (TREE_OPERAND (gnu_prefix
, 1));
1424 = byte_position (TREE_OPERAND (gnu_prefix
, 1));
1426 for (gnu_inner
= TREE_OPERAND (gnu_prefix
, 0);
1427 TREE_CODE (gnu_inner
) == COMPONENT_REF
1428 && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner
, 1));
1429 gnu_inner
= TREE_OPERAND (gnu_inner
, 0))
1432 = size_binop (PLUS_EXPR
, gnu_field_bitpos
,
1433 bit_position (TREE_OPERAND (gnu_inner
,
1436 = size_binop (PLUS_EXPR
, gnu_field_offset
,
1437 byte_position (TREE_OPERAND (gnu_inner
,
1441 else if (TREE_CODE (gnu_prefix
) == FIELD_DECL
)
1443 gnu_field_bitpos
= bit_position (gnu_prefix
);
1444 gnu_field_offset
= byte_position (gnu_prefix
);
1448 gnu_field_bitpos
= bitsize_zero_node
;
1449 gnu_field_offset
= size_zero_node
;
1455 gnu_result
= gnu_field_offset
;
1458 case Attr_First_Bit
:
1460 gnu_result
= size_int (bitpos
% BITS_PER_UNIT
);
1464 gnu_result
= bitsize_int (bitpos
% BITS_PER_UNIT
);
1466 = size_binop (PLUS_EXPR
, gnu_result
,
1467 TYPE_SIZE (TREE_TYPE (gnu_prefix
)));
1468 gnu_result
= size_binop (MINUS_EXPR
, gnu_result
,
1472 case Attr_Bit_Position
:
1473 gnu_result
= gnu_field_bitpos
;
1477 /* If this has a PLACEHOLDER_EXPR, qualify it by the object
1479 if (TREE_CODE (gnu_result
) != INTEGER_CST
1480 && contains_placeholder_p (gnu_result
))
1481 gnu_result
= build (WITH_RECORD_EXPR
, TREE_TYPE (gnu_result
),
1482 gnu_result
, gnu_prefix
);
1489 gnu_lhs
= gnat_to_gnu (First (Expressions (gnat_node
)));
1490 gnu_rhs
= gnat_to_gnu (Next (First (Expressions (gnat_node
))));
1492 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1493 gnu_result
= build_binary_op (attribute
== Attr_Min
1494 ? MIN_EXPR
: MAX_EXPR
,
1495 gnu_result_type
, gnu_lhs
, gnu_rhs
);
1498 case Attr_Passed_By_Reference
:
1499 gnu_result
= size_int (default_pass_by_ref (gnu_type
)
1500 || must_pass_by_ref (gnu_type
));
1501 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1504 case Attr_Component_Size
:
1505 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
1506 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))
1508 && (TYPE_IS_PADDING_P
1509 (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))))
1510 gnu_prefix
= TREE_OPERAND (gnu_prefix
, 0);
1512 gnu_prefix
= maybe_implicit_deref (gnu_prefix
);
1513 gnu_type
= TREE_TYPE (gnu_prefix
);
1515 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
1517 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type
))));
1519 while (TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
1520 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
)))
1521 gnu_type
= TREE_TYPE (gnu_type
);
1523 if (TREE_CODE (gnu_type
) != ARRAY_TYPE
)
1526 /* Note this size cannot be self-referential. */
1527 gnu_result
= TYPE_SIZE (TREE_TYPE (gnu_type
));
1528 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1532 case Attr_Null_Parameter
:
1533 /* This is just a zero cast to the pointer type for
1534 our prefix and dereferenced. */
1535 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1537 = build_unary_op (INDIRECT_REF
, NULL_TREE
,
1538 convert (build_pointer_type (gnu_result_type
),
1539 integer_zero_node
));
1540 TREE_PRIVATE (gnu_result
) = 1;
1543 case Attr_Mechanism_Code
:
1546 Entity_Id gnat_obj
= Entity (Prefix (gnat_node
));
1549 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1550 if (Present (Expressions (gnat_node
)))
1552 int i
= UI_To_Int (Intval (First (Expressions (gnat_node
))));
1554 for (gnat_obj
= First_Formal (gnat_obj
); i
> 1;
1555 i
--, gnat_obj
= Next_Formal (gnat_obj
))
1559 code
= Mechanism (gnat_obj
);
1560 if (code
== Default
)
1561 code
= ((present_gnu_tree (gnat_obj
)
1562 && (DECL_BY_REF_P (get_gnu_tree (gnat_obj
))
1563 || (DECL_BY_COMPONENT_PTR_P
1564 (get_gnu_tree (gnat_obj
)))))
1565 ? By_Reference
: By_Copy
);
1566 gnu_result
= convert (gnu_result_type
, size_int (- code
));
1571 /* Say we have an unimplemented attribute. Then set the
1572 value to be returned to be a zero and hope that's something
1573 we can convert to the type of this attribute. */
1575 post_error ("unimplemented attribute", gnat_node
);
1576 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1577 gnu_result
= integer_zero_node
;
1581 /* If this is an attribute where the prefix was unused,
1582 force a use of it if it has a side-effect. But don't do it if
1583 the prefix is just an entity name. However, if an access check
1584 is needed, we must do it. See second example in AARM 11.6(5.e). */
1585 if (prefix_unused
&& TREE_SIDE_EFFECTS (gnu_prefix
)
1586 && (! Is_Entity_Name (Prefix (gnat_node
))
1587 || Do_Access_Check (gnat_node
)))
1588 gnu_result
= fold (build (COMPOUND_EXPR
, TREE_TYPE (gnu_result
),
1589 gnu_prefix
, gnu_result
));
1594 /* Like 'Access as far as we are concerned. */
1595 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
1596 gnu_result
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_result
);
1597 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1601 case N_Extension_Aggregate
:
1605 /* ??? It is wrong to evaluate the type now, but there doesn't
1606 seem to be any other practical way of doing it. */
1608 gnu_aggr_type
= gnu_result_type
1609 = get_unpadded_type (Etype (gnat_node
));
1611 if (TREE_CODE (gnu_result_type
) == RECORD_TYPE
1612 && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type
))
1614 = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_result_type
)));
1616 if (Null_Record_Present (gnat_node
))
1617 gnu_result
= gnat_build_constructor (gnu_aggr_type
, NULL_TREE
);
1619 else if (TREE_CODE (gnu_aggr_type
) == RECORD_TYPE
)
1621 = assoc_to_constructor (First (Component_Associations (gnat_node
)),
1623 else if (TREE_CODE (gnu_aggr_type
) == UNION_TYPE
)
1625 /* The first element is the discrimant, which we ignore. The
1626 next is the field we're building. Convert the expression
1627 to the type of the field and then to the union type. */
1629 = Next (First (Component_Associations (gnat_node
)));
1630 Entity_Id gnat_field
= Entity (First (Choices (gnat_assoc
)));
1632 = TREE_TYPE (gnat_to_gnu_entity (gnat_field
, NULL_TREE
, 0));
1634 gnu_result
= convert (gnu_field_type
,
1635 gnat_to_gnu (Expression (gnat_assoc
)));
1637 else if (TREE_CODE (gnu_aggr_type
) == ARRAY_TYPE
)
1638 gnu_result
= pos_to_constructor (First (Expressions (gnat_node
)),
1640 Component_Type (Etype (gnat_node
)));
1641 else if (TREE_CODE (gnu_aggr_type
) == COMPLEX_TYPE
)
1644 (COMPLEX_EXPR
, gnu_aggr_type
,
1645 gnat_to_gnu (Expression (First
1646 (Component_Associations (gnat_node
)))),
1647 gnat_to_gnu (Expression
1649 (First (Component_Associations (gnat_node
))))));
1653 gnu_result
= convert (gnu_result_type
, gnu_result
);
1658 gnu_result
= null_pointer_node
;
1659 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1662 case N_Type_Conversion
:
1663 case N_Qualified_Expression
:
1664 /* Get the operand expression. */
1665 gnu_result
= gnat_to_gnu (Expression (gnat_node
));
1666 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1669 = convert_with_check (Etype (gnat_node
), gnu_result
,
1670 Do_Overflow_Check (gnat_node
),
1671 Do_Range_Check (Expression (gnat_node
)),
1672 Nkind (gnat_node
) == N_Type_Conversion
1673 && Float_Truncate (gnat_node
));
1676 case N_Unchecked_Type_Conversion
:
1677 gnu_result
= gnat_to_gnu (Expression (gnat_node
));
1678 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1680 /* If the result is a pointer type, see if we are improperly
1681 converting to a stricter alignment. */
1683 if (STRICT_ALIGNMENT
&& POINTER_TYPE_P (gnu_result_type
)
1684 && IN (Ekind (Etype (gnat_node
)), Access_Kind
))
1686 unsigned int align
= known_alignment (gnu_result
);
1687 tree gnu_obj_type
= TREE_TYPE (gnu_result_type
);
1689 = TREE_CODE (gnu_obj_type
) == FUNCTION_TYPE
1690 ? FUNCTION_BOUNDARY
: TYPE_ALIGN (gnu_obj_type
);
1692 if (align
!= 0 && align
< oalign
&& ! TYPE_ALIGN_OK (gnu_obj_type
))
1693 post_error_ne_tree_2
1694 ("?source alignment (^) < alignment of & (^)",
1695 gnat_node
, Designated_Type (Etype (gnat_node
)),
1696 size_int (align
/ BITS_PER_UNIT
), oalign
/ BITS_PER_UNIT
);
1699 gnu_result
= unchecked_convert (gnu_result_type
, gnu_result
);
1705 tree gnu_object
= gnat_to_gnu (Left_Opnd (gnat_node
));
1706 Node_Id gnat_range
= Right_Opnd (gnat_node
);
1710 /* GNAT_RANGE is either an N_Range node or an identifier
1711 denoting a subtype. */
1712 if (Nkind (gnat_range
) == N_Range
)
1714 gnu_low
= gnat_to_gnu (Low_Bound (gnat_range
));
1715 gnu_high
= gnat_to_gnu (High_Bound (gnat_range
));
1717 else if (Nkind (gnat_range
) == N_Identifier
1718 || Nkind (gnat_range
) == N_Expanded_Name
)
1720 tree gnu_range_type
= get_unpadded_type (Entity (gnat_range
));
1722 gnu_low
= TYPE_MIN_VALUE (gnu_range_type
);
1723 gnu_high
= TYPE_MAX_VALUE (gnu_range_type
);
1728 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1730 /* If LOW and HIGH are identical, perform an equality test.
1731 Otherwise, ensure that GNU_OBJECT is only evaluated once
1732 and perform a full range test. */
1733 if (operand_equal_p (gnu_low
, gnu_high
, 0))
1734 gnu_result
= build_binary_op (EQ_EXPR
, gnu_result_type
,
1735 gnu_object
, gnu_low
);
1738 gnu_object
= protect_multiple_eval (gnu_object
);
1740 = build_binary_op (TRUTH_ANDIF_EXPR
, gnu_result_type
,
1741 build_binary_op (GE_EXPR
, gnu_result_type
,
1742 gnu_object
, gnu_low
),
1743 build_binary_op (LE_EXPR
, gnu_result_type
,
1744 gnu_object
, gnu_high
));
1747 if (Nkind (gnat_node
) == N_Not_In
)
1748 gnu_result
= invert_truthvalue (gnu_result
);
1753 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
1754 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
1755 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1756 gnu_result
= build_binary_op (FLOAT_TYPE_P (gnu_result_type
)
1758 : (Rounded_Result (gnat_node
)
1759 ? ROUND_DIV_EXPR
: TRUNC_DIV_EXPR
),
1760 gnu_result_type
, gnu_lhs
, gnu_rhs
);
1763 case N_And_Then
: case N_Or_Else
:
1765 enum tree_code code
= gnu_codes
[Nkind (gnat_node
)];
1768 /* The elaboration of the RHS may generate code. If so,
1769 we need to make sure it gets executed after the LHS. */
1770 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
1772 gnu_rhs_side
= expand_start_stmt_expr (/*has_scope=*/1);
1773 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
1774 expand_end_stmt_expr (gnu_rhs_side
);
1775 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1777 if (RTL_EXPR_SEQUENCE (gnu_rhs_side
) != 0)
1778 gnu_rhs
= build (COMPOUND_EXPR
, gnu_result_type
, gnu_rhs_side
,
1781 gnu_result
= build_binary_op (code
, gnu_result_type
, gnu_lhs
, gnu_rhs
);
1785 case N_Op_Or
: case N_Op_And
: case N_Op_Xor
:
1786 /* These can either be operations on booleans or on modular types.
1787 Fall through for boolean types since that's the way GNU_CODES is
1789 if (IN (Ekind (Underlying_Type (Etype (gnat_node
))),
1790 Modular_Integer_Kind
))
1793 = (Nkind (gnat_node
) == N_Op_Or
? BIT_IOR_EXPR
1794 : Nkind (gnat_node
) == N_Op_And
? BIT_AND_EXPR
1797 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
1798 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
1799 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1800 gnu_result
= build_binary_op (code
, gnu_result_type
,
1805 /* ... fall through ... */
1807 case N_Op_Eq
: case N_Op_Ne
: case N_Op_Lt
:
1808 case N_Op_Le
: case N_Op_Gt
: case N_Op_Ge
:
1809 case N_Op_Add
: case N_Op_Subtract
: case N_Op_Multiply
:
1810 case N_Op_Mod
: case N_Op_Rem
:
1811 case N_Op_Rotate_Left
:
1812 case N_Op_Rotate_Right
:
1813 case N_Op_Shift_Left
:
1814 case N_Op_Shift_Right
:
1815 case N_Op_Shift_Right_Arithmetic
:
1817 enum tree_code code
= gnu_codes
[Nkind (gnat_node
)];
1820 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
1821 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
1822 gnu_type
= gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1824 /* If this is a comparison operator, convert any references to
1825 an unconstrained array value into a reference to the
1827 if (TREE_CODE_CLASS (code
) == '<')
1829 gnu_lhs
= maybe_unconstrained_array (gnu_lhs
);
1830 gnu_rhs
= maybe_unconstrained_array (gnu_rhs
);
1833 /* If the result type is a private type, its full view may be a
1834 numeric subtype. The representation we need is that of its base
1835 type, given that it is the result of an arithmetic operation. */
1836 else if (Is_Private_Type (Etype (gnat_node
)))
1837 gnu_type
= gnu_result_type
1838 = get_unpadded_type (Base_Type (Full_View (Etype (gnat_node
))));
1840 /* If this is a shift whose count is not guaranteed to be correct,
1841 we need to adjust the shift count. */
1842 if (IN (Nkind (gnat_node
), N_Op_Shift
)
1843 && ! Shift_Count_OK (gnat_node
))
1845 tree gnu_count_type
= get_base_type (TREE_TYPE (gnu_rhs
));
1847 = convert (gnu_count_type
, TYPE_SIZE (gnu_type
));
1849 if (Nkind (gnat_node
) == N_Op_Rotate_Left
1850 || Nkind (gnat_node
) == N_Op_Rotate_Right
)
1851 gnu_rhs
= build_binary_op (TRUNC_MOD_EXPR
, gnu_count_type
,
1852 gnu_rhs
, gnu_max_shift
);
1853 else if (Nkind (gnat_node
) == N_Op_Shift_Right_Arithmetic
)
1856 (MIN_EXPR
, gnu_count_type
,
1857 build_binary_op (MINUS_EXPR
,
1860 convert (gnu_count_type
,
1865 /* For right shifts, the type says what kind of shift to do,
1866 so we may need to choose a different type. */
1867 if (Nkind (gnat_node
) == N_Op_Shift_Right
1868 && ! TREE_UNSIGNED (gnu_type
))
1869 gnu_type
= gnat_unsigned_type (gnu_type
);
1870 else if (Nkind (gnat_node
) == N_Op_Shift_Right_Arithmetic
1871 && TREE_UNSIGNED (gnu_type
))
1872 gnu_type
= gnat_signed_type (gnu_type
);
1874 if (gnu_type
!= gnu_result_type
)
1876 gnu_lhs
= convert (gnu_type
, gnu_lhs
);
1877 gnu_rhs
= convert (gnu_type
, gnu_rhs
);
1880 gnu_result
= build_binary_op (code
, gnu_type
, gnu_lhs
, gnu_rhs
);
1882 /* If this is a logical shift with the shift count not verified,
1883 we must return zero if it is too large. We cannot compensate
1884 above in this case. */
1885 if ((Nkind (gnat_node
) == N_Op_Shift_Left
1886 || Nkind (gnat_node
) == N_Op_Shift_Right
)
1887 && ! Shift_Count_OK (gnat_node
))
1891 build_binary_op (GE_EXPR
, integer_type_node
,
1893 convert (TREE_TYPE (gnu_rhs
),
1894 TYPE_SIZE (gnu_type
))),
1895 convert (gnu_type
, integer_zero_node
),
1900 case N_Conditional_Expression
:
1902 tree gnu_cond
= gnat_to_gnu (First (Expressions (gnat_node
)));
1903 tree gnu_true
= gnat_to_gnu (Next (First (Expressions (gnat_node
))));
1905 = gnat_to_gnu (Next (Next (First (Expressions (gnat_node
)))));
1907 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1908 gnu_result
= build_cond_expr (gnu_result_type
,
1909 gnat_truthvalue_conversion (gnu_cond
),
1910 gnu_true
, gnu_false
);
1915 gnu_result
= gnat_to_gnu (Right_Opnd (gnat_node
));
1916 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1920 /* This case can apply to a boolean or a modular type.
1921 Fall through for a boolean operand since GNU_CODES is set
1922 up to handle this. */
1923 if (IN (Ekind (Etype (gnat_node
)), Modular_Integer_Kind
))
1925 gnu_expr
= gnat_to_gnu (Right_Opnd (gnat_node
));
1926 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1927 gnu_result
= build_unary_op (BIT_NOT_EXPR
, gnu_result_type
,
1932 /* ... fall through ... */
1934 case N_Op_Minus
: case N_Op_Abs
:
1935 gnu_expr
= gnat_to_gnu (Right_Opnd (gnat_node
));
1937 if (Ekind (Etype (gnat_node
)) != E_Private_Type
)
1938 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1940 gnu_result_type
= get_unpadded_type (Base_Type
1941 (Full_View (Etype (gnat_node
))));
1943 gnu_result
= build_unary_op (gnu_codes
[Nkind (gnat_node
)],
1944 gnu_result_type
, gnu_expr
);
1952 gnat_temp
= Expression (gnat_node
);
1954 /* The Expression operand can either be an N_Identifier or
1955 Expanded_Name, which must represent a type, or a
1956 N_Qualified_Expression, which contains both the object type and an
1957 initial value for the object. */
1958 if (Nkind (gnat_temp
) == N_Identifier
1959 || Nkind (gnat_temp
) == N_Expanded_Name
)
1960 gnu_type
= gnat_to_gnu_type (Entity (gnat_temp
));
1961 else if (Nkind (gnat_temp
) == N_Qualified_Expression
)
1963 Entity_Id gnat_desig_type
1964 = Designated_Type (Underlying_Type (Etype (gnat_node
)));
1966 gnu_init
= gnat_to_gnu (Expression (gnat_temp
));
1968 gnu_init
= maybe_unconstrained_array (gnu_init
);
1969 if (Do_Range_Check (Expression (gnat_temp
)))
1970 gnu_init
= emit_range_check (gnu_init
, gnat_desig_type
);
1972 if (Is_Elementary_Type (gnat_desig_type
)
1973 || Is_Constrained (gnat_desig_type
))
1975 gnu_type
= gnat_to_gnu_type (gnat_desig_type
);
1976 gnu_init
= convert (gnu_type
, gnu_init
);
1980 gnu_type
= gnat_to_gnu_type (Etype (Expression (gnat_temp
)));
1981 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
1982 gnu_type
= TREE_TYPE (gnu_init
);
1984 gnu_init
= convert (gnu_type
, gnu_init
);
1990 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1991 return build_allocator (gnu_type
, gnu_init
, gnu_result_type
,
1992 Procedure_To_Call (gnat_node
),
1993 Storage_Pool (gnat_node
));
1997 /***************************/
1998 /* Chapter 5: Statements: */
1999 /***************************/
2002 if (! type_annotate_only
)
2004 tree gnu_label
= gnat_to_gnu (Identifier (gnat_node
));
2005 Node_Id gnat_parent
= Parent (gnat_node
);
2007 expand_label (gnu_label
);
2009 /* If this is the first label of an exception handler, we must
2010 mark that any CALL_INSN can jump to it. */
2011 if (Present (gnat_parent
)
2012 && Nkind (gnat_parent
) == N_Exception_Handler
2013 && First (Statements (gnat_parent
)) == gnat_node
)
2014 nonlocal_goto_handler_labels
2015 = gen_rtx_EXPR_LIST (VOIDmode
, label_rtx (gnu_label
),
2016 nonlocal_goto_handler_labels
);
2020 case N_Null_Statement
:
2023 case N_Assignment_Statement
:
2024 if (type_annotate_only
)
2027 /* Get the LHS and RHS of the statement and convert any reference to an
2028 unconstrained array into a reference to the underlying array. */
2029 gnu_lhs
= maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node
)));
2031 = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node
)));
2033 set_lineno (gnat_node
, 1);
2035 /* If range check is needed, emit code to generate it */
2036 if (Do_Range_Check (Expression (gnat_node
)))
2037 gnu_rhs
= emit_range_check (gnu_rhs
, Etype (Name (gnat_node
)));
2039 /* If either side's type has a size that overflows, convert this
2040 into raise of Storage_Error: execution shouldn't have gotten
2042 if ((TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_lhs
))) == INTEGER_CST
2043 && TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_lhs
))))
2044 || (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_rhs
))) == INTEGER_CST
2045 && TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_rhs
)))))
2046 expand_expr_stmt (build_call_raise (SE_Object_Too_Large
));
2048 expand_expr_stmt (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
2052 case N_If_Statement
:
2053 /* Start an IF statement giving the condition. */
2054 gnu_expr
= gnat_to_gnu (Condition (gnat_node
));
2055 set_lineno (gnat_node
, 1);
2056 expand_start_cond (gnu_expr
, 0);
2058 /* Generate code for the statements to be executed if the condition
2061 for (gnat_temp
= First (Then_Statements (gnat_node
));
2062 Present (gnat_temp
);
2063 gnat_temp
= Next (gnat_temp
))
2064 gnat_to_code (gnat_temp
);
2066 /* Generate each of the "else if" parts. */
2067 if (Present (Elsif_Parts (gnat_node
)))
2069 for (gnat_temp
= First (Elsif_Parts (gnat_node
));
2070 Present (gnat_temp
);
2071 gnat_temp
= Next (gnat_temp
))
2073 Node_Id gnat_statement
;
2075 expand_start_else ();
2077 /* Set up the line numbers for each condition we test. */
2078 set_lineno (Condition (gnat_temp
), 1);
2079 expand_elseif (gnat_to_gnu (Condition (gnat_temp
)));
2081 for (gnat_statement
= First (Then_Statements (gnat_temp
));
2082 Present (gnat_statement
);
2083 gnat_statement
= Next (gnat_statement
))
2084 gnat_to_code (gnat_statement
);
2088 /* Finally, handle any statements in the "else" part. */
2089 if (Present (Else_Statements (gnat_node
)))
2091 expand_start_else ();
2093 for (gnat_temp
= First (Else_Statements (gnat_node
));
2094 Present (gnat_temp
);
2095 gnat_temp
= Next (gnat_temp
))
2096 gnat_to_code (gnat_temp
);
2102 case N_Case_Statement
:
2105 Node_Id gnat_choice
;
2107 Node_Id gnat_statement
;
2109 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
2110 gnu_expr
= convert (get_base_type (TREE_TYPE (gnu_expr
)), gnu_expr
);
2112 set_lineno (gnat_node
, 1);
2113 expand_start_case (1, gnu_expr
, TREE_TYPE (gnu_expr
), "case");
2115 for (gnat_when
= First_Non_Pragma (Alternatives (gnat_node
));
2116 Present (gnat_when
);
2117 gnat_when
= Next_Non_Pragma (gnat_when
))
2119 /* First compile all the different case choices for the current
2120 WHEN alternative. */
2122 for (gnat_choice
= First (Discrete_Choices (gnat_when
));
2123 Present (gnat_choice
); gnat_choice
= Next (gnat_choice
))
2127 gnu_label
= build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
);
2129 set_lineno (gnat_choice
, 1);
2130 switch (Nkind (gnat_choice
))
2133 /* Abort on all errors except range empty, which
2134 means we ignore this alternative. */
2136 = pushcase_range (gnat_to_gnu (Low_Bound (gnat_choice
)),
2137 gnat_to_gnu (High_Bound (gnat_choice
)),
2138 convert
, gnu_label
, 0);
2140 if (error_code
!= 0 && error_code
!= 4)
2144 case N_Subtype_Indication
:
2147 (gnat_to_gnu (Low_Bound (Range_Expression
2148 (Constraint (gnat_choice
)))),
2149 gnat_to_gnu (High_Bound (Range_Expression
2150 (Constraint (gnat_choice
)))),
2151 convert
, gnu_label
, 0);
2153 if (error_code
!= 0 && error_code
!= 4)
2158 case N_Expanded_Name
:
2159 /* This represents either a subtype range or a static value
2160 of some kind; Ekind says which. If a static value,
2161 fall through to the next case. */
2162 if (IN (Ekind (Entity (gnat_choice
)), Type_Kind
))
2164 tree type
= get_unpadded_type (Entity (gnat_choice
));
2167 = pushcase_range (fold (TYPE_MIN_VALUE (type
)),
2168 fold (TYPE_MAX_VALUE (type
)),
2169 convert
, gnu_label
, 0);
2171 if (error_code
!= 0 && error_code
!= 4)
2175 /* ... fall through ... */
2176 case N_Character_Literal
:
2177 case N_Integer_Literal
:
2178 if (pushcase (gnat_to_gnu (gnat_choice
), convert
,
2183 case N_Others_Choice
:
2184 if (pushcase (NULL_TREE
, convert
, gnu_label
, 0))
2193 /* After compiling the choices attached to the WHEN compile the
2194 body of statements that have to be executed, should the
2195 "WHEN ... =>" be taken. Push a binding level here in case
2196 variables are declared since we want them to be local to this
2197 set of statements instead of the block containing the Case
2200 expand_start_bindings (0);
2201 for (gnat_statement
= First (Statements (gnat_when
));
2202 Present (gnat_statement
);
2203 gnat_statement
= Next (gnat_statement
))
2204 gnat_to_code (gnat_statement
);
2206 /* Communicate to GCC that we are done with the current WHEN,
2207 i.e. insert a "break" statement. */
2208 expand_exit_something ();
2209 expand_end_bindings (getdecls (), kept_level_p (), 0);
2210 poplevel (kept_level_p (), 1, 0);
2213 expand_end_case (gnu_expr
);
2217 case N_Loop_Statement
:
2219 /* The loop variable in GCC form, if any. */
2220 tree gnu_loop_var
= NULL_TREE
;
2221 /* PREINCREMENT_EXPR or PREDECREMENT_EXPR. */
2222 enum tree_code gnu_update
= ERROR_MARK
;
2223 /* Used if this is a named loop for so EXIT can work. */
2224 struct nesting
*loop_id
;
2225 /* Condition to continue loop tested at top of loop. */
2226 tree gnu_top_condition
= integer_one_node
;
2227 /* Similar, but tested at bottom of loop. */
2228 tree gnu_bottom_condition
= integer_one_node
;
2229 Node_Id gnat_statement
;
2230 Node_Id gnat_iter_scheme
= Iteration_Scheme (gnat_node
);
2231 Node_Id gnat_top_condition
= Empty
;
2232 int enclosing_if_p
= 0;
2234 /* Set the condition that under which the loop should continue.
2235 For "LOOP .... END LOOP;" the condition is always true. */
2236 if (No (gnat_iter_scheme
))
2238 /* The case "WHILE condition LOOP ..... END LOOP;" */
2239 else if (Present (Condition (gnat_iter_scheme
)))
2240 gnat_top_condition
= Condition (gnat_iter_scheme
);
2243 /* We have an iteration scheme. */
2244 Node_Id gnat_loop_spec
2245 = Loop_Parameter_Specification (gnat_iter_scheme
);
2246 Entity_Id gnat_loop_var
= Defining_Entity (gnat_loop_spec
);
2247 Entity_Id gnat_type
= Etype (gnat_loop_var
);
2248 tree gnu_type
= get_unpadded_type (gnat_type
);
2249 tree gnu_low
= TYPE_MIN_VALUE (gnu_type
);
2250 tree gnu_high
= TYPE_MAX_VALUE (gnu_type
);
2251 int reversep
= Reverse_Present (gnat_loop_spec
);
2252 tree gnu_first
= reversep
? gnu_high
: gnu_low
;
2253 tree gnu_last
= reversep
? gnu_low
: gnu_high
;
2254 enum tree_code end_code
= reversep
? GE_EXPR
: LE_EXPR
;
2255 tree gnu_base_type
= get_base_type (gnu_type
);
2257 = (reversep
? TYPE_MIN_VALUE (gnu_base_type
)
2258 : TYPE_MAX_VALUE (gnu_base_type
));
2260 /* We know the loop variable will not overflow if GNU_LAST is
2261 a constant and is not equal to GNU_LIMIT. If it might
2262 overflow, we have to move the limit test to the end of
2263 the loop. In that case, we have to test for an
2264 empty loop outside the loop. */
2265 if (TREE_CODE (gnu_last
) != INTEGER_CST
2266 || TREE_CODE (gnu_limit
) != INTEGER_CST
2267 || tree_int_cst_equal (gnu_last
, gnu_limit
))
2269 gnu_expr
= build_binary_op (LE_EXPR
, integer_type_node
,
2271 set_lineno (gnat_loop_spec
, 1);
2272 expand_start_cond (gnu_expr
, 0);
2276 /* Open a new nesting level that will surround the loop to declare
2277 the loop index variable. */
2279 expand_start_bindings (0);
2281 /* Declare the loop index and set it to its initial value. */
2282 gnu_loop_var
= gnat_to_gnu_entity (gnat_loop_var
, gnu_first
, 1);
2283 if (DECL_BY_REF_P (gnu_loop_var
))
2284 gnu_loop_var
= build_unary_op (INDIRECT_REF
, NULL_TREE
,
2287 /* The loop variable might be a padded type, so use `convert' to
2288 get a reference to the inner variable if so. */
2289 gnu_loop_var
= convert (get_base_type (gnu_type
), gnu_loop_var
);
2291 /* Set either the top or bottom exit condition as
2292 appropriate depending on whether we know an overflow
2293 cannot occur or not. */
2295 gnu_bottom_condition
2296 = build_binary_op (NE_EXPR
, integer_type_node
,
2297 gnu_loop_var
, gnu_last
);
2300 = build_binary_op (end_code
, integer_type_node
,
2301 gnu_loop_var
, gnu_last
);
2303 gnu_update
= reversep
? PREDECREMENT_EXPR
: PREINCREMENT_EXPR
;
2306 set_lineno (gnat_node
, 1);
2308 loop_id
= expand_start_loop_continue_elsewhere (1);
2310 loop_id
= expand_start_loop (1);
2312 /* If the loop was named, have the name point to this loop. In this
2313 case, the association is not a ..._DECL node; in fact, it isn't
2314 a GCC tree node at all. Since this name is referenced inside
2315 the loop, do it before we process the statements of the loop. */
2316 if (Present (Identifier (gnat_node
)))
2318 tree gnu_loop_id
= make_node (GNAT_LOOP_ID
);
2320 TREE_LOOP_ID (gnu_loop_id
) = loop_id
;
2321 save_gnu_tree (Entity (Identifier (gnat_node
)), gnu_loop_id
, 1);
2324 set_lineno (gnat_node
, 1);
2326 /* We must evaluate the condition after we've entered the
2327 loop so that any expression actions get done in the right
2329 if (Present (gnat_top_condition
))
2330 gnu_top_condition
= gnat_to_gnu (gnat_top_condition
);
2332 expand_exit_loop_top_cond (0, gnu_top_condition
);
2334 /* Make the loop body into its own block, so any allocated
2335 storage will be released every iteration. This is needed
2336 for stack allocation. */
2340 = tree_cons (gnu_bottom_condition
, NULL_TREE
, gnu_block_stack
);
2341 expand_start_bindings (0);
2343 for (gnat_statement
= First (Statements (gnat_node
));
2344 Present (gnat_statement
);
2345 gnat_statement
= Next (gnat_statement
))
2346 gnat_to_code (gnat_statement
);
2348 expand_end_bindings (getdecls (), kept_level_p (), 0);
2349 poplevel (kept_level_p (), 1, 0);
2350 gnu_block_stack
= TREE_CHAIN (gnu_block_stack
);
2352 set_lineno (gnat_node
, 1);
2353 expand_exit_loop_if_false (0, gnu_bottom_condition
);
2357 expand_loop_continue_here ();
2358 gnu_expr
= build_binary_op (gnu_update
, TREE_TYPE (gnu_loop_var
),
2360 convert (TREE_TYPE (gnu_loop_var
),
2362 set_lineno (gnat_iter_scheme
, 1);
2363 expand_expr_stmt (gnu_expr
);
2366 set_lineno (gnat_node
, 1);
2371 /* Close the nesting level that sourround the loop that was used to
2372 declare the loop index variable. */
2373 set_lineno (gnat_node
, 1);
2374 expand_end_bindings (getdecls (), 1, 0);
2380 set_lineno (gnat_node
, 1);
2386 case N_Block_Statement
:
2388 gnu_block_stack
= tree_cons (NULL_TREE
, NULL_TREE
, gnu_block_stack
);
2389 expand_start_bindings (0);
2390 process_decls (Declarations (gnat_node
), Empty
, Empty
, 1, 1);
2391 gnat_to_code (Handled_Statement_Sequence (gnat_node
));
2392 expand_end_bindings (getdecls (), kept_level_p (), 0);
2393 poplevel (kept_level_p (), 1, 0);
2394 gnu_block_stack
= TREE_CHAIN (gnu_block_stack
);
2395 if (Present (Identifier (gnat_node
)))
2396 mark_out_of_scope (Entity (Identifier (gnat_node
)));
2399 case N_Exit_Statement
:
2401 /* Which loop to exit, NULL if the current loop. */
2402 struct nesting
*loop_id
= 0;
2403 /* The GCC version of the optional GNAT condition node attached to the
2404 exit statement. Exit the loop if this is false. */
2405 tree gnu_cond
= integer_zero_node
;
2407 if (Present (Name (gnat_node
)))
2409 = TREE_LOOP_ID (get_gnu_tree (Entity (Name (gnat_node
))));
2411 if (Present (Condition (gnat_node
)))
2412 gnu_cond
= invert_truthvalue (gnat_truthvalue_conversion
2413 (gnat_to_gnu (Condition (gnat_node
))));
2415 set_lineno (gnat_node
, 1);
2416 expand_exit_loop_if_false (loop_id
, gnu_cond
);
2420 case N_Return_Statement
:
2421 if (type_annotate_only
)
2425 /* The gnu function type of the subprogram currently processed. */
2426 tree gnu_subprog_type
= TREE_TYPE (current_function_decl
);
2427 /* The return value from the subprogram. */
2428 tree gnu_ret_val
= 0;
2430 /* If we are dealing with a "return;" from an Ada procedure with
2431 parameters passed by copy in copy out, we need to return a record
2432 containing the final values of these parameters. If the list
2433 contains only one entry, return just that entry.
2435 For a full description of the copy in copy out parameter mechanism,
2436 see the part of the gnat_to_gnu_entity routine dealing with the
2437 translation of subprograms.
2439 But if we have a return label defined, convert this into
2440 a branch to that label. */
2442 if (TREE_VALUE (gnu_return_label_stack
) != 0)
2443 expand_goto (TREE_VALUE (gnu_return_label_stack
));
2445 else if (TYPE_CI_CO_LIST (gnu_subprog_type
) != NULL_TREE
)
2447 if (list_length (TYPE_CI_CO_LIST (gnu_subprog_type
)) == 1)
2448 gnu_ret_val
= TREE_VALUE (TYPE_CI_CO_LIST (gnu_subprog_type
));
2451 = gnat_build_constructor (TREE_TYPE (gnu_subprog_type
),
2452 TYPE_CI_CO_LIST (gnu_subprog_type
));
2455 /* If the Ada subprogram is a function, we just need to return the
2456 expression. If the subprogram returns an unconstrained
2457 array, we have to allocate a new version of the result and
2458 return it. If we return by reference, return a pointer. */
2460 else if (Present (Expression (gnat_node
)))
2462 gnu_ret_val
= gnat_to_gnu (Expression (gnat_node
));
2464 /* Do not remove the padding from GNU_RET_VAL if the inner
2465 type is self-referential since we want to allocate the fixed
2466 size in that case. */
2467 if (TREE_CODE (gnu_ret_val
) == COMPONENT_REF
2468 && (TYPE_IS_PADDING_P
2469 (TREE_TYPE (TREE_OPERAND (gnu_ret_val
, 0))))
2470 && contains_placeholder_p
2471 (TYPE_SIZE (TREE_TYPE (gnu_ret_val
))))
2472 gnu_ret_val
= TREE_OPERAND (gnu_ret_val
, 0);
2474 if (TYPE_RETURNS_BY_REF_P (gnu_subprog_type
)
2475 || By_Ref (gnat_node
))
2476 gnu_ret_val
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_ret_val
);
2478 else if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type
))
2480 gnu_ret_val
= maybe_unconstrained_array (gnu_ret_val
);
2482 /* We have two cases: either the function returns with
2483 depressed stack or not. If not, we allocate on the
2484 secondary stack. If so, we allocate in the stack frame.
2485 if no copy is needed, the front end will set By_Ref,
2486 which we handle in the case above. */
2487 if (TYPE_RETURNS_STACK_DEPRESSED (gnu_subprog_type
))
2489 = build_allocator (TREE_TYPE (gnu_ret_val
), gnu_ret_val
,
2490 TREE_TYPE (gnu_subprog_type
), 0, -1);
2493 = build_allocator (TREE_TYPE (gnu_ret_val
), gnu_ret_val
,
2494 TREE_TYPE (gnu_subprog_type
),
2495 Procedure_To_Call (gnat_node
),
2496 Storage_Pool (gnat_node
));
2500 set_lineno (gnat_node
, 1);
2502 expand_return (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
2503 DECL_RESULT (current_function_decl
),
2506 expand_null_return ();
2511 case N_Goto_Statement
:
2512 if (type_annotate_only
)
2515 gnu_expr
= gnat_to_gnu (Name (gnat_node
));
2516 TREE_USED (gnu_expr
) = 1;
2517 set_lineno (gnat_node
, 1);
2518 expand_goto (gnu_expr
);
2521 /****************************/
2522 /* Chapter 6: Subprograms: */
2523 /****************************/
2525 case N_Subprogram_Declaration
:
2526 /* Unless there is a freeze node, declare the subprogram. We consider
2527 this a "definition" even though we're not generating code for
2528 the subprogram because we will be making the corresponding GCC
2531 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node
)))))
2532 gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node
)),
2537 case N_Abstract_Subprogram_Declaration
:
2538 /* This subprogram doesn't exist for code generation purposes, but we
2539 have to elaborate the types of any parameters, unless they are
2540 imported types (nothing to generate in this case). */
2542 = First_Formal (Defining_Entity (Specification (gnat_node
)));
2543 Present (gnat_temp
);
2544 gnat_temp
= Next_Formal_With_Extras (gnat_temp
))
2545 if (Is_Itype (Etype (gnat_temp
))
2546 && !From_With_Type (Etype (gnat_temp
)))
2547 gnat_to_gnu_entity (Etype (gnat_temp
), NULL_TREE
, 0);
2551 case N_Defining_Program_Unit_Name
:
2552 /* For a child unit identifier go up a level to get the
2553 specificaton. We get this when we try to find the spec of
2554 a child unit package that is the compilation unit being compiled. */
2555 gnat_to_code (Parent (gnat_node
));
2558 case N_Subprogram_Body
:
2560 /* Save debug output mode in case it is reset. */
2561 enum debug_info_type save_write_symbols
= write_symbols
;
2562 const struct gcc_debug_hooks
*const save_debug_hooks
= debug_hooks
;
2563 /* Definining identifier of a parameter to the subprogram. */
2564 Entity_Id gnat_param
;
2565 /* The defining identifier for the subprogram body. Note that if a
2566 specification has appeared before for this body, then the identifier
2567 occurring in that specification will also be a defining identifier
2568 and all the calls to this subprogram will point to that
2570 Entity_Id gnat_subprog_id
2571 = (Present (Corresponding_Spec (gnat_node
))
2572 ? Corresponding_Spec (gnat_node
) : Defining_Entity (gnat_node
));
2574 /* The FUNCTION_DECL node corresponding to the subprogram spec. */
2575 tree gnu_subprog_decl
;
2576 /* The FUNCTION_TYPE node corresponding to the subprogram spec. */
2577 tree gnu_subprog_type
;
2580 /* If this is a generic object or if it has been eliminated,
2583 if (Ekind (gnat_subprog_id
) == E_Generic_Procedure
2584 || Ekind (gnat_subprog_id
) == E_Generic_Function
2585 || Is_Eliminated (gnat_subprog_id
))
2588 /* If debug information is suppressed for the subprogram,
2589 turn debug mode off for the duration of processing. */
2590 if (Debug_Info_Off (gnat_subprog_id
))
2592 write_symbols
= NO_DEBUG
;
2593 debug_hooks
= &do_nothing_debug_hooks
;
2596 /* If this subprogram acts as its own spec, define it. Otherwise,
2597 just get the already-elaborated tree node. However, if this
2598 subprogram had its elaboration deferred, we will already have
2599 made a tree node for it. So treat it as not being defined in
2600 that case. Such a subprogram cannot have an address clause or
2601 a freeze node, so this test is safe, though it does disable
2602 some otherwise-useful error checking. */
2604 = gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
,
2605 Acts_As_Spec (gnat_node
)
2606 && ! present_gnu_tree (gnat_subprog_id
));
2608 gnu_subprog_type
= TREE_TYPE (gnu_subprog_decl
);
2610 /* Set the line number in the decl to correspond to that of
2611 the body so that the line number notes are written
2613 set_lineno (gnat_node
, 0);
2614 DECL_SOURCE_LOCATION (gnu_subprog_decl
) = input_location
;
2616 begin_subprog_body (gnu_subprog_decl
);
2617 set_lineno (gnat_node
, 1);
2620 gnu_block_stack
= tree_cons (NULL_TREE
, NULL_TREE
, gnu_block_stack
);
2621 expand_start_bindings (0);
2623 gnu_cico_list
= TYPE_CI_CO_LIST (gnu_subprog_type
);
2625 /* If there are OUT parameters, we need to ensure that the
2626 return statement properly copies them out. We do this by
2627 making a new block and converting any inner return into a goto
2628 to a label at the end of the block. */
2630 if (gnu_cico_list
!= 0)
2632 gnu_return_label_stack
2633 = tree_cons (NULL_TREE
,
2634 build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
),
2635 gnu_return_label_stack
);
2637 expand_start_bindings (0);
2640 gnu_return_label_stack
2641 = tree_cons (NULL_TREE
, NULL_TREE
, gnu_return_label_stack
);
2643 /* See if there are any parameters for which we don't yet have
2644 GCC entities. These must be for OUT parameters for which we
2645 will be making VAR_DECL nodes here. Fill them in to
2646 TYPE_CI_CO_LIST, which must contain the empty entry as well.
2647 We can match up the entries because TYPE_CI_CO_LIST is in the
2648 order of the parameters. */
2650 for (gnat_param
= First_Formal (gnat_subprog_id
);
2651 Present (gnat_param
);
2652 gnat_param
= Next_Formal_With_Extras (gnat_param
))
2653 if (present_gnu_tree (gnat_param
))
2654 adjust_decl_rtl (get_gnu_tree (gnat_param
));
2657 /* Skip any entries that have been already filled in; they
2658 must correspond to IN OUT parameters. */
2659 for (; gnu_cico_list
!= 0 && TREE_VALUE (gnu_cico_list
) != 0;
2660 gnu_cico_list
= TREE_CHAIN (gnu_cico_list
))
2663 /* Do any needed references for padded types. */
2664 TREE_VALUE (gnu_cico_list
)
2665 = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_list
)),
2666 gnat_to_gnu_entity (gnat_param
, NULL_TREE
, 1));
2669 process_decls (Declarations (gnat_node
), Empty
, Empty
, 1, 1);
2671 /* Generate the code of the subprogram itself. A return statement
2672 will be present and any OUT parameters will be handled there. */
2673 gnat_to_code (Handled_Statement_Sequence (gnat_node
));
2675 expand_end_bindings (getdecls (), kept_level_p (), 0);
2676 poplevel (kept_level_p (), 1, 0);
2677 gnu_block_stack
= TREE_CHAIN (gnu_block_stack
);
2679 if (TREE_VALUE (gnu_return_label_stack
) != 0)
2683 expand_end_bindings (NULL_TREE
, kept_level_p (), 0);
2684 poplevel (kept_level_p (), 1, 0);
2685 expand_label (TREE_VALUE (gnu_return_label_stack
));
2687 gnu_cico_list
= TYPE_CI_CO_LIST (gnu_subprog_type
);
2688 set_lineno (gnat_node
, 1);
2689 if (list_length (gnu_cico_list
) == 1)
2690 gnu_retval
= TREE_VALUE (gnu_cico_list
);
2692 gnu_retval
= gnat_build_constructor (TREE_TYPE (gnu_subprog_type
),
2695 if (DECL_P (gnu_retval
) && DECL_BY_REF_P (gnu_retval
))
2697 = build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_retval
);
2700 (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
2701 DECL_RESULT (current_function_decl
),
2706 gnu_return_label_stack
= TREE_CHAIN (gnu_return_label_stack
);
2708 /* Disconnect the trees for parameters that we made variables for
2709 from the GNAT entities since these will become unusable after
2710 we end the function. */
2711 for (gnat_param
= First_Formal (gnat_subprog_id
);
2712 Present (gnat_param
);
2713 gnat_param
= Next_Formal_With_Extras (gnat_param
))
2714 if (TREE_CODE (get_gnu_tree (gnat_param
)) == VAR_DECL
)
2715 save_gnu_tree (gnat_param
, NULL_TREE
, 0);
2717 end_subprog_body ();
2718 mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node
)));
2719 write_symbols
= save_write_symbols
;
2720 debug_hooks
= save_debug_hooks
;
2724 case N_Function_Call
:
2725 case N_Procedure_Call_Statement
:
2727 if (type_annotate_only
)
2731 /* The GCC node corresponding to the GNAT subprogram name. This can
2732 either be a FUNCTION_DECL node if we are dealing with a standard
2733 subprogram call, or an indirect reference expression (an
2734 INDIRECT_REF node) pointing to a subprogram. */
2735 tree gnu_subprog_node
= gnat_to_gnu (Name (gnat_node
));
2736 /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */
2737 tree gnu_subprog_type
= TREE_TYPE (gnu_subprog_node
);
2738 tree gnu_subprog_addr
2739 = build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_subprog_node
);
2740 Entity_Id gnat_formal
;
2741 Node_Id gnat_actual
;
2742 tree gnu_actual_list
= NULL_TREE
;
2743 tree gnu_name_list
= NULL_TREE
;
2744 tree gnu_after_list
= NULL_TREE
;
2745 tree gnu_subprog_call
;
2747 switch (Nkind (Name (gnat_node
)))
2750 case N_Operator_Symbol
:
2751 case N_Expanded_Name
:
2752 case N_Attribute_Reference
:
2753 if (Is_Eliminated (Entity (Name (gnat_node
))))
2754 post_error_ne ("cannot call eliminated subprogram &!",
2755 gnat_node
, Entity (Name (gnat_node
)));
2758 if (TREE_CODE (gnu_subprog_type
) != FUNCTION_TYPE
)
2761 /* If we are calling a stubbed function, make this into a
2762 raise of Program_Error. Elaborate all our args first. */
2764 if (TREE_CODE (gnu_subprog_node
) == FUNCTION_DECL
2765 && DECL_STUBBED_P (gnu_subprog_node
))
2767 for (gnat_actual
= First_Actual (gnat_node
);
2768 Present (gnat_actual
);
2769 gnat_actual
= Next_Actual (gnat_actual
))
2770 expand_expr_stmt (gnat_to_gnu (gnat_actual
));
2772 if (Nkind (gnat_node
) == N_Function_Call
)
2774 gnu_result_type
= TREE_TYPE (gnu_subprog_type
);
2776 = build1 (NULL_EXPR
, gnu_result_type
,
2777 build_call_raise (PE_Stubbed_Subprogram_Called
));
2781 (build_call_raise (PE_Stubbed_Subprogram_Called
));
2785 /* The only way we can be making a call via an access type is
2786 if Name is an explicit dereference. In that case, get the
2787 list of formal args from the type the access type is pointing
2788 to. Otherwise, get the formals from entity being called. */
2789 if (Nkind (Name (gnat_node
)) == N_Explicit_Dereference
)
2790 gnat_formal
= First_Formal (Etype (Name (gnat_node
)));
2791 else if (Nkind (Name (gnat_node
)) == N_Attribute_Reference
)
2792 /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
2795 gnat_formal
= First_Formal (Entity (Name (gnat_node
)));
2797 /* Create the list of the actual parameters as GCC expects it, namely
2798 a chain of TREE_LIST nodes in which the TREE_VALUE field of each
2799 node is a parameter-expression and the TREE_PURPOSE field is
2800 null. Skip OUT parameters that are not passed by reference. */
2802 for (gnat_actual
= First_Actual (gnat_node
);
2803 Present (gnat_actual
);
2804 gnat_formal
= Next_Formal_With_Extras (gnat_formal
),
2805 gnat_actual
= Next_Actual (gnat_actual
))
2807 tree gnu_formal_type
= gnat_to_gnu_type (Etype (gnat_formal
));
2809 = ((Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
)
2810 ? Expression (gnat_actual
) : gnat_actual
);
2811 tree gnu_name
= gnat_to_gnu (gnat_name
);
2812 tree gnu_name_type
= gnat_to_gnu_type (Etype (gnat_name
));
2815 /* If it's possible we may need to use this expression twice,
2816 make sure than any side-effects are handled via SAVE_EXPRs.
2817 Likewise if we need to force side-effects before the call.
2818 ??? This is more conservative than we need since we don't
2819 need to do this for pass-by-ref with no conversion.
2820 If we are passing a non-addressable Out or In Out parameter by
2821 reference, pass the address of a copy and set up to copy back
2822 out after the call. */
2824 if (Ekind (gnat_formal
) != E_In_Parameter
)
2826 gnu_name
= gnat_stabilize_reference (gnu_name
, 1);
2827 if (! addressable_p (gnu_name
)
2828 && present_gnu_tree (gnat_formal
)
2829 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal
))
2830 || DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal
))
2831 || DECL_BY_DESCRIPTOR_P (get_gnu_tree (gnat_formal
))))
2833 tree gnu_copy
= gnu_name
;
2835 /* Remove any unpadding on the actual and make a copy.
2836 But if the actual is a left-justified modular type,
2837 first convert to it. */
2838 if (TREE_CODE (gnu_name
) == COMPONENT_REF
2839 && (TYPE_IS_PADDING_P
2840 (TREE_TYPE (TREE_OPERAND (gnu_name
, 0)))))
2841 gnu_name
= gnu_copy
= TREE_OPERAND (gnu_name
, 0);
2842 else if (TREE_CODE (gnu_name_type
) == RECORD_TYPE
2843 && (TYPE_LEFT_JUSTIFIED_MODULAR_P
2845 gnu_name
= convert (gnu_name_type
, gnu_name
);
2847 gnu_actual
= save_expr (gnu_name
);
2849 /* Set up to move the copy back to the original. */
2850 gnu_after_list
= tree_cons (gnu_copy
, gnu_actual
,
2853 gnu_name
= gnu_actual
;
2857 /* If this was a procedure call, we may not have removed any
2858 padding. So do it here for the part we will use as an
2860 gnu_actual
= gnu_name
;
2861 if (Ekind (gnat_formal
) != E_Out_Parameter
2862 && TREE_CODE (TREE_TYPE (gnu_actual
)) == RECORD_TYPE
2863 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual
)))
2864 gnu_actual
= convert (get_unpadded_type (Etype (gnat_actual
)),
2867 if (Ekind (gnat_formal
) != E_Out_Parameter
2868 && Nkind (gnat_actual
) != N_Unchecked_Type_Conversion
2869 && Do_Range_Check (gnat_actual
))
2870 gnu_actual
= emit_range_check (gnu_actual
, Etype (gnat_formal
));
2872 /* Do any needed conversions. We need only check for
2873 unchecked conversion since normal conversions will be handled
2874 by just converting to the formal type. */
2875 if (Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
)
2878 = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual
)),
2881 /* One we've done the unchecked conversion, we still
2882 must ensure that the object is in range of the formal's
2884 if (Ekind (gnat_formal
) != E_Out_Parameter
2885 && Do_Range_Check (gnat_actual
))
2886 gnu_actual
= emit_range_check (gnu_actual
,
2887 Etype (gnat_formal
));
2890 /* We may have suppressed a conversion to the Etype of the
2891 actual since the parent is a procedure call. So add the
2893 gnu_actual
= convert (gnat_to_gnu_type (Etype (gnat_actual
)),
2896 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
2898 /* If we have not saved a GCC object for the formal, it means
2899 it is an OUT parameter not passed by reference. Otherwise,
2900 look at the PARM_DECL to see if it is passed by reference. */
2901 if (present_gnu_tree (gnat_formal
)
2902 && TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
2903 && DECL_BY_REF_P (get_gnu_tree (gnat_formal
)))
2905 if (Ekind (gnat_formal
) != E_In_Parameter
)
2907 gnu_actual
= gnu_name
;
2909 /* If we have a padded type, be sure we've removed the
2911 if (TREE_CODE (TREE_TYPE (gnu_actual
)) == RECORD_TYPE
2912 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual
)))
2914 = convert (get_unpadded_type (Etype (gnat_actual
)),
2918 /* The symmetry of the paths to the type of an entity is
2919 broken here since arguments don't know that they will
2920 be passed by ref. */
2921 gnu_formal_type
= TREE_TYPE (get_gnu_tree (gnat_formal
));
2922 gnu_actual
= build_unary_op (ADDR_EXPR
, gnu_formal_type
,
2925 else if (present_gnu_tree (gnat_formal
)
2926 && TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
2927 && DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal
)))
2929 gnu_formal_type
= TREE_TYPE (get_gnu_tree (gnat_formal
));
2930 gnu_actual
= maybe_implicit_deref (gnu_actual
);
2931 gnu_actual
= maybe_unconstrained_array (gnu_actual
);
2933 if (TREE_CODE (gnu_formal_type
) == RECORD_TYPE
2934 && TYPE_IS_PADDING_P (gnu_formal_type
))
2937 = TREE_TYPE (TYPE_FIELDS (gnu_formal_type
));
2938 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
2941 /* Take the address of the object and convert to the
2942 proper pointer type. We'd like to actually compute
2943 the address of the beginning of the array using
2944 an ADDR_EXPR of an ARRAY_REF, but there's a possibility
2945 that the ARRAY_REF might return a constant and we'd
2946 be getting the wrong address. Neither approach is
2947 exactly correct, but this is the most likely to work
2949 gnu_actual
= convert (gnu_formal_type
,
2950 build_unary_op (ADDR_EXPR
, NULL_TREE
,
2953 else if (present_gnu_tree (gnat_formal
)
2954 && TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
2955 && DECL_BY_DESCRIPTOR_P (get_gnu_tree (gnat_formal
)))
2957 /* If arg is 'Null_Parameter, pass zero descriptor. */
2958 if ((TREE_CODE (gnu_actual
) == INDIRECT_REF
2959 || TREE_CODE (gnu_actual
) == UNCONSTRAINED_ARRAY_REF
)
2960 && TREE_PRIVATE (gnu_actual
))
2962 = convert (DECL_ARG_TYPE (get_gnu_tree (gnat_formal
)),
2966 = build_unary_op (ADDR_EXPR
, NULL_TREE
,
2967 fill_vms_descriptor (gnu_actual
,
2972 tree gnu_actual_size
= TYPE_SIZE (TREE_TYPE (gnu_actual
));
2974 if (Ekind (gnat_formal
) != E_In_Parameter
)
2976 = chainon (gnu_name_list
,
2977 build_tree_list (NULL_TREE
, gnu_name
));
2979 if (! present_gnu_tree (gnat_formal
)
2980 || TREE_CODE (get_gnu_tree (gnat_formal
)) != PARM_DECL
)
2983 /* If this is 'Null_Parameter, pass a zero even though we are
2984 dereferencing it. */
2985 else if (TREE_CODE (gnu_actual
) == INDIRECT_REF
2986 && TREE_PRIVATE (gnu_actual
)
2987 && host_integerp (gnu_actual_size
, 1)
2988 && 0 >= compare_tree_int (gnu_actual_size
,
2992 (DECL_ARG_TYPE (get_gnu_tree (gnat_formal
)),
2993 convert (gnat_type_for_size
2994 (tree_low_cst (gnu_actual_size
, 1), 1),
2995 integer_zero_node
));
2998 = convert (TYPE_MAIN_VARIANT
2999 (DECL_ARG_TYPE (get_gnu_tree (gnat_formal
))),
3004 = chainon (gnu_actual_list
,
3005 build_tree_list (NULL_TREE
, gnu_actual
));
3008 gnu_subprog_call
= build (CALL_EXPR
, TREE_TYPE (gnu_subprog_type
),
3009 gnu_subprog_addr
, gnu_actual_list
,
3011 TREE_SIDE_EFFECTS (gnu_subprog_call
) = 1;
3013 /* If it is a function call, the result is the call expression. */
3014 if (Nkind (gnat_node
) == N_Function_Call
)
3016 gnu_result
= gnu_subprog_call
;
3018 /* If the function returns an unconstrained array or by reference,
3019 we have to de-dereference the pointer. */
3020 if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type
)
3021 || TYPE_RETURNS_BY_REF_P (gnu_subprog_type
))
3022 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
,
3025 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
3028 /* If this is the case where the GNAT tree contains a procedure call
3029 but the Ada procedure has copy in copy out parameters, the special
3030 parameter passing mechanism must be used. */
3031 else if (TYPE_CI_CO_LIST (gnu_subprog_type
) != NULL_TREE
)
3033 /* List of FIELD_DECLs associated with the PARM_DECLs of the copy
3034 in copy out parameters. */
3035 tree scalar_return_list
= TYPE_CI_CO_LIST (gnu_subprog_type
);
3036 int length
= list_length (scalar_return_list
);
3042 gnu_subprog_call
= protect_multiple_eval (gnu_subprog_call
);
3044 /* If any of the names had side-effects, ensure they are
3045 all evaluated before the call. */
3046 for (gnu_name
= gnu_name_list
; gnu_name
;
3047 gnu_name
= TREE_CHAIN (gnu_name
))
3048 if (TREE_SIDE_EFFECTS (TREE_VALUE (gnu_name
)))
3050 = build (COMPOUND_EXPR
, TREE_TYPE (gnu_subprog_call
),
3051 TREE_VALUE (gnu_name
), gnu_subprog_call
);
3054 if (Nkind (Name (gnat_node
)) == N_Explicit_Dereference
)
3055 gnat_formal
= First_Formal (Etype (Name (gnat_node
)));
3057 gnat_formal
= First_Formal (Entity (Name (gnat_node
)));
3059 for (gnat_actual
= First_Actual (gnat_node
);
3060 Present (gnat_actual
);
3061 gnat_formal
= Next_Formal_With_Extras (gnat_formal
),
3062 gnat_actual
= Next_Actual (gnat_actual
))
3063 /* If we are dealing with a copy in copy out parameter, we must
3064 retrieve its value from the record returned in the function
3066 if (! (present_gnu_tree (gnat_formal
)
3067 && TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
3068 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal
))
3069 || (DECL_BY_COMPONENT_PTR_P
3070 (get_gnu_tree (gnat_formal
)))
3071 || DECL_BY_DESCRIPTOR_P (get_gnu_tree (gnat_formal
))))
3072 && Ekind (gnat_formal
) != E_In_Parameter
)
3074 /* Get the value to assign to this OUT or IN OUT
3075 parameter. It is either the result of the function if
3076 there is only a single such parameter or the appropriate
3077 field from the record returned. */
3079 = length
== 1 ? gnu_subprog_call
3080 : build_component_ref
3081 (gnu_subprog_call
, NULL_TREE
,
3082 TREE_PURPOSE (scalar_return_list
));
3083 int unchecked_conversion
3084 = Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
;
3085 /* If the actual is a conversion, get the inner expression,
3086 which will be the real destination, and convert the
3087 result to the type of the actual parameter. */
3089 = maybe_unconstrained_array (TREE_VALUE (gnu_name_list
));
3091 /* If the result is a padded type, remove the padding. */
3092 if (TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
3093 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result
)))
3095 = convert (TREE_TYPE (TYPE_FIELDS
3096 (TREE_TYPE (gnu_result
))),
3099 /* If the result is a type conversion, do it. */
3100 if (Nkind (gnat_actual
) == N_Type_Conversion
)
3102 = convert_with_check
3103 (Etype (Expression (gnat_actual
)), gnu_result
,
3104 Do_Overflow_Check (gnat_actual
),
3105 Do_Range_Check (Expression (gnat_actual
)),
3106 Float_Truncate (gnat_actual
));
3108 else if (unchecked_conversion
)
3110 = unchecked_convert (TREE_TYPE (gnu_actual
), gnu_result
);
3113 if (Do_Range_Check (gnat_actual
))
3114 gnu_result
= emit_range_check (gnu_result
,
3115 Etype (gnat_actual
));
3117 if (! (! TREE_CONSTANT (TYPE_SIZE
3118 (TREE_TYPE (gnu_actual
)))
3119 && TREE_CONSTANT (TYPE_SIZE
3120 (TREE_TYPE (gnu_result
)))))
3121 gnu_result
= convert (TREE_TYPE (gnu_actual
),
3125 set_lineno (gnat_node
, 1);
3126 expand_expr_stmt (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
3127 gnu_actual
, gnu_result
));
3128 scalar_return_list
= TREE_CHAIN (scalar_return_list
);
3129 gnu_name_list
= TREE_CHAIN (gnu_name_list
);
3134 set_lineno (gnat_node
, 1);
3135 expand_expr_stmt (gnu_subprog_call
);
3138 /* Handle anything we need to assign back. */
3139 for (gnu_expr
= gnu_after_list
;
3141 gnu_expr
= TREE_CHAIN (gnu_expr
))
3142 expand_expr_stmt (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
3143 TREE_PURPOSE (gnu_expr
),
3144 TREE_VALUE (gnu_expr
)));
3148 /*************************/
3149 /* Chapter 7: Packages: */
3150 /*************************/
3152 case N_Package_Declaration
:
3153 gnat_to_code (Specification (gnat_node
));
3156 case N_Package_Specification
:
3158 process_decls (Visible_Declarations (gnat_node
),
3159 Private_Declarations (gnat_node
), Empty
, 1, 1);
3162 case N_Package_Body
:
3164 /* If this is the body of a generic package - do nothing */
3165 if (Ekind (Corresponding_Spec (gnat_node
)) == E_Generic_Package
)
3168 process_decls (Declarations (gnat_node
), Empty
, Empty
, 1, 1);
3170 if (Present (Handled_Statement_Sequence (gnat_node
)))
3172 gnu_block_stack
= tree_cons (NULL_TREE
, NULL_TREE
, gnu_block_stack
);
3173 gnat_to_code (Handled_Statement_Sequence (gnat_node
));
3174 gnu_block_stack
= TREE_CHAIN (gnu_block_stack
);
3178 /*********************************/
3179 /* Chapter 8: Visibility Rules: */
3180 /*********************************/
3182 case N_Use_Package_Clause
:
3183 case N_Use_Type_Clause
:
3184 /* Nothing to do here - but these may appear in list of declarations */
3187 /***********************/
3188 /* Chapter 9: Tasks: */
3189 /***********************/
3191 case N_Protected_Type_Declaration
:
3194 case N_Single_Task_Declaration
:
3195 gnat_to_gnu_entity (Defining_Entity (gnat_node
), NULL_TREE
, 1);
3198 /***********************************************************/
3199 /* Chapter 10: Program Structure and Compilation Issues: */
3200 /***********************************************************/
3202 case N_Compilation_Unit
:
3204 /* For a body, first process the spec if there is one. */
3205 if (Nkind (Unit (gnat_node
)) == N_Package_Body
3206 || (Nkind (Unit (gnat_node
)) == N_Subprogram_Body
3207 && ! Acts_As_Spec (gnat_node
)))
3208 gnat_to_code (Library_Unit (gnat_node
));
3210 process_inlined_subprograms (gnat_node
);
3212 if (type_annotate_only
&& gnat_node
== Cunit (Main_Unit
))
3214 elaborate_all_entities (gnat_node
);
3216 if (Nkind (Unit (gnat_node
)) == N_Subprogram_Declaration
3217 || Nkind (Unit (gnat_node
)) == N_Generic_Package_Declaration
3218 || Nkind (Unit (gnat_node
)) == N_Generic_Subprogram_Declaration
)
3222 process_decls (Declarations (Aux_Decls_Node (gnat_node
)),
3223 Empty
, Empty
, 1, 1);
3225 gnat_to_code (Unit (gnat_node
));
3227 /* Process any pragmas following the unit. */
3228 if (Present (Pragmas_After (Aux_Decls_Node (gnat_node
))))
3229 for (gnat_temp
= First (Pragmas_After (Aux_Decls_Node (gnat_node
)));
3230 gnat_temp
; gnat_temp
= Next (gnat_temp
))
3231 gnat_to_code (gnat_temp
);
3233 /* Put all the Actions into the elaboration routine if we already had
3234 elaborations. This will happen anyway if they are statements, but we
3235 want to force declarations there too due to order-of-elaboration
3236 issues. Most should have Is_Statically_Allocated set. If we
3237 have had no elaborations, we have no order-of-elaboration issue and
3238 don't want to create elaborations here. */
3239 if (Is_Non_Empty_List (Actions (Aux_Decls_Node (gnat_node
))))
3240 for (gnat_temp
= First (Actions (Aux_Decls_Node (gnat_node
)));
3241 Present (gnat_temp
); gnat_temp
= Next (gnat_temp
))
3243 if (pending_elaborations_p ())
3244 add_pending_elaborations (NULL_TREE
,
3245 make_transform_expr (gnat_temp
));
3247 gnat_to_code (gnat_temp
);
3250 /* Generate elaboration code for this unit, if necessary, and
3251 say whether we did or not. */
3252 Set_Has_No_Elaboration_Code
3255 (Defining_Entity (Unit (gnat_node
)),
3256 Nkind (Unit (gnat_node
)) == N_Package_Body
3257 || Nkind (Unit (gnat_node
)) == N_Subprogram_Body
,
3258 get_pending_elaborations ()));
3262 case N_Subprogram_Body_Stub
:
3263 case N_Package_Body_Stub
:
3264 case N_Protected_Body_Stub
:
3265 case N_Task_Body_Stub
:
3266 /* Simply process whatever unit is being inserted. */
3267 gnat_to_code (Unit (Library_Unit (gnat_node
)));
3271 gnat_to_code (Proper_Body (gnat_node
));
3274 /***************************/
3275 /* Chapter 11: Exceptions: */
3276 /***************************/
3278 case N_Handled_Sequence_Of_Statements
:
3280 /* The GCC exception handling mechanism can handle both ZCX and SJLJ
3281 schemes and we have our own SJLJ mechanism. To call the GCC
3282 mechanism, we first call expand_eh_region_start if there is at least
3283 one handler associated with the region. We then generate code for
3284 the region and call expand_start_all_catch to announce that the
3285 associated handlers are going to be generated.
3287 For each handler we call expand_start_catch, generate code for the
3288 handler, and then call expand_end_catch.
3290 After all the handlers, we call expand_end_all_catch.
3292 Here we deal with the region level calls and the
3293 N_Exception_Handler branch deals with the handler level calls
3294 (start_catch/end_catch).
3296 ??? The region level calls down there have been specifically put in
3297 place for a ZCX context and currently the order in which things are
3298 emitted (region/handlers) is different from the SJLJ case. Instead of
3299 putting other calls with different conditions at other places for the
3300 SJLJ case, it seems cleaner to reorder things for the SJLJ case and
3301 generalize the condition to make it not ZCX specific. */
3303 /* Tell the back-end we are starting a new exception region if
3305 if (! type_annotate_only
3306 && Exception_Mechanism
== GCC_ZCX
3307 && Present (Exception_Handlers (gnat_node
)))
3308 expand_eh_region_start ();
3310 /* If there are exception handlers, start a new binding level that
3311 we can exit (since each exception handler will do so). Then
3312 declare a variable to save the old __gnat_jmpbuf value and a
3313 variable for our jmpbuf. Call setjmp and handle each of the
3314 possible exceptions if it returns one. */
3316 if (! type_annotate_only
&& Present (Exception_Handlers (gnat_node
)))
3318 tree gnu_jmpsave_decl
= 0;
3319 tree gnu_jmpbuf_decl
= 0;
3320 tree gnu_cleanup_call
= 0;
3321 tree gnu_cleanup_decl
;
3324 expand_start_bindings (1);
3326 if (Exception_Mechanism
== Setjmp_Longjmp
)
3329 = create_var_decl (get_identifier ("JMPBUF_SAVE"), NULL_TREE
,
3331 build_call_0_expr (get_jmpbuf_decl
),
3334 gnu_jmpbuf_decl
= create_var_decl (get_identifier ("JMP_BUF"),
3335 NULL_TREE
, jmpbuf_type
,
3336 NULL_TREE
, 0, 0, 0, 0,
3338 TREE_VALUE (gnu_block_stack
) = gnu_jmpbuf_decl
;
3341 /* See if we are to call a function when exiting this block. */
3342 if (Present (At_End_Proc (gnat_node
)))
3345 = build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node
)));
3348 = create_var_decl (get_identifier ("CLEANUP"), NULL_TREE
,
3349 integer_type_node
, NULL_TREE
, 0, 0, 0, 0,
3352 expand_decl_cleanup (gnu_cleanup_decl
, gnu_cleanup_call
);
3355 if (Exception_Mechanism
== Setjmp_Longjmp
)
3357 /* When we exit this block, restore the saved value. */
3358 expand_decl_cleanup (gnu_jmpsave_decl
,
3359 build_call_1_expr (set_jmpbuf_decl
,
3362 /* Call setjmp and handle exceptions if it returns one. */
3363 set_lineno (gnat_node
, 1);
3365 (build_call_1_expr (setjmp_decl
,
3366 build_unary_op (ADDR_EXPR
, NULL_TREE
,
3370 /* Restore our incoming longjmp value before we do anything. */
3371 expand_expr_stmt (build_call_1_expr (set_jmpbuf_decl
,
3375 expand_start_bindings (0);
3377 gnu_except_ptr_stack
3378 = tree_cons (NULL_TREE
,
3380 (get_identifier ("EXCEPT_PTR"), NULL_TREE
,
3381 build_pointer_type (except_type_node
),
3382 build_call_0_expr (get_excptr_decl
),
3384 gnu_except_ptr_stack
);
3386 /* Generate code for each exception handler. The code at
3387 N_Exception_Handler below does the real work. Note that
3388 we ignore the dummy exception handler for the identifier
3389 case, this is used only by the front end */
3390 if (Present (Exception_Handlers (gnat_node
)))
3392 = First_Non_Pragma (Exception_Handlers (gnat_node
));
3393 Present (gnat_temp
);
3394 gnat_temp
= Next_Non_Pragma (gnat_temp
))
3395 gnat_to_code (gnat_temp
);
3397 /* If none of the exception handlers did anything, re-raise
3398 but do not defer abortion. */
3399 set_lineno (gnat_node
, 1);
3401 (build_call_1_expr (raise_nodefer_decl
,
3402 TREE_VALUE (gnu_except_ptr_stack
)));
3404 gnu_except_ptr_stack
= TREE_CHAIN (gnu_except_ptr_stack
);
3405 expand_end_bindings (getdecls (), kept_level_p (), 0);
3406 poplevel (kept_level_p (), 1, 0);
3408 /* End the "if" on setjmp. Note that we have arranged things so
3409 control never returns here. */
3412 /* This is now immediately before the body proper. Set
3413 our jmp_buf as the current buffer. */
3415 (build_call_1_expr (set_jmpbuf_decl
,
3416 build_unary_op (ADDR_EXPR
, NULL_TREE
,
3421 /* If there are no exception handlers, we must not have an at end
3422 cleanup identifier, since the cleanup identifier should always
3423 generate a corresponding exception handler, except in the case
3424 of the No_Exception_Handlers restriction, where the front-end
3425 does not generate exception handlers. */
3426 else if (! type_annotate_only
&& Present (At_End_Proc (gnat_node
)))
3428 if (No_Exception_Handlers_Set ())
3430 tree gnu_cleanup_call
= 0;
3431 tree gnu_cleanup_decl
;
3434 = build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node
)));
3437 = create_var_decl (get_identifier ("CLEANUP"), NULL_TREE
,
3438 integer_type_node
, NULL_TREE
, 0, 0, 0, 0,
3441 expand_decl_cleanup (gnu_cleanup_decl
, gnu_cleanup_call
);
3447 /* Generate code and declarations for the prefix of this block,
3449 if (Present (First_Real_Statement (gnat_node
)))
3450 process_decls (Statements (gnat_node
), Empty
,
3451 First_Real_Statement (gnat_node
), 1, 1);
3453 /* Generate code for each statement in the block. */
3454 for (gnat_temp
= (Present (First_Real_Statement (gnat_node
))
3455 ? First_Real_Statement (gnat_node
)
3456 : First (Statements (gnat_node
)));
3457 Present (gnat_temp
); gnat_temp
= Next (gnat_temp
))
3458 gnat_to_code (gnat_temp
);
3460 /* Tell the back-end we are ending the new exception region and
3461 starting the associated handlers. */
3462 if (! type_annotate_only
3463 && Exception_Mechanism
== GCC_ZCX
3464 && Present (Exception_Handlers (gnat_node
)))
3465 expand_start_all_catch ();
3467 /* For zero-cost exceptions, exit the block and then compile
3469 if (! type_annotate_only
3470 && Exception_Mechanism
== GCC_ZCX
3471 && Present (Exception_Handlers (gnat_node
)))
3473 expand_exit_something ();
3474 for (gnat_temp
= First_Non_Pragma (Exception_Handlers (gnat_node
));
3475 Present (gnat_temp
);
3476 gnat_temp
= Next_Non_Pragma (gnat_temp
))
3477 gnat_to_code (gnat_temp
);
3480 /* We don't support Front_End_ZCX in GNAT 5.0, but we don't want to
3481 crash if -gnatdX is specified. */
3482 if (! type_annotate_only
3483 && Exception_Mechanism
== Front_End_ZCX
3484 && Present (Exception_Handlers (gnat_node
)))
3486 for (gnat_temp
= First_Non_Pragma (Exception_Handlers (gnat_node
));
3487 Present (gnat_temp
);
3488 gnat_temp
= Next_Non_Pragma (gnat_temp
))
3489 gnat_to_code (gnat_temp
);
3492 /* Tell the backend when we are done with the handlers. */
3493 if (! type_annotate_only
3494 && Exception_Mechanism
== GCC_ZCX
3495 && Present (Exception_Handlers (gnat_node
)))
3496 expand_end_all_catch ();
3498 /* If we have handlers, close the block we made. */
3499 if (! type_annotate_only
&& Present (Exception_Handlers (gnat_node
)))
3501 expand_end_bindings (getdecls (), kept_level_p (), 0);
3502 poplevel (kept_level_p (), 1, 0);
3507 case N_Exception_Handler
:
3508 if (Exception_Mechanism
== Setjmp_Longjmp
)
3510 /* Unless this is "Others" or the special "Non-Ada" exception
3511 for Ada, make an "if" statement to select the proper
3512 exceptions. For "Others", exclude exceptions where
3513 Handled_By_Others is nonzero unless the All_Others flag is set.
3514 For "Non-ada", accept an exception if "Lang" is 'V'. */
3515 tree gnu_choice
= integer_zero_node
;
3517 for (gnat_temp
= First (Exception_Choices (gnat_node
));
3518 gnat_temp
; gnat_temp
= Next (gnat_temp
))
3522 if (Nkind (gnat_temp
) == N_Others_Choice
)
3524 if (All_Others (gnat_temp
))
3525 this_choice
= integer_one_node
;
3529 (EQ_EXPR
, integer_type_node
,
3534 (INDIRECT_REF
, NULL_TREE
,
3535 TREE_VALUE (gnu_except_ptr_stack
)),
3536 get_identifier ("not_handled_by_others"), NULL_TREE
)),
3540 else if (Nkind (gnat_temp
) == N_Identifier
3541 || Nkind (gnat_temp
) == N_Expanded_Name
)
3543 /* ??? Note that we have to use gnat_to_gnu_entity here
3544 since the type of the exception will be wrong in the
3545 VMS case and that's exactly what this test is for. */
3547 = gnat_to_gnu_entity (Entity (gnat_temp
), NULL_TREE
, 0);
3549 /* If this was a VMS exception, check import_code
3550 against the value of the exception. */
3551 if (TREE_CODE (TREE_TYPE (gnu_expr
)) == INTEGER_TYPE
)
3554 (EQ_EXPR
, integer_type_node
,
3557 (INDIRECT_REF
, NULL_TREE
,
3558 TREE_VALUE (gnu_except_ptr_stack
)),
3559 get_identifier ("import_code"), NULL_TREE
),
3564 (EQ_EXPR
, integer_type_node
,
3565 TREE_VALUE (gnu_except_ptr_stack
),
3567 (TREE_TYPE (TREE_VALUE (gnu_except_ptr_stack
)),
3568 build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
)));
3570 /* If this is the distinguished exception "Non_Ada_Error"
3571 (and we are in VMS mode), also allow a non-Ada
3572 exception (a VMS condition) to match. */
3573 if (Is_Non_Ada_Error (Entity (gnat_temp
)))
3576 = build_component_ref
3578 (INDIRECT_REF
, NULL_TREE
,
3579 TREE_VALUE (gnu_except_ptr_stack
)),
3580 get_identifier ("lang"), NULL_TREE
);
3584 (TRUTH_ORIF_EXPR
, integer_type_node
,
3586 (EQ_EXPR
, integer_type_node
, gnu_comp
,
3587 convert (TREE_TYPE (gnu_comp
),
3588 build_int_2 ('V', 0))),
3595 gnu_choice
= build_binary_op (TRUTH_ORIF_EXPR
, integer_type_node
,
3596 gnu_choice
, this_choice
);
3599 set_lineno (gnat_node
, 1);
3601 expand_start_cond (gnu_choice
, 0);
3604 /* Tell the back end that we start an exception handler if necessary. */
3605 if (Exception_Mechanism
== GCC_ZCX
)
3607 /* We build a TREE_LIST of nodes representing what exception
3608 types this handler is able to catch, with special cases
3609 for others and all others cases.
3611 Each exception type is actually identified by a pointer to the
3612 exception id, with special value zero for "others" and one for
3613 "all others". Beware that these special values are known and used
3614 by the personality routine to identify the corresponding specific
3617 ??? For initial time frame reasons, the others and all_others
3618 cases have been handled using specific type trees, but this
3619 somehow hides information to the back-end, which expects NULL to
3620 be passed for catch all and end_cleanup to be used for cleanups.
3622 Care should be taken to ensure that the control flow impact of
3623 such clauses is rendered in some way. lang_eh_type_covers is
3624 doing the trick currently.
3626 ??? Should investigate the possible usage of the end_cleanup
3627 interface in this context. */
3629 tree gnu_expr
, gnu_etype
;
3630 tree gnu_etypes_list
= NULL_TREE
;
3632 for (gnat_temp
= First (Exception_Choices (gnat_node
));
3633 gnat_temp
; gnat_temp
= Next (gnat_temp
))
3635 if (Nkind (gnat_temp
) == N_Others_Choice
)
3637 = All_Others (gnat_temp
) ? integer_one_node
3638 : integer_zero_node
;
3639 else if (Nkind (gnat_temp
) == N_Identifier
3640 || Nkind (gnat_temp
) == N_Expanded_Name
)
3642 gnu_expr
= gnat_to_gnu_entity (Entity (gnat_temp
),
3644 gnu_etype
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
);
3650 = tree_cons (NULL_TREE
, gnu_etype
, gnu_etypes_list
);
3652 /* The GCC interface expects NULL to be passed for catch all
3653 handlers, so the approach below is quite tempting :
3655 if (gnu_etype == integer_zero_node)
3656 gnu_etypes_list = NULL;
3658 It would not work, however, because GCC's notion
3659 of "catch all" is stronger than our notion of "others".
3661 Until we correctly use the cleanup interface as well, the
3662 two lines above will prevent the "all others" handlers from
3663 beeing seen, because nothing can be caught beyond a catch
3664 all from GCC's point of view. */
3667 expand_start_catch (gnu_etypes_list
);
3670 for (gnat_temp
= First (Statements (gnat_node
));
3671 gnat_temp
; gnat_temp
= Next (gnat_temp
))
3672 gnat_to_code (gnat_temp
);
3674 /* At the end of the handler, exit the block. We made this block
3675 in N_Handled_Sequence_Of_Statements. */
3676 expand_exit_something ();
3678 /* Tell the back end that we're done with the current handler. */
3679 if (Exception_Mechanism
== GCC_ZCX
)
3680 expand_end_catch ();
3681 else if (Exception_Mechanism
== Setjmp_Longjmp
)
3686 /*******************************/
3687 /* Chapter 12: Generic Units: */
3688 /*******************************/
3690 case N_Generic_Function_Renaming_Declaration
:
3691 case N_Generic_Package_Renaming_Declaration
:
3692 case N_Generic_Procedure_Renaming_Declaration
:
3693 case N_Generic_Package_Declaration
:
3694 case N_Generic_Subprogram_Declaration
:
3695 case N_Package_Instantiation
:
3696 case N_Procedure_Instantiation
:
3697 case N_Function_Instantiation
:
3698 /* These nodes can appear on a declaration list but there is nothing to
3699 to be done with them. */
3702 /***************************************************/
3703 /* Chapter 13: Representation Clauses and */
3704 /* Implementation-Dependent Features: */
3705 /***************************************************/
3707 case N_Attribute_Definition_Clause
:
3709 /* The only one we need deal with is for 'Address. For the others, SEM
3710 puts the information elsewhere. We need only deal with 'Address
3711 if the object has a Freeze_Node (which it never will currently). */
3712 if (Get_Attribute_Id (Chars (gnat_node
)) != Attr_Address
3713 || No (Freeze_Node (Entity (Name (gnat_node
)))))
3716 /* Get the value to use as the address and save it as the
3717 equivalent for GNAT_TEMP. When the object is frozen,
3718 gnat_to_gnu_entity will do the right thing. */
3719 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
3720 save_gnu_tree (Entity (Name (gnat_node
)), gnu_expr
, 1);
3723 case N_Enumeration_Representation_Clause
:
3724 case N_Record_Representation_Clause
:
3726 /* We do nothing with these. SEM puts the information elsewhere. */
3729 case N_Code_Statement
:
3730 if (! type_annotate_only
)
3732 tree gnu_template
= gnat_to_gnu (Asm_Template (gnat_node
));
3733 tree gnu_input_list
= 0, gnu_output_list
= 0, gnu_orig_out_list
= 0;
3734 tree gnu_clobber_list
= 0;
3737 /* First process inputs, then outputs, then clobbers. */
3738 Setup_Asm_Inputs (gnat_node
);
3739 while (Present (gnat_temp
= Asm_Input_Value ()))
3741 tree gnu_value
= gnat_to_gnu (gnat_temp
);
3742 tree gnu_constr
= build_tree_list (NULL_TREE
, gnat_to_gnu
3743 (Asm_Input_Constraint ()));
3746 = tree_cons (gnu_constr
, gnu_value
, gnu_input_list
);
3750 Setup_Asm_Outputs (gnat_node
);
3751 while (Present (gnat_temp
= Asm_Output_Variable ()))
3753 tree gnu_value
= gnat_to_gnu (gnat_temp
);
3754 tree gnu_constr
= build_tree_list (NULL_TREE
, gnat_to_gnu
3755 (Asm_Output_Constraint ()));
3758 = tree_cons (gnu_constr
, gnu_value
, gnu_orig_out_list
);
3760 = tree_cons (gnu_constr
, gnu_value
, gnu_output_list
);
3764 Clobber_Setup (gnat_node
);
3765 while ((clobber
= Clobber_Get_Next ()) != 0)
3767 = tree_cons (NULL_TREE
,
3768 build_string (strlen (clobber
) + 1, clobber
),
3771 gnu_input_list
= nreverse (gnu_input_list
);
3772 gnu_output_list
= nreverse (gnu_output_list
);
3773 gnu_orig_out_list
= nreverse (gnu_orig_out_list
);
3774 expand_asm_operands (gnu_template
, gnu_output_list
, gnu_input_list
,
3775 gnu_clobber_list
, Is_Asm_Volatile (gnat_node
),
3776 input_filename
, input_line
);
3778 /* Copy all the intermediate outputs into the specified outputs. */
3779 for (; gnu_output_list
;
3780 (gnu_output_list
= TREE_CHAIN (gnu_output_list
),
3781 gnu_orig_out_list
= TREE_CHAIN (gnu_orig_out_list
)))
3782 if (TREE_VALUE (gnu_orig_out_list
) != TREE_VALUE (gnu_output_list
))
3785 (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
3786 TREE_VALUE (gnu_orig_out_list
),
3787 TREE_VALUE (gnu_output_list
)));
3793 /***************************************************/
3795 /***************************************************/
3797 case N_Freeze_Entity
:
3798 process_freeze_entity (gnat_node
);
3799 process_decls (Actions (gnat_node
), Empty
, Empty
, 1, 1);
3802 case N_Itype_Reference
:
3803 if (! present_gnu_tree (Itype (gnat_node
)))
3804 process_type (Itype (gnat_node
));
3807 case N_Free_Statement
:
3808 if (! type_annotate_only
)
3810 tree gnu_ptr
= gnat_to_gnu (Expression (gnat_node
));
3815 /* If this is an unconstrained array, we know the object must
3816 have been allocated with the template in front of the object.
3817 So pass the template address, but get the total size. Do this
3818 by converting to a thin pointer. */
3819 if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr
)))
3821 = convert (build_pointer_type
3822 (TYPE_OBJECT_RECORD_TYPE
3823 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr
)))),
3826 gnu_obj_type
= TREE_TYPE (TREE_TYPE (gnu_ptr
));
3827 gnu_obj_size
= TYPE_SIZE_UNIT (gnu_obj_type
);
3828 align
= TYPE_ALIGN (gnu_obj_type
);
3830 if (TREE_CODE (gnu_obj_type
) == RECORD_TYPE
3831 && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type
))
3833 tree gnu_char_ptr_type
= build_pointer_type (char_type_node
);
3834 tree gnu_pos
= byte_position (TYPE_FIELDS (gnu_obj_type
));
3835 tree gnu_byte_offset
3836 = convert (gnu_char_ptr_type
,
3837 size_diffop (size_zero_node
, gnu_pos
));
3839 gnu_ptr
= convert (gnu_char_ptr_type
, gnu_ptr
);
3840 gnu_ptr
= build_binary_op (MINUS_EXPR
, gnu_char_ptr_type
,
3841 gnu_ptr
, gnu_byte_offset
);
3844 set_lineno (gnat_node
, 1);
3846 (build_call_alloc_dealloc (gnu_ptr
, gnu_obj_size
, align
,
3847 Procedure_To_Call (gnat_node
),
3848 Storage_Pool (gnat_node
)));
3852 case N_Raise_Constraint_Error
:
3853 case N_Raise_Program_Error
:
3854 case N_Raise_Storage_Error
:
3856 if (type_annotate_only
)
3859 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
3860 gnu_result
= build_call_raise (UI_To_Int (Reason (gnat_node
)));
3862 /* If the type is VOID, this is a statement, so we need to
3863 generate the code for the call. Handle a Condition, if there
3865 if (TREE_CODE (gnu_result_type
) == VOID_TYPE
)
3867 set_lineno (gnat_node
, 1);
3869 if (Present (Condition (gnat_node
)))
3870 expand_start_cond (gnat_to_gnu (Condition (gnat_node
)), 0);
3872 expand_expr_stmt (gnu_result
);
3873 if (Present (Condition (gnat_node
)))
3875 gnu_result
= error_mark_node
;
3878 gnu_result
= build1 (NULL_EXPR
, gnu_result_type
, gnu_result
);
3881 /* Nothing to do, since front end does all validation using the
3882 values that Gigi back-annotates. */
3883 case N_Validate_Unchecked_Conversion
:
3886 case N_Raise_Statement
:
3887 case N_Function_Specification
:
3888 case N_Procedure_Specification
:
3890 case N_Component_Association
:
3893 if (! type_annotate_only
)
3897 /* If the result is a constant that overflows, raise constraint error. */
3898 if (TREE_CODE (gnu_result
) == INTEGER_CST
3899 && TREE_CONSTANT_OVERFLOW (gnu_result
))
3901 post_error ("Constraint_Error will be raised at run-time?", gnat_node
);
3904 = build1 (NULL_EXPR
, gnu_result_type
,
3905 build_call_raise (CE_Overflow_Check_Failed
));
3908 /* If our result has side-effects and is of an unconstrained type,
3909 make a SAVE_EXPR so that we can be sure it will only be referenced
3910 once. Note we must do this before any conversions. */
3911 if (TREE_SIDE_EFFECTS (gnu_result
)
3912 && (TREE_CODE (gnu_result_type
) == UNCONSTRAINED_ARRAY_TYPE
3913 || (TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
3914 && contains_placeholder_p (TYPE_SIZE (gnu_result_type
)))))
3915 gnu_result
= gnat_stabilize_reference (gnu_result
, 0);
3917 /* Now convert the result to the proper type. If the type is void or if
3918 we have no result, return error_mark_node to show we have no result.
3919 If the type of the result is correct or if we have a label (which doesn't
3920 have any well-defined type), return our result. Also don't do the
3921 conversion if the "desired" type involves a PLACEHOLDER_EXPR in its size
3922 since those are the cases where the front end may have the type wrong due
3923 to "instantiating" the unconstrained record with discriminant values
3924 or if this is a FIELD_DECL. If this is the Name of an assignment
3925 statement or a parameter of a procedure call, return what we have since
3926 the RHS has to be converted to our type there in that case, unless
3927 GNU_RESULT_TYPE has a simpler size. Similarly, if the two types are
3928 record types with the same name, the expression type has integral mode,
3929 and GNU_RESULT_TYPE BLKmode, don't convert. This will be the case when
3930 we are converting from a packable type to its actual type and we need
3931 those conversions to be NOPs in order for assignments into these types to
3932 work properly if the inner object is a bitfield and hence can't have
3933 its address taken. Finally, don't convert integral types that are the
3934 operand of an unchecked conversion since we need to ignore those
3935 conversions (for 'Valid). Otherwise, convert the result to the proper
3938 if (Present (Parent (gnat_node
))
3939 && ((Nkind (Parent (gnat_node
)) == N_Assignment_Statement
3940 && Name (Parent (gnat_node
)) == gnat_node
)
3941 || (Nkind (Parent (gnat_node
)) == N_Procedure_Call_Statement
3942 && Name (Parent (gnat_node
)) != gnat_node
)
3943 || (Nkind (Parent (gnat_node
)) == N_Unchecked_Type_Conversion
3944 && ! AGGREGATE_TYPE_P (gnu_result_type
)
3945 && ! AGGREGATE_TYPE_P (TREE_TYPE (gnu_result
)))
3946 || Nkind (Parent (gnat_node
)) == N_Parameter_Association
)
3947 && ! (TYPE_SIZE (gnu_result_type
) != 0
3948 && TYPE_SIZE (TREE_TYPE (gnu_result
)) != 0
3949 && (AGGREGATE_TYPE_P (gnu_result_type
)
3950 == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result
)))
3951 && ((TREE_CODE (TYPE_SIZE (gnu_result_type
)) == INTEGER_CST
3952 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result
)))
3954 || (TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
3955 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result
)))
3957 && ! (contains_placeholder_p (TYPE_SIZE (gnu_result_type
)))
3958 && (contains_placeholder_p
3959 (TYPE_SIZE (TREE_TYPE (gnu_result
))))))
3960 && ! (TREE_CODE (gnu_result_type
) == RECORD_TYPE
3961 && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_result_type
))))
3963 /* In this case remove padding only if the inner object is of
3964 self-referential size: in that case it must be an object of
3965 unconstrained type with a default discriminant. In other cases,
3966 we want to avoid copying too much data. */
3967 if (TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
3968 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result
))
3969 && contains_placeholder_p (TYPE_SIZE
3970 (TREE_TYPE (TYPE_FIELDS
3971 (TREE_TYPE (gnu_result
))))))
3972 gnu_result
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result
))),
3976 else if (TREE_CODE (gnu_result
) == LABEL_DECL
3977 || TREE_CODE (gnu_result
) == FIELD_DECL
3978 || TREE_CODE (gnu_result
) == ERROR_MARK
3979 || (TYPE_SIZE (gnu_result_type
) != 0
3980 && TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
3981 && TREE_CODE (gnu_result
) != INDIRECT_REF
3982 && contains_placeholder_p (TYPE_SIZE (gnu_result_type
)))
3983 || ((TYPE_NAME (gnu_result_type
)
3984 == TYPE_NAME (TREE_TYPE (gnu_result
)))
3985 && TREE_CODE (gnu_result_type
) == RECORD_TYPE
3986 && TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
3987 && TYPE_MODE (gnu_result_type
) == BLKmode
3988 && (GET_MODE_CLASS (TYPE_MODE (TREE_TYPE (gnu_result
)))
3991 /* Remove any padding record, but do nothing more in this case. */
3992 if (TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
3993 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result
)))
3994 gnu_result
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result
))),
3998 else if (gnu_result
== error_mark_node
3999 || gnu_result_type
== void_type_node
)
4000 gnu_result
= error_mark_node
;
4001 else if (gnu_result_type
!= TREE_TYPE (gnu_result
))
4002 gnu_result
= convert (gnu_result_type
, gnu_result
);
4004 /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on GNU_RESULT. */
4005 while ((TREE_CODE (gnu_result
) == NOP_EXPR
4006 || TREE_CODE (gnu_result
) == NON_LVALUE_EXPR
)
4007 && TREE_TYPE (TREE_OPERAND (gnu_result
, 0)) == TREE_TYPE (gnu_result
))
4008 gnu_result
= TREE_OPERAND (gnu_result
, 0);
4013 /* Force references to each of the entities in packages GNAT_NODE with's
4014 so that the debugging information for all of them are identical
4015 in all clients. Operate recursively on anything it with's, but check
4016 that we aren't elaborating something more than once. */
4018 /* The reason for this routine's existence is two-fold.
4019 First, with some debugging formats, notably MDEBUG on SGI
4020 IRIX, the linker will remove duplicate debugging information if two
4021 clients have identical debugguing information. With the normal scheme
4022 of elaboration, this does not usually occur, since entities in with'ed
4023 packages are elaborated on demand, and if clients have different usage
4024 patterns, the normal case, then the order and selection of entities
4025 will differ. In most cases however, it seems that linkers do not know
4026 how to eliminate duplicate debugging information, even if it is
4027 identical, so the use of this routine would increase the total amount
4028 of debugging information in the final executable.
4030 Second, this routine is called in type_annotate mode, to compute DDA
4031 information for types in withed units, for ASIS use */
4034 elaborate_all_entities (gnat_node
)
4037 Entity_Id gnat_with_clause
, gnat_entity
;
4039 save_gnu_tree (gnat_node
, integer_zero_node
, 1);
4041 /* Save entities in all context units. A body may have an implicit_with
4042 on its own spec, if the context includes a child unit, so don't save
4045 for (gnat_with_clause
= First (Context_Items (gnat_node
));
4046 Present (gnat_with_clause
);
4047 gnat_with_clause
= Next (gnat_with_clause
))
4048 if (Nkind (gnat_with_clause
) == N_With_Clause
4049 && ! present_gnu_tree (Library_Unit (gnat_with_clause
))
4050 && Library_Unit (gnat_with_clause
) != Library_Unit (Cunit (Main_Unit
)))
4052 elaborate_all_entities (Library_Unit (gnat_with_clause
));
4054 if (Ekind (Entity (Name (gnat_with_clause
))) == E_Package
)
4055 for (gnat_entity
= First_Entity (Entity (Name (gnat_with_clause
)));
4056 Present (gnat_entity
);
4057 gnat_entity
= Next_Entity (gnat_entity
))
4058 if (Is_Public (gnat_entity
)
4059 && Convention (gnat_entity
) != Convention_Intrinsic
4060 && Ekind (gnat_entity
) != E_Package
4061 && Ekind (gnat_entity
) != E_Package_Body
4062 && Ekind (gnat_entity
) != E_Operator
4063 && ! (IN (Ekind (gnat_entity
), Type_Kind
)
4064 && ! Is_Frozen (gnat_entity
))
4065 && ! ((Ekind (gnat_entity
) == E_Procedure
4066 || Ekind (gnat_entity
) == E_Function
)
4067 && Is_Intrinsic_Subprogram (gnat_entity
))
4068 && ! IN (Ekind (gnat_entity
), Named_Kind
)
4069 && ! IN (Ekind (gnat_entity
), Generic_Unit_Kind
))
4070 gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 0);
4073 if (Nkind (Unit (gnat_node
)) == N_Package_Body
&& type_annotate_only
)
4074 elaborate_all_entities (Library_Unit (gnat_node
));
4077 /* Do the processing of N_Freeze_Entity, GNAT_NODE. */
4080 process_freeze_entity (gnat_node
)
4083 Entity_Id gnat_entity
= Entity (gnat_node
);
4087 = (Nkind (Declaration_Node (gnat_entity
)) == N_Object_Declaration
4088 && present_gnu_tree (Declaration_Node (gnat_entity
)))
4089 ? get_gnu_tree (Declaration_Node (gnat_entity
)) : NULL_TREE
;
4091 /* If this is a package, need to generate code for the package. */
4092 if (Ekind (gnat_entity
) == E_Package
)
4095 (Parent (Corresponding_Body
4096 (Parent (Declaration_Node (gnat_entity
)))));
4100 /* Check for old definition after the above call. This Freeze_Node
4101 might be for one its Itypes. */
4103 = present_gnu_tree (gnat_entity
) ? get_gnu_tree (gnat_entity
) : 0;
4105 /* If this entity has an Address representation clause, GNU_OLD is the
4106 address, so discard it here. */
4107 if (Present (Address_Clause (gnat_entity
)))
4110 /* Don't do anything for class-wide types they are always
4111 transformed into their root type. */
4112 if (Ekind (gnat_entity
) == E_Class_Wide_Type
4113 || (Ekind (gnat_entity
) == E_Class_Wide_Subtype
4114 && Present (Equivalent_Type (gnat_entity
))))
4117 /* Don't do anything for subprograms that may have been elaborated before
4118 their freeze nodes. This can happen, for example because of an inner call
4119 in an instance body. */
4121 && TREE_CODE (gnu_old
) == FUNCTION_DECL
4122 && (Ekind (gnat_entity
) == E_Function
4123 || Ekind (gnat_entity
) == E_Procedure
))
4126 /* If we have a non-dummy type old tree, we have nothing to do. Unless
4127 this is the public view of a private type whose full view was not
4128 delayed, this node was never delayed as it should have been.
4129 Also allow this to happen for concurrent types since we may have
4130 frozen both the Corresponding_Record_Type and this type. */
4132 && ! (TREE_CODE (gnu_old
) == TYPE_DECL
4133 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old
))))
4135 if (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
4136 && Present (Full_View (gnat_entity
))
4137 && No (Freeze_Node (Full_View (gnat_entity
))))
4139 else if (Is_Concurrent_Type (gnat_entity
))
4145 /* Reset the saved tree, if any, and elaborate the object or type for real.
4146 If there is a full declaration, elaborate it and copy the type to
4147 GNAT_ENTITY. Likewise if this is the record subtype corresponding to
4148 a class wide type or subtype. */
4151 save_gnu_tree (gnat_entity
, NULL_TREE
, 0);
4152 if (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
4153 && Present (Full_View (gnat_entity
))
4154 && present_gnu_tree (Full_View (gnat_entity
)))
4155 save_gnu_tree (Full_View (gnat_entity
), NULL_TREE
, 0);
4156 if (Present (Class_Wide_Type (gnat_entity
))
4157 && Class_Wide_Type (gnat_entity
) != gnat_entity
)
4158 save_gnu_tree (Class_Wide_Type (gnat_entity
), NULL_TREE
, 0);
4161 if (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
4162 && Present (Full_View (gnat_entity
)))
4164 gnu_new
= gnat_to_gnu_entity (Full_View (gnat_entity
), NULL_TREE
, 1);
4166 /* The above call may have defined this entity (the simplest example
4167 of this is when we have a private enumeral type since the bounds
4168 will have the public view. */
4169 if (! present_gnu_tree (gnat_entity
))
4170 save_gnu_tree (gnat_entity
, gnu_new
, 0);
4171 if (Present (Class_Wide_Type (gnat_entity
))
4172 && Class_Wide_Type (gnat_entity
) != gnat_entity
)
4173 save_gnu_tree (Class_Wide_Type (gnat_entity
), gnu_new
, 0);
4176 gnu_new
= gnat_to_gnu_entity (gnat_entity
, gnu_init
, 1);
4178 /* If we've made any pointers to the old version of this type, we
4179 have to update them. */
4181 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old
)),
4182 TREE_TYPE (gnu_new
));
4185 /* Process the list of inlined subprograms of GNAT_NODE, which is an
4186 N_Compilation_Unit. */
4189 process_inlined_subprograms (gnat_node
)
4192 Entity_Id gnat_entity
;
4195 /* If we can inline, generate RTL for all the inlined subprograms.
4196 Define the entity first so we set DECL_EXTERNAL. */
4197 if (optimize
> 0 && ! flag_no_inline
)
4198 for (gnat_entity
= First_Inlined_Subprogram (gnat_node
);
4199 Present (gnat_entity
);
4200 gnat_entity
= Next_Inlined_Subprogram (gnat_entity
))
4202 gnat_body
= Parent (Declaration_Node (gnat_entity
));
4204 if (Nkind (gnat_body
) != N_Subprogram_Body
)
4206 /* ??? This really should always be Present. */
4207 if (No (Corresponding_Body (gnat_body
)))
4211 = Parent (Declaration_Node (Corresponding_Body (gnat_body
)));
4214 if (Present (gnat_body
))
4216 gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 0);
4217 gnat_to_code (gnat_body
);
4222 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
4223 We make two passes, one to elaborate anything other than bodies (but
4224 we declare a function if there was no spec). The second pass
4225 elaborates the bodies.
4227 GNAT_END_LIST gives the element in the list past the end. Normally,
4228 this is Empty, but can be First_Real_Statement for a
4229 Handled_Sequence_Of_Statements.
4231 We make a complete pass through both lists if PASS1P is true, then make
4232 the second pass over both lists if PASS2P is true. The lists usually
4233 correspond to the public and private parts of a package. */
4236 process_decls (gnat_decls
, gnat_decls2
, gnat_end_list
, pass1p
, pass2p
)
4237 List_Id gnat_decls
, gnat_decls2
;
4238 Node_Id gnat_end_list
;
4241 List_Id gnat_decl_array
[2];
4245 gnat_decl_array
[0] = gnat_decls
, gnat_decl_array
[1] = gnat_decls2
;
4248 for (i
= 0; i
<= 1; i
++)
4249 if (Present (gnat_decl_array
[i
]))
4250 for (gnat_decl
= First (gnat_decl_array
[i
]);
4251 gnat_decl
!= gnat_end_list
; gnat_decl
= Next (gnat_decl
))
4253 set_lineno (gnat_decl
, 0);
4255 /* For package specs, we recurse inside the declarations,
4256 thus taking the two pass approach inside the boundary. */
4257 if (Nkind (gnat_decl
) == N_Package_Declaration
4258 && (Nkind (Specification (gnat_decl
)
4259 == N_Package_Specification
)))
4260 process_decls (Visible_Declarations (Specification (gnat_decl
)),
4261 Private_Declarations (Specification (gnat_decl
)),
4264 /* Similarly for any declarations in the actions of a
4266 else if (Nkind (gnat_decl
) == N_Freeze_Entity
)
4268 process_freeze_entity (gnat_decl
);
4269 process_decls (Actions (gnat_decl
), Empty
, Empty
, 1, 0);
4272 /* Package bodies with freeze nodes get their elaboration deferred
4273 until the freeze node, but the code must be placed in the right
4274 place, so record the code position now. */
4275 else if (Nkind (gnat_decl
) == N_Package_Body
4276 && Present (Freeze_Node (Corresponding_Spec (gnat_decl
))))
4277 record_code_position (gnat_decl
);
4279 else if (Nkind (gnat_decl
) == N_Package_Body_Stub
4280 && Present (Library_Unit (gnat_decl
))
4281 && Present (Freeze_Node
4284 (Library_Unit (gnat_decl
)))))))
4285 record_code_position
4286 (Proper_Body (Unit (Library_Unit (gnat_decl
))));
4288 /* We defer most subprogram bodies to the second pass.
4289 However, Init_Proc subprograms cannot be defered, but luckily
4290 don't need to be. */
4291 else if ((Nkind (gnat_decl
) == N_Subprogram_Body
4292 && (Chars (Defining_Entity (gnat_decl
))
4293 != Name_uInit_Proc
)))
4295 if (Acts_As_Spec (gnat_decl
))
4297 Node_Id gnat_subprog_id
= Defining_Entity (gnat_decl
);
4299 if (Ekind (gnat_subprog_id
) != E_Generic_Procedure
4300 && Ekind (gnat_subprog_id
) != E_Generic_Function
)
4301 gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
, 1);
4304 /* For bodies and stubs that act as their own specs, the entity
4305 itself must be elaborated in the first pass, because it may
4306 be used in other declarations. */
4307 else if (Nkind (gnat_decl
) == N_Subprogram_Body_Stub
)
4309 Node_Id gnat_subprog_id
=
4310 Defining_Entity (Specification (gnat_decl
));
4312 if (Ekind (gnat_subprog_id
) != E_Subprogram_Body
4313 && Ekind (gnat_subprog_id
) != E_Generic_Procedure
4314 && Ekind (gnat_subprog_id
) != E_Generic_Function
)
4315 gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
, 1);
4318 /* Concurrent stubs stand for the corresponding subprogram bodies,
4319 which are deferred like other bodies. */
4320 else if (Nkind (gnat_decl
) == N_Task_Body_Stub
4321 || Nkind (gnat_decl
) == N_Protected_Body_Stub
)
4325 gnat_to_code (gnat_decl
);
4328 /* Here we elaborate everything we deferred above except for package bodies,
4329 which are elaborated at their freeze nodes. Note that we must also
4330 go inside things (package specs and freeze nodes) the first pass did. */
4332 for (i
= 0; i
<= 1; i
++)
4333 if (Present (gnat_decl_array
[i
]))
4334 for (gnat_decl
= First (gnat_decl_array
[i
]);
4335 gnat_decl
!= gnat_end_list
; gnat_decl
= Next (gnat_decl
))
4337 if ((Nkind (gnat_decl
) == N_Subprogram_Body
4338 && (Chars (Defining_Entity (gnat_decl
))
4339 != Name_uInit_Proc
))
4340 || Nkind (gnat_decl
) == N_Subprogram_Body_Stub
4341 || Nkind (gnat_decl
) == N_Task_Body_Stub
4342 || Nkind (gnat_decl
) == N_Protected_Body_Stub
)
4343 gnat_to_code (gnat_decl
);
4345 else if (Nkind (gnat_decl
) == N_Package_Declaration
4346 && (Nkind (Specification (gnat_decl
)
4347 == N_Package_Specification
)))
4348 process_decls (Visible_Declarations (Specification (gnat_decl
)),
4349 Private_Declarations (Specification (gnat_decl
)),
4352 else if (Nkind (gnat_decl
) == N_Freeze_Entity
)
4353 process_decls (Actions (gnat_decl
), Empty
, Empty
, 0, 1);
4357 /* Emits an access check. GNU_EXPR is the expression that needs to be
4358 checked against the NULL pointer. */
4361 emit_access_check (gnu_expr
)
4364 tree gnu_check_expr
;
4366 /* Checked expressions must be evaluated only once. */
4367 gnu_check_expr
= gnu_expr
= protect_multiple_eval (gnu_expr
);
4369 /* Technically, we check a fat pointer against two words of zero. However,
4370 that's wasteful and really doesn't protect against null accesses. It
4371 makes more sense to check oly the array pointer. */
4372 if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_expr
)))
4374 = build_component_ref (gnu_expr
, get_identifier ("P_ARRAY"), NULL_TREE
);
4376 if (! POINTER_TYPE_P (TREE_TYPE (gnu_check_expr
)))
4379 return emit_check (build_binary_op (EQ_EXPR
, integer_type_node
,
4381 convert (TREE_TYPE (gnu_check_expr
),
4382 integer_zero_node
)),
4384 CE_Access_Check_Failed
);
4387 /* Emits a discriminant check. GNU_EXPR is the expression to be checked and
4388 GNAT_NODE a N_Selected_Component node. */
4391 emit_discriminant_check (gnu_expr
, gnat_node
)
4396 = Original_Record_Component (Entity (Selector_Name (gnat_node
)));
4397 Entity_Id gnat_discr_fct
= Discriminant_Checking_Func (orig_comp
);
4399 Entity_Id gnat_discr
;
4400 tree gnu_actual_list
= NULL_TREE
;
4402 Entity_Id gnat_pref_type
;
4405 if (Is_Tagged_Type (Scope (orig_comp
)))
4406 gnat_pref_type
= Scope (orig_comp
);
4409 gnat_pref_type
= Etype (Prefix (gnat_node
));
4411 /* For an untagged derived type, use the discriminants of the parent,
4412 which have been renamed in the derivation, possibly by a one-to-many
4414 if (Is_Derived_Type (gnat_pref_type
)
4415 && (Number_Discriminants (gnat_pref_type
)
4416 != Number_Discriminants (Etype (Base_Type (gnat_pref_type
)))))
4417 gnat_pref_type
= Etype (Base_Type (gnat_pref_type
));
4420 if (! Present (gnat_discr_fct
))
4423 gnu_discr_fct
= gnat_to_gnu (gnat_discr_fct
);
4425 /* Checked expressions must be evaluated only once. */
4426 gnu_expr
= protect_multiple_eval (gnu_expr
);
4428 /* Create the list of the actual parameters as GCC expects it.
4429 This list is the list of the discriminant fields of the
4430 record expression to be discriminant checked. For documentation
4431 on what is the GCC format for this list see under the
4432 N_Function_Call case */
4434 while (IN (Ekind (gnat_pref_type
), Incomplete_Or_Private_Kind
)
4435 || IN (Ekind (gnat_pref_type
), Access_Kind
))
4437 if (IN (Ekind (gnat_pref_type
), Incomplete_Or_Private_Kind
))
4438 gnat_pref_type
= Underlying_Type (gnat_pref_type
);
4439 else if (IN (Ekind (gnat_pref_type
), Access_Kind
))
4440 gnat_pref_type
= Designated_Type (gnat_pref_type
);
4444 = TREE_TYPE (gnat_to_gnu_entity (gnat_pref_type
, NULL_TREE
, 0));
4446 for (gnat_discr
= First_Discriminant (gnat_pref_type
);
4447 Present (gnat_discr
); gnat_discr
= Next_Discriminant (gnat_discr
))
4449 Entity_Id gnat_real_discr
4450 = ((Present (Corresponding_Discriminant (gnat_discr
))
4451 && Present (Parent_Subtype (gnat_pref_type
)))
4452 ? Corresponding_Discriminant (gnat_discr
) : gnat_discr
);
4453 tree gnu_discr
= gnat_to_gnu_entity (gnat_real_discr
, NULL_TREE
, 0);
4456 = chainon (gnu_actual_list
,
4457 build_tree_list (NULL_TREE
,
4459 (convert (gnu_pref_type
, gnu_expr
),
4460 NULL_TREE
, gnu_discr
)));
4463 gnu_cond
= build (CALL_EXPR
,
4464 TREE_TYPE (TREE_TYPE (gnu_discr_fct
)),
4465 build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_discr_fct
),
4468 TREE_SIDE_EFFECTS (gnu_cond
) = 1;
4472 (INDIRECT_REF
, NULL_TREE
,
4473 emit_check (gnu_cond
,
4474 build_unary_op (ADDR_EXPR
,
4475 build_reference_type (TREE_TYPE (gnu_expr
)),
4477 CE_Discriminant_Check_Failed
));
4480 /* Emit code for a range check. GNU_EXPR is the expression to be checked,
4481 GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
4482 which we have to check. */
4485 emit_range_check (gnu_expr
, gnat_range_type
)
4487 Entity_Id gnat_range_type
;
4489 tree gnu_range_type
= get_unpadded_type (gnat_range_type
);
4490 tree gnu_low
= TYPE_MIN_VALUE (gnu_range_type
);
4491 tree gnu_high
= TYPE_MAX_VALUE (gnu_range_type
);
4492 tree gnu_compare_type
= get_base_type (TREE_TYPE (gnu_expr
));
4494 /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE,
4495 we can't do anything since we might be truncating the bounds. No
4496 check is needed in this case. */
4497 if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr
))
4498 && (TYPE_PRECISION (gnu_compare_type
)
4499 < TYPE_PRECISION (get_base_type (gnu_range_type
))))
4502 /* Checked expressions must be evaluated only once. */
4503 gnu_expr
= protect_multiple_eval (gnu_expr
);
4505 /* There's no good type to use here, so we might as well use
4506 integer_type_node. Note that the form of the check is
4507 (not (expr >= lo)) or (not (expr >= hi))
4508 the reason for this slightly convoluted form is that NaN's
4509 are not considered to be in range in the float case. */
4511 (build_binary_op (TRUTH_ORIF_EXPR
, integer_type_node
,
4513 (build_binary_op (GE_EXPR
, integer_type_node
,
4514 convert (gnu_compare_type
, gnu_expr
),
4515 convert (gnu_compare_type
, gnu_low
))),
4517 (build_binary_op (LE_EXPR
, integer_type_node
,
4518 convert (gnu_compare_type
, gnu_expr
),
4519 convert (gnu_compare_type
,
4521 gnu_expr
, CE_Range_Check_Failed
);
4524 /* Emit code for an index check. GNU_ARRAY_OBJECT is the array object
4525 which we are about to index, GNU_EXPR is the index expression to be
4526 checked, GNU_LOW and GNU_HIGH are the lower and upper bounds
4527 against which GNU_EXPR has to be checked. Note that for index
4528 checking we cannot use the emit_range_check function (although very
4529 similar code needs to be generated in both cases) since for index
4530 checking the array type against which we are checking the indeces
4531 may be unconstrained and consequently we need to retrieve the
4532 actual index bounds from the array object itself
4533 (GNU_ARRAY_OBJECT). The place where we need to do that is in
4534 subprograms having unconstrained array formal parameters */
4537 emit_index_check (gnu_array_object
, gnu_expr
, gnu_low
, gnu_high
)
4538 tree gnu_array_object
;
4543 tree gnu_expr_check
;
4545 /* Checked expressions must be evaluated only once. */
4546 gnu_expr
= protect_multiple_eval (gnu_expr
);
4548 /* Must do this computation in the base type in case the expression's
4549 type is an unsigned subtypes. */
4550 gnu_expr_check
= convert (get_base_type (TREE_TYPE (gnu_expr
)), gnu_expr
);
4552 /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by
4553 the object we are handling. */
4554 if (TREE_CODE (gnu_low
) != INTEGER_CST
&& contains_placeholder_p (gnu_low
))
4555 gnu_low
= build (WITH_RECORD_EXPR
, TREE_TYPE (gnu_low
),
4556 gnu_low
, gnu_array_object
);
4558 if (TREE_CODE (gnu_high
) != INTEGER_CST
&& contains_placeholder_p (gnu_high
))
4559 gnu_high
= build (WITH_RECORD_EXPR
, TREE_TYPE (gnu_high
),
4560 gnu_high
, gnu_array_object
);
4562 /* There's no good type to use here, so we might as well use
4563 integer_type_node. */
4565 (build_binary_op (TRUTH_ORIF_EXPR
, integer_type_node
,
4566 build_binary_op (LT_EXPR
, integer_type_node
,
4568 convert (TREE_TYPE (gnu_expr_check
),
4570 build_binary_op (GT_EXPR
, integer_type_node
,
4572 convert (TREE_TYPE (gnu_expr_check
),
4574 gnu_expr
, CE_Index_Check_Failed
);
4577 /* Given GNU_COND which contains the condition corresponding to an access,
4578 discriminant or range check, of value GNU_EXPR, build a COND_EXPR
4579 that returns GNU_EXPR if GNU_COND is false and raises a
4580 CONSTRAINT_ERROR if GNU_COND is true. REASON is the code that says
4581 why the exception was raised. */
4584 emit_check (gnu_cond
, gnu_expr
, reason
)
4592 gnu_call
= build_call_raise (reason
);
4594 /* Use an outer COMPOUND_EXPR to make sure that GNU_EXPR will get evaluated
4595 in front of the comparison in case it ends up being a SAVE_EXPR. Put the
4596 whole thing inside its own SAVE_EXPR so the inner SAVE_EXPR doesn't leak
4598 gnu_result
= fold (build (COND_EXPR
, TREE_TYPE (gnu_expr
), gnu_cond
,
4599 build (COMPOUND_EXPR
, TREE_TYPE (gnu_expr
),
4600 gnu_call
, gnu_expr
),
4603 /* If GNU_EXPR has side effects, make the outer COMPOUND_EXPR and
4604 protect it. Otherwise, show GNU_RESULT has no side effects: we
4605 don't need to evaluate it just for the check. */
4606 if (TREE_SIDE_EFFECTS (gnu_expr
))
4608 = build (COMPOUND_EXPR
, TREE_TYPE (gnu_expr
), gnu_expr
, gnu_result
);
4610 TREE_SIDE_EFFECTS (gnu_result
) = 0;
4612 /* ??? Unfortunately, if we don't put a SAVE_EXPR around this whole thing,
4613 we will repeatedly do the test. It would be nice if GCC was able
4614 to optimize this and only do it once. */
4615 return save_expr (gnu_result
);
4618 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing
4619 overflow checks if OVERFLOW_P is nonzero and range checks if
4620 RANGE_P is nonzero. GNAT_TYPE is known to be an integral type.
4621 If TRUNCATE_P is nonzero, do a float to integer conversion with
4622 truncation; otherwise round. */
4625 convert_with_check (gnat_type
, gnu_expr
, overflow_p
, range_p
, truncate_p
)
4626 Entity_Id gnat_type
;
4632 tree gnu_type
= get_unpadded_type (gnat_type
);
4633 tree gnu_in_type
= TREE_TYPE (gnu_expr
);
4634 tree gnu_in_basetype
= get_base_type (gnu_in_type
);
4635 tree gnu_base_type
= get_base_type (gnu_type
);
4636 tree gnu_ada_base_type
= get_ada_base_type (gnu_type
);
4637 tree gnu_in_lb
= TYPE_MIN_VALUE (gnu_in_basetype
);
4638 tree gnu_in_ub
= TYPE_MAX_VALUE (gnu_in_basetype
);
4639 tree gnu_out_lb
= TYPE_MIN_VALUE (gnu_base_type
);
4640 tree gnu_out_ub
= TYPE_MAX_VALUE (gnu_base_type
);
4641 tree gnu_result
= gnu_expr
;
4643 /* If we are not doing any checks, the output is an integral type, and
4644 the input is not a floating type, just do the conversion. This
4645 shortcut is required to avoid problems with packed array types
4646 and simplifies code in all cases anyway. */
4647 if (! range_p
&& ! overflow_p
&& INTEGRAL_TYPE_P (gnu_base_type
)
4648 && ! FLOAT_TYPE_P (gnu_in_type
))
4649 return convert (gnu_type
, gnu_expr
);
4651 /* First convert the expression to its base type. This
4652 will never generate code, but makes the tests below much simpler.
4653 But don't do this if converting from an integer type to an unconstrained
4654 array type since then we need to get the bounds from the original
4656 if (TREE_CODE (gnu_type
) != UNCONSTRAINED_ARRAY_TYPE
)
4657 gnu_result
= convert (gnu_in_basetype
, gnu_result
);
4659 /* If overflow checks are requested, we need to be sure the result will
4660 fit in the output base type. But don't do this if the input
4661 is integer and the output floating-point. */
4663 && ! (FLOAT_TYPE_P (gnu_base_type
) && INTEGRAL_TYPE_P (gnu_in_basetype
)))
4665 /* Ensure GNU_EXPR only gets evaluated once. */
4666 tree gnu_input
= protect_multiple_eval (gnu_result
);
4667 tree gnu_cond
= integer_zero_node
;
4669 /* Convert the lower bounds to signed types, so we're sure we're
4670 comparing them properly. Likewise, convert the upper bounds
4671 to unsigned types. */
4672 if (INTEGRAL_TYPE_P (gnu_in_basetype
) && TREE_UNSIGNED (gnu_in_basetype
))
4673 gnu_in_lb
= convert (gnat_signed_type (gnu_in_basetype
), gnu_in_lb
);
4675 if (INTEGRAL_TYPE_P (gnu_in_basetype
)
4676 && ! TREE_UNSIGNED (gnu_in_basetype
))
4677 gnu_in_ub
= convert (gnat_unsigned_type (gnu_in_basetype
), gnu_in_ub
);
4679 if (INTEGRAL_TYPE_P (gnu_base_type
) && TREE_UNSIGNED (gnu_base_type
))
4680 gnu_out_lb
= convert (gnat_signed_type (gnu_base_type
), gnu_out_lb
);
4682 if (INTEGRAL_TYPE_P (gnu_base_type
) && ! TREE_UNSIGNED (gnu_base_type
))
4683 gnu_out_ub
= convert (gnat_unsigned_type (gnu_base_type
), gnu_out_ub
);
4685 /* Check each bound separately and only if the result bound
4686 is tighter than the bound on the input type. Note that all the
4687 types are base types, so the bounds must be constant. Also,
4688 the comparison is done in the base type of the input, which
4689 always has the proper signedness. First check for input
4690 integer (which means output integer), output float (which means
4691 both float), or mixed, in which case we always compare.
4692 Note that we have to do the comparison which would *fail* in the
4693 case of an error since if it's an FP comparison and one of the
4694 values is a NaN or Inf, the comparison will fail. */
4695 if (INTEGRAL_TYPE_P (gnu_in_basetype
)
4696 ? tree_int_cst_lt (gnu_in_lb
, gnu_out_lb
)
4697 : (FLOAT_TYPE_P (gnu_base_type
)
4698 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_in_lb
),
4699 TREE_REAL_CST (gnu_out_lb
))
4703 (build_binary_op (GE_EXPR
, integer_type_node
,
4704 gnu_input
, convert (gnu_in_basetype
,
4707 if (INTEGRAL_TYPE_P (gnu_in_basetype
)
4708 ? tree_int_cst_lt (gnu_out_ub
, gnu_in_ub
)
4709 : (FLOAT_TYPE_P (gnu_base_type
)
4710 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_out_ub
),
4711 TREE_REAL_CST (gnu_in_lb
))
4714 = build_binary_op (TRUTH_ORIF_EXPR
, integer_type_node
, gnu_cond
,
4716 (build_binary_op (LE_EXPR
, integer_type_node
,
4718 convert (gnu_in_basetype
,
4721 if (! integer_zerop (gnu_cond
))
4722 gnu_result
= emit_check (gnu_cond
, gnu_input
,
4723 CE_Overflow_Check_Failed
);
4726 /* Now convert to the result base type. If this is a non-truncating
4727 float-to-integer conversion, round. */
4728 if (INTEGRAL_TYPE_P (gnu_ada_base_type
) && FLOAT_TYPE_P (gnu_in_basetype
)
4731 tree gnu_point_5
= build_real (gnu_in_basetype
, dconstp5
);
4732 tree gnu_minus_point_5
= build_real (gnu_in_basetype
, dconstmp5
);
4733 tree gnu_zero
= convert (gnu_in_basetype
, integer_zero_node
);
4734 tree gnu_saved_result
= save_expr (gnu_result
);
4735 tree gnu_comp
= build (GE_EXPR
, integer_type_node
,
4736 gnu_saved_result
, gnu_zero
);
4737 tree gnu_adjust
= build (COND_EXPR
, gnu_in_basetype
, gnu_comp
,
4738 gnu_point_5
, gnu_minus_point_5
);
4741 = build (PLUS_EXPR
, gnu_in_basetype
, gnu_saved_result
, gnu_adjust
);
4744 if (TREE_CODE (gnu_ada_base_type
) == INTEGER_TYPE
4745 && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_ada_base_type
)
4746 && TREE_CODE (gnu_result
) == UNCONSTRAINED_ARRAY_REF
)
4747 gnu_result
= unchecked_convert (gnu_ada_base_type
, gnu_result
);
4749 gnu_result
= convert (gnu_ada_base_type
, gnu_result
);
4751 /* Finally, do the range check if requested. Note that if the
4752 result type is a modular type, the range check is actually
4753 an overflow check. */
4756 || (TREE_CODE (gnu_base_type
) == INTEGER_TYPE
4757 && TYPE_MODULAR_P (gnu_base_type
) && overflow_p
))
4758 gnu_result
= emit_range_check (gnu_result
, gnat_type
);
4760 return convert (gnu_type
, gnu_result
);
4763 /* Return 1 if GNU_EXPR can be directly addressed. This is the case
4764 unless it is an expression involving computation or if it involves
4765 a bitfield reference. This returns the same as
4766 gnat_mark_addressable in most cases. */
4769 addressable_p (gnu_expr
)
4772 switch (TREE_CODE (gnu_expr
))
4774 case UNCONSTRAINED_ARRAY_REF
:
4785 return (! DECL_BIT_FIELD (TREE_OPERAND (gnu_expr
, 1))
4786 && addressable_p (TREE_OPERAND (gnu_expr
, 0)));
4788 case ARRAY_REF
: case ARRAY_RANGE_REF
:
4789 case REALPART_EXPR
: case IMAGPART_EXPR
:
4791 return addressable_p (TREE_OPERAND (gnu_expr
, 0));
4794 return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr
))
4795 && addressable_p (TREE_OPERAND (gnu_expr
, 0)));
4797 case VIEW_CONVERT_EXPR
:
4799 /* This is addressable if we can avoid a copy. */
4800 tree type
= TREE_TYPE (gnu_expr
);
4801 tree inner_type
= TREE_TYPE (TREE_OPERAND (gnu_expr
, 0));
4803 return (((TYPE_MODE (type
) == TYPE_MODE (inner_type
)
4804 && (TYPE_ALIGN (type
) <= TYPE_ALIGN (inner_type
)
4805 || TYPE_ALIGN (inner_type
) >= BIGGEST_ALIGNMENT
))
4806 || ((TYPE_MODE (type
) == BLKmode
4807 || TYPE_MODE (inner_type
) == BLKmode
)
4808 && (TYPE_ALIGN (type
) <= TYPE_ALIGN (inner_type
)
4809 || TYPE_ALIGN (inner_type
) >= BIGGEST_ALIGNMENT
4810 || TYPE_ALIGN_OK (type
)
4811 || TYPE_ALIGN_OK (inner_type
))))
4812 && addressable_p (TREE_OPERAND (gnu_expr
, 0)));
4820 /* Do the processing for the declaration of a GNAT_ENTITY, a type. If
4821 a separate Freeze node exists, delay the bulk of the processing. Otherwise
4822 make a GCC type for GNAT_ENTITY and set up the correspondance. */
4825 process_type (gnat_entity
)
4826 Entity_Id gnat_entity
;
4829 = present_gnu_tree (gnat_entity
) ? get_gnu_tree (gnat_entity
) : 0;
4832 /* If we are to delay elaboration of this type, just do any
4833 elaborations needed for expressions within the declaration and
4834 make a dummy type entry for this node and its Full_View (if
4835 any) in case something points to it. Don't do this if it
4836 has already been done (the only way that can happen is if
4837 the private completion is also delayed). */
4838 if (Present (Freeze_Node (gnat_entity
))
4839 || (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
4840 && Present (Full_View (gnat_entity
))
4841 && Freeze_Node (Full_View (gnat_entity
))
4842 && ! present_gnu_tree (Full_View (gnat_entity
))))
4844 elaborate_entity (gnat_entity
);
4848 tree gnu_decl
= create_type_decl (get_entity_name (gnat_entity
),
4849 make_dummy_type (gnat_entity
),
4852 save_gnu_tree (gnat_entity
, gnu_decl
, 0);
4853 if (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
4854 && Present (Full_View (gnat_entity
)))
4855 save_gnu_tree (Full_View (gnat_entity
), gnu_decl
, 0);
4861 /* If we saved away a dummy type for this node it means that this
4862 made the type that corresponds to the full type of an incomplete
4863 type. Clear that type for now and then update the type in the
4867 if (TREE_CODE (gnu_old
) != TYPE_DECL
4868 || ! TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old
)))
4870 /* If this was a withed access type, this is not an error
4871 and merely indicates we've already elaborated the type
4873 if (Is_Type (gnat_entity
) && From_With_Type (gnat_entity
))
4879 save_gnu_tree (gnat_entity
, NULL_TREE
, 0);
4882 /* Now fully elaborate the type. */
4883 gnu_new
= gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 1);
4884 if (TREE_CODE (gnu_new
) != TYPE_DECL
)
4887 /* If we have an old type and we've made pointers to this type,
4888 update those pointers. */
4890 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old
)),
4891 TREE_TYPE (gnu_new
));
4893 /* If this is a record type corresponding to a task or protected type
4894 that is a completion of an incomplete type, perform a similar update
4896 /* ??? Including protected types here is a guess. */
4898 if (IN (Ekind (gnat_entity
), Record_Kind
)
4899 && Is_Concurrent_Record_Type (gnat_entity
)
4900 && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
)))
4903 = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
));
4905 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
),
4907 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
),
4910 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old
)),
4911 TREE_TYPE (gnu_new
));
4915 /* GNAT_ASSOC is the front of the Component_Associations of an N_Aggregate.
4916 GNU_TYPE is the GCC type of the corresponding record.
4918 Return a CONSTRUCTOR to build the record. */
4921 assoc_to_constructor (gnat_assoc
, gnu_type
)
4925 tree gnu_field
, gnu_list
, gnu_result
;
4927 /* We test for GNU_FIELD being empty in the case where a variant
4928 was the last thing since we don't take things off GNAT_ASSOC in
4929 that case. We check GNAT_ASSOC in case we have a variant, but it
4932 for (gnu_list
= NULL_TREE
; Present (gnat_assoc
);
4933 gnat_assoc
= Next (gnat_assoc
))
4935 Node_Id gnat_field
= First (Choices (gnat_assoc
));
4936 tree gnu_field
= gnat_to_gnu_entity (Entity (gnat_field
), NULL_TREE
, 0);
4937 tree gnu_expr
= gnat_to_gnu (Expression (gnat_assoc
));
4939 /* The expander is supposed to put a single component selector name
4940 in every record component association */
4941 if (Next (gnat_field
))
4944 /* Before assigning a value in an aggregate make sure range checks
4945 are done if required. Then convert to the type of the field. */
4946 if (Do_Range_Check (Expression (gnat_assoc
)))
4947 gnu_expr
= emit_range_check (gnu_expr
, Etype (gnat_field
));
4949 gnu_expr
= convert (TREE_TYPE (gnu_field
), gnu_expr
);
4951 /* Add the field and expression to the list. */
4952 gnu_list
= tree_cons (gnu_field
, gnu_expr
, gnu_list
);
4955 gnu_result
= extract_values (gnu_list
, gnu_type
);
4957 /* Verify every enty in GNU_LIST was used. */
4958 for (gnu_field
= gnu_list
; gnu_field
; gnu_field
= TREE_CHAIN (gnu_field
))
4959 if (! TREE_ADDRESSABLE (gnu_field
))
4965 /* Builds a possibly nested constructor for array aggregates. GNAT_EXPR
4966 is the first element of an array aggregate. It may itself be an
4967 aggregate (an array or record aggregate). GNU_ARRAY_TYPE is the gnu type
4968 corresponding to the array aggregate. GNAT_COMPONENT_TYPE is the type
4969 of the array component. It is needed for range checking. */
4972 pos_to_constructor (gnat_expr
, gnu_array_type
, gnat_component_type
)
4974 tree gnu_array_type
;
4975 Entity_Id gnat_component_type
;
4978 tree gnu_expr_list
= NULL_TREE
;
4980 for ( ; Present (gnat_expr
); gnat_expr
= Next (gnat_expr
))
4982 /* If the expression is itself an array aggregate then first build the
4983 innermost constructor if it is part of our array (multi-dimensional
4986 if (Nkind (gnat_expr
) == N_Aggregate
4987 && TREE_CODE (TREE_TYPE (gnu_array_type
)) == ARRAY_TYPE
4988 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type
)))
4989 gnu_expr
= pos_to_constructor (First (Expressions (gnat_expr
)),
4990 TREE_TYPE (gnu_array_type
),
4991 gnat_component_type
);
4994 gnu_expr
= gnat_to_gnu (gnat_expr
);
4996 /* before assigning the element to the array make sure it is
4998 if (Do_Range_Check (gnat_expr
))
4999 gnu_expr
= emit_range_check (gnu_expr
, gnat_component_type
);
5003 = tree_cons (NULL_TREE
, convert (TREE_TYPE (gnu_array_type
), gnu_expr
),
5007 return gnat_build_constructor (gnu_array_type
, nreverse (gnu_expr_list
));
5010 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
5011 some of which are from RECORD_TYPE. Return a CONSTRUCTOR consisting
5012 of the associations that are from RECORD_TYPE. If we see an internal
5013 record, make a recursive call to fill it in as well. */
5016 extract_values (values
, record_type
)
5020 tree result
= NULL_TREE
;
5023 for (field
= TYPE_FIELDS (record_type
); field
; field
= TREE_CHAIN (field
))
5027 /* _Parent is an internal field, but may have values in the aggregate,
5028 so check for values first. */
5029 if ((tem
= purpose_member (field
, values
)) != 0)
5031 value
= TREE_VALUE (tem
);
5032 TREE_ADDRESSABLE (tem
) = 1;
5035 else if (DECL_INTERNAL_P (field
))
5037 value
= extract_values (values
, TREE_TYPE (field
));
5038 if (TREE_CODE (value
) == CONSTRUCTOR
5039 && CONSTRUCTOR_ELTS (value
) == 0)
5043 /* If we have a record subtype, the names will match, but not the
5044 actual FIELD_DECLs. */
5045 for (tem
= values
; tem
; tem
= TREE_CHAIN (tem
))
5046 if (DECL_NAME (TREE_PURPOSE (tem
)) == DECL_NAME (field
))
5048 value
= convert (TREE_TYPE (field
), TREE_VALUE (tem
));
5049 TREE_ADDRESSABLE (tem
) = 1;
5055 result
= tree_cons (field
, value
, result
);
5058 return gnat_build_constructor (record_type
, nreverse (result
));
5061 /* EXP is to be treated as an array or record. Handle the cases when it is
5062 an access object and perform the required dereferences. */
5065 maybe_implicit_deref (exp
)
5068 /* If the type is a pointer, dereference it. */
5070 if (POINTER_TYPE_P (TREE_TYPE (exp
)) || TYPE_FAT_POINTER_P (TREE_TYPE (exp
)))
5071 exp
= build_unary_op (INDIRECT_REF
, NULL_TREE
, exp
);
5073 /* If we got a padded type, remove it too. */
5074 if (TREE_CODE (TREE_TYPE (exp
)) == RECORD_TYPE
5075 && TYPE_IS_PADDING_P (TREE_TYPE (exp
)))
5076 exp
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp
))), exp
);
5081 /* Protect EXP from multiple evaluation. This may make a SAVE_EXPR. */
5084 protect_multiple_eval (exp
)
5087 tree type
= TREE_TYPE (exp
);
5089 /* If this has no side effects, we don't need to do anything. */
5090 if (! TREE_SIDE_EFFECTS (exp
))
5093 /* If it is a conversion, protect what's inside the conversion.
5094 Similarly, if we're indirectly referencing something, we only
5095 actually need to protect the address since the data itself can't
5096 change in these situations. */
5097 else if (TREE_CODE (exp
) == NON_LVALUE_EXPR
5098 || TREE_CODE (exp
) == NOP_EXPR
|| TREE_CODE (exp
) == CONVERT_EXPR
5099 || TREE_CODE (exp
) == VIEW_CONVERT_EXPR
5100 || TREE_CODE (exp
) == INDIRECT_REF
5101 || TREE_CODE (exp
) == UNCONSTRAINED_ARRAY_REF
)
5102 return build1 (TREE_CODE (exp
), type
,
5103 protect_multiple_eval (TREE_OPERAND (exp
, 0)));
5105 /* If EXP is a fat pointer or something that can be placed into a register,
5106 just make a SAVE_EXPR. */
5107 if (TYPE_FAT_POINTER_P (type
) || TYPE_MODE (type
) != BLKmode
)
5108 return save_expr (exp
);
5110 /* Otherwise, dereference, protect the address, and re-reference. */
5113 build_unary_op (INDIRECT_REF
, type
,
5114 save_expr (build_unary_op (ADDR_EXPR
,
5115 build_reference_type (type
),
5119 /* This is equivalent to stabilize_reference in GCC's tree.c, but we know
5120 how to handle our new nodes and we take an extra argument that says
5121 whether to force evaluation of everything. */
5124 gnat_stabilize_reference (ref
, force
)
5128 register tree type
= TREE_TYPE (ref
);
5129 register enum tree_code code
= TREE_CODE (ref
);
5130 register tree result
;
5137 /* No action is needed in this case. */
5143 case FIX_TRUNC_EXPR
:
5144 case FIX_FLOOR_EXPR
:
5145 case FIX_ROUND_EXPR
:
5147 case VIEW_CONVERT_EXPR
:
5150 = build1 (code
, type
,
5151 gnat_stabilize_reference (TREE_OPERAND (ref
, 0), force
));
5155 case UNCONSTRAINED_ARRAY_REF
:
5156 result
= build1 (code
, type
,
5157 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 0),
5162 result
= build (COMPONENT_REF
, type
,
5163 gnat_stabilize_reference (TREE_OPERAND (ref
, 0),
5165 TREE_OPERAND (ref
, 1));
5169 result
= build (BIT_FIELD_REF
, type
,
5170 gnat_stabilize_reference (TREE_OPERAND (ref
, 0), force
),
5171 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 1),
5173 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 2),
5178 result
= build (ARRAY_REF
, type
,
5179 gnat_stabilize_reference (TREE_OPERAND (ref
, 0), force
),
5180 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 1),
5184 case ARRAY_RANGE_REF
:
5185 result
= build (ARRAY_RANGE_REF
, type
,
5186 gnat_stabilize_reference (TREE_OPERAND (ref
, 0), force
),
5187 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 1),
5192 result
= build (COMPOUND_EXPR
, type
,
5193 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 0),
5195 gnat_stabilize_reference (TREE_OPERAND (ref
, 1),
5200 result
= build1 (INDIRECT_REF
, type
,
5201 save_expr (build1 (ADDR_EXPR
,
5202 build_reference_type (type
), ref
)));
5205 /* If arg isn't a kind of lvalue we recognize, make no change.
5206 Caller should recognize the error for an invalid lvalue. */
5211 return error_mark_node
;
5214 TREE_READONLY (result
) = TREE_READONLY (ref
);
5218 /* Similar to stabilize_reference_1 in tree.c, but supports an extra
5219 arg to force a SAVE_EXPR for everything. */
5222 gnat_stabilize_reference_1 (e
, force
)
5226 register enum tree_code code
= TREE_CODE (e
);
5227 register tree type
= TREE_TYPE (e
);
5228 register tree result
;
5230 /* We cannot ignore const expressions because it might be a reference
5231 to a const array but whose index contains side-effects. But we can
5232 ignore things that are actual constant or that already have been
5233 handled by this function. */
5235 if (TREE_CONSTANT (e
) || code
== SAVE_EXPR
)
5238 switch (TREE_CODE_CLASS (code
))
5248 if (TREE_SIDE_EFFECTS (e
) || force
)
5249 return save_expr (e
);
5253 /* Constants need no processing. In fact, we should never reach
5258 /* Recursively stabilize each operand. */
5259 result
= build (code
, type
,
5260 gnat_stabilize_reference_1 (TREE_OPERAND (e
, 0), force
),
5261 gnat_stabilize_reference_1 (TREE_OPERAND (e
, 1), force
));
5265 /* Recursively stabilize each operand. */
5266 result
= build1 (code
, type
,
5267 gnat_stabilize_reference_1 (TREE_OPERAND (e
, 0),
5275 TREE_READONLY (result
) = TREE_READONLY (e
);
5279 /* GNAT_UNIT is the Defining_Identifier for some package or subprogram,
5280 either a spec or a body, BODY_P says which. If needed, make a function
5281 to be the elaboration routine for that object and perform the elaborations
5284 Return 1 if we didn't need an elaboration function, zero otherwise. */
5287 build_unit_elab (gnat_unit
, body_p
, gnu_elab_list
)
5288 Entity_Id gnat_unit
;
5296 /* If we have nothing to do, return. */
5297 if (gnu_elab_list
== 0)
5300 /* Prevent the elaboration list from being reclaimed by the GC. */
5301 gnu_pending_elaboration_lists
= chainon (gnu_pending_elaboration_lists
,
5304 /* Set our file and line number to that of the object and set up the
5305 elaboration routine. */
5306 gnu_decl
= create_subprog_decl (create_concat_name (gnat_unit
,
5309 NULL_TREE
, void_ftype
, NULL_TREE
, 0, 1, 0,
5311 DECL_ELABORATION_PROC_P (gnu_decl
) = 1;
5313 begin_subprog_body (gnu_decl
);
5314 set_lineno (gnat_unit
, 1);
5316 gnu_block_stack
= tree_cons (NULL_TREE
, NULL_TREE
, gnu_block_stack
);
5317 expand_start_bindings (0);
5319 /* Emit the assignments for the elaborations we have to do. If there
5320 is no destination, this is just a call to execute some statement
5321 that was placed within the declarative region. But first save a
5322 pointer so we can see if any insns were generated. */
5324 insn
= get_last_insn ();
5326 for (; gnu_elab_list
; gnu_elab_list
= TREE_CHAIN (gnu_elab_list
))
5327 if (TREE_PURPOSE (gnu_elab_list
) == NULL_TREE
)
5329 if (TREE_VALUE (gnu_elab_list
) != 0)
5330 expand_expr_stmt (TREE_VALUE (gnu_elab_list
));
5334 tree lhs
= TREE_PURPOSE (gnu_elab_list
);
5336 input_location
= DECL_SOURCE_LOCATION (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_location
);
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 /* We are finished with the elaboration list it can now be discarded. */
5364 gnu_pending_elaboration_lists
= TREE_CHAIN (gnu_pending_elaboration_lists
);
5366 /* If there were no insns, we don't need an elab routine. It would
5367 be nice to not output this one, but there's no good way to do that. */
5371 extern char *__gnat_to_canonical_file_spec
PARAMS ((char *));
5373 /* Determine the input_filename and the input_line from the source location
5374 (Sloc) of GNAT_NODE node. Set the global variable input_filename and
5375 input_line. If WRITE_NOTE_P is true, emit a line number note. */
5378 set_lineno (gnat_node
, write_note_p
)
5382 Source_Ptr source_location
= Sloc (gnat_node
);
5384 /* If node not from source code, ignore. */
5385 if (source_location
< 0)
5388 /* Use the identifier table to make a hashed, permanent copy of the filename,
5389 since the name table gets reallocated after Gigi returns but before all
5390 the debugging information is output. The call to
5391 __gnat_to_canonical_file_spec translates filenames from pragmas
5392 Source_Reference that contain host style syntax not understood by gdb. */
5394 = IDENTIFIER_POINTER
5396 (__gnat_to_canonical_file_spec
5398 (Debug_Source_Name (Get_Source_File_Index (source_location
))))));
5400 /* ref_filename is the reference file name as given by sinput (i.e no
5403 = IDENTIFIER_POINTER
5406 (Reference_Name (Get_Source_File_Index (source_location
)))));;
5407 input_line
= Get_Logical_Line_Number (source_location
);
5410 emit_line_note (input_location
);
5413 /* Post an error message. MSG is the error message, properly annotated.
5414 NODE is the node at which to post the error and the node to use for the
5415 "&" substitution. */
5418 post_error (msg
, node
)
5422 String_Template temp
;
5425 temp
.Low_Bound
= 1, temp
.High_Bound
= strlen (msg
);
5426 fp
.Array
= msg
, fp
.Bounds
= &temp
;
5428 Error_Msg_N (fp
, node
);
5431 /* Similar, but NODE is the node at which to post the error and ENT
5432 is the node to use for the "&" substitution. */
5435 post_error_ne (msg
, node
, ent
)
5440 String_Template temp
;
5443 temp
.Low_Bound
= 1, temp
.High_Bound
= strlen (msg
);
5444 fp
.Array
= msg
, fp
.Bounds
= &temp
;
5446 Error_Msg_NE (fp
, node
, ent
);
5449 /* Similar, but NODE is the node at which to post the error, ENT is the node
5450 to use for the "&" substitution, and N is the number to use for the ^. */
5453 post_error_ne_num (msg
, node
, ent
, n
)
5459 String_Template temp
;
5462 temp
.Low_Bound
= 1, temp
.High_Bound
= strlen (msg
);
5463 fp
.Array
= msg
, fp
.Bounds
= &temp
;
5464 Error_Msg_Uint_1
= UI_From_Int (n
);
5467 Error_Msg_NE (fp
, node
, ent
);
5470 /* Similar to post_error_ne_num, but T is a GCC tree representing the
5471 number to write. If the tree represents a constant that fits within
5472 a host integer, the text inside curly brackets in MSG will be output
5473 (presumably including a '^'). Otherwise that text will not be output
5474 and the text inside square brackets will be output instead. */
5477 post_error_ne_tree (msg
, node
, ent
, t
)
5483 char *newmsg
= alloca (strlen (msg
) + 1);
5484 String_Template temp
= {1, 0};
5486 char start_yes
, end_yes
, start_no
, end_no
;
5490 fp
.Array
= newmsg
, fp
.Bounds
= &temp
;
5492 if (host_integerp (t
, 1)
5493 #if HOST_BITS_PER_WIDE_INT > HOST_BITS_PER_INT
5494 && compare_tree_int (t
, 1 << (HOST_BITS_PER_INT
- 2)) < 0
5498 Error_Msg_Uint_1
= UI_From_Int (tree_low_cst (t
, 1));
5499 start_yes
= '{', end_yes
= '}', start_no
= '[', end_no
= ']';
5502 start_yes
= '[', end_yes
= ']', start_no
= '{', end_no
= '}';
5504 for (p
= msg
, q
= newmsg
; *p
!= 0; p
++)
5506 if (*p
== start_yes
)
5507 for (p
++; *p
!= end_yes
; p
++)
5509 else if (*p
== start_no
)
5510 for (p
++; *p
!= end_no
; p
++)
5518 temp
.High_Bound
= strlen (newmsg
);
5520 Error_Msg_NE (fp
, node
, ent
);
5523 /* Similar to post_error_ne_tree, except that NUM is a second
5524 integer to write in the message. */
5527 post_error_ne_tree_2 (msg
, node
, ent
, t
, num
)
5534 Error_Msg_Uint_2
= UI_From_Int (num
);
5535 post_error_ne_tree (msg
, node
, ent
, t
);
5538 /* Set the node for a second '&' in the error message. */
5541 set_second_error_entity (e
)
5544 Error_Msg_Node_2
= e
;
5547 /* Signal abort, with "Gigi abort" as the error label, and error_gnat_node
5548 as the relevant node that provides the location info for the error */
5554 String_Template temp
= {1, 10};
5557 fp
.Array
= "Gigi abort", fp
.Bounds
= &temp
;
5559 Current_Error_Node
= error_gnat_node
;
5560 Compiler_Abort (fp
, code
);
5563 /* Initialize the table that maps GNAT codes to GCC codes for simple
5564 binary and unary operations. */
5569 gnu_codes
[N_And_Then
] = TRUTH_ANDIF_EXPR
;
5570 gnu_codes
[N_Or_Else
] = TRUTH_ORIF_EXPR
;
5572 gnu_codes
[N_Op_And
] = TRUTH_AND_EXPR
;
5573 gnu_codes
[N_Op_Or
] = TRUTH_OR_EXPR
;
5574 gnu_codes
[N_Op_Xor
] = TRUTH_XOR_EXPR
;
5575 gnu_codes
[N_Op_Eq
] = EQ_EXPR
;
5576 gnu_codes
[N_Op_Ne
] = NE_EXPR
;
5577 gnu_codes
[N_Op_Lt
] = LT_EXPR
;
5578 gnu_codes
[N_Op_Le
] = LE_EXPR
;
5579 gnu_codes
[N_Op_Gt
] = GT_EXPR
;
5580 gnu_codes
[N_Op_Ge
] = GE_EXPR
;
5581 gnu_codes
[N_Op_Add
] = PLUS_EXPR
;
5582 gnu_codes
[N_Op_Subtract
] = MINUS_EXPR
;
5583 gnu_codes
[N_Op_Multiply
] = MULT_EXPR
;
5584 gnu_codes
[N_Op_Mod
] = FLOOR_MOD_EXPR
;
5585 gnu_codes
[N_Op_Rem
] = TRUNC_MOD_EXPR
;
5586 gnu_codes
[N_Op_Minus
] = NEGATE_EXPR
;
5587 gnu_codes
[N_Op_Abs
] = ABS_EXPR
;
5588 gnu_codes
[N_Op_Not
] = TRUTH_NOT_EXPR
;
5589 gnu_codes
[N_Op_Rotate_Left
] = LROTATE_EXPR
;
5590 gnu_codes
[N_Op_Rotate_Right
] = RROTATE_EXPR
;
5591 gnu_codes
[N_Op_Shift_Left
] = LSHIFT_EXPR
;
5592 gnu_codes
[N_Op_Shift_Right
] = RSHIFT_EXPR
;
5593 gnu_codes
[N_Op_Shift_Right_Arithmetic
] = RSHIFT_EXPR
;
5596 #include "gt-ada-trans.h"