1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
11 * Copyright (C) 1992-2001, Free Software Foundation, Inc. *
13 * GNAT is free software; you can redistribute it and/or modify it under *
14 * terms of the GNU General Public License as published by the Free Soft- *
15 * ware Foundation; either version 2, or (at your option) any later ver- *
16 * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
17 * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
18 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
19 * for more details. You should have received a copy of the GNU General *
20 * Public License distributed with GNAT; see file COPYING. If not, write *
21 * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
22 * MA 02111-1307, USA. *
24 * GNAT was originally developed by the GNAT team at New York University. *
25 * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
27 ****************************************************************************/
58 struct Node
*Nodes_Ptr
;
59 Node_Id
*Next_Node_Ptr
;
60 Node_Id
*Prev_Node_Ptr
;
61 struct Elist_Header
*Elists_Ptr
;
62 struct Elmt_Item
*Elmts_Ptr
;
63 struct String_Entry
*Strings_Ptr
;
64 Char_Code
*String_Chars_Ptr
;
65 struct List_Header
*List_Headers_Ptr
;
67 /* Current filename without path. */
68 const char *ref_filename
;
70 /* Flag indicating whether file names are discarded in exception messages */
71 int discard_file_names
;
73 /* If true, then gigi is being called on an analyzed but unexpanded
74 tree, and the only purpose of the call is to properly annotate
75 types with representation information. */
76 int type_annotate_only
;
78 /* List of TREE_LIST nodes representing a block stack. TREE_VALUE
79 of each gives the variable used for the setjmp buffer in the current
80 block, if any. TREE_PURPOSE gives the bottom condition for a loop,
81 if this block is for a loop. The latter is only used to save the tree
85 /* List of TREE_LIST nodes representing a stack of exception pointer
86 variables. TREE_VALUE is the VAR_DECL that stores the address of
87 the raised exception. Nonzero means we are in an exception
88 handler. Set to error_mark_node in the zero-cost case. */
89 static tree gnu_except_ptr_stack
;
91 /* Map GNAT tree codes to GCC tree codes for simple expressions. */
92 static enum tree_code gnu_codes
[Number_Node_Kinds
];
94 /* Current node being treated, in case gigi_abort called. */
95 Node_Id error_gnat_node
;
97 /* Variable that stores a list of labels to be used as a goto target instead of
98 a return in some functions. See processing for N_Subprogram_Body. */
99 static tree gnu_return_label_stack
;
101 static tree tree_transform
PARAMS((Node_Id
));
102 static void elaborate_all_entities
PARAMS((Node_Id
));
103 static void process_freeze_entity
PARAMS((Node_Id
));
104 static void process_inlined_subprograms
PARAMS((Node_Id
));
105 static void process_decls
PARAMS((List_Id
, List_Id
, Node_Id
,
107 static tree emit_access_check
PARAMS((tree
));
108 static tree emit_discriminant_check
PARAMS((tree
, Node_Id
));
109 static tree emit_range_check
PARAMS((tree
, Node_Id
));
110 static tree emit_index_check
PARAMS((tree
, tree
, tree
, tree
));
111 static tree emit_check
PARAMS((tree
, tree
));
112 static tree convert_with_check
PARAMS((Entity_Id
, tree
,
114 static int addressable_p
PARAMS((tree
));
115 static tree assoc_to_constructor
PARAMS((Node_Id
, tree
));
116 static tree extract_values
PARAMS((tree
, tree
));
117 static tree pos_to_constructor
PARAMS((Node_Id
, tree
, Entity_Id
));
118 static tree maybe_implicit_deref
PARAMS((tree
));
119 static tree gnat_stabilize_reference_1
PARAMS((tree
, int));
120 static int build_unit_elab
PARAMS((Entity_Id
, int, tree
));
122 /* Constants for +0.5 and -0.5 for float-to-integer rounding. */
123 static REAL_VALUE_TYPE dconstp5
;
124 static REAL_VALUE_TYPE dconstmp5
;
126 /* This is the main program of the back-end. It sets up all the table
127 structures and then generates code. */
130 gigi (gnat_root
, max_gnat_node
, number_name
,
131 nodes_ptr
, next_node_ptr
, prev_node_ptr
, elists_ptr
, elmts_ptr
,
132 strings_ptr
, string_chars_ptr
, list_headers_ptr
,
133 number_units
, file_info_ptr
,
134 standard_integer
, standard_long_long_float
, standard_exception_type
,
141 struct Node
*nodes_ptr
;
142 Node_Id
*next_node_ptr
;
143 Node_Id
*prev_node_ptr
;
144 struct Elist_Header
*elists_ptr
;
145 struct Elmt_Item
*elmts_ptr
;
146 struct String_Entry
*strings_ptr
;
147 Char_Code
*string_chars_ptr
;
148 struct List_Header
*list_headers_ptr
;
149 Int number_units ATTRIBUTE_UNUSED
;
150 char *file_info_ptr ATTRIBUTE_UNUSED
;
152 Entity_Id standard_integer
;
153 Entity_Id standard_long_long_float
;
154 Entity_Id standard_exception_type
;
156 Int gigi_operating_mode
;
158 max_gnat_nodes
= max_gnat_node
;
159 number_names
= number_name
;
160 Nodes_Ptr
= nodes_ptr
- First_Node_Id
;
161 Next_Node_Ptr
= next_node_ptr
- First_Node_Id
;
162 Prev_Node_Ptr
= prev_node_ptr
- First_Node_Id
;
163 Elists_Ptr
= elists_ptr
- First_Elist_Id
;
164 Elmts_Ptr
= elmts_ptr
- First_Elmt_Id
;
165 Strings_Ptr
= strings_ptr
- First_String_Id
;
166 String_Chars_Ptr
= string_chars_ptr
;
167 List_Headers_Ptr
= list_headers_ptr
- First_List_Id
;
169 type_annotate_only
= (gigi_operating_mode
== 1);
171 /* See if we should discard file names in exception messages. */
172 discard_file_names
= (Global_Discard_Names
|| Debug_Flag_NN
);
174 if (Nkind (gnat_root
) != N_Compilation_Unit
)
177 set_lineno (gnat_root
, 0);
179 /* Initialize ourselves. */
184 /* Enable GNAT stack checking method if needed */
185 if (!Stack_Check_Probes_On_Target
)
186 set_stack_check_libfunc (gen_rtx (SYMBOL_REF
, Pmode
, "_gnat_stack_check"));
188 /* Save the type we made for integer as the type for Standard.Integer.
189 Then make the rest of the standard types. Note that some of these
191 save_gnu_tree (Base_Type (standard_integer
),
192 TYPE_NAME (integer_type_node
), 0);
194 ggc_add_tree_root (&gnu_block_stack
, 1);
195 ggc_add_tree_root (&gnu_except_ptr_stack
, 1);
196 ggc_add_tree_root (&gnu_return_label_stack
, 1);
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 init_gigi_decls (gnat_to_gnu_entity (Base_Type (standard_long_long_float
),
204 gnat_to_gnu_entity (Base_Type (standard_exception_type
),
207 /* Emit global symbols containing context list info for the SGI Workshop
210 #ifdef MIPS_DEBUGGING_INFO
211 if (Spec_Context_List
!= 0)
212 emit_unit_label (Spec_Context_List
, Spec_Filename
);
214 if (Body_Context_List
!= 0)
215 emit_unit_label (Body_Context_List
, Body_Filename
);
218 #ifdef ASM_OUTPUT_IDENT
219 if (Present (Ident_String (Main_Unit
)))
222 TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit
))));
225 gnat_to_code (gnat_root
);
229 /* This function is the driver of the GNAT to GCC tree transformation process.
230 GNAT_NODE is the root of some gnat tree. It generates code for that
234 gnat_to_code (gnat_node
)
239 /* Save node number in case error */
240 error_gnat_node
= gnat_node
;
242 gnu_root
= tree_transform (gnat_node
);
244 /* This should just generate code, not return a value. If it returns
245 a value, something is wrong. */
246 if (gnu_root
!= error_mark_node
)
250 /* GNAT_NODE is the root of some GNAT tree. Return the root of the GCC
251 tree corresponding to that GNAT tree. Normally, no code is generated.
252 We just return an equivalent tree which is used elsewhere to generate
256 gnat_to_gnu (gnat_node
)
261 /* Save node number in case error */
262 error_gnat_node
= gnat_node
;
264 gnu_root
= tree_transform (gnat_node
);
266 /* If we got no code as a result, something is wrong. */
267 if (gnu_root
== error_mark_node
&& ! type_annotate_only
)
273 /* This function is the driver of the GNAT to GCC tree transformation process.
274 It is the entry point of the tree transformer. GNAT_NODE is the root of
275 some GNAT tree. Return the root of the corresponding GCC tree or
276 error_mark_node to signal that there is no GCC tree to return.
278 The latter is the case if only code generation actions have to be performed
279 like in the case of if statements, loops, etc. This routine is wrapped
280 in the above two routines for most purposes. */
283 tree_transform (gnat_node
)
286 tree gnu_result
= error_mark_node
; /* Default to no value. */
287 tree gnu_result_type
= void_type_node
;
289 tree gnu_lhs
, gnu_rhs
;
291 Entity_Id gnat_temp_type
;
293 /* Set input_file_name and lineno from the Sloc in the GNAT tree. */
294 set_lineno (gnat_node
, 0);
296 /* If this is a Statement and we are at top level, we add the statement
297 as an elaboration for a null tree. That will cause it to be placed
298 in the elaboration procedure. */
299 if (global_bindings_p ()
300 && ((IN (Nkind (gnat_node
), N_Statement_Other_Than_Procedure_Call
)
301 && Nkind (gnat_node
) != N_Null_Statement
)
302 || Nkind (gnat_node
) == N_Procedure_Call_Statement
303 || Nkind (gnat_node
) == N_Label
304 || (Nkind (gnat_node
) == N_Handled_Sequence_Of_Statements
305 && (Present (Exception_Handlers (gnat_node
))
306 || Present (At_End_Proc (gnat_node
))))
307 || ((Nkind (gnat_node
) == N_Raise_Constraint_Error
308 || Nkind (gnat_node
) == N_Raise_Storage_Error
309 || Nkind (gnat_node
) == N_Raise_Program_Error
)
310 && (Ekind (Etype (gnat_node
)) == E_Void
))))
312 add_pending_elaborations (NULL_TREE
, make_transform_expr (gnat_node
));
314 return error_mark_node
;
317 /* If this node is a non-static subexpression and we are only
318 annotating types, make this into a NULL_EXPR for non-VOID types
319 and error_mark_node for void return types. But allow
320 N_Identifier since we use it for lots of things, including
321 getting trees for discriminants. */
323 if (type_annotate_only
324 && IN (Nkind (gnat_node
), N_Subexpr
)
325 && Nkind (gnat_node
) != N_Identifier
326 && ! Compile_Time_Known_Value (gnat_node
))
328 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
330 if (TREE_CODE (gnu_result_type
) == VOID_TYPE
)
331 return error_mark_node
;
333 return build1 (NULL_EXPR
, gnu_result_type
,
334 build_call_raise (raise_constraint_error_decl
));
337 switch (Nkind (gnat_node
))
339 /********************************/
340 /* Chapter 2: Lexical Elements: */
341 /********************************/
344 case N_Expanded_Name
:
345 case N_Operator_Symbol
:
346 case N_Defining_Identifier
:
348 /* If the Etype of this node does not equal the Etype of the
349 Entity, something is wrong with the entity map, probably in
350 generic instantiation. However, this does not apply to
351 types. Since we sometime have strange Ekind's, just do
352 this test for objects. Also, if the Etype of the Entity
353 is private, the Etype of the N_Identifier is allowed to be the
354 full type and also we consider a packed array type to be the
355 same as the original type. Finally, if the types are Itypes,
356 one may be a copy of the other, which is also legal. */
358 gnat_temp
= (Nkind (gnat_node
) == N_Defining_Identifier
359 ? gnat_node
: Entity (gnat_node
));
360 gnat_temp_type
= Etype (gnat_temp
);
362 if (Etype (gnat_node
) != gnat_temp_type
363 && ! (Is_Packed (gnat_temp_type
)
364 && Etype (gnat_node
) == Packed_Array_Type (gnat_temp_type
))
365 && ! (IN (Ekind (gnat_temp_type
), Private_Kind
)
366 && Present (Full_View (gnat_temp_type
))
367 && ((Etype (gnat_node
) == Full_View (gnat_temp_type
))
368 || (Is_Packed (Full_View (gnat_temp_type
))
369 && Etype (gnat_node
) ==
370 Packed_Array_Type (Full_View (gnat_temp_type
)))))
371 && (!Is_Itype (Etype (gnat_node
)) || !Is_Itype (gnat_temp_type
))
372 && (Ekind (gnat_temp
) == E_Variable
373 || Ekind (gnat_temp
) == E_Component
374 || Ekind (gnat_temp
) == E_Constant
375 || Ekind (gnat_temp
) == E_Loop_Parameter
376 || IN (Ekind (gnat_temp
), Formal_Kind
)))
379 /* If this is a reference to a deferred constant whose partial view
380 is an unconstrained private type, the proper type is on the full
381 view of the constant, not on the full view of the type, which may
384 This may be a reference to a type, for example in the prefix of the
385 attribute Position, generated for dispatching code (see Make_DT in
386 exp_disp,adb). In that case we need the type itself, not is parent,
387 in particular if it is a derived type */
389 if (Is_Private_Type (gnat_temp_type
)
390 && Has_Unknown_Discriminants (gnat_temp_type
)
391 && Present (Full_View (gnat_temp
))
392 && ! Is_Type (gnat_temp
))
394 gnat_temp
= Full_View (gnat_temp
);
395 gnat_temp_type
= Etype (gnat_temp
);
396 gnu_result_type
= get_unpadded_type (gnat_temp_type
);
400 /* Expand the type of this identitier first, in case it is
401 an enumeral literal, which only get made when the type
402 is expanded. There is no order-of-elaboration issue here.
403 We want to use the Actual_Subtype if it has already been
404 elaborated, otherwise the Etype. Avoid using Actual_Subtype
405 for packed arrays to simplify things. */
406 if ((Ekind (gnat_temp
) == E_Constant
407 || Ekind (gnat_temp
) == E_Variable
|| Is_Formal (gnat_temp
))
408 && ! (Is_Array_Type (Etype (gnat_temp
))
409 && Present (Packed_Array_Type (Etype (gnat_temp
))))
410 && Present (Actual_Subtype (gnat_temp
))
411 && present_gnu_tree (Actual_Subtype (gnat_temp
)))
412 gnat_temp_type
= Actual_Subtype (gnat_temp
);
414 gnat_temp_type
= Etype (gnat_node
);
416 gnu_result_type
= get_unpadded_type (gnat_temp_type
);
419 gnu_result
= gnat_to_gnu_entity (gnat_temp
, NULL_TREE
, 0);
421 /* If we are in an exception handler, force this variable into memory
422 to ensure optimization does not remove stores that appear
423 redundant but are actually needed in case an exception occurs.
425 ??? Note that we need not do this if the variable is declared within
426 the handler, only if it is referenced in the handler and declared
427 in an enclosing block, but we have no way of testing that
429 if (TREE_VALUE (gnu_except_ptr_stack
) != 0)
431 mark_addressable (gnu_result
);
432 flush_addressof (gnu_result
);
435 /* Some objects (such as parameters passed by reference, globals of
436 variable size, and renamed objects) actually represent the address
437 of the object. In that case, we must do the dereference. Likewise,
438 deal with parameters to foreign convention subprograms. Call fold
439 here since GNU_RESULT may be a CONST_DECL. */
440 if (DECL_P (gnu_result
)
441 && (DECL_BY_REF_P (gnu_result
)
442 || DECL_BY_COMPONENT_PTR_P (gnu_result
)))
444 int ro
= DECL_POINTS_TO_READONLY_P (gnu_result
);
446 if (DECL_BY_COMPONENT_PTR_P (gnu_result
))
447 gnu_result
= convert (build_pointer_type (gnu_result_type
),
450 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
,
452 TREE_READONLY (gnu_result
) = TREE_STATIC (gnu_result
) = ro
;
455 /* The GNAT tree has the type of a function as the type of its result.
456 Also use the type of the result if the Etype is a subtype which
457 is nominally unconstrained. But remove any padding from the
459 if (TREE_CODE (TREE_TYPE (gnu_result
)) == FUNCTION_TYPE
460 || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type
))
462 gnu_result_type
= TREE_TYPE (gnu_result
);
463 if (TREE_CODE (gnu_result_type
) == RECORD_TYPE
464 && TYPE_IS_PADDING_P (gnu_result_type
))
465 gnu_result_type
= TREE_TYPE (TYPE_FIELDS (gnu_result_type
));
468 /* We always want to return the underlying INTEGER_CST for an
469 enumeration literal to avoid the need to call fold in lots
470 of places. But don't do this is the parent will be taking
471 the address of this object. */
472 if (TREE_CODE (gnu_result
) == CONST_DECL
)
474 gnat_temp
= Parent (gnat_node
);
475 if (DECL_CONST_CORRESPONDING_VAR (gnu_result
) == 0
476 || (Nkind (gnat_temp
) != N_Reference
477 && ! (Nkind (gnat_temp
) == N_Attribute_Reference
478 && ((Get_Attribute_Id (Attribute_Name (gnat_temp
))
480 || (Get_Attribute_Id (Attribute_Name (gnat_temp
))
482 || (Get_Attribute_Id (Attribute_Name (gnat_temp
))
483 == Attr_Unchecked_Access
)
484 || (Get_Attribute_Id (Attribute_Name (gnat_temp
))
485 == Attr_Unrestricted_Access
)))))
486 gnu_result
= DECL_INITIAL (gnu_result
);
490 case N_Integer_Literal
:
494 /* Get the type of the result, looking inside any padding and
495 left-justified modular types. Then get the value in that type. */
496 gnu_type
= gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
498 if (TREE_CODE (gnu_type
) == RECORD_TYPE
499 && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_type
))
500 gnu_type
= TREE_TYPE (TYPE_FIELDS (gnu_type
));
502 gnu_result
= UI_To_gnu (Intval (gnat_node
), gnu_type
);
503 /* Get the type of the result, looking inside any padding and
504 left-justified modular types. Then get the value in that type. */
505 gnu_type
= gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
507 if (TREE_CODE (gnu_type
) == RECORD_TYPE
508 && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_type
))
509 gnu_type
= TREE_TYPE (TYPE_FIELDS (gnu_type
));
511 gnu_result
= UI_To_gnu (Intval (gnat_node
), gnu_type
);
513 /* If the result overflows (meaning it doesn't fit in its base type)
514 or is outside of the range of the subtype, we have an illegal tree
515 entry, so abort. Note that the test for of types with biased
516 representation is harder, so we don't test in that case. */
517 if (TREE_CONSTANT_OVERFLOW (gnu_result
)
518 || (TREE_CODE (TYPE_MIN_VALUE (gnu_result_type
)) == INTEGER_CST
519 && ! TYPE_BIASED_REPRESENTATION_P (gnu_result_type
)
520 && tree_int_cst_lt (gnu_result
,
521 TYPE_MIN_VALUE (gnu_result_type
)))
522 || (TREE_CODE (TYPE_MAX_VALUE (gnu_result_type
)) == INTEGER_CST
523 && ! TYPE_BIASED_REPRESENTATION_P (gnu_result_type
)
524 && tree_int_cst_lt (TYPE_MAX_VALUE (gnu_result_type
),
530 case N_Character_Literal
:
531 /* If a Entity is present, it means that this was one of the
532 literals in a user-defined character type. In that case,
533 just return the value in the CONST_DECL. Otherwise, use the
534 character code. In that case, the base type should be an
535 INTEGER_TYPE, but we won't bother checking for that. */
536 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
537 if (Present (Entity (gnat_node
)))
538 gnu_result
= DECL_INITIAL (get_gnu_tree (Entity (gnat_node
)));
540 gnu_result
= convert (gnu_result_type
,
541 build_int_2 (Char_Literal_Value (gnat_node
), 0));
545 /* If this is of a fixed-point type, the value we want is the
546 value of the corresponding integer. */
547 if (IN (Ekind (Underlying_Type (Etype (gnat_node
))), Fixed_Point_Kind
))
549 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
550 gnu_result
= UI_To_gnu (Corresponding_Integer_Value (gnat_node
),
552 if (TREE_CONSTANT_OVERFLOW (gnu_result
)
554 || (TREE_CODE (TYPE_MIN_VALUE (gnu_result_type
)) == INTEGER_CST
555 && tree_int_cst_lt (gnu_result
,
556 TYPE_MIN_VALUE (gnu_result_type
)))
557 || (TREE_CODE (TYPE_MAX_VALUE (gnu_result_type
)) == INTEGER_CST
558 && tree_int_cst_lt (TYPE_MAX_VALUE (gnu_result_type
),
564 /* We should never see a Vax_Float type literal, since the front end
565 is supposed to transform these using appropriate conversions */
566 else if (Vax_Float (Underlying_Type (Etype (gnat_node
))))
571 Ureal ur_realval
= Realval (gnat_node
);
573 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
575 /* If the real value is zero, so is the result. Otherwise,
576 convert it to a machine number if it isn't already. That
577 forces BASE to 0 or 2 and simplifies the rest of our logic. */
578 if (UR_Is_Zero (ur_realval
))
579 gnu_result
= convert (gnu_result_type
, integer_zero_node
);
582 if (! Is_Machine_Number (gnat_node
))
584 Machine (Base_Type (Underlying_Type (Etype (gnat_node
))),
588 = UI_To_gnu (Numerator (ur_realval
), gnu_result_type
);
590 /* If we have a base of zero, divide by the denominator.
591 Otherwise, the base must be 2 and we scale the value, which
592 we know can fit in the mantissa of the type (hence the use
593 of that type above). */
594 if (Rbase (ur_realval
) == 0)
596 = build_binary_op (RDIV_EXPR
,
597 get_base_type (gnu_result_type
),
599 UI_To_gnu (Denominator (ur_realval
),
601 else if (Rbase (ur_realval
) != 2)
606 = build_real (gnu_result_type
,
608 (TREE_REAL_CST (gnu_result
),
609 - UI_To_Int (Denominator (ur_realval
))));
612 /* Now see if we need to negate the result. Do it this way to
613 properly handle -0. */
614 if (UR_Is_Negative (Realval (gnat_node
)))
616 = build_unary_op (NEGATE_EXPR
, get_base_type (gnu_result_type
),
622 case N_String_Literal
:
623 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
624 if (TYPE_PRECISION (TREE_TYPE (gnu_result_type
)) == HOST_BITS_PER_CHAR
)
626 /* We assume here that all strings are of type standard.string.
627 "Weird" types of string have been converted to an aggregate
629 String_Id gnat_string
= Strval (gnat_node
);
630 int length
= String_Length (gnat_string
);
631 char *string
= (char *) alloca (length
+ 1);
634 /* Build the string with the characters in the literal. Note
635 that Ada strings are 1-origin. */
636 for (i
= 0; i
< length
; i
++)
637 string
[i
] = Get_String_Char (gnat_string
, i
+ 1);
639 /* Put a null at the end of the string in case it's in a context
640 where GCC will want to treat it as a C string. */
643 gnu_result
= build_string (length
, string
);
645 /* Strings in GCC don't normally have types, but we want
646 this to not be converted to the array type. */
647 TREE_TYPE (gnu_result
) = gnu_result_type
;
651 /* Build a list consisting of each character, then make
653 String_Id gnat_string
= Strval (gnat_node
);
654 int length
= String_Length (gnat_string
);
656 tree gnu_list
= NULL_TREE
;
658 for (i
= 0; i
< length
; i
++)
660 = tree_cons (NULL_TREE
,
661 convert (TREE_TYPE (gnu_result_type
),
662 build_int_2 (Get_String_Char (gnat_string
,
668 = build_constructor (gnu_result_type
, nreverse (gnu_list
));
673 if (type_annotate_only
)
676 /* Check for (and ignore) unrecognized pragma */
677 if (! Is_Pragma_Name (Chars (gnat_node
)))
680 switch (Get_Pragma_Id (Chars (gnat_node
)))
682 case Pragma_Inspection_Point
:
683 /* Do nothing at top level: all such variables are already
685 if (global_bindings_p ())
688 set_lineno (gnat_node
, 1);
689 for (gnat_temp
= First (Pragma_Argument_Associations (gnat_node
));
691 gnat_temp
= Next (gnat_temp
))
693 gnu_expr
= gnat_to_gnu (Expression (gnat_temp
));
694 if (TREE_CODE (gnu_expr
) == UNCONSTRAINED_ARRAY_REF
)
695 gnu_expr
= TREE_OPERAND (gnu_expr
, 0);
697 gnu_expr
= build1 (USE_EXPR
, void_type_node
, gnu_expr
);
698 TREE_SIDE_EFFECTS (gnu_expr
) = 1;
699 expand_expr_stmt (gnu_expr
);
703 case Pragma_Optimize
:
704 switch (Chars (Expression
705 (First (Pragma_Argument_Associations (gnat_node
)))))
707 case Name_Time
: case Name_Space
:
709 post_error ("insufficient -O value?", gnat_node
);
714 post_error ("must specify -O0?", gnat_node
);
723 case Pragma_Reviewable
:
724 if (write_symbols
== NO_DEBUG
)
725 post_error ("must specify -g?", gnat_node
);
730 /**************************************/
731 /* Chapter 3: Declarations and Types: */
732 /**************************************/
734 case N_Subtype_Declaration
:
735 case N_Full_Type_Declaration
:
736 case N_Incomplete_Type_Declaration
:
737 case N_Private_Type_Declaration
:
738 case N_Private_Extension_Declaration
:
739 case N_Task_Type_Declaration
:
740 process_type (Defining_Entity (gnat_node
));
743 case N_Object_Declaration
:
744 case N_Exception_Declaration
:
745 gnat_temp
= Defining_Entity (gnat_node
);
747 /* If we are just annotating types and this object has an unconstrained
748 or task type, don't elaborate it. */
749 if (type_annotate_only
750 && (((Is_Array_Type (Etype (gnat_temp
))
751 || Is_Record_Type (Etype (gnat_temp
)))
752 && ! Is_Constrained (Etype (gnat_temp
)))
753 || Is_Concurrent_Type (Etype (gnat_temp
))))
756 if (Present (Expression (gnat_node
))
757 && ! (Nkind (gnat_node
) == N_Object_Declaration
758 && No_Initialization (gnat_node
))
759 && (! type_annotate_only
760 || Compile_Time_Known_Value (Expression (gnat_node
))))
762 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
763 if (Do_Range_Check (Expression (gnat_node
)))
764 gnu_expr
= emit_range_check (gnu_expr
, Etype (gnat_temp
));
766 /* If this object has its elaboration delayed, we must force
767 evaluation of GNU_EXPR right now and save it for when the object
769 if (Present (Freeze_Node (gnat_temp
)))
771 if ((Is_Public (gnat_temp
) || global_bindings_p ())
772 && ! TREE_CONSTANT (gnu_expr
))
774 = create_var_decl (create_concat_name (gnat_temp
, "init"),
775 NULL_TREE
, TREE_TYPE (gnu_expr
), gnu_expr
,
776 0, Is_Public (gnat_temp
), 0, 0, 0);
778 gnu_expr
= maybe_variable (gnu_expr
, Expression (gnat_node
));
780 save_gnu_tree (gnat_node
, gnu_expr
, 1);
786 if (type_annotate_only
&& gnu_expr
!= 0
787 && TREE_CODE (gnu_expr
) == ERROR_MARK
)
790 if (No (Freeze_Node (gnat_temp
)))
791 gnat_to_gnu_entity (gnat_temp
, gnu_expr
, 1);
794 case N_Object_Renaming_Declaration
:
796 gnat_temp
= Defining_Entity (gnat_node
);
798 /* Don't do anything if this renaming handled by the front end.
799 or if we are just annotating types and this object has an
800 unconstrained or task type, don't elaborate it. */
801 if (! Is_Renaming_Of_Object (gnat_temp
)
802 && ! (type_annotate_only
803 && (((Is_Array_Type (Etype (gnat_temp
))
804 || Is_Record_Type (Etype (gnat_temp
)))
805 && ! Is_Constrained (Etype (gnat_temp
)))
806 || Is_Concurrent_Type (Etype (gnat_temp
)))))
808 gnu_expr
= gnat_to_gnu (Renamed_Object (gnat_temp
));
809 gnat_to_gnu_entity (gnat_temp
, gnu_expr
, 1);
813 case N_Implicit_Label_Declaration
:
814 gnat_to_gnu_entity (Defining_Entity (gnat_node
), NULL_TREE
, 1);
817 case N_Subprogram_Renaming_Declaration
:
818 case N_Package_Renaming_Declaration
:
819 case N_Exception_Renaming_Declaration
:
820 case N_Number_Declaration
:
821 /* These are fully handled in the front end. */
824 /*************************************/
825 /* Chapter 4: Names and Expressions: */
826 /*************************************/
828 case N_Explicit_Dereference
:
829 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
830 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
832 /* Emit access check if necessary */
833 if (Do_Access_Check (gnat_node
))
834 gnu_result
= emit_access_check (gnu_result
);
836 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_result
);
839 case N_Indexed_Component
:
841 tree gnu_array_object
= gnat_to_gnu (Prefix (gnat_node
));
845 Node_Id
*gnat_expr_array
;
847 /* Emit access check if necessary */
848 if (Do_Access_Check (gnat_node
))
849 gnu_array_object
= emit_access_check (gnu_array_object
);
851 gnu_array_object
= maybe_implicit_deref (gnu_array_object
);
852 gnu_array_object
= maybe_unconstrained_array (gnu_array_object
);
854 /* If we got a padded type, remove it too. */
855 if (TREE_CODE (TREE_TYPE (gnu_array_object
)) == RECORD_TYPE
856 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object
)))
858 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object
))),
861 gnu_result
= gnu_array_object
;
863 /* First compute the number of dimensions of the array, then
864 fill the expression array, the order depending on whether
865 this is a Convention_Fortran array or not. */
866 for (ndim
= 1, gnu_type
= TREE_TYPE (gnu_array_object
);
867 TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
868 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
));
869 ndim
++, gnu_type
= TREE_TYPE (gnu_type
))
872 gnat_expr_array
= (Node_Id
*) alloca (ndim
* sizeof (Node_Id
));
874 if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object
)))
875 for (i
= ndim
- 1, gnat_temp
= First (Expressions (gnat_node
));
877 i
--, gnat_temp
= Next (gnat_temp
))
878 gnat_expr_array
[i
] = gnat_temp
;
880 for (i
= 0, gnat_temp
= First (Expressions (gnat_node
));
882 i
++, gnat_temp
= Next (gnat_temp
))
883 gnat_expr_array
[i
] = gnat_temp
;
885 for (i
= 0, gnu_type
= TREE_TYPE (gnu_array_object
);
886 i
< ndim
; i
++, gnu_type
= TREE_TYPE (gnu_type
))
888 if (TREE_CODE (gnu_type
) != ARRAY_TYPE
)
891 gnat_temp
= gnat_expr_array
[i
];
892 gnu_expr
= gnat_to_gnu (gnat_temp
);
894 if (Do_Range_Check (gnat_temp
))
897 (gnu_array_object
, gnu_expr
,
898 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))),
899 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))));
901 gnu_result
= build_binary_op (ARRAY_REF
, NULL_TREE
,
902 gnu_result
, gnu_expr
);
906 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
912 Node_Id gnat_range_node
= Discrete_Range (gnat_node
);
914 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
915 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
917 /* Emit access check if necessary */
918 if (Do_Access_Check (gnat_node
))
919 gnu_result
= emit_access_check (gnu_result
);
921 /* Do any implicit dereferences of the prefix and do any needed
923 gnu_result
= maybe_implicit_deref (gnu_result
);
924 gnu_result
= maybe_unconstrained_array (gnu_result
);
925 gnu_type
= TREE_TYPE (gnu_result
);
926 if (Do_Range_Check (gnat_range_node
))
928 /* Get the bounds of the slice. */
930 = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_result_type
));
931 tree gnu_min_expr
= TYPE_MIN_VALUE (gnu_index_type
);
932 tree gnu_max_expr
= TYPE_MAX_VALUE (gnu_index_type
);
933 tree gnu_expr_l
, gnu_expr_h
, gnu_expr_type
;
935 /* Check to see that the minimum slice value is in range */
938 (gnu_result
, gnu_min_expr
,
939 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))),
940 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))));
942 /* Check to see that the maximum slice value is in range */
945 (gnu_result
, gnu_max_expr
,
946 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))),
947 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))));
949 /* Derive a good type to convert everything too */
950 gnu_expr_type
= get_base_type (TREE_TYPE (gnu_expr_l
));
952 /* Build a compound expression that does the range checks */
954 = build_binary_op (COMPOUND_EXPR
, gnu_expr_type
,
955 convert (gnu_expr_type
, gnu_expr_h
),
956 convert (gnu_expr_type
, gnu_expr_l
));
958 /* Build a conditional expression that returns the range checks
959 expression if the slice range is not null (max >= min) or
960 returns the min if the slice range is null */
962 = fold (build (COND_EXPR
, gnu_expr_type
,
963 build_binary_op (GE_EXPR
, gnu_expr_type
,
964 convert (gnu_expr_type
,
966 convert (gnu_expr_type
,
968 gnu_expr
, gnu_min_expr
));
971 gnu_expr
= TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type
));
973 gnu_result
= build_binary_op (ARRAY_RANGE_REF
, gnu_result_type
,
974 gnu_result
, gnu_expr
);
978 case N_Selected_Component
:
980 tree gnu_prefix
= gnat_to_gnu (Prefix (gnat_node
));
981 Entity_Id gnat_field
= Entity (Selector_Name (gnat_node
));
982 Entity_Id gnat_pref_type
= Etype (Prefix (gnat_node
));
985 while (IN (Ekind (gnat_pref_type
), Incomplete_Or_Private_Kind
)
986 || IN (Ekind (gnat_pref_type
), Access_Kind
))
988 if (IN (Ekind (gnat_pref_type
), Incomplete_Or_Private_Kind
))
989 gnat_pref_type
= Underlying_Type (gnat_pref_type
);
990 else if (IN (Ekind (gnat_pref_type
), Access_Kind
))
991 gnat_pref_type
= Designated_Type (gnat_pref_type
);
994 if (Do_Access_Check (gnat_node
))
995 gnu_prefix
= emit_access_check (gnu_prefix
);
997 gnu_prefix
= maybe_implicit_deref (gnu_prefix
);
999 /* For discriminant references in tagged types always substitute the
1000 corresponding discriminant as the actual selected component. */
1002 if (Is_Tagged_Type (gnat_pref_type
))
1003 while (Present (Corresponding_Discriminant (gnat_field
)))
1004 gnat_field
= Corresponding_Discriminant (gnat_field
);
1006 /* For discriminant references of untagged types always substitute the
1007 corresponding girder discriminant. */
1009 else if (Present (Corresponding_Discriminant (gnat_field
)))
1010 gnat_field
= Original_Record_Component (gnat_field
);
1012 /* Handle extracting the real or imaginary part of a complex.
1013 The real part is the first field and the imaginary the last. */
1015 if (TREE_CODE (TREE_TYPE (gnu_prefix
)) == COMPLEX_TYPE
)
1016 gnu_result
= build_unary_op (Present (Next_Entity (gnat_field
))
1017 ? REALPART_EXPR
: IMAGPART_EXPR
,
1018 NULL_TREE
, gnu_prefix
);
1021 gnu_field
= gnat_to_gnu_entity (gnat_field
, NULL_TREE
, 0);
1023 /* If there are discriminants, the prefix might be
1024 evaluated more than once, which is a problem if it has
1027 if (Has_Discriminants (Is_Access_Type (Etype (Prefix (gnat_node
)))
1028 ? Designated_Type (Etype
1029 (Prefix (gnat_node
)))
1030 : Etype (Prefix (gnat_node
)))
1031 && TREE_SIDE_EFFECTS (gnu_prefix
))
1032 gnu_prefix
= make_save_expr (gnu_prefix
);
1034 /* Emit discriminant check if necessary. */
1035 if (Do_Discriminant_Check (gnat_node
))
1036 gnu_prefix
= emit_discriminant_check (gnu_prefix
, gnat_node
);
1038 = build_component_ref (gnu_prefix
, NULL_TREE
, gnu_field
);
1041 if (gnu_result
== 0)
1044 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1048 case N_Attribute_Reference
:
1050 /* The attribute designator (like an enumeration value). */
1051 int attribute
= Get_Attribute_Id (Attribute_Name (gnat_node
));
1052 int prefix_unused
= 0;
1056 /* The Elab_Spec and Elab_Body attributes are special in that
1057 Prefix is a unit, not an object with a GCC equivalent. Similarly
1058 for Elaborated, since that variable isn't otherwise known. */
1059 if (attribute
== Attr_Elab_Body
|| attribute
== Attr_Elab_Spec
)
1062 = create_subprog_decl
1063 (create_concat_name (Entity (Prefix (gnat_node
)),
1064 attribute
== Attr_Elab_Body
1065 ? "elabb" : "elabs"),
1066 NULL_TREE
, void_ftype
, NULL_TREE
, 0, 1, 1, 0);
1070 gnu_prefix
= gnat_to_gnu (Prefix (gnat_node
));
1071 gnu_type
= TREE_TYPE (gnu_prefix
);
1073 /* If the input is a NULL_EXPR, make a new one. */
1074 if (TREE_CODE (gnu_prefix
) == NULL_EXPR
)
1076 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1077 gnu_result
= build1 (NULL_EXPR
, gnu_result_type
,
1078 TREE_OPERAND (gnu_prefix
, 0));
1086 /* These are just conversions until since representation
1087 clauses for enumerations are handled in the front end. */
1089 int check_p
= Do_Range_Check (First (Expressions (gnat_node
)));
1091 gnu_result
= gnat_to_gnu (First (Expressions (gnat_node
)));
1092 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1093 gnu_result
= convert_with_check (Etype (gnat_node
), gnu_result
,
1094 check_p
, check_p
, 1);
1100 /* These just add or subject the constant 1. Representation
1101 clauses for enumerations are handled in the front-end. */
1102 gnu_expr
= gnat_to_gnu (First (Expressions (gnat_node
)));
1103 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1105 if (Do_Range_Check (First (Expressions (gnat_node
))))
1107 gnu_expr
= make_save_expr (gnu_expr
);
1110 (build_binary_op (EQ_EXPR
, integer_type_node
,
1112 attribute
== Attr_Pred
1113 ? TYPE_MIN_VALUE (gnu_result_type
)
1114 : TYPE_MAX_VALUE (gnu_result_type
)),
1119 = build_binary_op (attribute
== Attr_Pred
1120 ? MINUS_EXPR
: PLUS_EXPR
,
1121 gnu_result_type
, gnu_expr
,
1122 convert (gnu_result_type
, integer_one_node
));
1126 case Attr_Unrestricted_Access
:
1128 /* Conversions don't change something's address but can cause
1129 us to miss the COMPONENT_REF case below, so strip them off. */
1130 gnu_prefix
= remove_conversions (gnu_prefix
);
1132 /* If we are taking 'Address of an unconstrained object,
1133 this is the pointer to the underlying array. */
1134 gnu_prefix
= maybe_unconstrained_array (gnu_prefix
);
1136 /* ... fall through ... */
1139 case Attr_Unchecked_Access
:
1140 case Attr_Code_Address
:
1142 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1144 = build_unary_op (attribute
== Attr_Address
1145 || attribute
== Attr_Unrestricted_Access
1146 ? ATTR_ADDR_EXPR
: ADDR_EXPR
,
1147 gnu_result_type
, gnu_prefix
);
1149 /* For 'Code_Address, find an inner ADDR_EXPR and mark it
1150 so that we don't try to build a trampoline. */
1151 if (attribute
== Attr_Code_Address
)
1153 for (gnu_expr
= gnu_result
;
1154 TREE_CODE (gnu_expr
) == NOP_EXPR
1155 || TREE_CODE (gnu_expr
) == CONVERT_EXPR
;
1156 gnu_expr
= TREE_OPERAND (gnu_expr
, 0))
1157 TREE_CONSTANT (gnu_expr
) = 1;
1160 if (TREE_CODE (gnu_expr
) == ADDR_EXPR
)
1161 TREE_STATIC (gnu_expr
) = TREE_CONSTANT (gnu_expr
) = 1;
1167 case Attr_Object_Size
:
1168 case Attr_Value_Size
:
1169 case Attr_Max_Size_In_Storage_Elements
:
1171 gnu_expr
= gnu_prefix
;
1173 /* Remove NOPS from gnu_expr and conversions from gnu_prefix.
1174 We only use GNU_EXPR to see if a COMPONENT_REF was involved. */
1175 while (TREE_CODE (gnu_expr
) == NOP_EXPR
)
1176 gnu_expr
= TREE_OPERAND (gnu_expr
, 0);
1178 gnu_prefix
= remove_conversions (gnu_prefix
);
1180 gnu_type
= TREE_TYPE (gnu_prefix
);
1182 /* Replace an unconstrained array type with the type of the
1183 underlying array. We can't do this with a call to
1184 maybe_unconstrained_array since we may have a TYPE_DECL.
1185 For 'Max_Size_In_Storage_Elements, use the record type
1186 that will be used to allocate the object and its template. */
1188 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
1190 gnu_type
= TYPE_OBJECT_RECORD_TYPE (gnu_type
);
1191 if (attribute
!= Attr_Max_Size_In_Storage_Elements
)
1192 gnu_type
= TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type
)));
1195 /* If we are looking for the size of a field, return the
1196 field size. Otherwise, if the prefix is an object,
1197 or if 'Object_Size or 'Max_Size_In_Storage_Elements has
1198 been specified, the result is the GCC size of the type.
1199 Otherwise, the result is the RM_Size of the type. */
1200 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
1201 gnu_result
= DECL_SIZE (TREE_OPERAND (gnu_prefix
, 1));
1202 else if (TREE_CODE (gnu_prefix
) != TYPE_DECL
1203 || attribute
== Attr_Object_Size
1204 || attribute
== Attr_Max_Size_In_Storage_Elements
)
1206 /* If this is a padded type, the GCC size isn't relevant
1207 to the programmer. Normally, what we want is the RM_Size,
1208 which was set from the specified size, but if it was not
1209 set, we want the size of the relevant field. Using the MAX
1210 of those two produces the right result in all case. Don't
1211 use the size of the field if it's a self-referential type,
1212 since that's never what's wanted. */
1213 if (TREE_CODE (gnu_type
) == RECORD_TYPE
1214 && TYPE_IS_PADDING_P (gnu_type
)
1215 && TREE_CODE (gnu_expr
) == COMPONENT_REF
)
1217 gnu_result
= rm_size (gnu_type
);
1218 if (! (contains_placeholder_p
1219 (DECL_SIZE (TREE_OPERAND (gnu_expr
, 1)))))
1221 = size_binop (MAX_EXPR
, gnu_result
,
1222 DECL_SIZE (TREE_OPERAND (gnu_expr
, 1)));
1225 gnu_result
= TYPE_SIZE (gnu_type
);
1228 gnu_result
= rm_size (gnu_type
);
1230 if (gnu_result
== 0)
1233 /* Deal with a self-referential size by returning the maximum
1234 size for a type and by qualifying the size with
1235 the object for 'Size of an object. */
1237 if (TREE_CODE (gnu_result
) != INTEGER_CST
1238 && contains_placeholder_p (gnu_result
))
1240 if (TREE_CODE (gnu_prefix
) != TYPE_DECL
)
1241 gnu_result
= build (WITH_RECORD_EXPR
, TREE_TYPE (gnu_result
),
1242 gnu_result
, gnu_prefix
);
1244 gnu_result
= max_size (gnu_result
, 1);
1247 /* If the type contains a template, subtract the size of the
1249 if (TREE_CODE (gnu_type
) == RECORD_TYPE
1250 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
1251 gnu_result
= size_binop (MINUS_EXPR
, gnu_result
,
1252 DECL_SIZE (TYPE_FIELDS (gnu_type
)));
1254 /* If the type contains a template, subtract the size of the
1256 if (TREE_CODE (gnu_type
) == RECORD_TYPE
1257 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
1258 gnu_result
= size_binop (MINUS_EXPR
, gnu_result
,
1259 DECL_SIZE (TYPE_FIELDS (gnu_type
)));
1261 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1263 /* Always perform division using unsigned arithmetic as the
1264 size cannot be negative, but may be an overflowed positive
1265 value. This provides correct results for sizes up to 512 MB.
1266 ??? Size should be calculated in storage elements directly. */
1268 if (attribute
== Attr_Max_Size_In_Storage_Elements
)
1269 gnu_result
= convert (sizetype
,
1270 fold (build (CEIL_DIV_EXPR
, bitsizetype
,
1272 bitsize_unit_node
)));
1275 case Attr_Alignment
:
1276 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
1277 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))
1279 && (TYPE_IS_PADDING_P
1280 (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))))
1281 gnu_prefix
= TREE_OPERAND (gnu_prefix
, 0);
1283 gnu_type
= TREE_TYPE (gnu_prefix
);
1284 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1287 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
1289 = size_int (DECL_ALIGN (TREE_OPERAND (gnu_prefix
, 1)));
1291 gnu_result
= size_int (TYPE_ALIGN (gnu_type
) / BITS_PER_UNIT
);
1296 case Attr_Range_Length
:
1299 if (INTEGRAL_TYPE_P (gnu_type
)
1300 || TREE_CODE (gnu_type
) == REAL_TYPE
)
1302 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1304 if (attribute
== Attr_First
)
1305 gnu_result
= TYPE_MIN_VALUE (gnu_type
);
1306 else if (attribute
== Attr_Last
)
1307 gnu_result
= TYPE_MAX_VALUE (gnu_type
);
1311 (MAX_EXPR
, get_base_type (gnu_result_type
),
1313 (PLUS_EXPR
, get_base_type (gnu_result_type
),
1314 build_binary_op (MINUS_EXPR
,
1315 get_base_type (gnu_result_type
),
1316 convert (gnu_result_type
,
1317 TYPE_MAX_VALUE (gnu_type
)),
1318 convert (gnu_result_type
,
1319 TYPE_MIN_VALUE (gnu_type
))),
1320 convert (gnu_result_type
, integer_one_node
)),
1321 convert (gnu_result_type
, integer_zero_node
));
1325 /* ... fall through ... */
1329 = (Present (Expressions (gnat_node
))
1330 ? UI_To_Int (Intval (First (Expressions (gnat_node
))))
1333 /* Emit access check if necessary */
1334 if (Do_Access_Check (gnat_node
))
1335 gnu_prefix
= emit_access_check (gnu_prefix
);
1337 /* Make sure any implicit dereference gets done. */
1338 gnu_prefix
= maybe_implicit_deref (gnu_prefix
);
1339 gnu_prefix
= maybe_unconstrained_array (gnu_prefix
);
1340 gnu_type
= TREE_TYPE (gnu_prefix
);
1342 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1344 if (TYPE_CONVENTION_FORTRAN_P (gnu_type
))
1349 for (ndim
= 1, gnu_type_temp
= gnu_type
;
1350 TREE_CODE (TREE_TYPE (gnu_type_temp
)) == ARRAY_TYPE
1351 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp
));
1352 ndim
++, gnu_type_temp
= TREE_TYPE (gnu_type_temp
))
1355 Dimension
= ndim
+ 1 - Dimension
;
1358 for (; Dimension
> 1; Dimension
--)
1359 gnu_type
= TREE_TYPE (gnu_type
);
1361 if (TREE_CODE (gnu_type
) != ARRAY_TYPE
)
1364 if (attribute
== Attr_First
)
1366 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)));
1367 else if (attribute
== Attr_Last
)
1369 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)));
1371 /* 'Length or 'Range_Length. */
1373 tree gnu_compute_type
1374 = signed_or_unsigned_type
1375 (0, get_base_type (gnu_result_type
));
1379 (MAX_EXPR
, gnu_compute_type
,
1381 (PLUS_EXPR
, gnu_compute_type
,
1383 (MINUS_EXPR
, gnu_compute_type
,
1384 convert (gnu_compute_type
,
1386 (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)))),
1387 convert (gnu_compute_type
,
1389 (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))))),
1390 convert (gnu_compute_type
, integer_one_node
)),
1391 convert (gnu_compute_type
, integer_zero_node
));
1394 /* If this has a PLACEHOLDER_EXPR, qualify it by the object
1395 we are handling. Note that these attributes could not
1396 have been used on an unconstrained array type. */
1397 if (TREE_CODE (gnu_result
) != INTEGER_CST
1398 && contains_placeholder_p (gnu_result
))
1399 gnu_result
= build (WITH_RECORD_EXPR
, TREE_TYPE (gnu_result
),
1400 gnu_result
, gnu_prefix
);
1405 case Attr_Bit_Position
:
1407 case Attr_First_Bit
:
1411 HOST_WIDE_INT bitsize
;
1412 HOST_WIDE_INT bitpos
;
1414 tree gnu_field_bitpos
;
1415 tree gnu_field_offset
;
1417 enum machine_mode mode
;
1418 int unsignedp
, volatilep
;
1419 unsigned int alignment
;
1421 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1422 gnu_prefix
= remove_conversions (gnu_prefix
);
1425 /* We can have 'Bit on any object, but if it isn't a
1426 COMPONENT_REF, the result is zero. Do not allow
1427 'Bit on a bare component, though. */
1428 if (attribute
== Attr_Bit
1429 && TREE_CODE (gnu_prefix
) != COMPONENT_REF
1430 && TREE_CODE (gnu_prefix
) != FIELD_DECL
)
1432 gnu_result
= integer_zero_node
;
1436 else if (TREE_CODE (gnu_prefix
) != COMPONENT_REF
1437 && ! (attribute
== Attr_Bit_Position
1438 && TREE_CODE (gnu_prefix
) == FIELD_DECL
))
1441 get_inner_reference (gnu_prefix
, &bitsize
, &bitpos
, &gnu_offset
,
1442 &mode
, &unsignedp
, &volatilep
, &alignment
);
1445 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
1448 = bit_position (TREE_OPERAND (gnu_prefix
, 1));
1450 = byte_position (TREE_OPERAND (gnu_prefix
, 1));
1452 for (gnu_inner
= TREE_OPERAND (gnu_prefix
, 0);
1453 TREE_CODE (gnu_inner
) == COMPONENT_REF
1454 && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner
, 1));
1455 gnu_inner
= TREE_OPERAND (gnu_inner
, 0))
1458 = size_binop (PLUS_EXPR
, gnu_field_bitpos
,
1459 bit_position (TREE_OPERAND (gnu_inner
,
1462 = size_binop (PLUS_EXPR
, gnu_field_offset
,
1463 byte_position (TREE_OPERAND (gnu_inner
,
1467 else if (TREE_CODE (gnu_prefix
) == FIELD_DECL
)
1469 gnu_field_bitpos
= bit_position (gnu_prefix
);
1470 gnu_field_offset
= byte_position (gnu_prefix
);
1474 gnu_field_bitpos
= bitsize_zero_node
;
1475 gnu_field_offset
= size_zero_node
;
1481 gnu_result
= gnu_field_offset
;
1485 case Attr_First_Bit
:
1487 gnu_result
= size_int (bitpos
% BITS_PER_UNIT
);
1492 gnu_result
= bitsize_int (bitpos
% BITS_PER_UNIT
);
1494 = size_binop (PLUS_EXPR
, gnu_result
,
1495 TYPE_SIZE (TREE_TYPE (gnu_prefix
)));
1496 gnu_result
= size_binop (MINUS_EXPR
, gnu_result
,
1500 case Attr_Bit_Position
:
1501 gnu_result
= gnu_field_bitpos
;
1505 /* If this has a PLACEHOLDER_EXPR, qualify it by the object
1507 if (TREE_CODE (gnu_result
) != INTEGER_CST
1508 && contains_placeholder_p (gnu_result
))
1509 gnu_result
= build (WITH_RECORD_EXPR
, TREE_TYPE (gnu_result
),
1510 gnu_result
, gnu_prefix
);
1517 gnu_lhs
= gnat_to_gnu (First (Expressions (gnat_node
)));
1518 gnu_rhs
= gnat_to_gnu (Next (First (Expressions (gnat_node
))));
1520 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1521 gnu_result
= build_binary_op (attribute
== Attr_Min
1522 ? MIN_EXPR
: MAX_EXPR
,
1523 gnu_result_type
, gnu_lhs
, gnu_rhs
);
1526 case Attr_Passed_By_Reference
:
1527 gnu_result
= size_int (default_pass_by_ref (gnu_type
)
1528 || must_pass_by_ref (gnu_type
));
1529 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1532 case Attr_Component_Size
:
1533 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
1534 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))
1536 && (TYPE_IS_PADDING_P
1537 (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))))
1538 gnu_prefix
= TREE_OPERAND (gnu_prefix
, 0);
1540 gnu_prefix
= maybe_implicit_deref (gnu_prefix
);
1541 gnu_type
= TREE_TYPE (gnu_prefix
);
1543 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
1545 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type
))));
1547 while (TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
1548 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
)))
1549 gnu_type
= TREE_TYPE (gnu_type
);
1551 if (TREE_CODE (gnu_type
) != ARRAY_TYPE
)
1554 /* Note this size cannot be self-referential. */
1555 gnu_result
= TYPE_SIZE (TREE_TYPE (gnu_type
));
1556 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1560 case Attr_Null_Parameter
:
1561 /* This is just a zero cast to the pointer type for
1562 our prefix and dereferenced. */
1563 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1565 = build_unary_op (INDIRECT_REF
, NULL_TREE
,
1566 convert (build_pointer_type (gnu_result_type
),
1567 integer_zero_node
));
1568 TREE_PRIVATE (gnu_result
) = 1;
1571 case Attr_Mechanism_Code
:
1574 Entity_Id gnat_obj
= Entity (Prefix (gnat_node
));
1577 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1578 if (Present (Expressions (gnat_node
)))
1580 int i
= UI_To_Int (Intval (First (Expressions (gnat_node
))));
1582 for (gnat_obj
= First_Formal (gnat_obj
); i
> 1;
1583 i
--, gnat_obj
= Next_Formal (gnat_obj
))
1587 code
= Mechanism (gnat_obj
);
1588 if (code
== Default
)
1589 code
= ((present_gnu_tree (gnat_obj
)
1590 && (DECL_BY_REF_P (get_gnu_tree (gnat_obj
))
1591 || (DECL_BY_COMPONENT_PTR_P
1592 (get_gnu_tree (gnat_obj
)))))
1593 ? By_Reference
: By_Copy
);
1594 gnu_result
= convert (gnu_result_type
, size_int (- code
));
1599 /* Say we have an unimplemented attribute. Then set the
1600 value to be returned to be a zero and hope that's something
1601 we can convert to the type of this attribute. */
1603 post_error ("unimplemented attribute", gnat_node
);
1604 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1605 gnu_result
= integer_zero_node
;
1609 /* If this is an attribute where the prefix was unused,
1610 force a use of it if it has a side-effect. */
1611 if (prefix_unused
&& TREE_SIDE_EFFECTS (gnu_prefix
))
1612 gnu_result
= fold (build (COMPOUND_EXPR
, TREE_TYPE (gnu_result
),
1613 gnu_prefix
, gnu_result
));
1618 /* Like 'Access as far as we are concerned. */
1619 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
1620 gnu_result
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_result
);
1621 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1625 case N_Extension_Aggregate
:
1629 /* ??? It is wrong to evaluate the type now, but there doesn't
1630 seem to be any other practical way of doing it. */
1632 gnu_aggr_type
= gnu_result_type
1633 = get_unpadded_type (Etype (gnat_node
));
1635 if (TREE_CODE (gnu_result_type
) == RECORD_TYPE
1636 && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type
))
1638 = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_result_type
)));
1640 if (Null_Record_Present (gnat_node
))
1641 gnu_result
= build_constructor (gnu_aggr_type
, NULL_TREE
);
1643 else if (TREE_CODE (gnu_aggr_type
) == RECORD_TYPE
)
1645 = assoc_to_constructor (First (Component_Associations (gnat_node
)),
1647 else if (TREE_CODE (gnu_aggr_type
) == UNION_TYPE
)
1649 /* The first element is the discrimant, which we ignore. The
1650 next is the field we're building. Convert the expression
1651 to the type of the field and then to the union type. */
1653 = Next (First (Component_Associations (gnat_node
)));
1654 Entity_Id gnat_field
= Entity (First (Choices (gnat_assoc
)));
1656 = TREE_TYPE (gnat_to_gnu_entity (gnat_field
, NULL_TREE
, 0));
1658 gnu_result
= convert (gnu_field_type
,
1659 gnat_to_gnu (Expression (gnat_assoc
)));
1661 else if (TREE_CODE (gnu_aggr_type
) == ARRAY_TYPE
)
1662 gnu_result
= pos_to_constructor (First (Expressions (gnat_node
)),
1664 Component_Type (Etype (gnat_node
)));
1665 else if (TREE_CODE (gnu_aggr_type
) == COMPLEX_TYPE
)
1668 (COMPLEX_EXPR
, gnu_aggr_type
,
1669 gnat_to_gnu (Expression (First
1670 (Component_Associations (gnat_node
)))),
1671 gnat_to_gnu (Expression
1673 (First (Component_Associations (gnat_node
))))));
1677 gnu_result
= convert (gnu_result_type
, gnu_result
);
1682 gnu_result
= null_pointer_node
;
1683 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1686 case N_Type_Conversion
:
1687 case N_Qualified_Expression
:
1688 /* Get the operand expression. */
1689 gnu_result
= gnat_to_gnu (Expression (gnat_node
));
1690 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1693 = convert_with_check (Etype (gnat_node
), gnu_result
,
1694 Do_Overflow_Check (gnat_node
),
1695 Do_Range_Check (Expression (gnat_node
)),
1696 Nkind (gnat_node
) == N_Type_Conversion
1697 && Float_Truncate (gnat_node
));
1700 case N_Unchecked_Type_Conversion
:
1701 gnu_result
= gnat_to_gnu (Expression (gnat_node
));
1702 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1704 /* If the result is a pointer type, see if we are improperly
1705 converting to a stricter alignment. */
1707 if (STRICT_ALIGNMENT
&& POINTER_TYPE_P (gnu_result_type
)
1708 && IN (Ekind (Etype (gnat_node
)), Access_Kind
))
1710 unsigned int align
= known_alignment (gnu_result
);
1711 tree gnu_obj_type
= TREE_TYPE (gnu_result_type
);
1713 = TREE_CODE (gnu_obj_type
) == FUNCTION_TYPE
1714 ? FUNCTION_BOUNDARY
: TYPE_ALIGN (gnu_obj_type
);
1716 if (align
!= 0 && align
< oalign
&& ! TYPE_ALIGN_OK_P (gnu_obj_type
))
1717 post_error_ne_tree_2
1718 ("?source alignment (^) < alignment of & (^)",
1719 gnat_node
, Designated_Type (Etype (gnat_node
)),
1720 size_int (align
/ BITS_PER_UNIT
), oalign
/ BITS_PER_UNIT
);
1723 gnu_result
= unchecked_convert (gnu_result_type
, gnu_result
);
1729 tree gnu_object
= gnat_to_gnu (Left_Opnd (gnat_node
));
1730 Node_Id gnat_range
= Right_Opnd (gnat_node
);
1734 /* GNAT_RANGE is either an N_Range node or an identifier
1735 denoting a subtype. */
1736 if (Nkind (gnat_range
) == N_Range
)
1738 gnu_low
= gnat_to_gnu (Low_Bound (gnat_range
));
1739 gnu_high
= gnat_to_gnu (High_Bound (gnat_range
));
1741 else if (Nkind (gnat_range
) == N_Identifier
1742 || Nkind (gnat_range
) == N_Expanded_Name
)
1744 tree gnu_range_type
= get_unpadded_type (Entity (gnat_range
));
1746 gnu_low
= TYPE_MIN_VALUE (gnu_range_type
);
1747 gnu_high
= TYPE_MAX_VALUE (gnu_range_type
);
1752 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1754 /* If LOW and HIGH are identical, perform an equality test.
1755 Otherwise, ensure that GNU_OBJECT is only evaluated once
1756 and perform a full range test. */
1757 if (operand_equal_p (gnu_low
, gnu_high
, 0))
1758 gnu_result
= build_binary_op (EQ_EXPR
, gnu_result_type
,
1759 gnu_object
, gnu_low
);
1762 gnu_object
= make_save_expr (gnu_object
);
1764 = build_binary_op (TRUTH_ANDIF_EXPR
, gnu_result_type
,
1765 build_binary_op (GE_EXPR
, gnu_result_type
,
1766 gnu_object
, gnu_low
),
1767 build_binary_op (LE_EXPR
, gnu_result_type
,
1768 gnu_object
, gnu_high
));
1771 if (Nkind (gnat_node
) == N_Not_In
)
1772 gnu_result
= invert_truthvalue (gnu_result
);
1777 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
1778 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
1779 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1780 gnu_result
= build_binary_op (FLOAT_TYPE_P (gnu_result_type
)
1782 : (Rounded_Result (gnat_node
)
1783 ? ROUND_DIV_EXPR
: TRUNC_DIV_EXPR
),
1784 gnu_result_type
, gnu_lhs
, gnu_rhs
);
1787 case N_And_Then
: case N_Or_Else
:
1789 enum tree_code code
= gnu_codes
[Nkind (gnat_node
)];
1792 /* The elaboration of the RHS may generate code. If so,
1793 we need to make sure it gets executed after the LHS. */
1794 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
1796 gnu_rhs_side
= expand_start_stmt_expr ();
1797 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
1798 expand_end_stmt_expr (gnu_rhs_side
);
1799 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1801 if (RTL_EXPR_SEQUENCE (gnu_rhs_side
) != 0)
1802 gnu_rhs
= build (COMPOUND_EXPR
, gnu_result_type
, gnu_rhs_side
,
1805 gnu_result
= build_binary_op (code
, gnu_result_type
, gnu_lhs
, gnu_rhs
);
1809 case N_Op_Or
: case N_Op_And
: case N_Op_Xor
:
1810 /* These can either be operations on booleans or on modular types.
1811 Fall through for boolean types since that's the way GNU_CODES is
1813 if (IN (Ekind (Underlying_Type (Etype (gnat_node
))),
1814 Modular_Integer_Kind
))
1817 = (Nkind (gnat_node
) == N_Op_Or
? BIT_IOR_EXPR
1818 : Nkind (gnat_node
) == N_Op_And
? BIT_AND_EXPR
1821 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
1822 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
1823 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1824 gnu_result
= build_binary_op (code
, gnu_result_type
,
1829 /* ... fall through ... */
1831 case N_Op_Eq
: case N_Op_Ne
: case N_Op_Lt
:
1832 case N_Op_Le
: case N_Op_Gt
: case N_Op_Ge
:
1833 case N_Op_Add
: case N_Op_Subtract
: case N_Op_Multiply
:
1834 case N_Op_Mod
: case N_Op_Rem
:
1835 case N_Op_Rotate_Left
:
1836 case N_Op_Rotate_Right
:
1837 case N_Op_Shift_Left
:
1838 case N_Op_Shift_Right
:
1839 case N_Op_Shift_Right_Arithmetic
:
1841 enum tree_code code
= gnu_codes
[Nkind (gnat_node
)];
1844 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
1845 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
1846 gnu_type
= gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1848 /* If this is a comparison operator, convert any references to
1849 an unconstrained array value into a reference to the
1851 if (TREE_CODE_CLASS (code
) == '<')
1853 gnu_lhs
= maybe_unconstrained_array (gnu_lhs
);
1854 gnu_rhs
= maybe_unconstrained_array (gnu_rhs
);
1857 /* If this is a shift whose count is not guaranteed to be correct,
1858 we need to adjust the shift count. */
1859 if (IN (Nkind (gnat_node
), N_Op_Shift
)
1860 && ! Shift_Count_OK (gnat_node
))
1862 tree gnu_count_type
= get_base_type (TREE_TYPE (gnu_rhs
));
1864 = convert (gnu_count_type
, TYPE_SIZE (gnu_type
));
1866 if (Nkind (gnat_node
) == N_Op_Rotate_Left
1867 || Nkind (gnat_node
) == N_Op_Rotate_Right
)
1868 gnu_rhs
= build_binary_op (TRUNC_MOD_EXPR
, gnu_count_type
,
1869 gnu_rhs
, gnu_max_shift
);
1870 else if (Nkind (gnat_node
) == N_Op_Shift_Right_Arithmetic
)
1873 (MIN_EXPR
, gnu_count_type
,
1874 build_binary_op (MINUS_EXPR
,
1877 convert (gnu_count_type
,
1882 /* For right shifts, the type says what kind of shift to do,
1883 so we may need to choose a different type. */
1884 if (Nkind (gnat_node
) == N_Op_Shift_Right
1885 && ! TREE_UNSIGNED (gnu_type
))
1886 gnu_type
= unsigned_type (gnu_type
);
1887 else if (Nkind (gnat_node
) == N_Op_Shift_Right_Arithmetic
1888 && TREE_UNSIGNED (gnu_type
))
1889 gnu_type
= signed_type (gnu_type
);
1891 if (gnu_type
!= gnu_result_type
)
1893 gnu_lhs
= convert (gnu_type
, gnu_lhs
);
1894 gnu_rhs
= convert (gnu_type
, gnu_rhs
);
1897 gnu_result
= build_binary_op (code
, gnu_type
, gnu_lhs
, gnu_rhs
);
1899 /* If this is a logical shift with the shift count not verified,
1900 we must return zero if it is too large. We cannot compensate
1901 above in this case. */
1902 if ((Nkind (gnat_node
) == N_Op_Shift_Left
1903 || Nkind (gnat_node
) == N_Op_Shift_Right
)
1904 && ! Shift_Count_OK (gnat_node
))
1908 build_binary_op (GE_EXPR
, integer_type_node
,
1910 convert (TREE_TYPE (gnu_rhs
),
1911 TYPE_SIZE (gnu_type
))),
1912 convert (gnu_type
, integer_zero_node
),
1917 case N_Conditional_Expression
:
1919 tree gnu_cond
= gnat_to_gnu (First (Expressions (gnat_node
)));
1920 tree gnu_true
= gnat_to_gnu (Next (First (Expressions (gnat_node
))));
1922 = gnat_to_gnu (Next (Next (First (Expressions (gnat_node
)))));
1924 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1925 gnu_result
= build_cond_expr (gnu_result_type
,
1926 truthvalue_conversion (gnu_cond
),
1927 gnu_true
, gnu_false
);
1932 gnu_result
= gnat_to_gnu (Right_Opnd (gnat_node
));
1933 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1937 /* This case can apply to a boolean or a modular type.
1938 Fall through for a boolean operand since GNU_CODES is set
1939 up to handle this. */
1940 if (IN (Ekind (Etype (gnat_node
)), Modular_Integer_Kind
))
1942 gnu_expr
= gnat_to_gnu (Right_Opnd (gnat_node
));
1943 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1944 gnu_result
= build_unary_op (BIT_NOT_EXPR
, gnu_result_type
,
1949 /* ... fall through ... */
1951 case N_Op_Minus
: case N_Op_Abs
:
1952 gnu_expr
= gnat_to_gnu (Right_Opnd (gnat_node
));
1954 if (Ekind (Etype (gnat_node
)) != E_Private_Type
)
1955 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1957 gnu_result_type
= get_unpadded_type (Base_Type
1958 (Full_View (Etype (gnat_node
))));
1960 gnu_result
= build_unary_op (gnu_codes
[Nkind (gnat_node
)],
1961 gnu_result_type
, gnu_expr
);
1969 gnat_temp
= Expression (gnat_node
);
1971 /* The Expression operand can either be an N_Identifier or
1972 Expanded_Name, which must represent a type, or a
1973 N_Qualified_Expression, which contains both the object type and an
1974 initial value for the object. */
1975 if (Nkind (gnat_temp
) == N_Identifier
1976 || Nkind (gnat_temp
) == N_Expanded_Name
)
1977 gnu_type
= gnat_to_gnu_type (Entity (gnat_temp
));
1978 else if (Nkind (gnat_temp
) == N_Qualified_Expression
)
1980 Entity_Id gnat_desig_type
1981 = Designated_Type (Underlying_Type (Etype (gnat_node
)));
1983 gnu_init
= gnat_to_gnu (Expression (gnat_temp
));
1985 gnu_init
= maybe_unconstrained_array (gnu_init
);
1986 if (Do_Range_Check (Expression (gnat_temp
)))
1987 gnu_init
= emit_range_check (gnu_init
, gnat_desig_type
);
1989 if (Is_Elementary_Type (gnat_desig_type
)
1990 || Is_Constrained (gnat_desig_type
))
1992 gnu_type
= gnat_to_gnu_type (gnat_desig_type
);
1993 gnu_init
= convert (gnu_type
, gnu_init
);
1997 gnu_type
= gnat_to_gnu_type (Etype (Expression (gnat_temp
)));
1998 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
1999 gnu_type
= TREE_TYPE (gnu_init
);
2001 gnu_init
= convert (gnu_type
, gnu_init
);
2007 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2008 return build_allocator (gnu_type
, gnu_init
, gnu_result_type
,
2009 Procedure_To_Call (gnat_node
),
2010 Storage_Pool (gnat_node
));
2014 /***************************/
2015 /* Chapter 5: Statements: */
2016 /***************************/
2019 if (! type_annotate_only
)
2021 tree gnu_label
= gnat_to_gnu (Identifier (gnat_node
));
2022 Node_Id gnat_parent
= Parent (gnat_node
);
2024 expand_label (gnu_label
);
2026 /* If this is the first label of an exception handler, we must
2027 mark that any CALL_INSN can jump to it. */
2028 if (Present (gnat_parent
)
2029 && Nkind (gnat_parent
) == N_Exception_Handler
2030 && First (Statements (gnat_parent
)) == gnat_node
)
2031 nonlocal_goto_handler_labels
2032 = gen_rtx_EXPR_LIST (VOIDmode
, label_rtx (gnu_label
),
2033 nonlocal_goto_handler_labels
);
2037 case N_Null_Statement
:
2040 case N_Assignment_Statement
:
2041 if (type_annotate_only
)
2044 /* Get the LHS and RHS of the statement and convert any reference to an
2045 unconstrained array into a reference to the underlying array. */
2046 gnu_lhs
= maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node
)));
2048 = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node
)));
2050 /* If range check is needed, emit code to generate it */
2051 if (Do_Range_Check (Expression (gnat_node
)))
2052 gnu_rhs
= emit_range_check (gnu_rhs
, Etype (Name (gnat_node
)));
2054 set_lineno (gnat_node
, 1);
2056 /* If either side's type has a size that overflows, convert this
2057 into raise of Storage_Error: execution shouldn't have gotten
2059 if ((TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_lhs
))) == INTEGER_CST
2060 && TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_lhs
))))
2061 || (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_rhs
))) == INTEGER_CST
2062 && TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_rhs
)))))
2063 expand_expr_stmt (build_call_raise (raise_storage_error_decl
));
2065 expand_expr_stmt (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
2069 case N_If_Statement
:
2070 /* Start an IF statement giving the condition. */
2071 gnu_expr
= gnat_to_gnu (Condition (gnat_node
));
2072 set_lineno (gnat_node
, 1);
2073 expand_start_cond (gnu_expr
, 0);
2075 /* Generate code for the statements to be executed if the condition
2078 for (gnat_temp
= First (Then_Statements (gnat_node
));
2079 Present (gnat_temp
);
2080 gnat_temp
= Next (gnat_temp
))
2081 gnat_to_code (gnat_temp
);
2083 /* Generate each of the "else if" parts. */
2084 if (Present (Elsif_Parts (gnat_node
)))
2086 for (gnat_temp
= First (Elsif_Parts (gnat_node
));
2087 Present (gnat_temp
);
2088 gnat_temp
= Next (gnat_temp
))
2090 Node_Id gnat_statement
;
2092 expand_start_else ();
2094 /* Set up the line numbers for each condition we test. */
2095 set_lineno (Condition (gnat_temp
), 1);
2096 expand_elseif (gnat_to_gnu (Condition (gnat_temp
)));
2098 for (gnat_statement
= First (Then_Statements (gnat_temp
));
2099 Present (gnat_statement
);
2100 gnat_statement
= Next (gnat_statement
))
2101 gnat_to_code (gnat_statement
);
2105 /* Finally, handle any statements in the "else" part. */
2106 if (Present (Else_Statements (gnat_node
)))
2108 expand_start_else ();
2110 for (gnat_temp
= First (Else_Statements (gnat_node
));
2111 Present (gnat_temp
);
2112 gnat_temp
= Next (gnat_temp
))
2113 gnat_to_code (gnat_temp
);
2119 case N_Case_Statement
:
2122 Node_Id gnat_choice
;
2124 Node_Id gnat_statement
;
2126 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
2127 gnu_expr
= convert (get_base_type (TREE_TYPE (gnu_expr
)), gnu_expr
);
2129 set_lineno (gnat_node
, 1);
2130 expand_start_case (1, gnu_expr
, TREE_TYPE (gnu_expr
), "case");
2132 for (gnat_when
= First_Non_Pragma (Alternatives (gnat_node
));
2133 Present (gnat_when
);
2134 gnat_when
= Next_Non_Pragma (gnat_when
))
2136 /* First compile all the different case choices for the current
2137 WHEN alternative. */
2139 for (gnat_choice
= First (Discrete_Choices (gnat_when
));
2140 Present (gnat_choice
); gnat_choice
= Next (gnat_choice
))
2144 gnu_label
= build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
);
2146 set_lineno (gnat_choice
, 1);
2147 switch (Nkind (gnat_choice
))
2150 /* Abort on all errors except range empty, which
2151 means we ignore this alternative. */
2153 = pushcase_range (gnat_to_gnu (Low_Bound (gnat_choice
)),
2154 gnat_to_gnu (High_Bound (gnat_choice
)),
2155 convert
, gnu_label
, 0);
2157 if (error_code
!= 0 && error_code
!= 4)
2161 case N_Subtype_Indication
:
2164 (gnat_to_gnu (Low_Bound (Range_Expression
2165 (Constraint (gnat_choice
)))),
2166 gnat_to_gnu (High_Bound (Range_Expression
2167 (Constraint (gnat_choice
)))),
2168 convert
, gnu_label
, 0);
2170 if (error_code
!= 0 && error_code
!= 4)
2175 case N_Expanded_Name
:
2176 /* This represents either a subtype range or a static value
2177 of some kind; Ekind says which. If a static value,
2178 fall through to the next case. */
2179 if (IN (Ekind (Entity (gnat_choice
)), Type_Kind
))
2181 tree type
= get_unpadded_type (Entity (gnat_choice
));
2184 = pushcase_range (fold (TYPE_MIN_VALUE (type
)),
2185 fold (TYPE_MAX_VALUE (type
)),
2186 convert
, gnu_label
, 0);
2188 if (error_code
!= 0 && error_code
!= 4)
2192 /* ... fall through ... */
2193 case N_Character_Literal
:
2194 case N_Integer_Literal
:
2195 if (pushcase (gnat_to_gnu (gnat_choice
), convert
,
2200 case N_Others_Choice
:
2201 if (pushcase (NULL_TREE
, convert
, gnu_label
, 0))
2210 /* After compiling the choices attached to the WHEN compile the
2211 body of statements that have to be executed, should the
2212 "WHEN ... =>" be taken. */
2213 for (gnat_statement
= First (Statements (gnat_when
));
2214 Present (gnat_statement
);
2215 gnat_statement
= Next (gnat_statement
))
2216 gnat_to_code (gnat_statement
);
2218 /* Communicate to GCC that we are done with the current WHEN,
2219 i.e. insert a "break" statement. */
2220 expand_exit_something ();
2223 expand_end_case (gnu_expr
);
2227 case N_Loop_Statement
:
2229 /* The loop variable in GCC form, if any. */
2230 tree gnu_loop_var
= NULL_TREE
;
2231 /* PREINCREMENT_EXPR or PREDECREMENT_EXPR. */
2232 enum tree_code gnu_update
= ERROR_MARK
;
2233 /* Used if this is a named loop for so EXIT can work. */
2234 struct nesting
*loop_id
;
2235 /* Condition to continue loop tested at top of loop. */
2236 tree gnu_top_condition
= integer_one_node
;
2237 /* Similar, but tested at bottom of loop. */
2238 tree gnu_bottom_condition
= integer_one_node
;
2239 Node_Id gnat_statement
;
2240 Node_Id gnat_iter_scheme
= Iteration_Scheme (gnat_node
);
2241 Node_Id gnat_top_condition
= Empty
;
2242 int enclosing_if_p
= 0;
2244 /* Set the condition that under which the loop should continue.
2245 For "LOOP .... END LOOP;" the condition is always true. */
2246 if (No (gnat_iter_scheme
))
2248 /* The case "WHILE condition LOOP ..... END LOOP;" */
2249 else if (Present (Condition (gnat_iter_scheme
)))
2250 gnat_top_condition
= Condition (gnat_iter_scheme
);
2253 /* We have an iteration scheme. */
2254 Node_Id gnat_loop_spec
2255 = Loop_Parameter_Specification (gnat_iter_scheme
);
2256 Entity_Id gnat_loop_var
= Defining_Entity (gnat_loop_spec
);
2257 Entity_Id gnat_type
= Etype (gnat_loop_var
);
2258 tree gnu_type
= get_unpadded_type (gnat_type
);
2259 tree gnu_low
= TYPE_MIN_VALUE (gnu_type
);
2260 tree gnu_high
= TYPE_MAX_VALUE (gnu_type
);
2261 int reversep
= Reverse_Present (gnat_loop_spec
);
2262 tree gnu_first
= reversep
? gnu_high
: gnu_low
;
2263 tree gnu_last
= reversep
? gnu_low
: gnu_high
;
2264 enum tree_code end_code
= reversep
? GE_EXPR
: LE_EXPR
;
2265 tree gnu_base_type
= get_base_type (gnu_type
);
2267 = (reversep
? TYPE_MIN_VALUE (gnu_base_type
)
2268 : TYPE_MAX_VALUE (gnu_base_type
));
2270 /* We know the loop variable will not overflow if GNU_LAST is
2271 a constant and is not equal to GNU_LIMIT. If it might
2272 overflow, we have to move the limit test to the end of
2273 the loop. In that case, we have to test for an
2274 empty loop outside the loop. */
2275 if (TREE_CODE (gnu_last
) != INTEGER_CST
2276 || TREE_CODE (gnu_limit
) != INTEGER_CST
2277 || tree_int_cst_equal (gnu_last
, gnu_limit
))
2279 gnu_expr
= build_binary_op (LE_EXPR
, integer_type_node
,
2281 set_lineno (gnat_loop_spec
, 1);
2282 expand_start_cond (gnu_expr
, 0);
2286 /* Open a new nesting level that will surround the loop to declare
2287 the loop index variable. */
2289 expand_start_bindings (0);
2291 /* Declare the loop index and set it to its initial value. */
2292 gnu_loop_var
= gnat_to_gnu_entity (gnat_loop_var
, gnu_first
, 1);
2293 if (DECL_BY_REF_P (gnu_loop_var
))
2294 gnu_loop_var
= build_unary_op (INDIRECT_REF
, NULL_TREE
,
2297 /* The loop variable might be a padded type, so use `convert' to
2298 get a reference to the inner variable if so. */
2299 gnu_loop_var
= convert (get_base_type (gnu_type
), gnu_loop_var
);
2301 /* Set either the top or bottom exit condition as
2302 appropriate depending on whether we know an overflow
2303 cannot occur or not. */
2305 gnu_bottom_condition
2306 = build_binary_op (NE_EXPR
, integer_type_node
,
2307 gnu_loop_var
, gnu_last
);
2310 = build_binary_op (end_code
, integer_type_node
,
2311 gnu_loop_var
, gnu_last
);
2313 gnu_update
= reversep
? PREDECREMENT_EXPR
: PREINCREMENT_EXPR
;
2316 set_lineno (gnat_node
, 1);
2318 loop_id
= expand_start_loop_continue_elsewhere (1);
2320 loop_id
= expand_start_loop (1);
2322 /* If the loop was named, have the name point to this loop. In this
2323 case, the association is not a ..._DECL node; in fact, it isn't
2324 a GCC tree node at all. Since this name is referenced inside
2325 the loop, do it before we process the statements of the loop. */
2326 if (Present (Identifier (gnat_node
)))
2328 tree gnu_loop_id
= make_node (GNAT_LOOP_ID
);
2330 TREE_LOOP_ID (gnu_loop_id
) = (rtx
) loop_id
;
2331 save_gnu_tree (Entity (Identifier (gnat_node
)), gnu_loop_id
, 1);
2334 set_lineno (gnat_node
, 1);
2336 /* We must evaluate the condition after we've entered the
2337 loop so that any expression actions get done in the right
2339 if (Present (gnat_top_condition
))
2340 gnu_top_condition
= gnat_to_gnu (gnat_top_condition
);
2342 expand_exit_loop_if_false (0, gnu_top_condition
);
2344 /* Make the loop body into its own block, so any allocated
2345 storage will be released every iteration. This is needed
2346 for stack allocation. */
2350 = tree_cons (gnu_bottom_condition
, NULL_TREE
, gnu_block_stack
);
2351 expand_start_bindings (0);
2353 for (gnat_statement
= First (Statements (gnat_node
));
2354 Present (gnat_statement
);
2355 gnat_statement
= Next (gnat_statement
))
2356 gnat_to_code (gnat_statement
);
2358 expand_end_bindings (getdecls (), kept_level_p (), 0);
2359 poplevel (kept_level_p (), 1, 0);
2360 gnu_block_stack
= TREE_CHAIN (gnu_block_stack
);
2362 set_lineno (gnat_node
, 1);
2363 expand_exit_loop_if_false (0, gnu_bottom_condition
);
2367 expand_loop_continue_here ();
2368 gnu_expr
= build_binary_op (gnu_update
, TREE_TYPE (gnu_loop_var
),
2370 convert (TREE_TYPE (gnu_loop_var
),
2372 set_lineno (gnat_iter_scheme
, 1);
2373 expand_expr_stmt (gnu_expr
);
2376 set_lineno (gnat_node
, 1);
2381 /* Close the nesting level that sourround the loop that was used to
2382 declare the loop index variable. */
2383 set_lineno (gnat_node
, 1);
2384 expand_end_bindings (getdecls (), 1, 0);
2390 set_lineno (gnat_node
, 1);
2396 case N_Block_Statement
:
2398 gnu_block_stack
= tree_cons (NULL_TREE
, NULL_TREE
, gnu_block_stack
);
2399 expand_start_bindings (0);
2400 process_decls (Declarations (gnat_node
), Empty
, Empty
, 1, 1);
2401 gnat_to_code (Handled_Statement_Sequence (gnat_node
));
2402 expand_end_bindings (getdecls (), kept_level_p (), 0);
2403 poplevel (kept_level_p (), 1, 0);
2404 gnu_block_stack
= TREE_CHAIN (gnu_block_stack
);
2405 if (Present (Identifier (gnat_node
)))
2406 mark_out_of_scope (Entity (Identifier (gnat_node
)));
2409 case N_Exit_Statement
:
2411 /* Which loop to exit, NULL if the current loop. */
2412 struct nesting
*loop_id
= 0;
2413 /* The GCC version of the optional GNAT condition node attached to the
2414 exit statement. Exit the loop if this is false. */
2415 tree gnu_cond
= integer_zero_node
;
2417 if (Present (Name (gnat_node
)))
2419 = (struct nesting
*)
2420 TREE_LOOP_ID (get_gnu_tree (Entity (Name (gnat_node
))));
2422 if (Present (Condition (gnat_node
)))
2425 (truthvalue_conversion (gnat_to_gnu (Condition (gnat_node
))));
2427 set_lineno (gnat_node
, 1);
2428 expand_exit_loop_if_false (loop_id
, gnu_cond
);
2432 case N_Return_Statement
:
2433 if (type_annotate_only
)
2437 /* The gnu function type of the subprogram currently processed. */
2438 tree gnu_subprog_type
= TREE_TYPE (current_function_decl
);
2439 /* The return value from the subprogram. */
2440 tree gnu_ret_val
= 0;
2442 /* If we are dealing with a "return;" from an Ada procedure with
2443 parameters passed by copy in copy out, we need to return a record
2444 containing the final values of these parameters. If the list
2445 contains only one entry, return just that entry.
2447 For a full description of the copy in copy out parameter mechanism,
2448 see the part of the gnat_to_gnu_entity routine dealing with the
2449 translation of subprograms.
2451 But if we have a return label defined, convert this into
2452 a branch to that label. */
2454 if (TREE_VALUE (gnu_return_label_stack
) != 0)
2455 expand_goto (TREE_VALUE (gnu_return_label_stack
));
2457 else if (TYPE_CI_CO_LIST (gnu_subprog_type
) != NULL_TREE
)
2459 if (list_length (TYPE_CI_CO_LIST (gnu_subprog_type
)) == 1)
2460 gnu_ret_val
= TREE_VALUE (TYPE_CI_CO_LIST (gnu_subprog_type
));
2463 = build_constructor (TREE_TYPE (gnu_subprog_type
),
2464 TYPE_CI_CO_LIST (gnu_subprog_type
));
2467 /* If the Ada subprogram is a function, we just need to return the
2468 expression. If the subprogram returns an unconstrained
2469 array, we have to allocate a new version of the result and
2470 return it. If we return by reference, return a pointer. */
2472 else if (Present (Expression (gnat_node
)))
2474 gnu_ret_val
= gnat_to_gnu (Expression (gnat_node
));
2476 /* Do not remove the padding from GNU_RET_VAL if the inner
2477 type is self-referential since we want to allocate the fixed
2478 size in that case. */
2479 if (TREE_CODE (gnu_ret_val
) == COMPONENT_REF
2480 && (TYPE_IS_PADDING_P
2481 (TREE_TYPE (TREE_OPERAND (gnu_ret_val
, 0))))
2482 && contains_placeholder_p
2483 (TYPE_SIZE (TREE_TYPE (gnu_ret_val
))))
2484 gnu_ret_val
= TREE_OPERAND (gnu_ret_val
, 0);
2486 if (TYPE_RETURNS_BY_REF_P (gnu_subprog_type
)
2487 || By_Ref (gnat_node
))
2488 gnu_ret_val
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_ret_val
);
2490 else if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type
))
2492 gnu_ret_val
= maybe_unconstrained_array (gnu_ret_val
);
2494 /* We have two cases: either the function returns with
2495 depressed stack or not. If not, we allocate on the
2496 secondary stack. If so, we allocate in the stack frame.
2497 if no copy is needed, the front end will set By_Ref,
2498 which we handle in the case above. */
2499 if (TYPE_RETURNS_STACK_DEPRESSED (gnu_subprog_type
))
2501 = build_allocator (TREE_TYPE (gnu_ret_val
), gnu_ret_val
,
2502 TREE_TYPE (gnu_subprog_type
), 0, -1);
2505 = build_allocator (TREE_TYPE (gnu_ret_val
), gnu_ret_val
,
2506 TREE_TYPE (gnu_subprog_type
),
2507 Procedure_To_Call (gnat_node
),
2508 Storage_Pool (gnat_node
));
2512 set_lineno (gnat_node
, 1);
2514 expand_return (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
2515 DECL_RESULT (current_function_decl
),
2518 expand_null_return ();
2523 case N_Goto_Statement
:
2524 if (type_annotate_only
)
2527 gnu_expr
= gnat_to_gnu (Name (gnat_node
));
2528 TREE_USED (gnu_expr
) = 1;
2529 set_lineno (gnat_node
, 1);
2530 expand_goto (gnu_expr
);
2533 /****************************/
2534 /* Chapter 6: Subprograms: */
2535 /****************************/
2537 case N_Subprogram_Declaration
:
2538 /* Unless there is a freeze node, declare the subprogram. We consider
2539 this a "definition" even though we're not generating code for
2540 the subprogram because we will be making the corresponding GCC
2543 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node
)))))
2544 gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node
)),
2549 case N_Abstract_Subprogram_Declaration
:
2550 /* This subprogram doesn't exist for code generation purposes, but we
2551 have to elaborate the types of any parameters, unless they are
2552 imported types (nothing to generate in this case). */
2554 = First_Formal (Defining_Entity (Specification (gnat_node
)));
2555 Present (gnat_temp
);
2556 gnat_temp
= Next_Formal_With_Extras (gnat_temp
))
2557 if (Is_Itype (Etype (gnat_temp
))
2558 && !From_With_Type (Etype (gnat_temp
)))
2559 gnat_to_gnu_entity (Etype (gnat_temp
), NULL_TREE
, 0);
2563 case N_Defining_Program_Unit_Name
:
2564 /* For a child unit identifier go up a level to get the
2565 specificaton. We get this when we try to find the spec of
2566 a child unit package that is the compilation unit being compiled. */
2567 gnat_to_code (Parent (gnat_node
));
2570 case N_Subprogram_Body
:
2572 /* Save debug output mode in case it is reset. */
2573 enum debug_info_type save_write_symbols
= write_symbols
;
2574 struct gcc_debug_hooks
*save_debug_hooks
= debug_hooks
;
2575 /* Definining identifier of a parameter to the subprogram. */
2576 Entity_Id gnat_param
;
2577 /* The defining identifier for the subprogram body. Note that if a
2578 specification has appeared before for this body, then the identifier
2579 occurring in that specification will also be a defining identifier
2580 and all the calls to this subprogram will point to that
2582 Entity_Id gnat_subprog_id
2583 = (Present (Corresponding_Spec (gnat_node
))
2584 ? Corresponding_Spec (gnat_node
) : Defining_Entity (gnat_node
));
2586 /* The FUNCTION_DECL node corresponding to the subprogram spec. */
2587 tree gnu_subprog_decl
;
2588 /* The FUNCTION_TYPE node corresponding to the subprogram spec. */
2589 tree gnu_subprog_type
;
2592 /* If this is a generic object or if it has been eliminated,
2595 if (Ekind (gnat_subprog_id
) == E_Generic_Procedure
2596 || Ekind (gnat_subprog_id
) == E_Generic_Function
2597 || Is_Eliminated (gnat_subprog_id
))
2600 /* If debug information is suppressed for the subprogram,
2601 turn debug mode off for the duration of processing. */
2602 if (Debug_Info_Off (gnat_subprog_id
))
2604 write_symbols
= NO_DEBUG
;
2605 debug_hooks
= &do_nothing_debug_hooks
;
2608 /* If this subprogram acts as its own spec, define it. Otherwise,
2609 just get the already-elaborated tree node. However, if this
2610 subprogram had its elaboration deferred, we will already have
2611 made a tree node for it. So treat it as not being defined in
2612 that case. Such a subprogram cannot have an address clause or
2613 a freeze node, so this test is safe, though it does disable
2614 some otherwise-useful error checking. */
2616 = gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
,
2617 Acts_As_Spec (gnat_node
)
2618 && ! present_gnu_tree (gnat_subprog_id
));
2620 gnu_subprog_type
= TREE_TYPE (gnu_subprog_decl
);
2622 /* Set the line number in the decl to correspond to that of
2623 the body so that the line number notes are written
2625 set_lineno (gnat_node
, 0);
2626 DECL_SOURCE_FILE (gnu_subprog_decl
) = input_filename
;
2627 DECL_SOURCE_LINE (gnu_subprog_decl
) = lineno
;
2629 begin_subprog_body (gnu_subprog_decl
);
2630 set_lineno (gnat_node
, 1);
2633 gnu_block_stack
= tree_cons (NULL_TREE
, NULL_TREE
, gnu_block_stack
);
2634 expand_start_bindings (0);
2636 gnu_cico_list
= TYPE_CI_CO_LIST (gnu_subprog_type
);
2638 /* If there are OUT parameters, we need to ensure that the
2639 return statement properly copies them out. We do this by
2640 making a new block and converting any inner return into a goto
2641 to a label at the end of the block. */
2643 if (gnu_cico_list
!= 0)
2645 gnu_return_label_stack
2646 = tree_cons (NULL_TREE
,
2647 build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
),
2648 gnu_return_label_stack
);
2650 expand_start_bindings (0);
2653 gnu_return_label_stack
2654 = tree_cons (NULL_TREE
, NULL_TREE
, gnu_return_label_stack
);
2656 /* See if there are any parameters for which we don't yet have
2657 GCC entities. These must be for OUT parameters for which we
2658 will be making VAR_DECL nodes here. Fill them in to
2659 TYPE_CI_CO_LIST, which must contain the empty entry as well.
2660 We can match up the entries because TYPE_CI_CO_LIST is in the
2661 order of the parameters. */
2663 for (gnat_param
= First_Formal (gnat_subprog_id
);
2664 Present (gnat_param
);
2665 gnat_param
= Next_Formal_With_Extras (gnat_param
))
2666 if (present_gnu_tree (gnat_param
))
2667 adjust_decl_rtl (get_gnu_tree (gnat_param
));
2670 /* Skip any entries that have been already filled in; they
2671 must correspond to IN OUT parameters. */
2672 for (; gnu_cico_list
!= 0 && TREE_VALUE (gnu_cico_list
) != 0;
2673 gnu_cico_list
= TREE_CHAIN (gnu_cico_list
))
2676 /* Do any needed references for padded types. */
2677 TREE_VALUE (gnu_cico_list
)
2678 = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_list
)),
2679 gnat_to_gnu_entity (gnat_param
, NULL_TREE
, 1));
2682 process_decls (Declarations (gnat_node
), Empty
, Empty
, 1, 1);
2684 /* Generate the code of the subprogram itself. A return statement
2685 will be present and any OUT parameters will be handled there. */
2686 gnat_to_code (Handled_Statement_Sequence (gnat_node
));
2688 expand_end_bindings (getdecls (), kept_level_p (), 0);
2689 poplevel (kept_level_p (), 1, 0);
2690 gnu_block_stack
= TREE_CHAIN (gnu_block_stack
);
2692 if (TREE_VALUE (gnu_return_label_stack
) != 0)
2696 expand_end_bindings (NULL_TREE
, kept_level_p (), 0);
2697 poplevel (kept_level_p (), 1, 0);
2698 expand_label (TREE_VALUE (gnu_return_label_stack
));
2700 gnu_cico_list
= TYPE_CI_CO_LIST (gnu_subprog_type
);
2701 set_lineno (gnat_node
, 1);
2702 if (list_length (gnu_cico_list
) == 1)
2703 gnu_retval
= TREE_VALUE (gnu_cico_list
);
2705 gnu_retval
= build_constructor (TREE_TYPE (gnu_subprog_type
),
2708 if (DECL_P (gnu_retval
) && DECL_BY_REF_P (gnu_retval
))
2710 = build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_retval
);
2713 (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
2714 DECL_RESULT (current_function_decl
),
2719 gnu_return_label_stack
= TREE_CHAIN (gnu_return_label_stack
);
2721 /* Disconnect the trees for parameters that we made variables for
2722 from the GNAT entities since these will become unusable after
2723 we end the function. */
2724 for (gnat_param
= First_Formal (gnat_subprog_id
);
2725 Present (gnat_param
);
2726 gnat_param
= Next_Formal_With_Extras (gnat_param
))
2727 if (TREE_CODE (get_gnu_tree (gnat_param
)) == VAR_DECL
)
2728 save_gnu_tree (gnat_param
, NULL_TREE
, 0);
2730 end_subprog_body ();
2731 mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node
)));
2732 write_symbols
= save_write_symbols
;
2733 debug_hooks
= save_debug_hooks
;
2737 case N_Function_Call
:
2738 case N_Procedure_Call_Statement
:
2740 if (type_annotate_only
)
2744 /* The GCC node corresponding to the GNAT subprogram name. This can
2745 either be a FUNCTION_DECL node if we are dealing with a standard
2746 subprogram call, or an indirect reference expression (an
2747 INDIRECT_REF node) pointing to a subprogram. */
2748 tree gnu_subprog_node
= gnat_to_gnu (Name (gnat_node
));
2749 /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */
2750 tree gnu_subprog_type
= TREE_TYPE (gnu_subprog_node
);
2751 tree gnu_subprog_addr
2752 = build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_subprog_node
);
2753 Entity_Id gnat_formal
;
2754 Node_Id gnat_actual
;
2755 tree gnu_actual_list
= NULL_TREE
;
2756 tree gnu_name_list
= NULL_TREE
;
2757 tree gnu_after_list
= NULL_TREE
;
2758 tree gnu_subprog_call
;
2760 switch (Nkind (Name (gnat_node
)))
2763 case N_Operator_Symbol
:
2764 case N_Expanded_Name
:
2765 case N_Attribute_Reference
:
2766 if (Is_Eliminated (Entity (Name (gnat_node
))))
2767 post_error_ne ("cannot call eliminated subprogram &!",
2768 gnat_node
, Entity (Name (gnat_node
)));
2771 if (TREE_CODE (gnu_subprog_type
) != FUNCTION_TYPE
)
2774 /* If we are calling a stubbed function, make this into a
2775 raise of Program_Error. Elaborate all our args first. */
2777 if (TREE_CODE (gnu_subprog_node
) == FUNCTION_DECL
2778 && DECL_STUBBED_P (gnu_subprog_node
))
2780 for (gnat_actual
= First_Actual (gnat_node
);
2781 Present (gnat_actual
);
2782 gnat_actual
= Next_Actual (gnat_actual
))
2783 expand_expr_stmt (gnat_to_gnu (gnat_actual
));
2785 if (Nkind (gnat_node
) == N_Function_Call
)
2787 gnu_result_type
= TREE_TYPE (gnu_subprog_type
);
2789 = build1 (NULL_EXPR
, gnu_result_type
,
2790 build_call_raise (raise_program_error_decl
));
2793 expand_expr_stmt (build_call_raise (raise_program_error_decl
));
2797 /* The only way we can be making a call via an access type is
2798 if Name is an explicit dereference. In that case, get the
2799 list of formal args from the type the access type is pointing
2800 to. Otherwise, get the formals from entity being called. */
2801 if (Nkind (Name (gnat_node
)) == N_Explicit_Dereference
)
2802 gnat_formal
= First_Formal (Etype (Name (gnat_node
)));
2803 else if (Nkind (Name (gnat_node
)) == N_Attribute_Reference
)
2804 /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
2807 gnat_formal
= First_Formal (Entity (Name (gnat_node
)));
2809 /* Create the list of the actual parameters as GCC expects it, namely
2810 a chain of TREE_LIST nodes in which the TREE_VALUE field of each
2811 node is a parameter-expression and the TREE_PURPOSE field is
2812 null. Skip OUT parameters that are not passed by reference. */
2814 for (gnat_actual
= First_Actual (gnat_node
);
2815 Present (gnat_actual
);
2816 gnat_formal
= Next_Formal_With_Extras (gnat_formal
),
2817 gnat_actual
= Next_Actual (gnat_actual
))
2819 tree gnu_formal_type
= gnat_to_gnu_type (Etype (gnat_formal
));
2821 = ((Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
)
2822 ? Expression (gnat_actual
) : gnat_actual
);
2823 tree gnu_name
= gnat_to_gnu (gnat_name
);
2824 tree gnu_name_type
= gnat_to_gnu_type (Etype (gnat_name
));
2827 /* If it's possible we may need to use this expression twice,
2828 make sure than any side-effects are handled via SAVE_EXPRs.
2829 Likewise if we need to force side-effects before the call.
2830 ??? This is more conservative than we need since we don't
2831 need to do this for pass-by-ref with no conversion.
2832 If we are passing a non-addressable Out or In Out parameter by
2833 reference, pass the address of a copy and set up to copy back
2834 out after the call. */
2836 if (Ekind (gnat_formal
) != E_In_Parameter
)
2838 gnu_name
= gnat_stabilize_reference (gnu_name
, 1);
2839 if (! addressable_p (gnu_name
)
2840 && present_gnu_tree (gnat_formal
)
2841 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal
))
2842 || DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal
))
2843 || DECL_BY_DESCRIPTOR_P (get_gnu_tree (gnat_formal
))))
2845 tree gnu_copy
= gnu_name
;
2847 /* Remove any unpadding on the actual and make a copy.
2848 But if the actual is a left-justified modular type,
2849 first convert to it. */
2850 if (TREE_CODE (gnu_name
) == COMPONENT_REF
2851 && (TYPE_IS_PADDING_P
2852 (TREE_TYPE (TREE_OPERAND (gnu_name
, 0)))))
2853 gnu_name
= gnu_copy
= TREE_OPERAND (gnu_name
, 0);
2854 else if (TREE_CODE (gnu_name_type
) == RECORD_TYPE
2855 && (TYPE_LEFT_JUSTIFIED_MODULAR_P
2857 gnu_name
= convert (gnu_name_type
, gnu_name
);
2859 gnu_actual
= save_expr (gnu_name
);
2861 /* Set up to move the copy back to the original. */
2862 gnu_after_list
= tree_cons (gnu_copy
, gnu_actual
,
2865 gnu_name
= gnu_actual
;
2869 /* If this was a procedure call, we may not have removed any
2870 padding. So do it here for the part we will use as an
2872 gnu_actual
= gnu_name
;
2873 if (Ekind (gnat_formal
) != E_Out_Parameter
2874 && TREE_CODE (TREE_TYPE (gnu_actual
)) == RECORD_TYPE
2875 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual
)))
2876 gnu_actual
= convert (get_unpadded_type (Etype (gnat_actual
)),
2879 if (Ekind (gnat_formal
) != E_Out_Parameter
2880 && Nkind (gnat_actual
) != N_Unchecked_Type_Conversion
2881 && Do_Range_Check (gnat_actual
))
2882 gnu_actual
= emit_range_check (gnu_actual
, Etype (gnat_formal
));
2884 /* Do any needed conversions. We need only check for
2885 unchecked conversion since normal conversions will be handled
2886 by just converting to the formal type. */
2887 if (Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
)
2890 = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual
)),
2893 /* One we've done the unchecked conversion, we still
2894 must ensure that the object is in range of the formal's
2896 if (Ekind (gnat_formal
) != E_Out_Parameter
2897 && Do_Range_Check (gnat_actual
))
2898 gnu_actual
= emit_range_check (gnu_actual
,
2899 Etype (gnat_formal
));
2902 /* We may have suppressed a conversion to the Etype of the
2903 actual since the parent is a procedure call. So add the
2905 gnu_actual
= convert (gnat_to_gnu_type (Etype (gnat_actual
)),
2908 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
2910 /* If we have not saved a GCC object for the formal, it means
2911 it is an OUT parameter not passed by reference. Otherwise,
2912 look at the PARM_DECL to see if it is passed by reference. */
2913 if (present_gnu_tree (gnat_formal
)
2914 && TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
2915 && DECL_BY_REF_P (get_gnu_tree (gnat_formal
)))
2917 if (Ekind (gnat_formal
) != E_In_Parameter
)
2919 gnu_actual
= gnu_name
;
2921 /* If we have a padded type, be sure we've removed the
2923 if (TREE_CODE (TREE_TYPE (gnu_actual
)) == RECORD_TYPE
2924 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual
)))
2926 = convert (get_unpadded_type (Etype (gnat_actual
)),
2930 /* The symmetry of the paths to the type of an entity is
2931 broken here since arguments don't know that they will
2932 be passed by ref. */
2933 gnu_formal_type
= TREE_TYPE (get_gnu_tree (gnat_formal
));
2934 gnu_actual
= build_unary_op (ADDR_EXPR
, gnu_formal_type
,
2937 else if (present_gnu_tree (gnat_formal
)
2938 && TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
2939 && DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal
)))
2941 gnu_formal_type
= TREE_TYPE (get_gnu_tree (gnat_formal
));
2942 gnu_actual
= maybe_implicit_deref (gnu_actual
);
2943 gnu_actual
= maybe_unconstrained_array (gnu_actual
);
2945 if (TREE_CODE (gnu_formal_type
) == RECORD_TYPE
2946 && TYPE_IS_PADDING_P (gnu_formal_type
))
2949 = TREE_TYPE (TYPE_FIELDS (gnu_formal_type
));
2950 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
2953 /* Take the address of the object and convert to the
2954 proper pointer type. We'd like to actually compute
2955 the address of the beginning of the array using
2956 an ADDR_EXPR of an ARRAY_REF, but there's a possibility
2957 that the ARRAY_REF might return a constant and we'd
2958 be getting the wrong address. Neither approach is
2959 exactly correct, but this is the most likely to work
2961 gnu_actual
= convert (gnu_formal_type
,
2962 build_unary_op (ADDR_EXPR
, NULL_TREE
,
2965 else if (present_gnu_tree (gnat_formal
)
2966 && TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
2967 && DECL_BY_DESCRIPTOR_P (get_gnu_tree (gnat_formal
)))
2969 /* If arg is 'Null_Parameter, pass zero descriptor. */
2970 if ((TREE_CODE (gnu_actual
) == INDIRECT_REF
2971 || TREE_CODE (gnu_actual
) == UNCONSTRAINED_ARRAY_REF
)
2972 && TREE_PRIVATE (gnu_actual
))
2974 = convert (DECL_ARG_TYPE (get_gnu_tree (gnat_formal
)),
2978 = build_unary_op (ADDR_EXPR
, NULL_TREE
,
2979 fill_vms_descriptor (gnu_actual
,
2984 tree gnu_actual_size
= TYPE_SIZE (TREE_TYPE (gnu_actual
));
2986 if (Ekind (gnat_formal
) != E_In_Parameter
)
2988 = chainon (gnu_name_list
,
2989 build_tree_list (NULL_TREE
, gnu_name
));
2991 if (! present_gnu_tree (gnat_formal
)
2992 || TREE_CODE (get_gnu_tree (gnat_formal
)) != PARM_DECL
)
2995 /* If this is 'Null_Parameter, pass a zero even though we are
2996 dereferencing it. */
2997 else if (TREE_CODE (gnu_actual
) == INDIRECT_REF
2998 && TREE_PRIVATE (gnu_actual
)
2999 && host_integerp (gnu_actual_size
, 1)
3000 && 0 >= compare_tree_int (gnu_actual_size
,
3004 (DECL_ARG_TYPE (get_gnu_tree (gnat_formal
)),
3005 convert (type_for_size
3006 (tree_low_cst (gnu_actual_size
, 1), 1),
3007 integer_zero_node
));
3010 = convert (TYPE_MAIN_VARIANT
3011 (DECL_ARG_TYPE (get_gnu_tree (gnat_formal
))),
3016 = chainon (gnu_actual_list
,
3017 build_tree_list (NULL_TREE
, gnu_actual
));
3020 gnu_subprog_call
= build (CALL_EXPR
, TREE_TYPE (gnu_subprog_type
),
3021 gnu_subprog_addr
, gnu_actual_list
,
3023 TREE_SIDE_EFFECTS (gnu_subprog_call
) = 1;
3025 /* If it is a function call, the result is the call expression. */
3026 if (Nkind (gnat_node
) == N_Function_Call
)
3028 gnu_result
= gnu_subprog_call
;
3030 /* If the function returns an unconstrained array or by reference,
3031 we have to de-dereference the pointer. */
3032 if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type
)
3033 || TYPE_RETURNS_BY_REF_P (gnu_subprog_type
))
3034 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
,
3037 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
3040 /* If this is the case where the GNAT tree contains a procedure call
3041 but the Ada procedure has copy in copy out parameters, the special
3042 parameter passing mechanism must be used. */
3043 else if (TYPE_CI_CO_LIST (gnu_subprog_type
) != NULL_TREE
)
3045 /* List of FIELD_DECLs associated with the PARM_DECLs of the copy
3046 in copy out parameters. */
3047 tree scalar_return_list
= TYPE_CI_CO_LIST (gnu_subprog_type
);
3048 int length
= list_length (scalar_return_list
);
3054 gnu_subprog_call
= make_save_expr (gnu_subprog_call
);
3056 /* If any of the names had side-effects, ensure they are
3057 all evaluated before the call. */
3058 for (gnu_name
= gnu_name_list
; gnu_name
;
3059 gnu_name
= TREE_CHAIN (gnu_name
))
3060 if (TREE_SIDE_EFFECTS (TREE_VALUE (gnu_name
)))
3062 = build (COMPOUND_EXPR
, TREE_TYPE (gnu_subprog_call
),
3063 TREE_VALUE (gnu_name
), gnu_subprog_call
);
3066 if (Nkind (Name (gnat_node
)) == N_Explicit_Dereference
)
3067 gnat_formal
= First_Formal (Etype (Name (gnat_node
)));
3069 gnat_formal
= First_Formal (Entity (Name (gnat_node
)));
3071 for (gnat_actual
= First_Actual (gnat_node
);
3072 Present (gnat_actual
);
3073 gnat_formal
= Next_Formal_With_Extras (gnat_formal
),
3074 gnat_actual
= Next_Actual (gnat_actual
))
3075 /* If we are dealing with a copy in copy out parameter, we must
3076 retrieve its value from the record returned in the function
3078 if (! (present_gnu_tree (gnat_formal
)
3079 && TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
3080 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal
))
3081 || (DECL_BY_COMPONENT_PTR_P
3082 (get_gnu_tree (gnat_formal
)))
3083 || DECL_BY_DESCRIPTOR_P (get_gnu_tree (gnat_formal
))))
3084 && Ekind (gnat_formal
) != E_In_Parameter
)
3086 /* Get the value to assign to this OUT or IN OUT
3087 parameter. It is either the result of the function if
3088 there is only a single such parameter or the appropriate
3089 field from the record returned. */
3091 = length
== 1 ? gnu_subprog_call
3092 : build_component_ref
3093 (gnu_subprog_call
, NULL_TREE
,
3094 TREE_PURPOSE (scalar_return_list
));
3095 int unchecked_conversion
3096 = Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
;
3097 /* If the actual is a conversion, get the inner expression,
3098 which will be the real destination, and convert the
3099 result to the type of the actual parameter. */
3101 = maybe_unconstrained_array (TREE_VALUE (gnu_name_list
));
3103 /* If the result is a padded type, remove the padding. */
3104 if (TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
3105 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result
)))
3107 = convert (TREE_TYPE (TYPE_FIELDS
3108 (TREE_TYPE (gnu_result
))),
3111 /* If the result is a type conversion, do it. */
3112 if (Nkind (gnat_actual
) == N_Type_Conversion
)
3114 = convert_with_check
3115 (Etype (Expression (gnat_actual
)), gnu_result
,
3116 Do_Overflow_Check (gnat_actual
),
3117 Do_Range_Check (Expression (gnat_actual
)),
3118 Float_Truncate (gnat_actual
));
3120 else if (unchecked_conversion
)
3122 = unchecked_convert (TREE_TYPE (gnu_actual
), gnu_result
);
3125 if (Do_Range_Check (gnat_actual
))
3126 gnu_result
= emit_range_check (gnu_result
,
3127 Etype (gnat_actual
));
3129 if (! (! TREE_CONSTANT (TYPE_SIZE
3130 (TREE_TYPE (gnu_actual
)))
3131 && TREE_CONSTANT (TYPE_SIZE
3132 (TREE_TYPE (gnu_result
)))))
3133 gnu_result
= convert (TREE_TYPE (gnu_actual
),
3137 set_lineno (gnat_node
, 1);
3138 expand_expr_stmt (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
3139 gnu_actual
, gnu_result
));
3140 scalar_return_list
= TREE_CHAIN (scalar_return_list
);
3141 gnu_name_list
= TREE_CHAIN (gnu_name_list
);
3146 set_lineno (gnat_node
, 1);
3147 expand_expr_stmt (gnu_subprog_call
);
3150 /* Handle anything we need to assign back. */
3151 for (gnu_expr
= gnu_after_list
;
3153 gnu_expr
= TREE_CHAIN (gnu_expr
))
3154 expand_expr_stmt (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
3155 TREE_PURPOSE (gnu_expr
),
3156 TREE_VALUE (gnu_expr
)));
3160 /*************************/
3161 /* Chapter 7: Packages: */
3162 /*************************/
3164 case N_Package_Declaration
:
3165 gnat_to_code (Specification (gnat_node
));
3168 case N_Package_Specification
:
3170 process_decls (Visible_Declarations (gnat_node
),
3171 Private_Declarations (gnat_node
), Empty
, 1, 1);
3174 case N_Package_Body
:
3176 /* If this is the body of a generic package - do nothing */
3177 if (Ekind (Corresponding_Spec (gnat_node
)) == E_Generic_Package
)
3180 process_decls (Declarations (gnat_node
), Empty
, Empty
, 1, 1);
3182 if (Present (Handled_Statement_Sequence (gnat_node
)))
3184 gnu_block_stack
= tree_cons (NULL_TREE
, NULL_TREE
, gnu_block_stack
);
3185 gnat_to_code (Handled_Statement_Sequence (gnat_node
));
3186 gnu_block_stack
= TREE_CHAIN (gnu_block_stack
);
3190 /*********************************/
3191 /* Chapter 8: Visibility Rules: */
3192 /*********************************/
3194 case N_Use_Package_Clause
:
3195 case N_Use_Type_Clause
:
3196 /* Nothing to do here - but these may appear in list of declarations */
3199 /***********************/
3200 /* Chapter 9: Tasks: */
3201 /***********************/
3203 case N_Protected_Type_Declaration
:
3206 case N_Single_Task_Declaration
:
3207 gnat_to_gnu_entity (Defining_Entity (gnat_node
), NULL_TREE
, 1);
3210 /***********************************************************/
3211 /* Chapter 10: Program Structure and Compilation Issues: */
3212 /***********************************************************/
3214 case N_Compilation_Unit
:
3216 /* For a body, first process the spec if there is one. */
3217 if (Nkind (Unit (gnat_node
)) == N_Package_Body
3218 || (Nkind (Unit (gnat_node
)) == N_Subprogram_Body
3219 && ! Acts_As_Spec (gnat_node
)))
3220 gnat_to_code (Library_Unit (gnat_node
));
3222 process_inlined_subprograms (gnat_node
);
3224 if (type_annotate_only
&& gnat_node
== Cunit (Main_Unit
))
3226 elaborate_all_entities (gnat_node
);
3228 if (Nkind (Unit (gnat_node
)) == N_Subprogram_Declaration
3229 || Nkind (Unit (gnat_node
)) == N_Generic_Package_Declaration
3230 || Nkind (Unit (gnat_node
)) == N_Generic_Subprogram_Declaration
)
3234 process_decls (Declarations (Aux_Decls_Node (gnat_node
)),
3235 Empty
, Empty
, 1, 1);
3237 gnat_to_code (Unit (gnat_node
));
3239 /* Process any pragmas following the unit. */
3240 if (Present (Pragmas_After (Aux_Decls_Node (gnat_node
))))
3241 for (gnat_temp
= First (Pragmas_After (Aux_Decls_Node (gnat_node
)));
3242 gnat_temp
; gnat_temp
= Next (gnat_temp
))
3243 gnat_to_code (gnat_temp
);
3245 /* Put all the Actions into the elaboration routine if we already had
3246 elaborations. This will happen anyway if they are statements, but we
3247 want to force declarations there too due to order-of-elaboration
3248 issues. Most should have Is_Statically_Allocated set. If we
3249 have had no elaborations, we have no order-of-elaboration issue and
3250 don't want to create elaborations here. */
3251 if (Is_Non_Empty_List (Actions (Aux_Decls_Node (gnat_node
))))
3252 for (gnat_temp
= First (Actions (Aux_Decls_Node (gnat_node
)));
3253 Present (gnat_temp
); gnat_temp
= Next (gnat_temp
))
3255 if (pending_elaborations_p ())
3256 add_pending_elaborations (NULL_TREE
,
3257 make_transform_expr (gnat_temp
));
3259 gnat_to_code (gnat_temp
);
3262 /* Generate elaboration code for this unit, if necessary, and
3263 say whether we did or not. */
3264 Set_Has_No_Elaboration_Code
3267 (Defining_Entity (Unit (gnat_node
)),
3268 Nkind (Unit (gnat_node
)) == N_Package_Body
3269 || Nkind (Unit (gnat_node
)) == N_Subprogram_Body
,
3270 get_pending_elaborations ()));
3274 case N_Subprogram_Body_Stub
:
3275 case N_Package_Body_Stub
:
3276 case N_Protected_Body_Stub
:
3277 case N_Task_Body_Stub
:
3278 /* Simply process whatever unit is being inserted. */
3279 gnat_to_code (Unit (Library_Unit (gnat_node
)));
3283 gnat_to_code (Proper_Body (gnat_node
));
3286 /***************************/
3287 /* Chapter 11: Exceptions: */
3288 /***************************/
3290 case N_Handled_Sequence_Of_Statements
:
3291 /* If there are exception handlers, start a new binding level that
3292 we can exit (since each exception handler will do so). Then
3293 declare a variable to save the old __gnat_jmpbuf value and a
3294 variable for our jmpbuf. Call setjmp and handle each of the
3295 possible exceptions if it returns one. */
3297 if (! type_annotate_only
&& Present (Exception_Handlers (gnat_node
)))
3299 tree gnu_jmpsave_decl
= 0;
3300 tree gnu_jmpbuf_decl
= 0;
3301 tree gnu_cleanup_call
= 0;
3302 tree gnu_cleanup_decl
;
3305 expand_start_bindings (1);
3307 if (! Zero_Cost_Handling (gnat_node
))
3310 = create_var_decl (get_identifier ("JMPBUF_SAVE"), NULL_TREE
,
3312 build_call_0_expr (get_jmpbuf_decl
),
3315 gnu_jmpbuf_decl
= create_var_decl (get_identifier ("JMP_BUF"),
3316 NULL_TREE
, jmpbuf_type
,
3317 NULL_TREE
, 0, 0, 0, 0,
3319 TREE_VALUE (gnu_block_stack
) = gnu_jmpbuf_decl
;
3322 /* See if we are to call a function when exiting this block. */
3323 if (Present (At_End_Proc (gnat_node
)))
3326 = build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node
)));
3329 = create_var_decl (get_identifier ("CLEANUP"), NULL_TREE
,
3330 integer_type_node
, NULL_TREE
, 0, 0, 0, 0,
3333 expand_decl_cleanup (gnu_cleanup_decl
, gnu_cleanup_call
);
3336 if (! Zero_Cost_Handling (gnat_node
))
3338 /* When we exit this block, restore the saved value. */
3339 expand_decl_cleanup (gnu_jmpsave_decl
,
3340 build_call_1_expr (set_jmpbuf_decl
,
3343 /* Call setjmp and handle exceptions if it returns one. */
3344 set_lineno (gnat_node
, 1);
3346 (build_call_1_expr (setjmp_decl
,
3347 build_unary_op (ADDR_EXPR
, NULL_TREE
,
3351 /* Restore our incoming longjmp value before we do anything. */
3352 expand_expr_stmt (build_call_1_expr (set_jmpbuf_decl
,
3356 expand_start_bindings (0);
3358 gnu_except_ptr_stack
3359 = tree_cons (NULL_TREE
,
3361 (get_identifier ("EXCEPT_PTR"), NULL_TREE
,
3362 build_pointer_type (except_type_node
),
3363 build_call_0_expr (get_excptr_decl
),
3365 gnu_except_ptr_stack
);
3367 /* Generate code for each exception handler. The code at
3368 N_Exception_Handler below does the real work. Note that
3369 we ignore the dummy exception handler for the identifier
3370 case, this is used only by the front end */
3371 if (Present (Exception_Handlers (gnat_node
)))
3373 = First_Non_Pragma (Exception_Handlers (gnat_node
));
3374 Present (gnat_temp
);
3375 gnat_temp
= Next_Non_Pragma (gnat_temp
))
3376 gnat_to_code (gnat_temp
);
3378 /* If none of the exception handlers did anything, re-raise
3379 but do not defer abortion. */
3380 set_lineno (gnat_node
, 1);
3382 (build_call_1_expr (raise_nodefer_decl
,
3383 TREE_VALUE (gnu_except_ptr_stack
)));
3385 gnu_except_ptr_stack
= TREE_CHAIN (gnu_except_ptr_stack
);
3386 expand_end_bindings (getdecls (), kept_level_p (), 0);
3387 poplevel (kept_level_p (), 1, 0);
3389 /* End the "if" on setjmp. Note that we have arranged things so
3390 control never returns here. */
3393 /* This is now immediately before the body proper. Set
3394 our jmp_buf as the current buffer. */
3396 (build_call_1_expr (set_jmpbuf_decl
,
3397 build_unary_op (ADDR_EXPR
, NULL_TREE
,
3402 /* If there are no exception handlers, we must not have an at end
3403 cleanup identifier, since the cleanup identifier should always
3404 generate a corresponding exception handler. */
3405 else if (! type_annotate_only
&& Present (At_End_Proc (gnat_node
)))
3408 /* Generate code and declarations for the prefix of this block,
3410 if (Present (First_Real_Statement (gnat_node
)))
3411 process_decls (Statements (gnat_node
), Empty
,
3412 First_Real_Statement (gnat_node
), 1, 1);
3414 /* Generate code for each statement in the block. */
3415 for (gnat_temp
= (Present (First_Real_Statement (gnat_node
))
3416 ? First_Real_Statement (gnat_node
)
3417 : First (Statements (gnat_node
)));
3418 Present (gnat_temp
); gnat_temp
= Next (gnat_temp
))
3419 gnat_to_code (gnat_temp
);
3421 /* For zero-cost exceptions, exit the block and then compile
3423 if (! type_annotate_only
&& Zero_Cost_Handling (gnat_node
)
3424 && Present (Exception_Handlers (gnat_node
)))
3426 expand_exit_something ();
3427 gnu_except_ptr_stack
3428 = tree_cons (NULL_TREE
, error_mark_node
, gnu_except_ptr_stack
);
3430 for (gnat_temp
= First_Non_Pragma (Exception_Handlers (gnat_node
));
3431 Present (gnat_temp
);
3432 gnat_temp
= Next_Non_Pragma (gnat_temp
))
3433 gnat_to_code (gnat_temp
);
3435 gnu_except_ptr_stack
= TREE_CHAIN (gnu_except_ptr_stack
);
3438 /* If we have handlers, close the block we made. */
3439 if (! type_annotate_only
&& Present (Exception_Handlers (gnat_node
)))
3441 expand_end_bindings (getdecls (), kept_level_p (), 0);
3442 poplevel (kept_level_p (), 1, 0);
3447 case N_Exception_Handler
:
3448 if (! Zero_Cost_Handling (gnat_node
))
3450 /* Unless this is "Others" or the special "Non-Ada" exception
3451 for Ada, make an "if" statement to select the proper
3452 exceptions. For "Others", exclude exceptions where
3453 Handled_By_Others is nonzero unless the All_Others flag is set.
3454 For "Non-ada", accept an exception if "Lang" is 'V'. */
3455 tree gnu_choice
= integer_zero_node
;
3457 for (gnat_temp
= First (Exception_Choices (gnat_node
));
3458 gnat_temp
; gnat_temp
= Next (gnat_temp
))
3462 if (Nkind (gnat_temp
) == N_Others_Choice
)
3464 if (All_Others (gnat_temp
))
3465 this_choice
= integer_one_node
;
3469 (EQ_EXPR
, integer_type_node
,
3474 (INDIRECT_REF
, NULL_TREE
,
3475 TREE_VALUE (gnu_except_ptr_stack
)),
3476 get_identifier ("not_handled_by_others"), NULL_TREE
)),
3480 else if (Nkind (gnat_temp
) == N_Identifier
3481 || Nkind (gnat_temp
) == N_Expanded_Name
)
3483 /* ??? Note that we have to use gnat_to_gnu_entity here
3484 since the type of the exception will be wrong in the
3485 VMS case and that's exactly what this test is for. */
3487 = gnat_to_gnu_entity (Entity (gnat_temp
), NULL_TREE
, 0);
3489 /* If this was a VMS exception, check import_code
3490 against the value of the exception. */
3491 if (TREE_CODE (TREE_TYPE (gnu_expr
)) == INTEGER_TYPE
)
3494 (EQ_EXPR
, integer_type_node
,
3497 (INDIRECT_REF
, NULL_TREE
,
3498 TREE_VALUE (gnu_except_ptr_stack
)),
3499 get_identifier ("import_code"), NULL_TREE
),
3504 (EQ_EXPR
, integer_type_node
,
3505 TREE_VALUE (gnu_except_ptr_stack
),
3507 (TREE_TYPE (TREE_VALUE (gnu_except_ptr_stack
)),
3508 build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
)));
3510 /* If this is the distinguished exception "Non_Ada_Error"
3511 (and we are in VMS mode), also allow a non-Ada
3512 exception (a VMS condition) to match. */
3513 if (Is_Non_Ada_Error (Entity (gnat_temp
)))
3516 = build_component_ref
3518 (INDIRECT_REF
, NULL_TREE
,
3519 TREE_VALUE (gnu_except_ptr_stack
)),
3520 get_identifier ("lang"), NULL_TREE
);
3524 (TRUTH_ORIF_EXPR
, integer_type_node
,
3526 (EQ_EXPR
, integer_type_node
, gnu_comp
,
3527 convert (TREE_TYPE (gnu_comp
),
3528 build_int_2 ('V', 0))),
3535 gnu_choice
= build_binary_op (TRUTH_ORIF_EXPR
, integer_type_node
,
3536 gnu_choice
, this_choice
);
3539 set_lineno (gnat_node
, 1);
3541 expand_start_cond (gnu_choice
, 0);
3544 for (gnat_temp
= First (Statements (gnat_node
));
3545 gnat_temp
; gnat_temp
= Next (gnat_temp
))
3546 gnat_to_code (gnat_temp
);
3548 /* At the end of the handler, exit the block. We made this block
3549 in N_Handled_Sequence_Of_Statements. */
3550 expand_exit_something ();
3552 if (! Zero_Cost_Handling (gnat_node
))
3557 /*******************************/
3558 /* Chapter 12: Generic Units: */
3559 /*******************************/
3561 case N_Generic_Function_Renaming_Declaration
:
3562 case N_Generic_Package_Renaming_Declaration
:
3563 case N_Generic_Procedure_Renaming_Declaration
:
3564 case N_Generic_Package_Declaration
:
3565 case N_Generic_Subprogram_Declaration
:
3566 case N_Package_Instantiation
:
3567 case N_Procedure_Instantiation
:
3568 case N_Function_Instantiation
:
3569 /* These nodes can appear on a declaration list but there is nothing to
3570 to be done with them. */
3574 /***************************************************/
3575 /* Chapter 13: Representation Clauses and */
3576 /* Implementation-Dependent Features: */
3577 /***************************************************/
3579 case N_Attribute_Definition_Clause
:
3581 /* The only one we need deal with is for 'Address. For the others, SEM
3582 puts the information elsewhere. We need only deal with 'Address
3583 if the object has a Freeze_Node (which it never will currently). */
3584 if (Get_Attribute_Id (Chars (gnat_node
)) != Attr_Address
3585 || No (Freeze_Node (Entity (Name (gnat_node
)))))
3588 /* Get the value to use as the address and save it as the
3589 equivalent for GNAT_TEMP. When the object is frozen,
3590 gnat_to_gnu_entity will do the right thing. */
3591 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
3592 save_gnu_tree (Entity (Name (gnat_node
)), gnu_expr
, 1);
3595 case N_Enumeration_Representation_Clause
:
3596 case N_Record_Representation_Clause
:
3598 /* We do nothing with these. SEM puts the information elsewhere. */
3601 case N_Code_Statement
:
3602 if (! type_annotate_only
)
3604 tree gnu_template
= gnat_to_gnu (Asm_Template (gnat_node
));
3605 tree gnu_input_list
= 0, gnu_output_list
= 0, gnu_orig_out_list
= 0;
3606 tree gnu_clobber_list
= 0;
3609 /* First process inputs, then outputs, then clobbers. */
3610 Setup_Asm_Inputs (gnat_node
);
3611 while (Present (gnat_temp
= Asm_Input_Value ()))
3613 tree gnu_value
= gnat_to_gnu (gnat_temp
);
3614 tree gnu_constr
= build_tree_list (NULL_TREE
, gnat_to_gnu
3615 (Asm_Input_Constraint ()));
3618 = tree_cons (gnu_constr
, gnu_value
, gnu_input_list
);
3622 Setup_Asm_Outputs (gnat_node
);
3623 while (Present (gnat_temp
= Asm_Output_Variable ()))
3625 tree gnu_value
= gnat_to_gnu (gnat_temp
);
3626 tree gnu_constr
= build_tree_list (NULL_TREE
, gnat_to_gnu
3627 (Asm_Output_Constraint ()));
3630 = tree_cons (gnu_constr
, gnu_value
, gnu_orig_out_list
);
3632 = tree_cons (gnu_constr
, gnu_value
, gnu_output_list
);
3636 Clobber_Setup (gnat_node
);
3637 while ((clobber
= Clobber_Get_Next ()) != 0)
3639 = tree_cons (NULL_TREE
,
3640 build_string (strlen (clobber
) + 1, clobber
),
3643 expand_asm_operands (gnu_template
, nreverse (gnu_output_list
),
3644 nreverse (gnu_input_list
), gnu_clobber_list
,
3645 Is_Asm_Volatile (gnat_node
),
3646 input_filename
, lineno
);
3648 /* Copy all the intermediate outputs into the specified outputs. */
3649 for (; gnu_output_list
;
3650 (gnu_output_list
= TREE_CHAIN (gnu_output_list
),
3651 gnu_orig_out_list
= TREE_CHAIN (gnu_orig_out_list
)))
3652 if (TREE_VALUE (gnu_orig_out_list
) != TREE_VALUE (gnu_output_list
))
3655 (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
3656 TREE_VALUE (gnu_orig_out_list
),
3657 TREE_VALUE (gnu_output_list
)));
3663 /***************************************************/
3665 /***************************************************/
3667 case N_Freeze_Entity
:
3668 process_freeze_entity (gnat_node
);
3669 process_decls (Actions (gnat_node
), Empty
, Empty
, 1, 1);
3672 case N_Itype_Reference
:
3673 if (! present_gnu_tree (Itype (gnat_node
)))
3674 process_type (Itype (gnat_node
));
3677 case N_Free_Statement
:
3678 if (! type_annotate_only
)
3680 tree gnu_ptr
= gnat_to_gnu (Expression (gnat_node
));
3685 /* If this is an unconstrained array, we know the object must
3686 have been allocated with the template in front of the object.
3687 So pass the template address, but get the total size. Do this
3688 by converting to a thin pointer. */
3689 if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr
)))
3691 = convert (build_pointer_type
3692 (TYPE_OBJECT_RECORD_TYPE
3693 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr
)))),
3696 gnu_obj_type
= TREE_TYPE (TREE_TYPE (gnu_ptr
));
3697 gnu_obj_size
= TYPE_SIZE_UNIT (gnu_obj_type
);
3698 align
= TYPE_ALIGN (gnu_obj_type
);
3700 if (TREE_CODE (gnu_obj_type
) == RECORD_TYPE
3701 && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type
))
3703 tree gnu_char_ptr_type
= build_pointer_type (char_type_node
);
3704 tree gnu_pos
= byte_position (TYPE_FIELDS (gnu_obj_type
));
3705 tree gnu_byte_offset
3706 = convert (gnu_char_ptr_type
,
3707 size_diffop (size_zero_node
, gnu_pos
));
3709 gnu_ptr
= convert (gnu_char_ptr_type
, gnu_ptr
);
3710 gnu_ptr
= build_binary_op (MINUS_EXPR
, gnu_char_ptr_type
,
3711 gnu_ptr
, gnu_byte_offset
);
3714 set_lineno (gnat_node
, 1);
3716 (build_call_alloc_dealloc (gnu_ptr
, gnu_obj_size
, align
,
3717 Procedure_To_Call (gnat_node
),
3718 Storage_Pool (gnat_node
)));
3722 case N_Raise_Constraint_Error
:
3723 case N_Raise_Program_Error
:
3724 case N_Raise_Storage_Error
:
3726 if (type_annotate_only
)
3729 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
3732 (Nkind (gnat_node
) == N_Raise_Constraint_Error
3733 ? raise_constraint_error_decl
3734 : Nkind (gnat_node
) == N_Raise_Program_Error
3735 ? raise_program_error_decl
: raise_storage_error_decl
);
3737 /* If the type is VOID, this is a statement, so we need to
3738 generate the code for the call. Handle a Condition, if there
3740 if (TREE_CODE (gnu_result_type
) == VOID_TYPE
)
3742 set_lineno (gnat_node
, 1);
3744 if (Present (Condition (gnat_node
)))
3745 expand_start_cond (gnat_to_gnu (Condition (gnat_node
)), 0);
3747 expand_expr_stmt (gnu_result
);
3748 if (Present (Condition (gnat_node
)))
3750 gnu_result
= error_mark_node
;
3753 gnu_result
= build1 (NULL_EXPR
, gnu_result_type
, gnu_result
);
3756 /* Nothing to do, since front end does all validation using the
3757 values that Gigi back-annotates. */
3758 case N_Validate_Unchecked_Conversion
:
3761 case N_Raise_Statement
:
3762 case N_Function_Specification
:
3763 case N_Procedure_Specification
:
3765 case N_Component_Association
:
3768 if (! type_annotate_only
)
3772 /* If the result is a constant that overflows, raise constraint error. */
3773 if (TREE_CODE (gnu_result
) == INTEGER_CST
3774 && TREE_CONSTANT_OVERFLOW (gnu_result
))
3776 post_error ("Constraint_Error will be raised at run-time?", gnat_node
);
3779 = build1 (NULL_EXPR
, gnu_result_type
,
3780 build_call_raise (raise_constraint_error_decl
));
3783 /* If our result has side-effects and is of an unconstrained type,
3784 make a SAVE_EXPR so that we can be sure it will only be referenced
3785 once. Note we must do this before any conversions. */
3786 if (TREE_SIDE_EFFECTS (gnu_result
)
3787 && (TREE_CODE (gnu_result_type
) == UNCONSTRAINED_ARRAY_TYPE
3788 || (TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
3789 && contains_placeholder_p (TYPE_SIZE (gnu_result_type
)))))
3790 gnu_result
= gnat_stabilize_reference (gnu_result
, 0);
3792 /* Now convert the result to the proper type. If the type is void or if
3793 we have no result, return error_mark_node to show we have no result.
3794 If the type of the result is correct or if we have a label (which doesn't
3795 have any well-defined type), return our result. Also don't do the
3796 conversion if the "desired" type involves a PLACEHOLDER_EXPR in its size
3797 since those are the cases where the front end may have the type wrong due
3798 to "instantiating" the unconstrained record with discriminant values
3799 or if this is a FIELD_DECL. If this is the Name of an assignment
3800 statement or a parameter of a procedure call, return what we have since
3801 the RHS has to be converted to our type there in that case, unless
3802 GNU_RESULT_TYPE has a simpler size. Similarly, if the two types are
3803 record types with the same name, the expression type has integral mode,
3804 and GNU_RESULT_TYPE BLKmode, don't convert. This will be the case when
3805 we are converting from a packable type to its actual type and we need
3806 those conversions to be NOPs in order for assignments into these types to
3807 work properly if the inner object is a bitfield and hence can't have
3808 its address taken. Finally, don't convert integral types that are the
3809 operand of an unchecked conversion since we need to ignore those
3810 conversions (for 'Valid). Otherwise, convert the result to the proper
3813 if (Present (Parent (gnat_node
))
3814 && ((Nkind (Parent (gnat_node
)) == N_Assignment_Statement
3815 && Name (Parent (gnat_node
)) == gnat_node
)
3816 || (Nkind (Parent (gnat_node
)) == N_Procedure_Call_Statement
3817 && Name (Parent (gnat_node
)) != gnat_node
)
3818 || (Nkind (Parent (gnat_node
)) == N_Unchecked_Type_Conversion
3819 && ! AGGREGATE_TYPE_P (gnu_result_type
)
3820 && ! AGGREGATE_TYPE_P (TREE_TYPE (gnu_result
)))
3821 || Nkind (Parent (gnat_node
)) == N_Parameter_Association
)
3822 && ! (TYPE_SIZE (gnu_result_type
) != 0
3823 && TYPE_SIZE (TREE_TYPE (gnu_result
)) != 0
3824 && (AGGREGATE_TYPE_P (gnu_result_type
)
3825 == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result
)))
3826 && ((TREE_CODE (TYPE_SIZE (gnu_result_type
)) == INTEGER_CST
3827 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result
)))
3829 || (TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
3830 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result
)))
3832 && ! (contains_placeholder_p (TYPE_SIZE (gnu_result_type
)))
3833 && (contains_placeholder_p
3834 (TYPE_SIZE (TREE_TYPE (gnu_result
))))))
3835 && ! (TREE_CODE (gnu_result_type
) == RECORD_TYPE
3836 && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_result_type
))))
3838 /* In this case remove padding only if the inner object is of
3839 self-referential size: in that case it must be an object of
3840 unconstrained type with a default discriminant. In other cases,
3841 we want to avoid copying too much data. */
3842 if (TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
3843 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result
))
3844 && contains_placeholder_p (TYPE_SIZE
3845 (TREE_TYPE (TYPE_FIELDS
3846 (TREE_TYPE (gnu_result
))))))
3847 gnu_result
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result
))),
3851 else if (TREE_CODE (gnu_result
) == LABEL_DECL
3852 || TREE_CODE (gnu_result
) == FIELD_DECL
3853 || TREE_CODE (gnu_result
) == ERROR_MARK
3854 || (TYPE_SIZE (gnu_result_type
) != 0
3855 && TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
3856 && TREE_CODE (gnu_result
) != INDIRECT_REF
3857 && contains_placeholder_p (TYPE_SIZE (gnu_result_type
)))
3858 || ((TYPE_NAME (gnu_result_type
)
3859 == TYPE_NAME (TREE_TYPE (gnu_result
)))
3860 && TREE_CODE (gnu_result_type
) == RECORD_TYPE
3861 && TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
3862 && TYPE_MODE (gnu_result_type
) == BLKmode
3863 && (GET_MODE_CLASS (TYPE_MODE (TREE_TYPE (gnu_result
)))
3866 /* Remove any padding record, but do nothing more in this case. */
3867 if (TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
3868 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result
)))
3869 gnu_result
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result
))),
3873 else if (gnu_result
== error_mark_node
3874 || gnu_result_type
== void_type_node
)
3875 gnu_result
= error_mark_node
;
3876 else if (gnu_result_type
!= TREE_TYPE (gnu_result
))
3877 gnu_result
= convert (gnu_result_type
, gnu_result
);
3879 /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on GNU_RESULT. */
3880 while ((TREE_CODE (gnu_result
) == NOP_EXPR
3881 || TREE_CODE (gnu_result
) == NON_LVALUE_EXPR
)
3882 && TREE_TYPE (TREE_OPERAND (gnu_result
, 0)) == TREE_TYPE (gnu_result
))
3883 gnu_result
= TREE_OPERAND (gnu_result
, 0);
3888 /* Force references to each of the entities in packages GNAT_NODE with's
3889 so that the debugging information for all of them are identical
3890 in all clients. Operate recursively on anything it with's, but check
3891 that we aren't elaborating something more than once. */
3893 /* The reason for this routine's existence is two-fold.
3894 First, with some debugging formats, notably MDEBUG on SGI
3895 IRIX, the linker will remove duplicate debugging information if two
3896 clients have identical debugguing information. With the normal scheme
3897 of elaboration, this does not usually occur, since entities in with'ed
3898 packages are elaborated on demand, and if clients have different usage
3899 patterns, the normal case, then the order and selection of entities
3900 will differ. In most cases however, it seems that linkers do not know
3901 how to eliminate duplicate debugging information, even if it is
3902 identical, so the use of this routine would increase the total amount
3903 of debugging information in the final executable.
3905 Second, this routine is called in type_annotate mode, to compute DDA
3906 information for types in withed units, for ASIS use */
3909 elaborate_all_entities (gnat_node
)
3912 Entity_Id gnat_with_clause
, gnat_entity
;
3914 save_gnu_tree (gnat_node
, integer_zero_node
, 1);
3916 /* Save entities in all context units. A body may have an implicit_with
3917 on its own spec, if the context includes a child unit, so don't save
3920 for (gnat_with_clause
= First (Context_Items (gnat_node
));
3921 Present (gnat_with_clause
);
3922 gnat_with_clause
= Next (gnat_with_clause
))
3923 if (Nkind (gnat_with_clause
) == N_With_Clause
3924 && ! present_gnu_tree (Library_Unit (gnat_with_clause
))
3925 && Library_Unit (gnat_with_clause
) != Library_Unit (Cunit (Main_Unit
)))
3927 elaborate_all_entities (Library_Unit (gnat_with_clause
));
3929 if (Ekind (Entity (Name (gnat_with_clause
))) == E_Package
)
3930 for (gnat_entity
= First_Entity (Entity (Name (gnat_with_clause
)));
3931 Present (gnat_entity
);
3932 gnat_entity
= Next_Entity (gnat_entity
))
3933 if (Is_Public (gnat_entity
)
3934 && Convention (gnat_entity
) != Convention_Intrinsic
3935 && Ekind (gnat_entity
) != E_Package
3936 && Ekind (gnat_entity
) != E_Package_Body
3937 && Ekind (gnat_entity
) != E_Operator
3938 && ! (IN (Ekind (gnat_entity
), Type_Kind
)
3939 && ! Is_Frozen (gnat_entity
))
3940 && ! ((Ekind (gnat_entity
) == E_Procedure
3941 || Ekind (gnat_entity
) == E_Function
)
3942 && Is_Intrinsic_Subprogram (gnat_entity
))
3943 && ! IN (Ekind (gnat_entity
), Named_Kind
)
3944 && ! IN (Ekind (gnat_entity
), Generic_Unit_Kind
))
3945 gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 0);
3948 if (Nkind (Unit (gnat_node
)) == N_Package_Body
&& type_annotate_only
)
3949 elaborate_all_entities (Library_Unit (gnat_node
));
3952 /* Do the processing of N_Freeze_Entity, GNAT_NODE. */
3955 process_freeze_entity (gnat_node
)
3958 Entity_Id gnat_entity
= Entity (gnat_node
);
3962 = (Nkind (Declaration_Node (gnat_entity
)) == N_Object_Declaration
3963 && present_gnu_tree (Declaration_Node (gnat_entity
)))
3964 ? get_gnu_tree (Declaration_Node (gnat_entity
)) : NULL_TREE
;
3966 /* If this is a package, need to generate code for the package. */
3967 if (Ekind (gnat_entity
) == E_Package
)
3970 (Parent (Corresponding_Body
3971 (Parent (Declaration_Node (gnat_entity
)))));
3975 /* Check for old definition after the above call. This Freeze_Node
3976 might be for one its Itypes. */
3978 = present_gnu_tree (gnat_entity
) ? get_gnu_tree (gnat_entity
) : 0;
3980 /* If this entity has an Address representation clause, GNU_OLD is the
3981 address, so discard it here. */
3982 if (Present (Address_Clause (gnat_entity
)))
3985 /* Don't do anything for class-wide types they are always
3986 transformed into their root type. */
3987 if (Ekind (gnat_entity
) == E_Class_Wide_Type
3988 || (Ekind (gnat_entity
) == E_Class_Wide_Subtype
3989 && Present (Equivalent_Type (gnat_entity
))))
3992 /* If we have a non-dummy type old tree, we have nothing to do. Unless
3993 this is the public view of a private type whose full view was not
3994 delayed, this node was never delayed as it should have been.
3995 Also allow this to happen for concurrent types since we may have
3996 frozen both the Corresponding_Record_Type and this type. */
3998 && ! (TREE_CODE (gnu_old
) == TYPE_DECL
3999 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old
))))
4001 if (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
4002 && Present (Full_View (gnat_entity
))
4003 && No (Freeze_Node (Full_View (gnat_entity
))))
4005 else if (Is_Concurrent_Type (gnat_entity
))
4011 /* Reset the saved tree, if any, and elaborate the object or type for real.
4012 If there is a full declaration, elaborate it and copy the type to
4013 GNAT_ENTITY. Likewise if this is the record subtype corresponding to
4014 a class wide type or subtype. */
4017 save_gnu_tree (gnat_entity
, NULL_TREE
, 0);
4018 if (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
4019 && Present (Full_View (gnat_entity
))
4020 && present_gnu_tree (Full_View (gnat_entity
)))
4021 save_gnu_tree (Full_View (gnat_entity
), NULL_TREE
, 0);
4022 if (Present (Class_Wide_Type (gnat_entity
))
4023 && Class_Wide_Type (gnat_entity
) != gnat_entity
)
4024 save_gnu_tree (Class_Wide_Type (gnat_entity
), NULL_TREE
, 0);
4027 if (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
4028 && Present (Full_View (gnat_entity
)))
4030 gnu_new
= gnat_to_gnu_entity (Full_View (gnat_entity
), NULL_TREE
, 1);
4032 /* The above call may have defined this entity (the simplest example
4033 of this is when we have a private enumeral type since the bounds
4034 will have the public view. */
4035 if (! present_gnu_tree (gnat_entity
))
4036 save_gnu_tree (gnat_entity
, gnu_new
, 0);
4037 if (Present (Class_Wide_Type (gnat_entity
))
4038 && Class_Wide_Type (gnat_entity
) != gnat_entity
)
4039 save_gnu_tree (Class_Wide_Type (gnat_entity
), gnu_new
, 0);
4042 gnu_new
= gnat_to_gnu_entity (gnat_entity
, gnu_init
, 1);
4044 /* If we've made any pointers to the old version of this type, we
4045 have to update them. Also copy the name of the old object to
4050 DECL_NAME (gnu_new
) = DECL_NAME (gnu_old
);
4051 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old
)),
4052 TREE_TYPE (gnu_new
));
4056 /* Process the list of inlined subprograms of GNAT_NODE, which is an
4057 N_Compilation_Unit. */
4060 process_inlined_subprograms (gnat_node
)
4063 Entity_Id gnat_entity
;
4066 /* If we can inline, generate RTL for all the inlined subprograms.
4067 Define the entity first so we set DECL_EXTERNAL. */
4068 if (optimize
> 0 && ! flag_no_inline
)
4069 for (gnat_entity
= First_Inlined_Subprogram (gnat_node
);
4070 Present (gnat_entity
);
4071 gnat_entity
= Next_Inlined_Subprogram (gnat_entity
))
4073 gnat_body
= Parent (Declaration_Node (gnat_entity
));
4075 if (Nkind (gnat_body
) != N_Subprogram_Body
)
4077 /* ??? This really should always be Present. */
4078 if (No (Corresponding_Body (gnat_body
)))
4082 = Parent (Declaration_Node (Corresponding_Body (gnat_body
)));
4085 if (Present (gnat_body
))
4087 gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 0);
4088 gnat_to_code (gnat_body
);
4093 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
4094 We make two passes, one to elaborate anything other than bodies (but
4095 we declare a function if there was no spec). The second pass
4096 elaborates the bodies.
4098 GNAT_END_LIST gives the element in the list past the end. Normally,
4099 this is Empty, but can be First_Real_Statement for a
4100 Handled_Sequence_Of_Statements.
4102 We make a complete pass through both lists if PASS1P is true, then make
4103 the second pass over both lists if PASS2P is true. The lists usually
4104 correspond to the public and private parts of a package. */
4107 process_decls (gnat_decls
, gnat_decls2
, gnat_end_list
, pass1p
, pass2p
)
4108 List_Id gnat_decls
, gnat_decls2
;
4109 Node_Id gnat_end_list
;
4112 List_Id gnat_decl_array
[2];
4116 gnat_decl_array
[0] = gnat_decls
, gnat_decl_array
[1] = gnat_decls2
;
4119 for (i
= 0; i
<= 1; i
++)
4120 if (Present (gnat_decl_array
[i
]))
4121 for (gnat_decl
= First (gnat_decl_array
[i
]);
4122 gnat_decl
!= gnat_end_list
; gnat_decl
= Next (gnat_decl
))
4124 set_lineno (gnat_decl
, 0);
4126 /* For package specs, we recurse inside the declarations,
4127 thus taking the two pass approach inside the boundary. */
4128 if (Nkind (gnat_decl
) == N_Package_Declaration
4129 && (Nkind (Specification (gnat_decl
)
4130 == N_Package_Specification
)))
4131 process_decls (Visible_Declarations (Specification (gnat_decl
)),
4132 Private_Declarations (Specification (gnat_decl
)),
4135 /* Similarly for any declarations in the actions of a
4137 else if (Nkind (gnat_decl
) == N_Freeze_Entity
)
4139 process_freeze_entity (gnat_decl
);
4140 process_decls (Actions (gnat_decl
), Empty
, Empty
, 1, 0);
4143 /* Package bodies with freeze nodes get their elaboration deferred
4144 until the freeze node, but the code must be placed in the right
4145 place, so record the code position now. */
4146 else if (Nkind (gnat_decl
) == N_Package_Body
4147 && Present (Freeze_Node (Corresponding_Spec (gnat_decl
))))
4148 record_code_position (gnat_decl
);
4150 else if (Nkind (gnat_decl
) == N_Package_Body_Stub
4151 && Present (Library_Unit (gnat_decl
))
4152 && Present (Freeze_Node
4155 (Library_Unit (gnat_decl
)))))))
4156 record_code_position
4157 (Proper_Body (Unit (Library_Unit (gnat_decl
))));
4159 /* We defer most subprogram bodies to the second pass.
4160 However, Init_Proc subprograms cannot be defered, but luckily
4161 don't need to be. */
4162 else if ((Nkind (gnat_decl
) == N_Subprogram_Body
4163 && (Chars (Defining_Entity (gnat_decl
))
4164 != Name_uInit_Proc
)))
4166 if (Acts_As_Spec (gnat_decl
))
4168 Node_Id gnat_subprog_id
= Defining_Entity (gnat_decl
);
4170 if (Ekind (gnat_subprog_id
) != E_Generic_Procedure
4171 && Ekind (gnat_subprog_id
) != E_Generic_Function
)
4172 gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
, 1);
4175 /* For bodies and stubs that act as their own specs, the entity
4176 itself must be elaborated in the first pass, because it may
4177 be used in other declarations. */
4178 else if (Nkind (gnat_decl
) == N_Subprogram_Body_Stub
)
4180 Node_Id gnat_subprog_id
=
4181 Defining_Entity (Specification (gnat_decl
));
4183 if (Ekind (gnat_subprog_id
) != E_Subprogram_Body
4184 && Ekind (gnat_subprog_id
) != E_Generic_Procedure
4185 && Ekind (gnat_subprog_id
) != E_Generic_Function
)
4186 gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
, 1);
4189 /* Concurrent stubs stand for the corresponding subprogram bodies,
4190 which are deferred like other bodies. */
4191 else if (Nkind (gnat_decl
) == N_Task_Body_Stub
4192 || Nkind (gnat_decl
) == N_Protected_Body_Stub
)
4196 gnat_to_code (gnat_decl
);
4199 /* Here we elaborate everything we deferred above except for package bodies,
4200 which are elaborated at their freeze nodes. Note that we must also
4201 go inside things (package specs and freeze nodes) the first pass did. */
4203 for (i
= 0; i
<= 1; i
++)
4204 if (Present (gnat_decl_array
[i
]))
4205 for (gnat_decl
= First (gnat_decl_array
[i
]);
4206 gnat_decl
!= gnat_end_list
; gnat_decl
= Next (gnat_decl
))
4208 if ((Nkind (gnat_decl
) == N_Subprogram_Body
4209 && (Chars (Defining_Entity (gnat_decl
))
4210 != Name_uInit_Proc
))
4211 || Nkind (gnat_decl
) == N_Subprogram_Body_Stub
4212 || Nkind (gnat_decl
) == N_Task_Body_Stub
4213 || Nkind (gnat_decl
) == N_Protected_Body_Stub
)
4214 gnat_to_code (gnat_decl
);
4216 else if (Nkind (gnat_decl
) == N_Package_Declaration
4217 && (Nkind (Specification (gnat_decl
)
4218 == N_Package_Specification
)))
4219 process_decls (Visible_Declarations (Specification (gnat_decl
)),
4220 Private_Declarations (Specification (gnat_decl
)),
4223 else if (Nkind (gnat_decl
) == N_Freeze_Entity
)
4224 process_decls (Actions (gnat_decl
), Empty
, Empty
, 0, 1);
4228 /* Emits an access check. GNU_EXPR is the expression that needs to be
4229 checked against the NULL pointer. */
4232 emit_access_check (gnu_expr
)
4235 tree gnu_type
= TREE_TYPE (gnu_expr
);
4237 /* This only makes sense if GNU_TYPE is a pointer of some sort. */
4238 if (! POINTER_TYPE_P (gnu_type
) && ! TYPE_FAT_POINTER_P (gnu_type
))
4241 /* Checked expressions must be evaluated only once. */
4242 gnu_expr
= make_save_expr (gnu_expr
);
4244 return emit_check (build_binary_op (EQ_EXPR
, integer_type_node
,
4246 convert (TREE_TYPE (gnu_expr
),
4247 integer_zero_node
)),
4251 /* Emits a discriminant check. GNU_EXPR is the expression to be checked and
4252 GNAT_NODE a N_Selected_Component node. */
4255 emit_discriminant_check (gnu_expr
, gnat_node
)
4260 = Original_Record_Component (Entity (Selector_Name (gnat_node
)));
4261 Entity_Id gnat_discr_fct
= Discriminant_Checking_Func (orig_comp
);
4263 Entity_Id gnat_discr
;
4264 tree gnu_actual_list
= NULL_TREE
;
4266 Entity_Id gnat_pref_type
;
4269 if (Is_Tagged_Type (Scope (orig_comp
)))
4270 gnat_pref_type
= Scope (orig_comp
);
4272 gnat_pref_type
= Etype (Prefix (gnat_node
));
4274 if (! Present (gnat_discr_fct
))
4277 gnu_discr_fct
= gnat_to_gnu (gnat_discr_fct
);
4279 /* Checked expressions must be evaluated only once. */
4280 gnu_expr
= make_save_expr (gnu_expr
);
4282 /* Create the list of the actual parameters as GCC expects it.
4283 This list is the list of the discriminant fields of the
4284 record expression to be discriminant checked. For documentation
4285 on what is the GCC format for this list see under the
4286 N_Function_Call case */
4288 while (IN (Ekind (gnat_pref_type
), Incomplete_Or_Private_Kind
)
4289 || IN (Ekind (gnat_pref_type
), Access_Kind
))
4291 if (IN (Ekind (gnat_pref_type
), Incomplete_Or_Private_Kind
))
4292 gnat_pref_type
= Underlying_Type (gnat_pref_type
);
4293 else if (IN (Ekind (gnat_pref_type
), Access_Kind
))
4294 gnat_pref_type
= Designated_Type (gnat_pref_type
);
4298 = TREE_TYPE (gnat_to_gnu_entity (gnat_pref_type
, NULL_TREE
, 0));
4300 for (gnat_discr
= First_Discriminant (gnat_pref_type
);
4301 Present (gnat_discr
); gnat_discr
= Next_Discriminant (gnat_discr
))
4303 Entity_Id gnat_real_discr
4304 = ((Present (Corresponding_Discriminant (gnat_discr
))
4305 && Present (Parent_Subtype (gnat_pref_type
)))
4306 ? Corresponding_Discriminant (gnat_discr
) : gnat_discr
);
4307 tree gnu_discr
= gnat_to_gnu_entity (gnat_real_discr
, NULL_TREE
, 0);
4310 = chainon (gnu_actual_list
,
4311 build_tree_list (NULL_TREE
,
4313 (convert (gnu_pref_type
, gnu_expr
),
4314 NULL_TREE
, gnu_discr
)));
4317 gnu_cond
= build (CALL_EXPR
,
4318 TREE_TYPE (TREE_TYPE (gnu_discr_fct
)),
4319 build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_discr_fct
),
4322 TREE_SIDE_EFFECTS (gnu_cond
) = 1;
4326 (INDIRECT_REF
, NULL_TREE
,
4327 emit_check (gnu_cond
,
4328 build_unary_op (ADDR_EXPR
,
4329 build_reference_type (TREE_TYPE (gnu_expr
)),
4333 /* Emit code for a range check. GNU_EXPR is the expression to be checked,
4334 GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
4335 which we have to check. */
4338 emit_range_check (gnu_expr
, gnat_range_type
)
4340 Entity_Id gnat_range_type
;
4342 tree gnu_range_type
= get_unpadded_type (gnat_range_type
);
4343 tree gnu_low
= TYPE_MIN_VALUE (gnu_range_type
);
4344 tree gnu_high
= TYPE_MAX_VALUE (gnu_range_type
);
4345 tree gnu_compare_type
= get_base_type (TREE_TYPE (gnu_expr
));
4347 /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE,
4348 we can't do anything since we might be truncating the bounds. No
4349 check is needed in this case. */
4350 if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr
))
4351 && (TYPE_PRECISION (gnu_compare_type
)
4352 < TYPE_PRECISION (get_base_type (gnu_range_type
))))
4355 /* Checked expressions must be evaluated only once. */
4356 gnu_expr
= make_save_expr (gnu_expr
);
4358 /* There's no good type to use here, so we might as well use
4359 integer_type_node. Note that the form of the check is
4360 (not (expr >= lo)) or (not (expr >= hi))
4361 the reason for this slightly convoluted form is that NaN's
4362 are not considered to be in range in the float case. */
4364 (build_binary_op (TRUTH_ORIF_EXPR
, integer_type_node
,
4366 (build_binary_op (GE_EXPR
, integer_type_node
,
4367 convert (gnu_compare_type
, gnu_expr
),
4368 convert (gnu_compare_type
, gnu_low
))),
4370 (build_binary_op (LE_EXPR
, integer_type_node
,
4371 convert (gnu_compare_type
, gnu_expr
),
4372 convert (gnu_compare_type
,
4377 /* Emit code for an index check. GNU_ARRAY_OBJECT is the array object
4378 which we are about to index, GNU_EXPR is the index expression to be
4379 checked, GNU_LOW and GNU_HIGH are the lower and upper bounds
4380 against which GNU_EXPR has to be checked. Note that for index
4381 checking we cannot use the emit_range_check function (although very
4382 similar code needs to be generated in both cases) since for index
4383 checking the array type against which we are checking the indeces
4384 may be unconstrained and consequently we need to retrieve the
4385 actual index bounds from the array object itself
4386 (GNU_ARRAY_OBJECT). The place where we need to do that is in
4387 subprograms having unconstrained array formal parameters */
4390 emit_index_check (gnu_array_object
, gnu_expr
, gnu_low
, gnu_high
)
4391 tree gnu_array_object
;
4396 tree gnu_expr_check
;
4398 /* Checked expressions must be evaluated only once. */
4399 gnu_expr
= make_save_expr (gnu_expr
);
4401 /* Must do this computation in the base type in case the expression's
4402 type is an unsigned subtypes. */
4403 gnu_expr_check
= convert (get_base_type (TREE_TYPE (gnu_expr
)), gnu_expr
);
4405 /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by
4406 the object we are handling. */
4407 if (TREE_CODE (gnu_low
) != INTEGER_CST
&& contains_placeholder_p (gnu_low
))
4408 gnu_low
= build (WITH_RECORD_EXPR
, TREE_TYPE (gnu_low
),
4409 gnu_low
, gnu_array_object
);
4411 if (TREE_CODE (gnu_high
) != INTEGER_CST
&& contains_placeholder_p (gnu_high
))
4412 gnu_high
= build (WITH_RECORD_EXPR
, TREE_TYPE (gnu_high
),
4413 gnu_high
, gnu_array_object
);
4415 /* There's no good type to use here, so we might as well use
4416 integer_type_node. */
4418 (build_binary_op (TRUTH_ORIF_EXPR
, integer_type_node
,
4419 build_binary_op (LT_EXPR
, integer_type_node
,
4421 convert (TREE_TYPE (gnu_expr_check
),
4423 build_binary_op (GT_EXPR
, integer_type_node
,
4425 convert (TREE_TYPE (gnu_expr_check
),
4430 /* Given GNU_COND which contains the condition corresponding to an access,
4431 discriminant or range check, of value GNU_EXPR, build a COND_EXPR
4432 that returns GNU_EXPR if GNU_COND is false and raises a
4433 CONSTRAINT_ERROR if GNU_COND is true. */
4436 emit_check (gnu_cond
, gnu_expr
)
4442 gnu_call
= build_call_raise (raise_constraint_error_decl
);
4444 /* Use an outer COMPOUND_EXPR to make sure that GNU_EXPR will
4445 get evaluated in front of the comparison in case it ends
4446 up being a SAVE_EXPR. Put the whole thing inside its own
4447 SAVE_EXPR do the inner SAVE_EXPR doesn't leak out. */
4449 return make_save_expr (build (COMPOUND_EXPR
, TREE_TYPE (gnu_expr
), gnu_expr
,
4450 fold (build (COND_EXPR
, TREE_TYPE (gnu_expr
),
4452 build (COMPOUND_EXPR
,
4453 TREE_TYPE (gnu_expr
),
4454 gnu_call
, gnu_expr
),
4458 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing
4459 overflow checks if OVERFLOW_P is nonzero and range checks if
4460 RANGE_P is nonzero. GNAT_TYPE is known to be an integral type.
4461 If TRUNCATE_P is nonzero, do a float to integer conversion with
4462 truncation; otherwise round. */
4465 convert_with_check (gnat_type
, gnu_expr
, overflow_p
, range_p
, truncate_p
)
4466 Entity_Id gnat_type
;
4472 tree gnu_type
= get_unpadded_type (gnat_type
);
4473 tree gnu_in_type
= TREE_TYPE (gnu_expr
);
4474 tree gnu_in_basetype
= get_base_type (gnu_in_type
);
4475 tree gnu_base_type
= get_base_type (gnu_type
);
4476 tree gnu_ada_base_type
= get_ada_base_type (gnu_type
);
4477 tree gnu_in_lb
= TYPE_MIN_VALUE (gnu_in_basetype
);
4478 tree gnu_in_ub
= TYPE_MAX_VALUE (gnu_in_basetype
);
4479 tree gnu_out_lb
= TYPE_MIN_VALUE (gnu_base_type
);
4480 tree gnu_out_ub
= TYPE_MAX_VALUE (gnu_base_type
);
4481 tree gnu_result
= gnu_expr
;
4483 /* If we are not doing any checks, the output is an integral type, and
4484 the input is not a floating type, just do the conversion. This
4485 shortcut is required to avoid problems with packed array types
4486 and simplifies code in all cases anyway. */
4487 if (! range_p
&& ! overflow_p
&& INTEGRAL_TYPE_P (gnu_base_type
)
4488 && ! FLOAT_TYPE_P (gnu_in_type
))
4489 return convert (gnu_type
, gnu_expr
);
4491 /* First convert the expression to its base type. This
4492 will never generate code, but makes the tests below much simpler.
4493 But don't do this if converting from an integer type to an unconstrained
4494 array type since then we need to get the bounds from the original
4496 if (TREE_CODE (gnu_type
) != UNCONSTRAINED_ARRAY_TYPE
)
4497 gnu_result
= convert (gnu_in_basetype
, gnu_result
);
4499 /* If overflow checks are requested, we need to be sure the result will
4500 fit in the output base type. But don't do this if the input
4501 is integer and the output floating-point. */
4503 && ! (FLOAT_TYPE_P (gnu_base_type
) && INTEGRAL_TYPE_P (gnu_in_basetype
)))
4505 /* Ensure GNU_EXPR only gets evaluated once. */
4506 tree gnu_input
= make_save_expr (gnu_result
);
4507 tree gnu_cond
= integer_zero_node
;
4509 /* Convert the lower bounds to signed types, so we're sure we're
4510 comparing them properly. Likewise, convert the upper bounds
4511 to unsigned types. */
4512 if (INTEGRAL_TYPE_P (gnu_in_basetype
) && TREE_UNSIGNED (gnu_in_basetype
))
4513 gnu_in_lb
= convert (signed_type (gnu_in_basetype
), gnu_in_lb
);
4515 if (INTEGRAL_TYPE_P (gnu_in_basetype
)
4516 && ! TREE_UNSIGNED (gnu_in_basetype
))
4517 gnu_in_ub
= convert (unsigned_type (gnu_in_basetype
), gnu_in_ub
);
4519 if (INTEGRAL_TYPE_P (gnu_base_type
) && TREE_UNSIGNED (gnu_base_type
))
4520 gnu_out_lb
= convert (signed_type (gnu_base_type
), gnu_out_lb
);
4522 if (INTEGRAL_TYPE_P (gnu_base_type
) && ! TREE_UNSIGNED (gnu_base_type
))
4523 gnu_out_ub
= convert (unsigned_type (gnu_base_type
), gnu_out_ub
);
4525 /* Check each bound separately and only if the result bound
4526 is tighter than the bound on the input type. Note that all the
4527 types are base types, so the bounds must be constant. Also,
4528 the comparison is done in the base type of the input, which
4529 always has the proper signedness. First check for input
4530 integer (which means output integer), output float (which means
4531 both float), or mixed, in which case we always compare.
4532 Note that we have to do the comparison which would *fail* in the
4533 case of an error since if it's an FP comparison and one of the
4534 values is a NaN or Inf, the comparison will fail. */
4535 if (INTEGRAL_TYPE_P (gnu_in_basetype
)
4536 ? tree_int_cst_lt (gnu_in_lb
, gnu_out_lb
)
4537 : (FLOAT_TYPE_P (gnu_base_type
)
4538 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_in_lb
),
4539 TREE_REAL_CST (gnu_out_lb
))
4543 (build_binary_op (GE_EXPR
, integer_type_node
,
4544 gnu_input
, convert (gnu_in_basetype
,
4547 if (INTEGRAL_TYPE_P (gnu_in_basetype
)
4548 ? tree_int_cst_lt (gnu_out_ub
, gnu_in_ub
)
4549 : (FLOAT_TYPE_P (gnu_base_type
)
4550 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_out_ub
),
4551 TREE_REAL_CST (gnu_in_lb
))
4554 = build_binary_op (TRUTH_ORIF_EXPR
, integer_type_node
, gnu_cond
,
4556 (build_binary_op (LE_EXPR
, integer_type_node
,
4558 convert (gnu_in_basetype
,
4561 if (! integer_zerop (gnu_cond
))
4562 gnu_result
= emit_check (gnu_cond
, gnu_input
);
4565 /* Now convert to the result base type. If this is a non-truncating
4566 float-to-integer conversion, round. */
4567 if (INTEGRAL_TYPE_P (gnu_ada_base_type
) && FLOAT_TYPE_P (gnu_in_basetype
)
4570 tree gnu_point_5
= build_real (gnu_in_basetype
, dconstp5
);
4571 tree gnu_minus_point_5
= build_real (gnu_in_basetype
, dconstmp5
);
4572 tree gnu_zero
= convert (gnu_in_basetype
, integer_zero_node
);
4573 tree gnu_saved_result
= save_expr (gnu_result
);
4574 tree gnu_comp
= build (GE_EXPR
, integer_type_node
,
4575 gnu_saved_result
, gnu_zero
);
4576 tree gnu_adjust
= build (COND_EXPR
, gnu_in_basetype
, gnu_comp
,
4577 gnu_point_5
, gnu_minus_point_5
);
4580 = build (PLUS_EXPR
, gnu_in_basetype
, gnu_saved_result
, gnu_adjust
);
4583 if (TREE_CODE (gnu_ada_base_type
) == INTEGER_TYPE
4584 && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_ada_base_type
)
4585 && TREE_CODE (gnu_result
) == UNCONSTRAINED_ARRAY_REF
)
4586 gnu_result
= unchecked_convert (gnu_ada_base_type
, gnu_result
);
4588 gnu_result
= convert (gnu_ada_base_type
, gnu_result
);
4590 /* Finally, do the range check if requested. Note that if the
4591 result type is a modular type, the range check is actually
4592 an overflow check. */
4595 || (TREE_CODE (gnu_base_type
) == INTEGER_TYPE
4596 && TYPE_MODULAR_P (gnu_base_type
) && overflow_p
))
4597 gnu_result
= emit_range_check (gnu_result
, gnat_type
);
4599 return convert (gnu_type
, gnu_result
);
4602 /* Return 1 if GNU_EXPR can be directly addressed. This is the case unless
4603 it is an expression involving computation or if it involves a bitfield
4604 reference. This returns the same as mark_addressable in most cases. */
4607 addressable_p (gnu_expr
)
4610 switch (TREE_CODE (gnu_expr
))
4612 case UNCONSTRAINED_ARRAY_REF
:
4623 return (! DECL_BIT_FIELD (TREE_OPERAND (gnu_expr
, 1))
4624 && addressable_p (TREE_OPERAND (gnu_expr
, 0)));
4626 case ARRAY_REF
: case ARRAY_RANGE_REF
:
4627 case REALPART_EXPR
: case IMAGPART_EXPR
:
4629 return addressable_p (TREE_OPERAND (gnu_expr
, 0));
4632 return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr
))
4633 && addressable_p (TREE_OPERAND (gnu_expr
, 0)));
4635 case UNCHECKED_CONVERT_EXPR
:
4637 /* This is addressable if the code in gnat_expand_expr can do
4638 it by either just taking the operand or by pointer punning. */
4639 tree inner
= TREE_OPERAND (gnu_expr
, 0);
4640 tree type
= TREE_TYPE (gnu_expr
);
4641 tree inner_type
= TREE_TYPE (inner
);
4643 return ((TYPE_MODE (type
) == TYPE_MODE (inner_type
)
4644 && (TYPE_ALIGN (type
) <= TYPE_ALIGN (inner_type
)
4645 || TYPE_ALIGN (inner_type
) >= BIGGEST_ALIGNMENT
))
4646 || ((TYPE_MODE (type
) == BLKmode
4647 || TYPE_MODE (inner_type
) == BLKmode
)
4648 && (TYPE_ALIGN (type
) <= TYPE_ALIGN (inner_type
)
4649 || TYPE_ALIGN (inner_type
) >= BIGGEST_ALIGNMENT
4650 || TYPE_ALIGN_OK_P (type
)
4651 || TYPE_ALIGN_OK_P (inner_type
))));
4659 /* Do the processing for the declaration of a GNAT_ENTITY, a type. If
4660 a separate Freeze node exists, delay the bulk of the processing. Otherwise
4661 make a GCC type for GNAT_ENTITY and set up the correspondance. */
4664 process_type (gnat_entity
)
4665 Entity_Id gnat_entity
;
4668 = present_gnu_tree (gnat_entity
) ? get_gnu_tree (gnat_entity
) : 0;
4671 /* If we are to delay elaboration of this type, just do any
4672 elaborations needed for expressions within the declaration and
4673 make a dummy type entry for this node and its Full_View (if
4674 any) in case something points to it. Don't do this if it
4675 has already been done (the only way that can happen is if
4676 the private completion is also delayed). */
4677 if (Present (Freeze_Node (gnat_entity
))
4678 || (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
4679 && Present (Full_View (gnat_entity
))
4680 && Freeze_Node (Full_View (gnat_entity
))
4681 && ! present_gnu_tree (Full_View (gnat_entity
))))
4683 elaborate_entity (gnat_entity
);
4687 tree gnu_decl
= create_type_decl (get_entity_name (gnat_entity
),
4688 make_dummy_type (gnat_entity
),
4691 save_gnu_tree (gnat_entity
, gnu_decl
, 0);
4692 if (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
4693 && Present (Full_View (gnat_entity
)))
4694 save_gnu_tree (Full_View (gnat_entity
), gnu_decl
, 0);
4700 /* If we saved away a dummy type for this node it means that this
4701 made the type that corresponds to the full type of an incomplete
4702 type. Clear that type for now and then update the type in the
4706 if (TREE_CODE (gnu_old
) != TYPE_DECL
4707 || ! TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old
)))
4709 /* If this was a withed access type, this is not an error
4710 and merely indicates we've already elaborated the type
4712 if (Is_Type (gnat_entity
) && From_With_Type (gnat_entity
))
4718 save_gnu_tree (gnat_entity
, NULL_TREE
, 0);
4721 /* Now fully elaborate the type. */
4722 gnu_new
= gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 1);
4723 if (TREE_CODE (gnu_new
) != TYPE_DECL
)
4726 /* If we have an old type and we've made pointers to this type,
4727 update those pointers. */
4729 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old
)),
4730 TREE_TYPE (gnu_new
));
4732 /* If this is a record type corresponding to a task or protected type
4733 that is a completion of an incomplete type, perform a similar update
4735 /* ??? Including protected types here is a guess. */
4737 if (IN (Ekind (gnat_entity
), Record_Kind
)
4738 && Is_Concurrent_Record_Type (gnat_entity
)
4739 && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
)))
4742 = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
));
4744 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
),
4746 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
),
4749 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old
)),
4750 TREE_TYPE (gnu_new
));
4754 /* GNAT_ASSOC is the front of the Component_Associations of an N_Aggregate.
4755 GNU_TYPE is the GCC type of the corresponding record.
4757 Return a CONSTRUCTOR to build the record. */
4760 assoc_to_constructor (gnat_assoc
, gnu_type
)
4764 tree gnu_field
, gnu_list
, gnu_result
;
4766 /* We test for GNU_FIELD being empty in the case where a variant
4767 was the last thing since we don't take things off GNAT_ASSOC in
4768 that case. We check GNAT_ASSOC in case we have a variant, but it
4771 for (gnu_list
= NULL_TREE
; Present (gnat_assoc
);
4772 gnat_assoc
= Next (gnat_assoc
))
4774 Node_Id gnat_field
= First (Choices (gnat_assoc
));
4775 tree gnu_field
= gnat_to_gnu_entity (Entity (gnat_field
), NULL_TREE
, 0);
4776 tree gnu_expr
= gnat_to_gnu (Expression (gnat_assoc
));
4778 /* The expander is supposed to put a single component selector name
4779 in every record component association */
4780 if (Next (gnat_field
))
4783 /* Before assigning a value in an aggregate make sure range checks
4784 are done if required. Then convert to the type of the field. */
4785 if (Do_Range_Check (Expression (gnat_assoc
)))
4786 gnu_expr
= emit_range_check (gnu_expr
, Etype (gnat_field
));
4788 gnu_expr
= convert (TREE_TYPE (gnu_field
), gnu_expr
);
4790 /* Add the field and expression to the list. */
4791 gnu_list
= tree_cons (gnu_field
, gnu_expr
, gnu_list
);
4794 gnu_result
= extract_values (gnu_list
, gnu_type
);
4796 /* Verify every enty in GNU_LIST was used. */
4797 for (gnu_field
= gnu_list
; gnu_field
; gnu_field
= TREE_CHAIN (gnu_field
))
4798 if (! TREE_ADDRESSABLE (gnu_field
))
4804 /* Builds a possibly nested constructor for array aggregates. GNAT_EXPR
4805 is the first element of an array aggregate. It may itself be an
4806 aggregate (an array or record aggregate). GNU_ARRAY_TYPE is the gnu type
4807 corresponding to the array aggregate. GNAT_COMPONENT_TYPE is the type
4808 of the array component. It is needed for range checking. */
4811 pos_to_constructor (gnat_expr
, gnu_array_type
, gnat_component_type
)
4813 tree gnu_array_type
;
4814 Entity_Id gnat_component_type
;
4817 tree gnu_expr_list
= NULL_TREE
;
4819 for ( ; Present (gnat_expr
); gnat_expr
= Next (gnat_expr
))
4821 /* If the expression is itself an array aggregate then first build the
4822 innermost constructor if it is part of our array (multi-dimensional
4825 if (Nkind (gnat_expr
) == N_Aggregate
4826 && TREE_CODE (TREE_TYPE (gnu_array_type
)) == ARRAY_TYPE
4827 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type
)))
4828 gnu_expr
= pos_to_constructor (First (Expressions (gnat_expr
)),
4829 TREE_TYPE (gnu_array_type
),
4830 gnat_component_type
);
4833 gnu_expr
= gnat_to_gnu (gnat_expr
);
4835 /* before assigning the element to the array make sure it is
4837 if (Do_Range_Check (gnat_expr
))
4838 gnu_expr
= emit_range_check (gnu_expr
, gnat_component_type
);
4842 = tree_cons (NULL_TREE
, convert (TREE_TYPE (gnu_array_type
), gnu_expr
),
4846 return build_constructor (gnu_array_type
, nreverse (gnu_expr_list
));
4849 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
4850 some of which are from RECORD_TYPE. Return a CONSTRUCTOR consisting
4851 of the associations that are from RECORD_TYPE. If we see an internal
4852 record, make a recursive call to fill it in as well. */
4855 extract_values (values
, record_type
)
4859 tree result
= NULL_TREE
;
4862 for (field
= TYPE_FIELDS (record_type
); field
; field
= TREE_CHAIN (field
))
4866 /* _Parent is an internal field, but may have values in the aggregate,
4867 so check for values first. */
4868 if ((tem
= purpose_member (field
, values
)) != 0)
4870 value
= TREE_VALUE (tem
);
4871 TREE_ADDRESSABLE (tem
) = 1;
4874 else if (DECL_INTERNAL_P (field
))
4876 value
= extract_values (values
, TREE_TYPE (field
));
4877 if (TREE_CODE (value
) == CONSTRUCTOR
4878 && CONSTRUCTOR_ELTS (value
) == 0)
4882 /* If we have a record subtype, the names will match, but not the
4883 actual FIELD_DECLs. */
4884 for (tem
= values
; tem
; tem
= TREE_CHAIN (tem
))
4885 if (DECL_NAME (TREE_PURPOSE (tem
)) == DECL_NAME (field
))
4887 value
= convert (TREE_TYPE (field
), TREE_VALUE (tem
));
4888 TREE_ADDRESSABLE (tem
) = 1;
4894 result
= tree_cons (field
, value
, result
);
4897 return build_constructor (record_type
, nreverse (result
));
4900 /* EXP is to be treated as an array or record. Handle the cases when it is
4901 an access object and perform the required dereferences. */
4904 maybe_implicit_deref (exp
)
4907 /* If the type is a pointer, dereference it. */
4909 if (POINTER_TYPE_P (TREE_TYPE (exp
)) || TYPE_FAT_POINTER_P (TREE_TYPE (exp
)))
4910 exp
= build_unary_op (INDIRECT_REF
, NULL_TREE
, exp
);
4912 /* If we got a padded type, remove it too. */
4913 if (TREE_CODE (TREE_TYPE (exp
)) == RECORD_TYPE
4914 && TYPE_IS_PADDING_P (TREE_TYPE (exp
)))
4915 exp
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp
))), exp
);
4920 /* Surround EXP with a SAVE_EXPR, but handle unconstrained objects specially
4921 since it doesn't make any sense to put them in a SAVE_EXPR. */
4924 make_save_expr (exp
)
4927 tree type
= TREE_TYPE (exp
);
4929 /* If this is an unchecked conversion, save the input since we may need to
4930 handle this expression separately if it's the operand of a component
4932 if (TREE_CODE (exp
) == UNCHECKED_CONVERT_EXPR
)
4933 return build1 (UNCHECKED_CONVERT_EXPR
, type
,
4934 make_save_expr (TREE_OPERAND (exp
, 0)));
4936 /* If this is an aggregate type, we may be doing a dereference of it in
4937 the LHS side of an assignment. In that case, we need to evaluate
4938 it , take its address, make a SAVE_EXPR of that, then do the indirect
4939 reference. Note that for an unconstrained array, the effect will be
4940 to make a SAVE_EXPR of the fat pointer.
4942 ??? This is an efficiency problem in the case of a type that can be
4943 placed into memory, but until we can deal with the LHS issue,
4944 we have to take that hit. This really should test for BLKmode. */
4945 else if (TREE_CODE (type
) == UNCONSTRAINED_ARRAY_TYPE
4946 || (AGGREGATE_TYPE_P (type
) && ! TYPE_FAT_POINTER_P (type
)))
4948 build_unary_op (INDIRECT_REF
, type
,
4949 save_expr (build_unary_op (ADDR_EXPR
,
4950 build_reference_type (type
),
4953 /* Otherwise, just do the usual thing. */
4954 return save_expr (exp
);
4957 /* This is equivalent to stabilize_reference in GCC's tree.c, but we know
4958 how to handle our new nodes and we take an extra argument that says
4959 whether to force evaluation of everything. */
4962 gnat_stabilize_reference (ref
, force
)
4966 register tree type
= TREE_TYPE (ref
);
4967 register enum tree_code code
= TREE_CODE (ref
);
4968 register tree result
;
4975 /* No action is needed in this case. */
4981 case FIX_TRUNC_EXPR
:
4982 case FIX_FLOOR_EXPR
:
4983 case FIX_ROUND_EXPR
:
4985 case UNCHECKED_CONVERT_EXPR
:
4988 = build1 (code
, type
,
4989 gnat_stabilize_reference (TREE_OPERAND (ref
, 0), force
));
4993 case UNCONSTRAINED_ARRAY_REF
:
4994 result
= build1 (code
, type
,
4995 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 0),
5000 result
= build (COMPONENT_REF
, type
,
5001 gnat_stabilize_reference (TREE_OPERAND (ref
, 0),
5003 TREE_OPERAND (ref
, 1));
5007 result
= build (BIT_FIELD_REF
, type
,
5008 gnat_stabilize_reference (TREE_OPERAND (ref
, 0), force
),
5009 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 1),
5011 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 2),
5016 result
= build (ARRAY_REF
, type
,
5017 gnat_stabilize_reference (TREE_OPERAND (ref
, 0), force
),
5018 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 1),
5022 case ARRAY_RANGE_REF
:
5023 result
= build (ARRAY_RANGE_REF
, type
,
5024 gnat_stabilize_reference (TREE_OPERAND (ref
, 0), force
),
5025 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 1),
5030 result
= build (COMPOUND_EXPR
, type
,
5031 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 0),
5033 gnat_stabilize_reference (TREE_OPERAND (ref
, 1),
5038 result
= build1 (INDIRECT_REF
, type
,
5039 save_expr (build1 (ADDR_EXPR
,
5040 build_reference_type (type
), ref
)));
5043 /* If arg isn't a kind of lvalue we recognize, make no change.
5044 Caller should recognize the error for an invalid lvalue. */
5049 return error_mark_node
;
5052 TREE_READONLY (result
) = TREE_READONLY (ref
);
5056 /* Similar to stabilize_reference_1 in tree.c, but supports an extra
5057 arg to force a SAVE_EXPR for everything. */
5060 gnat_stabilize_reference_1 (e
, force
)
5064 register enum tree_code code
= TREE_CODE (e
);
5065 register tree type
= TREE_TYPE (e
);
5066 register tree result
;
5068 /* We cannot ignore const expressions because it might be a reference
5069 to a const array but whose index contains side-effects. But we can
5070 ignore things that are actual constant or that already have been
5071 handled by this function. */
5073 if (TREE_CONSTANT (e
) || code
== SAVE_EXPR
)
5076 switch (TREE_CODE_CLASS (code
))
5086 if (TREE_SIDE_EFFECTS (e
) || force
)
5087 return save_expr (e
);
5091 /* Constants need no processing. In fact, we should never reach
5096 /* Division is slow and tends to be compiled with jumps,
5097 especially the division by powers of 2 that is often
5098 found inside of an array reference. So do it just once. */
5099 if (code
== TRUNC_DIV_EXPR
|| code
== TRUNC_MOD_EXPR
5100 || code
== FLOOR_DIV_EXPR
|| code
== FLOOR_MOD_EXPR
5101 || code
== CEIL_DIV_EXPR
|| code
== CEIL_MOD_EXPR
5102 || code
== ROUND_DIV_EXPR
|| code
== ROUND_MOD_EXPR
)
5103 return save_expr (e
);
5104 /* Recursively stabilize each operand. */
5105 result
= build (code
, type
,
5106 gnat_stabilize_reference_1 (TREE_OPERAND (e
, 0), force
),
5107 gnat_stabilize_reference_1 (TREE_OPERAND (e
, 1), force
));
5111 /* Recursively stabilize each operand. */
5112 result
= build1 (code
, type
,
5113 gnat_stabilize_reference_1 (TREE_OPERAND (e
, 0),
5121 TREE_READONLY (result
) = TREE_READONLY (e
);
5125 /* GNAT_UNIT is the Defining_Identifier for some package or subprogram,
5126 either a spec or a body, BODY_P says which. If needed, make a function
5127 to be the elaboration routine for that object and perform the elaborations
5130 Return 1 if we didn't need an elaboration function, zero otherwise. */
5133 build_unit_elab (gnat_unit
, body_p
, gnu_elab_list
)
5134 Entity_Id gnat_unit
;
5142 /* If we have nothing to do, return. */
5143 if (gnu_elab_list
== 0)
5146 /* Set our file and line number to that of the object and set up the
5147 elaboration routine. */
5148 gnu_decl
= create_subprog_decl (create_concat_name (gnat_unit
,
5151 NULL_TREE
, void_ftype
, NULL_TREE
, 0, 1, 0,
5153 DECL_ELABORATION_PROC_P (gnu_decl
) = 1;
5155 begin_subprog_body (gnu_decl
);
5156 set_lineno (gnat_unit
, 1);
5158 gnu_block_stack
= tree_cons (NULL_TREE
, NULL_TREE
, gnu_block_stack
);
5159 expand_start_bindings (0);
5161 /* Emit the assignments for the elaborations we have to do. If there
5162 is no destination, this is just a call to execute some statement
5163 that was placed within the declarative region. But first save a
5164 pointer so we can see if any insns were generated. */
5166 insn
= get_last_insn ();
5168 for (; gnu_elab_list
; gnu_elab_list
= TREE_CHAIN (gnu_elab_list
))
5169 if (TREE_PURPOSE (gnu_elab_list
) == NULL_TREE
)
5171 if (TREE_VALUE (gnu_elab_list
) != 0)
5172 expand_expr_stmt (TREE_VALUE (gnu_elab_list
));
5176 tree lhs
= TREE_PURPOSE (gnu_elab_list
);
5178 input_filename
= DECL_SOURCE_FILE (lhs
);
5179 lineno
= DECL_SOURCE_LINE (lhs
);
5181 /* If LHS has a padded type, convert it to the unpadded type
5182 so the assignment is done properly. */
5183 if (TREE_CODE (TREE_TYPE (lhs
)) == RECORD_TYPE
5184 && TYPE_IS_PADDING_P (TREE_TYPE (lhs
)))
5185 lhs
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (lhs
))), lhs
);
5187 emit_line_note (input_filename
, lineno
);
5188 expand_expr_stmt (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
5189 TREE_PURPOSE (gnu_elab_list
),
5190 TREE_VALUE (gnu_elab_list
)));
5193 /* See if any non-NOTE insns were generated. */
5194 for (insn
= NEXT_INSN (insn
); insn
; insn
= NEXT_INSN (insn
))
5195 if (GET_RTX_CLASS (GET_CODE (insn
)) == 'i')
5201 expand_end_bindings (getdecls (), kept_level_p (), 0);
5202 poplevel (kept_level_p (), 1, 0);
5203 gnu_block_stack
= TREE_CHAIN (gnu_block_stack
);
5204 end_subprog_body ();
5206 /* If there were no insns, we don't need an elab routine. It would
5207 be nice to not output this one, but there's no good way to do that. */
5211 extern char *__gnat_to_canonical_file_spec
PARAMS ((char *));
5213 /* Determine the input_filename and the lineno from the source location
5214 (Sloc) of GNAT_NODE node. Set the global variable input_filename and
5215 lineno. If WRITE_NOTE_P is true, emit a line number note. */
5218 set_lineno (gnat_node
, write_note_p
)
5222 Source_Ptr source_location
= Sloc (gnat_node
);
5224 /* If node not from source code, ignore. */
5225 if (source_location
< 0)
5228 /* Use the identifier table to make a hashed, permanent copy of the filename,
5229 since the name table gets reallocated after Gigi returns but before all
5230 the debugging information is output. The call to
5231 __gnat_to_canonical_file_spec translates filenames from pragmas
5232 Source_Reference that contain host style syntax not understood by gdb. */
5234 = IDENTIFIER_POINTER
5236 (__gnat_to_canonical_file_spec
5238 (Debug_Source_Name (Get_Source_File_Index (source_location
))))));
5240 /* ref_filename is the reference file name as given by sinput (i.e no
5243 = IDENTIFIER_POINTER
5246 (Reference_Name (Get_Source_File_Index (source_location
)))));;
5247 lineno
= Get_Logical_Line_Number (source_location
);
5250 emit_line_note (input_filename
, lineno
);
5253 /* Post an error message. MSG is the error message, properly annotated.
5254 NODE is the node at which to post the error and the node to use for the
5255 "&" substitution. */
5258 post_error (msg
, node
)
5262 String_Template temp
;
5265 temp
.Low_Bound
= 1, temp
.High_Bound
= strlen (msg
);
5266 fp
.Array
= msg
, fp
.Bounds
= &temp
;
5268 Error_Msg_N (fp
, node
);
5271 /* Similar, but NODE is the node at which to post the error and ENT
5272 is the node to use for the "&" substitution. */
5275 post_error_ne (msg
, node
, ent
)
5280 String_Template temp
;
5283 temp
.Low_Bound
= 1, temp
.High_Bound
= strlen (msg
);
5284 fp
.Array
= msg
, fp
.Bounds
= &temp
;
5286 Error_Msg_NE (fp
, node
, ent
);
5289 /* Similar, but NODE is the node at which to post the error, ENT is the node
5290 to use for the "&" substitution, and N is the number to use for the ^. */
5293 post_error_ne_num (msg
, node
, ent
, n
)
5299 String_Template temp
;
5302 temp
.Low_Bound
= 1, temp
.High_Bound
= strlen (msg
);
5303 fp
.Array
= msg
, fp
.Bounds
= &temp
;
5304 Error_Msg_Uint_1
= UI_From_Int (n
);
5307 Error_Msg_NE (fp
, node
, ent
);
5310 /* Similar to post_error_ne_num, but T is a GCC tree representing the
5311 number to write. If the tree represents a constant that fits within
5312 a host integer, the text inside curly brackets in MSG will be output
5313 (presumably including a '^'). Otherwise that text will not be output
5314 and the text inside square brackets will be output instead. */
5317 post_error_ne_tree (msg
, node
, ent
, t
)
5323 char *newmsg
= alloca (strlen (msg
) + 1);
5324 String_Template temp
= {1, 0};
5326 char start_yes
, end_yes
, start_no
, end_no
;
5330 fp
.Array
= newmsg
, fp
.Bounds
= &temp
;
5332 if (host_integerp (t
, 1)
5333 #if HOST_BITS_PER_WIDE_INT > HOST_BITS_PER_INT
5334 && compare_tree_int (t
, 1 << (HOST_BITS_PER_INT
- 2)) < 0
5338 Error_Msg_Uint_1
= UI_From_Int (tree_low_cst (t
, 1));
5339 start_yes
= '{', end_yes
= '}', start_no
= '[', end_no
= ']';
5342 start_yes
= '[', end_yes
= ']', start_no
= '{', end_no
= '}';
5344 for (p
= msg
, q
= newmsg
; *p
!= 0; p
++)
5346 if (*p
== start_yes
)
5347 for (p
++; *p
!= end_yes
; p
++)
5349 else if (*p
== start_no
)
5350 for (p
++; *p
!= end_no
; p
++)
5358 temp
.High_Bound
= strlen (newmsg
);
5360 Error_Msg_NE (fp
, node
, ent
);
5363 /* Similar to post_error_ne_tree, except that NUM is a second
5364 integer to write in the message. */
5367 post_error_ne_tree_2 (msg
, node
, ent
, t
, num
)
5374 Error_Msg_Uint_2
= UI_From_Int (num
);
5375 post_error_ne_tree (msg
, node
, ent
, t
);
5378 /* Set the node for a second '&' in the error message. */
5381 set_second_error_entity (e
)
5384 Error_Msg_Node_2
= e
;
5387 /* Signal abort, with "Gigi abort" as the error label, and error_gnat_node
5388 as the relevant node that provides the location info for the error */
5394 String_Template temp
= {1, 10};
5397 fp
.Array
= "Gigi abort", fp
.Bounds
= &temp
;
5399 Current_Error_Node
= error_gnat_node
;
5400 Compiler_Abort (fp
, code
);
5403 /* Initialize the table that maps GNAT codes to GCC codes for simple
5404 binary and unary operations. */
5409 gnu_codes
[N_And_Then
] = TRUTH_ANDIF_EXPR
;
5410 gnu_codes
[N_Or_Else
] = TRUTH_ORIF_EXPR
;
5412 gnu_codes
[N_Op_And
] = TRUTH_AND_EXPR
;
5413 gnu_codes
[N_Op_Or
] = TRUTH_OR_EXPR
;
5414 gnu_codes
[N_Op_Xor
] = TRUTH_XOR_EXPR
;
5415 gnu_codes
[N_Op_Eq
] = EQ_EXPR
;
5416 gnu_codes
[N_Op_Ne
] = NE_EXPR
;
5417 gnu_codes
[N_Op_Lt
] = LT_EXPR
;
5418 gnu_codes
[N_Op_Le
] = LE_EXPR
;
5419 gnu_codes
[N_Op_Gt
] = GT_EXPR
;
5420 gnu_codes
[N_Op_Ge
] = GE_EXPR
;
5421 gnu_codes
[N_Op_Add
] = PLUS_EXPR
;
5422 gnu_codes
[N_Op_Subtract
] = MINUS_EXPR
;
5423 gnu_codes
[N_Op_Multiply
] = MULT_EXPR
;
5424 gnu_codes
[N_Op_Mod
] = FLOOR_MOD_EXPR
;
5425 gnu_codes
[N_Op_Rem
] = TRUNC_MOD_EXPR
;
5426 gnu_codes
[N_Op_Minus
] = NEGATE_EXPR
;
5427 gnu_codes
[N_Op_Abs
] = ABS_EXPR
;
5428 gnu_codes
[N_Op_Not
] = TRUTH_NOT_EXPR
;
5429 gnu_codes
[N_Op_Rotate_Left
] = LROTATE_EXPR
;
5430 gnu_codes
[N_Op_Rotate_Right
] = RROTATE_EXPR
;
5431 gnu_codes
[N_Op_Shift_Left
] = LSHIFT_EXPR
;
5432 gnu_codes
[N_Op_Shift_Right
] = RSHIFT_EXPR
;
5433 gnu_codes
[N_Op_Shift_Right_Arithmetic
] = RSHIFT_EXPR
;