1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
10 * Copyright (C) 1992-2002, Free Software Foundation, Inc. *
12 * GNAT is free software; you can redistribute it and/or modify it under *
13 * terms of the GNU General Public License as published by the Free Soft- *
14 * ware Foundation; either version 2, or (at your option) any later ver- *
15 * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
16 * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
17 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
18 * for more details. You should have received a copy of the GNU General *
19 * Public License distributed with GNAT; see file COPYING. If not, write *
20 * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
21 * MA 02111-1307, USA. *
23 * GNAT was originally developed by the GNAT team at New York University. *
24 * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
26 ****************************************************************************/
58 struct Node *Nodes_Ptr;
59 Node_Id *Next_Node_Ptr;
60 Node_Id *Prev_Node_Ptr;
61 struct Elist_Header *Elists_Ptr;
62 struct Elmt_Item *Elmts_Ptr;
63 struct String_Entry *Strings_Ptr;
64 Char_Code *String_Chars_Ptr;
65 struct List_Header *List_Headers_Ptr;
67 /* Current filename without path. */
68 const char *ref_filename;
70 /* Flag indicating whether file names are discarded in exception messages */
71 int discard_file_names;
73 /* If true, then gigi is being called on an analyzed but unexpanded
74 tree, and the only purpose of the call is to properly annotate
75 types with representation information. */
76 int type_annotate_only;
78 /* List of TREE_LIST nodes representing a block stack. TREE_VALUE
79 of each gives the variable used for the setjmp buffer in the current
80 block, if any. TREE_PURPOSE gives the bottom condition for a loop,
81 if this block is for a loop. The latter is only used to save the tree
85 /* List of TREE_LIST nodes representing a stack of exception pointer
86 variables. TREE_VALUE is the VAR_DECL that stores the address of
87 the raised exception. Nonzero means we are in an exception
88 handler. Not used in the zero-cost case. */
89 static GTY(()) 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 GTY(()) tree gnu_return_label_stack;
101 static tree tree_transform PARAMS((Node_Id));
102 static void elaborate_all_entities PARAMS((Node_Id));
103 static void process_freeze_entity PARAMS((Node_Id));
104 static void process_inlined_subprograms PARAMS((Node_Id));
105 static void process_decls PARAMS((List_Id, List_Id, Node_Id,
107 static tree emit_access_check PARAMS((tree));
108 static tree emit_discriminant_check PARAMS((tree, Node_Id));
109 static tree emit_range_check PARAMS((tree, Node_Id));
110 static tree emit_index_check PARAMS((tree, tree, tree, tree));
111 static tree emit_check PARAMS((tree, tree, int));
112 static tree convert_with_check PARAMS((Entity_Id, tree,
114 static int addressable_p PARAMS((tree));
115 static tree assoc_to_constructor PARAMS((Node_Id, tree));
116 static tree extract_values PARAMS((tree, tree));
117 static tree pos_to_constructor PARAMS((Node_Id, tree, Entity_Id));
118 static tree maybe_implicit_deref PARAMS((tree));
119 static tree gnat_stabilize_reference_1 PARAMS((tree, int));
120 static int build_unit_elab PARAMS((Entity_Id, int, tree));
122 /* Constants for +0.5 and -0.5 for float-to-integer rounding. */
123 static REAL_VALUE_TYPE dconstp5;
124 static REAL_VALUE_TYPE dconstmp5;
126 /* This is the main program of the back-end. It sets up all the table
127 structures and then generates code. */
130 gigi (gnat_root, max_gnat_node, number_name, nodes_ptr, next_node_ptr,
131 prev_node_ptr, elists_ptr, elmts_ptr, strings_ptr, string_chars_ptr,
132 list_headers_ptr, number_units, file_info_ptr, standard_integer,
133 standard_long_long_float, standard_exception_type, gigi_operating_mode)
137 struct Node *nodes_ptr;
138 Node_Id *next_node_ptr;
139 Node_Id *prev_node_ptr;
140 struct Elist_Header *elists_ptr;
141 struct Elmt_Item *elmts_ptr;
142 struct String_Entry *strings_ptr;
143 Char_Code *string_chars_ptr;
144 struct List_Header *list_headers_ptr;
145 Int number_units ATTRIBUTE_UNUSED;
146 char *file_info_ptr ATTRIBUTE_UNUSED;
147 Entity_Id standard_integer;
148 Entity_Id standard_long_long_float;
149 Entity_Id standard_exception_type;
150 Int gigi_operating_mode;
152 tree gnu_standard_long_long_float;
153 tree gnu_standard_exception_type;
155 max_gnat_nodes = max_gnat_node;
156 number_names = number_name;
157 Nodes_Ptr = nodes_ptr;
158 Next_Node_Ptr = next_node_ptr;
159 Prev_Node_Ptr = prev_node_ptr;
160 Elists_Ptr = elists_ptr;
161 Elmts_Ptr = elmts_ptr;
162 Strings_Ptr = strings_ptr;
163 String_Chars_Ptr = string_chars_ptr;
164 List_Headers_Ptr = list_headers_ptr;
166 type_annotate_only = (gigi_operating_mode == 1);
168 /* See if we should discard file names in exception messages. */
169 discard_file_names = (Global_Discard_Names || Debug_Flag_NN);
171 if (Nkind (gnat_root) != N_Compilation_Unit)
174 set_lineno (gnat_root, 0);
176 /* Initialize ourselves. */
181 /* Enable GNAT stack checking method if needed */
182 if (!Stack_Check_Probes_On_Target)
183 set_stack_check_libfunc (gen_rtx (SYMBOL_REF, Pmode, "_gnat_stack_check"));
185 /* Save the type we made for integer as the type for Standard.Integer.
186 Then make the rest of the standard types. Note that some of these
188 save_gnu_tree (Base_Type (standard_integer),
189 TYPE_NAME (integer_type_node), 0);
191 gnu_except_ptr_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE);
193 dconstp5 = REAL_VALUE_ATOF ("0.5", DFmode);
194 dconstmp5 = REAL_VALUE_ATOF ("-0.5", DFmode);
196 gnu_standard_long_long_float
197 = gnat_to_gnu_entity (Base_Type (standard_long_long_float), NULL_TREE, 0);
198 gnu_standard_exception_type
199 = gnat_to_gnu_entity (Base_Type (standard_exception_type), NULL_TREE, 0);
201 init_gigi_decls (gnu_standard_long_long_float, gnu_standard_exception_type);
203 /* Process any Pragma Ident for the main unit. */
204 #ifdef ASM_OUTPUT_IDENT
205 if (Present (Ident_String (Main_Unit)))
208 TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit))));
211 /* If we are using the GCC exception mechanism, let GCC know. */
212 if (Exception_Mechanism == GCC_ZCX)
215 gnat_to_code (gnat_root);
219 /* This function is the driver of the GNAT to GCC tree transformation process.
220 GNAT_NODE is the root of some gnat tree. It generates code for that
224 gnat_to_code (gnat_node)
229 /* Save node number in case error */
230 error_gnat_node = gnat_node;
232 gnu_root = tree_transform (gnat_node);
234 /* This should just generate code, not return a value. If it returns
235 a value, something is wrong. */
236 if (gnu_root != error_mark_node)
240 /* GNAT_NODE is the root of some GNAT tree. Return the root of the GCC
241 tree corresponding to that GNAT tree. Normally, no code is generated.
242 We just return an equivalent tree which is used elsewhere to generate
246 gnat_to_gnu (gnat_node)
251 /* Save node number in case error */
252 error_gnat_node = gnat_node;
254 gnu_root = tree_transform (gnat_node);
256 /* If we got no code as a result, something is wrong. */
257 if (gnu_root == error_mark_node && ! type_annotate_only)
263 /* This function is the driver of the GNAT to GCC tree transformation process.
264 It is the entry point of the tree transformer. GNAT_NODE is the root of
265 some GNAT tree. Return the root of the corresponding GCC tree or
266 error_mark_node to signal that there is no GCC tree to return.
268 The latter is the case if only code generation actions have to be performed
269 like in the case of if statements, loops, etc. This routine is wrapped
270 in the above two routines for most purposes. */
273 tree_transform (gnat_node)
276 tree gnu_result = error_mark_node; /* Default to no value. */
277 tree gnu_result_type = void_type_node;
279 tree gnu_lhs, gnu_rhs;
281 Entity_Id gnat_temp_type;
283 /* Set input_file_name and lineno from the Sloc in the GNAT tree. */
284 set_lineno (gnat_node, 0);
286 /* If this is a Statement and we are at top level, we add the statement
287 as an elaboration for a null tree. That will cause it to be placed
288 in the elaboration procedure. */
289 if (global_bindings_p ()
290 && ((IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call)
291 && Nkind (gnat_node) != N_Null_Statement)
292 || Nkind (gnat_node) == N_Procedure_Call_Statement
293 || Nkind (gnat_node) == N_Label
294 || (Nkind (gnat_node) == N_Handled_Sequence_Of_Statements
295 && (Present (Exception_Handlers (gnat_node))
296 || Present (At_End_Proc (gnat_node))))
297 || ((Nkind (gnat_node) == N_Raise_Constraint_Error
298 || Nkind (gnat_node) == N_Raise_Storage_Error
299 || Nkind (gnat_node) == N_Raise_Program_Error)
300 && (Ekind (Etype (gnat_node)) == E_Void))))
302 add_pending_elaborations (NULL_TREE, make_transform_expr (gnat_node));
304 return error_mark_node;
307 /* If this node is a non-static subexpression and we are only
308 annotating types, make this into a NULL_EXPR for non-VOID types
309 and error_mark_node for void return types. But allow
310 N_Identifier since we use it for lots of things, including
311 getting trees for discriminants. */
313 if (type_annotate_only
314 && IN (Nkind (gnat_node), N_Subexpr)
315 && Nkind (gnat_node) != N_Identifier
316 && ! Compile_Time_Known_Value (gnat_node))
318 gnu_result_type = get_unpadded_type (Etype (gnat_node));
320 if (TREE_CODE (gnu_result_type) == VOID_TYPE)
321 return error_mark_node;
323 return build1 (NULL_EXPR, gnu_result_type,
324 build_call_raise (CE_Range_Check_Failed));
327 switch (Nkind (gnat_node))
329 /********************************/
330 /* Chapter 2: Lexical Elements: */
331 /********************************/
334 case N_Expanded_Name:
335 case N_Operator_Symbol:
336 case N_Defining_Identifier:
338 /* If the Etype of this node does not equal the Etype of the
339 Entity, something is wrong with the entity map, probably in
340 generic instantiation. However, this does not apply to
341 types. Since we sometime have strange Ekind's, just do
342 this test for objects. Also, if the Etype of the Entity
343 is private, the Etype of the N_Identifier is allowed to be the
344 full type and also we consider a packed array type to be the
345 same as the original type. Finally, if the types are Itypes,
346 one may be a copy of the other, which is also legal. */
348 gnat_temp = (Nkind (gnat_node) == N_Defining_Identifier
349 ? gnat_node : Entity (gnat_node));
350 gnat_temp_type = Etype (gnat_temp);
352 if (Etype (gnat_node) != gnat_temp_type
353 && ! (Is_Packed (gnat_temp_type)
354 && Etype (gnat_node) == Packed_Array_Type (gnat_temp_type))
355 && ! (IN (Ekind (gnat_temp_type), Private_Kind)
356 && Present (Full_View (gnat_temp_type))
357 && ((Etype (gnat_node) == Full_View (gnat_temp_type))
358 || (Is_Packed (Full_View (gnat_temp_type))
359 && Etype (gnat_node) ==
360 Packed_Array_Type (Full_View (gnat_temp_type)))))
361 && (!Is_Itype (Etype (gnat_node)) || !Is_Itype (gnat_temp_type))
362 && (Ekind (gnat_temp) == E_Variable
363 || Ekind (gnat_temp) == E_Component
364 || Ekind (gnat_temp) == E_Constant
365 || Ekind (gnat_temp) == E_Loop_Parameter
366 || IN (Ekind (gnat_temp), Formal_Kind)))
369 /* If this is a reference to a deferred constant whose partial view
370 is an unconstrained private type, the proper type is on the full
371 view of the constant, not on the full view of the type, which may
374 This may be a reference to a type, for example in the prefix of the
375 attribute Position, generated for dispatching code (see Make_DT in
376 exp_disp,adb). In that case we need the type itself, not is parent,
377 in particular if it is a derived type */
379 if (Is_Private_Type (gnat_temp_type)
380 && Has_Unknown_Discriminants (gnat_temp_type)
381 && Present (Full_View (gnat_temp))
382 && ! Is_Type (gnat_temp))
384 gnat_temp = Full_View (gnat_temp);
385 gnat_temp_type = Etype (gnat_temp);
386 gnu_result_type = get_unpadded_type (gnat_temp_type);
390 /* Expand the type of this identitier first, in case it is
391 an enumeral literal, which only get made when the type
392 is expanded. There is no order-of-elaboration issue here.
393 We want to use the Actual_Subtype if it has already been
394 elaborated, otherwise the Etype. Avoid using Actual_Subtype
395 for packed arrays to simplify things. */
396 if ((Ekind (gnat_temp) == E_Constant
397 || Ekind (gnat_temp) == E_Variable || Is_Formal (gnat_temp))
398 && ! (Is_Array_Type (Etype (gnat_temp))
399 && Present (Packed_Array_Type (Etype (gnat_temp))))
400 && Present (Actual_Subtype (gnat_temp))
401 && present_gnu_tree (Actual_Subtype (gnat_temp)))
402 gnat_temp_type = Actual_Subtype (gnat_temp);
404 gnat_temp_type = Etype (gnat_node);
406 gnu_result_type = get_unpadded_type (gnat_temp_type);
409 gnu_result = gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0);
411 /* If we are in an exception handler, force this variable into memory
412 to ensure optimization does not remove stores that appear
413 redundant but are actually needed in case an exception occurs.
415 ??? Note that we need not do this if the variable is declared within
416 the handler, only if it is referenced in the handler and declared
417 in an enclosing block, but we have no way of testing that
419 if (TREE_VALUE (gnu_except_ptr_stack) != 0)
421 gnat_mark_addressable (gnu_result);
422 flush_addressof (gnu_result);
425 /* Some objects (such as parameters passed by reference, globals of
426 variable size, and renamed objects) actually represent the address
427 of the object. In that case, we must do the dereference. Likewise,
428 deal with parameters to foreign convention subprograms. Call fold
429 here since GNU_RESULT may be a CONST_DECL. */
430 if (DECL_P (gnu_result)
431 && (DECL_BY_REF_P (gnu_result)
432 || DECL_BY_COMPONENT_PTR_P (gnu_result)))
434 int ro = DECL_POINTS_TO_READONLY_P (gnu_result);
436 if (DECL_BY_COMPONENT_PTR_P (gnu_result))
437 gnu_result = convert (build_pointer_type (gnu_result_type),
440 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE,
442 TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result) = ro;
445 /* The GNAT tree has the type of a function as the type of its result.
446 Also use the type of the result if the Etype is a subtype which
447 is nominally unconstrained. But remove any padding from the
449 if (TREE_CODE (TREE_TYPE (gnu_result)) == FUNCTION_TYPE
450 || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type))
452 gnu_result_type = TREE_TYPE (gnu_result);
453 if (TREE_CODE (gnu_result_type) == RECORD_TYPE
454 && TYPE_IS_PADDING_P (gnu_result_type))
455 gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type));
458 /* We always want to return the underlying INTEGER_CST for an
459 enumeration literal to avoid the need to call fold in lots
460 of places. But don't do this is the parent will be taking
461 the address of this object. */
462 if (TREE_CODE (gnu_result) == CONST_DECL)
464 gnat_temp = Parent (gnat_node);
465 if (DECL_CONST_CORRESPONDING_VAR (gnu_result) == 0
466 || (Nkind (gnat_temp) != N_Reference
467 && ! (Nkind (gnat_temp) == N_Attribute_Reference
468 && ((Get_Attribute_Id (Attribute_Name (gnat_temp))
470 || (Get_Attribute_Id (Attribute_Name (gnat_temp))
472 || (Get_Attribute_Id (Attribute_Name (gnat_temp))
473 == Attr_Unchecked_Access)
474 || (Get_Attribute_Id (Attribute_Name (gnat_temp))
475 == Attr_Unrestricted_Access)))))
476 gnu_result = DECL_INITIAL (gnu_result);
480 case N_Integer_Literal:
484 /* Get the type of the result, looking inside any padding and
485 left-justified modular types. Then get the value in that type. */
486 gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
488 if (TREE_CODE (gnu_type) == RECORD_TYPE
489 && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_type))
490 gnu_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
492 gnu_result = UI_To_gnu (Intval (gnat_node), gnu_type);
494 /* If the result overflows (meaning it doesn't fit in its base type),
495 abort. We would like to check that the value is within the range
496 of the subtype, but that causes problems with subtypes whose usage
497 will raise Constraint_Error and with biased representation, so
499 if (TREE_CONSTANT_OVERFLOW (gnu_result))
504 case N_Character_Literal:
505 /* If a Entity is present, it means that this was one of the
506 literals in a user-defined character type. In that case,
507 just return the value in the CONST_DECL. Otherwise, use the
508 character code. In that case, the base type should be an
509 INTEGER_TYPE, but we won't bother checking for that. */
510 gnu_result_type = get_unpadded_type (Etype (gnat_node));
511 if (Present (Entity (gnat_node)))
512 gnu_result = DECL_INITIAL (get_gnu_tree (Entity (gnat_node)));
514 gnu_result = convert (gnu_result_type,
515 build_int_2 (Char_Literal_Value (gnat_node), 0));
519 /* If this is of a fixed-point type, the value we want is the
520 value of the corresponding integer. */
521 if (IN (Ekind (Underlying_Type (Etype (gnat_node))), Fixed_Point_Kind))
523 gnu_result_type = get_unpadded_type (Etype (gnat_node));
524 gnu_result = UI_To_gnu (Corresponding_Integer_Value (gnat_node),
526 if (TREE_CONSTANT_OVERFLOW (gnu_result)
528 || (TREE_CODE (TYPE_MIN_VALUE (gnu_result_type)) == INTEGER_CST
529 && tree_int_cst_lt (gnu_result,
530 TYPE_MIN_VALUE (gnu_result_type)))
531 || (TREE_CODE (TYPE_MAX_VALUE (gnu_result_type)) == INTEGER_CST
532 && tree_int_cst_lt (TYPE_MAX_VALUE (gnu_result_type),
538 /* We should never see a Vax_Float type literal, since the front end
539 is supposed to transform these using appropriate conversions */
540 else if (Vax_Float (Underlying_Type (Etype (gnat_node))))
545 Ureal ur_realval = Realval (gnat_node);
547 gnu_result_type = get_unpadded_type (Etype (gnat_node));
549 /* If the real value is zero, so is the result. Otherwise,
550 convert it to a machine number if it isn't already. That
551 forces BASE to 0 or 2 and simplifies the rest of our logic. */
552 if (UR_Is_Zero (ur_realval))
553 gnu_result = convert (gnu_result_type, integer_zero_node);
556 if (! Is_Machine_Number (gnat_node))
558 = Machine (Base_Type (Underlying_Type (Etype (gnat_node))),
559 ur_realval, Round_Even);
562 = UI_To_gnu (Numerator (ur_realval), gnu_result_type);
564 /* If we have a base of zero, divide by the denominator.
565 Otherwise, the base must be 2 and we scale the value, which
566 we know can fit in the mantissa of the type (hence the use
567 of that type above). */
568 if (Rbase (ur_realval) == 0)
570 = build_binary_op (RDIV_EXPR,
571 get_base_type (gnu_result_type),
573 UI_To_gnu (Denominator (ur_realval),
575 else if (Rbase (ur_realval) != 2)
580 = build_real (gnu_result_type,
582 (TREE_REAL_CST (gnu_result),
583 - UI_To_Int (Denominator (ur_realval))));
586 /* Now see if we need to negate the result. Do it this way to
587 properly handle -0. */
588 if (UR_Is_Negative (Realval (gnat_node)))
590 = build_unary_op (NEGATE_EXPR, get_base_type (gnu_result_type),
596 case N_String_Literal:
597 gnu_result_type = get_unpadded_type (Etype (gnat_node));
598 if (TYPE_PRECISION (TREE_TYPE (gnu_result_type)) == HOST_BITS_PER_CHAR)
600 /* We assume here that all strings are of type standard.string.
601 "Weird" types of string have been converted to an aggregate
603 String_Id gnat_string = Strval (gnat_node);
604 int length = String_Length (gnat_string);
605 char *string = (char *) alloca (length + 1);
608 /* Build the string with the characters in the literal. Note
609 that Ada strings are 1-origin. */
610 for (i = 0; i < length; i++)
611 string[i] = Get_String_Char (gnat_string, i + 1);
613 /* Put a null at the end of the string in case it's in a context
614 where GCC will want to treat it as a C string. */
617 gnu_result = build_string (length, string);
619 /* Strings in GCC don't normally have types, but we want
620 this to not be converted to the array type. */
621 TREE_TYPE (gnu_result) = gnu_result_type;
625 /* Build a list consisting of each character, then make
627 String_Id gnat_string = Strval (gnat_node);
628 int length = String_Length (gnat_string);
630 tree gnu_list = NULL_TREE;
632 for (i = 0; i < length; i++)
634 = tree_cons (NULL_TREE,
635 convert (TREE_TYPE (gnu_result_type),
636 build_int_2 (Get_String_Char (gnat_string,
642 = build_constructor (gnu_result_type, nreverse (gnu_list));
647 if (type_annotate_only)
650 /* Check for (and ignore) unrecognized pragma */
651 if (! Is_Pragma_Name (Chars (gnat_node)))
654 switch (Get_Pragma_Id (Chars (gnat_node)))
656 case Pragma_Inspection_Point:
657 /* Do nothing at top level: all such variables are already
659 if (global_bindings_p ())
662 set_lineno (gnat_node, 1);
663 for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
665 gnat_temp = Next (gnat_temp))
667 gnu_expr = gnat_to_gnu (Expression (gnat_temp));
668 if (TREE_CODE (gnu_expr) == UNCONSTRAINED_ARRAY_REF)
669 gnu_expr = TREE_OPERAND (gnu_expr, 0);
671 gnu_expr = build1 (USE_EXPR, void_type_node, gnu_expr);
672 TREE_SIDE_EFFECTS (gnu_expr) = 1;
673 expand_expr_stmt (gnu_expr);
677 case Pragma_Optimize:
678 switch (Chars (Expression
679 (First (Pragma_Argument_Associations (gnat_node)))))
681 case Name_Time: case Name_Space:
683 post_error ("insufficient -O value?", gnat_node);
688 post_error ("must specify -O0?", gnat_node);
697 case Pragma_Reviewable:
698 if (write_symbols == NO_DEBUG)
699 post_error ("must specify -g?", gnat_node);
704 /**************************************/
705 /* Chapter 3: Declarations and Types: */
706 /**************************************/
708 case N_Subtype_Declaration:
709 case N_Full_Type_Declaration:
710 case N_Incomplete_Type_Declaration:
711 case N_Private_Type_Declaration:
712 case N_Private_Extension_Declaration:
713 case N_Task_Type_Declaration:
714 process_type (Defining_Entity (gnat_node));
717 case N_Object_Declaration:
718 case N_Exception_Declaration:
719 gnat_temp = Defining_Entity (gnat_node);
721 /* If we are just annotating types and this object has an unconstrained
722 or task type, don't elaborate it. */
723 if (type_annotate_only
724 && (((Is_Array_Type (Etype (gnat_temp))
725 || Is_Record_Type (Etype (gnat_temp)))
726 && ! Is_Constrained (Etype (gnat_temp)))
727 || Is_Concurrent_Type (Etype (gnat_temp))))
730 if (Present (Expression (gnat_node))
731 && ! (Nkind (gnat_node) == N_Object_Declaration
732 && No_Initialization (gnat_node))
733 && (! type_annotate_only
734 || Compile_Time_Known_Value (Expression (gnat_node))))
736 gnu_expr = gnat_to_gnu (Expression (gnat_node));
737 if (Do_Range_Check (Expression (gnat_node)))
738 gnu_expr = emit_range_check (gnu_expr, Etype (gnat_temp));
740 /* If this object has its elaboration delayed, we must force
741 evaluation of GNU_EXPR right now and save it for when the object
743 if (Present (Freeze_Node (gnat_temp)))
745 if ((Is_Public (gnat_temp) || global_bindings_p ())
746 && ! TREE_CONSTANT (gnu_expr))
748 = create_var_decl (create_concat_name (gnat_temp, "init"),
749 NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr,
750 0, Is_Public (gnat_temp), 0, 0, 0);
752 gnu_expr = maybe_variable (gnu_expr, Expression (gnat_node));
754 save_gnu_tree (gnat_node, gnu_expr, 1);
760 if (type_annotate_only && gnu_expr != 0
761 && TREE_CODE (gnu_expr) == ERROR_MARK)
764 if (No (Freeze_Node (gnat_temp)))
765 gnat_to_gnu_entity (gnat_temp, gnu_expr, 1);
768 case N_Object_Renaming_Declaration:
770 gnat_temp = Defining_Entity (gnat_node);
772 /* Don't do anything if this renaming is handled by the front end.
773 or if we are just annotating types and this object has a
774 composite or task type, don't elaborate it. */
775 if (! Is_Renaming_Of_Object (gnat_temp)
776 && ! (type_annotate_only
777 && (Is_Array_Type (Etype (gnat_temp))
778 || Is_Record_Type (Etype (gnat_temp))
779 || Is_Concurrent_Type (Etype (gnat_temp)))))
781 gnu_expr = gnat_to_gnu (Renamed_Object (gnat_temp));
782 gnat_to_gnu_entity (gnat_temp, gnu_expr, 1);
786 case N_Implicit_Label_Declaration:
787 gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
790 case N_Subprogram_Renaming_Declaration:
791 case N_Package_Renaming_Declaration:
792 case N_Exception_Renaming_Declaration:
793 case N_Number_Declaration:
794 /* These are fully handled in the front end. */
797 /*************************************/
798 /* Chapter 4: Names and Expressions: */
799 /*************************************/
801 case N_Explicit_Dereference:
802 gnu_result = gnat_to_gnu (Prefix (gnat_node));
803 gnu_result_type = get_unpadded_type (Etype (gnat_node));
805 /* Emit access check if necessary */
806 if (Do_Access_Check (gnat_node))
807 gnu_result = emit_access_check (gnu_result);
809 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
812 case N_Indexed_Component:
814 tree gnu_array_object = gnat_to_gnu (Prefix (gnat_node));
818 Node_Id *gnat_expr_array;
820 /* Emit access check if necessary */
821 if (Do_Access_Check (gnat_node))
822 gnu_array_object = emit_access_check (gnu_array_object);
824 gnu_array_object = maybe_implicit_deref (gnu_array_object);
825 gnu_array_object = maybe_unconstrained_array (gnu_array_object);
827 /* If we got a padded type, remove it too. */
828 if (TREE_CODE (TREE_TYPE (gnu_array_object)) == RECORD_TYPE
829 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object)))
831 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object))),
834 gnu_result = gnu_array_object;
836 /* First compute the number of dimensions of the array, then
837 fill the expression array, the order depending on whether
838 this is a Convention_Fortran array or not. */
839 for (ndim = 1, gnu_type = TREE_TYPE (gnu_array_object);
840 TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
841 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type));
842 ndim++, gnu_type = TREE_TYPE (gnu_type))
845 gnat_expr_array = (Node_Id *) alloca (ndim * sizeof (Node_Id));
847 if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object)))
848 for (i = ndim - 1, gnat_temp = First (Expressions (gnat_node));
850 i--, gnat_temp = Next (gnat_temp))
851 gnat_expr_array[i] = gnat_temp;
853 for (i = 0, gnat_temp = First (Expressions (gnat_node));
855 i++, gnat_temp = Next (gnat_temp))
856 gnat_expr_array[i] = gnat_temp;
858 for (i = 0, gnu_type = TREE_TYPE (gnu_array_object);
859 i < ndim; i++, gnu_type = TREE_TYPE (gnu_type))
861 if (TREE_CODE (gnu_type) != ARRAY_TYPE)
864 gnat_temp = gnat_expr_array[i];
865 gnu_expr = gnat_to_gnu (gnat_temp);
867 if (Do_Range_Check (gnat_temp))
870 (gnu_array_object, gnu_expr,
871 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
872 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))));
874 gnu_result = build_binary_op (ARRAY_REF, NULL_TREE,
875 gnu_result, gnu_expr);
879 gnu_result_type = get_unpadded_type (Etype (gnat_node));
885 Node_Id gnat_range_node = Discrete_Range (gnat_node);
887 gnu_result = gnat_to_gnu (Prefix (gnat_node));
888 gnu_result_type = get_unpadded_type (Etype (gnat_node));
890 /* Emit access check if necessary */
891 if (Do_Access_Check (gnat_node))
892 gnu_result = emit_access_check (gnu_result);
894 /* Do any implicit dereferences of the prefix and do any needed
896 gnu_result = maybe_implicit_deref (gnu_result);
897 gnu_result = maybe_unconstrained_array (gnu_result);
898 gnu_type = TREE_TYPE (gnu_result);
899 if (Do_Range_Check (gnat_range_node))
901 /* Get the bounds of the slice. */
903 = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_result_type));
904 tree gnu_min_expr = TYPE_MIN_VALUE (gnu_index_type);
905 tree gnu_max_expr = TYPE_MAX_VALUE (gnu_index_type);
906 tree gnu_expr_l, gnu_expr_h, gnu_expr_type;
908 /* Check to see that the minimum slice value is in range */
911 (gnu_result, gnu_min_expr,
912 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
913 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))));
915 /* Check to see that the maximum slice value is in range */
918 (gnu_result, gnu_max_expr,
919 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
920 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))));
922 /* Derive a good type to convert everything too */
923 gnu_expr_type = get_base_type (TREE_TYPE (gnu_expr_l));
925 /* Build a compound expression that does the range checks */
927 = build_binary_op (COMPOUND_EXPR, gnu_expr_type,
928 convert (gnu_expr_type, gnu_expr_h),
929 convert (gnu_expr_type, gnu_expr_l));
931 /* Build a conditional expression that returns the range checks
932 expression if the slice range is not null (max >= min) or
933 returns the min if the slice range is null */
935 = fold (build (COND_EXPR, gnu_expr_type,
936 build_binary_op (GE_EXPR, gnu_expr_type,
937 convert (gnu_expr_type,
939 convert (gnu_expr_type,
941 gnu_expr, gnu_min_expr));
944 gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
946 gnu_result = build_binary_op (ARRAY_RANGE_REF, gnu_result_type,
947 gnu_result, gnu_expr);
951 case N_Selected_Component:
953 tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
954 Entity_Id gnat_field = Entity (Selector_Name (gnat_node));
955 Entity_Id gnat_pref_type = Etype (Prefix (gnat_node));
958 while (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind)
959 || IN (Ekind (gnat_pref_type), Access_Kind))
961 if (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind))
962 gnat_pref_type = Underlying_Type (gnat_pref_type);
963 else if (IN (Ekind (gnat_pref_type), Access_Kind))
964 gnat_pref_type = Designated_Type (gnat_pref_type);
967 if (Do_Access_Check (gnat_node))
968 gnu_prefix = emit_access_check (gnu_prefix);
970 gnu_prefix = maybe_implicit_deref (gnu_prefix);
972 /* For discriminant references in tagged types always substitute the
973 corresponding discriminant as the actual selected component. */
975 if (Is_Tagged_Type (gnat_pref_type))
976 while (Present (Corresponding_Discriminant (gnat_field)))
977 gnat_field = Corresponding_Discriminant (gnat_field);
979 /* For discriminant references of untagged types always substitute the
980 corresponding girder discriminant. */
982 else if (Present (Corresponding_Discriminant (gnat_field)))
983 gnat_field = Original_Record_Component (gnat_field);
985 /* Handle extracting the real or imaginary part of a complex.
986 The real part is the first field and the imaginary the last. */
988 if (TREE_CODE (TREE_TYPE (gnu_prefix)) == COMPLEX_TYPE)
989 gnu_result = build_unary_op (Present (Next_Entity (gnat_field))
990 ? REALPART_EXPR : IMAGPART_EXPR,
991 NULL_TREE, gnu_prefix);
994 gnu_field = gnat_to_gnu_entity (gnat_field, NULL_TREE, 0);
996 /* If there are discriminants, the prefix might be
997 evaluated more than once, which is a problem if it has
999 if (Has_Discriminants (Is_Access_Type (Etype (Prefix (gnat_node)))
1000 ? Designated_Type (Etype
1001 (Prefix (gnat_node)))
1002 : Etype (Prefix (gnat_node))))
1003 gnu_prefix = gnat_stabilize_reference (gnu_prefix, 0);
1005 /* Emit discriminant check if necessary. */
1006 if (Do_Discriminant_Check (gnat_node))
1007 gnu_prefix = emit_discriminant_check (gnu_prefix, gnat_node);
1009 = build_component_ref (gnu_prefix, NULL_TREE, gnu_field);
1012 if (gnu_result == 0)
1015 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1019 case N_Attribute_Reference:
1021 /* The attribute designator (like an enumeration value). */
1022 int attribute = Get_Attribute_Id (Attribute_Name (gnat_node));
1023 int prefix_unused = 0;
1027 /* The Elab_Spec and Elab_Body attributes are special in that
1028 Prefix is a unit, not an object with a GCC equivalent. Similarly
1029 for Elaborated, since that variable isn't otherwise known. */
1030 if (attribute == Attr_Elab_Body || attribute == Attr_Elab_Spec)
1033 = create_subprog_decl
1034 (create_concat_name (Entity (Prefix (gnat_node)),
1035 attribute == Attr_Elab_Body
1036 ? "elabb" : "elabs"),
1037 NULL_TREE, void_ftype, NULL_TREE, 0, 1, 1, 0);
1041 gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
1042 gnu_type = TREE_TYPE (gnu_prefix);
1044 /* If the input is a NULL_EXPR, make a new one. */
1045 if (TREE_CODE (gnu_prefix) == NULL_EXPR)
1047 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1048 gnu_result = build1 (NULL_EXPR, gnu_result_type,
1049 TREE_OPERAND (gnu_prefix, 0));
1057 /* These are just conversions until since representation
1058 clauses for enumerations are handled in the front end. */
1060 int check_p = Do_Range_Check (First (Expressions (gnat_node)));
1062 gnu_result = gnat_to_gnu (First (Expressions (gnat_node)));
1063 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1064 gnu_result = convert_with_check (Etype (gnat_node), gnu_result,
1065 check_p, check_p, 1);
1071 /* These just add or subject the constant 1. Representation
1072 clauses for enumerations are handled in the front-end. */
1073 gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
1074 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1076 if (Do_Range_Check (First (Expressions (gnat_node))))
1078 gnu_expr = protect_multiple_eval (gnu_expr);
1081 (build_binary_op (EQ_EXPR, integer_type_node,
1083 attribute == Attr_Pred
1084 ? TYPE_MIN_VALUE (gnu_result_type)
1085 : TYPE_MAX_VALUE (gnu_result_type)),
1086 gnu_expr, CE_Range_Check_Failed);
1090 = build_binary_op (attribute == Attr_Pred
1091 ? MINUS_EXPR : PLUS_EXPR,
1092 gnu_result_type, gnu_expr,
1093 convert (gnu_result_type, integer_one_node));
1097 case Attr_Unrestricted_Access:
1099 /* Conversions don't change something's address but can cause
1100 us to miss the COMPONENT_REF case below, so strip them off. */
1102 = remove_conversions (gnu_prefix,
1103 ! Must_Be_Byte_Aligned (gnat_node));
1105 /* If we are taking 'Address of an unconstrained object,
1106 this is the pointer to the underlying array. */
1107 gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1109 /* ... fall through ... */
1112 case Attr_Unchecked_Access:
1113 case Attr_Code_Address:
1115 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1117 = build_unary_op (((attribute == Attr_Address
1118 || attribute == Attr_Unrestricted_Access)
1119 && ! Must_Be_Byte_Aligned (gnat_node))
1120 ? ATTR_ADDR_EXPR : ADDR_EXPR,
1121 gnu_result_type, gnu_prefix);
1123 /* For 'Code_Address, find an inner ADDR_EXPR and mark it
1124 so that we don't try to build a trampoline. */
1125 if (attribute == Attr_Code_Address)
1127 for (gnu_expr = gnu_result;
1128 TREE_CODE (gnu_expr) == NOP_EXPR
1129 || TREE_CODE (gnu_expr) == CONVERT_EXPR;
1130 gnu_expr = TREE_OPERAND (gnu_expr, 0))
1131 TREE_CONSTANT (gnu_expr) = 1;
1134 if (TREE_CODE (gnu_expr) == ADDR_EXPR)
1135 TREE_STATIC (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1;
1141 case Attr_Object_Size:
1142 case Attr_Value_Size:
1143 case Attr_Max_Size_In_Storage_Elements:
1145 gnu_expr = gnu_prefix;
1147 /* Remove NOPS from gnu_expr and conversions from gnu_prefix.
1148 We only use GNU_EXPR to see if a COMPONENT_REF was involved. */
1149 while (TREE_CODE (gnu_expr) == NOP_EXPR)
1150 gnu_expr = TREE_OPERAND (gnu_expr, 0);
1152 gnu_prefix = remove_conversions (gnu_prefix, 1);
1154 gnu_type = TREE_TYPE (gnu_prefix);
1156 /* Replace an unconstrained array type with the type of the
1157 underlying array. We can't do this with a call to
1158 maybe_unconstrained_array since we may have a TYPE_DECL.
1159 For 'Max_Size_In_Storage_Elements, use the record type
1160 that will be used to allocate the object and its template. */
1162 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1164 gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
1165 if (attribute != Attr_Max_Size_In_Storage_Elements)
1166 gnu_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)));
1169 /* If we are looking for the size of a field, return the
1170 field size. Otherwise, if the prefix is an object,
1171 or if 'Object_Size or 'Max_Size_In_Storage_Elements has
1172 been specified, the result is the GCC size of the type.
1173 Otherwise, the result is the RM_Size of the type. */
1174 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1175 gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1));
1176 else if (TREE_CODE (gnu_prefix) != TYPE_DECL
1177 || attribute == Attr_Object_Size
1178 || attribute == Attr_Max_Size_In_Storage_Elements)
1180 /* If this is a padded type, the GCC size isn't relevant
1181 to the programmer. Normally, what we want is the RM_Size,
1182 which was set from the specified size, but if it was not
1183 set, we want the size of the relevant field. Using the MAX
1184 of those two produces the right result in all case. Don't
1185 use the size of the field if it's a self-referential type,
1186 since that's never what's wanted. */
1187 if (TREE_CODE (gnu_type) == RECORD_TYPE
1188 && TYPE_IS_PADDING_P (gnu_type)
1189 && TREE_CODE (gnu_expr) == COMPONENT_REF)
1191 gnu_result = rm_size (gnu_type);
1192 if (! (contains_placeholder_p
1193 (DECL_SIZE (TREE_OPERAND (gnu_expr, 1)))))
1195 = size_binop (MAX_EXPR, gnu_result,
1196 DECL_SIZE (TREE_OPERAND (gnu_expr, 1)));
1199 gnu_result = TYPE_SIZE (gnu_type);
1202 gnu_result = rm_size (gnu_type);
1204 if (gnu_result == 0)
1207 /* Deal with a self-referential size by returning the maximum
1208 size for a type and by qualifying the size with
1209 the object for 'Size of an object. */
1211 if (TREE_CODE (gnu_result) != INTEGER_CST
1212 && contains_placeholder_p (gnu_result))
1214 if (TREE_CODE (gnu_prefix) != TYPE_DECL)
1215 gnu_result = build (WITH_RECORD_EXPR, TREE_TYPE (gnu_result),
1216 gnu_result, gnu_prefix);
1218 gnu_result = max_size (gnu_result, 1);
1221 /* If the type contains a template, subtract the size of the
1223 if (TREE_CODE (gnu_type) == RECORD_TYPE
1224 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
1225 gnu_result = size_binop (MINUS_EXPR, gnu_result,
1226 DECL_SIZE (TYPE_FIELDS (gnu_type)));
1228 /* If the type contains a template, subtract the size of the
1230 if (TREE_CODE (gnu_type) == RECORD_TYPE
1231 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
1232 gnu_result = size_binop (MINUS_EXPR, gnu_result,
1233 DECL_SIZE (TYPE_FIELDS (gnu_type)));
1235 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1237 /* Always perform division using unsigned arithmetic as the
1238 size cannot be negative, but may be an overflowed positive
1239 value. This provides correct results for sizes up to 512 MB.
1240 ??? Size should be calculated in storage elements directly. */
1242 if (attribute == Attr_Max_Size_In_Storage_Elements)
1243 gnu_result = convert (sizetype,
1244 fold (build (CEIL_DIV_EXPR, bitsizetype,
1246 bitsize_unit_node)));
1249 case Attr_Alignment:
1250 if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1251 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))
1253 && (TYPE_IS_PADDING_P
1254 (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))))
1255 gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1257 gnu_type = TREE_TYPE (gnu_prefix);
1258 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1261 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1263 = size_int (DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1)));
1265 gnu_result = size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT);
1270 case Attr_Range_Length:
1273 if (INTEGRAL_TYPE_P (gnu_type)
1274 || TREE_CODE (gnu_type) == REAL_TYPE)
1276 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1278 if (attribute == Attr_First)
1279 gnu_result = TYPE_MIN_VALUE (gnu_type);
1280 else if (attribute == Attr_Last)
1281 gnu_result = TYPE_MAX_VALUE (gnu_type);
1285 (MAX_EXPR, get_base_type (gnu_result_type),
1287 (PLUS_EXPR, get_base_type (gnu_result_type),
1288 build_binary_op (MINUS_EXPR,
1289 get_base_type (gnu_result_type),
1290 convert (gnu_result_type,
1291 TYPE_MAX_VALUE (gnu_type)),
1292 convert (gnu_result_type,
1293 TYPE_MIN_VALUE (gnu_type))),
1294 convert (gnu_result_type, integer_one_node)),
1295 convert (gnu_result_type, integer_zero_node));
1299 /* ... fall through ... */
1303 = (Present (Expressions (gnat_node))
1304 ? UI_To_Int (Intval (First (Expressions (gnat_node))))
1307 /* Emit access check if necessary */
1308 if (Do_Access_Check (gnat_node))
1309 gnu_prefix = emit_access_check (gnu_prefix);
1311 /* Make sure any implicit dereference gets done. */
1312 gnu_prefix = maybe_implicit_deref (gnu_prefix);
1313 gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1314 gnu_type = TREE_TYPE (gnu_prefix);
1316 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1318 if (TYPE_CONVENTION_FORTRAN_P (gnu_type))
1323 for (ndim = 1, gnu_type_temp = gnu_type;
1324 TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE
1325 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp));
1326 ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp))
1329 Dimension = ndim + 1 - Dimension;
1332 for (; Dimension > 1; Dimension--)
1333 gnu_type = TREE_TYPE (gnu_type);
1335 if (TREE_CODE (gnu_type) != ARRAY_TYPE)
1338 if (attribute == Attr_First)
1340 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
1341 else if (attribute == Attr_Last)
1343 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
1345 /* 'Length or 'Range_Length. */
1347 tree gnu_compute_type
1348 = gnat_signed_or_unsigned_type
1349 (0, get_base_type (gnu_result_type));
1353 (MAX_EXPR, gnu_compute_type,
1355 (PLUS_EXPR, gnu_compute_type,
1357 (MINUS_EXPR, gnu_compute_type,
1358 convert (gnu_compute_type,
1360 (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)))),
1361 convert (gnu_compute_type,
1363 (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))))),
1364 convert (gnu_compute_type, integer_one_node)),
1365 convert (gnu_compute_type, integer_zero_node));
1368 /* If this has a PLACEHOLDER_EXPR, qualify it by the object
1369 we are handling. Note that these attributes could not
1370 have been used on an unconstrained array type. */
1371 if (TREE_CODE (gnu_result) != INTEGER_CST
1372 && contains_placeholder_p (gnu_result))
1373 gnu_result = build (WITH_RECORD_EXPR, TREE_TYPE (gnu_result),
1374 gnu_result, gnu_prefix);
1379 case Attr_Bit_Position:
1381 case Attr_First_Bit:
1385 HOST_WIDE_INT bitsize;
1386 HOST_WIDE_INT bitpos;
1388 tree gnu_field_bitpos;
1389 tree gnu_field_offset;
1391 enum machine_mode mode;
1392 int unsignedp, volatilep;
1394 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1395 gnu_prefix = remove_conversions (gnu_prefix, 1);
1398 /* We can have 'Bit on any object, but if it isn't a
1399 COMPONENT_REF, the result is zero. Do not allow
1400 'Bit on a bare component, though. */
1401 if (attribute == Attr_Bit
1402 && TREE_CODE (gnu_prefix) != COMPONENT_REF
1403 && TREE_CODE (gnu_prefix) != FIELD_DECL)
1405 gnu_result = integer_zero_node;
1409 else if (TREE_CODE (gnu_prefix) != COMPONENT_REF
1410 && ! (attribute == Attr_Bit_Position
1411 && TREE_CODE (gnu_prefix) == FIELD_DECL))
1414 get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset,
1415 &mode, &unsignedp, &volatilep);
1417 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1420 = bit_position (TREE_OPERAND (gnu_prefix, 1));
1422 = byte_position (TREE_OPERAND (gnu_prefix, 1));
1424 for (gnu_inner = TREE_OPERAND (gnu_prefix, 0);
1425 TREE_CODE (gnu_inner) == COMPONENT_REF
1426 && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1));
1427 gnu_inner = TREE_OPERAND (gnu_inner, 0))
1430 = size_binop (PLUS_EXPR, gnu_field_bitpos,
1431 bit_position (TREE_OPERAND (gnu_inner,
1434 = size_binop (PLUS_EXPR, gnu_field_offset,
1435 byte_position (TREE_OPERAND (gnu_inner,
1439 else if (TREE_CODE (gnu_prefix) == FIELD_DECL)
1441 gnu_field_bitpos = bit_position (gnu_prefix);
1442 gnu_field_offset = byte_position (gnu_prefix);
1446 gnu_field_bitpos = bitsize_zero_node;
1447 gnu_field_offset = size_zero_node;
1453 gnu_result = gnu_field_offset;
1456 case Attr_First_Bit:
1458 gnu_result = size_int (bitpos % BITS_PER_UNIT);
1462 gnu_result = bitsize_int (bitpos % BITS_PER_UNIT);
1464 = size_binop (PLUS_EXPR, gnu_result,
1465 TYPE_SIZE (TREE_TYPE (gnu_prefix)));
1466 gnu_result = size_binop (MINUS_EXPR, gnu_result,
1470 case Attr_Bit_Position:
1471 gnu_result = gnu_field_bitpos;
1475 /* If this has a PLACEHOLDER_EXPR, qualify it by the object
1477 if (TREE_CODE (gnu_result) != INTEGER_CST
1478 && contains_placeholder_p (gnu_result))
1479 gnu_result = build (WITH_RECORD_EXPR, TREE_TYPE (gnu_result),
1480 gnu_result, gnu_prefix);
1487 gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node)));
1488 gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node))));
1490 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1491 gnu_result = build_binary_op (attribute == Attr_Min
1492 ? MIN_EXPR : MAX_EXPR,
1493 gnu_result_type, gnu_lhs, gnu_rhs);
1496 case Attr_Passed_By_Reference:
1497 gnu_result = size_int (default_pass_by_ref (gnu_type)
1498 || must_pass_by_ref (gnu_type));
1499 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1502 case Attr_Component_Size:
1503 if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1504 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))
1506 && (TYPE_IS_PADDING_P
1507 (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))))
1508 gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1510 gnu_prefix = maybe_implicit_deref (gnu_prefix);
1511 gnu_type = TREE_TYPE (gnu_prefix);
1513 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1515 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type))));
1517 while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
1518 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
1519 gnu_type = TREE_TYPE (gnu_type);
1521 if (TREE_CODE (gnu_type) != ARRAY_TYPE)
1524 /* Note this size cannot be self-referential. */
1525 gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type));
1526 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1530 case Attr_Null_Parameter:
1531 /* This is just a zero cast to the pointer type for
1532 our prefix and dereferenced. */
1533 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1535 = build_unary_op (INDIRECT_REF, NULL_TREE,
1536 convert (build_pointer_type (gnu_result_type),
1537 integer_zero_node));
1538 TREE_PRIVATE (gnu_result) = 1;
1541 case Attr_Mechanism_Code:
1544 Entity_Id gnat_obj = Entity (Prefix (gnat_node));
1547 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1548 if (Present (Expressions (gnat_node)))
1550 int i = UI_To_Int (Intval (First (Expressions (gnat_node))));
1552 for (gnat_obj = First_Formal (gnat_obj); i > 1;
1553 i--, gnat_obj = Next_Formal (gnat_obj))
1557 code = Mechanism (gnat_obj);
1558 if (code == Default)
1559 code = ((present_gnu_tree (gnat_obj)
1560 && (DECL_BY_REF_P (get_gnu_tree (gnat_obj))
1561 || (DECL_BY_COMPONENT_PTR_P
1562 (get_gnu_tree (gnat_obj)))))
1563 ? By_Reference : By_Copy);
1564 gnu_result = convert (gnu_result_type, size_int (- code));
1569 /* Say we have an unimplemented attribute. Then set the
1570 value to be returned to be a zero and hope that's something
1571 we can convert to the type of this attribute. */
1573 post_error ("unimplemented attribute", gnat_node);
1574 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1575 gnu_result = integer_zero_node;
1579 /* If this is an attribute where the prefix was unused,
1580 force a use of it if it has a side-effect. But don't do it if
1581 the prefix is just an entity name. However, if an access check
1582 is needed, we must do it. See second example in AARM 11.6(5.e). */
1583 if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix)
1584 && (! Is_Entity_Name (Prefix (gnat_node))
1585 || Do_Access_Check (gnat_node)))
1586 gnu_result = fold (build (COMPOUND_EXPR, TREE_TYPE (gnu_result),
1587 gnu_prefix, gnu_result));
1592 /* Like 'Access as far as we are concerned. */
1593 gnu_result = gnat_to_gnu (Prefix (gnat_node));
1594 gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result);
1595 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1599 case N_Extension_Aggregate:
1603 /* ??? It is wrong to evaluate the type now, but there doesn't
1604 seem to be any other practical way of doing it. */
1606 gnu_aggr_type = gnu_result_type
1607 = get_unpadded_type (Etype (gnat_node));
1609 if (TREE_CODE (gnu_result_type) == RECORD_TYPE
1610 && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type))
1612 = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_result_type)));
1614 if (Null_Record_Present (gnat_node))
1615 gnu_result = build_constructor (gnu_aggr_type, NULL_TREE);
1617 else if (TREE_CODE (gnu_aggr_type) == RECORD_TYPE)
1619 = assoc_to_constructor (First (Component_Associations (gnat_node)),
1621 else if (TREE_CODE (gnu_aggr_type) == UNION_TYPE)
1623 /* The first element is the discrimant, which we ignore. The
1624 next is the field we're building. Convert the expression
1625 to the type of the field and then to the union type. */
1627 = Next (First (Component_Associations (gnat_node)));
1628 Entity_Id gnat_field = Entity (First (Choices (gnat_assoc)));
1630 = TREE_TYPE (gnat_to_gnu_entity (gnat_field, NULL_TREE, 0));
1632 gnu_result = convert (gnu_field_type,
1633 gnat_to_gnu (Expression (gnat_assoc)));
1635 else if (TREE_CODE (gnu_aggr_type) == ARRAY_TYPE)
1636 gnu_result = pos_to_constructor (First (Expressions (gnat_node)),
1638 Component_Type (Etype (gnat_node)));
1639 else if (TREE_CODE (gnu_aggr_type) == COMPLEX_TYPE)
1642 (COMPLEX_EXPR, gnu_aggr_type,
1643 gnat_to_gnu (Expression (First
1644 (Component_Associations (gnat_node)))),
1645 gnat_to_gnu (Expression
1647 (First (Component_Associations (gnat_node))))));
1651 gnu_result = convert (gnu_result_type, gnu_result);
1656 gnu_result = null_pointer_node;
1657 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1660 case N_Type_Conversion:
1661 case N_Qualified_Expression:
1662 /* Get the operand expression. */
1663 gnu_result = gnat_to_gnu (Expression (gnat_node));
1664 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1667 = convert_with_check (Etype (gnat_node), gnu_result,
1668 Do_Overflow_Check (gnat_node),
1669 Do_Range_Check (Expression (gnat_node)),
1670 Nkind (gnat_node) == N_Type_Conversion
1671 && Float_Truncate (gnat_node));
1674 case N_Unchecked_Type_Conversion:
1675 gnu_result = gnat_to_gnu (Expression (gnat_node));
1676 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1678 /* If the result is a pointer type, see if we are improperly
1679 converting to a stricter alignment. */
1681 if (STRICT_ALIGNMENT && POINTER_TYPE_P (gnu_result_type)
1682 && IN (Ekind (Etype (gnat_node)), Access_Kind))
1684 unsigned int align = known_alignment (gnu_result);
1685 tree gnu_obj_type = TREE_TYPE (gnu_result_type);
1687 = TREE_CODE (gnu_obj_type) == FUNCTION_TYPE
1688 ? FUNCTION_BOUNDARY : TYPE_ALIGN (gnu_obj_type);
1690 if (align != 0 && align < oalign && ! TYPE_ALIGN_OK (gnu_obj_type))
1691 post_error_ne_tree_2
1692 ("?source alignment (^) < alignment of & (^)",
1693 gnat_node, Designated_Type (Etype (gnat_node)),
1694 size_int (align / BITS_PER_UNIT), oalign / BITS_PER_UNIT);
1697 gnu_result = unchecked_convert (gnu_result_type, gnu_result);
1703 tree gnu_object = gnat_to_gnu (Left_Opnd (gnat_node));
1704 Node_Id gnat_range = Right_Opnd (gnat_node);
1708 /* GNAT_RANGE is either an N_Range node or an identifier
1709 denoting a subtype. */
1710 if (Nkind (gnat_range) == N_Range)
1712 gnu_low = gnat_to_gnu (Low_Bound (gnat_range));
1713 gnu_high = gnat_to_gnu (High_Bound (gnat_range));
1715 else if (Nkind (gnat_range) == N_Identifier
1716 || Nkind (gnat_range) == N_Expanded_Name)
1718 tree gnu_range_type = get_unpadded_type (Entity (gnat_range));
1720 gnu_low = TYPE_MIN_VALUE (gnu_range_type);
1721 gnu_high = TYPE_MAX_VALUE (gnu_range_type);
1726 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1728 /* If LOW and HIGH are identical, perform an equality test.
1729 Otherwise, ensure that GNU_OBJECT is only evaluated once
1730 and perform a full range test. */
1731 if (operand_equal_p (gnu_low, gnu_high, 0))
1732 gnu_result = build_binary_op (EQ_EXPR, gnu_result_type,
1733 gnu_object, gnu_low);
1736 gnu_object = protect_multiple_eval (gnu_object);
1738 = build_binary_op (TRUTH_ANDIF_EXPR, gnu_result_type,
1739 build_binary_op (GE_EXPR, gnu_result_type,
1740 gnu_object, gnu_low),
1741 build_binary_op (LE_EXPR, gnu_result_type,
1742 gnu_object, gnu_high));
1745 if (Nkind (gnat_node) == N_Not_In)
1746 gnu_result = invert_truthvalue (gnu_result);
1751 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
1752 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
1753 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1754 gnu_result = build_binary_op (FLOAT_TYPE_P (gnu_result_type)
1756 : (Rounded_Result (gnat_node)
1757 ? ROUND_DIV_EXPR : TRUNC_DIV_EXPR),
1758 gnu_result_type, gnu_lhs, gnu_rhs);
1761 case N_And_Then: case N_Or_Else:
1763 enum tree_code code = gnu_codes[Nkind (gnat_node)];
1766 /* The elaboration of the RHS may generate code. If so,
1767 we need to make sure it gets executed after the LHS. */
1768 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
1770 gnu_rhs_side = expand_start_stmt_expr (/*has_scope=*/1);
1771 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
1772 expand_end_stmt_expr (gnu_rhs_side);
1773 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1775 if (RTL_EXPR_SEQUENCE (gnu_rhs_side) != 0)
1776 gnu_rhs = build (COMPOUND_EXPR, gnu_result_type, gnu_rhs_side,
1779 gnu_result = build_binary_op (code, gnu_result_type, gnu_lhs, gnu_rhs);
1783 case N_Op_Or: case N_Op_And: case N_Op_Xor:
1784 /* These can either be operations on booleans or on modular types.
1785 Fall through for boolean types since that's the way GNU_CODES is
1787 if (IN (Ekind (Underlying_Type (Etype (gnat_node))),
1788 Modular_Integer_Kind))
1791 = (Nkind (gnat_node) == N_Op_Or ? BIT_IOR_EXPR
1792 : Nkind (gnat_node) == N_Op_And ? BIT_AND_EXPR
1795 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
1796 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
1797 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1798 gnu_result = build_binary_op (code, gnu_result_type,
1803 /* ... fall through ... */
1805 case N_Op_Eq: case N_Op_Ne: case N_Op_Lt:
1806 case N_Op_Le: case N_Op_Gt: case N_Op_Ge:
1807 case N_Op_Add: case N_Op_Subtract: case N_Op_Multiply:
1808 case N_Op_Mod: case N_Op_Rem:
1809 case N_Op_Rotate_Left:
1810 case N_Op_Rotate_Right:
1811 case N_Op_Shift_Left:
1812 case N_Op_Shift_Right:
1813 case N_Op_Shift_Right_Arithmetic:
1815 enum tree_code code = gnu_codes[Nkind (gnat_node)];
1818 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
1819 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
1820 gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
1822 /* If this is a comparison operator, convert any references to
1823 an unconstrained array value into a reference to the
1825 if (TREE_CODE_CLASS (code) == '<')
1827 gnu_lhs = maybe_unconstrained_array (gnu_lhs);
1828 gnu_rhs = maybe_unconstrained_array (gnu_rhs);
1831 /* If the result type is a private type, its full view may be a
1832 numeric subtype. The representation we need is that of its base
1833 type, given that it is the result of an arithmetic operation. */
1834 else if (Is_Private_Type (Etype (gnat_node)))
1835 gnu_type = gnu_result_type
1836 = get_unpadded_type (Base_Type (Full_View (Etype (gnat_node))));
1838 /* If this is a shift whose count is not guaranteed to be correct,
1839 we need to adjust the shift count. */
1840 if (IN (Nkind (gnat_node), N_Op_Shift)
1841 && ! Shift_Count_OK (gnat_node))
1843 tree gnu_count_type = get_base_type (TREE_TYPE (gnu_rhs));
1845 = convert (gnu_count_type, TYPE_SIZE (gnu_type));
1847 if (Nkind (gnat_node) == N_Op_Rotate_Left
1848 || Nkind (gnat_node) == N_Op_Rotate_Right)
1849 gnu_rhs = build_binary_op (TRUNC_MOD_EXPR, gnu_count_type,
1850 gnu_rhs, gnu_max_shift);
1851 else if (Nkind (gnat_node) == N_Op_Shift_Right_Arithmetic)
1854 (MIN_EXPR, gnu_count_type,
1855 build_binary_op (MINUS_EXPR,
1858 convert (gnu_count_type,
1863 /* For right shifts, the type says what kind of shift to do,
1864 so we may need to choose a different type. */
1865 if (Nkind (gnat_node) == N_Op_Shift_Right
1866 && ! TREE_UNSIGNED (gnu_type))
1867 gnu_type = gnat_unsigned_type (gnu_type);
1868 else if (Nkind (gnat_node) == N_Op_Shift_Right_Arithmetic
1869 && TREE_UNSIGNED (gnu_type))
1870 gnu_type = gnat_signed_type (gnu_type);
1872 if (gnu_type != gnu_result_type)
1874 gnu_lhs = convert (gnu_type, gnu_lhs);
1875 gnu_rhs = convert (gnu_type, gnu_rhs);
1878 gnu_result = build_binary_op (code, gnu_type, gnu_lhs, gnu_rhs);
1880 /* If this is a logical shift with the shift count not verified,
1881 we must return zero if it is too large. We cannot compensate
1882 above in this case. */
1883 if ((Nkind (gnat_node) == N_Op_Shift_Left
1884 || Nkind (gnat_node) == N_Op_Shift_Right)
1885 && ! Shift_Count_OK (gnat_node))
1889 build_binary_op (GE_EXPR, integer_type_node,
1891 convert (TREE_TYPE (gnu_rhs),
1892 TYPE_SIZE (gnu_type))),
1893 convert (gnu_type, integer_zero_node),
1898 case N_Conditional_Expression:
1900 tree gnu_cond = gnat_to_gnu (First (Expressions (gnat_node)));
1901 tree gnu_true = gnat_to_gnu (Next (First (Expressions (gnat_node))));
1903 = gnat_to_gnu (Next (Next (First (Expressions (gnat_node)))));
1905 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1906 gnu_result = build_cond_expr (gnu_result_type,
1907 gnat_truthvalue_conversion (gnu_cond),
1908 gnu_true, gnu_false);
1913 gnu_result = gnat_to_gnu (Right_Opnd (gnat_node));
1914 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1918 /* This case can apply to a boolean or a modular type.
1919 Fall through for a boolean operand since GNU_CODES is set
1920 up to handle this. */
1921 if (IN (Ekind (Etype (gnat_node)), Modular_Integer_Kind))
1923 gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
1924 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1925 gnu_result = build_unary_op (BIT_NOT_EXPR, gnu_result_type,
1930 /* ... fall through ... */
1932 case N_Op_Minus: case N_Op_Abs:
1933 gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
1935 if (Ekind (Etype (gnat_node)) != E_Private_Type)
1936 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1938 gnu_result_type = get_unpadded_type (Base_Type
1939 (Full_View (Etype (gnat_node))));
1941 gnu_result = build_unary_op (gnu_codes[Nkind (gnat_node)],
1942 gnu_result_type, gnu_expr);
1950 gnat_temp = Expression (gnat_node);
1952 /* The Expression operand can either be an N_Identifier or
1953 Expanded_Name, which must represent a type, or a
1954 N_Qualified_Expression, which contains both the object type and an
1955 initial value for the object. */
1956 if (Nkind (gnat_temp) == N_Identifier
1957 || Nkind (gnat_temp) == N_Expanded_Name)
1958 gnu_type = gnat_to_gnu_type (Entity (gnat_temp));
1959 else if (Nkind (gnat_temp) == N_Qualified_Expression)
1961 Entity_Id gnat_desig_type
1962 = Designated_Type (Underlying_Type (Etype (gnat_node)));
1964 gnu_init = gnat_to_gnu (Expression (gnat_temp));
1966 gnu_init = maybe_unconstrained_array (gnu_init);
1967 if (Do_Range_Check (Expression (gnat_temp)))
1968 gnu_init = emit_range_check (gnu_init, gnat_desig_type);
1970 if (Is_Elementary_Type (gnat_desig_type)
1971 || Is_Constrained (gnat_desig_type))
1973 gnu_type = gnat_to_gnu_type (gnat_desig_type);
1974 gnu_init = convert (gnu_type, gnu_init);
1978 gnu_type = gnat_to_gnu_type (Etype (Expression (gnat_temp)));
1979 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1980 gnu_type = TREE_TYPE (gnu_init);
1982 gnu_init = convert (gnu_type, gnu_init);
1988 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1989 return build_allocator (gnu_type, gnu_init, gnu_result_type,
1990 Procedure_To_Call (gnat_node),
1991 Storage_Pool (gnat_node));
1995 /***************************/
1996 /* Chapter 5: Statements: */
1997 /***************************/
2000 if (! type_annotate_only)
2002 tree gnu_label = gnat_to_gnu (Identifier (gnat_node));
2003 Node_Id gnat_parent = Parent (gnat_node);
2005 expand_label (gnu_label);
2007 /* If this is the first label of an exception handler, we must
2008 mark that any CALL_INSN can jump to it. */
2009 if (Present (gnat_parent)
2010 && Nkind (gnat_parent) == N_Exception_Handler
2011 && First (Statements (gnat_parent)) == gnat_node)
2012 nonlocal_goto_handler_labels
2013 = gen_rtx_EXPR_LIST (VOIDmode, label_rtx (gnu_label),
2014 nonlocal_goto_handler_labels);
2018 case N_Null_Statement:
2021 case N_Assignment_Statement:
2022 if (type_annotate_only)
2025 /* Get the LHS and RHS of the statement and convert any reference to an
2026 unconstrained array into a reference to the underlying array. */
2027 gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node)));
2029 = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node)));
2031 set_lineno (gnat_node, 1);
2033 /* If range check is needed, emit code to generate it */
2034 if (Do_Range_Check (Expression (gnat_node)))
2035 gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node)));
2037 /* If either side's type has a size that overflows, convert this
2038 into raise of Storage_Error: execution shouldn't have gotten
2040 if ((TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_lhs))) == INTEGER_CST
2041 && TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_lhs))))
2042 || (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_rhs))) == INTEGER_CST
2043 && TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_rhs)))))
2044 expand_expr_stmt (build_call_raise (SE_Object_Too_Large));
2046 expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE,
2050 case N_If_Statement:
2051 /* Start an IF statement giving the condition. */
2052 gnu_expr = gnat_to_gnu (Condition (gnat_node));
2053 set_lineno (gnat_node, 1);
2054 expand_start_cond (gnu_expr, 0);
2056 /* Generate code for the statements to be executed if the condition
2059 for (gnat_temp = First (Then_Statements (gnat_node));
2060 Present (gnat_temp);
2061 gnat_temp = Next (gnat_temp))
2062 gnat_to_code (gnat_temp);
2064 /* Generate each of the "else if" parts. */
2065 if (Present (Elsif_Parts (gnat_node)))
2067 for (gnat_temp = First (Elsif_Parts (gnat_node));
2068 Present (gnat_temp);
2069 gnat_temp = Next (gnat_temp))
2071 Node_Id gnat_statement;
2073 expand_start_else ();
2075 /* Set up the line numbers for each condition we test. */
2076 set_lineno (Condition (gnat_temp), 1);
2077 expand_elseif (gnat_to_gnu (Condition (gnat_temp)));
2079 for (gnat_statement = First (Then_Statements (gnat_temp));
2080 Present (gnat_statement);
2081 gnat_statement = Next (gnat_statement))
2082 gnat_to_code (gnat_statement);
2086 /* Finally, handle any statements in the "else" part. */
2087 if (Present (Else_Statements (gnat_node)))
2089 expand_start_else ();
2091 for (gnat_temp = First (Else_Statements (gnat_node));
2092 Present (gnat_temp);
2093 gnat_temp = Next (gnat_temp))
2094 gnat_to_code (gnat_temp);
2100 case N_Case_Statement:
2103 Node_Id gnat_choice;
2105 Node_Id gnat_statement;
2107 gnu_expr = gnat_to_gnu (Expression (gnat_node));
2108 gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
2110 set_lineno (gnat_node, 1);
2111 expand_start_case (1, gnu_expr, TREE_TYPE (gnu_expr), "case");
2113 for (gnat_when = First_Non_Pragma (Alternatives (gnat_node));
2114 Present (gnat_when);
2115 gnat_when = Next_Non_Pragma (gnat_when))
2117 /* First compile all the different case choices for the current
2118 WHEN alternative. */
2120 for (gnat_choice = First (Discrete_Choices (gnat_when));
2121 Present (gnat_choice); gnat_choice = Next (gnat_choice))
2125 gnu_label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
2127 set_lineno (gnat_choice, 1);
2128 switch (Nkind (gnat_choice))
2131 /* Abort on all errors except range empty, which
2132 means we ignore this alternative. */
2134 = pushcase_range (gnat_to_gnu (Low_Bound (gnat_choice)),
2135 gnat_to_gnu (High_Bound (gnat_choice)),
2136 convert, gnu_label, 0);
2138 if (error_code != 0 && error_code != 4)
2142 case N_Subtype_Indication:
2145 (gnat_to_gnu (Low_Bound (Range_Expression
2146 (Constraint (gnat_choice)))),
2147 gnat_to_gnu (High_Bound (Range_Expression
2148 (Constraint (gnat_choice)))),
2149 convert, gnu_label, 0);
2151 if (error_code != 0 && error_code != 4)
2156 case N_Expanded_Name:
2157 /* This represents either a subtype range or a static value
2158 of some kind; Ekind says which. If a static value,
2159 fall through to the next case. */
2160 if (IN (Ekind (Entity (gnat_choice)), Type_Kind))
2162 tree type = get_unpadded_type (Entity (gnat_choice));
2165 = pushcase_range (fold (TYPE_MIN_VALUE (type)),
2166 fold (TYPE_MAX_VALUE (type)),
2167 convert, gnu_label, 0);
2169 if (error_code != 0 && error_code != 4)
2173 /* ... fall through ... */
2174 case N_Character_Literal:
2175 case N_Integer_Literal:
2176 if (pushcase (gnat_to_gnu (gnat_choice), convert,
2181 case N_Others_Choice:
2182 if (pushcase (NULL_TREE, convert, gnu_label, 0))
2191 /* After compiling the choices attached to the WHEN compile the
2192 body of statements that have to be executed, should the
2193 "WHEN ... =>" be taken. Push a binding level here in case
2194 variables are declared since we want them to be local to this
2195 set of statements instead of the block containing the Case
2198 expand_start_bindings (0);
2199 for (gnat_statement = First (Statements (gnat_when));
2200 Present (gnat_statement);
2201 gnat_statement = Next (gnat_statement))
2202 gnat_to_code (gnat_statement);
2204 /* Communicate to GCC that we are done with the current WHEN,
2205 i.e. insert a "break" statement. */
2206 expand_exit_something ();
2207 expand_end_bindings (getdecls (), kept_level_p (), 0);
2208 poplevel (kept_level_p (), 1, 0);
2211 expand_end_case (gnu_expr);
2215 case N_Loop_Statement:
2217 /* The loop variable in GCC form, if any. */
2218 tree gnu_loop_var = NULL_TREE;
2219 /* PREINCREMENT_EXPR or PREDECREMENT_EXPR. */
2220 enum tree_code gnu_update = ERROR_MARK;
2221 /* Used if this is a named loop for so EXIT can work. */
2222 struct nesting *loop_id;
2223 /* Condition to continue loop tested at top of loop. */
2224 tree gnu_top_condition = integer_one_node;
2225 /* Similar, but tested at bottom of loop. */
2226 tree gnu_bottom_condition = integer_one_node;
2227 Node_Id gnat_statement;
2228 Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node);
2229 Node_Id gnat_top_condition = Empty;
2230 int enclosing_if_p = 0;
2232 /* Set the condition that under which the loop should continue.
2233 For "LOOP .... END LOOP;" the condition is always true. */
2234 if (No (gnat_iter_scheme))
2236 /* The case "WHILE condition LOOP ..... END LOOP;" */
2237 else if (Present (Condition (gnat_iter_scheme)))
2238 gnat_top_condition = Condition (gnat_iter_scheme);
2241 /* We have an iteration scheme. */
2242 Node_Id gnat_loop_spec
2243 = Loop_Parameter_Specification (gnat_iter_scheme);
2244 Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec);
2245 Entity_Id gnat_type = Etype (gnat_loop_var);
2246 tree gnu_type = get_unpadded_type (gnat_type);
2247 tree gnu_low = TYPE_MIN_VALUE (gnu_type);
2248 tree gnu_high = TYPE_MAX_VALUE (gnu_type);
2249 int reversep = Reverse_Present (gnat_loop_spec);
2250 tree gnu_first = reversep ? gnu_high : gnu_low;
2251 tree gnu_last = reversep ? gnu_low : gnu_high;
2252 enum tree_code end_code = reversep ? GE_EXPR : LE_EXPR;
2253 tree gnu_base_type = get_base_type (gnu_type);
2255 = (reversep ? TYPE_MIN_VALUE (gnu_base_type)
2256 : TYPE_MAX_VALUE (gnu_base_type));
2258 /* We know the loop variable will not overflow if GNU_LAST is
2259 a constant and is not equal to GNU_LIMIT. If it might
2260 overflow, we have to move the limit test to the end of
2261 the loop. In that case, we have to test for an
2262 empty loop outside the loop. */
2263 if (TREE_CODE (gnu_last) != INTEGER_CST
2264 || TREE_CODE (gnu_limit) != INTEGER_CST
2265 || tree_int_cst_equal (gnu_last, gnu_limit))
2267 gnu_expr = build_binary_op (LE_EXPR, integer_type_node,
2269 set_lineno (gnat_loop_spec, 1);
2270 expand_start_cond (gnu_expr, 0);
2274 /* Open a new nesting level that will surround the loop to declare
2275 the loop index variable. */
2277 expand_start_bindings (0);
2279 /* Declare the loop index and set it to its initial value. */
2280 gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1);
2281 if (DECL_BY_REF_P (gnu_loop_var))
2282 gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE,
2285 /* The loop variable might be a padded type, so use `convert' to
2286 get a reference to the inner variable if so. */
2287 gnu_loop_var = convert (get_base_type (gnu_type), gnu_loop_var);
2289 /* Set either the top or bottom exit condition as
2290 appropriate depending on whether we know an overflow
2291 cannot occur or not. */
2293 gnu_bottom_condition
2294 = build_binary_op (NE_EXPR, integer_type_node,
2295 gnu_loop_var, gnu_last);
2298 = build_binary_op (end_code, integer_type_node,
2299 gnu_loop_var, gnu_last);
2301 gnu_update = reversep ? PREDECREMENT_EXPR : PREINCREMENT_EXPR;
2304 set_lineno (gnat_node, 1);
2306 loop_id = expand_start_loop_continue_elsewhere (1);
2308 loop_id = expand_start_loop (1);
2310 /* If the loop was named, have the name point to this loop. In this
2311 case, the association is not a ..._DECL node; in fact, it isn't
2312 a GCC tree node at all. Since this name is referenced inside
2313 the loop, do it before we process the statements of the loop. */
2314 if (Present (Identifier (gnat_node)))
2316 tree gnu_loop_id = make_node (GNAT_LOOP_ID);
2318 TREE_LOOP_ID (gnu_loop_id) = loop_id;
2319 save_gnu_tree (Entity (Identifier (gnat_node)), gnu_loop_id, 1);
2322 set_lineno (gnat_node, 1);
2324 /* We must evaluate the condition after we've entered the
2325 loop so that any expression actions get done in the right
2327 if (Present (gnat_top_condition))
2328 gnu_top_condition = gnat_to_gnu (gnat_top_condition);
2330 expand_exit_loop_top_cond (0, gnu_top_condition);
2332 /* Make the loop body into its own block, so any allocated
2333 storage will be released every iteration. This is needed
2334 for stack allocation. */
2338 = tree_cons (gnu_bottom_condition, NULL_TREE, gnu_block_stack);
2339 expand_start_bindings (0);
2341 for (gnat_statement = First (Statements (gnat_node));
2342 Present (gnat_statement);
2343 gnat_statement = Next (gnat_statement))
2344 gnat_to_code (gnat_statement);
2346 expand_end_bindings (getdecls (), kept_level_p (), 0);
2347 poplevel (kept_level_p (), 1, 0);
2348 gnu_block_stack = TREE_CHAIN (gnu_block_stack);
2350 set_lineno (gnat_node, 1);
2351 expand_exit_loop_if_false (0, gnu_bottom_condition);
2355 expand_loop_continue_here ();
2356 gnu_expr = build_binary_op (gnu_update, TREE_TYPE (gnu_loop_var),
2358 convert (TREE_TYPE (gnu_loop_var),
2360 set_lineno (gnat_iter_scheme, 1);
2361 expand_expr_stmt (gnu_expr);
2364 set_lineno (gnat_node, 1);
2369 /* Close the nesting level that sourround the loop that was used to
2370 declare the loop index variable. */
2371 set_lineno (gnat_node, 1);
2372 expand_end_bindings (getdecls (), 1, 0);
2378 set_lineno (gnat_node, 1);
2384 case N_Block_Statement:
2386 gnu_block_stack = tree_cons (NULL_TREE, NULL_TREE, gnu_block_stack);
2387 expand_start_bindings (0);
2388 process_decls (Declarations (gnat_node), Empty, Empty, 1, 1);
2389 gnat_to_code (Handled_Statement_Sequence (gnat_node));
2390 expand_end_bindings (getdecls (), kept_level_p (), 0);
2391 poplevel (kept_level_p (), 1, 0);
2392 gnu_block_stack = TREE_CHAIN (gnu_block_stack);
2393 if (Present (Identifier (gnat_node)))
2394 mark_out_of_scope (Entity (Identifier (gnat_node)));
2397 case N_Exit_Statement:
2399 /* Which loop to exit, NULL if the current loop. */
2400 struct nesting *loop_id = 0;
2401 /* The GCC version of the optional GNAT condition node attached to the
2402 exit statement. Exit the loop if this is false. */
2403 tree gnu_cond = integer_zero_node;
2405 if (Present (Name (gnat_node)))
2407 = TREE_LOOP_ID (get_gnu_tree (Entity (Name (gnat_node))));
2409 if (Present (Condition (gnat_node)))
2410 gnu_cond = invert_truthvalue (gnat_truthvalue_conversion
2411 (gnat_to_gnu (Condition (gnat_node))));
2413 set_lineno (gnat_node, 1);
2414 expand_exit_loop_if_false (loop_id, gnu_cond);
2418 case N_Return_Statement:
2419 if (type_annotate_only)
2423 /* The gnu function type of the subprogram currently processed. */
2424 tree gnu_subprog_type = TREE_TYPE (current_function_decl);
2425 /* The return value from the subprogram. */
2426 tree gnu_ret_val = 0;
2428 /* If we are dealing with a "return;" from an Ada procedure with
2429 parameters passed by copy in copy out, we need to return a record
2430 containing the final values of these parameters. If the list
2431 contains only one entry, return just that entry.
2433 For a full description of the copy in copy out parameter mechanism,
2434 see the part of the gnat_to_gnu_entity routine dealing with the
2435 translation of subprograms.
2437 But if we have a return label defined, convert this into
2438 a branch to that label. */
2440 if (TREE_VALUE (gnu_return_label_stack) != 0)
2441 expand_goto (TREE_VALUE (gnu_return_label_stack));
2443 else if (TYPE_CI_CO_LIST (gnu_subprog_type) != NULL_TREE)
2445 if (list_length (TYPE_CI_CO_LIST (gnu_subprog_type)) == 1)
2446 gnu_ret_val = TREE_VALUE (TYPE_CI_CO_LIST (gnu_subprog_type));
2449 = build_constructor (TREE_TYPE (gnu_subprog_type),
2450 TYPE_CI_CO_LIST (gnu_subprog_type));
2453 /* If the Ada subprogram is a function, we just need to return the
2454 expression. If the subprogram returns an unconstrained
2455 array, we have to allocate a new version of the result and
2456 return it. If we return by reference, return a pointer. */
2458 else if (Present (Expression (gnat_node)))
2460 gnu_ret_val = gnat_to_gnu (Expression (gnat_node));
2462 /* Do not remove the padding from GNU_RET_VAL if the inner
2463 type is self-referential since we want to allocate the fixed
2464 size in that case. */
2465 if (TREE_CODE (gnu_ret_val) == COMPONENT_REF
2466 && (TYPE_IS_PADDING_P
2467 (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0))))
2468 && contains_placeholder_p
2469 (TYPE_SIZE (TREE_TYPE (gnu_ret_val))))
2470 gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0);
2472 if (TYPE_RETURNS_BY_REF_P (gnu_subprog_type)
2473 || By_Ref (gnat_node))
2474 gnu_ret_val = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val);
2476 else if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type))
2478 gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
2480 /* We have two cases: either the function returns with
2481 depressed stack or not. If not, we allocate on the
2482 secondary stack. If so, we allocate in the stack frame.
2483 if no copy is needed, the front end will set By_Ref,
2484 which we handle in the case above. */
2485 if (TYPE_RETURNS_STACK_DEPRESSED (gnu_subprog_type))
2487 = build_allocator (TREE_TYPE (gnu_ret_val), gnu_ret_val,
2488 TREE_TYPE (gnu_subprog_type), 0, -1);
2491 = build_allocator (TREE_TYPE (gnu_ret_val), gnu_ret_val,
2492 TREE_TYPE (gnu_subprog_type),
2493 Procedure_To_Call (gnat_node),
2494 Storage_Pool (gnat_node));
2498 set_lineno (gnat_node, 1);
2500 expand_return (build_binary_op (MODIFY_EXPR, NULL_TREE,
2501 DECL_RESULT (current_function_decl),
2504 expand_null_return ();
2509 case N_Goto_Statement:
2510 if (type_annotate_only)
2513 gnu_expr = gnat_to_gnu (Name (gnat_node));
2514 TREE_USED (gnu_expr) = 1;
2515 set_lineno (gnat_node, 1);
2516 expand_goto (gnu_expr);
2519 /****************************/
2520 /* Chapter 6: Subprograms: */
2521 /****************************/
2523 case N_Subprogram_Declaration:
2524 /* Unless there is a freeze node, declare the subprogram. We consider
2525 this a "definition" even though we're not generating code for
2526 the subprogram because we will be making the corresponding GCC
2529 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
2530 gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node)),
2535 case N_Abstract_Subprogram_Declaration:
2536 /* This subprogram doesn't exist for code generation purposes, but we
2537 have to elaborate the types of any parameters, unless they are
2538 imported types (nothing to generate in this case). */
2540 = First_Formal (Defining_Entity (Specification (gnat_node)));
2541 Present (gnat_temp);
2542 gnat_temp = Next_Formal_With_Extras (gnat_temp))
2543 if (Is_Itype (Etype (gnat_temp))
2544 && !From_With_Type (Etype (gnat_temp)))
2545 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
2549 case N_Defining_Program_Unit_Name:
2550 /* For a child unit identifier go up a level to get the
2551 specificaton. We get this when we try to find the spec of
2552 a child unit package that is the compilation unit being compiled. */
2553 gnat_to_code (Parent (gnat_node));
2556 case N_Subprogram_Body:
2558 /* Save debug output mode in case it is reset. */
2559 enum debug_info_type save_write_symbols = write_symbols;
2560 const struct gcc_debug_hooks *const save_debug_hooks = debug_hooks;
2561 /* Definining identifier of a parameter to the subprogram. */
2562 Entity_Id gnat_param;
2563 /* The defining identifier for the subprogram body. Note that if a
2564 specification has appeared before for this body, then the identifier
2565 occurring in that specification will also be a defining identifier
2566 and all the calls to this subprogram will point to that
2568 Entity_Id gnat_subprog_id
2569 = (Present (Corresponding_Spec (gnat_node))
2570 ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node));
2572 /* The FUNCTION_DECL node corresponding to the subprogram spec. */
2573 tree gnu_subprog_decl;
2574 /* The FUNCTION_TYPE node corresponding to the subprogram spec. */
2575 tree gnu_subprog_type;
2578 /* If this is a generic object or if it has been eliminated,
2581 if (Ekind (gnat_subprog_id) == E_Generic_Procedure
2582 || Ekind (gnat_subprog_id) == E_Generic_Function
2583 || Is_Eliminated (gnat_subprog_id))
2586 /* If debug information is suppressed for the subprogram,
2587 turn debug mode off for the duration of processing. */
2588 if (Debug_Info_Off (gnat_subprog_id))
2590 write_symbols = NO_DEBUG;
2591 debug_hooks = &do_nothing_debug_hooks;
2594 /* If this subprogram acts as its own spec, define it. Otherwise,
2595 just get the already-elaborated tree node. However, if this
2596 subprogram had its elaboration deferred, we will already have
2597 made a tree node for it. So treat it as not being defined in
2598 that case. Such a subprogram cannot have an address clause or
2599 a freeze node, so this test is safe, though it does disable
2600 some otherwise-useful error checking. */
2602 = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE,
2603 Acts_As_Spec (gnat_node)
2604 && ! present_gnu_tree (gnat_subprog_id));
2606 gnu_subprog_type = TREE_TYPE (gnu_subprog_decl);
2608 /* Set the line number in the decl to correspond to that of
2609 the body so that the line number notes are written
2611 set_lineno (gnat_node, 0);
2612 DECL_SOURCE_FILE (gnu_subprog_decl) = input_filename;
2613 DECL_SOURCE_LINE (gnu_subprog_decl) = lineno;
2615 begin_subprog_body (gnu_subprog_decl);
2616 set_lineno (gnat_node, 1);
2619 gnu_block_stack = tree_cons (NULL_TREE, NULL_TREE, gnu_block_stack);
2620 expand_start_bindings (0);
2622 gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
2624 /* If there are OUT parameters, we need to ensure that the
2625 return statement properly copies them out. We do this by
2626 making a new block and converting any inner return into a goto
2627 to a label at the end of the block. */
2629 if (gnu_cico_list != 0)
2631 gnu_return_label_stack
2632 = tree_cons (NULL_TREE,
2633 build_decl (LABEL_DECL, NULL_TREE, NULL_TREE),
2634 gnu_return_label_stack);
2636 expand_start_bindings (0);
2639 gnu_return_label_stack
2640 = tree_cons (NULL_TREE, NULL_TREE, gnu_return_label_stack);
2642 /* See if there are any parameters for which we don't yet have
2643 GCC entities. These must be for OUT parameters for which we
2644 will be making VAR_DECL nodes here. Fill them in to
2645 TYPE_CI_CO_LIST, which must contain the empty entry as well.
2646 We can match up the entries because TYPE_CI_CO_LIST is in the
2647 order of the parameters. */
2649 for (gnat_param = First_Formal (gnat_subprog_id);
2650 Present (gnat_param);
2651 gnat_param = Next_Formal_With_Extras (gnat_param))
2652 if (present_gnu_tree (gnat_param))
2653 adjust_decl_rtl (get_gnu_tree (gnat_param));
2656 /* Skip any entries that have been already filled in; they
2657 must correspond to IN OUT parameters. */
2658 for (; gnu_cico_list != 0 && TREE_VALUE (gnu_cico_list) != 0;
2659 gnu_cico_list = TREE_CHAIN (gnu_cico_list))
2662 /* Do any needed references for padded types. */
2663 TREE_VALUE (gnu_cico_list)
2664 = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_list)),
2665 gnat_to_gnu_entity (gnat_param, NULL_TREE, 1));
2668 process_decls (Declarations (gnat_node), Empty, Empty, 1, 1);
2670 /* Generate the code of the subprogram itself. A return statement
2671 will be present and any OUT parameters will be handled there. */
2672 gnat_to_code (Handled_Statement_Sequence (gnat_node));
2674 expand_end_bindings (getdecls (), kept_level_p (), 0);
2675 poplevel (kept_level_p (), 1, 0);
2676 gnu_block_stack = TREE_CHAIN (gnu_block_stack);
2678 if (TREE_VALUE (gnu_return_label_stack) != 0)
2682 expand_end_bindings (NULL_TREE, kept_level_p (), 0);
2683 poplevel (kept_level_p (), 1, 0);
2684 expand_label (TREE_VALUE (gnu_return_label_stack));
2686 gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
2687 set_lineno (gnat_node, 1);
2688 if (list_length (gnu_cico_list) == 1)
2689 gnu_retval = TREE_VALUE (gnu_cico_list);
2691 gnu_retval = build_constructor (TREE_TYPE (gnu_subprog_type),
2694 if (DECL_P (gnu_retval) && DECL_BY_REF_P (gnu_retval))
2696 = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_retval);
2699 (build_binary_op (MODIFY_EXPR, NULL_TREE,
2700 DECL_RESULT (current_function_decl),
2705 gnu_return_label_stack = TREE_CHAIN (gnu_return_label_stack);
2707 /* Disconnect the trees for parameters that we made variables for
2708 from the GNAT entities since these will become unusable after
2709 we end the function. */
2710 for (gnat_param = First_Formal (gnat_subprog_id);
2711 Present (gnat_param);
2712 gnat_param = Next_Formal_With_Extras (gnat_param))
2713 if (TREE_CODE (get_gnu_tree (gnat_param)) == VAR_DECL)
2714 save_gnu_tree (gnat_param, NULL_TREE, 0);
2716 end_subprog_body ();
2717 mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node)));
2718 write_symbols = save_write_symbols;
2719 debug_hooks = save_debug_hooks;
2723 case N_Function_Call:
2724 case N_Procedure_Call_Statement:
2726 if (type_annotate_only)
2730 /* The GCC node corresponding to the GNAT subprogram name. This can
2731 either be a FUNCTION_DECL node if we are dealing with a standard
2732 subprogram call, or an indirect reference expression (an
2733 INDIRECT_REF node) pointing to a subprogram. */
2734 tree gnu_subprog_node = gnat_to_gnu (Name (gnat_node));
2735 /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */
2736 tree gnu_subprog_type = TREE_TYPE (gnu_subprog_node);
2737 tree gnu_subprog_addr
2738 = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_subprog_node);
2739 Entity_Id gnat_formal;
2740 Node_Id gnat_actual;
2741 tree gnu_actual_list = NULL_TREE;
2742 tree gnu_name_list = NULL_TREE;
2743 tree gnu_after_list = NULL_TREE;
2744 tree gnu_subprog_call;
2746 switch (Nkind (Name (gnat_node)))
2749 case N_Operator_Symbol:
2750 case N_Expanded_Name:
2751 case N_Attribute_Reference:
2752 if (Is_Eliminated (Entity (Name (gnat_node))))
2753 post_error_ne ("cannot call eliminated subprogram &!",
2754 gnat_node, Entity (Name (gnat_node)));
2757 if (TREE_CODE (gnu_subprog_type) != FUNCTION_TYPE)
2760 /* If we are calling a stubbed function, make this into a
2761 raise of Program_Error. Elaborate all our args first. */
2763 if (TREE_CODE (gnu_subprog_node) == FUNCTION_DECL
2764 && DECL_STUBBED_P (gnu_subprog_node))
2766 for (gnat_actual = First_Actual (gnat_node);
2767 Present (gnat_actual);
2768 gnat_actual = Next_Actual (gnat_actual))
2769 expand_expr_stmt (gnat_to_gnu (gnat_actual));
2771 if (Nkind (gnat_node) == N_Function_Call)
2773 gnu_result_type = TREE_TYPE (gnu_subprog_type);
2775 = build1 (NULL_EXPR, gnu_result_type,
2776 build_call_raise (PE_Stubbed_Subprogram_Called));
2780 (build_call_raise (PE_Stubbed_Subprogram_Called));
2784 /* The only way we can be making a call via an access type is
2785 if Name is an explicit dereference. In that case, get the
2786 list of formal args from the type the access type is pointing
2787 to. Otherwise, get the formals from entity being called. */
2788 if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
2789 gnat_formal = First_Formal (Etype (Name (gnat_node)));
2790 else if (Nkind (Name (gnat_node)) == N_Attribute_Reference)
2791 /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
2794 gnat_formal = First_Formal (Entity (Name (gnat_node)));
2796 /* Create the list of the actual parameters as GCC expects it, namely
2797 a chain of TREE_LIST nodes in which the TREE_VALUE field of each
2798 node is a parameter-expression and the TREE_PURPOSE field is
2799 null. Skip OUT parameters that are not passed by reference. */
2801 for (gnat_actual = First_Actual (gnat_node);
2802 Present (gnat_actual);
2803 gnat_formal = Next_Formal_With_Extras (gnat_formal),
2804 gnat_actual = Next_Actual (gnat_actual))
2806 tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal));
2808 = ((Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
2809 ? Expression (gnat_actual) : gnat_actual);
2810 tree gnu_name = gnat_to_gnu (gnat_name);
2811 tree gnu_name_type = gnat_to_gnu_type (Etype (gnat_name));
2814 /* If it's possible we may need to use this expression twice,
2815 make sure than any side-effects are handled via SAVE_EXPRs.
2816 Likewise if we need to force side-effects before the call.
2817 ??? This is more conservative than we need since we don't
2818 need to do this for pass-by-ref with no conversion.
2819 If we are passing a non-addressable Out or In Out parameter by
2820 reference, pass the address of a copy and set up to copy back
2821 out after the call. */
2823 if (Ekind (gnat_formal) != E_In_Parameter)
2825 gnu_name = gnat_stabilize_reference (gnu_name, 1);
2826 if (! addressable_p (gnu_name)
2827 && present_gnu_tree (gnat_formal)
2828 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
2829 || DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal))
2830 || DECL_BY_DESCRIPTOR_P (get_gnu_tree (gnat_formal))))
2832 tree gnu_copy = gnu_name;
2834 /* Remove any unpadding on the actual and make a copy.
2835 But if the actual is a left-justified modular type,
2836 first convert to it. */
2837 if (TREE_CODE (gnu_name) == COMPONENT_REF
2838 && (TYPE_IS_PADDING_P
2839 (TREE_TYPE (TREE_OPERAND (gnu_name, 0)))))
2840 gnu_name = gnu_copy = TREE_OPERAND (gnu_name, 0);
2841 else if (TREE_CODE (gnu_name_type) == RECORD_TYPE
2842 && (TYPE_LEFT_JUSTIFIED_MODULAR_P
2844 gnu_name = convert (gnu_name_type, gnu_name);
2846 gnu_actual = save_expr (gnu_name);
2848 /* Set up to move the copy back to the original. */
2849 gnu_after_list = tree_cons (gnu_copy, gnu_actual,
2852 gnu_name = gnu_actual;
2856 /* If this was a procedure call, we may not have removed any
2857 padding. So do it here for the part we will use as an
2859 gnu_actual = gnu_name;
2860 if (Ekind (gnat_formal) != E_Out_Parameter
2861 && TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
2862 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
2863 gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
2866 if (Ekind (gnat_formal) != E_Out_Parameter
2867 && Nkind (gnat_actual) != N_Unchecked_Type_Conversion
2868 && Do_Range_Check (gnat_actual))
2869 gnu_actual = emit_range_check (gnu_actual, Etype (gnat_formal));
2871 /* Do any needed conversions. We need only check for
2872 unchecked conversion since normal conversions will be handled
2873 by just converting to the formal type. */
2874 if (Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
2877 = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)),
2880 /* One we've done the unchecked conversion, we still
2881 must ensure that the object is in range of the formal's
2883 if (Ekind (gnat_formal) != E_Out_Parameter
2884 && Do_Range_Check (gnat_actual))
2885 gnu_actual = emit_range_check (gnu_actual,
2886 Etype (gnat_formal));
2889 /* We may have suppressed a conversion to the Etype of the
2890 actual since the parent is a procedure call. So add the
2892 gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
2895 gnu_actual = convert (gnu_formal_type, gnu_actual);
2897 /* If we have not saved a GCC object for the formal, it means
2898 it is an OUT parameter not passed by reference. Otherwise,
2899 look at the PARM_DECL to see if it is passed by reference. */
2900 if (present_gnu_tree (gnat_formal)
2901 && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
2902 && DECL_BY_REF_P (get_gnu_tree (gnat_formal)))
2904 if (Ekind (gnat_formal) != E_In_Parameter)
2906 gnu_actual = gnu_name;
2908 /* If we have a padded type, be sure we've removed the
2910 if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
2911 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
2913 = convert (get_unpadded_type (Etype (gnat_actual)),
2917 /* The symmetry of the paths to the type of an entity is
2918 broken here since arguments don't know that they will
2919 be passed by ref. */
2920 gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
2921 gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type,
2924 else if (present_gnu_tree (gnat_formal)
2925 && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
2926 && DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal)))
2928 gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
2929 gnu_actual = maybe_implicit_deref (gnu_actual);
2930 gnu_actual = maybe_unconstrained_array (gnu_actual);
2932 if (TREE_CODE (gnu_formal_type) == RECORD_TYPE
2933 && TYPE_IS_PADDING_P (gnu_formal_type))
2936 = TREE_TYPE (TYPE_FIELDS (gnu_formal_type));
2937 gnu_actual = convert (gnu_formal_type, gnu_actual);
2940 /* Take the address of the object and convert to the
2941 proper pointer type. We'd like to actually compute
2942 the address of the beginning of the array using
2943 an ADDR_EXPR of an ARRAY_REF, but there's a possibility
2944 that the ARRAY_REF might return a constant and we'd
2945 be getting the wrong address. Neither approach is
2946 exactly correct, but this is the most likely to work
2948 gnu_actual = convert (gnu_formal_type,
2949 build_unary_op (ADDR_EXPR, NULL_TREE,
2952 else if (present_gnu_tree (gnat_formal)
2953 && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
2954 && DECL_BY_DESCRIPTOR_P (get_gnu_tree (gnat_formal)))
2956 /* If arg is 'Null_Parameter, pass zero descriptor. */
2957 if ((TREE_CODE (gnu_actual) == INDIRECT_REF
2958 || TREE_CODE (gnu_actual) == UNCONSTRAINED_ARRAY_REF)
2959 && TREE_PRIVATE (gnu_actual))
2961 = convert (DECL_ARG_TYPE (get_gnu_tree (gnat_formal)),
2965 = build_unary_op (ADDR_EXPR, NULL_TREE,
2966 fill_vms_descriptor (gnu_actual,
2971 tree gnu_actual_size = TYPE_SIZE (TREE_TYPE (gnu_actual));
2973 if (Ekind (gnat_formal) != E_In_Parameter)
2975 = chainon (gnu_name_list,
2976 build_tree_list (NULL_TREE, gnu_name));
2978 if (! present_gnu_tree (gnat_formal)
2979 || TREE_CODE (get_gnu_tree (gnat_formal)) != PARM_DECL)
2982 /* If this is 'Null_Parameter, pass a zero even though we are
2983 dereferencing it. */
2984 else if (TREE_CODE (gnu_actual) == INDIRECT_REF
2985 && TREE_PRIVATE (gnu_actual)
2986 && host_integerp (gnu_actual_size, 1)
2987 && 0 >= compare_tree_int (gnu_actual_size,
2991 (DECL_ARG_TYPE (get_gnu_tree (gnat_formal)),
2992 convert (gnat_type_for_size
2993 (tree_low_cst (gnu_actual_size, 1), 1),
2994 integer_zero_node));
2997 = convert (TYPE_MAIN_VARIANT
2998 (DECL_ARG_TYPE (get_gnu_tree (gnat_formal))),
3003 = chainon (gnu_actual_list,
3004 build_tree_list (NULL_TREE, gnu_actual));
3007 gnu_subprog_call = build (CALL_EXPR, TREE_TYPE (gnu_subprog_type),
3008 gnu_subprog_addr, gnu_actual_list,
3010 TREE_SIDE_EFFECTS (gnu_subprog_call) = 1;
3012 /* If it is a function call, the result is the call expression. */
3013 if (Nkind (gnat_node) == N_Function_Call)
3015 gnu_result = gnu_subprog_call;
3017 /* If the function returns an unconstrained array or by reference,
3018 we have to de-dereference the pointer. */
3019 if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type)
3020 || TYPE_RETURNS_BY_REF_P (gnu_subprog_type))
3021 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE,
3024 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3027 /* If this is the case where the GNAT tree contains a procedure call
3028 but the Ada procedure has copy in copy out parameters, the special
3029 parameter passing mechanism must be used. */
3030 else if (TYPE_CI_CO_LIST (gnu_subprog_type) != NULL_TREE)
3032 /* List of FIELD_DECLs associated with the PARM_DECLs of the copy
3033 in copy out parameters. */
3034 tree scalar_return_list = TYPE_CI_CO_LIST (gnu_subprog_type);
3035 int length = list_length (scalar_return_list);
3041 gnu_subprog_call = protect_multiple_eval (gnu_subprog_call);
3043 /* If any of the names had side-effects, ensure they are
3044 all evaluated before the call. */
3045 for (gnu_name = gnu_name_list; gnu_name;
3046 gnu_name = TREE_CHAIN (gnu_name))
3047 if (TREE_SIDE_EFFECTS (TREE_VALUE (gnu_name)))
3049 = build (COMPOUND_EXPR, TREE_TYPE (gnu_subprog_call),
3050 TREE_VALUE (gnu_name), gnu_subprog_call);
3053 if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
3054 gnat_formal = First_Formal (Etype (Name (gnat_node)));
3056 gnat_formal = First_Formal (Entity (Name (gnat_node)));
3058 for (gnat_actual = First_Actual (gnat_node);
3059 Present (gnat_actual);
3060 gnat_formal = Next_Formal_With_Extras (gnat_formal),
3061 gnat_actual = Next_Actual (gnat_actual))
3062 /* If we are dealing with a copy in copy out parameter, we must
3063 retrieve its value from the record returned in the function
3065 if (! (present_gnu_tree (gnat_formal)
3066 && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
3067 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
3068 || (DECL_BY_COMPONENT_PTR_P
3069 (get_gnu_tree (gnat_formal)))
3070 || DECL_BY_DESCRIPTOR_P (get_gnu_tree (gnat_formal))))
3071 && Ekind (gnat_formal) != E_In_Parameter)
3073 /* Get the value to assign to this OUT or IN OUT
3074 parameter. It is either the result of the function if
3075 there is only a single such parameter or the appropriate
3076 field from the record returned. */
3078 = length == 1 ? gnu_subprog_call
3079 : build_component_ref
3080 (gnu_subprog_call, NULL_TREE,
3081 TREE_PURPOSE (scalar_return_list));
3082 int unchecked_conversion
3083 = Nkind (gnat_actual) == N_Unchecked_Type_Conversion;
3084 /* If the actual is a conversion, get the inner expression,
3085 which will be the real destination, and convert the
3086 result to the type of the actual parameter. */
3088 = maybe_unconstrained_array (TREE_VALUE (gnu_name_list));
3090 /* If the result is a padded type, remove the padding. */
3091 if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
3092 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
3094 = convert (TREE_TYPE (TYPE_FIELDS
3095 (TREE_TYPE (gnu_result))),
3098 /* If the result is a type conversion, do it. */
3099 if (Nkind (gnat_actual) == N_Type_Conversion)
3101 = convert_with_check
3102 (Etype (Expression (gnat_actual)), gnu_result,
3103 Do_Overflow_Check (gnat_actual),
3104 Do_Range_Check (Expression (gnat_actual)),
3105 Float_Truncate (gnat_actual));
3107 else if (unchecked_conversion)
3109 = unchecked_convert (TREE_TYPE (gnu_actual), gnu_result);
3112 if (Do_Range_Check (gnat_actual))
3113 gnu_result = emit_range_check (gnu_result,
3114 Etype (gnat_actual));
3116 if (! (! TREE_CONSTANT (TYPE_SIZE
3117 (TREE_TYPE (gnu_actual)))
3118 && TREE_CONSTANT (TYPE_SIZE
3119 (TREE_TYPE (gnu_result)))))
3120 gnu_result = convert (TREE_TYPE (gnu_actual),
3124 set_lineno (gnat_node, 1);
3125 expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE,
3126 gnu_actual, gnu_result));
3127 scalar_return_list = TREE_CHAIN (scalar_return_list);
3128 gnu_name_list = TREE_CHAIN (gnu_name_list);
3133 set_lineno (gnat_node, 1);
3134 expand_expr_stmt (gnu_subprog_call);
3137 /* Handle anything we need to assign back. */
3138 for (gnu_expr = gnu_after_list;
3140 gnu_expr = TREE_CHAIN (gnu_expr))
3141 expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE,
3142 TREE_PURPOSE (gnu_expr),
3143 TREE_VALUE (gnu_expr)));
3147 /*************************/
3148 /* Chapter 7: Packages: */
3149 /*************************/
3151 case N_Package_Declaration:
3152 gnat_to_code (Specification (gnat_node));
3155 case N_Package_Specification:
3157 process_decls (Visible_Declarations (gnat_node),
3158 Private_Declarations (gnat_node), Empty, 1, 1);
3161 case N_Package_Body:
3163 /* If this is the body of a generic package - do nothing */
3164 if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package)
3167 process_decls (Declarations (gnat_node), Empty, Empty, 1, 1);
3169 if (Present (Handled_Statement_Sequence (gnat_node)))
3171 gnu_block_stack = tree_cons (NULL_TREE, NULL_TREE, gnu_block_stack);
3172 gnat_to_code (Handled_Statement_Sequence (gnat_node));
3173 gnu_block_stack = TREE_CHAIN (gnu_block_stack);
3177 /*********************************/
3178 /* Chapter 8: Visibility Rules: */
3179 /*********************************/
3181 case N_Use_Package_Clause:
3182 case N_Use_Type_Clause:
3183 /* Nothing to do here - but these may appear in list of declarations */
3186 /***********************/
3187 /* Chapter 9: Tasks: */
3188 /***********************/
3190 case N_Protected_Type_Declaration:
3193 case N_Single_Task_Declaration:
3194 gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
3197 /***********************************************************/
3198 /* Chapter 10: Program Structure and Compilation Issues: */
3199 /***********************************************************/
3201 case N_Compilation_Unit:
3203 /* For a body, first process the spec if there is one. */
3204 if (Nkind (Unit (gnat_node)) == N_Package_Body
3205 || (Nkind (Unit (gnat_node)) == N_Subprogram_Body
3206 && ! Acts_As_Spec (gnat_node)))
3207 gnat_to_code (Library_Unit (gnat_node));
3209 process_inlined_subprograms (gnat_node);
3211 if (type_annotate_only && gnat_node == Cunit (Main_Unit))
3213 elaborate_all_entities (gnat_node);
3215 if (Nkind (Unit (gnat_node)) == N_Subprogram_Declaration
3216 || Nkind (Unit (gnat_node)) == N_Generic_Package_Declaration
3217 || Nkind (Unit (gnat_node)) == N_Generic_Subprogram_Declaration)
3221 process_decls (Declarations (Aux_Decls_Node (gnat_node)),
3222 Empty, Empty, 1, 1);
3224 gnat_to_code (Unit (gnat_node));
3226 /* Process any pragmas following the unit. */
3227 if (Present (Pragmas_After (Aux_Decls_Node (gnat_node))))
3228 for (gnat_temp = First (Pragmas_After (Aux_Decls_Node (gnat_node)));
3229 gnat_temp; gnat_temp = Next (gnat_temp))
3230 gnat_to_code (gnat_temp);
3232 /* Put all the Actions into the elaboration routine if we already had
3233 elaborations. This will happen anyway if they are statements, but we
3234 want to force declarations there too due to order-of-elaboration
3235 issues. Most should have Is_Statically_Allocated set. If we
3236 have had no elaborations, we have no order-of-elaboration issue and
3237 don't want to create elaborations here. */
3238 if (Is_Non_Empty_List (Actions (Aux_Decls_Node (gnat_node))))
3239 for (gnat_temp = First (Actions (Aux_Decls_Node (gnat_node)));
3240 Present (gnat_temp); gnat_temp = Next (gnat_temp))
3242 if (pending_elaborations_p ())
3243 add_pending_elaborations (NULL_TREE,
3244 make_transform_expr (gnat_temp));
3246 gnat_to_code (gnat_temp);
3249 /* Generate elaboration code for this unit, if necessary, and
3250 say whether we did or not. */
3251 Set_Has_No_Elaboration_Code
3254 (Defining_Entity (Unit (gnat_node)),
3255 Nkind (Unit (gnat_node)) == N_Package_Body
3256 || Nkind (Unit (gnat_node)) == N_Subprogram_Body,
3257 get_pending_elaborations ()));
3261 case N_Subprogram_Body_Stub:
3262 case N_Package_Body_Stub:
3263 case N_Protected_Body_Stub:
3264 case N_Task_Body_Stub:
3265 /* Simply process whatever unit is being inserted. */
3266 gnat_to_code (Unit (Library_Unit (gnat_node)));
3270 gnat_to_code (Proper_Body (gnat_node));
3273 /***************************/
3274 /* Chapter 11: Exceptions: */
3275 /***************************/
3277 case N_Handled_Sequence_Of_Statements:
3279 /* The GCC exception handling mechanism can handle both ZCX and SJLJ
3280 schemes and we have our own SJLJ mechanism. To call the GCC
3281 mechanism, we first call expand_eh_region_start if there is at least
3282 one handler associated with the region. We then generate code for
3283 the region and call expand_start_all_catch to announce that the
3284 associated handlers are going to be generated.
3286 For each handler we call expand_start_catch, generate code for the
3287 handler, and then call expand_end_catch.
3289 After all the handlers, we call expand_end_all_catch.
3291 Here we deal with the region level calls and the
3292 N_Exception_Handler branch deals with the handler level calls
3293 (start_catch/end_catch).
3295 ??? The region level calls down there have been specifically put in
3296 place for a ZCX context and currently the order in which things are
3297 emitted (region/handlers) is different from the SJLJ case. Instead of
3298 putting other calls with different conditions at other places for the
3299 SJLJ case, it seems cleaner to reorder things for the SJLJ case and
3300 generalize the condition to make it not ZCX specific. */
3302 /* Tell the back-end we are starting a new exception region if
3304 if (! type_annotate_only
3305 && Exception_Mechanism == GCC_ZCX
3306 && Present (Exception_Handlers (gnat_node)))
3307 expand_eh_region_start ();
3309 /* If there are exception handlers, start a new binding level that
3310 we can exit (since each exception handler will do so). Then
3311 declare a variable to save the old __gnat_jmpbuf value and a
3312 variable for our jmpbuf. Call setjmp and handle each of the
3313 possible exceptions if it returns one. */
3315 if (! type_annotate_only && Present (Exception_Handlers (gnat_node)))
3317 tree gnu_jmpsave_decl = 0;
3318 tree gnu_jmpbuf_decl = 0;
3319 tree gnu_cleanup_call = 0;
3320 tree gnu_cleanup_decl;
3323 expand_start_bindings (1);
3325 if (Exception_Mechanism == Setjmp_Longjmp)
3328 = create_var_decl (get_identifier ("JMPBUF_SAVE"), NULL_TREE,
3330 build_call_0_expr (get_jmpbuf_decl),
3333 gnu_jmpbuf_decl = create_var_decl (get_identifier ("JMP_BUF"),
3334 NULL_TREE, jmpbuf_type,
3335 NULL_TREE, 0, 0, 0, 0,
3337 TREE_VALUE (gnu_block_stack) = gnu_jmpbuf_decl;
3340 /* See if we are to call a function when exiting this block. */
3341 if (Present (At_End_Proc (gnat_node)))
3344 = build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node)));
3347 = create_var_decl (get_identifier ("CLEANUP"), NULL_TREE,
3348 integer_type_node, NULL_TREE, 0, 0, 0, 0,
3351 expand_decl_cleanup (gnu_cleanup_decl, gnu_cleanup_call);
3354 if (Exception_Mechanism == Setjmp_Longjmp)
3356 /* When we exit this block, restore the saved value. */
3357 expand_decl_cleanup (gnu_jmpsave_decl,
3358 build_call_1_expr (set_jmpbuf_decl,
3361 /* Call setjmp and handle exceptions if it returns one. */
3362 set_lineno (gnat_node, 1);
3364 (build_call_1_expr (setjmp_decl,
3365 build_unary_op (ADDR_EXPR, NULL_TREE,
3369 /* Restore our incoming longjmp value before we do anything. */
3370 expand_expr_stmt (build_call_1_expr (set_jmpbuf_decl,
3374 expand_start_bindings (0);
3376 gnu_except_ptr_stack
3377 = tree_cons (NULL_TREE,
3379 (get_identifier ("EXCEPT_PTR"), NULL_TREE,
3380 build_pointer_type (except_type_node),
3381 build_call_0_expr (get_excptr_decl),
3383 gnu_except_ptr_stack);
3385 /* Generate code for each exception handler. The code at
3386 N_Exception_Handler below does the real work. Note that
3387 we ignore the dummy exception handler for the identifier
3388 case, this is used only by the front end */
3389 if (Present (Exception_Handlers (gnat_node)))
3391 = First_Non_Pragma (Exception_Handlers (gnat_node));
3392 Present (gnat_temp);
3393 gnat_temp = Next_Non_Pragma (gnat_temp))
3394 gnat_to_code (gnat_temp);
3396 /* If none of the exception handlers did anything, re-raise
3397 but do not defer abortion. */
3398 set_lineno (gnat_node, 1);
3400 (build_call_1_expr (raise_nodefer_decl,
3401 TREE_VALUE (gnu_except_ptr_stack)));
3403 gnu_except_ptr_stack = TREE_CHAIN (gnu_except_ptr_stack);
3404 expand_end_bindings (getdecls (), kept_level_p (), 0);
3405 poplevel (kept_level_p (), 1, 0);
3407 /* End the "if" on setjmp. Note that we have arranged things so
3408 control never returns here. */
3411 /* This is now immediately before the body proper. Set
3412 our jmp_buf as the current buffer. */
3414 (build_call_1_expr (set_jmpbuf_decl,
3415 build_unary_op (ADDR_EXPR, NULL_TREE,
3420 /* If there are no exception handlers, we must not have an at end
3421 cleanup identifier, since the cleanup identifier should always
3422 generate a corresponding exception handler, except in the case
3423 of the No_Exception_Handlers restriction, where the front-end
3424 does not generate exception handlers. */
3425 else if (! type_annotate_only && Present (At_End_Proc (gnat_node)))
3427 if (No_Exception_Handlers_Set ())
3429 tree gnu_cleanup_call = 0;
3430 tree gnu_cleanup_decl;
3433 = build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node)));
3436 = create_var_decl (get_identifier ("CLEANUP"), NULL_TREE,
3437 integer_type_node, NULL_TREE, 0, 0, 0, 0,
3440 expand_decl_cleanup (gnu_cleanup_decl, gnu_cleanup_call);
3446 /* Generate code and declarations for the prefix of this block,
3448 if (Present (First_Real_Statement (gnat_node)))
3449 process_decls (Statements (gnat_node), Empty,
3450 First_Real_Statement (gnat_node), 1, 1);
3452 /* Generate code for each statement in the block. */
3453 for (gnat_temp = (Present (First_Real_Statement (gnat_node))
3454 ? First_Real_Statement (gnat_node)
3455 : First (Statements (gnat_node)));
3456 Present (gnat_temp); gnat_temp = Next (gnat_temp))
3457 gnat_to_code (gnat_temp);
3459 /* Tell the back-end we are ending the new exception region and
3460 starting the associated handlers. */
3461 if (! type_annotate_only
3462 && Exception_Mechanism == GCC_ZCX
3463 && Present (Exception_Handlers (gnat_node)))
3464 expand_start_all_catch ();
3466 /* For zero-cost exceptions, exit the block and then compile
3468 if (! type_annotate_only
3469 && Exception_Mechanism == GCC_ZCX
3470 && Present (Exception_Handlers (gnat_node)))
3472 expand_exit_something ();
3473 for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
3474 Present (gnat_temp);
3475 gnat_temp = Next_Non_Pragma (gnat_temp))
3476 gnat_to_code (gnat_temp);
3479 /* We don't support Front_End_ZCX in GNAT 5.0, but we don't want to
3480 crash if -gnatdX is specified. */
3481 if (! type_annotate_only
3482 && Exception_Mechanism == Front_End_ZCX
3483 && Present (Exception_Handlers (gnat_node)))
3485 for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
3486 Present (gnat_temp);
3487 gnat_temp = Next_Non_Pragma (gnat_temp))
3488 gnat_to_code (gnat_temp);
3491 /* Tell the backend when we are done with the handlers. */
3492 if (! type_annotate_only
3493 && Exception_Mechanism == GCC_ZCX
3494 && Present (Exception_Handlers (gnat_node)))
3495 expand_end_all_catch ();
3497 /* If we have handlers, close the block we made. */
3498 if (! type_annotate_only && Present (Exception_Handlers (gnat_node)))
3500 expand_end_bindings (getdecls (), kept_level_p (), 0);
3501 poplevel (kept_level_p (), 1, 0);
3506 case N_Exception_Handler:
3507 if (Exception_Mechanism == Setjmp_Longjmp)
3509 /* Unless this is "Others" or the special "Non-Ada" exception
3510 for Ada, make an "if" statement to select the proper
3511 exceptions. For "Others", exclude exceptions where
3512 Handled_By_Others is nonzero unless the All_Others flag is set.
3513 For "Non-ada", accept an exception if "Lang" is 'V'. */
3514 tree gnu_choice = integer_zero_node;
3516 for (gnat_temp = First (Exception_Choices (gnat_node));
3517 gnat_temp; gnat_temp = Next (gnat_temp))
3521 if (Nkind (gnat_temp) == N_Others_Choice)
3523 if (All_Others (gnat_temp))
3524 this_choice = integer_one_node;
3528 (EQ_EXPR, integer_type_node,
3533 (INDIRECT_REF, NULL_TREE,
3534 TREE_VALUE (gnu_except_ptr_stack)),
3535 get_identifier ("not_handled_by_others"), NULL_TREE)),
3539 else if (Nkind (gnat_temp) == N_Identifier
3540 || Nkind (gnat_temp) == N_Expanded_Name)
3542 /* ??? Note that we have to use gnat_to_gnu_entity here
3543 since the type of the exception will be wrong in the
3544 VMS case and that's exactly what this test is for. */
3546 = gnat_to_gnu_entity (Entity (gnat_temp), NULL_TREE, 0);
3548 /* If this was a VMS exception, check import_code
3549 against the value of the exception. */
3550 if (TREE_CODE (TREE_TYPE (gnu_expr)) == INTEGER_TYPE)
3553 (EQ_EXPR, integer_type_node,
3556 (INDIRECT_REF, NULL_TREE,
3557 TREE_VALUE (gnu_except_ptr_stack)),
3558 get_identifier ("import_code"), NULL_TREE),
3563 (EQ_EXPR, integer_type_node,
3564 TREE_VALUE (gnu_except_ptr_stack),
3566 (TREE_TYPE (TREE_VALUE (gnu_except_ptr_stack)),
3567 build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr)));
3569 /* If this is the distinguished exception "Non_Ada_Error"
3570 (and we are in VMS mode), also allow a non-Ada
3571 exception (a VMS condition) to match. */
3572 if (Is_Non_Ada_Error (Entity (gnat_temp)))
3575 = build_component_ref
3577 (INDIRECT_REF, NULL_TREE,
3578 TREE_VALUE (gnu_except_ptr_stack)),
3579 get_identifier ("lang"), NULL_TREE);
3583 (TRUTH_ORIF_EXPR, integer_type_node,
3585 (EQ_EXPR, integer_type_node, gnu_comp,
3586 convert (TREE_TYPE (gnu_comp),
3587 build_int_2 ('V', 0))),
3594 gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
3595 gnu_choice, this_choice);
3598 set_lineno (gnat_node, 1);
3600 expand_start_cond (gnu_choice, 0);
3603 /* Tell the back end that we start an exception handler if necessary. */
3604 if (Exception_Mechanism == GCC_ZCX)
3606 /* We build a TREE_LIST of nodes representing what exception
3607 types this handler is able to catch, with special cases
3608 for others and all others cases.
3610 Each exception type is actually identified by a pointer to the
3611 exception id, with special value zero for "others" and one for
3612 "all others". Beware that these special values are known and used
3613 by the personality routine to identify the corresponding specific
3616 ??? For initial time frame reasons, the others and all_others
3617 cases have been handled using specific type trees, but this
3618 somehow hides information to the back-end, which expects NULL to
3619 be passed for catch all and end_cleanup to be used for cleanups.
3621 Care should be taken to ensure that the control flow impact of
3622 such clauses is rendered in some way. lang_eh_type_covers is
3623 doing the trick currently.
3625 ??? Should investigate the possible usage of the end_cleanup
3626 interface in this context. */
3628 tree gnu_expr, gnu_etype;
3629 tree gnu_etypes_list = NULL_TREE;
3631 for (gnat_temp = First (Exception_Choices (gnat_node));
3632 gnat_temp; gnat_temp = Next (gnat_temp))
3634 if (Nkind (gnat_temp) == N_Others_Choice)
3636 = All_Others (gnat_temp) ? integer_one_node
3637 : integer_zero_node;
3638 else if (Nkind (gnat_temp) == N_Identifier
3639 || Nkind (gnat_temp) == N_Expanded_Name)
3641 gnu_expr = gnat_to_gnu_entity (Entity (gnat_temp),
3643 gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
3649 = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list);
3651 /* The GCC interface expects NULL to be passed for catch all
3652 handlers, so the approach below is quite tempting :
3654 if (gnu_etype == integer_zero_node)
3655 gnu_etypes_list = NULL;
3657 It would not work, however, because GCC's notion
3658 of "catch all" is stronger than our notion of "others".
3660 Until we correctly use the cleanup interface as well, the
3661 two lines above will prevent the "all others" handlers from
3662 beeing seen, because nothing can be caught beyond a catch
3663 all from GCC's point of view. */
3666 expand_start_catch (gnu_etypes_list);
3669 for (gnat_temp = First (Statements (gnat_node));
3670 gnat_temp; gnat_temp = Next (gnat_temp))
3671 gnat_to_code (gnat_temp);
3673 /* At the end of the handler, exit the block. We made this block
3674 in N_Handled_Sequence_Of_Statements. */
3675 expand_exit_something ();
3677 /* Tell the back end that we're done with the current handler. */
3678 if (Exception_Mechanism == GCC_ZCX)
3679 expand_end_catch ();
3680 else if (Exception_Mechanism == Setjmp_Longjmp)
3685 /*******************************/
3686 /* Chapter 12: Generic Units: */
3687 /*******************************/
3689 case N_Generic_Function_Renaming_Declaration:
3690 case N_Generic_Package_Renaming_Declaration:
3691 case N_Generic_Procedure_Renaming_Declaration:
3692 case N_Generic_Package_Declaration:
3693 case N_Generic_Subprogram_Declaration:
3694 case N_Package_Instantiation:
3695 case N_Procedure_Instantiation:
3696 case N_Function_Instantiation:
3697 /* These nodes can appear on a declaration list but there is nothing to
3698 to be done with them. */
3701 /***************************************************/
3702 /* Chapter 13: Representation Clauses and */
3703 /* Implementation-Dependent Features: */
3704 /***************************************************/
3706 case N_Attribute_Definition_Clause:
3708 /* The only one we need deal with is for 'Address. For the others, SEM
3709 puts the information elsewhere. We need only deal with 'Address
3710 if the object has a Freeze_Node (which it never will currently). */
3711 if (Get_Attribute_Id (Chars (gnat_node)) != Attr_Address
3712 || No (Freeze_Node (Entity (Name (gnat_node)))))
3715 /* Get the value to use as the address and save it as the
3716 equivalent for GNAT_TEMP. When the object is frozen,
3717 gnat_to_gnu_entity will do the right thing. */
3718 gnu_expr = gnat_to_gnu (Expression (gnat_node));
3719 save_gnu_tree (Entity (Name (gnat_node)), gnu_expr, 1);
3722 case N_Enumeration_Representation_Clause:
3723 case N_Record_Representation_Clause:
3725 /* We do nothing with these. SEM puts the information elsewhere. */
3728 case N_Code_Statement:
3729 if (! type_annotate_only)
3731 tree gnu_template = gnat_to_gnu (Asm_Template (gnat_node));
3732 tree gnu_input_list = 0, gnu_output_list = 0, gnu_orig_out_list = 0;
3733 tree gnu_clobber_list = 0;
3736 /* First process inputs, then outputs, then clobbers. */
3737 Setup_Asm_Inputs (gnat_node);
3738 while (Present (gnat_temp = Asm_Input_Value ()))
3740 tree gnu_value = gnat_to_gnu (gnat_temp);
3741 tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
3742 (Asm_Input_Constraint ()));
3745 = tree_cons (gnu_constr, gnu_value, gnu_input_list);
3749 Setup_Asm_Outputs (gnat_node);
3750 while (Present (gnat_temp = Asm_Output_Variable ()))
3752 tree gnu_value = gnat_to_gnu (gnat_temp);
3753 tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
3754 (Asm_Output_Constraint ()));
3757 = tree_cons (gnu_constr, gnu_value, gnu_orig_out_list);
3759 = tree_cons (gnu_constr, gnu_value, gnu_output_list);
3763 Clobber_Setup (gnat_node);
3764 while ((clobber = Clobber_Get_Next ()) != 0)
3766 = tree_cons (NULL_TREE,
3767 build_string (strlen (clobber) + 1, clobber),
3770 gnu_input_list = nreverse (gnu_input_list);
3771 gnu_output_list = nreverse (gnu_output_list);
3772 gnu_orig_out_list = nreverse (gnu_orig_out_list);
3773 expand_asm_operands (gnu_template, gnu_output_list, gnu_input_list,
3774 gnu_clobber_list, Is_Asm_Volatile (gnat_node),
3775 input_filename, lineno);
3777 /* Copy all the intermediate outputs into the specified outputs. */
3778 for (; gnu_output_list;
3779 (gnu_output_list = TREE_CHAIN (gnu_output_list),
3780 gnu_orig_out_list = TREE_CHAIN (gnu_orig_out_list)))
3781 if (TREE_VALUE (gnu_orig_out_list) != TREE_VALUE (gnu_output_list))
3784 (build_binary_op (MODIFY_EXPR, NULL_TREE,
3785 TREE_VALUE (gnu_orig_out_list),
3786 TREE_VALUE (gnu_output_list)));
3792 /***************************************************/
3794 /***************************************************/
3796 case N_Freeze_Entity:
3797 process_freeze_entity (gnat_node);
3798 process_decls (Actions (gnat_node), Empty, Empty, 1, 1);
3801 case N_Itype_Reference:
3802 if (! present_gnu_tree (Itype (gnat_node)))
3803 process_type (Itype (gnat_node));
3806 case N_Free_Statement:
3807 if (! type_annotate_only)
3809 tree gnu_ptr = gnat_to_gnu (Expression (gnat_node));
3814 /* If this is an unconstrained array, we know the object must
3815 have been allocated with the template in front of the object.
3816 So pass the template address, but get the total size. Do this
3817 by converting to a thin pointer. */
3818 if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
3820 = convert (build_pointer_type
3821 (TYPE_OBJECT_RECORD_TYPE
3822 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
3825 gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
3826 gnu_obj_size = TYPE_SIZE_UNIT (gnu_obj_type);
3827 align = TYPE_ALIGN (gnu_obj_type);
3829 if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
3830 && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
3832 tree gnu_char_ptr_type = build_pointer_type (char_type_node);
3833 tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
3834 tree gnu_byte_offset
3835 = convert (gnu_char_ptr_type,
3836 size_diffop (size_zero_node, gnu_pos));
3838 gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
3839 gnu_ptr = build_binary_op (MINUS_EXPR, gnu_char_ptr_type,
3840 gnu_ptr, gnu_byte_offset);
3843 set_lineno (gnat_node, 1);
3845 (build_call_alloc_dealloc (gnu_ptr, gnu_obj_size, align,
3846 Procedure_To_Call (gnat_node),
3847 Storage_Pool (gnat_node)));
3851 case N_Raise_Constraint_Error:
3852 case N_Raise_Program_Error:
3853 case N_Raise_Storage_Error:
3855 if (type_annotate_only)
3858 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3859 gnu_result = build_call_raise (UI_To_Int (Reason (gnat_node)));
3861 /* If the type is VOID, this is a statement, so we need to
3862 generate the code for the call. Handle a Condition, if there
3864 if (TREE_CODE (gnu_result_type) == VOID_TYPE)
3866 set_lineno (gnat_node, 1);
3868 if (Present (Condition (gnat_node)))
3869 expand_start_cond (gnat_to_gnu (Condition (gnat_node)), 0);
3871 expand_expr_stmt (gnu_result);
3872 if (Present (Condition (gnat_node)))
3874 gnu_result = error_mark_node;
3877 gnu_result = build1 (NULL_EXPR, gnu_result_type, gnu_result);
3880 /* Nothing to do, since front end does all validation using the
3881 values that Gigi back-annotates. */
3882 case N_Validate_Unchecked_Conversion:
3885 case N_Raise_Statement:
3886 case N_Function_Specification:
3887 case N_Procedure_Specification:
3889 case N_Component_Association:
3892 if (! type_annotate_only)
3896 /* If the result is a constant that overflows, raise constraint error. */
3897 if (TREE_CODE (gnu_result) == INTEGER_CST
3898 && TREE_CONSTANT_OVERFLOW (gnu_result))
3900 post_error ("Constraint_Error will be raised at run-time?", gnat_node);
3903 = build1 (NULL_EXPR, gnu_result_type,
3904 build_call_raise (CE_Overflow_Check_Failed));
3907 /* If our result has side-effects and is of an unconstrained type,
3908 make a SAVE_EXPR so that we can be sure it will only be referenced
3909 once. Note we must do this before any conversions. */
3910 if (TREE_SIDE_EFFECTS (gnu_result)
3911 && (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE
3912 || (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
3913 && contains_placeholder_p (TYPE_SIZE (gnu_result_type)))))
3914 gnu_result = gnat_stabilize_reference (gnu_result, 0);
3916 /* Now convert the result to the proper type. If the type is void or if
3917 we have no result, return error_mark_node to show we have no result.
3918 If the type of the result is correct or if we have a label (which doesn't
3919 have any well-defined type), return our result. Also don't do the
3920 conversion if the "desired" type involves a PLACEHOLDER_EXPR in its size
3921 since those are the cases where the front end may have the type wrong due
3922 to "instantiating" the unconstrained record with discriminant values
3923 or if this is a FIELD_DECL. If this is the Name of an assignment
3924 statement or a parameter of a procedure call, return what we have since
3925 the RHS has to be converted to our type there in that case, unless
3926 GNU_RESULT_TYPE has a simpler size. Similarly, if the two types are
3927 record types with the same name, the expression type has integral mode,
3928 and GNU_RESULT_TYPE BLKmode, don't convert. This will be the case when
3929 we are converting from a packable type to its actual type and we need
3930 those conversions to be NOPs in order for assignments into these types to
3931 work properly if the inner object is a bitfield and hence can't have
3932 its address taken. Finally, don't convert integral types that are the
3933 operand of an unchecked conversion since we need to ignore those
3934 conversions (for 'Valid). Otherwise, convert the result to the proper
3937 if (Present (Parent (gnat_node))
3938 && ((Nkind (Parent (gnat_node)) == N_Assignment_Statement
3939 && Name (Parent (gnat_node)) == gnat_node)
3940 || (Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement
3941 && Name (Parent (gnat_node)) != gnat_node)
3942 || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
3943 && ! AGGREGATE_TYPE_P (gnu_result_type)
3944 && ! AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))
3945 || Nkind (Parent (gnat_node)) == N_Parameter_Association)
3946 && ! (TYPE_SIZE (gnu_result_type) != 0
3947 && TYPE_SIZE (TREE_TYPE (gnu_result)) != 0
3948 && (AGGREGATE_TYPE_P (gnu_result_type)
3949 == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))
3950 && ((TREE_CODE (TYPE_SIZE (gnu_result_type)) == INTEGER_CST
3951 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result)))
3953 || (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
3954 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result)))
3956 && ! (contains_placeholder_p (TYPE_SIZE (gnu_result_type)))
3957 && (contains_placeholder_p
3958 (TYPE_SIZE (TREE_TYPE (gnu_result))))))
3959 && ! (TREE_CODE (gnu_result_type) == RECORD_TYPE
3960 && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_result_type))))
3962 /* In this case remove padding only if the inner object is of
3963 self-referential size: in that case it must be an object of
3964 unconstrained type with a default discriminant. In other cases,
3965 we want to avoid copying too much data. */
3966 if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
3967 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))
3968 && contains_placeholder_p (TYPE_SIZE
3969 (TREE_TYPE (TYPE_FIELDS
3970 (TREE_TYPE (gnu_result))))))
3971 gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
3975 else if (TREE_CODE (gnu_result) == LABEL_DECL
3976 || TREE_CODE (gnu_result) == FIELD_DECL
3977 || TREE_CODE (gnu_result) == ERROR_MARK
3978 || (TYPE_SIZE (gnu_result_type) != 0
3979 && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
3980 && TREE_CODE (gnu_result) != INDIRECT_REF
3981 && contains_placeholder_p (TYPE_SIZE (gnu_result_type)))
3982 || ((TYPE_NAME (gnu_result_type)
3983 == TYPE_NAME (TREE_TYPE (gnu_result)))
3984 && TREE_CODE (gnu_result_type) == RECORD_TYPE
3985 && TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
3986 && TYPE_MODE (gnu_result_type) == BLKmode
3987 && (GET_MODE_CLASS (TYPE_MODE (TREE_TYPE (gnu_result)))
3990 /* Remove any padding record, but do nothing more in this case. */
3991 if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
3992 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
3993 gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
3997 else if (gnu_result == error_mark_node
3998 || gnu_result_type == void_type_node)
3999 gnu_result = error_mark_node;
4000 else if (gnu_result_type != TREE_TYPE (gnu_result))
4001 gnu_result = convert (gnu_result_type, gnu_result);
4003 /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on GNU_RESULT. */
4004 while ((TREE_CODE (gnu_result) == NOP_EXPR
4005 || TREE_CODE (gnu_result) == NON_LVALUE_EXPR)
4006 && TREE_TYPE (TREE_OPERAND (gnu_result, 0)) == TREE_TYPE (gnu_result))
4007 gnu_result = TREE_OPERAND (gnu_result, 0);
4012 /* Force references to each of the entities in packages GNAT_NODE with's
4013 so that the debugging information for all of them are identical
4014 in all clients. Operate recursively on anything it with's, but check
4015 that we aren't elaborating something more than once. */
4017 /* The reason for this routine's existence is two-fold.
4018 First, with some debugging formats, notably MDEBUG on SGI
4019 IRIX, the linker will remove duplicate debugging information if two
4020 clients have identical debugguing information. With the normal scheme
4021 of elaboration, this does not usually occur, since entities in with'ed
4022 packages are elaborated on demand, and if clients have different usage
4023 patterns, the normal case, then the order and selection of entities
4024 will differ. In most cases however, it seems that linkers do not know
4025 how to eliminate duplicate debugging information, even if it is
4026 identical, so the use of this routine would increase the total amount
4027 of debugging information in the final executable.
4029 Second, this routine is called in type_annotate mode, to compute DDA
4030 information for types in withed units, for ASIS use */
4033 elaborate_all_entities (gnat_node)
4036 Entity_Id gnat_with_clause, gnat_entity;
4038 save_gnu_tree (gnat_node, integer_zero_node, 1);
4040 /* Save entities in all context units. A body may have an implicit_with
4041 on its own spec, if the context includes a child unit, so don't save
4044 for (gnat_with_clause = First (Context_Items (gnat_node));
4045 Present (gnat_with_clause);
4046 gnat_with_clause = Next (gnat_with_clause))
4047 if (Nkind (gnat_with_clause) == N_With_Clause
4048 && ! present_gnu_tree (Library_Unit (gnat_with_clause))
4049 && Library_Unit (gnat_with_clause) != Library_Unit (Cunit (Main_Unit)))
4051 elaborate_all_entities (Library_Unit (gnat_with_clause));
4053 if (Ekind (Entity (Name (gnat_with_clause))) == E_Package)
4054 for (gnat_entity = First_Entity (Entity (Name (gnat_with_clause)));
4055 Present (gnat_entity);
4056 gnat_entity = Next_Entity (gnat_entity))
4057 if (Is_Public (gnat_entity)
4058 && Convention (gnat_entity) != Convention_Intrinsic
4059 && Ekind (gnat_entity) != E_Package
4060 && Ekind (gnat_entity) != E_Package_Body
4061 && Ekind (gnat_entity) != E_Operator
4062 && ! (IN (Ekind (gnat_entity), Type_Kind)
4063 && ! Is_Frozen (gnat_entity))
4064 && ! ((Ekind (gnat_entity) == E_Procedure
4065 || Ekind (gnat_entity) == E_Function)
4066 && Is_Intrinsic_Subprogram (gnat_entity))
4067 && ! IN (Ekind (gnat_entity), Named_Kind)
4068 && ! IN (Ekind (gnat_entity), Generic_Unit_Kind))
4069 gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
4072 if (Nkind (Unit (gnat_node)) == N_Package_Body && type_annotate_only)
4073 elaborate_all_entities (Library_Unit (gnat_node));
4076 /* Do the processing of N_Freeze_Entity, GNAT_NODE. */
4079 process_freeze_entity (gnat_node)
4082 Entity_Id gnat_entity = Entity (gnat_node);
4086 = (Nkind (Declaration_Node (gnat_entity)) == N_Object_Declaration
4087 && present_gnu_tree (Declaration_Node (gnat_entity)))
4088 ? get_gnu_tree (Declaration_Node (gnat_entity)) : NULL_TREE;
4090 /* If this is a package, need to generate code for the package. */
4091 if (Ekind (gnat_entity) == E_Package)
4094 (Parent (Corresponding_Body
4095 (Parent (Declaration_Node (gnat_entity)))));
4099 /* Check for old definition after the above call. This Freeze_Node
4100 might be for one its Itypes. */
4102 = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
4104 /* If this entity has an Address representation clause, GNU_OLD is the
4105 address, so discard it here. */
4106 if (Present (Address_Clause (gnat_entity)))
4109 /* Don't do anything for class-wide types they are always
4110 transformed into their root type. */
4111 if (Ekind (gnat_entity) == E_Class_Wide_Type
4112 || (Ekind (gnat_entity) == E_Class_Wide_Subtype
4113 && Present (Equivalent_Type (gnat_entity))))
4116 /* Don't do anything for subprograms that may have been elaborated before
4117 their freeze nodes. This can happen, for example because of an inner call
4118 in an instance body. */
4120 && TREE_CODE (gnu_old) == FUNCTION_DECL
4121 && (Ekind (gnat_entity) == E_Function
4122 || Ekind (gnat_entity) == E_Procedure))
4125 /* If we have a non-dummy type old tree, we have nothing to do. Unless
4126 this is the public view of a private type whose full view was not
4127 delayed, this node was never delayed as it should have been.
4128 Also allow this to happen for concurrent types since we may have
4129 frozen both the Corresponding_Record_Type and this type. */
4131 && ! (TREE_CODE (gnu_old) == TYPE_DECL
4132 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))))
4134 if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
4135 && Present (Full_View (gnat_entity))
4136 && No (Freeze_Node (Full_View (gnat_entity))))
4138 else if (Is_Concurrent_Type (gnat_entity))
4144 /* Reset the saved tree, if any, and elaborate the object or type for real.
4145 If there is a full declaration, elaborate it and copy the type to
4146 GNAT_ENTITY. Likewise if this is the record subtype corresponding to
4147 a class wide type or subtype. */
4150 save_gnu_tree (gnat_entity, NULL_TREE, 0);
4151 if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
4152 && Present (Full_View (gnat_entity))
4153 && present_gnu_tree (Full_View (gnat_entity)))
4154 save_gnu_tree (Full_View (gnat_entity), NULL_TREE, 0);
4155 if (Present (Class_Wide_Type (gnat_entity))
4156 && Class_Wide_Type (gnat_entity) != gnat_entity)
4157 save_gnu_tree (Class_Wide_Type (gnat_entity), NULL_TREE, 0);
4160 if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
4161 && Present (Full_View (gnat_entity)))
4163 gnu_new = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 1);
4165 /* The above call may have defined this entity (the simplest example
4166 of this is when we have a private enumeral type since the bounds
4167 will have the public view. */
4168 if (! present_gnu_tree (gnat_entity))
4169 save_gnu_tree (gnat_entity, gnu_new, 0);
4170 if (Present (Class_Wide_Type (gnat_entity))
4171 && Class_Wide_Type (gnat_entity) != gnat_entity)
4172 save_gnu_tree (Class_Wide_Type (gnat_entity), gnu_new, 0);
4175 gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, 1);
4177 /* If we've made any pointers to the old version of this type, we
4178 have to update them. */
4180 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
4181 TREE_TYPE (gnu_new));
4184 /* Process the list of inlined subprograms of GNAT_NODE, which is an
4185 N_Compilation_Unit. */
4188 process_inlined_subprograms (gnat_node)
4191 Entity_Id gnat_entity;
4194 /* If we can inline, generate RTL for all the inlined subprograms.
4195 Define the entity first so we set DECL_EXTERNAL. */
4196 if (optimize > 0 && ! flag_no_inline)
4197 for (gnat_entity = First_Inlined_Subprogram (gnat_node);
4198 Present (gnat_entity);
4199 gnat_entity = Next_Inlined_Subprogram (gnat_entity))
4201 gnat_body = Parent (Declaration_Node (gnat_entity));
4203 if (Nkind (gnat_body) != N_Subprogram_Body)
4205 /* ??? This really should always be Present. */
4206 if (No (Corresponding_Body (gnat_body)))
4210 = Parent (Declaration_Node (Corresponding_Body (gnat_body)));
4213 if (Present (gnat_body))
4215 gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
4216 gnat_to_code (gnat_body);
4221 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
4222 We make two passes, one to elaborate anything other than bodies (but
4223 we declare a function if there was no spec). The second pass
4224 elaborates the bodies.
4226 GNAT_END_LIST gives the element in the list past the end. Normally,
4227 this is Empty, but can be First_Real_Statement for a
4228 Handled_Sequence_Of_Statements.
4230 We make a complete pass through both lists if PASS1P is true, then make
4231 the second pass over both lists if PASS2P is true. The lists usually
4232 correspond to the public and private parts of a package. */
4235 process_decls (gnat_decls, gnat_decls2, gnat_end_list, pass1p, pass2p)
4236 List_Id gnat_decls, gnat_decls2;
4237 Node_Id gnat_end_list;
4240 List_Id gnat_decl_array[2];
4244 gnat_decl_array[0] = gnat_decls, gnat_decl_array[1] = gnat_decls2;
4247 for (i = 0; i <= 1; i++)
4248 if (Present (gnat_decl_array[i]))
4249 for (gnat_decl = First (gnat_decl_array[i]);
4250 gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
4252 set_lineno (gnat_decl, 0);
4254 /* For package specs, we recurse inside the declarations,
4255 thus taking the two pass approach inside the boundary. */
4256 if (Nkind (gnat_decl) == N_Package_Declaration
4257 && (Nkind (Specification (gnat_decl)
4258 == N_Package_Specification)))
4259 process_decls (Visible_Declarations (Specification (gnat_decl)),
4260 Private_Declarations (Specification (gnat_decl)),
4263 /* Similarly for any declarations in the actions of a
4265 else if (Nkind (gnat_decl) == N_Freeze_Entity)
4267 process_freeze_entity (gnat_decl);
4268 process_decls (Actions (gnat_decl), Empty, Empty, 1, 0);
4271 /* Package bodies with freeze nodes get their elaboration deferred
4272 until the freeze node, but the code must be placed in the right
4273 place, so record the code position now. */
4274 else if (Nkind (gnat_decl) == N_Package_Body
4275 && Present (Freeze_Node (Corresponding_Spec (gnat_decl))))
4276 record_code_position (gnat_decl);
4278 else if (Nkind (gnat_decl) == N_Package_Body_Stub
4279 && Present (Library_Unit (gnat_decl))
4280 && Present (Freeze_Node
4283 (Library_Unit (gnat_decl)))))))
4284 record_code_position
4285 (Proper_Body (Unit (Library_Unit (gnat_decl))));
4287 /* We defer most subprogram bodies to the second pass.
4288 However, Init_Proc subprograms cannot be defered, but luckily
4289 don't need to be. */
4290 else if ((Nkind (gnat_decl) == N_Subprogram_Body
4291 && (Chars (Defining_Entity (gnat_decl))
4292 != Name_uInit_Proc)))
4294 if (Acts_As_Spec (gnat_decl))
4296 Node_Id gnat_subprog_id = Defining_Entity (gnat_decl);
4298 if (Ekind (gnat_subprog_id) != E_Generic_Procedure
4299 && Ekind (gnat_subprog_id) != E_Generic_Function)
4300 gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
4303 /* For bodies and stubs that act as their own specs, the entity
4304 itself must be elaborated in the first pass, because it may
4305 be used in other declarations. */
4306 else if (Nkind (gnat_decl) == N_Subprogram_Body_Stub)
4308 Node_Id gnat_subprog_id =
4309 Defining_Entity (Specification (gnat_decl));
4311 if (Ekind (gnat_subprog_id) != E_Subprogram_Body
4312 && Ekind (gnat_subprog_id) != E_Generic_Procedure
4313 && Ekind (gnat_subprog_id) != E_Generic_Function)
4314 gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
4317 /* Concurrent stubs stand for the corresponding subprogram bodies,
4318 which are deferred like other bodies. */
4319 else if (Nkind (gnat_decl) == N_Task_Body_Stub
4320 || Nkind (gnat_decl) == N_Protected_Body_Stub)
4324 gnat_to_code (gnat_decl);
4327 /* Here we elaborate everything we deferred above except for package bodies,
4328 which are elaborated at their freeze nodes. Note that we must also
4329 go inside things (package specs and freeze nodes) the first pass did. */
4331 for (i = 0; i <= 1; i++)
4332 if (Present (gnat_decl_array[i]))
4333 for (gnat_decl = First (gnat_decl_array[i]);
4334 gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
4336 if ((Nkind (gnat_decl) == N_Subprogram_Body
4337 && (Chars (Defining_Entity (gnat_decl))
4338 != Name_uInit_Proc))
4339 || Nkind (gnat_decl) == N_Subprogram_Body_Stub
4340 || Nkind (gnat_decl) == N_Task_Body_Stub
4341 || Nkind (gnat_decl) == N_Protected_Body_Stub)
4342 gnat_to_code (gnat_decl);
4344 else if (Nkind (gnat_decl) == N_Package_Declaration
4345 && (Nkind (Specification (gnat_decl)
4346 == N_Package_Specification)))
4347 process_decls (Visible_Declarations (Specification (gnat_decl)),
4348 Private_Declarations (Specification (gnat_decl)),
4351 else if (Nkind (gnat_decl) == N_Freeze_Entity)
4352 process_decls (Actions (gnat_decl), Empty, Empty, 0, 1);
4356 /* Emits an access check. GNU_EXPR is the expression that needs to be
4357 checked against the NULL pointer. */
4360 emit_access_check (gnu_expr)
4363 tree gnu_check_expr;
4365 /* Checked expressions must be evaluated only once. */
4366 gnu_check_expr = gnu_expr = protect_multiple_eval (gnu_expr);
4368 /* Technically, we check a fat pointer against two words of zero. However,
4369 that's wasteful and really doesn't protect against null accesses. It
4370 makes more sense to check oly the array pointer. */
4371 if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_expr)))
4373 = build_component_ref (gnu_expr, get_identifier ("P_ARRAY"), NULL_TREE);
4375 if (! POINTER_TYPE_P (TREE_TYPE (gnu_check_expr)))
4378 return emit_check (build_binary_op (EQ_EXPR, integer_type_node,
4380 convert (TREE_TYPE (gnu_check_expr),
4381 integer_zero_node)),
4383 CE_Access_Check_Failed);
4386 /* Emits a discriminant check. GNU_EXPR is the expression to be checked and
4387 GNAT_NODE a N_Selected_Component node. */
4390 emit_discriminant_check (gnu_expr, gnat_node)
4395 = Original_Record_Component (Entity (Selector_Name (gnat_node)));
4396 Entity_Id gnat_discr_fct = Discriminant_Checking_Func (orig_comp);
4398 Entity_Id gnat_discr;
4399 tree gnu_actual_list = NULL_TREE;
4401 Entity_Id gnat_pref_type;
4404 if (Is_Tagged_Type (Scope (orig_comp)))
4405 gnat_pref_type = Scope (orig_comp);
4408 gnat_pref_type = Etype (Prefix (gnat_node));
4410 /* For an untagged derived type, use the discriminants of the parent,
4411 which have been renamed in the derivation, possibly by a one-to-many
4413 if (Is_Derived_Type (gnat_pref_type)
4414 && (Number_Discriminants (gnat_pref_type)
4415 != Number_Discriminants (Etype (Base_Type (gnat_pref_type)))))
4416 gnat_pref_type = Etype (Base_Type (gnat_pref_type));
4419 if (! Present (gnat_discr_fct))
4422 gnu_discr_fct = gnat_to_gnu (gnat_discr_fct);
4424 /* Checked expressions must be evaluated only once. */
4425 gnu_expr = protect_multiple_eval (gnu_expr);
4427 /* Create the list of the actual parameters as GCC expects it.
4428 This list is the list of the discriminant fields of the
4429 record expression to be discriminant checked. For documentation
4430 on what is the GCC format for this list see under the
4431 N_Function_Call case */
4433 while (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind)
4434 || IN (Ekind (gnat_pref_type), Access_Kind))
4436 if (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind))
4437 gnat_pref_type = Underlying_Type (gnat_pref_type);
4438 else if (IN (Ekind (gnat_pref_type), Access_Kind))
4439 gnat_pref_type = Designated_Type (gnat_pref_type);
4443 = TREE_TYPE (gnat_to_gnu_entity (gnat_pref_type, NULL_TREE, 0));
4445 for (gnat_discr = First_Discriminant (gnat_pref_type);
4446 Present (gnat_discr); gnat_discr = Next_Discriminant (gnat_discr))
4448 Entity_Id gnat_real_discr
4449 = ((Present (Corresponding_Discriminant (gnat_discr))
4450 && Present (Parent_Subtype (gnat_pref_type)))
4451 ? Corresponding_Discriminant (gnat_discr) : gnat_discr);
4452 tree gnu_discr = gnat_to_gnu_entity (gnat_real_discr, NULL_TREE, 0);
4455 = chainon (gnu_actual_list,
4456 build_tree_list (NULL_TREE,
4458 (convert (gnu_pref_type, gnu_expr),
4459 NULL_TREE, gnu_discr)));
4462 gnu_cond = build (CALL_EXPR,
4463 TREE_TYPE (TREE_TYPE (gnu_discr_fct)),
4464 build_unary_op (ADDR_EXPR, NULL_TREE, gnu_discr_fct),
4467 TREE_SIDE_EFFECTS (gnu_cond) = 1;
4471 (INDIRECT_REF, NULL_TREE,
4472 emit_check (gnu_cond,
4473 build_unary_op (ADDR_EXPR,
4474 build_reference_type (TREE_TYPE (gnu_expr)),
4476 CE_Discriminant_Check_Failed));
4479 /* Emit code for a range check. GNU_EXPR is the expression to be checked,
4480 GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
4481 which we have to check. */
4484 emit_range_check (gnu_expr, gnat_range_type)
4486 Entity_Id gnat_range_type;
4488 tree gnu_range_type = get_unpadded_type (gnat_range_type);
4489 tree gnu_low = TYPE_MIN_VALUE (gnu_range_type);
4490 tree gnu_high = TYPE_MAX_VALUE (gnu_range_type);
4491 tree gnu_compare_type = get_base_type (TREE_TYPE (gnu_expr));
4493 /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE,
4494 we can't do anything since we might be truncating the bounds. No
4495 check is needed in this case. */
4496 if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr))
4497 && (TYPE_PRECISION (gnu_compare_type)
4498 < TYPE_PRECISION (get_base_type (gnu_range_type))))
4501 /* Checked expressions must be evaluated only once. */
4502 gnu_expr = protect_multiple_eval (gnu_expr);
4504 /* There's no good type to use here, so we might as well use
4505 integer_type_node. Note that the form of the check is
4506 (not (expr >= lo)) or (not (expr >= hi))
4507 the reason for this slightly convoluted form is that NaN's
4508 are not considered to be in range in the float case. */
4510 (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
4512 (build_binary_op (GE_EXPR, integer_type_node,
4513 convert (gnu_compare_type, gnu_expr),
4514 convert (gnu_compare_type, gnu_low))),
4516 (build_binary_op (LE_EXPR, integer_type_node,
4517 convert (gnu_compare_type, gnu_expr),
4518 convert (gnu_compare_type,
4520 gnu_expr, CE_Range_Check_Failed);
4523 /* Emit code for an index check. GNU_ARRAY_OBJECT is the array object
4524 which we are about to index, GNU_EXPR is the index expression to be
4525 checked, GNU_LOW and GNU_HIGH are the lower and upper bounds
4526 against which GNU_EXPR has to be checked. Note that for index
4527 checking we cannot use the emit_range_check function (although very
4528 similar code needs to be generated in both cases) since for index
4529 checking the array type against which we are checking the indeces
4530 may be unconstrained and consequently we need to retrieve the
4531 actual index bounds from the array object itself
4532 (GNU_ARRAY_OBJECT). The place where we need to do that is in
4533 subprograms having unconstrained array formal parameters */
4536 emit_index_check (gnu_array_object, gnu_expr, gnu_low, gnu_high)
4537 tree gnu_array_object;
4542 tree gnu_expr_check;
4544 /* Checked expressions must be evaluated only once. */
4545 gnu_expr = protect_multiple_eval (gnu_expr);
4547 /* Must do this computation in the base type in case the expression's
4548 type is an unsigned subtypes. */
4549 gnu_expr_check = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
4551 /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by
4552 the object we are handling. */
4553 if (TREE_CODE (gnu_low) != INTEGER_CST && contains_placeholder_p (gnu_low))
4554 gnu_low = build (WITH_RECORD_EXPR, TREE_TYPE (gnu_low),
4555 gnu_low, gnu_array_object);
4557 if (TREE_CODE (gnu_high) != INTEGER_CST && contains_placeholder_p (gnu_high))
4558 gnu_high = build (WITH_RECORD_EXPR, TREE_TYPE (gnu_high),
4559 gnu_high, gnu_array_object);
4561 /* There's no good type to use here, so we might as well use
4562 integer_type_node. */
4564 (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
4565 build_binary_op (LT_EXPR, integer_type_node,
4567 convert (TREE_TYPE (gnu_expr_check),
4569 build_binary_op (GT_EXPR, integer_type_node,
4571 convert (TREE_TYPE (gnu_expr_check),
4573 gnu_expr, CE_Index_Check_Failed);
4576 /* Given GNU_COND which contains the condition corresponding to an access,
4577 discriminant or range check, of value GNU_EXPR, build a COND_EXPR
4578 that returns GNU_EXPR if GNU_COND is false and raises a
4579 CONSTRAINT_ERROR if GNU_COND is true. REASON is the code that says
4580 why the exception was raised. */
4583 emit_check (gnu_cond, gnu_expr, reason)
4591 gnu_call = build_call_raise (reason);
4593 /* Use an outer COMPOUND_EXPR to make sure that GNU_EXPR will get evaluated
4594 in front of the comparison in case it ends up being a SAVE_EXPR. Put the
4595 whole thing inside its own SAVE_EXPR so the inner SAVE_EXPR doesn't leak
4597 gnu_result = fold (build (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond,
4598 build (COMPOUND_EXPR, TREE_TYPE (gnu_expr),
4599 gnu_call, gnu_expr),
4602 /* If GNU_EXPR has side effects, make the outer COMPOUND_EXPR and
4603 protect it. Otherwise, show GNU_RESULT has no side effects: we
4604 don't need to evaluate it just for the check. */
4605 if (TREE_SIDE_EFFECTS (gnu_expr))
4607 = build (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_expr, gnu_result);
4609 TREE_SIDE_EFFECTS (gnu_result) = 0;
4611 /* ??? Unfortunately, if we don't put a SAVE_EXPR around this whole thing,
4612 we will repeatedly do the test. It would be nice if GCC was able
4613 to optimize this and only do it once. */
4614 return save_expr (gnu_result);
4617 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing
4618 overflow checks if OVERFLOW_P is nonzero and range checks if
4619 RANGE_P is nonzero. GNAT_TYPE is known to be an integral type.
4620 If TRUNCATE_P is nonzero, do a float to integer conversion with
4621 truncation; otherwise round. */
4624 convert_with_check (gnat_type, gnu_expr, overflow_p, range_p, truncate_p)
4625 Entity_Id gnat_type;
4631 tree gnu_type = get_unpadded_type (gnat_type);
4632 tree gnu_in_type = TREE_TYPE (gnu_expr);
4633 tree gnu_in_basetype = get_base_type (gnu_in_type);
4634 tree gnu_base_type = get_base_type (gnu_type);
4635 tree gnu_ada_base_type = get_ada_base_type (gnu_type);
4636 tree gnu_in_lb = TYPE_MIN_VALUE (gnu_in_basetype);
4637 tree gnu_in_ub = TYPE_MAX_VALUE (gnu_in_basetype);
4638 tree gnu_out_lb = TYPE_MIN_VALUE (gnu_base_type);
4639 tree gnu_out_ub = TYPE_MAX_VALUE (gnu_base_type);
4640 tree gnu_result = gnu_expr;
4642 /* If we are not doing any checks, the output is an integral type, and
4643 the input is not a floating type, just do the conversion. This
4644 shortcut is required to avoid problems with packed array types
4645 and simplifies code in all cases anyway. */
4646 if (! range_p && ! overflow_p && INTEGRAL_TYPE_P (gnu_base_type)
4647 && ! FLOAT_TYPE_P (gnu_in_type))
4648 return convert (gnu_type, gnu_expr);
4650 /* First convert the expression to its base type. This
4651 will never generate code, but makes the tests below much simpler.
4652 But don't do this if converting from an integer type to an unconstrained
4653 array type since then we need to get the bounds from the original
4655 if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE)
4656 gnu_result = convert (gnu_in_basetype, gnu_result);
4658 /* If overflow checks are requested, we need to be sure the result will
4659 fit in the output base type. But don't do this if the input
4660 is integer and the output floating-point. */
4662 && ! (FLOAT_TYPE_P (gnu_base_type) && INTEGRAL_TYPE_P (gnu_in_basetype)))
4664 /* Ensure GNU_EXPR only gets evaluated once. */
4665 tree gnu_input = protect_multiple_eval (gnu_result);
4666 tree gnu_cond = integer_zero_node;
4668 /* Convert the lower bounds to signed types, so we're sure we're
4669 comparing them properly. Likewise, convert the upper bounds
4670 to unsigned types. */
4671 if (INTEGRAL_TYPE_P (gnu_in_basetype) && TREE_UNSIGNED (gnu_in_basetype))
4672 gnu_in_lb = convert (gnat_signed_type (gnu_in_basetype), gnu_in_lb);
4674 if (INTEGRAL_TYPE_P (gnu_in_basetype)
4675 && ! TREE_UNSIGNED (gnu_in_basetype))
4676 gnu_in_ub = convert (gnat_unsigned_type (gnu_in_basetype), gnu_in_ub);
4678 if (INTEGRAL_TYPE_P (gnu_base_type) && TREE_UNSIGNED (gnu_base_type))
4679 gnu_out_lb = convert (gnat_signed_type (gnu_base_type), gnu_out_lb);
4681 if (INTEGRAL_TYPE_P (gnu_base_type) && ! TREE_UNSIGNED (gnu_base_type))
4682 gnu_out_ub = convert (gnat_unsigned_type (gnu_base_type), gnu_out_ub);
4684 /* Check each bound separately and only if the result bound
4685 is tighter than the bound on the input type. Note that all the
4686 types are base types, so the bounds must be constant. Also,
4687 the comparison is done in the base type of the input, which
4688 always has the proper signedness. First check for input
4689 integer (which means output integer), output float (which means
4690 both float), or mixed, in which case we always compare.
4691 Note that we have to do the comparison which would *fail* in the
4692 case of an error since if it's an FP comparison and one of the
4693 values is a NaN or Inf, the comparison will fail. */
4694 if (INTEGRAL_TYPE_P (gnu_in_basetype)
4695 ? tree_int_cst_lt (gnu_in_lb, gnu_out_lb)
4696 : (FLOAT_TYPE_P (gnu_base_type)
4697 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_in_lb),
4698 TREE_REAL_CST (gnu_out_lb))
4702 (build_binary_op (GE_EXPR, integer_type_node,
4703 gnu_input, convert (gnu_in_basetype,
4706 if (INTEGRAL_TYPE_P (gnu_in_basetype)
4707 ? tree_int_cst_lt (gnu_out_ub, gnu_in_ub)
4708 : (FLOAT_TYPE_P (gnu_base_type)
4709 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_out_ub),
4710 TREE_REAL_CST (gnu_in_lb))
4713 = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, gnu_cond,
4715 (build_binary_op (LE_EXPR, integer_type_node,
4717 convert (gnu_in_basetype,
4720 if (! integer_zerop (gnu_cond))
4721 gnu_result = emit_check (gnu_cond, gnu_input,
4722 CE_Overflow_Check_Failed);
4725 /* Now convert to the result base type. If this is a non-truncating
4726 float-to-integer conversion, round. */
4727 if (INTEGRAL_TYPE_P (gnu_ada_base_type) && FLOAT_TYPE_P (gnu_in_basetype)
4730 tree gnu_point_5 = build_real (gnu_in_basetype, dconstp5);
4731 tree gnu_minus_point_5 = build_real (gnu_in_basetype, dconstmp5);
4732 tree gnu_zero = convert (gnu_in_basetype, integer_zero_node);
4733 tree gnu_saved_result = save_expr (gnu_result);
4734 tree gnu_comp = build (GE_EXPR, integer_type_node,
4735 gnu_saved_result, gnu_zero);
4736 tree gnu_adjust = build (COND_EXPR, gnu_in_basetype, gnu_comp,
4737 gnu_point_5, gnu_minus_point_5);
4740 = build (PLUS_EXPR, gnu_in_basetype, gnu_saved_result, gnu_adjust);
4743 if (TREE_CODE (gnu_ada_base_type) == INTEGER_TYPE
4744 && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_ada_base_type)
4745 && TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
4746 gnu_result = unchecked_convert (gnu_ada_base_type, gnu_result);
4748 gnu_result = convert (gnu_ada_base_type, gnu_result);
4750 /* Finally, do the range check if requested. Note that if the
4751 result type is a modular type, the range check is actually
4752 an overflow check. */
4755 || (TREE_CODE (gnu_base_type) == INTEGER_TYPE
4756 && TYPE_MODULAR_P (gnu_base_type) && overflow_p))
4757 gnu_result = emit_range_check (gnu_result, gnat_type);
4759 return convert (gnu_type, gnu_result);
4762 /* Return 1 if GNU_EXPR can be directly addressed. This is the case
4763 unless it is an expression involving computation or if it involves
4764 a bitfield reference. This returns the same as
4765 gnat_mark_addressable in most cases. */
4768 addressable_p (gnu_expr)
4771 switch (TREE_CODE (gnu_expr))
4773 case UNCONSTRAINED_ARRAY_REF:
4784 return (! DECL_BIT_FIELD (TREE_OPERAND (gnu_expr, 1))
4785 && addressable_p (TREE_OPERAND (gnu_expr, 0)));
4787 case ARRAY_REF: case ARRAY_RANGE_REF:
4788 case REALPART_EXPR: case IMAGPART_EXPR:
4790 return addressable_p (TREE_OPERAND (gnu_expr, 0));
4793 return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr))
4794 && addressable_p (TREE_OPERAND (gnu_expr, 0)));
4796 case VIEW_CONVERT_EXPR:
4798 /* This is addressable if we can avoid a copy. */
4799 tree type = TREE_TYPE (gnu_expr);
4800 tree inner_type = TREE_TYPE (TREE_OPERAND (gnu_expr, 0));
4802 return (((TYPE_MODE (type) == TYPE_MODE (inner_type)
4803 && (TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
4804 || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT))
4805 || ((TYPE_MODE (type) == BLKmode
4806 || TYPE_MODE (inner_type) == BLKmode)
4807 && (TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
4808 || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT
4809 || TYPE_ALIGN_OK (type)
4810 || TYPE_ALIGN_OK (inner_type))))
4811 && addressable_p (TREE_OPERAND (gnu_expr, 0)));
4819 /* Do the processing for the declaration of a GNAT_ENTITY, a type. If
4820 a separate Freeze node exists, delay the bulk of the processing. Otherwise
4821 make a GCC type for GNAT_ENTITY and set up the correspondance. */
4824 process_type (gnat_entity)
4825 Entity_Id gnat_entity;
4828 = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
4831 /* If we are to delay elaboration of this type, just do any
4832 elaborations needed for expressions within the declaration and
4833 make a dummy type entry for this node and its Full_View (if
4834 any) in case something points to it. Don't do this if it
4835 has already been done (the only way that can happen is if
4836 the private completion is also delayed). */
4837 if (Present (Freeze_Node (gnat_entity))
4838 || (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
4839 && Present (Full_View (gnat_entity))
4840 && Freeze_Node (Full_View (gnat_entity))
4841 && ! present_gnu_tree (Full_View (gnat_entity))))
4843 elaborate_entity (gnat_entity);
4847 tree gnu_decl = create_type_decl (get_entity_name (gnat_entity),
4848 make_dummy_type (gnat_entity),
4851 save_gnu_tree (gnat_entity, gnu_decl, 0);
4852 if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
4853 && Present (Full_View (gnat_entity)))
4854 save_gnu_tree (Full_View (gnat_entity), gnu_decl, 0);
4860 /* If we saved away a dummy type for this node it means that this
4861 made the type that corresponds to the full type of an incomplete
4862 type. Clear that type for now and then update the type in the
4866 if (TREE_CODE (gnu_old) != TYPE_DECL
4867 || ! TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old)))
4869 /* If this was a withed access type, this is not an error
4870 and merely indicates we've already elaborated the type
4872 if (Is_Type (gnat_entity) && From_With_Type (gnat_entity))
4878 save_gnu_tree (gnat_entity, NULL_TREE, 0);
4881 /* Now fully elaborate the type. */
4882 gnu_new = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 1);
4883 if (TREE_CODE (gnu_new) != TYPE_DECL)
4886 /* If we have an old type and we've made pointers to this type,
4887 update those pointers. */
4889 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
4890 TREE_TYPE (gnu_new));
4892 /* If this is a record type corresponding to a task or protected type
4893 that is a completion of an incomplete type, perform a similar update
4895 /* ??? Including protected types here is a guess. */
4897 if (IN (Ekind (gnat_entity), Record_Kind)
4898 && Is_Concurrent_Record_Type (gnat_entity)
4899 && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity)))
4902 = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity));
4904 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
4906 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
4909 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old)),
4910 TREE_TYPE (gnu_new));
4914 /* GNAT_ASSOC is the front of the Component_Associations of an N_Aggregate.
4915 GNU_TYPE is the GCC type of the corresponding record.
4917 Return a CONSTRUCTOR to build the record. */
4920 assoc_to_constructor (gnat_assoc, gnu_type)
4924 tree gnu_field, gnu_list, gnu_result;
4926 /* We test for GNU_FIELD being empty in the case where a variant
4927 was the last thing since we don't take things off GNAT_ASSOC in
4928 that case. We check GNAT_ASSOC in case we have a variant, but it
4931 for (gnu_list = NULL_TREE; Present (gnat_assoc);
4932 gnat_assoc = Next (gnat_assoc))
4934 Node_Id gnat_field = First (Choices (gnat_assoc));
4935 tree gnu_field = gnat_to_gnu_entity (Entity (gnat_field), NULL_TREE, 0);
4936 tree gnu_expr = gnat_to_gnu (Expression (gnat_assoc));
4938 /* The expander is supposed to put a single component selector name
4939 in every record component association */
4940 if (Next (gnat_field))
4943 /* Before assigning a value in an aggregate make sure range checks
4944 are done if required. Then convert to the type of the field. */
4945 if (Do_Range_Check (Expression (gnat_assoc)))
4946 gnu_expr = emit_range_check (gnu_expr, Etype (gnat_field));
4948 gnu_expr = convert (TREE_TYPE (gnu_field), gnu_expr);
4950 /* Add the field and expression to the list. */
4951 gnu_list = tree_cons (gnu_field, gnu_expr, gnu_list);
4954 gnu_result = extract_values (gnu_list, gnu_type);
4956 /* Verify every enty in GNU_LIST was used. */
4957 for (gnu_field = gnu_list; gnu_field; gnu_field = TREE_CHAIN (gnu_field))
4958 if (! TREE_ADDRESSABLE (gnu_field))
4964 /* Builds a possibly nested constructor for array aggregates. GNAT_EXPR
4965 is the first element of an array aggregate. It may itself be an
4966 aggregate (an array or record aggregate). GNU_ARRAY_TYPE is the gnu type
4967 corresponding to the array aggregate. GNAT_COMPONENT_TYPE is the type
4968 of the array component. It is needed for range checking. */
4971 pos_to_constructor (gnat_expr, gnu_array_type, gnat_component_type)
4973 tree gnu_array_type;
4974 Entity_Id gnat_component_type;
4977 tree gnu_expr_list = NULL_TREE;
4979 for ( ; Present (gnat_expr); gnat_expr = Next (gnat_expr))
4981 /* If the expression is itself an array aggregate then first build the
4982 innermost constructor if it is part of our array (multi-dimensional
4985 if (Nkind (gnat_expr) == N_Aggregate
4986 && TREE_CODE (TREE_TYPE (gnu_array_type)) == ARRAY_TYPE
4987 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type)))
4988 gnu_expr = pos_to_constructor (First (Expressions (gnat_expr)),
4989 TREE_TYPE (gnu_array_type),
4990 gnat_component_type);
4993 gnu_expr = gnat_to_gnu (gnat_expr);
4995 /* before assigning the element to the array make sure it is
4997 if (Do_Range_Check (gnat_expr))
4998 gnu_expr = emit_range_check (gnu_expr, gnat_component_type);
5002 = tree_cons (NULL_TREE, convert (TREE_TYPE (gnu_array_type), gnu_expr),
5006 return build_constructor (gnu_array_type, nreverse (gnu_expr_list));
5009 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
5010 some of which are from RECORD_TYPE. Return a CONSTRUCTOR consisting
5011 of the associations that are from RECORD_TYPE. If we see an internal
5012 record, make a recursive call to fill it in as well. */
5015 extract_values (values, record_type)
5019 tree result = NULL_TREE;
5022 for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field))
5026 /* _Parent is an internal field, but may have values in the aggregate,
5027 so check for values first. */
5028 if ((tem = purpose_member (field, values)) != 0)
5030 value = TREE_VALUE (tem);
5031 TREE_ADDRESSABLE (tem) = 1;
5034 else if (DECL_INTERNAL_P (field))
5036 value = extract_values (values, TREE_TYPE (field));
5037 if (TREE_CODE (value) == CONSTRUCTOR
5038 && CONSTRUCTOR_ELTS (value) == 0)
5042 /* If we have a record subtype, the names will match, but not the
5043 actual FIELD_DECLs. */
5044 for (tem = values; tem; tem = TREE_CHAIN (tem))
5045 if (DECL_NAME (TREE_PURPOSE (tem)) == DECL_NAME (field))
5047 value = convert (TREE_TYPE (field), TREE_VALUE (tem));
5048 TREE_ADDRESSABLE (tem) = 1;
5054 result = tree_cons (field, value, result);
5057 return build_constructor (record_type, nreverse (result));
5060 /* EXP is to be treated as an array or record. Handle the cases when it is
5061 an access object and perform the required dereferences. */
5064 maybe_implicit_deref (exp)
5067 /* If the type is a pointer, dereference it. */
5069 if (POINTER_TYPE_P (TREE_TYPE (exp)) || TYPE_FAT_POINTER_P (TREE_TYPE (exp)))
5070 exp = build_unary_op (INDIRECT_REF, NULL_TREE, exp);
5072 /* If we got a padded type, remove it too. */
5073 if (TREE_CODE (TREE_TYPE (exp)) == RECORD_TYPE
5074 && TYPE_IS_PADDING_P (TREE_TYPE (exp)))
5075 exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
5080 /* Protect EXP from multiple evaluation. This may make a SAVE_EXPR. */
5083 protect_multiple_eval (exp)
5086 tree type = TREE_TYPE (exp);
5088 /* If this has no side effects, we don't need to do anything. */
5089 if (! TREE_SIDE_EFFECTS (exp))
5092 /* If it is a conversion, protect what's inside the conversion.
5093 Similarly, if we're indirectly referencing something, we only
5094 actually need to protect the address since the data itself can't
5095 change in these situations. */
5096 else if (TREE_CODE (exp) == NON_LVALUE_EXPR
5097 || TREE_CODE (exp) == NOP_EXPR || TREE_CODE (exp) == CONVERT_EXPR
5098 || TREE_CODE (exp) == VIEW_CONVERT_EXPR
5099 || TREE_CODE (exp) == INDIRECT_REF
5100 || TREE_CODE (exp) == UNCONSTRAINED_ARRAY_REF)
5101 return build1 (TREE_CODE (exp), type,
5102 protect_multiple_eval (TREE_OPERAND (exp, 0)));
5104 /* If EXP is a fat pointer or something that can be placed into a register,
5105 just make a SAVE_EXPR. */
5106 if (TYPE_FAT_POINTER_P (type) || TYPE_MODE (type) != BLKmode)
5107 return save_expr (exp);
5109 /* Otherwise, dereference, protect the address, and re-reference. */
5112 build_unary_op (INDIRECT_REF, type,
5113 save_expr (build_unary_op (ADDR_EXPR,
5114 build_reference_type (type),
5118 /* This is equivalent to stabilize_reference in GCC's tree.c, but we know
5119 how to handle our new nodes and we take an extra argument that says
5120 whether to force evaluation of everything. */
5123 gnat_stabilize_reference (ref, force)
5127 register tree type = TREE_TYPE (ref);
5128 register enum tree_code code = TREE_CODE (ref);
5129 register tree result;
5136 /* No action is needed in this case. */
5142 case FIX_TRUNC_EXPR:
5143 case FIX_FLOOR_EXPR:
5144 case FIX_ROUND_EXPR:
5146 case VIEW_CONVERT_EXPR:
5149 = build1 (code, type,
5150 gnat_stabilize_reference (TREE_OPERAND (ref, 0), force));
5154 case UNCONSTRAINED_ARRAY_REF:
5155 result = build1 (code, type,
5156 gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0),
5161 result = build (COMPONENT_REF, type,
5162 gnat_stabilize_reference (TREE_OPERAND (ref, 0),
5164 TREE_OPERAND (ref, 1));
5168 result = build (BIT_FIELD_REF, type,
5169 gnat_stabilize_reference (TREE_OPERAND (ref, 0), force),
5170 gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
5172 gnat_stabilize_reference_1 (TREE_OPERAND (ref, 2),
5177 result = build (ARRAY_REF, type,
5178 gnat_stabilize_reference (TREE_OPERAND (ref, 0), force),
5179 gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
5183 case ARRAY_RANGE_REF:
5184 result = build (ARRAY_RANGE_REF, type,
5185 gnat_stabilize_reference (TREE_OPERAND (ref, 0), force),
5186 gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
5191 result = build (COMPOUND_EXPR, type,
5192 gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0),
5194 gnat_stabilize_reference (TREE_OPERAND (ref, 1),
5199 result = build1 (INDIRECT_REF, type,
5200 save_expr (build1 (ADDR_EXPR,
5201 build_reference_type (type), ref)));
5204 /* If arg isn't a kind of lvalue we recognize, make no change.
5205 Caller should recognize the error for an invalid lvalue. */
5210 return error_mark_node;
5213 TREE_READONLY (result) = TREE_READONLY (ref);
5217 /* Similar to stabilize_reference_1 in tree.c, but supports an extra
5218 arg to force a SAVE_EXPR for everything. */
5221 gnat_stabilize_reference_1 (e, force)
5225 register enum tree_code code = TREE_CODE (e);
5226 register tree type = TREE_TYPE (e);
5227 register tree result;
5229 /* We cannot ignore const expressions because it might be a reference
5230 to a const array but whose index contains side-effects. But we can
5231 ignore things that are actual constant or that already have been
5232 handled by this function. */
5234 if (TREE_CONSTANT (e) || code == SAVE_EXPR)
5237 switch (TREE_CODE_CLASS (code))
5247 if (TREE_SIDE_EFFECTS (e) || force)
5248 return save_expr (e);
5252 /* Constants need no processing. In fact, we should never reach
5257 /* Recursively stabilize each operand. */
5258 result = build (code, type,
5259 gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force),
5260 gnat_stabilize_reference_1 (TREE_OPERAND (e, 1), force));
5264 /* Recursively stabilize each operand. */
5265 result = build1 (code, type,
5266 gnat_stabilize_reference_1 (TREE_OPERAND (e, 0),
5274 TREE_READONLY (result) = TREE_READONLY (e);
5278 /* GNAT_UNIT is the Defining_Identifier for some package or subprogram,
5279 either a spec or a body, BODY_P says which. If needed, make a function
5280 to be the elaboration routine for that object and perform the elaborations
5283 Return 1 if we didn't need an elaboration function, zero otherwise. */
5286 build_unit_elab (gnat_unit, body_p, gnu_elab_list)
5287 Entity_Id gnat_unit;
5295 /* If we have nothing to do, return. */
5296 if (gnu_elab_list == 0)
5299 /* Set our file and line number to that of the object and set up the
5300 elaboration routine. */
5301 gnu_decl = create_subprog_decl (create_concat_name (gnat_unit,
5304 NULL_TREE, void_ftype, NULL_TREE, 0, 1, 0,
5306 DECL_ELABORATION_PROC_P (gnu_decl) = 1;
5308 begin_subprog_body (gnu_decl);
5309 set_lineno (gnat_unit, 1);
5311 gnu_block_stack = tree_cons (NULL_TREE, NULL_TREE, gnu_block_stack);
5312 expand_start_bindings (0);
5314 /* Emit the assignments for the elaborations we have to do. If there
5315 is no destination, this is just a call to execute some statement
5316 that was placed within the declarative region. But first save a
5317 pointer so we can see if any insns were generated. */
5319 insn = get_last_insn ();
5321 for (; gnu_elab_list; gnu_elab_list = TREE_CHAIN (gnu_elab_list))
5322 if (TREE_PURPOSE (gnu_elab_list) == NULL_TREE)
5324 if (TREE_VALUE (gnu_elab_list) != 0)
5325 expand_expr_stmt (TREE_VALUE (gnu_elab_list));
5329 tree lhs = TREE_PURPOSE (gnu_elab_list);
5331 input_filename = DECL_SOURCE_FILE (lhs);
5332 lineno = DECL_SOURCE_LINE (lhs);
5334 /* If LHS has a padded type, convert it to the unpadded type
5335 so the assignment is done properly. */
5336 if (TREE_CODE (TREE_TYPE (lhs)) == RECORD_TYPE
5337 && TYPE_IS_PADDING_P (TREE_TYPE (lhs)))
5338 lhs = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (lhs))), lhs);
5340 emit_line_note (input_filename, lineno);
5341 expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE,
5342 TREE_PURPOSE (gnu_elab_list),
5343 TREE_VALUE (gnu_elab_list)));
5346 /* See if any non-NOTE insns were generated. */
5347 for (insn = NEXT_INSN (insn); insn; insn = NEXT_INSN (insn))
5348 if (GET_RTX_CLASS (GET_CODE (insn)) == 'i')
5354 expand_end_bindings (getdecls (), kept_level_p (), 0);
5355 poplevel (kept_level_p (), 1, 0);
5356 gnu_block_stack = TREE_CHAIN (gnu_block_stack);
5357 end_subprog_body ();
5359 /* If there were no insns, we don't need an elab routine. It would
5360 be nice to not output this one, but there's no good way to do that. */
5364 extern char *__gnat_to_canonical_file_spec PARAMS ((char *));
5366 /* Determine the input_filename and the lineno from the source location
5367 (Sloc) of GNAT_NODE node. Set the global variable input_filename and
5368 lineno. If WRITE_NOTE_P is true, emit a line number note. */
5371 set_lineno (gnat_node, write_note_p)
5375 Source_Ptr source_location = Sloc (gnat_node);
5377 /* If node not from source code, ignore. */
5378 if (source_location < 0)
5381 /* Use the identifier table to make a hashed, permanent copy of the filename,
5382 since the name table gets reallocated after Gigi returns but before all
5383 the debugging information is output. The call to
5384 __gnat_to_canonical_file_spec translates filenames from pragmas
5385 Source_Reference that contain host style syntax not understood by gdb. */
5387 = IDENTIFIER_POINTER
5389 (__gnat_to_canonical_file_spec
5391 (Debug_Source_Name (Get_Source_File_Index (source_location))))));
5393 /* ref_filename is the reference file name as given by sinput (i.e no
5396 = IDENTIFIER_POINTER
5399 (Reference_Name (Get_Source_File_Index (source_location)))));;
5400 lineno = Get_Logical_Line_Number (source_location);
5403 emit_line_note (input_filename, lineno);
5406 /* Post an error message. MSG is the error message, properly annotated.
5407 NODE is the node at which to post the error and the node to use for the
5408 "&" substitution. */
5411 post_error (msg, node)
5415 String_Template temp;
5418 temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
5419 fp.Array = msg, fp.Bounds = &temp;
5421 Error_Msg_N (fp, node);
5424 /* Similar, but NODE is the node at which to post the error and ENT
5425 is the node to use for the "&" substitution. */
5428 post_error_ne (msg, node, ent)
5433 String_Template temp;
5436 temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
5437 fp.Array = msg, fp.Bounds = &temp;
5439 Error_Msg_NE (fp, node, ent);
5442 /* Similar, but NODE is the node at which to post the error, ENT is the node
5443 to use for the "&" substitution, and N is the number to use for the ^. */
5446 post_error_ne_num (msg, node, ent, n)
5452 String_Template temp;
5455 temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
5456 fp.Array = msg, fp.Bounds = &temp;
5457 Error_Msg_Uint_1 = UI_From_Int (n);
5460 Error_Msg_NE (fp, node, ent);
5463 /* Similar to post_error_ne_num, but T is a GCC tree representing the
5464 number to write. If the tree represents a constant that fits within
5465 a host integer, the text inside curly brackets in MSG will be output
5466 (presumably including a '^'). Otherwise that text will not be output
5467 and the text inside square brackets will be output instead. */
5470 post_error_ne_tree (msg, node, ent, t)
5476 char *newmsg = alloca (strlen (msg) + 1);
5477 String_Template temp = {1, 0};
5479 char start_yes, end_yes, start_no, end_no;
5483 fp.Array = newmsg, fp.Bounds = &temp;
5485 if (host_integerp (t, 1)
5486 #if HOST_BITS_PER_WIDE_INT > HOST_BITS_PER_INT
5487 && compare_tree_int (t, 1 << (HOST_BITS_PER_INT - 2)) < 0
5491 Error_Msg_Uint_1 = UI_From_Int (tree_low_cst (t, 1));
5492 start_yes = '{', end_yes = '}', start_no = '[', end_no = ']';
5495 start_yes = '[', end_yes = ']', start_no = '{', end_no = '}';
5497 for (p = msg, q = newmsg; *p != 0; p++)
5499 if (*p == start_yes)
5500 for (p++; *p != end_yes; p++)
5502 else if (*p == start_no)
5503 for (p++; *p != end_no; p++)
5511 temp.High_Bound = strlen (newmsg);
5513 Error_Msg_NE (fp, node, ent);
5516 /* Similar to post_error_ne_tree, except that NUM is a second
5517 integer to write in the message. */
5520 post_error_ne_tree_2 (msg, node, ent, t, num)
5527 Error_Msg_Uint_2 = UI_From_Int (num);
5528 post_error_ne_tree (msg, node, ent, t);
5531 /* Set the node for a second '&' in the error message. */
5534 set_second_error_entity (e)
5537 Error_Msg_Node_2 = e;
5540 /* Signal abort, with "Gigi abort" as the error label, and error_gnat_node
5541 as the relevant node that provides the location info for the error */
5547 String_Template temp = {1, 10};
5550 fp.Array = "Gigi abort", fp.Bounds = &temp;
5552 Current_Error_Node = error_gnat_node;
5553 Compiler_Abort (fp, code);
5556 /* Initialize the table that maps GNAT codes to GCC codes for simple
5557 binary and unary operations. */
5562 gnu_codes[N_And_Then] = TRUTH_ANDIF_EXPR;
5563 gnu_codes[N_Or_Else] = TRUTH_ORIF_EXPR;
5565 gnu_codes[N_Op_And] = TRUTH_AND_EXPR;
5566 gnu_codes[N_Op_Or] = TRUTH_OR_EXPR;
5567 gnu_codes[N_Op_Xor] = TRUTH_XOR_EXPR;
5568 gnu_codes[N_Op_Eq] = EQ_EXPR;
5569 gnu_codes[N_Op_Ne] = NE_EXPR;
5570 gnu_codes[N_Op_Lt] = LT_EXPR;
5571 gnu_codes[N_Op_Le] = LE_EXPR;
5572 gnu_codes[N_Op_Gt] = GT_EXPR;
5573 gnu_codes[N_Op_Ge] = GE_EXPR;
5574 gnu_codes[N_Op_Add] = PLUS_EXPR;
5575 gnu_codes[N_Op_Subtract] = MINUS_EXPR;
5576 gnu_codes[N_Op_Multiply] = MULT_EXPR;
5577 gnu_codes[N_Op_Mod] = FLOOR_MOD_EXPR;
5578 gnu_codes[N_Op_Rem] = TRUNC_MOD_EXPR;
5579 gnu_codes[N_Op_Minus] = NEGATE_EXPR;
5580 gnu_codes[N_Op_Abs] = ABS_EXPR;
5581 gnu_codes[N_Op_Not] = TRUTH_NOT_EXPR;
5582 gnu_codes[N_Op_Rotate_Left] = LROTATE_EXPR;
5583 gnu_codes[N_Op_Rotate_Right] = RROTATE_EXPR;
5584 gnu_codes[N_Op_Shift_Left] = LSHIFT_EXPR;
5585 gnu_codes[N_Op_Shift_Right] = RSHIFT_EXPR;
5586 gnu_codes[N_Op_Shift_Right_Arithmetic] = RSHIFT_EXPR;
5589 #include "gt-ada-trans.h"
OSDN Git Service
