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 tree gnu_standard_long_long_float
;
159 tree gnu_standard_exception_type
;
161 max_gnat_nodes
= max_gnat_node
;
162 number_names
= number_name
;
163 Nodes_Ptr
= nodes_ptr
- First_Node_Id
;
164 Next_Node_Ptr
= next_node_ptr
- First_Node_Id
;
165 Prev_Node_Ptr
= prev_node_ptr
- First_Node_Id
;
166 Elists_Ptr
= elists_ptr
- First_Elist_Id
;
167 Elmts_Ptr
= elmts_ptr
- First_Elmt_Id
;
168 Strings_Ptr
= strings_ptr
- First_String_Id
;
169 String_Chars_Ptr
= string_chars_ptr
;
170 List_Headers_Ptr
= list_headers_ptr
- First_List_Id
;
172 type_annotate_only
= (gigi_operating_mode
== 1);
174 /* See if we should discard file names in exception messages. */
175 discard_file_names
= (Global_Discard_Names
|| Debug_Flag_NN
);
177 if (Nkind (gnat_root
) != N_Compilation_Unit
)
180 set_lineno (gnat_root
, 0);
182 /* Initialize ourselves. */
187 /* Enable GNAT stack checking method if needed */
188 if (!Stack_Check_Probes_On_Target
)
189 set_stack_check_libfunc (gen_rtx (SYMBOL_REF
, Pmode
, "_gnat_stack_check"));
191 /* Save the type we made for integer as the type for Standard.Integer.
192 Then make the rest of the standard types. Note that some of these
194 save_gnu_tree (Base_Type (standard_integer
),
195 TYPE_NAME (integer_type_node
), 0);
197 ggc_add_tree_root (&gnu_block_stack
, 1);
198 ggc_add_tree_root (&gnu_except_ptr_stack
, 1);
199 ggc_add_tree_root (&gnu_return_label_stack
, 1);
200 gnu_except_ptr_stack
= tree_cons (NULL_TREE
, NULL_TREE
, NULL_TREE
);
202 dconstp5
= REAL_VALUE_ATOF ("0.5", DFmode
);
203 dconstmp5
= REAL_VALUE_ATOF ("-0.5", DFmode
);
205 gnu_standard_long_long_float
206 = gnat_to_gnu_entity (Base_Type (standard_long_long_float
), NULL_TREE
, 0);
207 gnu_standard_exception_type
208 = gnat_to_gnu_entity (Base_Type (standard_exception_type
), NULL_TREE
, 0);
210 init_gigi_decls (gnu_standard_long_long_float
, gnu_standard_exception_type
);
212 /* Emit global symbols containing context list info for the SGI Workshop
215 #ifdef MIPS_DEBUGGING_INFO
216 if (Spec_Context_List
!= 0)
217 emit_unit_label (Spec_Context_List
, Spec_Filename
);
219 if (Body_Context_List
!= 0)
220 emit_unit_label (Body_Context_List
, Body_Filename
);
223 #ifdef ASM_OUTPUT_IDENT
224 if (Present (Ident_String (Main_Unit
)))
227 TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit
))));
230 gnat_to_code (gnat_root
);
234 /* This function is the driver of the GNAT to GCC tree transformation process.
235 GNAT_NODE is the root of some gnat tree. It generates code for that
239 gnat_to_code (gnat_node
)
244 /* Save node number in case error */
245 error_gnat_node
= gnat_node
;
247 gnu_root
= tree_transform (gnat_node
);
249 /* This should just generate code, not return a value. If it returns
250 a value, something is wrong. */
251 if (gnu_root
!= error_mark_node
)
255 /* GNAT_NODE is the root of some GNAT tree. Return the root of the GCC
256 tree corresponding to that GNAT tree. Normally, no code is generated.
257 We just return an equivalent tree which is used elsewhere to generate
261 gnat_to_gnu (gnat_node
)
266 /* Save node number in case error */
267 error_gnat_node
= gnat_node
;
269 gnu_root
= tree_transform (gnat_node
);
271 /* If we got no code as a result, something is wrong. */
272 if (gnu_root
== error_mark_node
&& ! type_annotate_only
)
278 /* This function is the driver of the GNAT to GCC tree transformation process.
279 It is the entry point of the tree transformer. GNAT_NODE is the root of
280 some GNAT tree. Return the root of the corresponding GCC tree or
281 error_mark_node to signal that there is no GCC tree to return.
283 The latter is the case if only code generation actions have to be performed
284 like in the case of if statements, loops, etc. This routine is wrapped
285 in the above two routines for most purposes. */
288 tree_transform (gnat_node
)
291 tree gnu_result
= error_mark_node
; /* Default to no value. */
292 tree gnu_result_type
= void_type_node
;
294 tree gnu_lhs
, gnu_rhs
;
296 Entity_Id gnat_temp_type
;
298 /* Set input_file_name and lineno from the Sloc in the GNAT tree. */
299 set_lineno (gnat_node
, 0);
301 /* If this is a Statement and we are at top level, we add the statement
302 as an elaboration for a null tree. That will cause it to be placed
303 in the elaboration procedure. */
304 if (global_bindings_p ()
305 && ((IN (Nkind (gnat_node
), N_Statement_Other_Than_Procedure_Call
)
306 && Nkind (gnat_node
) != N_Null_Statement
)
307 || Nkind (gnat_node
) == N_Procedure_Call_Statement
308 || Nkind (gnat_node
) == N_Label
309 || (Nkind (gnat_node
) == N_Handled_Sequence_Of_Statements
310 && (Present (Exception_Handlers (gnat_node
))
311 || Present (At_End_Proc (gnat_node
))))
312 || ((Nkind (gnat_node
) == N_Raise_Constraint_Error
313 || Nkind (gnat_node
) == N_Raise_Storage_Error
314 || Nkind (gnat_node
) == N_Raise_Program_Error
)
315 && (Ekind (Etype (gnat_node
)) == E_Void
))))
317 add_pending_elaborations (NULL_TREE
, make_transform_expr (gnat_node
));
319 return error_mark_node
;
322 /* If this node is a non-static subexpression and we are only
323 annotating types, make this into a NULL_EXPR for non-VOID types
324 and error_mark_node for void return types. But allow
325 N_Identifier since we use it for lots of things, including
326 getting trees for discriminants. */
328 if (type_annotate_only
329 && IN (Nkind (gnat_node
), N_Subexpr
)
330 && Nkind (gnat_node
) != N_Identifier
331 && ! Compile_Time_Known_Value (gnat_node
))
333 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
335 if (TREE_CODE (gnu_result_type
) == VOID_TYPE
)
336 return error_mark_node
;
338 return build1 (NULL_EXPR
, gnu_result_type
,
339 build_call_raise (raise_constraint_error_decl
));
342 switch (Nkind (gnat_node
))
344 /********************************/
345 /* Chapter 2: Lexical Elements: */
346 /********************************/
349 case N_Expanded_Name
:
350 case N_Operator_Symbol
:
351 case N_Defining_Identifier
:
353 /* If the Etype of this node does not equal the Etype of the
354 Entity, something is wrong with the entity map, probably in
355 generic instantiation. However, this does not apply to
356 types. Since we sometime have strange Ekind's, just do
357 this test for objects. Also, if the Etype of the Entity
358 is private, the Etype of the N_Identifier is allowed to be the
359 full type and also we consider a packed array type to be the
360 same as the original type. Finally, if the types are Itypes,
361 one may be a copy of the other, which is also legal. */
363 gnat_temp
= (Nkind (gnat_node
) == N_Defining_Identifier
364 ? gnat_node
: Entity (gnat_node
));
365 gnat_temp_type
= Etype (gnat_temp
);
367 if (Etype (gnat_node
) != gnat_temp_type
368 && ! (Is_Packed (gnat_temp_type
)
369 && Etype (gnat_node
) == Packed_Array_Type (gnat_temp_type
))
370 && ! (IN (Ekind (gnat_temp_type
), Private_Kind
)
371 && Present (Full_View (gnat_temp_type
))
372 && ((Etype (gnat_node
) == Full_View (gnat_temp_type
))
373 || (Is_Packed (Full_View (gnat_temp_type
))
374 && Etype (gnat_node
) ==
375 Packed_Array_Type (Full_View (gnat_temp_type
)))))
376 && (!Is_Itype (Etype (gnat_node
)) || !Is_Itype (gnat_temp_type
))
377 && (Ekind (gnat_temp
) == E_Variable
378 || Ekind (gnat_temp
) == E_Component
379 || Ekind (gnat_temp
) == E_Constant
380 || Ekind (gnat_temp
) == E_Loop_Parameter
381 || IN (Ekind (gnat_temp
), Formal_Kind
)))
384 /* If this is a reference to a deferred constant whose partial view
385 is an unconstrained private type, the proper type is on the full
386 view of the constant, not on the full view of the type, which may
389 This may be a reference to a type, for example in the prefix of the
390 attribute Position, generated for dispatching code (see Make_DT in
391 exp_disp,adb). In that case we need the type itself, not is parent,
392 in particular if it is a derived type */
394 if (Is_Private_Type (gnat_temp_type
)
395 && Has_Unknown_Discriminants (gnat_temp_type
)
396 && Present (Full_View (gnat_temp
))
397 && ! Is_Type (gnat_temp
))
399 gnat_temp
= Full_View (gnat_temp
);
400 gnat_temp_type
= Etype (gnat_temp
);
401 gnu_result_type
= get_unpadded_type (gnat_temp_type
);
405 /* Expand the type of this identitier first, in case it is
406 an enumeral literal, which only get made when the type
407 is expanded. There is no order-of-elaboration issue here.
408 We want to use the Actual_Subtype if it has already been
409 elaborated, otherwise the Etype. Avoid using Actual_Subtype
410 for packed arrays to simplify things. */
411 if ((Ekind (gnat_temp
) == E_Constant
412 || Ekind (gnat_temp
) == E_Variable
|| Is_Formal (gnat_temp
))
413 && ! (Is_Array_Type (Etype (gnat_temp
))
414 && Present (Packed_Array_Type (Etype (gnat_temp
))))
415 && Present (Actual_Subtype (gnat_temp
))
416 && present_gnu_tree (Actual_Subtype (gnat_temp
)))
417 gnat_temp_type
= Actual_Subtype (gnat_temp
);
419 gnat_temp_type
= Etype (gnat_node
);
421 gnu_result_type
= get_unpadded_type (gnat_temp_type
);
424 gnu_result
= gnat_to_gnu_entity (gnat_temp
, NULL_TREE
, 0);
426 /* If we are in an exception handler, force this variable into memory
427 to ensure optimization does not remove stores that appear
428 redundant but are actually needed in case an exception occurs.
430 ??? Note that we need not do this if the variable is declared within
431 the handler, only if it is referenced in the handler and declared
432 in an enclosing block, but we have no way of testing that
434 if (TREE_VALUE (gnu_except_ptr_stack
) != 0)
436 mark_addressable (gnu_result
);
437 flush_addressof (gnu_result
);
440 /* Some objects (such as parameters passed by reference, globals of
441 variable size, and renamed objects) actually represent the address
442 of the object. In that case, we must do the dereference. Likewise,
443 deal with parameters to foreign convention subprograms. Call fold
444 here since GNU_RESULT may be a CONST_DECL. */
445 if (DECL_P (gnu_result
)
446 && (DECL_BY_REF_P (gnu_result
)
447 || DECL_BY_COMPONENT_PTR_P (gnu_result
)))
449 int ro
= DECL_POINTS_TO_READONLY_P (gnu_result
);
451 if (DECL_BY_COMPONENT_PTR_P (gnu_result
))
452 gnu_result
= convert (build_pointer_type (gnu_result_type
),
455 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
,
457 TREE_READONLY (gnu_result
) = TREE_STATIC (gnu_result
) = ro
;
460 /* The GNAT tree has the type of a function as the type of its result.
461 Also use the type of the result if the Etype is a subtype which
462 is nominally unconstrained. But remove any padding from the
464 if (TREE_CODE (TREE_TYPE (gnu_result
)) == FUNCTION_TYPE
465 || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type
))
467 gnu_result_type
= TREE_TYPE (gnu_result
);
468 if (TREE_CODE (gnu_result_type
) == RECORD_TYPE
469 && TYPE_IS_PADDING_P (gnu_result_type
))
470 gnu_result_type
= TREE_TYPE (TYPE_FIELDS (gnu_result_type
));
473 /* We always want to return the underlying INTEGER_CST for an
474 enumeration literal to avoid the need to call fold in lots
475 of places. But don't do this is the parent will be taking
476 the address of this object. */
477 if (TREE_CODE (gnu_result
) == CONST_DECL
)
479 gnat_temp
= Parent (gnat_node
);
480 if (DECL_CONST_CORRESPONDING_VAR (gnu_result
) == 0
481 || (Nkind (gnat_temp
) != N_Reference
482 && ! (Nkind (gnat_temp
) == N_Attribute_Reference
483 && ((Get_Attribute_Id (Attribute_Name (gnat_temp
))
485 || (Get_Attribute_Id (Attribute_Name (gnat_temp
))
487 || (Get_Attribute_Id (Attribute_Name (gnat_temp
))
488 == Attr_Unchecked_Access
)
489 || (Get_Attribute_Id (Attribute_Name (gnat_temp
))
490 == Attr_Unrestricted_Access
)))))
491 gnu_result
= DECL_INITIAL (gnu_result
);
495 case N_Integer_Literal
:
499 /* Get the type of the result, looking inside any padding and
500 left-justified modular types. Then get the value in that type. */
501 gnu_type
= gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
503 if (TREE_CODE (gnu_type
) == RECORD_TYPE
504 && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_type
))
505 gnu_type
= TREE_TYPE (TYPE_FIELDS (gnu_type
));
507 gnu_result
= UI_To_gnu (Intval (gnat_node
), gnu_type
);
508 /* Get the type of the result, looking inside any padding and
509 left-justified modular types. Then get the value in that type. */
510 gnu_type
= gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
512 if (TREE_CODE (gnu_type
) == RECORD_TYPE
513 && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_type
))
514 gnu_type
= TREE_TYPE (TYPE_FIELDS (gnu_type
));
516 gnu_result
= UI_To_gnu (Intval (gnat_node
), gnu_type
);
518 /* If the result overflows (meaning it doesn't fit in its base type)
519 or is outside of the range of the subtype, we have an illegal tree
520 entry, so abort. Note that the test for of types with biased
521 representation is harder, so we don't test in that case. */
522 if (TREE_CONSTANT_OVERFLOW (gnu_result
)
523 || (TREE_CODE (TYPE_MIN_VALUE (gnu_result_type
)) == INTEGER_CST
524 && ! TYPE_BIASED_REPRESENTATION_P (gnu_result_type
)
525 && tree_int_cst_lt (gnu_result
,
526 TYPE_MIN_VALUE (gnu_result_type
)))
527 || (TREE_CODE (TYPE_MAX_VALUE (gnu_result_type
)) == INTEGER_CST
528 && ! TYPE_BIASED_REPRESENTATION_P (gnu_result_type
)
529 && tree_int_cst_lt (TYPE_MAX_VALUE (gnu_result_type
),
535 case N_Character_Literal
:
536 /* If a Entity is present, it means that this was one of the
537 literals in a user-defined character type. In that case,
538 just return the value in the CONST_DECL. Otherwise, use the
539 character code. In that case, the base type should be an
540 INTEGER_TYPE, but we won't bother checking for that. */
541 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
542 if (Present (Entity (gnat_node
)))
543 gnu_result
= DECL_INITIAL (get_gnu_tree (Entity (gnat_node
)));
545 gnu_result
= convert (gnu_result_type
,
546 build_int_2 (Char_Literal_Value (gnat_node
), 0));
550 /* If this is of a fixed-point type, the value we want is the
551 value of the corresponding integer. */
552 if (IN (Ekind (Underlying_Type (Etype (gnat_node
))), Fixed_Point_Kind
))
554 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
555 gnu_result
= UI_To_gnu (Corresponding_Integer_Value (gnat_node
),
557 if (TREE_CONSTANT_OVERFLOW (gnu_result
)
559 || (TREE_CODE (TYPE_MIN_VALUE (gnu_result_type
)) == INTEGER_CST
560 && tree_int_cst_lt (gnu_result
,
561 TYPE_MIN_VALUE (gnu_result_type
)))
562 || (TREE_CODE (TYPE_MAX_VALUE (gnu_result_type
)) == INTEGER_CST
563 && tree_int_cst_lt (TYPE_MAX_VALUE (gnu_result_type
),
569 /* We should never see a Vax_Float type literal, since the front end
570 is supposed to transform these using appropriate conversions */
571 else if (Vax_Float (Underlying_Type (Etype (gnat_node
))))
576 Ureal ur_realval
= Realval (gnat_node
);
578 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
580 /* If the real value is zero, so is the result. Otherwise,
581 convert it to a machine number if it isn't already. That
582 forces BASE to 0 or 2 and simplifies the rest of our logic. */
583 if (UR_Is_Zero (ur_realval
))
584 gnu_result
= convert (gnu_result_type
, integer_zero_node
);
587 if (! Is_Machine_Number (gnat_node
))
589 Machine (Base_Type (Underlying_Type (Etype (gnat_node
))),
593 = UI_To_gnu (Numerator (ur_realval
), gnu_result_type
);
595 /* If we have a base of zero, divide by the denominator.
596 Otherwise, the base must be 2 and we scale the value, which
597 we know can fit in the mantissa of the type (hence the use
598 of that type above). */
599 if (Rbase (ur_realval
) == 0)
601 = build_binary_op (RDIV_EXPR
,
602 get_base_type (gnu_result_type
),
604 UI_To_gnu (Denominator (ur_realval
),
606 else if (Rbase (ur_realval
) != 2)
611 = build_real (gnu_result_type
,
613 (TREE_REAL_CST (gnu_result
),
614 - UI_To_Int (Denominator (ur_realval
))));
617 /* Now see if we need to negate the result. Do it this way to
618 properly handle -0. */
619 if (UR_Is_Negative (Realval (gnat_node
)))
621 = build_unary_op (NEGATE_EXPR
, get_base_type (gnu_result_type
),
627 case N_String_Literal
:
628 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
629 if (TYPE_PRECISION (TREE_TYPE (gnu_result_type
)) == HOST_BITS_PER_CHAR
)
631 /* We assume here that all strings are of type standard.string.
632 "Weird" types of string have been converted to an aggregate
634 String_Id gnat_string
= Strval (gnat_node
);
635 int length
= String_Length (gnat_string
);
636 char *string
= (char *) alloca (length
+ 1);
639 /* Build the string with the characters in the literal. Note
640 that Ada strings are 1-origin. */
641 for (i
= 0; i
< length
; i
++)
642 string
[i
] = Get_String_Char (gnat_string
, i
+ 1);
644 /* Put a null at the end of the string in case it's in a context
645 where GCC will want to treat it as a C string. */
648 gnu_result
= build_string (length
, string
);
650 /* Strings in GCC don't normally have types, but we want
651 this to not be converted to the array type. */
652 TREE_TYPE (gnu_result
) = gnu_result_type
;
656 /* Build a list consisting of each character, then make
658 String_Id gnat_string
= Strval (gnat_node
);
659 int length
= String_Length (gnat_string
);
661 tree gnu_list
= NULL_TREE
;
663 for (i
= 0; i
< length
; i
++)
665 = tree_cons (NULL_TREE
,
666 convert (TREE_TYPE (gnu_result_type
),
667 build_int_2 (Get_String_Char (gnat_string
,
673 = build_constructor (gnu_result_type
, nreverse (gnu_list
));
678 if (type_annotate_only
)
681 /* Check for (and ignore) unrecognized pragma */
682 if (! Is_Pragma_Name (Chars (gnat_node
)))
685 switch (Get_Pragma_Id (Chars (gnat_node
)))
687 case Pragma_Inspection_Point
:
688 /* Do nothing at top level: all such variables are already
690 if (global_bindings_p ())
693 set_lineno (gnat_node
, 1);
694 for (gnat_temp
= First (Pragma_Argument_Associations (gnat_node
));
696 gnat_temp
= Next (gnat_temp
))
698 gnu_expr
= gnat_to_gnu (Expression (gnat_temp
));
699 if (TREE_CODE (gnu_expr
) == UNCONSTRAINED_ARRAY_REF
)
700 gnu_expr
= TREE_OPERAND (gnu_expr
, 0);
702 gnu_expr
= build1 (USE_EXPR
, void_type_node
, gnu_expr
);
703 TREE_SIDE_EFFECTS (gnu_expr
) = 1;
704 expand_expr_stmt (gnu_expr
);
708 case Pragma_Optimize
:
709 switch (Chars (Expression
710 (First (Pragma_Argument_Associations (gnat_node
)))))
712 case Name_Time
: case Name_Space
:
714 post_error ("insufficient -O value?", gnat_node
);
719 post_error ("must specify -O0?", gnat_node
);
728 case Pragma_Reviewable
:
729 if (write_symbols
== NO_DEBUG
)
730 post_error ("must specify -g?", gnat_node
);
735 /**************************************/
736 /* Chapter 3: Declarations and Types: */
737 /**************************************/
739 case N_Subtype_Declaration
:
740 case N_Full_Type_Declaration
:
741 case N_Incomplete_Type_Declaration
:
742 case N_Private_Type_Declaration
:
743 case N_Private_Extension_Declaration
:
744 case N_Task_Type_Declaration
:
745 process_type (Defining_Entity (gnat_node
));
748 case N_Object_Declaration
:
749 case N_Exception_Declaration
:
750 gnat_temp
= Defining_Entity (gnat_node
);
752 /* If we are just annotating types and this object has an unconstrained
753 or task type, don't elaborate it. */
754 if (type_annotate_only
755 && (((Is_Array_Type (Etype (gnat_temp
))
756 || Is_Record_Type (Etype (gnat_temp
)))
757 && ! Is_Constrained (Etype (gnat_temp
)))
758 || Is_Concurrent_Type (Etype (gnat_temp
))))
761 if (Present (Expression (gnat_node
))
762 && ! (Nkind (gnat_node
) == N_Object_Declaration
763 && No_Initialization (gnat_node
))
764 && (! type_annotate_only
765 || Compile_Time_Known_Value (Expression (gnat_node
))))
767 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
768 if (Do_Range_Check (Expression (gnat_node
)))
769 gnu_expr
= emit_range_check (gnu_expr
, Etype (gnat_temp
));
771 /* If this object has its elaboration delayed, we must force
772 evaluation of GNU_EXPR right now and save it for when the object
774 if (Present (Freeze_Node (gnat_temp
)))
776 if ((Is_Public (gnat_temp
) || global_bindings_p ())
777 && ! TREE_CONSTANT (gnu_expr
))
779 = create_var_decl (create_concat_name (gnat_temp
, "init"),
780 NULL_TREE
, TREE_TYPE (gnu_expr
), gnu_expr
,
781 0, Is_Public (gnat_temp
), 0, 0, 0);
783 gnu_expr
= maybe_variable (gnu_expr
, Expression (gnat_node
));
785 save_gnu_tree (gnat_node
, gnu_expr
, 1);
791 if (type_annotate_only
&& gnu_expr
!= 0
792 && TREE_CODE (gnu_expr
) == ERROR_MARK
)
795 if (No (Freeze_Node (gnat_temp
)))
796 gnat_to_gnu_entity (gnat_temp
, gnu_expr
, 1);
799 case N_Object_Renaming_Declaration
:
801 gnat_temp
= Defining_Entity (gnat_node
);
803 /* Don't do anything if this renaming handled by the front end.
804 or if we are just annotating types and this object has an
805 unconstrained or task type, don't elaborate it. */
806 if (! Is_Renaming_Of_Object (gnat_temp
)
807 && ! (type_annotate_only
808 && (((Is_Array_Type (Etype (gnat_temp
))
809 || Is_Record_Type (Etype (gnat_temp
)))
810 && ! Is_Constrained (Etype (gnat_temp
)))
811 || Is_Concurrent_Type (Etype (gnat_temp
)))))
813 gnu_expr
= gnat_to_gnu (Renamed_Object (gnat_temp
));
814 gnat_to_gnu_entity (gnat_temp
, gnu_expr
, 1);
818 case N_Implicit_Label_Declaration
:
819 gnat_to_gnu_entity (Defining_Entity (gnat_node
), NULL_TREE
, 1);
822 case N_Subprogram_Renaming_Declaration
:
823 case N_Package_Renaming_Declaration
:
824 case N_Exception_Renaming_Declaration
:
825 case N_Number_Declaration
:
826 /* These are fully handled in the front end. */
829 /*************************************/
830 /* Chapter 4: Names and Expressions: */
831 /*************************************/
833 case N_Explicit_Dereference
:
834 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
835 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
837 /* Emit access check if necessary */
838 if (Do_Access_Check (gnat_node
))
839 gnu_result
= emit_access_check (gnu_result
);
841 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_result
);
844 case N_Indexed_Component
:
846 tree gnu_array_object
= gnat_to_gnu (Prefix (gnat_node
));
850 Node_Id
*gnat_expr_array
;
852 /* Emit access check if necessary */
853 if (Do_Access_Check (gnat_node
))
854 gnu_array_object
= emit_access_check (gnu_array_object
);
856 gnu_array_object
= maybe_implicit_deref (gnu_array_object
);
857 gnu_array_object
= maybe_unconstrained_array (gnu_array_object
);
859 /* If we got a padded type, remove it too. */
860 if (TREE_CODE (TREE_TYPE (gnu_array_object
)) == RECORD_TYPE
861 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object
)))
863 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object
))),
866 gnu_result
= gnu_array_object
;
868 /* First compute the number of dimensions of the array, then
869 fill the expression array, the order depending on whether
870 this is a Convention_Fortran array or not. */
871 for (ndim
= 1, gnu_type
= TREE_TYPE (gnu_array_object
);
872 TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
873 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
));
874 ndim
++, gnu_type
= TREE_TYPE (gnu_type
))
877 gnat_expr_array
= (Node_Id
*) alloca (ndim
* sizeof (Node_Id
));
879 if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object
)))
880 for (i
= ndim
- 1, gnat_temp
= First (Expressions (gnat_node
));
882 i
--, gnat_temp
= Next (gnat_temp
))
883 gnat_expr_array
[i
] = gnat_temp
;
885 for (i
= 0, gnat_temp
= First (Expressions (gnat_node
));
887 i
++, gnat_temp
= Next (gnat_temp
))
888 gnat_expr_array
[i
] = gnat_temp
;
890 for (i
= 0, gnu_type
= TREE_TYPE (gnu_array_object
);
891 i
< ndim
; i
++, gnu_type
= TREE_TYPE (gnu_type
))
893 if (TREE_CODE (gnu_type
) != ARRAY_TYPE
)
896 gnat_temp
= gnat_expr_array
[i
];
897 gnu_expr
= gnat_to_gnu (gnat_temp
);
899 if (Do_Range_Check (gnat_temp
))
902 (gnu_array_object
, gnu_expr
,
903 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))),
904 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))));
906 gnu_result
= build_binary_op (ARRAY_REF
, NULL_TREE
,
907 gnu_result
, gnu_expr
);
911 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
917 Node_Id gnat_range_node
= Discrete_Range (gnat_node
);
919 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
920 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
922 /* Emit access check if necessary */
923 if (Do_Access_Check (gnat_node
))
924 gnu_result
= emit_access_check (gnu_result
);
926 /* Do any implicit dereferences of the prefix and do any needed
928 gnu_result
= maybe_implicit_deref (gnu_result
);
929 gnu_result
= maybe_unconstrained_array (gnu_result
);
930 gnu_type
= TREE_TYPE (gnu_result
);
931 if (Do_Range_Check (gnat_range_node
))
933 /* Get the bounds of the slice. */
935 = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_result_type
));
936 tree gnu_min_expr
= TYPE_MIN_VALUE (gnu_index_type
);
937 tree gnu_max_expr
= TYPE_MAX_VALUE (gnu_index_type
);
938 tree gnu_expr_l
, gnu_expr_h
, gnu_expr_type
;
940 /* Check to see that the minimum slice value is in range */
943 (gnu_result
, gnu_min_expr
,
944 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))),
945 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))));
947 /* Check to see that the maximum slice value is in range */
950 (gnu_result
, gnu_max_expr
,
951 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))),
952 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))));
954 /* Derive a good type to convert everything too */
955 gnu_expr_type
= get_base_type (TREE_TYPE (gnu_expr_l
));
957 /* Build a compound expression that does the range checks */
959 = build_binary_op (COMPOUND_EXPR
, gnu_expr_type
,
960 convert (gnu_expr_type
, gnu_expr_h
),
961 convert (gnu_expr_type
, gnu_expr_l
));
963 /* Build a conditional expression that returns the range checks
964 expression if the slice range is not null (max >= min) or
965 returns the min if the slice range is null */
967 = fold (build (COND_EXPR
, gnu_expr_type
,
968 build_binary_op (GE_EXPR
, gnu_expr_type
,
969 convert (gnu_expr_type
,
971 convert (gnu_expr_type
,
973 gnu_expr
, gnu_min_expr
));
976 gnu_expr
= TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type
));
978 gnu_result
= build_binary_op (ARRAY_RANGE_REF
, gnu_result_type
,
979 gnu_result
, gnu_expr
);
983 case N_Selected_Component
:
985 tree gnu_prefix
= gnat_to_gnu (Prefix (gnat_node
));
986 Entity_Id gnat_field
= Entity (Selector_Name (gnat_node
));
987 Entity_Id gnat_pref_type
= Etype (Prefix (gnat_node
));
990 while (IN (Ekind (gnat_pref_type
), Incomplete_Or_Private_Kind
)
991 || IN (Ekind (gnat_pref_type
), Access_Kind
))
993 if (IN (Ekind (gnat_pref_type
), Incomplete_Or_Private_Kind
))
994 gnat_pref_type
= Underlying_Type (gnat_pref_type
);
995 else if (IN (Ekind (gnat_pref_type
), Access_Kind
))
996 gnat_pref_type
= Designated_Type (gnat_pref_type
);
999 if (Do_Access_Check (gnat_node
))
1000 gnu_prefix
= emit_access_check (gnu_prefix
);
1002 gnu_prefix
= maybe_implicit_deref (gnu_prefix
);
1004 /* For discriminant references in tagged types always substitute the
1005 corresponding discriminant as the actual selected component. */
1007 if (Is_Tagged_Type (gnat_pref_type
))
1008 while (Present (Corresponding_Discriminant (gnat_field
)))
1009 gnat_field
= Corresponding_Discriminant (gnat_field
);
1011 /* For discriminant references of untagged types always substitute the
1012 corresponding girder discriminant. */
1014 else if (Present (Corresponding_Discriminant (gnat_field
)))
1015 gnat_field
= Original_Record_Component (gnat_field
);
1017 /* Handle extracting the real or imaginary part of a complex.
1018 The real part is the first field and the imaginary the last. */
1020 if (TREE_CODE (TREE_TYPE (gnu_prefix
)) == COMPLEX_TYPE
)
1021 gnu_result
= build_unary_op (Present (Next_Entity (gnat_field
))
1022 ? REALPART_EXPR
: IMAGPART_EXPR
,
1023 NULL_TREE
, gnu_prefix
);
1026 gnu_field
= gnat_to_gnu_entity (gnat_field
, NULL_TREE
, 0);
1028 /* If there are discriminants, the prefix might be
1029 evaluated more than once, which is a problem if it has
1032 if (Has_Discriminants (Is_Access_Type (Etype (Prefix (gnat_node
)))
1033 ? Designated_Type (Etype
1034 (Prefix (gnat_node
)))
1035 : Etype (Prefix (gnat_node
)))
1036 && TREE_SIDE_EFFECTS (gnu_prefix
))
1037 gnu_prefix
= make_save_expr (gnu_prefix
);
1039 /* Emit discriminant check if necessary. */
1040 if (Do_Discriminant_Check (gnat_node
))
1041 gnu_prefix
= emit_discriminant_check (gnu_prefix
, gnat_node
);
1043 = build_component_ref (gnu_prefix
, NULL_TREE
, gnu_field
);
1046 if (gnu_result
== 0)
1049 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1053 case N_Attribute_Reference
:
1055 /* The attribute designator (like an enumeration value). */
1056 int attribute
= Get_Attribute_Id (Attribute_Name (gnat_node
));
1057 int prefix_unused
= 0;
1061 /* The Elab_Spec and Elab_Body attributes are special in that
1062 Prefix is a unit, not an object with a GCC equivalent. Similarly
1063 for Elaborated, since that variable isn't otherwise known. */
1064 if (attribute
== Attr_Elab_Body
|| attribute
== Attr_Elab_Spec
)
1067 = create_subprog_decl
1068 (create_concat_name (Entity (Prefix (gnat_node
)),
1069 attribute
== Attr_Elab_Body
1070 ? "elabb" : "elabs"),
1071 NULL_TREE
, void_ftype
, NULL_TREE
, 0, 1, 1, 0);
1075 gnu_prefix
= gnat_to_gnu (Prefix (gnat_node
));
1076 gnu_type
= TREE_TYPE (gnu_prefix
);
1078 /* If the input is a NULL_EXPR, make a new one. */
1079 if (TREE_CODE (gnu_prefix
) == NULL_EXPR
)
1081 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1082 gnu_result
= build1 (NULL_EXPR
, gnu_result_type
,
1083 TREE_OPERAND (gnu_prefix
, 0));
1091 /* These are just conversions until since representation
1092 clauses for enumerations are handled in the front end. */
1094 int check_p
= Do_Range_Check (First (Expressions (gnat_node
)));
1096 gnu_result
= gnat_to_gnu (First (Expressions (gnat_node
)));
1097 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1098 gnu_result
= convert_with_check (Etype (gnat_node
), gnu_result
,
1099 check_p
, check_p
, 1);
1105 /* These just add or subject the constant 1. Representation
1106 clauses for enumerations are handled in the front-end. */
1107 gnu_expr
= gnat_to_gnu (First (Expressions (gnat_node
)));
1108 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1110 if (Do_Range_Check (First (Expressions (gnat_node
))))
1112 gnu_expr
= make_save_expr (gnu_expr
);
1115 (build_binary_op (EQ_EXPR
, integer_type_node
,
1117 attribute
== Attr_Pred
1118 ? TYPE_MIN_VALUE (gnu_result_type
)
1119 : TYPE_MAX_VALUE (gnu_result_type
)),
1124 = build_binary_op (attribute
== Attr_Pred
1125 ? MINUS_EXPR
: PLUS_EXPR
,
1126 gnu_result_type
, gnu_expr
,
1127 convert (gnu_result_type
, integer_one_node
));
1131 case Attr_Unrestricted_Access
:
1133 /* Conversions don't change something's address but can cause
1134 us to miss the COMPONENT_REF case below, so strip them off. */
1135 gnu_prefix
= remove_conversions (gnu_prefix
);
1137 /* If we are taking 'Address of an unconstrained object,
1138 this is the pointer to the underlying array. */
1139 gnu_prefix
= maybe_unconstrained_array (gnu_prefix
);
1141 /* ... fall through ... */
1144 case Attr_Unchecked_Access
:
1145 case Attr_Code_Address
:
1147 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1149 = build_unary_op (attribute
== Attr_Address
1150 || attribute
== Attr_Unrestricted_Access
1151 ? ATTR_ADDR_EXPR
: ADDR_EXPR
,
1152 gnu_result_type
, gnu_prefix
);
1154 /* For 'Code_Address, find an inner ADDR_EXPR and mark it
1155 so that we don't try to build a trampoline. */
1156 if (attribute
== Attr_Code_Address
)
1158 for (gnu_expr
= gnu_result
;
1159 TREE_CODE (gnu_expr
) == NOP_EXPR
1160 || TREE_CODE (gnu_expr
) == CONVERT_EXPR
;
1161 gnu_expr
= TREE_OPERAND (gnu_expr
, 0))
1162 TREE_CONSTANT (gnu_expr
) = 1;
1165 if (TREE_CODE (gnu_expr
) == ADDR_EXPR
)
1166 TREE_STATIC (gnu_expr
) = TREE_CONSTANT (gnu_expr
) = 1;
1172 case Attr_Object_Size
:
1173 case Attr_Value_Size
:
1174 case Attr_Max_Size_In_Storage_Elements
:
1176 gnu_expr
= gnu_prefix
;
1178 /* Remove NOPS from gnu_expr and conversions from gnu_prefix.
1179 We only use GNU_EXPR to see if a COMPONENT_REF was involved. */
1180 while (TREE_CODE (gnu_expr
) == NOP_EXPR
)
1181 gnu_expr
= TREE_OPERAND (gnu_expr
, 0);
1183 gnu_prefix
= remove_conversions (gnu_prefix
);
1185 gnu_type
= TREE_TYPE (gnu_prefix
);
1187 /* Replace an unconstrained array type with the type of the
1188 underlying array. We can't do this with a call to
1189 maybe_unconstrained_array since we may have a TYPE_DECL.
1190 For 'Max_Size_In_Storage_Elements, use the record type
1191 that will be used to allocate the object and its template. */
1193 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
1195 gnu_type
= TYPE_OBJECT_RECORD_TYPE (gnu_type
);
1196 if (attribute
!= Attr_Max_Size_In_Storage_Elements
)
1197 gnu_type
= TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type
)));
1200 /* If we are looking for the size of a field, return the
1201 field size. Otherwise, if the prefix is an object,
1202 or if 'Object_Size or 'Max_Size_In_Storage_Elements has
1203 been specified, the result is the GCC size of the type.
1204 Otherwise, the result is the RM_Size of the type. */
1205 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
1206 gnu_result
= DECL_SIZE (TREE_OPERAND (gnu_prefix
, 1));
1207 else if (TREE_CODE (gnu_prefix
) != TYPE_DECL
1208 || attribute
== Attr_Object_Size
1209 || attribute
== Attr_Max_Size_In_Storage_Elements
)
1211 /* If this is a padded type, the GCC size isn't relevant
1212 to the programmer. Normally, what we want is the RM_Size,
1213 which was set from the specified size, but if it was not
1214 set, we want the size of the relevant field. Using the MAX
1215 of those two produces the right result in all case. Don't
1216 use the size of the field if it's a self-referential type,
1217 since that's never what's wanted. */
1218 if (TREE_CODE (gnu_type
) == RECORD_TYPE
1219 && TYPE_IS_PADDING_P (gnu_type
)
1220 && TREE_CODE (gnu_expr
) == COMPONENT_REF
)
1222 gnu_result
= rm_size (gnu_type
);
1223 if (! (contains_placeholder_p
1224 (DECL_SIZE (TREE_OPERAND (gnu_expr
, 1)))))
1226 = size_binop (MAX_EXPR
, gnu_result
,
1227 DECL_SIZE (TREE_OPERAND (gnu_expr
, 1)));
1230 gnu_result
= TYPE_SIZE (gnu_type
);
1233 gnu_result
= rm_size (gnu_type
);
1235 if (gnu_result
== 0)
1238 /* Deal with a self-referential size by returning the maximum
1239 size for a type and by qualifying the size with
1240 the object for 'Size of an object. */
1242 if (TREE_CODE (gnu_result
) != INTEGER_CST
1243 && contains_placeholder_p (gnu_result
))
1245 if (TREE_CODE (gnu_prefix
) != TYPE_DECL
)
1246 gnu_result
= build (WITH_RECORD_EXPR
, TREE_TYPE (gnu_result
),
1247 gnu_result
, gnu_prefix
);
1249 gnu_result
= max_size (gnu_result
, 1);
1252 /* If the type contains a template, subtract the size of the
1254 if (TREE_CODE (gnu_type
) == RECORD_TYPE
1255 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
1256 gnu_result
= size_binop (MINUS_EXPR
, gnu_result
,
1257 DECL_SIZE (TYPE_FIELDS (gnu_type
)));
1259 /* If the type contains a template, subtract the size of the
1261 if (TREE_CODE (gnu_type
) == RECORD_TYPE
1262 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
1263 gnu_result
= size_binop (MINUS_EXPR
, gnu_result
,
1264 DECL_SIZE (TYPE_FIELDS (gnu_type
)));
1266 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1268 /* Always perform division using unsigned arithmetic as the
1269 size cannot be negative, but may be an overflowed positive
1270 value. This provides correct results for sizes up to 512 MB.
1271 ??? Size should be calculated in storage elements directly. */
1273 if (attribute
== Attr_Max_Size_In_Storage_Elements
)
1274 gnu_result
= convert (sizetype
,
1275 fold (build (CEIL_DIV_EXPR
, bitsizetype
,
1277 bitsize_unit_node
)));
1280 case Attr_Alignment
:
1281 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
1282 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))
1284 && (TYPE_IS_PADDING_P
1285 (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))))
1286 gnu_prefix
= TREE_OPERAND (gnu_prefix
, 0);
1288 gnu_type
= TREE_TYPE (gnu_prefix
);
1289 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1292 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
1294 = size_int (DECL_ALIGN (TREE_OPERAND (gnu_prefix
, 1)));
1296 gnu_result
= size_int (TYPE_ALIGN (gnu_type
) / BITS_PER_UNIT
);
1301 case Attr_Range_Length
:
1304 if (INTEGRAL_TYPE_P (gnu_type
)
1305 || TREE_CODE (gnu_type
) == REAL_TYPE
)
1307 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1309 if (attribute
== Attr_First
)
1310 gnu_result
= TYPE_MIN_VALUE (gnu_type
);
1311 else if (attribute
== Attr_Last
)
1312 gnu_result
= TYPE_MAX_VALUE (gnu_type
);
1316 (MAX_EXPR
, get_base_type (gnu_result_type
),
1318 (PLUS_EXPR
, get_base_type (gnu_result_type
),
1319 build_binary_op (MINUS_EXPR
,
1320 get_base_type (gnu_result_type
),
1321 convert (gnu_result_type
,
1322 TYPE_MAX_VALUE (gnu_type
)),
1323 convert (gnu_result_type
,
1324 TYPE_MIN_VALUE (gnu_type
))),
1325 convert (gnu_result_type
, integer_one_node
)),
1326 convert (gnu_result_type
, integer_zero_node
));
1330 /* ... fall through ... */
1334 = (Present (Expressions (gnat_node
))
1335 ? UI_To_Int (Intval (First (Expressions (gnat_node
))))
1338 /* Emit access check if necessary */
1339 if (Do_Access_Check (gnat_node
))
1340 gnu_prefix
= emit_access_check (gnu_prefix
);
1342 /* Make sure any implicit dereference gets done. */
1343 gnu_prefix
= maybe_implicit_deref (gnu_prefix
);
1344 gnu_prefix
= maybe_unconstrained_array (gnu_prefix
);
1345 gnu_type
= TREE_TYPE (gnu_prefix
);
1347 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1349 if (TYPE_CONVENTION_FORTRAN_P (gnu_type
))
1354 for (ndim
= 1, gnu_type_temp
= gnu_type
;
1355 TREE_CODE (TREE_TYPE (gnu_type_temp
)) == ARRAY_TYPE
1356 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp
));
1357 ndim
++, gnu_type_temp
= TREE_TYPE (gnu_type_temp
))
1360 Dimension
= ndim
+ 1 - Dimension
;
1363 for (; Dimension
> 1; Dimension
--)
1364 gnu_type
= TREE_TYPE (gnu_type
);
1366 if (TREE_CODE (gnu_type
) != ARRAY_TYPE
)
1369 if (attribute
== Attr_First
)
1371 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)));
1372 else if (attribute
== Attr_Last
)
1374 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)));
1376 /* 'Length or 'Range_Length. */
1378 tree gnu_compute_type
1379 = signed_or_unsigned_type
1380 (0, get_base_type (gnu_result_type
));
1384 (MAX_EXPR
, gnu_compute_type
,
1386 (PLUS_EXPR
, gnu_compute_type
,
1388 (MINUS_EXPR
, gnu_compute_type
,
1389 convert (gnu_compute_type
,
1391 (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)))),
1392 convert (gnu_compute_type
,
1394 (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))))),
1395 convert (gnu_compute_type
, integer_one_node
)),
1396 convert (gnu_compute_type
, integer_zero_node
));
1399 /* If this has a PLACEHOLDER_EXPR, qualify it by the object
1400 we are handling. Note that these attributes could not
1401 have been used on an unconstrained array type. */
1402 if (TREE_CODE (gnu_result
) != INTEGER_CST
1403 && contains_placeholder_p (gnu_result
))
1404 gnu_result
= build (WITH_RECORD_EXPR
, TREE_TYPE (gnu_result
),
1405 gnu_result
, gnu_prefix
);
1410 case Attr_Bit_Position
:
1412 case Attr_First_Bit
:
1416 HOST_WIDE_INT bitsize
;
1417 HOST_WIDE_INT bitpos
;
1419 tree gnu_field_bitpos
;
1420 tree gnu_field_offset
;
1422 enum machine_mode mode
;
1423 int unsignedp
, volatilep
;
1425 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1426 gnu_prefix
= remove_conversions (gnu_prefix
);
1429 /* We can have 'Bit on any object, but if it isn't a
1430 COMPONENT_REF, the result is zero. Do not allow
1431 'Bit on a bare component, though. */
1432 if (attribute
== Attr_Bit
1433 && TREE_CODE (gnu_prefix
) != COMPONENT_REF
1434 && TREE_CODE (gnu_prefix
) != FIELD_DECL
)
1436 gnu_result
= integer_zero_node
;
1440 else if (TREE_CODE (gnu_prefix
) != COMPONENT_REF
1441 && ! (attribute
== Attr_Bit_Position
1442 && TREE_CODE (gnu_prefix
) == FIELD_DECL
))
1445 get_inner_reference (gnu_prefix
, &bitsize
, &bitpos
, &gnu_offset
,
1446 &mode
, &unsignedp
, &volatilep
);
1449 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
1452 = bit_position (TREE_OPERAND (gnu_prefix
, 1));
1454 = byte_position (TREE_OPERAND (gnu_prefix
, 1));
1456 for (gnu_inner
= TREE_OPERAND (gnu_prefix
, 0);
1457 TREE_CODE (gnu_inner
) == COMPONENT_REF
1458 && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner
, 1));
1459 gnu_inner
= TREE_OPERAND (gnu_inner
, 0))
1462 = size_binop (PLUS_EXPR
, gnu_field_bitpos
,
1463 bit_position (TREE_OPERAND (gnu_inner
,
1466 = size_binop (PLUS_EXPR
, gnu_field_offset
,
1467 byte_position (TREE_OPERAND (gnu_inner
,
1471 else if (TREE_CODE (gnu_prefix
) == FIELD_DECL
)
1473 gnu_field_bitpos
= bit_position (gnu_prefix
);
1474 gnu_field_offset
= byte_position (gnu_prefix
);
1478 gnu_field_bitpos
= bitsize_zero_node
;
1479 gnu_field_offset
= size_zero_node
;
1485 gnu_result
= gnu_field_offset
;
1489 case Attr_First_Bit
:
1491 gnu_result
= size_int (bitpos
% BITS_PER_UNIT
);
1496 gnu_result
= bitsize_int (bitpos
% BITS_PER_UNIT
);
1498 = size_binop (PLUS_EXPR
, gnu_result
,
1499 TYPE_SIZE (TREE_TYPE (gnu_prefix
)));
1500 gnu_result
= size_binop (MINUS_EXPR
, gnu_result
,
1504 case Attr_Bit_Position
:
1505 gnu_result
= gnu_field_bitpos
;
1509 /* If this has a PLACEHOLDER_EXPR, qualify it by the object
1511 if (TREE_CODE (gnu_result
) != INTEGER_CST
1512 && contains_placeholder_p (gnu_result
))
1513 gnu_result
= build (WITH_RECORD_EXPR
, TREE_TYPE (gnu_result
),
1514 gnu_result
, gnu_prefix
);
1521 gnu_lhs
= gnat_to_gnu (First (Expressions (gnat_node
)));
1522 gnu_rhs
= gnat_to_gnu (Next (First (Expressions (gnat_node
))));
1524 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1525 gnu_result
= build_binary_op (attribute
== Attr_Min
1526 ? MIN_EXPR
: MAX_EXPR
,
1527 gnu_result_type
, gnu_lhs
, gnu_rhs
);
1530 case Attr_Passed_By_Reference
:
1531 gnu_result
= size_int (default_pass_by_ref (gnu_type
)
1532 || must_pass_by_ref (gnu_type
));
1533 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1536 case Attr_Component_Size
:
1537 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
1538 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))
1540 && (TYPE_IS_PADDING_P
1541 (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))))
1542 gnu_prefix
= TREE_OPERAND (gnu_prefix
, 0);
1544 gnu_prefix
= maybe_implicit_deref (gnu_prefix
);
1545 gnu_type
= TREE_TYPE (gnu_prefix
);
1547 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
1549 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type
))));
1551 while (TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
1552 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
)))
1553 gnu_type
= TREE_TYPE (gnu_type
);
1555 if (TREE_CODE (gnu_type
) != ARRAY_TYPE
)
1558 /* Note this size cannot be self-referential. */
1559 gnu_result
= TYPE_SIZE (TREE_TYPE (gnu_type
));
1560 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1564 case Attr_Null_Parameter
:
1565 /* This is just a zero cast to the pointer type for
1566 our prefix and dereferenced. */
1567 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1569 = build_unary_op (INDIRECT_REF
, NULL_TREE
,
1570 convert (build_pointer_type (gnu_result_type
),
1571 integer_zero_node
));
1572 TREE_PRIVATE (gnu_result
) = 1;
1575 case Attr_Mechanism_Code
:
1578 Entity_Id gnat_obj
= Entity (Prefix (gnat_node
));
1581 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1582 if (Present (Expressions (gnat_node
)))
1584 int i
= UI_To_Int (Intval (First (Expressions (gnat_node
))));
1586 for (gnat_obj
= First_Formal (gnat_obj
); i
> 1;
1587 i
--, gnat_obj
= Next_Formal (gnat_obj
))
1591 code
= Mechanism (gnat_obj
);
1592 if (code
== Default
)
1593 code
= ((present_gnu_tree (gnat_obj
)
1594 && (DECL_BY_REF_P (get_gnu_tree (gnat_obj
))
1595 || (DECL_BY_COMPONENT_PTR_P
1596 (get_gnu_tree (gnat_obj
)))))
1597 ? By_Reference
: By_Copy
);
1598 gnu_result
= convert (gnu_result_type
, size_int (- code
));
1603 /* Say we have an unimplemented attribute. Then set the
1604 value to be returned to be a zero and hope that's something
1605 we can convert to the type of this attribute. */
1607 post_error ("unimplemented attribute", gnat_node
);
1608 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1609 gnu_result
= integer_zero_node
;
1613 /* If this is an attribute where the prefix was unused,
1614 force a use of it if it has a side-effect. */
1615 if (prefix_unused
&& TREE_SIDE_EFFECTS (gnu_prefix
))
1616 gnu_result
= fold (build (COMPOUND_EXPR
, TREE_TYPE (gnu_result
),
1617 gnu_prefix
, gnu_result
));
1622 /* Like 'Access as far as we are concerned. */
1623 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
1624 gnu_result
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_result
);
1625 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1629 case N_Extension_Aggregate
:
1633 /* ??? It is wrong to evaluate the type now, but there doesn't
1634 seem to be any other practical way of doing it. */
1636 gnu_aggr_type
= gnu_result_type
1637 = get_unpadded_type (Etype (gnat_node
));
1639 if (TREE_CODE (gnu_result_type
) == RECORD_TYPE
1640 && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type
))
1642 = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_result_type
)));
1644 if (Null_Record_Present (gnat_node
))
1645 gnu_result
= build_constructor (gnu_aggr_type
, NULL_TREE
);
1647 else if (TREE_CODE (gnu_aggr_type
) == RECORD_TYPE
)
1649 = assoc_to_constructor (First (Component_Associations (gnat_node
)),
1651 else if (TREE_CODE (gnu_aggr_type
) == UNION_TYPE
)
1653 /* The first element is the discrimant, which we ignore. The
1654 next is the field we're building. Convert the expression
1655 to the type of the field and then to the union type. */
1657 = Next (First (Component_Associations (gnat_node
)));
1658 Entity_Id gnat_field
= Entity (First (Choices (gnat_assoc
)));
1660 = TREE_TYPE (gnat_to_gnu_entity (gnat_field
, NULL_TREE
, 0));
1662 gnu_result
= convert (gnu_field_type
,
1663 gnat_to_gnu (Expression (gnat_assoc
)));
1665 else if (TREE_CODE (gnu_aggr_type
) == ARRAY_TYPE
)
1666 gnu_result
= pos_to_constructor (First (Expressions (gnat_node
)),
1668 Component_Type (Etype (gnat_node
)));
1669 else if (TREE_CODE (gnu_aggr_type
) == COMPLEX_TYPE
)
1672 (COMPLEX_EXPR
, gnu_aggr_type
,
1673 gnat_to_gnu (Expression (First
1674 (Component_Associations (gnat_node
)))),
1675 gnat_to_gnu (Expression
1677 (First (Component_Associations (gnat_node
))))));
1681 gnu_result
= convert (gnu_result_type
, gnu_result
);
1686 gnu_result
= null_pointer_node
;
1687 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1690 case N_Type_Conversion
:
1691 case N_Qualified_Expression
:
1692 /* Get the operand expression. */
1693 gnu_result
= gnat_to_gnu (Expression (gnat_node
));
1694 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1697 = convert_with_check (Etype (gnat_node
), gnu_result
,
1698 Do_Overflow_Check (gnat_node
),
1699 Do_Range_Check (Expression (gnat_node
)),
1700 Nkind (gnat_node
) == N_Type_Conversion
1701 && Float_Truncate (gnat_node
));
1704 case N_Unchecked_Type_Conversion
:
1705 gnu_result
= gnat_to_gnu (Expression (gnat_node
));
1706 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1708 /* If the result is a pointer type, see if we are improperly
1709 converting to a stricter alignment. */
1711 if (STRICT_ALIGNMENT
&& POINTER_TYPE_P (gnu_result_type
)
1712 && IN (Ekind (Etype (gnat_node
)), Access_Kind
))
1714 unsigned int align
= known_alignment (gnu_result
);
1715 tree gnu_obj_type
= TREE_TYPE (gnu_result_type
);
1717 = TREE_CODE (gnu_obj_type
) == FUNCTION_TYPE
1718 ? FUNCTION_BOUNDARY
: TYPE_ALIGN (gnu_obj_type
);
1720 if (align
!= 0 && align
< oalign
&& ! TYPE_ALIGN_OK_P (gnu_obj_type
))
1721 post_error_ne_tree_2
1722 ("?source alignment (^) < alignment of & (^)",
1723 gnat_node
, Designated_Type (Etype (gnat_node
)),
1724 size_int (align
/ BITS_PER_UNIT
), oalign
/ BITS_PER_UNIT
);
1727 gnu_result
= unchecked_convert (gnu_result_type
, gnu_result
);
1733 tree gnu_object
= gnat_to_gnu (Left_Opnd (gnat_node
));
1734 Node_Id gnat_range
= Right_Opnd (gnat_node
);
1738 /* GNAT_RANGE is either an N_Range node or an identifier
1739 denoting a subtype. */
1740 if (Nkind (gnat_range
) == N_Range
)
1742 gnu_low
= gnat_to_gnu (Low_Bound (gnat_range
));
1743 gnu_high
= gnat_to_gnu (High_Bound (gnat_range
));
1745 else if (Nkind (gnat_range
) == N_Identifier
1746 || Nkind (gnat_range
) == N_Expanded_Name
)
1748 tree gnu_range_type
= get_unpadded_type (Entity (gnat_range
));
1750 gnu_low
= TYPE_MIN_VALUE (gnu_range_type
);
1751 gnu_high
= TYPE_MAX_VALUE (gnu_range_type
);
1756 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1758 /* If LOW and HIGH are identical, perform an equality test.
1759 Otherwise, ensure that GNU_OBJECT is only evaluated once
1760 and perform a full range test. */
1761 if (operand_equal_p (gnu_low
, gnu_high
, 0))
1762 gnu_result
= build_binary_op (EQ_EXPR
, gnu_result_type
,
1763 gnu_object
, gnu_low
);
1766 gnu_object
= make_save_expr (gnu_object
);
1768 = build_binary_op (TRUTH_ANDIF_EXPR
, gnu_result_type
,
1769 build_binary_op (GE_EXPR
, gnu_result_type
,
1770 gnu_object
, gnu_low
),
1771 build_binary_op (LE_EXPR
, gnu_result_type
,
1772 gnu_object
, gnu_high
));
1775 if (Nkind (gnat_node
) == N_Not_In
)
1776 gnu_result
= invert_truthvalue (gnu_result
);
1781 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
1782 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
1783 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1784 gnu_result
= build_binary_op (FLOAT_TYPE_P (gnu_result_type
)
1786 : (Rounded_Result (gnat_node
)
1787 ? ROUND_DIV_EXPR
: TRUNC_DIV_EXPR
),
1788 gnu_result_type
, gnu_lhs
, gnu_rhs
);
1791 case N_And_Then
: case N_Or_Else
:
1793 enum tree_code code
= gnu_codes
[Nkind (gnat_node
)];
1796 /* The elaboration of the RHS may generate code. If so,
1797 we need to make sure it gets executed after the LHS. */
1798 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
1800 gnu_rhs_side
= expand_start_stmt_expr ();
1801 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
1802 expand_end_stmt_expr (gnu_rhs_side
);
1803 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1805 if (RTL_EXPR_SEQUENCE (gnu_rhs_side
) != 0)
1806 gnu_rhs
= build (COMPOUND_EXPR
, gnu_result_type
, gnu_rhs_side
,
1809 gnu_result
= build_binary_op (code
, gnu_result_type
, gnu_lhs
, gnu_rhs
);
1813 case N_Op_Or
: case N_Op_And
: case N_Op_Xor
:
1814 /* These can either be operations on booleans or on modular types.
1815 Fall through for boolean types since that's the way GNU_CODES is
1817 if (IN (Ekind (Underlying_Type (Etype (gnat_node
))),
1818 Modular_Integer_Kind
))
1821 = (Nkind (gnat_node
) == N_Op_Or
? BIT_IOR_EXPR
1822 : Nkind (gnat_node
) == N_Op_And
? BIT_AND_EXPR
1825 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
1826 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
1827 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1828 gnu_result
= build_binary_op (code
, gnu_result_type
,
1833 /* ... fall through ... */
1835 case N_Op_Eq
: case N_Op_Ne
: case N_Op_Lt
:
1836 case N_Op_Le
: case N_Op_Gt
: case N_Op_Ge
:
1837 case N_Op_Add
: case N_Op_Subtract
: case N_Op_Multiply
:
1838 case N_Op_Mod
: case N_Op_Rem
:
1839 case N_Op_Rotate_Left
:
1840 case N_Op_Rotate_Right
:
1841 case N_Op_Shift_Left
:
1842 case N_Op_Shift_Right
:
1843 case N_Op_Shift_Right_Arithmetic
:
1845 enum tree_code code
= gnu_codes
[Nkind (gnat_node
)];
1848 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
1849 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
1850 gnu_type
= gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1852 /* If this is a comparison operator, convert any references to
1853 an unconstrained array value into a reference to the
1855 if (TREE_CODE_CLASS (code
) == '<')
1857 gnu_lhs
= maybe_unconstrained_array (gnu_lhs
);
1858 gnu_rhs
= maybe_unconstrained_array (gnu_rhs
);
1861 /* If this is a shift whose count is not guaranteed to be correct,
1862 we need to adjust the shift count. */
1863 if (IN (Nkind (gnat_node
), N_Op_Shift
)
1864 && ! Shift_Count_OK (gnat_node
))
1866 tree gnu_count_type
= get_base_type (TREE_TYPE (gnu_rhs
));
1868 = convert (gnu_count_type
, TYPE_SIZE (gnu_type
));
1870 if (Nkind (gnat_node
) == N_Op_Rotate_Left
1871 || Nkind (gnat_node
) == N_Op_Rotate_Right
)
1872 gnu_rhs
= build_binary_op (TRUNC_MOD_EXPR
, gnu_count_type
,
1873 gnu_rhs
, gnu_max_shift
);
1874 else if (Nkind (gnat_node
) == N_Op_Shift_Right_Arithmetic
)
1877 (MIN_EXPR
, gnu_count_type
,
1878 build_binary_op (MINUS_EXPR
,
1881 convert (gnu_count_type
,
1886 /* For right shifts, the type says what kind of shift to do,
1887 so we may need to choose a different type. */
1888 if (Nkind (gnat_node
) == N_Op_Shift_Right
1889 && ! TREE_UNSIGNED (gnu_type
))
1890 gnu_type
= unsigned_type (gnu_type
);
1891 else if (Nkind (gnat_node
) == N_Op_Shift_Right_Arithmetic
1892 && TREE_UNSIGNED (gnu_type
))
1893 gnu_type
= signed_type (gnu_type
);
1895 if (gnu_type
!= gnu_result_type
)
1897 gnu_lhs
= convert (gnu_type
, gnu_lhs
);
1898 gnu_rhs
= convert (gnu_type
, gnu_rhs
);
1901 gnu_result
= build_binary_op (code
, gnu_type
, gnu_lhs
, gnu_rhs
);
1903 /* If this is a logical shift with the shift count not verified,
1904 we must return zero if it is too large. We cannot compensate
1905 above in this case. */
1906 if ((Nkind (gnat_node
) == N_Op_Shift_Left
1907 || Nkind (gnat_node
) == N_Op_Shift_Right
)
1908 && ! Shift_Count_OK (gnat_node
))
1912 build_binary_op (GE_EXPR
, integer_type_node
,
1914 convert (TREE_TYPE (gnu_rhs
),
1915 TYPE_SIZE (gnu_type
))),
1916 convert (gnu_type
, integer_zero_node
),
1921 case N_Conditional_Expression
:
1923 tree gnu_cond
= gnat_to_gnu (First (Expressions (gnat_node
)));
1924 tree gnu_true
= gnat_to_gnu (Next (First (Expressions (gnat_node
))));
1926 = gnat_to_gnu (Next (Next (First (Expressions (gnat_node
)))));
1928 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1929 gnu_result
= build_cond_expr (gnu_result_type
,
1930 truthvalue_conversion (gnu_cond
),
1931 gnu_true
, gnu_false
);
1936 gnu_result
= gnat_to_gnu (Right_Opnd (gnat_node
));
1937 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1941 /* This case can apply to a boolean or a modular type.
1942 Fall through for a boolean operand since GNU_CODES is set
1943 up to handle this. */
1944 if (IN (Ekind (Etype (gnat_node
)), Modular_Integer_Kind
))
1946 gnu_expr
= gnat_to_gnu (Right_Opnd (gnat_node
));
1947 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1948 gnu_result
= build_unary_op (BIT_NOT_EXPR
, gnu_result_type
,
1953 /* ... fall through ... */
1955 case N_Op_Minus
: case N_Op_Abs
:
1956 gnu_expr
= gnat_to_gnu (Right_Opnd (gnat_node
));
1958 if (Ekind (Etype (gnat_node
)) != E_Private_Type
)
1959 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1961 gnu_result_type
= get_unpadded_type (Base_Type
1962 (Full_View (Etype (gnat_node
))));
1964 gnu_result
= build_unary_op (gnu_codes
[Nkind (gnat_node
)],
1965 gnu_result_type
, gnu_expr
);
1973 gnat_temp
= Expression (gnat_node
);
1975 /* The Expression operand can either be an N_Identifier or
1976 Expanded_Name, which must represent a type, or a
1977 N_Qualified_Expression, which contains both the object type and an
1978 initial value for the object. */
1979 if (Nkind (gnat_temp
) == N_Identifier
1980 || Nkind (gnat_temp
) == N_Expanded_Name
)
1981 gnu_type
= gnat_to_gnu_type (Entity (gnat_temp
));
1982 else if (Nkind (gnat_temp
) == N_Qualified_Expression
)
1984 Entity_Id gnat_desig_type
1985 = Designated_Type (Underlying_Type (Etype (gnat_node
)));
1987 gnu_init
= gnat_to_gnu (Expression (gnat_temp
));
1989 gnu_init
= maybe_unconstrained_array (gnu_init
);
1990 if (Do_Range_Check (Expression (gnat_temp
)))
1991 gnu_init
= emit_range_check (gnu_init
, gnat_desig_type
);
1993 if (Is_Elementary_Type (gnat_desig_type
)
1994 || Is_Constrained (gnat_desig_type
))
1996 gnu_type
= gnat_to_gnu_type (gnat_desig_type
);
1997 gnu_init
= convert (gnu_type
, gnu_init
);
2001 gnu_type
= gnat_to_gnu_type (Etype (Expression (gnat_temp
)));
2002 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
2003 gnu_type
= TREE_TYPE (gnu_init
);
2005 gnu_init
= convert (gnu_type
, gnu_init
);
2011 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2012 return build_allocator (gnu_type
, gnu_init
, gnu_result_type
,
2013 Procedure_To_Call (gnat_node
),
2014 Storage_Pool (gnat_node
));
2018 /***************************/
2019 /* Chapter 5: Statements: */
2020 /***************************/
2023 if (! type_annotate_only
)
2025 tree gnu_label
= gnat_to_gnu (Identifier (gnat_node
));
2026 Node_Id gnat_parent
= Parent (gnat_node
);
2028 expand_label (gnu_label
);
2030 /* If this is the first label of an exception handler, we must
2031 mark that any CALL_INSN can jump to it. */
2032 if (Present (gnat_parent
)
2033 && Nkind (gnat_parent
) == N_Exception_Handler
2034 && First (Statements (gnat_parent
)) == gnat_node
)
2035 nonlocal_goto_handler_labels
2036 = gen_rtx_EXPR_LIST (VOIDmode
, label_rtx (gnu_label
),
2037 nonlocal_goto_handler_labels
);
2041 case N_Null_Statement
:
2044 case N_Assignment_Statement
:
2045 if (type_annotate_only
)
2048 /* Get the LHS and RHS of the statement and convert any reference to an
2049 unconstrained array into a reference to the underlying array. */
2050 gnu_lhs
= maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node
)));
2052 = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node
)));
2054 /* If range check is needed, emit code to generate it */
2055 if (Do_Range_Check (Expression (gnat_node
)))
2056 gnu_rhs
= emit_range_check (gnu_rhs
, Etype (Name (gnat_node
)));
2058 set_lineno (gnat_node
, 1);
2060 /* If either side's type has a size that overflows, convert this
2061 into raise of Storage_Error: execution shouldn't have gotten
2063 if ((TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_lhs
))) == INTEGER_CST
2064 && TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_lhs
))))
2065 || (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_rhs
))) == INTEGER_CST
2066 && TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_rhs
)))))
2067 expand_expr_stmt (build_call_raise (raise_storage_error_decl
));
2069 expand_expr_stmt (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
2073 case N_If_Statement
:
2074 /* Start an IF statement giving the condition. */
2075 gnu_expr
= gnat_to_gnu (Condition (gnat_node
));
2076 set_lineno (gnat_node
, 1);
2077 expand_start_cond (gnu_expr
, 0);
2079 /* Generate code for the statements to be executed if the condition
2082 for (gnat_temp
= First (Then_Statements (gnat_node
));
2083 Present (gnat_temp
);
2084 gnat_temp
= Next (gnat_temp
))
2085 gnat_to_code (gnat_temp
);
2087 /* Generate each of the "else if" parts. */
2088 if (Present (Elsif_Parts (gnat_node
)))
2090 for (gnat_temp
= First (Elsif_Parts (gnat_node
));
2091 Present (gnat_temp
);
2092 gnat_temp
= Next (gnat_temp
))
2094 Node_Id gnat_statement
;
2096 expand_start_else ();
2098 /* Set up the line numbers for each condition we test. */
2099 set_lineno (Condition (gnat_temp
), 1);
2100 expand_elseif (gnat_to_gnu (Condition (gnat_temp
)));
2102 for (gnat_statement
= First (Then_Statements (gnat_temp
));
2103 Present (gnat_statement
);
2104 gnat_statement
= Next (gnat_statement
))
2105 gnat_to_code (gnat_statement
);
2109 /* Finally, handle any statements in the "else" part. */
2110 if (Present (Else_Statements (gnat_node
)))
2112 expand_start_else ();
2114 for (gnat_temp
= First (Else_Statements (gnat_node
));
2115 Present (gnat_temp
);
2116 gnat_temp
= Next (gnat_temp
))
2117 gnat_to_code (gnat_temp
);
2123 case N_Case_Statement
:
2126 Node_Id gnat_choice
;
2128 Node_Id gnat_statement
;
2130 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
2131 gnu_expr
= convert (get_base_type (TREE_TYPE (gnu_expr
)), gnu_expr
);
2133 set_lineno (gnat_node
, 1);
2134 expand_start_case (1, gnu_expr
, TREE_TYPE (gnu_expr
), "case");
2136 for (gnat_when
= First_Non_Pragma (Alternatives (gnat_node
));
2137 Present (gnat_when
);
2138 gnat_when
= Next_Non_Pragma (gnat_when
))
2140 /* First compile all the different case choices for the current
2141 WHEN alternative. */
2143 for (gnat_choice
= First (Discrete_Choices (gnat_when
));
2144 Present (gnat_choice
); gnat_choice
= Next (gnat_choice
))
2148 gnu_label
= build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
);
2150 set_lineno (gnat_choice
, 1);
2151 switch (Nkind (gnat_choice
))
2154 /* Abort on all errors except range empty, which
2155 means we ignore this alternative. */
2157 = pushcase_range (gnat_to_gnu (Low_Bound (gnat_choice
)),
2158 gnat_to_gnu (High_Bound (gnat_choice
)),
2159 convert
, gnu_label
, 0);
2161 if (error_code
!= 0 && error_code
!= 4)
2165 case N_Subtype_Indication
:
2168 (gnat_to_gnu (Low_Bound (Range_Expression
2169 (Constraint (gnat_choice
)))),
2170 gnat_to_gnu (High_Bound (Range_Expression
2171 (Constraint (gnat_choice
)))),
2172 convert
, gnu_label
, 0);
2174 if (error_code
!= 0 && error_code
!= 4)
2179 case N_Expanded_Name
:
2180 /* This represents either a subtype range or a static value
2181 of some kind; Ekind says which. If a static value,
2182 fall through to the next case. */
2183 if (IN (Ekind (Entity (gnat_choice
)), Type_Kind
))
2185 tree type
= get_unpadded_type (Entity (gnat_choice
));
2188 = pushcase_range (fold (TYPE_MIN_VALUE (type
)),
2189 fold (TYPE_MAX_VALUE (type
)),
2190 convert
, gnu_label
, 0);
2192 if (error_code
!= 0 && error_code
!= 4)
2196 /* ... fall through ... */
2197 case N_Character_Literal
:
2198 case N_Integer_Literal
:
2199 if (pushcase (gnat_to_gnu (gnat_choice
), convert
,
2204 case N_Others_Choice
:
2205 if (pushcase (NULL_TREE
, convert
, gnu_label
, 0))
2214 /* After compiling the choices attached to the WHEN compile the
2215 body of statements that have to be executed, should the
2216 "WHEN ... =>" be taken. */
2217 for (gnat_statement
= First (Statements (gnat_when
));
2218 Present (gnat_statement
);
2219 gnat_statement
= Next (gnat_statement
))
2220 gnat_to_code (gnat_statement
);
2222 /* Communicate to GCC that we are done with the current WHEN,
2223 i.e. insert a "break" statement. */
2224 expand_exit_something ();
2227 expand_end_case (gnu_expr
);
2231 case N_Loop_Statement
:
2233 /* The loop variable in GCC form, if any. */
2234 tree gnu_loop_var
= NULL_TREE
;
2235 /* PREINCREMENT_EXPR or PREDECREMENT_EXPR. */
2236 enum tree_code gnu_update
= ERROR_MARK
;
2237 /* Used if this is a named loop for so EXIT can work. */
2238 struct nesting
*loop_id
;
2239 /* Condition to continue loop tested at top of loop. */
2240 tree gnu_top_condition
= integer_one_node
;
2241 /* Similar, but tested at bottom of loop. */
2242 tree gnu_bottom_condition
= integer_one_node
;
2243 Node_Id gnat_statement
;
2244 Node_Id gnat_iter_scheme
= Iteration_Scheme (gnat_node
);
2245 Node_Id gnat_top_condition
= Empty
;
2246 int enclosing_if_p
= 0;
2248 /* Set the condition that under which the loop should continue.
2249 For "LOOP .... END LOOP;" the condition is always true. */
2250 if (No (gnat_iter_scheme
))
2252 /* The case "WHILE condition LOOP ..... END LOOP;" */
2253 else if (Present (Condition (gnat_iter_scheme
)))
2254 gnat_top_condition
= Condition (gnat_iter_scheme
);
2257 /* We have an iteration scheme. */
2258 Node_Id gnat_loop_spec
2259 = Loop_Parameter_Specification (gnat_iter_scheme
);
2260 Entity_Id gnat_loop_var
= Defining_Entity (gnat_loop_spec
);
2261 Entity_Id gnat_type
= Etype (gnat_loop_var
);
2262 tree gnu_type
= get_unpadded_type (gnat_type
);
2263 tree gnu_low
= TYPE_MIN_VALUE (gnu_type
);
2264 tree gnu_high
= TYPE_MAX_VALUE (gnu_type
);
2265 int reversep
= Reverse_Present (gnat_loop_spec
);
2266 tree gnu_first
= reversep
? gnu_high
: gnu_low
;
2267 tree gnu_last
= reversep
? gnu_low
: gnu_high
;
2268 enum tree_code end_code
= reversep
? GE_EXPR
: LE_EXPR
;
2269 tree gnu_base_type
= get_base_type (gnu_type
);
2271 = (reversep
? TYPE_MIN_VALUE (gnu_base_type
)
2272 : TYPE_MAX_VALUE (gnu_base_type
));
2274 /* We know the loop variable will not overflow if GNU_LAST is
2275 a constant and is not equal to GNU_LIMIT. If it might
2276 overflow, we have to move the limit test to the end of
2277 the loop. In that case, we have to test for an
2278 empty loop outside the loop. */
2279 if (TREE_CODE (gnu_last
) != INTEGER_CST
2280 || TREE_CODE (gnu_limit
) != INTEGER_CST
2281 || tree_int_cst_equal (gnu_last
, gnu_limit
))
2283 gnu_expr
= build_binary_op (LE_EXPR
, integer_type_node
,
2285 set_lineno (gnat_loop_spec
, 1);
2286 expand_start_cond (gnu_expr
, 0);
2290 /* Open a new nesting level that will surround the loop to declare
2291 the loop index variable. */
2293 expand_start_bindings (0);
2295 /* Declare the loop index and set it to its initial value. */
2296 gnu_loop_var
= gnat_to_gnu_entity (gnat_loop_var
, gnu_first
, 1);
2297 if (DECL_BY_REF_P (gnu_loop_var
))
2298 gnu_loop_var
= build_unary_op (INDIRECT_REF
, NULL_TREE
,
2301 /* The loop variable might be a padded type, so use `convert' to
2302 get a reference to the inner variable if so. */
2303 gnu_loop_var
= convert (get_base_type (gnu_type
), gnu_loop_var
);
2305 /* Set either the top or bottom exit condition as
2306 appropriate depending on whether we know an overflow
2307 cannot occur or not. */
2309 gnu_bottom_condition
2310 = build_binary_op (NE_EXPR
, integer_type_node
,
2311 gnu_loop_var
, gnu_last
);
2314 = build_binary_op (end_code
, integer_type_node
,
2315 gnu_loop_var
, gnu_last
);
2317 gnu_update
= reversep
? PREDECREMENT_EXPR
: PREINCREMENT_EXPR
;
2320 set_lineno (gnat_node
, 1);
2322 loop_id
= expand_start_loop_continue_elsewhere (1);
2324 loop_id
= expand_start_loop (1);
2326 /* If the loop was named, have the name point to this loop. In this
2327 case, the association is not a ..._DECL node; in fact, it isn't
2328 a GCC tree node at all. Since this name is referenced inside
2329 the loop, do it before we process the statements of the loop. */
2330 if (Present (Identifier (gnat_node
)))
2332 tree gnu_loop_id
= make_node (GNAT_LOOP_ID
);
2334 TREE_LOOP_ID (gnu_loop_id
) = (rtx
) loop_id
;
2335 save_gnu_tree (Entity (Identifier (gnat_node
)), gnu_loop_id
, 1);
2338 set_lineno (gnat_node
, 1);
2340 /* We must evaluate the condition after we've entered the
2341 loop so that any expression actions get done in the right
2343 if (Present (gnat_top_condition
))
2344 gnu_top_condition
= gnat_to_gnu (gnat_top_condition
);
2346 expand_exit_loop_if_false (0, gnu_top_condition
);
2348 /* Make the loop body into its own block, so any allocated
2349 storage will be released every iteration. This is needed
2350 for stack allocation. */
2354 = tree_cons (gnu_bottom_condition
, NULL_TREE
, gnu_block_stack
);
2355 expand_start_bindings (0);
2357 for (gnat_statement
= First (Statements (gnat_node
));
2358 Present (gnat_statement
);
2359 gnat_statement
= Next (gnat_statement
))
2360 gnat_to_code (gnat_statement
);
2362 expand_end_bindings (getdecls (), kept_level_p (), 0);
2363 poplevel (kept_level_p (), 1, 0);
2364 gnu_block_stack
= TREE_CHAIN (gnu_block_stack
);
2366 set_lineno (gnat_node
, 1);
2367 expand_exit_loop_if_false (0, gnu_bottom_condition
);
2371 expand_loop_continue_here ();
2372 gnu_expr
= build_binary_op (gnu_update
, TREE_TYPE (gnu_loop_var
),
2374 convert (TREE_TYPE (gnu_loop_var
),
2376 set_lineno (gnat_iter_scheme
, 1);
2377 expand_expr_stmt (gnu_expr
);
2380 set_lineno (gnat_node
, 1);
2385 /* Close the nesting level that sourround the loop that was used to
2386 declare the loop index variable. */
2387 set_lineno (gnat_node
, 1);
2388 expand_end_bindings (getdecls (), 1, 0);
2394 set_lineno (gnat_node
, 1);
2400 case N_Block_Statement
:
2402 gnu_block_stack
= tree_cons (NULL_TREE
, NULL_TREE
, gnu_block_stack
);
2403 expand_start_bindings (0);
2404 process_decls (Declarations (gnat_node
), Empty
, Empty
, 1, 1);
2405 gnat_to_code (Handled_Statement_Sequence (gnat_node
));
2406 expand_end_bindings (getdecls (), kept_level_p (), 0);
2407 poplevel (kept_level_p (), 1, 0);
2408 gnu_block_stack
= TREE_CHAIN (gnu_block_stack
);
2409 if (Present (Identifier (gnat_node
)))
2410 mark_out_of_scope (Entity (Identifier (gnat_node
)));
2413 case N_Exit_Statement
:
2415 /* Which loop to exit, NULL if the current loop. */
2416 struct nesting
*loop_id
= 0;
2417 /* The GCC version of the optional GNAT condition node attached to the
2418 exit statement. Exit the loop if this is false. */
2419 tree gnu_cond
= integer_zero_node
;
2421 if (Present (Name (gnat_node
)))
2423 = (struct nesting
*)
2424 TREE_LOOP_ID (get_gnu_tree (Entity (Name (gnat_node
))));
2426 if (Present (Condition (gnat_node
)))
2429 (truthvalue_conversion (gnat_to_gnu (Condition (gnat_node
))));
2431 set_lineno (gnat_node
, 1);
2432 expand_exit_loop_if_false (loop_id
, gnu_cond
);
2436 case N_Return_Statement
:
2437 if (type_annotate_only
)
2441 /* The gnu function type of the subprogram currently processed. */
2442 tree gnu_subprog_type
= TREE_TYPE (current_function_decl
);
2443 /* The return value from the subprogram. */
2444 tree gnu_ret_val
= 0;
2446 /* If we are dealing with a "return;" from an Ada procedure with
2447 parameters passed by copy in copy out, we need to return a record
2448 containing the final values of these parameters. If the list
2449 contains only one entry, return just that entry.
2451 For a full description of the copy in copy out parameter mechanism,
2452 see the part of the gnat_to_gnu_entity routine dealing with the
2453 translation of subprograms.
2455 But if we have a return label defined, convert this into
2456 a branch to that label. */
2458 if (TREE_VALUE (gnu_return_label_stack
) != 0)
2459 expand_goto (TREE_VALUE (gnu_return_label_stack
));
2461 else if (TYPE_CI_CO_LIST (gnu_subprog_type
) != NULL_TREE
)
2463 if (list_length (TYPE_CI_CO_LIST (gnu_subprog_type
)) == 1)
2464 gnu_ret_val
= TREE_VALUE (TYPE_CI_CO_LIST (gnu_subprog_type
));
2467 = build_constructor (TREE_TYPE (gnu_subprog_type
),
2468 TYPE_CI_CO_LIST (gnu_subprog_type
));
2471 /* If the Ada subprogram is a function, we just need to return the
2472 expression. If the subprogram returns an unconstrained
2473 array, we have to allocate a new version of the result and
2474 return it. If we return by reference, return a pointer. */
2476 else if (Present (Expression (gnat_node
)))
2478 gnu_ret_val
= gnat_to_gnu (Expression (gnat_node
));
2480 /* Do not remove the padding from GNU_RET_VAL if the inner
2481 type is self-referential since we want to allocate the fixed
2482 size in that case. */
2483 if (TREE_CODE (gnu_ret_val
) == COMPONENT_REF
2484 && (TYPE_IS_PADDING_P
2485 (TREE_TYPE (TREE_OPERAND (gnu_ret_val
, 0))))
2486 && contains_placeholder_p
2487 (TYPE_SIZE (TREE_TYPE (gnu_ret_val
))))
2488 gnu_ret_val
= TREE_OPERAND (gnu_ret_val
, 0);
2490 if (TYPE_RETURNS_BY_REF_P (gnu_subprog_type
)
2491 || By_Ref (gnat_node
))
2492 gnu_ret_val
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_ret_val
);
2494 else if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type
))
2496 gnu_ret_val
= maybe_unconstrained_array (gnu_ret_val
);
2498 /* We have two cases: either the function returns with
2499 depressed stack or not. If not, we allocate on the
2500 secondary stack. If so, we allocate in the stack frame.
2501 if no copy is needed, the front end will set By_Ref,
2502 which we handle in the case above. */
2503 if (TYPE_RETURNS_STACK_DEPRESSED (gnu_subprog_type
))
2505 = build_allocator (TREE_TYPE (gnu_ret_val
), gnu_ret_val
,
2506 TREE_TYPE (gnu_subprog_type
), 0, -1);
2509 = build_allocator (TREE_TYPE (gnu_ret_val
), gnu_ret_val
,
2510 TREE_TYPE (gnu_subprog_type
),
2511 Procedure_To_Call (gnat_node
),
2512 Storage_Pool (gnat_node
));
2516 set_lineno (gnat_node
, 1);
2518 expand_return (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
2519 DECL_RESULT (current_function_decl
),
2522 expand_null_return ();
2527 case N_Goto_Statement
:
2528 if (type_annotate_only
)
2531 gnu_expr
= gnat_to_gnu (Name (gnat_node
));
2532 TREE_USED (gnu_expr
) = 1;
2533 set_lineno (gnat_node
, 1);
2534 expand_goto (gnu_expr
);
2537 /****************************/
2538 /* Chapter 6: Subprograms: */
2539 /****************************/
2541 case N_Subprogram_Declaration
:
2542 /* Unless there is a freeze node, declare the subprogram. We consider
2543 this a "definition" even though we're not generating code for
2544 the subprogram because we will be making the corresponding GCC
2547 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node
)))))
2548 gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node
)),
2553 case N_Abstract_Subprogram_Declaration
:
2554 /* This subprogram doesn't exist for code generation purposes, but we
2555 have to elaborate the types of any parameters, unless they are
2556 imported types (nothing to generate in this case). */
2558 = First_Formal (Defining_Entity (Specification (gnat_node
)));
2559 Present (gnat_temp
);
2560 gnat_temp
= Next_Formal_With_Extras (gnat_temp
))
2561 if (Is_Itype (Etype (gnat_temp
))
2562 && !From_With_Type (Etype (gnat_temp
)))
2563 gnat_to_gnu_entity (Etype (gnat_temp
), NULL_TREE
, 0);
2567 case N_Defining_Program_Unit_Name
:
2568 /* For a child unit identifier go up a level to get the
2569 specificaton. We get this when we try to find the spec of
2570 a child unit package that is the compilation unit being compiled. */
2571 gnat_to_code (Parent (gnat_node
));
2574 case N_Subprogram_Body
:
2576 /* Save debug output mode in case it is reset. */
2577 enum debug_info_type save_write_symbols
= write_symbols
;
2578 struct gcc_debug_hooks
*save_debug_hooks
= debug_hooks
;
2579 /* Definining identifier of a parameter to the subprogram. */
2580 Entity_Id gnat_param
;
2581 /* The defining identifier for the subprogram body. Note that if a
2582 specification has appeared before for this body, then the identifier
2583 occurring in that specification will also be a defining identifier
2584 and all the calls to this subprogram will point to that
2586 Entity_Id gnat_subprog_id
2587 = (Present (Corresponding_Spec (gnat_node
))
2588 ? Corresponding_Spec (gnat_node
) : Defining_Entity (gnat_node
));
2590 /* The FUNCTION_DECL node corresponding to the subprogram spec. */
2591 tree gnu_subprog_decl
;
2592 /* The FUNCTION_TYPE node corresponding to the subprogram spec. */
2593 tree gnu_subprog_type
;
2596 /* If this is a generic object or if it has been eliminated,
2599 if (Ekind (gnat_subprog_id
) == E_Generic_Procedure
2600 || Ekind (gnat_subprog_id
) == E_Generic_Function
2601 || Is_Eliminated (gnat_subprog_id
))
2604 /* If debug information is suppressed for the subprogram,
2605 turn debug mode off for the duration of processing. */
2606 if (Debug_Info_Off (gnat_subprog_id
))
2608 write_symbols
= NO_DEBUG
;
2609 debug_hooks
= &do_nothing_debug_hooks
;
2612 /* If this subprogram acts as its own spec, define it. Otherwise,
2613 just get the already-elaborated tree node. However, if this
2614 subprogram had its elaboration deferred, we will already have
2615 made a tree node for it. So treat it as not being defined in
2616 that case. Such a subprogram cannot have an address clause or
2617 a freeze node, so this test is safe, though it does disable
2618 some otherwise-useful error checking. */
2620 = gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
,
2621 Acts_As_Spec (gnat_node
)
2622 && ! present_gnu_tree (gnat_subprog_id
));
2624 gnu_subprog_type
= TREE_TYPE (gnu_subprog_decl
);
2626 /* Set the line number in the decl to correspond to that of
2627 the body so that the line number notes are written
2629 set_lineno (gnat_node
, 0);
2630 DECL_SOURCE_FILE (gnu_subprog_decl
) = input_filename
;
2631 DECL_SOURCE_LINE (gnu_subprog_decl
) = lineno
;
2633 begin_subprog_body (gnu_subprog_decl
);
2634 set_lineno (gnat_node
, 1);
2637 gnu_block_stack
= tree_cons (NULL_TREE
, NULL_TREE
, gnu_block_stack
);
2638 expand_start_bindings (0);
2640 gnu_cico_list
= TYPE_CI_CO_LIST (gnu_subprog_type
);
2642 /* If there are OUT parameters, we need to ensure that the
2643 return statement properly copies them out. We do this by
2644 making a new block and converting any inner return into a goto
2645 to a label at the end of the block. */
2647 if (gnu_cico_list
!= 0)
2649 gnu_return_label_stack
2650 = tree_cons (NULL_TREE
,
2651 build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
),
2652 gnu_return_label_stack
);
2654 expand_start_bindings (0);
2657 gnu_return_label_stack
2658 = tree_cons (NULL_TREE
, NULL_TREE
, gnu_return_label_stack
);
2660 /* See if there are any parameters for which we don't yet have
2661 GCC entities. These must be for OUT parameters for which we
2662 will be making VAR_DECL nodes here. Fill them in to
2663 TYPE_CI_CO_LIST, which must contain the empty entry as well.
2664 We can match up the entries because TYPE_CI_CO_LIST is in the
2665 order of the parameters. */
2667 for (gnat_param
= First_Formal (gnat_subprog_id
);
2668 Present (gnat_param
);
2669 gnat_param
= Next_Formal_With_Extras (gnat_param
))
2670 if (present_gnu_tree (gnat_param
))
2671 adjust_decl_rtl (get_gnu_tree (gnat_param
));
2674 /* Skip any entries that have been already filled in; they
2675 must correspond to IN OUT parameters. */
2676 for (; gnu_cico_list
!= 0 && TREE_VALUE (gnu_cico_list
) != 0;
2677 gnu_cico_list
= TREE_CHAIN (gnu_cico_list
))
2680 /* Do any needed references for padded types. */
2681 TREE_VALUE (gnu_cico_list
)
2682 = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_list
)),
2683 gnat_to_gnu_entity (gnat_param
, NULL_TREE
, 1));
2686 process_decls (Declarations (gnat_node
), Empty
, Empty
, 1, 1);
2688 /* Generate the code of the subprogram itself. A return statement
2689 will be present and any OUT parameters will be handled there. */
2690 gnat_to_code (Handled_Statement_Sequence (gnat_node
));
2692 expand_end_bindings (getdecls (), kept_level_p (), 0);
2693 poplevel (kept_level_p (), 1, 0);
2694 gnu_block_stack
= TREE_CHAIN (gnu_block_stack
);
2696 if (TREE_VALUE (gnu_return_label_stack
) != 0)
2700 expand_end_bindings (NULL_TREE
, kept_level_p (), 0);
2701 poplevel (kept_level_p (), 1, 0);
2702 expand_label (TREE_VALUE (gnu_return_label_stack
));
2704 gnu_cico_list
= TYPE_CI_CO_LIST (gnu_subprog_type
);
2705 set_lineno (gnat_node
, 1);
2706 if (list_length (gnu_cico_list
) == 1)
2707 gnu_retval
= TREE_VALUE (gnu_cico_list
);
2709 gnu_retval
= build_constructor (TREE_TYPE (gnu_subprog_type
),
2712 if (DECL_P (gnu_retval
) && DECL_BY_REF_P (gnu_retval
))
2714 = build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_retval
);
2717 (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
2718 DECL_RESULT (current_function_decl
),
2723 gnu_return_label_stack
= TREE_CHAIN (gnu_return_label_stack
);
2725 /* Disconnect the trees for parameters that we made variables for
2726 from the GNAT entities since these will become unusable after
2727 we end the function. */
2728 for (gnat_param
= First_Formal (gnat_subprog_id
);
2729 Present (gnat_param
);
2730 gnat_param
= Next_Formal_With_Extras (gnat_param
))
2731 if (TREE_CODE (get_gnu_tree (gnat_param
)) == VAR_DECL
)
2732 save_gnu_tree (gnat_param
, NULL_TREE
, 0);
2734 end_subprog_body ();
2735 mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node
)));
2736 write_symbols
= save_write_symbols
;
2737 debug_hooks
= save_debug_hooks
;
2741 case N_Function_Call
:
2742 case N_Procedure_Call_Statement
:
2744 if (type_annotate_only
)
2748 /* The GCC node corresponding to the GNAT subprogram name. This can
2749 either be a FUNCTION_DECL node if we are dealing with a standard
2750 subprogram call, or an indirect reference expression (an
2751 INDIRECT_REF node) pointing to a subprogram. */
2752 tree gnu_subprog_node
= gnat_to_gnu (Name (gnat_node
));
2753 /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */
2754 tree gnu_subprog_type
= TREE_TYPE (gnu_subprog_node
);
2755 tree gnu_subprog_addr
2756 = build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_subprog_node
);
2757 Entity_Id gnat_formal
;
2758 Node_Id gnat_actual
;
2759 tree gnu_actual_list
= NULL_TREE
;
2760 tree gnu_name_list
= NULL_TREE
;
2761 tree gnu_after_list
= NULL_TREE
;
2762 tree gnu_subprog_call
;
2764 switch (Nkind (Name (gnat_node
)))
2767 case N_Operator_Symbol
:
2768 case N_Expanded_Name
:
2769 case N_Attribute_Reference
:
2770 if (Is_Eliminated (Entity (Name (gnat_node
))))
2771 post_error_ne ("cannot call eliminated subprogram &!",
2772 gnat_node
, Entity (Name (gnat_node
)));
2775 if (TREE_CODE (gnu_subprog_type
) != FUNCTION_TYPE
)
2778 /* If we are calling a stubbed function, make this into a
2779 raise of Program_Error. Elaborate all our args first. */
2781 if (TREE_CODE (gnu_subprog_node
) == FUNCTION_DECL
2782 && DECL_STUBBED_P (gnu_subprog_node
))
2784 for (gnat_actual
= First_Actual (gnat_node
);
2785 Present (gnat_actual
);
2786 gnat_actual
= Next_Actual (gnat_actual
))
2787 expand_expr_stmt (gnat_to_gnu (gnat_actual
));
2789 if (Nkind (gnat_node
) == N_Function_Call
)
2791 gnu_result_type
= TREE_TYPE (gnu_subprog_type
);
2793 = build1 (NULL_EXPR
, gnu_result_type
,
2794 build_call_raise (raise_program_error_decl
));
2797 expand_expr_stmt (build_call_raise (raise_program_error_decl
));
2801 /* The only way we can be making a call via an access type is
2802 if Name is an explicit dereference. In that case, get the
2803 list of formal args from the type the access type is pointing
2804 to. Otherwise, get the formals from entity being called. */
2805 if (Nkind (Name (gnat_node
)) == N_Explicit_Dereference
)
2806 gnat_formal
= First_Formal (Etype (Name (gnat_node
)));
2807 else if (Nkind (Name (gnat_node
)) == N_Attribute_Reference
)
2808 /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
2811 gnat_formal
= First_Formal (Entity (Name (gnat_node
)));
2813 /* Create the list of the actual parameters as GCC expects it, namely
2814 a chain of TREE_LIST nodes in which the TREE_VALUE field of each
2815 node is a parameter-expression and the TREE_PURPOSE field is
2816 null. Skip OUT parameters that are not passed by reference. */
2818 for (gnat_actual
= First_Actual (gnat_node
);
2819 Present (gnat_actual
);
2820 gnat_formal
= Next_Formal_With_Extras (gnat_formal
),
2821 gnat_actual
= Next_Actual (gnat_actual
))
2823 tree gnu_formal_type
= gnat_to_gnu_type (Etype (gnat_formal
));
2825 = ((Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
)
2826 ? Expression (gnat_actual
) : gnat_actual
);
2827 tree gnu_name
= gnat_to_gnu (gnat_name
);
2828 tree gnu_name_type
= gnat_to_gnu_type (Etype (gnat_name
));
2831 /* If it's possible we may need to use this expression twice,
2832 make sure than any side-effects are handled via SAVE_EXPRs.
2833 Likewise if we need to force side-effects before the call.
2834 ??? This is more conservative than we need since we don't
2835 need to do this for pass-by-ref with no conversion.
2836 If we are passing a non-addressable Out or In Out parameter by
2837 reference, pass the address of a copy and set up to copy back
2838 out after the call. */
2840 if (Ekind (gnat_formal
) != E_In_Parameter
)
2842 gnu_name
= gnat_stabilize_reference (gnu_name
, 1);
2843 if (! addressable_p (gnu_name
)
2844 && present_gnu_tree (gnat_formal
)
2845 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal
))
2846 || DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal
))
2847 || DECL_BY_DESCRIPTOR_P (get_gnu_tree (gnat_formal
))))
2849 tree gnu_copy
= gnu_name
;
2851 /* Remove any unpadding on the actual and make a copy.
2852 But if the actual is a left-justified modular type,
2853 first convert to it. */
2854 if (TREE_CODE (gnu_name
) == COMPONENT_REF
2855 && (TYPE_IS_PADDING_P
2856 (TREE_TYPE (TREE_OPERAND (gnu_name
, 0)))))
2857 gnu_name
= gnu_copy
= TREE_OPERAND (gnu_name
, 0);
2858 else if (TREE_CODE (gnu_name_type
) == RECORD_TYPE
2859 && (TYPE_LEFT_JUSTIFIED_MODULAR_P
2861 gnu_name
= convert (gnu_name_type
, gnu_name
);
2863 gnu_actual
= save_expr (gnu_name
);
2865 /* Set up to move the copy back to the original. */
2866 gnu_after_list
= tree_cons (gnu_copy
, gnu_actual
,
2869 gnu_name
= gnu_actual
;
2873 /* If this was a procedure call, we may not have removed any
2874 padding. So do it here for the part we will use as an
2876 gnu_actual
= gnu_name
;
2877 if (Ekind (gnat_formal
) != E_Out_Parameter
2878 && TREE_CODE (TREE_TYPE (gnu_actual
)) == RECORD_TYPE
2879 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual
)))
2880 gnu_actual
= convert (get_unpadded_type (Etype (gnat_actual
)),
2883 if (Ekind (gnat_formal
) != E_Out_Parameter
2884 && Nkind (gnat_actual
) != N_Unchecked_Type_Conversion
2885 && Do_Range_Check (gnat_actual
))
2886 gnu_actual
= emit_range_check (gnu_actual
, Etype (gnat_formal
));
2888 /* Do any needed conversions. We need only check for
2889 unchecked conversion since normal conversions will be handled
2890 by just converting to the formal type. */
2891 if (Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
)
2894 = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual
)),
2897 /* One we've done the unchecked conversion, we still
2898 must ensure that the object is in range of the formal's
2900 if (Ekind (gnat_formal
) != E_Out_Parameter
2901 && Do_Range_Check (gnat_actual
))
2902 gnu_actual
= emit_range_check (gnu_actual
,
2903 Etype (gnat_formal
));
2906 /* We may have suppressed a conversion to the Etype of the
2907 actual since the parent is a procedure call. So add the
2909 gnu_actual
= convert (gnat_to_gnu_type (Etype (gnat_actual
)),
2912 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
2914 /* If we have not saved a GCC object for the formal, it means
2915 it is an OUT parameter not passed by reference. Otherwise,
2916 look at the PARM_DECL to see if it is passed by reference. */
2917 if (present_gnu_tree (gnat_formal
)
2918 && TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
2919 && DECL_BY_REF_P (get_gnu_tree (gnat_formal
)))
2921 if (Ekind (gnat_formal
) != E_In_Parameter
)
2923 gnu_actual
= gnu_name
;
2925 /* If we have a padded type, be sure we've removed the
2927 if (TREE_CODE (TREE_TYPE (gnu_actual
)) == RECORD_TYPE
2928 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual
)))
2930 = convert (get_unpadded_type (Etype (gnat_actual
)),
2934 /* The symmetry of the paths to the type of an entity is
2935 broken here since arguments don't know that they will
2936 be passed by ref. */
2937 gnu_formal_type
= TREE_TYPE (get_gnu_tree (gnat_formal
));
2938 gnu_actual
= build_unary_op (ADDR_EXPR
, gnu_formal_type
,
2941 else if (present_gnu_tree (gnat_formal
)
2942 && TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
2943 && DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal
)))
2945 gnu_formal_type
= TREE_TYPE (get_gnu_tree (gnat_formal
));
2946 gnu_actual
= maybe_implicit_deref (gnu_actual
);
2947 gnu_actual
= maybe_unconstrained_array (gnu_actual
);
2949 if (TREE_CODE (gnu_formal_type
) == RECORD_TYPE
2950 && TYPE_IS_PADDING_P (gnu_formal_type
))
2953 = TREE_TYPE (TYPE_FIELDS (gnu_formal_type
));
2954 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
2957 /* Take the address of the object and convert to the
2958 proper pointer type. We'd like to actually compute
2959 the address of the beginning of the array using
2960 an ADDR_EXPR of an ARRAY_REF, but there's a possibility
2961 that the ARRAY_REF might return a constant and we'd
2962 be getting the wrong address. Neither approach is
2963 exactly correct, but this is the most likely to work
2965 gnu_actual
= convert (gnu_formal_type
,
2966 build_unary_op (ADDR_EXPR
, NULL_TREE
,
2969 else if (present_gnu_tree (gnat_formal
)
2970 && TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
2971 && DECL_BY_DESCRIPTOR_P (get_gnu_tree (gnat_formal
)))
2973 /* If arg is 'Null_Parameter, pass zero descriptor. */
2974 if ((TREE_CODE (gnu_actual
) == INDIRECT_REF
2975 || TREE_CODE (gnu_actual
) == UNCONSTRAINED_ARRAY_REF
)
2976 && TREE_PRIVATE (gnu_actual
))
2978 = convert (DECL_ARG_TYPE (get_gnu_tree (gnat_formal
)),
2982 = build_unary_op (ADDR_EXPR
, NULL_TREE
,
2983 fill_vms_descriptor (gnu_actual
,
2988 tree gnu_actual_size
= TYPE_SIZE (TREE_TYPE (gnu_actual
));
2990 if (Ekind (gnat_formal
) != E_In_Parameter
)
2992 = chainon (gnu_name_list
,
2993 build_tree_list (NULL_TREE
, gnu_name
));
2995 if (! present_gnu_tree (gnat_formal
)
2996 || TREE_CODE (get_gnu_tree (gnat_formal
)) != PARM_DECL
)
2999 /* If this is 'Null_Parameter, pass a zero even though we are
3000 dereferencing it. */
3001 else if (TREE_CODE (gnu_actual
) == INDIRECT_REF
3002 && TREE_PRIVATE (gnu_actual
)
3003 && host_integerp (gnu_actual_size
, 1)
3004 && 0 >= compare_tree_int (gnu_actual_size
,
3008 (DECL_ARG_TYPE (get_gnu_tree (gnat_formal
)),
3009 convert (type_for_size
3010 (tree_low_cst (gnu_actual_size
, 1), 1),
3011 integer_zero_node
));
3014 = convert (TYPE_MAIN_VARIANT
3015 (DECL_ARG_TYPE (get_gnu_tree (gnat_formal
))),
3020 = chainon (gnu_actual_list
,
3021 build_tree_list (NULL_TREE
, gnu_actual
));
3024 gnu_subprog_call
= build (CALL_EXPR
, TREE_TYPE (gnu_subprog_type
),
3025 gnu_subprog_addr
, gnu_actual_list
,
3027 TREE_SIDE_EFFECTS (gnu_subprog_call
) = 1;
3029 /* If it is a function call, the result is the call expression. */
3030 if (Nkind (gnat_node
) == N_Function_Call
)
3032 gnu_result
= gnu_subprog_call
;
3034 /* If the function returns an unconstrained array or by reference,
3035 we have to de-dereference the pointer. */
3036 if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type
)
3037 || TYPE_RETURNS_BY_REF_P (gnu_subprog_type
))
3038 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
,
3041 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
3044 /* If this is the case where the GNAT tree contains a procedure call
3045 but the Ada procedure has copy in copy out parameters, the special
3046 parameter passing mechanism must be used. */
3047 else if (TYPE_CI_CO_LIST (gnu_subprog_type
) != NULL_TREE
)
3049 /* List of FIELD_DECLs associated with the PARM_DECLs of the copy
3050 in copy out parameters. */
3051 tree scalar_return_list
= TYPE_CI_CO_LIST (gnu_subprog_type
);
3052 int length
= list_length (scalar_return_list
);
3058 gnu_subprog_call
= make_save_expr (gnu_subprog_call
);
3060 /* If any of the names had side-effects, ensure they are
3061 all evaluated before the call. */
3062 for (gnu_name
= gnu_name_list
; gnu_name
;
3063 gnu_name
= TREE_CHAIN (gnu_name
))
3064 if (TREE_SIDE_EFFECTS (TREE_VALUE (gnu_name
)))
3066 = build (COMPOUND_EXPR
, TREE_TYPE (gnu_subprog_call
),
3067 TREE_VALUE (gnu_name
), gnu_subprog_call
);
3070 if (Nkind (Name (gnat_node
)) == N_Explicit_Dereference
)
3071 gnat_formal
= First_Formal (Etype (Name (gnat_node
)));
3073 gnat_formal
= First_Formal (Entity (Name (gnat_node
)));
3075 for (gnat_actual
= First_Actual (gnat_node
);
3076 Present (gnat_actual
);
3077 gnat_formal
= Next_Formal_With_Extras (gnat_formal
),
3078 gnat_actual
= Next_Actual (gnat_actual
))
3079 /* If we are dealing with a copy in copy out parameter, we must
3080 retrieve its value from the record returned in the function
3082 if (! (present_gnu_tree (gnat_formal
)
3083 && TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
3084 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal
))
3085 || (DECL_BY_COMPONENT_PTR_P
3086 (get_gnu_tree (gnat_formal
)))
3087 || DECL_BY_DESCRIPTOR_P (get_gnu_tree (gnat_formal
))))
3088 && Ekind (gnat_formal
) != E_In_Parameter
)
3090 /* Get the value to assign to this OUT or IN OUT
3091 parameter. It is either the result of the function if
3092 there is only a single such parameter or the appropriate
3093 field from the record returned. */
3095 = length
== 1 ? gnu_subprog_call
3096 : build_component_ref
3097 (gnu_subprog_call
, NULL_TREE
,
3098 TREE_PURPOSE (scalar_return_list
));
3099 int unchecked_conversion
3100 = Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
;
3101 /* If the actual is a conversion, get the inner expression,
3102 which will be the real destination, and convert the
3103 result to the type of the actual parameter. */
3105 = maybe_unconstrained_array (TREE_VALUE (gnu_name_list
));
3107 /* If the result is a padded type, remove the padding. */
3108 if (TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
3109 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result
)))
3111 = convert (TREE_TYPE (TYPE_FIELDS
3112 (TREE_TYPE (gnu_result
))),
3115 /* If the result is a type conversion, do it. */
3116 if (Nkind (gnat_actual
) == N_Type_Conversion
)
3118 = convert_with_check
3119 (Etype (Expression (gnat_actual
)), gnu_result
,
3120 Do_Overflow_Check (gnat_actual
),
3121 Do_Range_Check (Expression (gnat_actual
)),
3122 Float_Truncate (gnat_actual
));
3124 else if (unchecked_conversion
)
3126 = unchecked_convert (TREE_TYPE (gnu_actual
), gnu_result
);
3129 if (Do_Range_Check (gnat_actual
))
3130 gnu_result
= emit_range_check (gnu_result
,
3131 Etype (gnat_actual
));
3133 if (! (! TREE_CONSTANT (TYPE_SIZE
3134 (TREE_TYPE (gnu_actual
)))
3135 && TREE_CONSTANT (TYPE_SIZE
3136 (TREE_TYPE (gnu_result
)))))
3137 gnu_result
= convert (TREE_TYPE (gnu_actual
),
3141 set_lineno (gnat_node
, 1);
3142 expand_expr_stmt (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
3143 gnu_actual
, gnu_result
));
3144 scalar_return_list
= TREE_CHAIN (scalar_return_list
);
3145 gnu_name_list
= TREE_CHAIN (gnu_name_list
);
3150 set_lineno (gnat_node
, 1);
3151 expand_expr_stmt (gnu_subprog_call
);
3154 /* Handle anything we need to assign back. */
3155 for (gnu_expr
= gnu_after_list
;
3157 gnu_expr
= TREE_CHAIN (gnu_expr
))
3158 expand_expr_stmt (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
3159 TREE_PURPOSE (gnu_expr
),
3160 TREE_VALUE (gnu_expr
)));
3164 /*************************/
3165 /* Chapter 7: Packages: */
3166 /*************************/
3168 case N_Package_Declaration
:
3169 gnat_to_code (Specification (gnat_node
));
3172 case N_Package_Specification
:
3174 process_decls (Visible_Declarations (gnat_node
),
3175 Private_Declarations (gnat_node
), Empty
, 1, 1);
3178 case N_Package_Body
:
3180 /* If this is the body of a generic package - do nothing */
3181 if (Ekind (Corresponding_Spec (gnat_node
)) == E_Generic_Package
)
3184 process_decls (Declarations (gnat_node
), Empty
, Empty
, 1, 1);
3186 if (Present (Handled_Statement_Sequence (gnat_node
)))
3188 gnu_block_stack
= tree_cons (NULL_TREE
, NULL_TREE
, gnu_block_stack
);
3189 gnat_to_code (Handled_Statement_Sequence (gnat_node
));
3190 gnu_block_stack
= TREE_CHAIN (gnu_block_stack
);
3194 /*********************************/
3195 /* Chapter 8: Visibility Rules: */
3196 /*********************************/
3198 case N_Use_Package_Clause
:
3199 case N_Use_Type_Clause
:
3200 /* Nothing to do here - but these may appear in list of declarations */
3203 /***********************/
3204 /* Chapter 9: Tasks: */
3205 /***********************/
3207 case N_Protected_Type_Declaration
:
3210 case N_Single_Task_Declaration
:
3211 gnat_to_gnu_entity (Defining_Entity (gnat_node
), NULL_TREE
, 1);
3214 /***********************************************************/
3215 /* Chapter 10: Program Structure and Compilation Issues: */
3216 /***********************************************************/
3218 case N_Compilation_Unit
:
3220 /* For a body, first process the spec if there is one. */
3221 if (Nkind (Unit (gnat_node
)) == N_Package_Body
3222 || (Nkind (Unit (gnat_node
)) == N_Subprogram_Body
3223 && ! Acts_As_Spec (gnat_node
)))
3224 gnat_to_code (Library_Unit (gnat_node
));
3226 process_inlined_subprograms (gnat_node
);
3228 if (type_annotate_only
&& gnat_node
== Cunit (Main_Unit
))
3230 elaborate_all_entities (gnat_node
);
3232 if (Nkind (Unit (gnat_node
)) == N_Subprogram_Declaration
3233 || Nkind (Unit (gnat_node
)) == N_Generic_Package_Declaration
3234 || Nkind (Unit (gnat_node
)) == N_Generic_Subprogram_Declaration
)
3238 process_decls (Declarations (Aux_Decls_Node (gnat_node
)),
3239 Empty
, Empty
, 1, 1);
3241 gnat_to_code (Unit (gnat_node
));
3243 /* Process any pragmas following the unit. */
3244 if (Present (Pragmas_After (Aux_Decls_Node (gnat_node
))))
3245 for (gnat_temp
= First (Pragmas_After (Aux_Decls_Node (gnat_node
)));
3246 gnat_temp
; gnat_temp
= Next (gnat_temp
))
3247 gnat_to_code (gnat_temp
);
3249 /* Put all the Actions into the elaboration routine if we already had
3250 elaborations. This will happen anyway if they are statements, but we
3251 want to force declarations there too due to order-of-elaboration
3252 issues. Most should have Is_Statically_Allocated set. If we
3253 have had no elaborations, we have no order-of-elaboration issue and
3254 don't want to create elaborations here. */
3255 if (Is_Non_Empty_List (Actions (Aux_Decls_Node (gnat_node
))))
3256 for (gnat_temp
= First (Actions (Aux_Decls_Node (gnat_node
)));
3257 Present (gnat_temp
); gnat_temp
= Next (gnat_temp
))
3259 if (pending_elaborations_p ())
3260 add_pending_elaborations (NULL_TREE
,
3261 make_transform_expr (gnat_temp
));
3263 gnat_to_code (gnat_temp
);
3266 /* Generate elaboration code for this unit, if necessary, and
3267 say whether we did or not. */
3268 Set_Has_No_Elaboration_Code
3271 (Defining_Entity (Unit (gnat_node
)),
3272 Nkind (Unit (gnat_node
)) == N_Package_Body
3273 || Nkind (Unit (gnat_node
)) == N_Subprogram_Body
,
3274 get_pending_elaborations ()));
3278 case N_Subprogram_Body_Stub
:
3279 case N_Package_Body_Stub
:
3280 case N_Protected_Body_Stub
:
3281 case N_Task_Body_Stub
:
3282 /* Simply process whatever unit is being inserted. */
3283 gnat_to_code (Unit (Library_Unit (gnat_node
)));
3287 gnat_to_code (Proper_Body (gnat_node
));
3290 /***************************/
3291 /* Chapter 11: Exceptions: */
3292 /***************************/
3294 case N_Handled_Sequence_Of_Statements
:
3295 /* If there are exception handlers, start a new binding level that
3296 we can exit (since each exception handler will do so). Then
3297 declare a variable to save the old __gnat_jmpbuf value and a
3298 variable for our jmpbuf. Call setjmp and handle each of the
3299 possible exceptions if it returns one. */
3301 if (! type_annotate_only
&& Present (Exception_Handlers (gnat_node
)))
3303 tree gnu_jmpsave_decl
= 0;
3304 tree gnu_jmpbuf_decl
= 0;
3305 tree gnu_cleanup_call
= 0;
3306 tree gnu_cleanup_decl
;
3309 expand_start_bindings (1);
3311 if (! Zero_Cost_Handling (gnat_node
))
3314 = create_var_decl (get_identifier ("JMPBUF_SAVE"), NULL_TREE
,
3316 build_call_0_expr (get_jmpbuf_decl
),
3319 gnu_jmpbuf_decl
= create_var_decl (get_identifier ("JMP_BUF"),
3320 NULL_TREE
, jmpbuf_type
,
3321 NULL_TREE
, 0, 0, 0, 0,
3323 TREE_VALUE (gnu_block_stack
) = gnu_jmpbuf_decl
;
3326 /* See if we are to call a function when exiting this block. */
3327 if (Present (At_End_Proc (gnat_node
)))
3330 = build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node
)));
3333 = create_var_decl (get_identifier ("CLEANUP"), NULL_TREE
,
3334 integer_type_node
, NULL_TREE
, 0, 0, 0, 0,
3337 expand_decl_cleanup (gnu_cleanup_decl
, gnu_cleanup_call
);
3340 if (! Zero_Cost_Handling (gnat_node
))
3342 /* When we exit this block, restore the saved value. */
3343 expand_decl_cleanup (gnu_jmpsave_decl
,
3344 build_call_1_expr (set_jmpbuf_decl
,
3347 /* Call setjmp and handle exceptions if it returns one. */
3348 set_lineno (gnat_node
, 1);
3350 (build_call_1_expr (setjmp_decl
,
3351 build_unary_op (ADDR_EXPR
, NULL_TREE
,
3355 /* Restore our incoming longjmp value before we do anything. */
3356 expand_expr_stmt (build_call_1_expr (set_jmpbuf_decl
,
3360 expand_start_bindings (0);
3362 gnu_except_ptr_stack
3363 = tree_cons (NULL_TREE
,
3365 (get_identifier ("EXCEPT_PTR"), NULL_TREE
,
3366 build_pointer_type (except_type_node
),
3367 build_call_0_expr (get_excptr_decl
),
3369 gnu_except_ptr_stack
);
3371 /* Generate code for each exception handler. The code at
3372 N_Exception_Handler below does the real work. Note that
3373 we ignore the dummy exception handler for the identifier
3374 case, this is used only by the front end */
3375 if (Present (Exception_Handlers (gnat_node
)))
3377 = First_Non_Pragma (Exception_Handlers (gnat_node
));
3378 Present (gnat_temp
);
3379 gnat_temp
= Next_Non_Pragma (gnat_temp
))
3380 gnat_to_code (gnat_temp
);
3382 /* If none of the exception handlers did anything, re-raise
3383 but do not defer abortion. */
3384 set_lineno (gnat_node
, 1);
3386 (build_call_1_expr (raise_nodefer_decl
,
3387 TREE_VALUE (gnu_except_ptr_stack
)));
3389 gnu_except_ptr_stack
= TREE_CHAIN (gnu_except_ptr_stack
);
3390 expand_end_bindings (getdecls (), kept_level_p (), 0);
3391 poplevel (kept_level_p (), 1, 0);
3393 /* End the "if" on setjmp. Note that we have arranged things so
3394 control never returns here. */
3397 /* This is now immediately before the body proper. Set
3398 our jmp_buf as the current buffer. */
3400 (build_call_1_expr (set_jmpbuf_decl
,
3401 build_unary_op (ADDR_EXPR
, NULL_TREE
,
3406 /* If there are no exception handlers, we must not have an at end
3407 cleanup identifier, since the cleanup identifier should always
3408 generate a corresponding exception handler. */
3409 else if (! type_annotate_only
&& Present (At_End_Proc (gnat_node
)))
3412 /* Generate code and declarations for the prefix of this block,
3414 if (Present (First_Real_Statement (gnat_node
)))
3415 process_decls (Statements (gnat_node
), Empty
,
3416 First_Real_Statement (gnat_node
), 1, 1);
3418 /* Generate code for each statement in the block. */
3419 for (gnat_temp
= (Present (First_Real_Statement (gnat_node
))
3420 ? First_Real_Statement (gnat_node
)
3421 : First (Statements (gnat_node
)));
3422 Present (gnat_temp
); gnat_temp
= Next (gnat_temp
))
3423 gnat_to_code (gnat_temp
);
3425 /* For zero-cost exceptions, exit the block and then compile
3427 if (! type_annotate_only
&& Zero_Cost_Handling (gnat_node
)
3428 && Present (Exception_Handlers (gnat_node
)))
3430 expand_exit_something ();
3431 gnu_except_ptr_stack
3432 = tree_cons (NULL_TREE
, error_mark_node
, gnu_except_ptr_stack
);
3434 for (gnat_temp
= First_Non_Pragma (Exception_Handlers (gnat_node
));
3435 Present (gnat_temp
);
3436 gnat_temp
= Next_Non_Pragma (gnat_temp
))
3437 gnat_to_code (gnat_temp
);
3439 gnu_except_ptr_stack
= TREE_CHAIN (gnu_except_ptr_stack
);
3442 /* If we have handlers, close the block we made. */
3443 if (! type_annotate_only
&& Present (Exception_Handlers (gnat_node
)))
3445 expand_end_bindings (getdecls (), kept_level_p (), 0);
3446 poplevel (kept_level_p (), 1, 0);
3451 case N_Exception_Handler
:
3452 if (! Zero_Cost_Handling (gnat_node
))
3454 /* Unless this is "Others" or the special "Non-Ada" exception
3455 for Ada, make an "if" statement to select the proper
3456 exceptions. For "Others", exclude exceptions where
3457 Handled_By_Others is nonzero unless the All_Others flag is set.
3458 For "Non-ada", accept an exception if "Lang" is 'V'. */
3459 tree gnu_choice
= integer_zero_node
;
3461 for (gnat_temp
= First (Exception_Choices (gnat_node
));
3462 gnat_temp
; gnat_temp
= Next (gnat_temp
))
3466 if (Nkind (gnat_temp
) == N_Others_Choice
)
3468 if (All_Others (gnat_temp
))
3469 this_choice
= integer_one_node
;
3473 (EQ_EXPR
, integer_type_node
,
3478 (INDIRECT_REF
, NULL_TREE
,
3479 TREE_VALUE (gnu_except_ptr_stack
)),
3480 get_identifier ("not_handled_by_others"), NULL_TREE
)),
3484 else if (Nkind (gnat_temp
) == N_Identifier
3485 || Nkind (gnat_temp
) == N_Expanded_Name
)
3487 /* ??? Note that we have to use gnat_to_gnu_entity here
3488 since the type of the exception will be wrong in the
3489 VMS case and that's exactly what this test is for. */
3491 = gnat_to_gnu_entity (Entity (gnat_temp
), NULL_TREE
, 0);
3493 /* If this was a VMS exception, check import_code
3494 against the value of the exception. */
3495 if (TREE_CODE (TREE_TYPE (gnu_expr
)) == INTEGER_TYPE
)
3498 (EQ_EXPR
, integer_type_node
,
3501 (INDIRECT_REF
, NULL_TREE
,
3502 TREE_VALUE (gnu_except_ptr_stack
)),
3503 get_identifier ("import_code"), NULL_TREE
),
3508 (EQ_EXPR
, integer_type_node
,
3509 TREE_VALUE (gnu_except_ptr_stack
),
3511 (TREE_TYPE (TREE_VALUE (gnu_except_ptr_stack
)),
3512 build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
)));
3514 /* If this is the distinguished exception "Non_Ada_Error"
3515 (and we are in VMS mode), also allow a non-Ada
3516 exception (a VMS condition) to match. */
3517 if (Is_Non_Ada_Error (Entity (gnat_temp
)))
3520 = build_component_ref
3522 (INDIRECT_REF
, NULL_TREE
,
3523 TREE_VALUE (gnu_except_ptr_stack
)),
3524 get_identifier ("lang"), NULL_TREE
);
3528 (TRUTH_ORIF_EXPR
, integer_type_node
,
3530 (EQ_EXPR
, integer_type_node
, gnu_comp
,
3531 convert (TREE_TYPE (gnu_comp
),
3532 build_int_2 ('V', 0))),
3539 gnu_choice
= build_binary_op (TRUTH_ORIF_EXPR
, integer_type_node
,
3540 gnu_choice
, this_choice
);
3543 set_lineno (gnat_node
, 1);
3545 expand_start_cond (gnu_choice
, 0);
3548 for (gnat_temp
= First (Statements (gnat_node
));
3549 gnat_temp
; gnat_temp
= Next (gnat_temp
))
3550 gnat_to_code (gnat_temp
);
3552 /* At the end of the handler, exit the block. We made this block
3553 in N_Handled_Sequence_Of_Statements. */
3554 expand_exit_something ();
3556 if (! Zero_Cost_Handling (gnat_node
))
3561 /*******************************/
3562 /* Chapter 12: Generic Units: */
3563 /*******************************/
3565 case N_Generic_Function_Renaming_Declaration
:
3566 case N_Generic_Package_Renaming_Declaration
:
3567 case N_Generic_Procedure_Renaming_Declaration
:
3568 case N_Generic_Package_Declaration
:
3569 case N_Generic_Subprogram_Declaration
:
3570 case N_Package_Instantiation
:
3571 case N_Procedure_Instantiation
:
3572 case N_Function_Instantiation
:
3573 /* These nodes can appear on a declaration list but there is nothing to
3574 to be done with them. */
3578 /***************************************************/
3579 /* Chapter 13: Representation Clauses and */
3580 /* Implementation-Dependent Features: */
3581 /***************************************************/
3583 case N_Attribute_Definition_Clause
:
3585 /* The only one we need deal with is for 'Address. For the others, SEM
3586 puts the information elsewhere. We need only deal with 'Address
3587 if the object has a Freeze_Node (which it never will currently). */
3588 if (Get_Attribute_Id (Chars (gnat_node
)) != Attr_Address
3589 || No (Freeze_Node (Entity (Name (gnat_node
)))))
3592 /* Get the value to use as the address and save it as the
3593 equivalent for GNAT_TEMP. When the object is frozen,
3594 gnat_to_gnu_entity will do the right thing. */
3595 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
3596 save_gnu_tree (Entity (Name (gnat_node
)), gnu_expr
, 1);
3599 case N_Enumeration_Representation_Clause
:
3600 case N_Record_Representation_Clause
:
3602 /* We do nothing with these. SEM puts the information elsewhere. */
3605 case N_Code_Statement
:
3606 if (! type_annotate_only
)
3608 tree gnu_template
= gnat_to_gnu (Asm_Template (gnat_node
));
3609 tree gnu_input_list
= 0, gnu_output_list
= 0, gnu_orig_out_list
= 0;
3610 tree gnu_clobber_list
= 0;
3613 /* First process inputs, then outputs, then clobbers. */
3614 Setup_Asm_Inputs (gnat_node
);
3615 while (Present (gnat_temp
= Asm_Input_Value ()))
3617 tree gnu_value
= gnat_to_gnu (gnat_temp
);
3618 tree gnu_constr
= build_tree_list (NULL_TREE
, gnat_to_gnu
3619 (Asm_Input_Constraint ()));
3622 = tree_cons (gnu_constr
, gnu_value
, gnu_input_list
);
3626 Setup_Asm_Outputs (gnat_node
);
3627 while (Present (gnat_temp
= Asm_Output_Variable ()))
3629 tree gnu_value
= gnat_to_gnu (gnat_temp
);
3630 tree gnu_constr
= build_tree_list (NULL_TREE
, gnat_to_gnu
3631 (Asm_Output_Constraint ()));
3634 = tree_cons (gnu_constr
, gnu_value
, gnu_orig_out_list
);
3636 = tree_cons (gnu_constr
, gnu_value
, gnu_output_list
);
3640 Clobber_Setup (gnat_node
);
3641 while ((clobber
= Clobber_Get_Next ()) != 0)
3643 = tree_cons (NULL_TREE
,
3644 build_string (strlen (clobber
) + 1, clobber
),
3647 expand_asm_operands (gnu_template
, nreverse (gnu_output_list
),
3648 nreverse (gnu_input_list
), gnu_clobber_list
,
3649 Is_Asm_Volatile (gnat_node
),
3650 input_filename
, lineno
);
3652 /* Copy all the intermediate outputs into the specified outputs. */
3653 for (; gnu_output_list
;
3654 (gnu_output_list
= TREE_CHAIN (gnu_output_list
),
3655 gnu_orig_out_list
= TREE_CHAIN (gnu_orig_out_list
)))
3656 if (TREE_VALUE (gnu_orig_out_list
) != TREE_VALUE (gnu_output_list
))
3659 (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
3660 TREE_VALUE (gnu_orig_out_list
),
3661 TREE_VALUE (gnu_output_list
)));
3667 /***************************************************/
3669 /***************************************************/
3671 case N_Freeze_Entity
:
3672 process_freeze_entity (gnat_node
);
3673 process_decls (Actions (gnat_node
), Empty
, Empty
, 1, 1);
3676 case N_Itype_Reference
:
3677 if (! present_gnu_tree (Itype (gnat_node
)))
3678 process_type (Itype (gnat_node
));
3681 case N_Free_Statement
:
3682 if (! type_annotate_only
)
3684 tree gnu_ptr
= gnat_to_gnu (Expression (gnat_node
));
3689 /* If this is an unconstrained array, we know the object must
3690 have been allocated with the template in front of the object.
3691 So pass the template address, but get the total size. Do this
3692 by converting to a thin pointer. */
3693 if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr
)))
3695 = convert (build_pointer_type
3696 (TYPE_OBJECT_RECORD_TYPE
3697 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr
)))),
3700 gnu_obj_type
= TREE_TYPE (TREE_TYPE (gnu_ptr
));
3701 gnu_obj_size
= TYPE_SIZE_UNIT (gnu_obj_type
);
3702 align
= TYPE_ALIGN (gnu_obj_type
);
3704 if (TREE_CODE (gnu_obj_type
) == RECORD_TYPE
3705 && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type
))
3707 tree gnu_char_ptr_type
= build_pointer_type (char_type_node
);
3708 tree gnu_pos
= byte_position (TYPE_FIELDS (gnu_obj_type
));
3709 tree gnu_byte_offset
3710 = convert (gnu_char_ptr_type
,
3711 size_diffop (size_zero_node
, gnu_pos
));
3713 gnu_ptr
= convert (gnu_char_ptr_type
, gnu_ptr
);
3714 gnu_ptr
= build_binary_op (MINUS_EXPR
, gnu_char_ptr_type
,
3715 gnu_ptr
, gnu_byte_offset
);
3718 set_lineno (gnat_node
, 1);
3720 (build_call_alloc_dealloc (gnu_ptr
, gnu_obj_size
, align
,
3721 Procedure_To_Call (gnat_node
),
3722 Storage_Pool (gnat_node
)));
3726 case N_Raise_Constraint_Error
:
3727 case N_Raise_Program_Error
:
3728 case N_Raise_Storage_Error
:
3730 if (type_annotate_only
)
3733 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
3736 (Nkind (gnat_node
) == N_Raise_Constraint_Error
3737 ? raise_constraint_error_decl
3738 : Nkind (gnat_node
) == N_Raise_Program_Error
3739 ? raise_program_error_decl
: raise_storage_error_decl
);
3741 /* If the type is VOID, this is a statement, so we need to
3742 generate the code for the call. Handle a Condition, if there
3744 if (TREE_CODE (gnu_result_type
) == VOID_TYPE
)
3746 set_lineno (gnat_node
, 1);
3748 if (Present (Condition (gnat_node
)))
3749 expand_start_cond (gnat_to_gnu (Condition (gnat_node
)), 0);
3751 expand_expr_stmt (gnu_result
);
3752 if (Present (Condition (gnat_node
)))
3754 gnu_result
= error_mark_node
;
3757 gnu_result
= build1 (NULL_EXPR
, gnu_result_type
, gnu_result
);
3760 /* Nothing to do, since front end does all validation using the
3761 values that Gigi back-annotates. */
3762 case N_Validate_Unchecked_Conversion
:
3765 case N_Raise_Statement
:
3766 case N_Function_Specification
:
3767 case N_Procedure_Specification
:
3769 case N_Component_Association
:
3772 if (! type_annotate_only
)
3776 /* If the result is a constant that overflows, raise constraint error. */
3777 if (TREE_CODE (gnu_result
) == INTEGER_CST
3778 && TREE_CONSTANT_OVERFLOW (gnu_result
))
3780 post_error ("Constraint_Error will be raised at run-time?", gnat_node
);
3783 = build1 (NULL_EXPR
, gnu_result_type
,
3784 build_call_raise (raise_constraint_error_decl
));
3787 /* If our result has side-effects and is of an unconstrained type,
3788 make a SAVE_EXPR so that we can be sure it will only be referenced
3789 once. Note we must do this before any conversions. */
3790 if (TREE_SIDE_EFFECTS (gnu_result
)
3791 && (TREE_CODE (gnu_result_type
) == UNCONSTRAINED_ARRAY_TYPE
3792 || (TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
3793 && contains_placeholder_p (TYPE_SIZE (gnu_result_type
)))))
3794 gnu_result
= gnat_stabilize_reference (gnu_result
, 0);
3796 /* Now convert the result to the proper type. If the type is void or if
3797 we have no result, return error_mark_node to show we have no result.
3798 If the type of the result is correct or if we have a label (which doesn't
3799 have any well-defined type), return our result. Also don't do the
3800 conversion if the "desired" type involves a PLACEHOLDER_EXPR in its size
3801 since those are the cases where the front end may have the type wrong due
3802 to "instantiating" the unconstrained record with discriminant values
3803 or if this is a FIELD_DECL. If this is the Name of an assignment
3804 statement or a parameter of a procedure call, return what we have since
3805 the RHS has to be converted to our type there in that case, unless
3806 GNU_RESULT_TYPE has a simpler size. Similarly, if the two types are
3807 record types with the same name, the expression type has integral mode,
3808 and GNU_RESULT_TYPE BLKmode, don't convert. This will be the case when
3809 we are converting from a packable type to its actual type and we need
3810 those conversions to be NOPs in order for assignments into these types to
3811 work properly if the inner object is a bitfield and hence can't have
3812 its address taken. Finally, don't convert integral types that are the
3813 operand of an unchecked conversion since we need to ignore those
3814 conversions (for 'Valid). Otherwise, convert the result to the proper
3817 if (Present (Parent (gnat_node
))
3818 && ((Nkind (Parent (gnat_node
)) == N_Assignment_Statement
3819 && Name (Parent (gnat_node
)) == gnat_node
)
3820 || (Nkind (Parent (gnat_node
)) == N_Procedure_Call_Statement
3821 && Name (Parent (gnat_node
)) != gnat_node
)
3822 || (Nkind (Parent (gnat_node
)) == N_Unchecked_Type_Conversion
3823 && ! AGGREGATE_TYPE_P (gnu_result_type
)
3824 && ! AGGREGATE_TYPE_P (TREE_TYPE (gnu_result
)))
3825 || Nkind (Parent (gnat_node
)) == N_Parameter_Association
)
3826 && ! (TYPE_SIZE (gnu_result_type
) != 0
3827 && TYPE_SIZE (TREE_TYPE (gnu_result
)) != 0
3828 && (AGGREGATE_TYPE_P (gnu_result_type
)
3829 == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result
)))
3830 && ((TREE_CODE (TYPE_SIZE (gnu_result_type
)) == INTEGER_CST
3831 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result
)))
3833 || (TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
3834 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result
)))
3836 && ! (contains_placeholder_p (TYPE_SIZE (gnu_result_type
)))
3837 && (contains_placeholder_p
3838 (TYPE_SIZE (TREE_TYPE (gnu_result
))))))
3839 && ! (TREE_CODE (gnu_result_type
) == RECORD_TYPE
3840 && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_result_type
))))
3842 /* In this case remove padding only if the inner object is of
3843 self-referential size: in that case it must be an object of
3844 unconstrained type with a default discriminant. In other cases,
3845 we want to avoid copying too much data. */
3846 if (TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
3847 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result
))
3848 && contains_placeholder_p (TYPE_SIZE
3849 (TREE_TYPE (TYPE_FIELDS
3850 (TREE_TYPE (gnu_result
))))))
3851 gnu_result
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result
))),
3855 else if (TREE_CODE (gnu_result
) == LABEL_DECL
3856 || TREE_CODE (gnu_result
) == FIELD_DECL
3857 || TREE_CODE (gnu_result
) == ERROR_MARK
3858 || (TYPE_SIZE (gnu_result_type
) != 0
3859 && TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
3860 && TREE_CODE (gnu_result
) != INDIRECT_REF
3861 && contains_placeholder_p (TYPE_SIZE (gnu_result_type
)))
3862 || ((TYPE_NAME (gnu_result_type
)
3863 == TYPE_NAME (TREE_TYPE (gnu_result
)))
3864 && TREE_CODE (gnu_result_type
) == RECORD_TYPE
3865 && TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
3866 && TYPE_MODE (gnu_result_type
) == BLKmode
3867 && (GET_MODE_CLASS (TYPE_MODE (TREE_TYPE (gnu_result
)))
3870 /* Remove any padding record, but do nothing more in this case. */
3871 if (TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
3872 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result
)))
3873 gnu_result
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result
))),
3877 else if (gnu_result
== error_mark_node
3878 || gnu_result_type
== void_type_node
)
3879 gnu_result
= error_mark_node
;
3880 else if (gnu_result_type
!= TREE_TYPE (gnu_result
))
3881 gnu_result
= convert (gnu_result_type
, gnu_result
);
3883 /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on GNU_RESULT. */
3884 while ((TREE_CODE (gnu_result
) == NOP_EXPR
3885 || TREE_CODE (gnu_result
) == NON_LVALUE_EXPR
)
3886 && TREE_TYPE (TREE_OPERAND (gnu_result
, 0)) == TREE_TYPE (gnu_result
))
3887 gnu_result
= TREE_OPERAND (gnu_result
, 0);
3892 /* Force references to each of the entities in packages GNAT_NODE with's
3893 so that the debugging information for all of them are identical
3894 in all clients. Operate recursively on anything it with's, but check
3895 that we aren't elaborating something more than once. */
3897 /* The reason for this routine's existence is two-fold.
3898 First, with some debugging formats, notably MDEBUG on SGI
3899 IRIX, the linker will remove duplicate debugging information if two
3900 clients have identical debugguing information. With the normal scheme
3901 of elaboration, this does not usually occur, since entities in with'ed
3902 packages are elaborated on demand, and if clients have different usage
3903 patterns, the normal case, then the order and selection of entities
3904 will differ. In most cases however, it seems that linkers do not know
3905 how to eliminate duplicate debugging information, even if it is
3906 identical, so the use of this routine would increase the total amount
3907 of debugging information in the final executable.
3909 Second, this routine is called in type_annotate mode, to compute DDA
3910 information for types in withed units, for ASIS use */
3913 elaborate_all_entities (gnat_node
)
3916 Entity_Id gnat_with_clause
, gnat_entity
;
3918 save_gnu_tree (gnat_node
, integer_zero_node
, 1);
3920 /* Save entities in all context units. A body may have an implicit_with
3921 on its own spec, if the context includes a child unit, so don't save
3924 for (gnat_with_clause
= First (Context_Items (gnat_node
));
3925 Present (gnat_with_clause
);
3926 gnat_with_clause
= Next (gnat_with_clause
))
3927 if (Nkind (gnat_with_clause
) == N_With_Clause
3928 && ! present_gnu_tree (Library_Unit (gnat_with_clause
))
3929 && Library_Unit (gnat_with_clause
) != Library_Unit (Cunit (Main_Unit
)))
3931 elaborate_all_entities (Library_Unit (gnat_with_clause
));
3933 if (Ekind (Entity (Name (gnat_with_clause
))) == E_Package
)
3934 for (gnat_entity
= First_Entity (Entity (Name (gnat_with_clause
)));
3935 Present (gnat_entity
);
3936 gnat_entity
= Next_Entity (gnat_entity
))
3937 if (Is_Public (gnat_entity
)
3938 && Convention (gnat_entity
) != Convention_Intrinsic
3939 && Ekind (gnat_entity
) != E_Package
3940 && Ekind (gnat_entity
) != E_Package_Body
3941 && Ekind (gnat_entity
) != E_Operator
3942 && ! (IN (Ekind (gnat_entity
), Type_Kind
)
3943 && ! Is_Frozen (gnat_entity
))
3944 && ! ((Ekind (gnat_entity
) == E_Procedure
3945 || Ekind (gnat_entity
) == E_Function
)
3946 && Is_Intrinsic_Subprogram (gnat_entity
))
3947 && ! IN (Ekind (gnat_entity
), Named_Kind
)
3948 && ! IN (Ekind (gnat_entity
), Generic_Unit_Kind
))
3949 gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 0);
3952 if (Nkind (Unit (gnat_node
)) == N_Package_Body
&& type_annotate_only
)
3953 elaborate_all_entities (Library_Unit (gnat_node
));
3956 /* Do the processing of N_Freeze_Entity, GNAT_NODE. */
3959 process_freeze_entity (gnat_node
)
3962 Entity_Id gnat_entity
= Entity (gnat_node
);
3966 = (Nkind (Declaration_Node (gnat_entity
)) == N_Object_Declaration
3967 && present_gnu_tree (Declaration_Node (gnat_entity
)))
3968 ? get_gnu_tree (Declaration_Node (gnat_entity
)) : NULL_TREE
;
3970 /* If this is a package, need to generate code for the package. */
3971 if (Ekind (gnat_entity
) == E_Package
)
3974 (Parent (Corresponding_Body
3975 (Parent (Declaration_Node (gnat_entity
)))));
3979 /* Check for old definition after the above call. This Freeze_Node
3980 might be for one its Itypes. */
3982 = present_gnu_tree (gnat_entity
) ? get_gnu_tree (gnat_entity
) : 0;
3984 /* If this entity has an Address representation clause, GNU_OLD is the
3985 address, so discard it here. */
3986 if (Present (Address_Clause (gnat_entity
)))
3989 /* Don't do anything for class-wide types they are always
3990 transformed into their root type. */
3991 if (Ekind (gnat_entity
) == E_Class_Wide_Type
3992 || (Ekind (gnat_entity
) == E_Class_Wide_Subtype
3993 && Present (Equivalent_Type (gnat_entity
))))
3996 /* If we have a non-dummy type old tree, we have nothing to do. Unless
3997 this is the public view of a private type whose full view was not
3998 delayed, this node was never delayed as it should have been.
3999 Also allow this to happen for concurrent types since we may have
4000 frozen both the Corresponding_Record_Type and this type. */
4002 && ! (TREE_CODE (gnu_old
) == TYPE_DECL
4003 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old
))))
4005 if (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
4006 && Present (Full_View (gnat_entity
))
4007 && No (Freeze_Node (Full_View (gnat_entity
))))
4009 else if (Is_Concurrent_Type (gnat_entity
))
4015 /* Reset the saved tree, if any, and elaborate the object or type for real.
4016 If there is a full declaration, elaborate it and copy the type to
4017 GNAT_ENTITY. Likewise if this is the record subtype corresponding to
4018 a class wide type or subtype. */
4021 save_gnu_tree (gnat_entity
, NULL_TREE
, 0);
4022 if (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
4023 && Present (Full_View (gnat_entity
))
4024 && present_gnu_tree (Full_View (gnat_entity
)))
4025 save_gnu_tree (Full_View (gnat_entity
), NULL_TREE
, 0);
4026 if (Present (Class_Wide_Type (gnat_entity
))
4027 && Class_Wide_Type (gnat_entity
) != gnat_entity
)
4028 save_gnu_tree (Class_Wide_Type (gnat_entity
), NULL_TREE
, 0);
4031 if (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
4032 && Present (Full_View (gnat_entity
)))
4034 gnu_new
= gnat_to_gnu_entity (Full_View (gnat_entity
), NULL_TREE
, 1);
4036 /* The above call may have defined this entity (the simplest example
4037 of this is when we have a private enumeral type since the bounds
4038 will have the public view. */
4039 if (! present_gnu_tree (gnat_entity
))
4040 save_gnu_tree (gnat_entity
, gnu_new
, 0);
4041 if (Present (Class_Wide_Type (gnat_entity
))
4042 && Class_Wide_Type (gnat_entity
) != gnat_entity
)
4043 save_gnu_tree (Class_Wide_Type (gnat_entity
), gnu_new
, 0);
4046 gnu_new
= gnat_to_gnu_entity (gnat_entity
, gnu_init
, 1);
4048 /* If we've made any pointers to the old version of this type, we
4049 have to update them. Also copy the name of the old object to
4054 DECL_NAME (gnu_new
) = DECL_NAME (gnu_old
);
4055 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old
)),
4056 TREE_TYPE (gnu_new
));
4060 /* Process the list of inlined subprograms of GNAT_NODE, which is an
4061 N_Compilation_Unit. */
4064 process_inlined_subprograms (gnat_node
)
4067 Entity_Id gnat_entity
;
4070 /* If we can inline, generate RTL for all the inlined subprograms.
4071 Define the entity first so we set DECL_EXTERNAL. */
4072 if (optimize
> 0 && ! flag_no_inline
)
4073 for (gnat_entity
= First_Inlined_Subprogram (gnat_node
);
4074 Present (gnat_entity
);
4075 gnat_entity
= Next_Inlined_Subprogram (gnat_entity
))
4077 gnat_body
= Parent (Declaration_Node (gnat_entity
));
4079 if (Nkind (gnat_body
) != N_Subprogram_Body
)
4081 /* ??? This really should always be Present. */
4082 if (No (Corresponding_Body (gnat_body
)))
4086 = Parent (Declaration_Node (Corresponding_Body (gnat_body
)));
4089 if (Present (gnat_body
))
4091 gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 0);
4092 gnat_to_code (gnat_body
);
4097 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
4098 We make two passes, one to elaborate anything other than bodies (but
4099 we declare a function if there was no spec). The second pass
4100 elaborates the bodies.
4102 GNAT_END_LIST gives the element in the list past the end. Normally,
4103 this is Empty, but can be First_Real_Statement for a
4104 Handled_Sequence_Of_Statements.
4106 We make a complete pass through both lists if PASS1P is true, then make
4107 the second pass over both lists if PASS2P is true. The lists usually
4108 correspond to the public and private parts of a package. */
4111 process_decls (gnat_decls
, gnat_decls2
, gnat_end_list
, pass1p
, pass2p
)
4112 List_Id gnat_decls
, gnat_decls2
;
4113 Node_Id gnat_end_list
;
4116 List_Id gnat_decl_array
[2];
4120 gnat_decl_array
[0] = gnat_decls
, gnat_decl_array
[1] = gnat_decls2
;
4123 for (i
= 0; i
<= 1; i
++)
4124 if (Present (gnat_decl_array
[i
]))
4125 for (gnat_decl
= First (gnat_decl_array
[i
]);
4126 gnat_decl
!= gnat_end_list
; gnat_decl
= Next (gnat_decl
))
4128 set_lineno (gnat_decl
, 0);
4130 /* For package specs, we recurse inside the declarations,
4131 thus taking the two pass approach inside the boundary. */
4132 if (Nkind (gnat_decl
) == N_Package_Declaration
4133 && (Nkind (Specification (gnat_decl
)
4134 == N_Package_Specification
)))
4135 process_decls (Visible_Declarations (Specification (gnat_decl
)),
4136 Private_Declarations (Specification (gnat_decl
)),
4139 /* Similarly for any declarations in the actions of a
4141 else if (Nkind (gnat_decl
) == N_Freeze_Entity
)
4143 process_freeze_entity (gnat_decl
);
4144 process_decls (Actions (gnat_decl
), Empty
, Empty
, 1, 0);
4147 /* Package bodies with freeze nodes get their elaboration deferred
4148 until the freeze node, but the code must be placed in the right
4149 place, so record the code position now. */
4150 else if (Nkind (gnat_decl
) == N_Package_Body
4151 && Present (Freeze_Node (Corresponding_Spec (gnat_decl
))))
4152 record_code_position (gnat_decl
);
4154 else if (Nkind (gnat_decl
) == N_Package_Body_Stub
4155 && Present (Library_Unit (gnat_decl
))
4156 && Present (Freeze_Node
4159 (Library_Unit (gnat_decl
)))))))
4160 record_code_position
4161 (Proper_Body (Unit (Library_Unit (gnat_decl
))));
4163 /* We defer most subprogram bodies to the second pass.
4164 However, Init_Proc subprograms cannot be defered, but luckily
4165 don't need to be. */
4166 else if ((Nkind (gnat_decl
) == N_Subprogram_Body
4167 && (Chars (Defining_Entity (gnat_decl
))
4168 != Name_uInit_Proc
)))
4170 if (Acts_As_Spec (gnat_decl
))
4172 Node_Id gnat_subprog_id
= Defining_Entity (gnat_decl
);
4174 if (Ekind (gnat_subprog_id
) != E_Generic_Procedure
4175 && Ekind (gnat_subprog_id
) != E_Generic_Function
)
4176 gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
, 1);
4179 /* For bodies and stubs that act as their own specs, the entity
4180 itself must be elaborated in the first pass, because it may
4181 be used in other declarations. */
4182 else if (Nkind (gnat_decl
) == N_Subprogram_Body_Stub
)
4184 Node_Id gnat_subprog_id
=
4185 Defining_Entity (Specification (gnat_decl
));
4187 if (Ekind (gnat_subprog_id
) != E_Subprogram_Body
4188 && Ekind (gnat_subprog_id
) != E_Generic_Procedure
4189 && Ekind (gnat_subprog_id
) != E_Generic_Function
)
4190 gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
, 1);
4193 /* Concurrent stubs stand for the corresponding subprogram bodies,
4194 which are deferred like other bodies. */
4195 else if (Nkind (gnat_decl
) == N_Task_Body_Stub
4196 || Nkind (gnat_decl
) == N_Protected_Body_Stub
)
4200 gnat_to_code (gnat_decl
);
4203 /* Here we elaborate everything we deferred above except for package bodies,
4204 which are elaborated at their freeze nodes. Note that we must also
4205 go inside things (package specs and freeze nodes) the first pass did. */
4207 for (i
= 0; i
<= 1; i
++)
4208 if (Present (gnat_decl_array
[i
]))
4209 for (gnat_decl
= First (gnat_decl_array
[i
]);
4210 gnat_decl
!= gnat_end_list
; gnat_decl
= Next (gnat_decl
))
4212 if ((Nkind (gnat_decl
) == N_Subprogram_Body
4213 && (Chars (Defining_Entity (gnat_decl
))
4214 != Name_uInit_Proc
))
4215 || Nkind (gnat_decl
) == N_Subprogram_Body_Stub
4216 || Nkind (gnat_decl
) == N_Task_Body_Stub
4217 || Nkind (gnat_decl
) == N_Protected_Body_Stub
)
4218 gnat_to_code (gnat_decl
);
4220 else if (Nkind (gnat_decl
) == N_Package_Declaration
4221 && (Nkind (Specification (gnat_decl
)
4222 == N_Package_Specification
)))
4223 process_decls (Visible_Declarations (Specification (gnat_decl
)),
4224 Private_Declarations (Specification (gnat_decl
)),
4227 else if (Nkind (gnat_decl
) == N_Freeze_Entity
)
4228 process_decls (Actions (gnat_decl
), Empty
, Empty
, 0, 1);
4232 /* Emits an access check. GNU_EXPR is the expression that needs to be
4233 checked against the NULL pointer. */
4236 emit_access_check (gnu_expr
)
4239 tree gnu_type
= TREE_TYPE (gnu_expr
);
4241 /* This only makes sense if GNU_TYPE is a pointer of some sort. */
4242 if (! POINTER_TYPE_P (gnu_type
) && ! TYPE_FAT_POINTER_P (gnu_type
))
4245 /* Checked expressions must be evaluated only once. */
4246 gnu_expr
= make_save_expr (gnu_expr
);
4248 return emit_check (build_binary_op (EQ_EXPR
, integer_type_node
,
4250 convert (TREE_TYPE (gnu_expr
),
4251 integer_zero_node
)),
4255 /* Emits a discriminant check. GNU_EXPR is the expression to be checked and
4256 GNAT_NODE a N_Selected_Component node. */
4259 emit_discriminant_check (gnu_expr
, gnat_node
)
4264 = Original_Record_Component (Entity (Selector_Name (gnat_node
)));
4265 Entity_Id gnat_discr_fct
= Discriminant_Checking_Func (orig_comp
);
4267 Entity_Id gnat_discr
;
4268 tree gnu_actual_list
= NULL_TREE
;
4270 Entity_Id gnat_pref_type
;
4273 if (Is_Tagged_Type (Scope (orig_comp
)))
4274 gnat_pref_type
= Scope (orig_comp
);
4276 gnat_pref_type
= Etype (Prefix (gnat_node
));
4278 if (! Present (gnat_discr_fct
))
4281 gnu_discr_fct
= gnat_to_gnu (gnat_discr_fct
);
4283 /* Checked expressions must be evaluated only once. */
4284 gnu_expr
= make_save_expr (gnu_expr
);
4286 /* Create the list of the actual parameters as GCC expects it.
4287 This list is the list of the discriminant fields of the
4288 record expression to be discriminant checked. For documentation
4289 on what is the GCC format for this list see under the
4290 N_Function_Call case */
4292 while (IN (Ekind (gnat_pref_type
), Incomplete_Or_Private_Kind
)
4293 || IN (Ekind (gnat_pref_type
), Access_Kind
))
4295 if (IN (Ekind (gnat_pref_type
), Incomplete_Or_Private_Kind
))
4296 gnat_pref_type
= Underlying_Type (gnat_pref_type
);
4297 else if (IN (Ekind (gnat_pref_type
), Access_Kind
))
4298 gnat_pref_type
= Designated_Type (gnat_pref_type
);
4302 = TREE_TYPE (gnat_to_gnu_entity (gnat_pref_type
, NULL_TREE
, 0));
4304 for (gnat_discr
= First_Discriminant (gnat_pref_type
);
4305 Present (gnat_discr
); gnat_discr
= Next_Discriminant (gnat_discr
))
4307 Entity_Id gnat_real_discr
4308 = ((Present (Corresponding_Discriminant (gnat_discr
))
4309 && Present (Parent_Subtype (gnat_pref_type
)))
4310 ? Corresponding_Discriminant (gnat_discr
) : gnat_discr
);
4311 tree gnu_discr
= gnat_to_gnu_entity (gnat_real_discr
, NULL_TREE
, 0);
4314 = chainon (gnu_actual_list
,
4315 build_tree_list (NULL_TREE
,
4317 (convert (gnu_pref_type
, gnu_expr
),
4318 NULL_TREE
, gnu_discr
)));
4321 gnu_cond
= build (CALL_EXPR
,
4322 TREE_TYPE (TREE_TYPE (gnu_discr_fct
)),
4323 build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_discr_fct
),
4326 TREE_SIDE_EFFECTS (gnu_cond
) = 1;
4330 (INDIRECT_REF
, NULL_TREE
,
4331 emit_check (gnu_cond
,
4332 build_unary_op (ADDR_EXPR
,
4333 build_reference_type (TREE_TYPE (gnu_expr
)),
4337 /* Emit code for a range check. GNU_EXPR is the expression to be checked,
4338 GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
4339 which we have to check. */
4342 emit_range_check (gnu_expr
, gnat_range_type
)
4344 Entity_Id gnat_range_type
;
4346 tree gnu_range_type
= get_unpadded_type (gnat_range_type
);
4347 tree gnu_low
= TYPE_MIN_VALUE (gnu_range_type
);
4348 tree gnu_high
= TYPE_MAX_VALUE (gnu_range_type
);
4349 tree gnu_compare_type
= get_base_type (TREE_TYPE (gnu_expr
));
4351 /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE,
4352 we can't do anything since we might be truncating the bounds. No
4353 check is needed in this case. */
4354 if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr
))
4355 && (TYPE_PRECISION (gnu_compare_type
)
4356 < TYPE_PRECISION (get_base_type (gnu_range_type
))))
4359 /* Checked expressions must be evaluated only once. */
4360 gnu_expr
= make_save_expr (gnu_expr
);
4362 /* There's no good type to use here, so we might as well use
4363 integer_type_node. Note that the form of the check is
4364 (not (expr >= lo)) or (not (expr >= hi))
4365 the reason for this slightly convoluted form is that NaN's
4366 are not considered to be in range in the float case. */
4368 (build_binary_op (TRUTH_ORIF_EXPR
, integer_type_node
,
4370 (build_binary_op (GE_EXPR
, integer_type_node
,
4371 convert (gnu_compare_type
, gnu_expr
),
4372 convert (gnu_compare_type
, gnu_low
))),
4374 (build_binary_op (LE_EXPR
, integer_type_node
,
4375 convert (gnu_compare_type
, gnu_expr
),
4376 convert (gnu_compare_type
,
4381 /* Emit code for an index check. GNU_ARRAY_OBJECT is the array object
4382 which we are about to index, GNU_EXPR is the index expression to be
4383 checked, GNU_LOW and GNU_HIGH are the lower and upper bounds
4384 against which GNU_EXPR has to be checked. Note that for index
4385 checking we cannot use the emit_range_check function (although very
4386 similar code needs to be generated in both cases) since for index
4387 checking the array type against which we are checking the indeces
4388 may be unconstrained and consequently we need to retrieve the
4389 actual index bounds from the array object itself
4390 (GNU_ARRAY_OBJECT). The place where we need to do that is in
4391 subprograms having unconstrained array formal parameters */
4394 emit_index_check (gnu_array_object
, gnu_expr
, gnu_low
, gnu_high
)
4395 tree gnu_array_object
;
4400 tree gnu_expr_check
;
4402 /* Checked expressions must be evaluated only once. */
4403 gnu_expr
= make_save_expr (gnu_expr
);
4405 /* Must do this computation in the base type in case the expression's
4406 type is an unsigned subtypes. */
4407 gnu_expr_check
= convert (get_base_type (TREE_TYPE (gnu_expr
)), gnu_expr
);
4409 /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by
4410 the object we are handling. */
4411 if (TREE_CODE (gnu_low
) != INTEGER_CST
&& contains_placeholder_p (gnu_low
))
4412 gnu_low
= build (WITH_RECORD_EXPR
, TREE_TYPE (gnu_low
),
4413 gnu_low
, gnu_array_object
);
4415 if (TREE_CODE (gnu_high
) != INTEGER_CST
&& contains_placeholder_p (gnu_high
))
4416 gnu_high
= build (WITH_RECORD_EXPR
, TREE_TYPE (gnu_high
),
4417 gnu_high
, gnu_array_object
);
4419 /* There's no good type to use here, so we might as well use
4420 integer_type_node. */
4422 (build_binary_op (TRUTH_ORIF_EXPR
, integer_type_node
,
4423 build_binary_op (LT_EXPR
, integer_type_node
,
4425 convert (TREE_TYPE (gnu_expr_check
),
4427 build_binary_op (GT_EXPR
, integer_type_node
,
4429 convert (TREE_TYPE (gnu_expr_check
),
4434 /* Given GNU_COND which contains the condition corresponding to an access,
4435 discriminant or range check, of value GNU_EXPR, build a COND_EXPR
4436 that returns GNU_EXPR if GNU_COND is false and raises a
4437 CONSTRAINT_ERROR if GNU_COND is true. */
4440 emit_check (gnu_cond
, gnu_expr
)
4446 gnu_call
= build_call_raise (raise_constraint_error_decl
);
4448 /* Use an outer COMPOUND_EXPR to make sure that GNU_EXPR will
4449 get evaluated in front of the comparison in case it ends
4450 up being a SAVE_EXPR. Put the whole thing inside its own
4451 SAVE_EXPR do the inner SAVE_EXPR doesn't leak out. */
4453 return make_save_expr (build (COMPOUND_EXPR
, TREE_TYPE (gnu_expr
), gnu_expr
,
4454 fold (build (COND_EXPR
, TREE_TYPE (gnu_expr
),
4456 build (COMPOUND_EXPR
,
4457 TREE_TYPE (gnu_expr
),
4458 gnu_call
, gnu_expr
),
4462 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing
4463 overflow checks if OVERFLOW_P is nonzero and range checks if
4464 RANGE_P is nonzero. GNAT_TYPE is known to be an integral type.
4465 If TRUNCATE_P is nonzero, do a float to integer conversion with
4466 truncation; otherwise round. */
4469 convert_with_check (gnat_type
, gnu_expr
, overflow_p
, range_p
, truncate_p
)
4470 Entity_Id gnat_type
;
4476 tree gnu_type
= get_unpadded_type (gnat_type
);
4477 tree gnu_in_type
= TREE_TYPE (gnu_expr
);
4478 tree gnu_in_basetype
= get_base_type (gnu_in_type
);
4479 tree gnu_base_type
= get_base_type (gnu_type
);
4480 tree gnu_ada_base_type
= get_ada_base_type (gnu_type
);
4481 tree gnu_in_lb
= TYPE_MIN_VALUE (gnu_in_basetype
);
4482 tree gnu_in_ub
= TYPE_MAX_VALUE (gnu_in_basetype
);
4483 tree gnu_out_lb
= TYPE_MIN_VALUE (gnu_base_type
);
4484 tree gnu_out_ub
= TYPE_MAX_VALUE (gnu_base_type
);
4485 tree gnu_result
= gnu_expr
;
4487 /* If we are not doing any checks, the output is an integral type, and
4488 the input is not a floating type, just do the conversion. This
4489 shortcut is required to avoid problems with packed array types
4490 and simplifies code in all cases anyway. */
4491 if (! range_p
&& ! overflow_p
&& INTEGRAL_TYPE_P (gnu_base_type
)
4492 && ! FLOAT_TYPE_P (gnu_in_type
))
4493 return convert (gnu_type
, gnu_expr
);
4495 /* First convert the expression to its base type. This
4496 will never generate code, but makes the tests below much simpler.
4497 But don't do this if converting from an integer type to an unconstrained
4498 array type since then we need to get the bounds from the original
4500 if (TREE_CODE (gnu_type
) != UNCONSTRAINED_ARRAY_TYPE
)
4501 gnu_result
= convert (gnu_in_basetype
, gnu_result
);
4503 /* If overflow checks are requested, we need to be sure the result will
4504 fit in the output base type. But don't do this if the input
4505 is integer and the output floating-point. */
4507 && ! (FLOAT_TYPE_P (gnu_base_type
) && INTEGRAL_TYPE_P (gnu_in_basetype
)))
4509 /* Ensure GNU_EXPR only gets evaluated once. */
4510 tree gnu_input
= make_save_expr (gnu_result
);
4511 tree gnu_cond
= integer_zero_node
;
4513 /* Convert the lower bounds to signed types, so we're sure we're
4514 comparing them properly. Likewise, convert the upper bounds
4515 to unsigned types. */
4516 if (INTEGRAL_TYPE_P (gnu_in_basetype
) && TREE_UNSIGNED (gnu_in_basetype
))
4517 gnu_in_lb
= convert (signed_type (gnu_in_basetype
), gnu_in_lb
);
4519 if (INTEGRAL_TYPE_P (gnu_in_basetype
)
4520 && ! TREE_UNSIGNED (gnu_in_basetype
))
4521 gnu_in_ub
= convert (unsigned_type (gnu_in_basetype
), gnu_in_ub
);
4523 if (INTEGRAL_TYPE_P (gnu_base_type
) && TREE_UNSIGNED (gnu_base_type
))
4524 gnu_out_lb
= convert (signed_type (gnu_base_type
), gnu_out_lb
);
4526 if (INTEGRAL_TYPE_P (gnu_base_type
) && ! TREE_UNSIGNED (gnu_base_type
))
4527 gnu_out_ub
= convert (unsigned_type (gnu_base_type
), gnu_out_ub
);
4529 /* Check each bound separately and only if the result bound
4530 is tighter than the bound on the input type. Note that all the
4531 types are base types, so the bounds must be constant. Also,
4532 the comparison is done in the base type of the input, which
4533 always has the proper signedness. First check for input
4534 integer (which means output integer), output float (which means
4535 both float), or mixed, in which case we always compare.
4536 Note that we have to do the comparison which would *fail* in the
4537 case of an error since if it's an FP comparison and one of the
4538 values is a NaN or Inf, the comparison will fail. */
4539 if (INTEGRAL_TYPE_P (gnu_in_basetype
)
4540 ? tree_int_cst_lt (gnu_in_lb
, gnu_out_lb
)
4541 : (FLOAT_TYPE_P (gnu_base_type
)
4542 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_in_lb
),
4543 TREE_REAL_CST (gnu_out_lb
))
4547 (build_binary_op (GE_EXPR
, integer_type_node
,
4548 gnu_input
, convert (gnu_in_basetype
,
4551 if (INTEGRAL_TYPE_P (gnu_in_basetype
)
4552 ? tree_int_cst_lt (gnu_out_ub
, gnu_in_ub
)
4553 : (FLOAT_TYPE_P (gnu_base_type
)
4554 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_out_ub
),
4555 TREE_REAL_CST (gnu_in_lb
))
4558 = build_binary_op (TRUTH_ORIF_EXPR
, integer_type_node
, gnu_cond
,
4560 (build_binary_op (LE_EXPR
, integer_type_node
,
4562 convert (gnu_in_basetype
,
4565 if (! integer_zerop (gnu_cond
))
4566 gnu_result
= emit_check (gnu_cond
, gnu_input
);
4569 /* Now convert to the result base type. If this is a non-truncating
4570 float-to-integer conversion, round. */
4571 if (INTEGRAL_TYPE_P (gnu_ada_base_type
) && FLOAT_TYPE_P (gnu_in_basetype
)
4574 tree gnu_point_5
= build_real (gnu_in_basetype
, dconstp5
);
4575 tree gnu_minus_point_5
= build_real (gnu_in_basetype
, dconstmp5
);
4576 tree gnu_zero
= convert (gnu_in_basetype
, integer_zero_node
);
4577 tree gnu_saved_result
= save_expr (gnu_result
);
4578 tree gnu_comp
= build (GE_EXPR
, integer_type_node
,
4579 gnu_saved_result
, gnu_zero
);
4580 tree gnu_adjust
= build (COND_EXPR
, gnu_in_basetype
, gnu_comp
,
4581 gnu_point_5
, gnu_minus_point_5
);
4584 = build (PLUS_EXPR
, gnu_in_basetype
, gnu_saved_result
, gnu_adjust
);
4587 if (TREE_CODE (gnu_ada_base_type
) == INTEGER_TYPE
4588 && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_ada_base_type
)
4589 && TREE_CODE (gnu_result
) == UNCONSTRAINED_ARRAY_REF
)
4590 gnu_result
= unchecked_convert (gnu_ada_base_type
, gnu_result
);
4592 gnu_result
= convert (gnu_ada_base_type
, gnu_result
);
4594 /* Finally, do the range check if requested. Note that if the
4595 result type is a modular type, the range check is actually
4596 an overflow check. */
4599 || (TREE_CODE (gnu_base_type
) == INTEGER_TYPE
4600 && TYPE_MODULAR_P (gnu_base_type
) && overflow_p
))
4601 gnu_result
= emit_range_check (gnu_result
, gnat_type
);
4603 return convert (gnu_type
, gnu_result
);
4606 /* Return 1 if GNU_EXPR can be directly addressed. This is the case unless
4607 it is an expression involving computation or if it involves a bitfield
4608 reference. This returns the same as mark_addressable in most cases. */
4611 addressable_p (gnu_expr
)
4614 switch (TREE_CODE (gnu_expr
))
4616 case UNCONSTRAINED_ARRAY_REF
:
4627 return (! DECL_BIT_FIELD (TREE_OPERAND (gnu_expr
, 1))
4628 && addressable_p (TREE_OPERAND (gnu_expr
, 0)));
4630 case ARRAY_REF
: case ARRAY_RANGE_REF
:
4631 case REALPART_EXPR
: case IMAGPART_EXPR
:
4633 return addressable_p (TREE_OPERAND (gnu_expr
, 0));
4636 return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr
))
4637 && addressable_p (TREE_OPERAND (gnu_expr
, 0)));
4639 case UNCHECKED_CONVERT_EXPR
:
4641 /* This is addressable if the code in gnat_expand_expr can do
4642 it by either just taking the operand or by pointer punning. */
4643 tree inner
= TREE_OPERAND (gnu_expr
, 0);
4644 tree type
= TREE_TYPE (gnu_expr
);
4645 tree inner_type
= TREE_TYPE (inner
);
4647 return ((TYPE_MODE (type
) == TYPE_MODE (inner_type
)
4648 && (TYPE_ALIGN (type
) <= TYPE_ALIGN (inner_type
)
4649 || TYPE_ALIGN (inner_type
) >= BIGGEST_ALIGNMENT
))
4650 || ((TYPE_MODE (type
) == BLKmode
4651 || TYPE_MODE (inner_type
) == BLKmode
)
4652 && (TYPE_ALIGN (type
) <= TYPE_ALIGN (inner_type
)
4653 || TYPE_ALIGN (inner_type
) >= BIGGEST_ALIGNMENT
4654 || TYPE_ALIGN_OK_P (type
)
4655 || TYPE_ALIGN_OK_P (inner_type
))));
4663 /* Do the processing for the declaration of a GNAT_ENTITY, a type. If
4664 a separate Freeze node exists, delay the bulk of the processing. Otherwise
4665 make a GCC type for GNAT_ENTITY and set up the correspondance. */
4668 process_type (gnat_entity
)
4669 Entity_Id gnat_entity
;
4672 = present_gnu_tree (gnat_entity
) ? get_gnu_tree (gnat_entity
) : 0;
4675 /* If we are to delay elaboration of this type, just do any
4676 elaborations needed for expressions within the declaration and
4677 make a dummy type entry for this node and its Full_View (if
4678 any) in case something points to it. Don't do this if it
4679 has already been done (the only way that can happen is if
4680 the private completion is also delayed). */
4681 if (Present (Freeze_Node (gnat_entity
))
4682 || (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
4683 && Present (Full_View (gnat_entity
))
4684 && Freeze_Node (Full_View (gnat_entity
))
4685 && ! present_gnu_tree (Full_View (gnat_entity
))))
4687 elaborate_entity (gnat_entity
);
4691 tree gnu_decl
= create_type_decl (get_entity_name (gnat_entity
),
4692 make_dummy_type (gnat_entity
),
4695 save_gnu_tree (gnat_entity
, gnu_decl
, 0);
4696 if (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
4697 && Present (Full_View (gnat_entity
)))
4698 save_gnu_tree (Full_View (gnat_entity
), gnu_decl
, 0);
4704 /* If we saved away a dummy type for this node it means that this
4705 made the type that corresponds to the full type of an incomplete
4706 type. Clear that type for now and then update the type in the
4710 if (TREE_CODE (gnu_old
) != TYPE_DECL
4711 || ! TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old
)))
4713 /* If this was a withed access type, this is not an error
4714 and merely indicates we've already elaborated the type
4716 if (Is_Type (gnat_entity
) && From_With_Type (gnat_entity
))
4722 save_gnu_tree (gnat_entity
, NULL_TREE
, 0);
4725 /* Now fully elaborate the type. */
4726 gnu_new
= gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 1);
4727 if (TREE_CODE (gnu_new
) != TYPE_DECL
)
4730 /* If we have an old type and we've made pointers to this type,
4731 update those pointers. */
4733 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old
)),
4734 TREE_TYPE (gnu_new
));
4736 /* If this is a record type corresponding to a task or protected type
4737 that is a completion of an incomplete type, perform a similar update
4739 /* ??? Including protected types here is a guess. */
4741 if (IN (Ekind (gnat_entity
), Record_Kind
)
4742 && Is_Concurrent_Record_Type (gnat_entity
)
4743 && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
)))
4746 = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
));
4748 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
),
4750 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
),
4753 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old
)),
4754 TREE_TYPE (gnu_new
));
4758 /* GNAT_ASSOC is the front of the Component_Associations of an N_Aggregate.
4759 GNU_TYPE is the GCC type of the corresponding record.
4761 Return a CONSTRUCTOR to build the record. */
4764 assoc_to_constructor (gnat_assoc
, gnu_type
)
4768 tree gnu_field
, gnu_list
, gnu_result
;
4770 /* We test for GNU_FIELD being empty in the case where a variant
4771 was the last thing since we don't take things off GNAT_ASSOC in
4772 that case. We check GNAT_ASSOC in case we have a variant, but it
4775 for (gnu_list
= NULL_TREE
; Present (gnat_assoc
);
4776 gnat_assoc
= Next (gnat_assoc
))
4778 Node_Id gnat_field
= First (Choices (gnat_assoc
));
4779 tree gnu_field
= gnat_to_gnu_entity (Entity (gnat_field
), NULL_TREE
, 0);
4780 tree gnu_expr
= gnat_to_gnu (Expression (gnat_assoc
));
4782 /* The expander is supposed to put a single component selector name
4783 in every record component association */
4784 if (Next (gnat_field
))
4787 /* Before assigning a value in an aggregate make sure range checks
4788 are done if required. Then convert to the type of the field. */
4789 if (Do_Range_Check (Expression (gnat_assoc
)))
4790 gnu_expr
= emit_range_check (gnu_expr
, Etype (gnat_field
));
4792 gnu_expr
= convert (TREE_TYPE (gnu_field
), gnu_expr
);
4794 /* Add the field and expression to the list. */
4795 gnu_list
= tree_cons (gnu_field
, gnu_expr
, gnu_list
);
4798 gnu_result
= extract_values (gnu_list
, gnu_type
);
4800 /* Verify every enty in GNU_LIST was used. */
4801 for (gnu_field
= gnu_list
; gnu_field
; gnu_field
= TREE_CHAIN (gnu_field
))
4802 if (! TREE_ADDRESSABLE (gnu_field
))
4808 /* Builds a possibly nested constructor for array aggregates. GNAT_EXPR
4809 is the first element of an array aggregate. It may itself be an
4810 aggregate (an array or record aggregate). GNU_ARRAY_TYPE is the gnu type
4811 corresponding to the array aggregate. GNAT_COMPONENT_TYPE is the type
4812 of the array component. It is needed for range checking. */
4815 pos_to_constructor (gnat_expr
, gnu_array_type
, gnat_component_type
)
4817 tree gnu_array_type
;
4818 Entity_Id gnat_component_type
;
4821 tree gnu_expr_list
= NULL_TREE
;
4823 for ( ; Present (gnat_expr
); gnat_expr
= Next (gnat_expr
))
4825 /* If the expression is itself an array aggregate then first build the
4826 innermost constructor if it is part of our array (multi-dimensional
4829 if (Nkind (gnat_expr
) == N_Aggregate
4830 && TREE_CODE (TREE_TYPE (gnu_array_type
)) == ARRAY_TYPE
4831 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type
)))
4832 gnu_expr
= pos_to_constructor (First (Expressions (gnat_expr
)),
4833 TREE_TYPE (gnu_array_type
),
4834 gnat_component_type
);
4837 gnu_expr
= gnat_to_gnu (gnat_expr
);
4839 /* before assigning the element to the array make sure it is
4841 if (Do_Range_Check (gnat_expr
))
4842 gnu_expr
= emit_range_check (gnu_expr
, gnat_component_type
);
4846 = tree_cons (NULL_TREE
, convert (TREE_TYPE (gnu_array_type
), gnu_expr
),
4850 return build_constructor (gnu_array_type
, nreverse (gnu_expr_list
));
4853 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
4854 some of which are from RECORD_TYPE. Return a CONSTRUCTOR consisting
4855 of the associations that are from RECORD_TYPE. If we see an internal
4856 record, make a recursive call to fill it in as well. */
4859 extract_values (values
, record_type
)
4863 tree result
= NULL_TREE
;
4866 for (field
= TYPE_FIELDS (record_type
); field
; field
= TREE_CHAIN (field
))
4870 /* _Parent is an internal field, but may have values in the aggregate,
4871 so check for values first. */
4872 if ((tem
= purpose_member (field
, values
)) != 0)
4874 value
= TREE_VALUE (tem
);
4875 TREE_ADDRESSABLE (tem
) = 1;
4878 else if (DECL_INTERNAL_P (field
))
4880 value
= extract_values (values
, TREE_TYPE (field
));
4881 if (TREE_CODE (value
) == CONSTRUCTOR
4882 && CONSTRUCTOR_ELTS (value
) == 0)
4886 /* If we have a record subtype, the names will match, but not the
4887 actual FIELD_DECLs. */
4888 for (tem
= values
; tem
; tem
= TREE_CHAIN (tem
))
4889 if (DECL_NAME (TREE_PURPOSE (tem
)) == DECL_NAME (field
))
4891 value
= convert (TREE_TYPE (field
), TREE_VALUE (tem
));
4892 TREE_ADDRESSABLE (tem
) = 1;
4898 result
= tree_cons (field
, value
, result
);
4901 return build_constructor (record_type
, nreverse (result
));
4904 /* EXP is to be treated as an array or record. Handle the cases when it is
4905 an access object and perform the required dereferences. */
4908 maybe_implicit_deref (exp
)
4911 /* If the type is a pointer, dereference it. */
4913 if (POINTER_TYPE_P (TREE_TYPE (exp
)) || TYPE_FAT_POINTER_P (TREE_TYPE (exp
)))
4914 exp
= build_unary_op (INDIRECT_REF
, NULL_TREE
, exp
);
4916 /* If we got a padded type, remove it too. */
4917 if (TREE_CODE (TREE_TYPE (exp
)) == RECORD_TYPE
4918 && TYPE_IS_PADDING_P (TREE_TYPE (exp
)))
4919 exp
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp
))), exp
);
4924 /* Surround EXP with a SAVE_EXPR, but handle unconstrained objects specially
4925 since it doesn't make any sense to put them in a SAVE_EXPR. */
4928 make_save_expr (exp
)
4931 tree type
= TREE_TYPE (exp
);
4933 /* If this is an unchecked conversion, save the input since we may need to
4934 handle this expression separately if it's the operand of a component
4936 if (TREE_CODE (exp
) == UNCHECKED_CONVERT_EXPR
)
4937 return build1 (UNCHECKED_CONVERT_EXPR
, type
,
4938 make_save_expr (TREE_OPERAND (exp
, 0)));
4940 /* If this is an aggregate type, we may be doing a dereference of it in
4941 the LHS side of an assignment. In that case, we need to evaluate
4942 it , take its address, make a SAVE_EXPR of that, then do the indirect
4943 reference. Note that for an unconstrained array, the effect will be
4944 to make a SAVE_EXPR of the fat pointer.
4946 ??? This is an efficiency problem in the case of a type that can be
4947 placed into memory, but until we can deal with the LHS issue,
4948 we have to take that hit. This really should test for BLKmode. */
4949 else if (TREE_CODE (type
) == UNCONSTRAINED_ARRAY_TYPE
4950 || (AGGREGATE_TYPE_P (type
) && ! TYPE_FAT_POINTER_P (type
)))
4952 build_unary_op (INDIRECT_REF
, type
,
4953 save_expr (build_unary_op (ADDR_EXPR
,
4954 build_reference_type (type
),
4957 /* Otherwise, just do the usual thing. */
4958 return save_expr (exp
);
4961 /* This is equivalent to stabilize_reference in GCC's tree.c, but we know
4962 how to handle our new nodes and we take an extra argument that says
4963 whether to force evaluation of everything. */
4966 gnat_stabilize_reference (ref
, force
)
4970 register tree type
= TREE_TYPE (ref
);
4971 register enum tree_code code
= TREE_CODE (ref
);
4972 register tree result
;
4979 /* No action is needed in this case. */
4985 case FIX_TRUNC_EXPR
:
4986 case FIX_FLOOR_EXPR
:
4987 case FIX_ROUND_EXPR
:
4989 case UNCHECKED_CONVERT_EXPR
:
4992 = build1 (code
, type
,
4993 gnat_stabilize_reference (TREE_OPERAND (ref
, 0), force
));
4997 case UNCONSTRAINED_ARRAY_REF
:
4998 result
= build1 (code
, type
,
4999 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 0),
5004 result
= build (COMPONENT_REF
, type
,
5005 gnat_stabilize_reference (TREE_OPERAND (ref
, 0),
5007 TREE_OPERAND (ref
, 1));
5011 result
= build (BIT_FIELD_REF
, type
,
5012 gnat_stabilize_reference (TREE_OPERAND (ref
, 0), force
),
5013 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 1),
5015 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 2),
5020 result
= build (ARRAY_REF
, type
,
5021 gnat_stabilize_reference (TREE_OPERAND (ref
, 0), force
),
5022 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 1),
5026 case ARRAY_RANGE_REF
:
5027 result
= build (ARRAY_RANGE_REF
, type
,
5028 gnat_stabilize_reference (TREE_OPERAND (ref
, 0), force
),
5029 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 1),
5034 result
= build (COMPOUND_EXPR
, type
,
5035 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 0),
5037 gnat_stabilize_reference (TREE_OPERAND (ref
, 1),
5042 result
= build1 (INDIRECT_REF
, type
,
5043 save_expr (build1 (ADDR_EXPR
,
5044 build_reference_type (type
), ref
)));
5047 /* If arg isn't a kind of lvalue we recognize, make no change.
5048 Caller should recognize the error for an invalid lvalue. */
5053 return error_mark_node
;
5056 TREE_READONLY (result
) = TREE_READONLY (ref
);
5060 /* Similar to stabilize_reference_1 in tree.c, but supports an extra
5061 arg to force a SAVE_EXPR for everything. */
5064 gnat_stabilize_reference_1 (e
, force
)
5068 register enum tree_code code
= TREE_CODE (e
);
5069 register tree type
= TREE_TYPE (e
);
5070 register tree result
;
5072 /* We cannot ignore const expressions because it might be a reference
5073 to a const array but whose index contains side-effects. But we can
5074 ignore things that are actual constant or that already have been
5075 handled by this function. */
5077 if (TREE_CONSTANT (e
) || code
== SAVE_EXPR
)
5080 switch (TREE_CODE_CLASS (code
))
5090 if (TREE_SIDE_EFFECTS (e
) || force
)
5091 return save_expr (e
);
5095 /* Constants need no processing. In fact, we should never reach
5100 /* Division is slow and tends to be compiled with jumps,
5101 especially the division by powers of 2 that is often
5102 found inside of an array reference. So do it just once. */
5103 if (code
== TRUNC_DIV_EXPR
|| code
== TRUNC_MOD_EXPR
5104 || code
== FLOOR_DIV_EXPR
|| code
== FLOOR_MOD_EXPR
5105 || code
== CEIL_DIV_EXPR
|| code
== CEIL_MOD_EXPR
5106 || code
== ROUND_DIV_EXPR
|| code
== ROUND_MOD_EXPR
)
5107 return save_expr (e
);
5108 /* Recursively stabilize each operand. */
5109 result
= build (code
, type
,
5110 gnat_stabilize_reference_1 (TREE_OPERAND (e
, 0), force
),
5111 gnat_stabilize_reference_1 (TREE_OPERAND (e
, 1), force
));
5115 /* Recursively stabilize each operand. */
5116 result
= build1 (code
, type
,
5117 gnat_stabilize_reference_1 (TREE_OPERAND (e
, 0),
5125 TREE_READONLY (result
) = TREE_READONLY (e
);
5129 /* GNAT_UNIT is the Defining_Identifier for some package or subprogram,
5130 either a spec or a body, BODY_P says which. If needed, make a function
5131 to be the elaboration routine for that object and perform the elaborations
5134 Return 1 if we didn't need an elaboration function, zero otherwise. */
5137 build_unit_elab (gnat_unit
, body_p
, gnu_elab_list
)
5138 Entity_Id gnat_unit
;
5146 /* If we have nothing to do, return. */
5147 if (gnu_elab_list
== 0)
5150 /* Set our file and line number to that of the object and set up the
5151 elaboration routine. */
5152 gnu_decl
= create_subprog_decl (create_concat_name (gnat_unit
,
5155 NULL_TREE
, void_ftype
, NULL_TREE
, 0, 1, 0,
5157 DECL_ELABORATION_PROC_P (gnu_decl
) = 1;
5159 begin_subprog_body (gnu_decl
);
5160 set_lineno (gnat_unit
, 1);
5162 gnu_block_stack
= tree_cons (NULL_TREE
, NULL_TREE
, gnu_block_stack
);
5163 expand_start_bindings (0);
5165 /* Emit the assignments for the elaborations we have to do. If there
5166 is no destination, this is just a call to execute some statement
5167 that was placed within the declarative region. But first save a
5168 pointer so we can see if any insns were generated. */
5170 insn
= get_last_insn ();
5172 for (; gnu_elab_list
; gnu_elab_list
= TREE_CHAIN (gnu_elab_list
))
5173 if (TREE_PURPOSE (gnu_elab_list
) == NULL_TREE
)
5175 if (TREE_VALUE (gnu_elab_list
) != 0)
5176 expand_expr_stmt (TREE_VALUE (gnu_elab_list
));
5180 tree lhs
= TREE_PURPOSE (gnu_elab_list
);
5182 input_filename
= DECL_SOURCE_FILE (lhs
);
5183 lineno
= DECL_SOURCE_LINE (lhs
);
5185 /* If LHS has a padded type, convert it to the unpadded type
5186 so the assignment is done properly. */
5187 if (TREE_CODE (TREE_TYPE (lhs
)) == RECORD_TYPE
5188 && TYPE_IS_PADDING_P (TREE_TYPE (lhs
)))
5189 lhs
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (lhs
))), lhs
);
5191 emit_line_note (input_filename
, lineno
);
5192 expand_expr_stmt (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
5193 TREE_PURPOSE (gnu_elab_list
),
5194 TREE_VALUE (gnu_elab_list
)));
5197 /* See if any non-NOTE insns were generated. */
5198 for (insn
= NEXT_INSN (insn
); insn
; insn
= NEXT_INSN (insn
))
5199 if (GET_RTX_CLASS (GET_CODE (insn
)) == 'i')
5205 expand_end_bindings (getdecls (), kept_level_p (), 0);
5206 poplevel (kept_level_p (), 1, 0);
5207 gnu_block_stack
= TREE_CHAIN (gnu_block_stack
);
5208 end_subprog_body ();
5210 /* If there were no insns, we don't need an elab routine. It would
5211 be nice to not output this one, but there's no good way to do that. */
5215 extern char *__gnat_to_canonical_file_spec
PARAMS ((char *));
5217 /* Determine the input_filename and the lineno from the source location
5218 (Sloc) of GNAT_NODE node. Set the global variable input_filename and
5219 lineno. If WRITE_NOTE_P is true, emit a line number note. */
5222 set_lineno (gnat_node
, write_note_p
)
5226 Source_Ptr source_location
= Sloc (gnat_node
);
5228 /* If node not from source code, ignore. */
5229 if (source_location
< 0)
5232 /* Use the identifier table to make a hashed, permanent copy of the filename,
5233 since the name table gets reallocated after Gigi returns but before all
5234 the debugging information is output. The call to
5235 __gnat_to_canonical_file_spec translates filenames from pragmas
5236 Source_Reference that contain host style syntax not understood by gdb. */
5238 = IDENTIFIER_POINTER
5240 (__gnat_to_canonical_file_spec
5242 (Debug_Source_Name (Get_Source_File_Index (source_location
))))));
5244 /* ref_filename is the reference file name as given by sinput (i.e no
5247 = IDENTIFIER_POINTER
5250 (Reference_Name (Get_Source_File_Index (source_location
)))));;
5251 lineno
= Get_Logical_Line_Number (source_location
);
5254 emit_line_note (input_filename
, lineno
);
5257 /* Post an error message. MSG is the error message, properly annotated.
5258 NODE is the node at which to post the error and the node to use for the
5259 "&" substitution. */
5262 post_error (msg
, node
)
5266 String_Template temp
;
5269 temp
.Low_Bound
= 1, temp
.High_Bound
= strlen (msg
);
5270 fp
.Array
= msg
, fp
.Bounds
= &temp
;
5272 Error_Msg_N (fp
, node
);
5275 /* Similar, but NODE is the node at which to post the error and ENT
5276 is the node to use for the "&" substitution. */
5279 post_error_ne (msg
, node
, ent
)
5284 String_Template temp
;
5287 temp
.Low_Bound
= 1, temp
.High_Bound
= strlen (msg
);
5288 fp
.Array
= msg
, fp
.Bounds
= &temp
;
5290 Error_Msg_NE (fp
, node
, ent
);
5293 /* Similar, but NODE is the node at which to post the error, ENT is the node
5294 to use for the "&" substitution, and N is the number to use for the ^. */
5297 post_error_ne_num (msg
, node
, ent
, n
)
5303 String_Template temp
;
5306 temp
.Low_Bound
= 1, temp
.High_Bound
= strlen (msg
);
5307 fp
.Array
= msg
, fp
.Bounds
= &temp
;
5308 Error_Msg_Uint_1
= UI_From_Int (n
);
5311 Error_Msg_NE (fp
, node
, ent
);
5314 /* Similar to post_error_ne_num, but T is a GCC tree representing the
5315 number to write. If the tree represents a constant that fits within
5316 a host integer, the text inside curly brackets in MSG will be output
5317 (presumably including a '^'). Otherwise that text will not be output
5318 and the text inside square brackets will be output instead. */
5321 post_error_ne_tree (msg
, node
, ent
, t
)
5327 char *newmsg
= alloca (strlen (msg
) + 1);
5328 String_Template temp
= {1, 0};
5330 char start_yes
, end_yes
, start_no
, end_no
;
5334 fp
.Array
= newmsg
, fp
.Bounds
= &temp
;
5336 if (host_integerp (t
, 1)
5337 #if HOST_BITS_PER_WIDE_INT > HOST_BITS_PER_INT
5338 && compare_tree_int (t
, 1 << (HOST_BITS_PER_INT
- 2)) < 0
5342 Error_Msg_Uint_1
= UI_From_Int (tree_low_cst (t
, 1));
5343 start_yes
= '{', end_yes
= '}', start_no
= '[', end_no
= ']';
5346 start_yes
= '[', end_yes
= ']', start_no
= '{', end_no
= '}';
5348 for (p
= msg
, q
= newmsg
; *p
!= 0; p
++)
5350 if (*p
== start_yes
)
5351 for (p
++; *p
!= end_yes
; p
++)
5353 else if (*p
== start_no
)
5354 for (p
++; *p
!= end_no
; p
++)
5362 temp
.High_Bound
= strlen (newmsg
);
5364 Error_Msg_NE (fp
, node
, ent
);
5367 /* Similar to post_error_ne_tree, except that NUM is a second
5368 integer to write in the message. */
5371 post_error_ne_tree_2 (msg
, node
, ent
, t
, num
)
5378 Error_Msg_Uint_2
= UI_From_Int (num
);
5379 post_error_ne_tree (msg
, node
, ent
, t
);
5382 /* Set the node for a second '&' in the error message. */
5385 set_second_error_entity (e
)
5388 Error_Msg_Node_2
= e
;
5391 /* Signal abort, with "Gigi abort" as the error label, and error_gnat_node
5392 as the relevant node that provides the location info for the error */
5398 String_Template temp
= {1, 10};
5401 fp
.Array
= "Gigi abort", fp
.Bounds
= &temp
;
5403 Current_Error_Node
= error_gnat_node
;
5404 Compiler_Abort (fp
, code
);
5407 /* Initialize the table that maps GNAT codes to GCC codes for simple
5408 binary and unary operations. */
5413 gnu_codes
[N_And_Then
] = TRUTH_ANDIF_EXPR
;
5414 gnu_codes
[N_Or_Else
] = TRUTH_ORIF_EXPR
;
5416 gnu_codes
[N_Op_And
] = TRUTH_AND_EXPR
;
5417 gnu_codes
[N_Op_Or
] = TRUTH_OR_EXPR
;
5418 gnu_codes
[N_Op_Xor
] = TRUTH_XOR_EXPR
;
5419 gnu_codes
[N_Op_Eq
] = EQ_EXPR
;
5420 gnu_codes
[N_Op_Ne
] = NE_EXPR
;
5421 gnu_codes
[N_Op_Lt
] = LT_EXPR
;
5422 gnu_codes
[N_Op_Le
] = LE_EXPR
;
5423 gnu_codes
[N_Op_Gt
] = GT_EXPR
;
5424 gnu_codes
[N_Op_Ge
] = GE_EXPR
;
5425 gnu_codes
[N_Op_Add
] = PLUS_EXPR
;
5426 gnu_codes
[N_Op_Subtract
] = MINUS_EXPR
;
5427 gnu_codes
[N_Op_Multiply
] = MULT_EXPR
;
5428 gnu_codes
[N_Op_Mod
] = FLOOR_MOD_EXPR
;
5429 gnu_codes
[N_Op_Rem
] = TRUNC_MOD_EXPR
;
5430 gnu_codes
[N_Op_Minus
] = NEGATE_EXPR
;
5431 gnu_codes
[N_Op_Abs
] = ABS_EXPR
;
5432 gnu_codes
[N_Op_Not
] = TRUTH_NOT_EXPR
;
5433 gnu_codes
[N_Op_Rotate_Left
] = LROTATE_EXPR
;
5434 gnu_codes
[N_Op_Rotate_Right
] = RROTATE_EXPR
;
5435 gnu_codes
[N_Op_Shift_Left
] = LSHIFT_EXPR
;
5436 gnu_codes
[N_Op_Shift_Right
] = RSHIFT_EXPR
;
5437 gnu_codes
[N_Op_Shift_Right_Arithmetic
] = RSHIFT_EXPR
;