1 /****************************************************************************
2 * *
3 * GNAT COMPILER COMPONENTS *
4 * *
5 * T R A N S *
6 * *
7 * C Implementation File *
8 * *
9 * Copyright (C) 1992-2004, Free Software Foundation, Inc. *
10 * *
11 * GNAT is free software; you can redistribute it and/or modify it under *
12 * terms of the GNU General Public License as published by the Free Soft- *
13 * ware Foundation; either version 2, or (at your option) any later ver- *
14 * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
15 * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
16 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
17 * for more details. You should have received a copy of the GNU General *
18 * Public License distributed with GNAT; see file COPYING. If not, write *
19 * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
20 * MA 02111-1307, USA. *
21 * *
22 * GNAT was originally developed by the GNAT team at New York University. *
23 * Extensive contributions were provided by Ada Core Technologies Inc. *
24 * *
25 ****************************************************************************/
26
27 #include "config.h"
28 #include "system.h"
29 #include "coretypes.h"
30 #include "tm.h"
31 #include "tree.h"
32 #include "real.h"
33 #include "flags.h"
34 #include "rtl.h"
35 #include "expr.h"
36 #include "ggc.h"
37 #include "function.h"
38 #include "except.h"
39 #include "debug.h"
40 #include "output.h"
41 #include "ada.h"
42 #include "types.h"
43 #include "atree.h"
44 #include "elists.h"
45 #include "namet.h"
46 #include "nlists.h"
47 #include "snames.h"
48 #include "stringt.h"
49 #include "uintp.h"
50 #include "urealp.h"
51 #include "fe.h"
52 #include "sinfo.h"
53 #include "einfo.h"
54 #include "ada-tree.h"
55 #include "gigi.h"
56
57 int max_gnat_nodes;
58 int number_names;
59 struct Node *Nodes_Ptr;
60 Node_Id *Next_Node_Ptr;
61 Node_Id *Prev_Node_Ptr;
62 struct Elist_Header *Elists_Ptr;
63 struct Elmt_Item *Elmts_Ptr;
64 struct String_Entry *Strings_Ptr;
65 Char_Code *String_Chars_Ptr;
66 struct List_Header *List_Headers_Ptr;
67
68 /* Current filename without path. */
69 const char *ref_filename;
70
71 /* Flag indicating whether file names are discarded in exception messages */
72 int discard_file_names;
73
74 /* If true, then gigi is being called on an analyzed but unexpanded
75 tree, and the only purpose of the call is to properly annotate
76 types with representation information. */
77 int type_annotate_only;
78
79 /* List of TREE_LIST nodes representing a block stack. TREE_VALUE
80 of each gives the variable used for the setjmp buffer in the current
81 block, if any. TREE_PURPOSE gives the bottom condition for a loop,
82 if this block is for a loop. The latter is only used to save the tree
83 over GC. */
84 tree gnu_block_stack;
85
86 /* List of TREE_LIST nodes representing a stack of exception pointer
87 variables. TREE_VALUE is the VAR_DECL that stores the address of
88 the raised exception. Nonzero means we are in an exception
89 handler. Not used in the zero-cost case. */
90 static GTY(()) tree gnu_except_ptr_stack;
91
92 /* List of TREE_LIST nodes containing pending elaborations lists.
93 used to prevent the elaborations being reclaimed by GC. */
94 static GTY(()) tree gnu_pending_elaboration_lists;
95
96 /* Map GNAT tree codes to GCC tree codes for simple expressions. */
97 static enum tree_code gnu_codes[Number_Node_Kinds];
98
99 /* Current node being treated, in case gigi_abort called. */
100 Node_Id error_gnat_node;
101
102 /* Variable that stores a list of labels to be used as a goto target instead of
103 a return in some functions. See processing for N_Subprogram_Body. */
104 static GTY(()) tree gnu_return_label_stack;
105
106 static tree tree_transform (Node_Id);
107 static void elaborate_all_entities (Node_Id);
108 static void process_freeze_entity (Node_Id);
109 static void process_inlined_subprograms (Node_Id);
110 static void process_decls (List_Id, List_Id, Node_Id, int, int);
111 static tree emit_range_check (tree, Node_Id);
112 static tree emit_index_check (tree, tree, tree, tree);
113 static tree emit_check (tree, tree, int);
114 static tree convert_with_check (Entity_Id, tree, int, int, int);
115 static int addressable_p (tree);
116 static tree assoc_to_constructor (Node_Id, tree);
117 static tree extract_values (tree, tree);
118 static tree pos_to_constructor (Node_Id, tree, Entity_Id);
119 static tree maybe_implicit_deref (tree);
120 static tree gnat_stabilize_reference_1 (tree, int);
121 static int build_unit_elab (Entity_Id, int, tree);
122
123 /* Constants for +0.5 and -0.5 for float-to-integer rounding. */
124 static REAL_VALUE_TYPE dconstp5;
125 static REAL_VALUE_TYPE dconstmp5;
126
127 /* This is the main program of the back-end. It sets up all the table
128 structures and then generates code. */
129
130 void
gigi(Node_Id gnat_root,int max_gnat_node,int number_name,struct Node * nodes_ptr,Node_Id * next_node_ptr,Node_Id * prev_node_ptr,struct Elist_Header * elists_ptr,struct Elmt_Item * elmts_ptr,struct String_Entry * strings_ptr,Char_Code * string_chars_ptr,struct List_Header * list_headers_ptr,Int number_units ATTRIBUTE_UNUSED,char * file_info_ptr ATTRIBUTE_UNUSED,Entity_Id standard_integer,Entity_Id standard_long_long_float,Entity_Id standard_exception_type,Int gigi_operating_mode)131 gigi (Node_Id gnat_root,
132 int max_gnat_node,
133 int number_name,
134 struct Node *nodes_ptr,
135 Node_Id *next_node_ptr,
136 Node_Id *prev_node_ptr,
137 struct Elist_Header *elists_ptr,
138 struct Elmt_Item *elmts_ptr,
139 struct String_Entry *strings_ptr,
140 Char_Code *string_chars_ptr,
141 struct List_Header *list_headers_ptr,
142 Int number_units ATTRIBUTE_UNUSED,
143 char *file_info_ptr ATTRIBUTE_UNUSED,
144 Entity_Id standard_integer,
145 Entity_Id standard_long_long_float,
146 Entity_Id standard_exception_type,
147 Int gigi_operating_mode)
148 {
149 tree gnu_standard_long_long_float;
150 tree gnu_standard_exception_type;
151
152 max_gnat_nodes = max_gnat_node;
153 number_names = number_name;
154 Nodes_Ptr = nodes_ptr;
155 Next_Node_Ptr = next_node_ptr;
156 Prev_Node_Ptr = prev_node_ptr;
157 Elists_Ptr = elists_ptr;
158 Elmts_Ptr = elmts_ptr;
159 Strings_Ptr = strings_ptr;
160 String_Chars_Ptr = string_chars_ptr;
161 List_Headers_Ptr = list_headers_ptr;
162
163 type_annotate_only = (gigi_operating_mode == 1);
164
165 /* If we are just annotating types, give VOID_TYPE zero sizes to avoid
166 errors. */
167 if (type_annotate_only)
168 {
169 TYPE_SIZE (void_type_node) = bitsize_zero_node;
170 TYPE_SIZE_UNIT (void_type_node) = size_zero_node;
171 }
172
173 /* See if we should discard file names in exception messages. */
174 discard_file_names = Debug_Flag_NN;
175
176 if (Nkind (gnat_root) != N_Compilation_Unit)
177 gigi_abort (301);
178
179 set_lineno (gnat_root, 0);
180
181 /* Initialize ourselves. */
182 init_gnat_to_gnu ();
183 init_dummy_type ();
184 init_code_table ();
185 gnat_compute_largest_alignment ();
186
187 /* Enable GNAT stack checking method if needed */
188 if (!Stack_Check_Probes_On_Target)
189 set_stack_check_libfunc (gen_rtx (SYMBOL_REF, Pmode, "_gnat_stack_check"));
190
191 /* Save the type we made for integer as the type for Standard.Integer.
192 Then make the rest of the standard types. Note that some of these
193 may be subtypes. */
194 save_gnu_tree (Base_Type (standard_integer),
195 TYPE_NAME (integer_type_node), 0);
196
197 gnu_except_ptr_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE);
198
199 REAL_ARITHMETIC (dconstp5, RDIV_EXPR, dconst1, dconst2);
200 REAL_ARITHMETIC (dconstmp5, RDIV_EXPR, dconstm1, dconst2);
201
202 gnu_standard_long_long_float
203 = gnat_to_gnu_entity (Base_Type (standard_long_long_float), NULL_TREE, 0);
204 gnu_standard_exception_type
205 = gnat_to_gnu_entity (Base_Type (standard_exception_type), NULL_TREE, 0);
206
207 init_gigi_decls (gnu_standard_long_long_float, gnu_standard_exception_type);
208
209 /* Process any Pragma Ident for the main unit. */
210 #ifdef ASM_OUTPUT_IDENT
211 if (Present (Ident_String (Main_Unit)))
212 ASM_OUTPUT_IDENT
213 (asm_out_file,
214 TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit))));
215 #endif
216
217 /* If we are using the GCC exception mechanism, let GCC know. */
218 if (Exception_Mechanism == GCC_ZCX)
219 gnat_init_gcc_eh ();
220
221 gnat_to_code (gnat_root);
222 }
223
224
225 /* This function is the driver of the GNAT to GCC tree transformation process.
226 GNAT_NODE is the root of some gnat tree. It generates code for that
227 part of the tree. */
228
229 void
gnat_to_code(Node_Id gnat_node)230 gnat_to_code (Node_Id gnat_node)
231 {
232 tree gnu_root;
233
234 /* Save node number in case error */
235 error_gnat_node = gnat_node;
236
237 gnu_root = tree_transform (gnat_node);
238
239 /* If we return a statement, generate code for it. */
240 if (IS_STMT (gnu_root))
241 expand_expr_stmt (gnu_root);
242
243 /* This should just generate code, not return a value. If it returns
244 a value, something is wrong. */
245 else if (gnu_root != error_mark_node)
246 gigi_abort (302);
247 }
248
249 /* GNAT_NODE is the root of some GNAT tree. Return the root of the GCC
250 tree corresponding to that GNAT tree. Normally, no code is generated.
251 We just return an equivalent tree which is used elsewhere to generate
252 code. */
253
254 tree
gnat_to_gnu(Node_Id gnat_node)255 gnat_to_gnu (Node_Id gnat_node)
256 {
257 tree gnu_root;
258
259 /* Save node number in case error */
260 error_gnat_node = gnat_node;
261
262 gnu_root = tree_transform (gnat_node);
263
264 /* If we got no code as a result, something is wrong. */
265 if (gnu_root == error_mark_node && ! type_annotate_only)
266 gigi_abort (303);
267
268 return gnu_root;
269 }
270
271 /* This function is the driver of the GNAT to GCC tree transformation process.
272 It is the entry point of the tree transformer. GNAT_NODE is the root of
273 some GNAT tree. Return the root of the corresponding GCC tree or
274 error_mark_node to signal that there is no GCC tree to return.
275
276 The latter is the case if only code generation actions have to be performed
277 like in the case of if statements, loops, etc. This routine is wrapped
278 in the above two routines for most purposes. */
279
280 static tree
tree_transform(Node_Id gnat_node)281 tree_transform (Node_Id gnat_node)
282 {
283 tree gnu_result = error_mark_node; /* Default to no value. */
284 tree gnu_result_type = void_type_node;
285 tree gnu_expr;
286 tree gnu_lhs, gnu_rhs;
287 Node_Id gnat_temp;
288 Entity_Id gnat_temp_type;
289
290 /* Set input_file_name and lineno from the Sloc in the GNAT tree. */
291 set_lineno (gnat_node, 0);
292
293 /* If this is a Statement and we are at top level, we add the statement
294 as an elaboration for a null tree. That will cause it to be placed
295 in the elaboration procedure. */
296 if (global_bindings_p ()
297 && ((IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call)
298 && Nkind (gnat_node) != N_Null_Statement)
299 || Nkind (gnat_node) == N_Procedure_Call_Statement
300 || Nkind (gnat_node) == N_Label
301 || (Nkind (gnat_node) == N_Handled_Sequence_Of_Statements
302 && (Present (Exception_Handlers (gnat_node))
303 || Present (At_End_Proc (gnat_node))))
304 || ((Nkind (gnat_node) == N_Raise_Constraint_Error
305 || Nkind (gnat_node) == N_Raise_Storage_Error
306 || Nkind (gnat_node) == N_Raise_Program_Error)
307 && (Ekind (Etype (gnat_node)) == E_Void))))
308 {
309 add_pending_elaborations (NULL_TREE, make_transform_expr (gnat_node));
310
311 return error_mark_node;
312 }
313
314 /* If this node is a non-static subexpression and we are only
315 annotating types, make this into a NULL_EXPR for non-VOID types
316 and error_mark_node for void return types. But allow
317 N_Identifier since we use it for lots of things, including
318 getting trees for discriminants. */
319
320 if (type_annotate_only
321 && IN (Nkind (gnat_node), N_Subexpr)
322 && Nkind (gnat_node) != N_Identifier
323 && ! Compile_Time_Known_Value (gnat_node))
324 {
325 gnu_result_type = get_unpadded_type (Etype (gnat_node));
326
327 if (TREE_CODE (gnu_result_type) == VOID_TYPE)
328 return error_mark_node;
329 else
330 return build1 (NULL_EXPR, gnu_result_type,
331 build_call_raise (CE_Range_Check_Failed));
332 }
333
334 switch (Nkind (gnat_node))
335 {
336 /********************************/
337 /* Chapter 2: Lexical Elements: */
338 /********************************/
339
340 case N_Identifier:
341 case N_Expanded_Name:
342 case N_Operator_Symbol:
343 case N_Defining_Identifier:
344
345 /* If the Etype of this node does not equal the Etype of the
346 Entity, something is wrong with the entity map, probably in
347 generic instantiation. However, this does not apply to
348 types. Since we sometime have strange Ekind's, just do
349 this test for objects. Also, if the Etype of the Entity is
350 private, the Etype of the N_Identifier is allowed to be the full
351 type and also we consider a packed array type to be the same as
352 the original type. Similarly, a class-wide type is equivalent
353 to a subtype of itself. Finally, if the types are Itypes,
354 one may be a copy of the other, which is also legal. */
355
356 gnat_temp = (Nkind (gnat_node) == N_Defining_Identifier
357 ? gnat_node : Entity (gnat_node));
358 gnat_temp_type = Etype (gnat_temp);
359
360 if (Etype (gnat_node) != gnat_temp_type
361 && ! (Is_Packed (gnat_temp_type)
362 && Etype (gnat_node) == Packed_Array_Type (gnat_temp_type))
363 && ! (Is_Class_Wide_Type (Etype (gnat_node)))
364 && ! (IN (Ekind (gnat_temp_type), Private_Kind)
365 && Present (Full_View (gnat_temp_type))
366 && ((Etype (gnat_node) == Full_View (gnat_temp_type))
367 || (Is_Packed (Full_View (gnat_temp_type))
368 && Etype (gnat_node) ==
369 Packed_Array_Type (Full_View (gnat_temp_type)))))
370 && (!Is_Itype (Etype (gnat_node)) || !Is_Itype (gnat_temp_type))
371 && (Ekind (gnat_temp) == E_Variable
372 || Ekind (gnat_temp) == E_Component
373 || Ekind (gnat_temp) == E_Constant
374 || Ekind (gnat_temp) == E_Loop_Parameter
375 || IN (Ekind (gnat_temp), Formal_Kind)))
376 gigi_abort (304);
377
378 /* If this is a reference to a deferred constant whose partial view
379 is an unconstrained private type, the proper type is on the full
380 view of the constant, not on the full view of the type, which may
381 be unconstrained.
382
383 This may be a reference to a type, for example in the prefix of the
384 attribute Position, generated for dispatching code (see Make_DT in
385 exp_disp,adb). In that case we need the type itself, not is parent,
386 in particular if it is a derived type */
387
388 if (Is_Private_Type (gnat_temp_type)
389 && Has_Unknown_Discriminants (gnat_temp_type)
390 && Present (Full_View (gnat_temp))
391 && ! Is_Type (gnat_temp))
392 {
393 gnat_temp = Full_View (gnat_temp);
394 gnat_temp_type = Etype (gnat_temp);
395 gnu_result_type = get_unpadded_type (gnat_temp_type);
396 }
397 else
398 {
399 /* Expand the type of this identitier first, in case it is
400 an enumeral literal, which only get made when the type
401 is expanded. There is no order-of-elaboration issue here.
402 We want to use the Actual_Subtype if it has already been
403 elaborated, otherwise the Etype. Avoid using Actual_Subtype
404 for packed arrays to simplify things. */
405 if ((Ekind (gnat_temp) == E_Constant
406 || Ekind (gnat_temp) == E_Variable || Is_Formal (gnat_temp))
407 && ! (Is_Array_Type (Etype (gnat_temp))
408 && Present (Packed_Array_Type (Etype (gnat_temp))))
409 && Present (Actual_Subtype (gnat_temp))
410 && present_gnu_tree (Actual_Subtype (gnat_temp)))
411 gnat_temp_type = Actual_Subtype (gnat_temp);
412 else
413 gnat_temp_type = Etype (gnat_node);
414
415 gnu_result_type = get_unpadded_type (gnat_temp_type);
416 }
417
418 gnu_result = gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0);
419
420 /* If we are in an exception handler, force this variable into memory
421 to ensure optimization does not remove stores that appear
422 redundant but are actually needed in case an exception occurs.
423
424 ??? Note that we need not do this if the variable is declared within
425 the handler, only if it is referenced in the handler and declared
426 in an enclosing block, but we have no way of testing that
427 right now. */
428 if (TREE_VALUE (gnu_except_ptr_stack) != 0)
429 {
430 gnat_mark_addressable (gnu_result);
431 flush_addressof (gnu_result);
432 }
433
434 /* Some objects (such as parameters passed by reference, globals of
435 variable size, and renamed objects) actually represent the address
436 of the object. In that case, we must do the dereference. Likewise,
437 deal with parameters to foreign convention subprograms. Call fold
438 here since GNU_RESULT may be a CONST_DECL. */
439 if (DECL_P (gnu_result)
440 && (DECL_BY_REF_P (gnu_result)
441 || (TREE_CODE (gnu_result) == PARM_DECL
442 && DECL_BY_COMPONENT_PTR_P (gnu_result))))
443 {
444 int ro = DECL_POINTS_TO_READONLY_P (gnu_result);
445
446 if (TREE_CODE (gnu_result) == PARM_DECL
447 && DECL_BY_COMPONENT_PTR_P (gnu_result))
448 gnu_result = convert (build_pointer_type (gnu_result_type),
449 gnu_result);
450
451 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE,
452 fold (gnu_result));
453 TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result) = ro;
454 }
455
456 /* The GNAT tree has the type of a function as the type of its result.
457 Also use the type of the result if the Etype is a subtype which
458 is nominally unconstrained. But remove any padding from the
459 resulting type. */
460 if (TREE_CODE (TREE_TYPE (gnu_result)) == FUNCTION_TYPE
461 || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type))
462 {
463 gnu_result_type = TREE_TYPE (gnu_result);
464 if (TREE_CODE (gnu_result_type) == RECORD_TYPE
465 && TYPE_IS_PADDING_P (gnu_result_type))
466 gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type));
467 }
468
469 /* We always want to return the underlying INTEGER_CST for an
470 enumeration literal to avoid the need to call fold in lots
471 of places. But don't do this is the parent will be taking
472 the address of this object. */
473 if (TREE_CODE (gnu_result) == CONST_DECL)
474 {
475 gnat_temp = Parent (gnat_node);
476 if (DECL_CONST_CORRESPONDING_VAR (gnu_result) == 0
477 || (Nkind (gnat_temp) != N_Reference
478 && ! (Nkind (gnat_temp) == N_Attribute_Reference
479 && ((Get_Attribute_Id (Attribute_Name (gnat_temp))
480 == Attr_Address)
481 || (Get_Attribute_Id (Attribute_Name (gnat_temp))
482 == Attr_Access)
483 || (Get_Attribute_Id (Attribute_Name (gnat_temp))
484 == Attr_Unchecked_Access)
485 || (Get_Attribute_Id (Attribute_Name (gnat_temp))
486 == Attr_Unrestricted_Access)))))
487 gnu_result = DECL_INITIAL (gnu_result);
488 }
489 break;
490
491 case N_Integer_Literal:
492 {
493 tree gnu_type;
494
495 /* Get the type of the result, looking inside any padding and
496 left-justified modular types. Then get the value in that type. */
497 gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
498
499 if (TREE_CODE (gnu_type) == RECORD_TYPE
500 && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_type))
501 gnu_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
502
503 gnu_result = UI_To_gnu (Intval (gnat_node), gnu_type);
504
505 /* If the result overflows (meaning it doesn't fit in its base type),
506 abort. We would like to check that the value is within the range
507 of the subtype, but that causes problems with subtypes whose usage
508 will raise Constraint_Error and with biased representation, so
509 we don't. */
510 if (TREE_CONSTANT_OVERFLOW (gnu_result))
511 gigi_abort (305);
512 }
513 break;
514
515 case N_Character_Literal:
516 /* If a Entity is present, it means that this was one of the
517 literals in a user-defined character type. In that case,
518 just return the value in the CONST_DECL. Otherwise, use the
519 character code. In that case, the base type should be an
520 INTEGER_TYPE, but we won't bother checking for that. */
521 gnu_result_type = get_unpadded_type (Etype (gnat_node));
522 if (Present (Entity (gnat_node)))
523 gnu_result = DECL_INITIAL (get_gnu_tree (Entity (gnat_node)));
524 else
525 gnu_result = convert (gnu_result_type,
526 build_int_2 (Char_Literal_Value (gnat_node), 0));
527 break;
528
529 case N_Real_Literal:
530 /* If this is of a fixed-point type, the value we want is the
531 value of the corresponding integer. */
532 if (IN (Ekind (Underlying_Type (Etype (gnat_node))), Fixed_Point_Kind))
533 {
534 gnu_result_type = get_unpadded_type (Etype (gnat_node));
535 gnu_result = UI_To_gnu (Corresponding_Integer_Value (gnat_node),
536 gnu_result_type);
537 if (TREE_CONSTANT_OVERFLOW (gnu_result))
538 gigi_abort (305);
539 }
540
541 /* We should never see a Vax_Float type literal, since the front end
542 is supposed to transform these using appropriate conversions */
543 else if (Vax_Float (Underlying_Type (Etype (gnat_node))))
544 gigi_abort (334);
545
546 else
547 {
548 Ureal ur_realval = Realval (gnat_node);
549
550 gnu_result_type = get_unpadded_type (Etype (gnat_node));
551
552 /* If the real value is zero, so is the result. Otherwise,
553 convert it to a machine number if it isn't already. That
554 forces BASE to 0 or 2 and simplifies the rest of our logic. */
555 if (UR_Is_Zero (ur_realval))
556 gnu_result = convert (gnu_result_type, integer_zero_node);
557 else
558 {
559 if (! Is_Machine_Number (gnat_node))
560 ur_realval
561 = Machine (Base_Type (Underlying_Type (Etype (gnat_node))),
562 ur_realval, Round_Even, gnat_node);
563
564 gnu_result
565 = UI_To_gnu (Numerator (ur_realval), gnu_result_type);
566
567 /* If we have a base of zero, divide by the denominator.
568 Otherwise, the base must be 2 and we scale the value, which
569 we know can fit in the mantissa of the type (hence the use
570 of that type above). */
571 if (Rbase (ur_realval) == 0)
572 gnu_result
573 = build_binary_op (RDIV_EXPR,
574 get_base_type (gnu_result_type),
575 gnu_result,
576 UI_To_gnu (Denominator (ur_realval),
577 gnu_result_type));
578 else if (Rbase (ur_realval) != 2)
579 gigi_abort (336);
580
581 else
582 {
583 REAL_VALUE_TYPE tmp;
584
585 real_ldexp (&tmp, &TREE_REAL_CST (gnu_result),
586 - UI_To_Int (Denominator (ur_realval)));
587 gnu_result = build_real (gnu_result_type, tmp);
588 }
589 }
590
591 /* Now see if we need to negate the result. Do it this way to
592 properly handle -0. */
593 if (UR_Is_Negative (Realval (gnat_node)))
594 gnu_result
595 = build_unary_op (NEGATE_EXPR, get_base_type (gnu_result_type),
596 gnu_result);
597 }
598
599 break;
600
601 case N_String_Literal:
602 gnu_result_type = get_unpadded_type (Etype (gnat_node));
603 if (TYPE_PRECISION (TREE_TYPE (gnu_result_type)) == HOST_BITS_PER_CHAR)
604 {
605 /* We assume here that all strings are of type standard.string.
606 "Weird" types of string have been converted to an aggregate
607 by the expander. */
608 String_Id gnat_string = Strval (gnat_node);
609 int length = String_Length (gnat_string);
610 char *string = (char *) alloca (length + 1);
611 int i;
612
613 /* Build the string with the characters in the literal. Note
614 that Ada strings are 1-origin. */
615 for (i = 0; i < length; i++)
616 string[i] = Get_String_Char (gnat_string, i + 1);
617
618 /* Put a null at the end of the string in case it's in a context
619 where GCC will want to treat it as a C string. */
620 string[i] = 0;
621
622 gnu_result = build_string (length, string);
623
624 /* Strings in GCC don't normally have types, but we want
625 this to not be converted to the array type. */
626 TREE_TYPE (gnu_result) = gnu_result_type;
627 }
628 else
629 {
630 /* Build a list consisting of each character, then make
631 the aggregate. */
632 String_Id gnat_string = Strval (gnat_node);
633 int length = String_Length (gnat_string);
634 int i;
635 tree gnu_list = NULL_TREE;
636
637 for (i = 0; i < length; i++)
638 gnu_list
639 = tree_cons (NULL_TREE,
640 convert (TREE_TYPE (gnu_result_type),
641 build_int_2 (Get_String_Char (gnat_string,
642 i + 1),
643 0)),
644 gnu_list);
645
646 gnu_result
647 = gnat_build_constructor (gnu_result_type, nreverse (gnu_list));
648 }
649 break;
650
651 case N_Pragma:
652 if (type_annotate_only)
653 break;
654
655 /* Check for (and ignore) unrecognized pragma */
656 if (! Is_Pragma_Name (Chars (gnat_node)))
657 break;
658
659 switch (Get_Pragma_Id (Chars (gnat_node)))
660 {
661 case Pragma_Inspection_Point:
662 /* Do nothing at top level: all such variables are already
663 viewable. */
664 if (global_bindings_p ())
665 break;
666
667 set_lineno (gnat_node, 1);
668 for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
669 Present (gnat_temp);
670 gnat_temp = Next (gnat_temp))
671 {
672 gnu_expr = gnat_to_gnu (Expression (gnat_temp));
673 if (TREE_CODE (gnu_expr) == UNCONSTRAINED_ARRAY_REF)
674 gnu_expr = TREE_OPERAND (gnu_expr, 0);
675
676 gnu_expr = build1 (USE_EXPR, void_type_node, gnu_expr);
677 TREE_SIDE_EFFECTS (gnu_expr) = 1;
678 expand_expr_stmt (gnu_expr);
679 }
680 break;
681
682 case Pragma_Optimize:
683 switch (Chars (Expression
684 (First (Pragma_Argument_Associations (gnat_node)))))
685 {
686 case Name_Time: case Name_Space:
687 if (optimize == 0)
688 post_error ("insufficient -O value?", gnat_node);
689 break;
690
691 case Name_Off:
692 if (optimize != 0)
693 post_error ("must specify -O0?", gnat_node);
694 break;
695
696 default:
697 gigi_abort (331);
698 break;
699 }
700 break;
701
702 case Pragma_Reviewable:
703 if (write_symbols == NO_DEBUG)
704 post_error ("must specify -g?", gnat_node);
705 break;
706 }
707 break;
708
709 /**************************************/
710 /* Chapter 3: Declarations and Types: */
711 /**************************************/
712
713 case N_Subtype_Declaration:
714 case N_Full_Type_Declaration:
715 case N_Incomplete_Type_Declaration:
716 case N_Private_Type_Declaration:
717 case N_Private_Extension_Declaration:
718 case N_Task_Type_Declaration:
719 process_type (Defining_Entity (gnat_node));
720 break;
721
722 case N_Object_Declaration:
723 case N_Exception_Declaration:
724 gnat_temp = Defining_Entity (gnat_node);
725
726 /* If we are just annotating types and this object has an unconstrained
727 or task type, don't elaborate it. */
728 if (type_annotate_only
729 && (((Is_Array_Type (Etype (gnat_temp))
730 || Is_Record_Type (Etype (gnat_temp)))
731 && ! Is_Constrained (Etype (gnat_temp)))
732 || Is_Concurrent_Type (Etype (gnat_temp))))
733 break;
734
735 if (Present (Expression (gnat_node))
736 && ! (Nkind (gnat_node) == N_Object_Declaration
737 && No_Initialization (gnat_node))
738 && (! type_annotate_only
739 || Compile_Time_Known_Value (Expression (gnat_node))))
740 {
741 gnu_expr = gnat_to_gnu (Expression (gnat_node));
742 if (Do_Range_Check (Expression (gnat_node)))
743 gnu_expr = emit_range_check (gnu_expr, Etype (gnat_temp));
744
745 /* If this object has its elaboration delayed, we must force
746 evaluation of GNU_EXPR right now and save it for when the object
747 is frozen. */
748 if (Present (Freeze_Node (gnat_temp)))
749 {
750 if ((Is_Public (gnat_temp) || global_bindings_p ())
751 && ! TREE_CONSTANT (gnu_expr))
752 gnu_expr
753 = create_var_decl (create_concat_name (gnat_temp, "init"),
754 NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr,
755 0, Is_Public (gnat_temp), 0, 0, 0);
756 else
757 gnu_expr = maybe_variable (gnu_expr, Expression (gnat_node));
758
759 save_gnu_tree (gnat_node, gnu_expr, 1);
760 }
761 }
762 else
763 gnu_expr = 0;
764
765 if (type_annotate_only && gnu_expr != 0
766 && TREE_CODE (gnu_expr) == ERROR_MARK)
767 gnu_expr = 0;
768
769 if (No (Freeze_Node (gnat_temp)))
770 gnat_to_gnu_entity (gnat_temp, gnu_expr, 1);
771 break;
772
773 case N_Object_Renaming_Declaration:
774
775 gnat_temp = Defining_Entity (gnat_node);
776
777 /* Don't do anything if this renaming is handled by the front end.
778 or if we are just annotating types and this object has a
779 composite or task type, don't elaborate it. */
780 if (! Is_Renaming_Of_Object (gnat_temp)
781 && ! (type_annotate_only
782 && (Is_Array_Type (Etype (gnat_temp))
783 || Is_Record_Type (Etype (gnat_temp))
784 || Is_Concurrent_Type (Etype (gnat_temp)))))
785 {
786 gnu_expr = gnat_to_gnu (Renamed_Object (gnat_temp));
787 gnat_to_gnu_entity (gnat_temp, gnu_expr, 1);
788 }
789 break;
790
791 case N_Implicit_Label_Declaration:
792 gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
793 break;
794
795 case N_Exception_Renaming_Declaration:
796 case N_Number_Declaration:
797 case N_Package_Renaming_Declaration:
798 case N_Subprogram_Renaming_Declaration:
799 /* These are fully handled in the front end. */
800 break;
801
802 /*************************************/
803 /* Chapter 4: Names and Expressions: */
804 /*************************************/
805
806 case N_Explicit_Dereference:
807 gnu_result = gnat_to_gnu (Prefix (gnat_node));
808 gnu_result_type = get_unpadded_type (Etype (gnat_node));
809 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
810 break;
811
812 case N_Indexed_Component:
813 {
814 tree gnu_array_object = gnat_to_gnu (Prefix (gnat_node));
815 tree gnu_type;
816 int ndim;
817 int i;
818 Node_Id *gnat_expr_array;
819
820 gnu_array_object = maybe_implicit_deref (gnu_array_object);
821 gnu_array_object = maybe_unconstrained_array (gnu_array_object);
822
823 /* If we got a padded type, remove it too. */
824 if (TREE_CODE (TREE_TYPE (gnu_array_object)) == RECORD_TYPE
825 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object)))
826 gnu_array_object
827 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object))),
828 gnu_array_object);
829
830 gnu_result = gnu_array_object;
831
832 /* First compute the number of dimensions of the array, then
833 fill the expression array, the order depending on whether
834 this is a Convention_Fortran array or not. */
835 for (ndim = 1, gnu_type = TREE_TYPE (gnu_array_object);
836 TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
837 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type));
838 ndim++, gnu_type = TREE_TYPE (gnu_type))
839 ;
840
841 gnat_expr_array = (Node_Id *) alloca (ndim * sizeof (Node_Id));
842
843 if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object)))
844 for (i = ndim - 1, gnat_temp = First (Expressions (gnat_node));
845 i >= 0;
846 i--, gnat_temp = Next (gnat_temp))
847 gnat_expr_array[i] = gnat_temp;
848 else
849 for (i = 0, gnat_temp = First (Expressions (gnat_node));
850 i < ndim;
851 i++, gnat_temp = Next (gnat_temp))
852 gnat_expr_array[i] = gnat_temp;
853
854 for (i = 0, gnu_type = TREE_TYPE (gnu_array_object);
855 i < ndim; i++, gnu_type = TREE_TYPE (gnu_type))
856 {
857 if (TREE_CODE (gnu_type) != ARRAY_TYPE)
858 gigi_abort (307);
859
860 gnat_temp = gnat_expr_array[i];
861 gnu_expr = gnat_to_gnu (gnat_temp);
862
863 if (Do_Range_Check (gnat_temp))
864 gnu_expr
865 = emit_index_check
866 (gnu_array_object, gnu_expr,
867 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
868 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))));
869
870 gnu_result = build_binary_op (ARRAY_REF, NULL_TREE,
871 gnu_result, gnu_expr);
872 }
873 }
874
875 gnu_result_type = get_unpadded_type (Etype (gnat_node));
876 break;
877
878 case N_Slice:
879 {
880 tree gnu_type;
881 Node_Id gnat_range_node = Discrete_Range (gnat_node);
882
883 gnu_result = gnat_to_gnu (Prefix (gnat_node));
884 gnu_result_type = get_unpadded_type (Etype (gnat_node));
885
886 /* Do any implicit dereferences of the prefix and do any needed
887 range check. */
888 gnu_result = maybe_implicit_deref (gnu_result);
889 gnu_result = maybe_unconstrained_array (gnu_result);
890 gnu_type = TREE_TYPE (gnu_result);
891 if (Do_Range_Check (gnat_range_node))
892 {
893 /* Get the bounds of the slice. */
894 tree gnu_index_type
895 = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_result_type));
896 tree gnu_min_expr = TYPE_MIN_VALUE (gnu_index_type);
897 tree gnu_max_expr = TYPE_MAX_VALUE (gnu_index_type);
898 tree gnu_expr_l, gnu_expr_h, gnu_expr_type;
899
900 /* Check to see that the minimum slice value is in range */
901 gnu_expr_l
902 = emit_index_check
903 (gnu_result, gnu_min_expr,
904 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
905 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))));
906
907 /* Check to see that the maximum slice value is in range */
908 gnu_expr_h
909 = emit_index_check
910 (gnu_result, gnu_max_expr,
911 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
912 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))));
913
914 /* Derive a good type to convert everything too */
915 gnu_expr_type = get_base_type (TREE_TYPE (gnu_expr_l));
916
917 /* Build a compound expression that does the range checks */
918 gnu_expr
919 = build_binary_op (COMPOUND_EXPR, gnu_expr_type,
920 convert (gnu_expr_type, gnu_expr_h),
921 convert (gnu_expr_type, gnu_expr_l));
922
923 /* Build a conditional expression that returns the range checks
924 expression if the slice range is not null (max >= min) or
925 returns the min if the slice range is null */
926 gnu_expr
927 = fold (build (COND_EXPR, gnu_expr_type,
928 build_binary_op (GE_EXPR, gnu_expr_type,
929 convert (gnu_expr_type,
930 gnu_max_expr),
931 convert (gnu_expr_type,
932 gnu_min_expr)),
933 gnu_expr, gnu_min_expr));
934 }
935 else
936 gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
937
938 gnu_result = build_binary_op (ARRAY_RANGE_REF, gnu_result_type,
939 gnu_result, gnu_expr);
940 }
941 break;
942
943 case N_Selected_Component:
944 {
945 tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
946 Entity_Id gnat_field = Entity (Selector_Name (gnat_node));
947 Entity_Id gnat_pref_type = Etype (Prefix (gnat_node));
948 tree gnu_field;
949
950 while (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind)
951 || IN (Ekind (gnat_pref_type), Access_Kind))
952 {
953 if (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind))
954 gnat_pref_type = Underlying_Type (gnat_pref_type);
955 else if (IN (Ekind (gnat_pref_type), Access_Kind))
956 gnat_pref_type = Designated_Type (gnat_pref_type);
957 }
958
959 gnu_prefix = maybe_implicit_deref (gnu_prefix);
960
961 /* For discriminant references in tagged types always substitute the
962 corresponding discriminant as the actual selected component. */
963
964 if (Is_Tagged_Type (gnat_pref_type))
965 while (Present (Corresponding_Discriminant (gnat_field)))
966 gnat_field = Corresponding_Discriminant (gnat_field);
967
968 /* For discriminant references of untagged types always substitute the
969 corresponding stored discriminant. */
970
971 else if (Present (Corresponding_Discriminant (gnat_field)))
972 gnat_field = Original_Record_Component (gnat_field);
973
974 /* Handle extracting the real or imaginary part of a complex.
975 The real part is the first field and the imaginary the last. */
976
977 if (TREE_CODE (TREE_TYPE (gnu_prefix)) == COMPLEX_TYPE)
978 gnu_result = build_unary_op (Present (Next_Entity (gnat_field))
979 ? REALPART_EXPR : IMAGPART_EXPR,
980 NULL_TREE, gnu_prefix);
981 else
982 {
983 gnu_field = gnat_to_gnu_entity (gnat_field, NULL_TREE, 0);
984
985 /* If there are discriminants, the prefix might be
986 evaluated more than once, which is a problem if it has
987 side-effects. */
988 if (Has_Discriminants (Is_Access_Type (Etype (Prefix (gnat_node)))
989 ? Designated_Type (Etype
990 (Prefix (gnat_node)))
991 : Etype (Prefix (gnat_node))))
992 gnu_prefix = gnat_stabilize_reference (gnu_prefix, 0);
993
994 gnu_result
995 = build_component_ref (gnu_prefix, NULL_TREE, gnu_field,
996 (Nkind (Parent (gnat_node))
997 == N_Attribute_Reference));
998 }
999
1000 if (gnu_result == 0)
1001 gigi_abort (308);
1002
1003 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1004 }
1005 break;
1006
1007 case N_Attribute_Reference:
1008 {
1009 /* The attribute designator (like an enumeration value). */
1010 int attribute = Get_Attribute_Id (Attribute_Name (gnat_node));
1011 int prefix_unused = 0;
1012 tree gnu_prefix;
1013 tree gnu_type;
1014
1015 /* The Elab_Spec and Elab_Body attributes are special in that
1016 Prefix is a unit, not an object with a GCC equivalent. Similarly
1017 for Elaborated, since that variable isn't otherwise known. */
1018 if (attribute == Attr_Elab_Body || attribute == Attr_Elab_Spec)
1019 {
1020 gnu_prefix
1021 = create_subprog_decl
1022 (create_concat_name (Entity (Prefix (gnat_node)),
1023 attribute == Attr_Elab_Body
1024 ? "elabb" : "elabs"),
1025 NULL_TREE, void_ftype, NULL_TREE, 0, 1, 1, 0);
1026 return gnu_prefix;
1027 }
1028
1029 gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
1030 gnu_type = TREE_TYPE (gnu_prefix);
1031
1032 /* If the input is a NULL_EXPR, make a new one. */
1033 if (TREE_CODE (gnu_prefix) == NULL_EXPR)
1034 {
1035 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1036 gnu_result = build1 (NULL_EXPR, gnu_result_type,
1037 TREE_OPERAND (gnu_prefix, 0));
1038 break;
1039 }
1040
1041 switch (attribute)
1042 {
1043 case Attr_Pos:
1044 case Attr_Val:
1045 /* These are just conversions until since representation
1046 clauses for enumerations are handled in the front end. */
1047 {
1048 int check_p = Do_Range_Check (First (Expressions (gnat_node)));
1049
1050 gnu_result = gnat_to_gnu (First (Expressions (gnat_node)));
1051 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1052 gnu_result = convert_with_check (Etype (gnat_node), gnu_result,
1053 check_p, check_p, 1);
1054 }
1055 break;
1056
1057 case Attr_Pred:
1058 case Attr_Succ:
1059 /* These just add or subject the constant 1. Representation
1060 clauses for enumerations are handled in the front-end. */
1061 gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
1062 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1063
1064 if (Do_Range_Check (First (Expressions (gnat_node))))
1065 {
1066 gnu_expr = protect_multiple_eval (gnu_expr);
1067 gnu_expr
1068 = emit_check
1069 (build_binary_op (EQ_EXPR, integer_type_node,
1070 gnu_expr,
1071 attribute == Attr_Pred
1072 ? TYPE_MIN_VALUE (gnu_result_type)
1073 : TYPE_MAX_VALUE (gnu_result_type)),
1074 gnu_expr, CE_Range_Check_Failed);
1075 }
1076
1077 gnu_result
1078 = build_binary_op (attribute == Attr_Pred
1079 ? MINUS_EXPR : PLUS_EXPR,
1080 gnu_result_type, gnu_expr,
1081 convert (gnu_result_type, integer_one_node));
1082 break;
1083
1084 case Attr_Address:
1085 case Attr_Unrestricted_Access:
1086
1087 /* Conversions don't change something's address but can cause
1088 us to miss the COMPONENT_REF case below, so strip them off. */
1089 gnu_prefix
1090 = remove_conversions (gnu_prefix,
1091 ! Must_Be_Byte_Aligned (gnat_node));
1092
1093 /* If we are taking 'Address of an unconstrained object,
1094 this is the pointer to the underlying array. */
1095 gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1096
1097 /* ... fall through ... */
1098
1099 case Attr_Access:
1100 case Attr_Unchecked_Access:
1101 case Attr_Code_Address:
1102
1103 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1104 gnu_result
1105 = build_unary_op (((attribute == Attr_Address
1106 || attribute == Attr_Unrestricted_Access)
1107 && ! Must_Be_Byte_Aligned (gnat_node))
1108 ? ATTR_ADDR_EXPR : ADDR_EXPR,
1109 gnu_result_type, gnu_prefix);
1110
1111 /* For 'Code_Address, find an inner ADDR_EXPR and mark it
1112 so that we don't try to build a trampoline. */
1113 if (attribute == Attr_Code_Address)
1114 {
1115 for (gnu_expr = gnu_result;
1116 TREE_CODE (gnu_expr) == NOP_EXPR
1117 || TREE_CODE (gnu_expr) == CONVERT_EXPR;
1118 gnu_expr = TREE_OPERAND (gnu_expr, 0))
1119 TREE_CONSTANT (gnu_expr) = 1;
1120 ;
1121
1122 if (TREE_CODE (gnu_expr) == ADDR_EXPR)
1123 TREE_STATIC (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1;
1124 }
1125
1126 break;
1127
1128 case Attr_Pool_Address:
1129 {
1130 tree gnu_obj_type;
1131 tree gnu_ptr = gnu_prefix;
1132
1133 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1134
1135 /* If this is an unconstrained array, we know the object must
1136 have been allocated with the template in front of the object.
1137 So compute the template address.*/
1138
1139 if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
1140 gnu_ptr
1141 = convert (build_pointer_type
1142 (TYPE_OBJECT_RECORD_TYPE
1143 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
1144 gnu_ptr);
1145
1146 gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
1147 if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
1148 && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
1149 {
1150 tree gnu_char_ptr_type = build_pointer_type (char_type_node);
1151 tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
1152 tree gnu_byte_offset
1153 = convert (gnu_char_ptr_type,
1154 size_diffop (size_zero_node, gnu_pos));
1155
1156 gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
1157 gnu_ptr = build_binary_op (MINUS_EXPR, gnu_char_ptr_type,
1158 gnu_ptr, gnu_byte_offset);
1159 }
1160
1161 gnu_result = convert (gnu_result_type, gnu_ptr);
1162 }
1163 break;
1164
1165 case Attr_Size:
1166 case Attr_Object_Size:
1167 case Attr_Value_Size:
1168 case Attr_Max_Size_In_Storage_Elements:
1169
1170 gnu_expr = gnu_prefix;
1171
1172 /* Remove NOPS from gnu_expr and conversions from gnu_prefix.
1173 We only use GNU_EXPR to see if a COMPONENT_REF was involved. */
1174 while (TREE_CODE (gnu_expr) == NOP_EXPR)
1175 gnu_expr = TREE_OPERAND (gnu_expr, 0);
1176
1177 gnu_prefix = remove_conversions (gnu_prefix, 1);
1178 prefix_unused = 1;
1179 gnu_type = TREE_TYPE (gnu_prefix);
1180
1181 /* Replace an unconstrained array type with the type of the
1182 underlying array. We can't do this with a call to
1183 maybe_unconstrained_array since we may have a TYPE_DECL.
1184 For 'Max_Size_In_Storage_Elements, use the record type
1185 that will be used to allocate the object and its template. */
1186
1187 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1188 {
1189 gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
1190 if (attribute != Attr_Max_Size_In_Storage_Elements)
1191 gnu_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)));
1192 }
1193
1194 /* If we are looking for the size of a field, return the
1195 field size. Otherwise, if the prefix is an object,
1196 or if 'Object_Size or 'Max_Size_In_Storage_Elements has
1197 been specified, the result is the GCC size of the type.
1198 Otherwise, the result is the RM_Size of the type. */
1199 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1200 gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1));
1201 else if (TREE_CODE (gnu_prefix) != TYPE_DECL
1202 || attribute == Attr_Object_Size
1203 || attribute == Attr_Max_Size_In_Storage_Elements)
1204 {
1205 /* If this is a padded type, the GCC size isn't relevant
1206 to the programmer. Normally, what we want is the RM_Size,
1207 which was set from the specified size, but if it was not
1208 set, we want the size of the relevant field. Using the MAX
1209 of those two produces the right result in all case. Don't
1210 use the size of the field if it's a self-referential type,
1211 since that's never what's wanted. */
1212 if (TREE_CODE (gnu_type) == RECORD_TYPE
1213 && TYPE_IS_PADDING_P (gnu_type)
1214 && TREE_CODE (gnu_expr) == COMPONENT_REF)
1215 {
1216 gnu_result = rm_size (gnu_type);
1217 if (! (CONTAINS_PLACEHOLDER_P
1218 (DECL_SIZE (TREE_OPERAND (gnu_expr, 1)))))
1219 gnu_result
1220 = size_binop (MAX_EXPR, gnu_result,
1221 DECL_SIZE (TREE_OPERAND (gnu_expr, 1)));
1222 }
1223 else
1224 gnu_result = TYPE_SIZE (gnu_type);
1225 }
1226 else
1227 gnu_result = rm_size (gnu_type);
1228
1229 if (gnu_result == 0)
1230 gigi_abort (325);
1231
1232 /* Deal with a self-referential size by returning the maximum
1233 size for a type and by qualifying the size with
1234 the object for 'Size of an object. */
1235
1236 if (CONTAINS_PLACEHOLDER_P (gnu_result))
1237 {
1238 if (TREE_CODE (gnu_prefix) != TYPE_DECL)
1239 gnu_result = build (WITH_RECORD_EXPR, TREE_TYPE (gnu_result),
1240 gnu_result, gnu_expr);
1241 else
1242 gnu_result = max_size (gnu_result, 1);
1243 }
1244
1245 /* If the type contains a template, subtract the size of the
1246 template. */
1247 if (TREE_CODE (gnu_type) == RECORD_TYPE
1248 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
1249 gnu_result = size_binop (MINUS_EXPR, gnu_result,
1250 DECL_SIZE (TYPE_FIELDS (gnu_type)));
1251
1252 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1253
1254 /* Always perform division using unsigned arithmetic as the
1255 size cannot be negative, but may be an overflowed positive
1256 value. This provides correct results for sizes up to 512 MB.
1257 ??? Size should be calculated in storage elements directly. */
1258
1259 if (attribute == Attr_Max_Size_In_Storage_Elements)
1260 gnu_result = convert (sizetype,
1261 fold (build (CEIL_DIV_EXPR, bitsizetype,
1262 gnu_result,
1263 bitsize_unit_node)));
1264 break;
1265
1266 case Attr_Alignment:
1267 if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1268 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))
1269 == RECORD_TYPE)
1270 && (TYPE_IS_PADDING_P
1271 (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))))
1272 gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1273
1274 gnu_type = TREE_TYPE (gnu_prefix);
1275 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1276 prefix_unused = 1;
1277
1278 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1279 gnu_result
1280 = size_int (DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1)));
1281 else
1282 gnu_result = size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT);
1283 break;
1284
1285 case Attr_First:
1286 case Attr_Last:
1287 case Attr_Range_Length:
1288 prefix_unused = 1;
1289
1290 if (INTEGRAL_TYPE_P (gnu_type)
1291 || TREE_CODE (gnu_type) == REAL_TYPE)
1292 {
1293 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1294
1295 if (attribute == Attr_First)
1296 gnu_result = TYPE_MIN_VALUE (gnu_type);
1297 else if (attribute == Attr_Last)
1298 gnu_result = TYPE_MAX_VALUE (gnu_type);
1299 else
1300 gnu_result
1301 = build_binary_op
1302 (MAX_EXPR, get_base_type (gnu_result_type),
1303 build_binary_op
1304 (PLUS_EXPR, get_base_type (gnu_result_type),
1305 build_binary_op (MINUS_EXPR,
1306 get_base_type (gnu_result_type),
1307 convert (gnu_result_type,
1308 TYPE_MAX_VALUE (gnu_type)),
1309 convert (gnu_result_type,
1310 TYPE_MIN_VALUE (gnu_type))),
1311 convert (gnu_result_type, integer_one_node)),
1312 convert (gnu_result_type, integer_zero_node));
1313
1314 break;
1315 }
1316 /* ... fall through ... */
1317 case Attr_Length:
1318 {
1319 int Dimension
1320 = (Present (Expressions (gnat_node))
1321 ? UI_To_Int (Intval (First (Expressions (gnat_node))))
1322 : 1);
1323
1324 /* Make sure any implicit dereference gets done. */
1325 gnu_prefix = maybe_implicit_deref (gnu_prefix);
1326 gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1327 gnu_type = TREE_TYPE (gnu_prefix);
1328 prefix_unused = 1;
1329 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1330
1331 if (TYPE_CONVENTION_FORTRAN_P (gnu_type))
1332 {
1333 int ndim;
1334 tree gnu_type_temp;
1335
1336 for (ndim = 1, gnu_type_temp = gnu_type;
1337 TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE
1338 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp));
1339 ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp))
1340 ;
1341
1342 Dimension = ndim + 1 - Dimension;
1343 }
1344
1345 for (; Dimension > 1; Dimension--)
1346 gnu_type = TREE_TYPE (gnu_type);
1347
1348 if (TREE_CODE (gnu_type) != ARRAY_TYPE)
1349 gigi_abort (309);
1350
1351 if (attribute == Attr_First)
1352 gnu_result
1353 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
1354 else if (attribute == Attr_Last)
1355 gnu_result
1356 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
1357 else
1358 /* 'Length or 'Range_Length. */
1359 {
1360 tree gnu_compute_type
1361 = gnat_signed_or_unsigned_type
1362 (0, get_base_type (gnu_result_type));
1363
1364 gnu_result
1365 = build_binary_op
1366 (MAX_EXPR, gnu_compute_type,
1367 build_binary_op
1368 (PLUS_EXPR, gnu_compute_type,
1369 build_binary_op
1370 (MINUS_EXPR, gnu_compute_type,
1371 convert (gnu_compute_type,
1372 TYPE_MAX_VALUE
1373 (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)))),
1374 convert (gnu_compute_type,
1375 TYPE_MIN_VALUE
1376 (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))))),
1377 convert (gnu_compute_type, integer_one_node)),
1378 convert (gnu_compute_type, integer_zero_node));
1379 }
1380
1381 /* If this has a PLACEHOLDER_EXPR, qualify it by the object
1382 we are handling. Note that these attributes could not
1383 have been used on an unconstrained array type. */
1384 if (CONTAINS_PLACEHOLDER_P (gnu_result))
1385 gnu_result = build (WITH_RECORD_EXPR, TREE_TYPE (gnu_result),
1386 gnu_result, gnu_prefix);
1387
1388 break;
1389 }
1390
1391 case Attr_Bit_Position:
1392 case Attr_Position:
1393 case Attr_First_Bit:
1394 case Attr_Last_Bit:
1395 case Attr_Bit:
1396 {
1397 HOST_WIDE_INT bitsize;
1398 HOST_WIDE_INT bitpos;
1399 tree gnu_offset;
1400 tree gnu_field_bitpos;
1401 tree gnu_field_offset;
1402 tree gnu_inner;
1403 enum machine_mode mode;
1404 int unsignedp, volatilep;
1405
1406 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1407 gnu_prefix = remove_conversions (gnu_prefix, 1);
1408 prefix_unused = 1;
1409
1410 /* We can have 'Bit on any object, but if it isn't a
1411 COMPONENT_REF, the result is zero. Do not allow
1412 'Bit on a bare component, though. */
1413 if (attribute == Attr_Bit
1414 && TREE_CODE (gnu_prefix) != COMPONENT_REF
1415 && TREE_CODE (gnu_prefix) != FIELD_DECL)
1416 {
1417 gnu_result = integer_zero_node;
1418 break;
1419 }
1420
1421 else if (TREE_CODE (gnu_prefix) != COMPONENT_REF
1422 && ! (attribute == Attr_Bit_Position
1423 && TREE_CODE (gnu_prefix) == FIELD_DECL))
1424 gigi_abort (310);
1425
1426 get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset,
1427 &mode, &unsignedp, &volatilep);
1428
1429 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1430 {
1431 gnu_field_bitpos
1432 = bit_position (TREE_OPERAND (gnu_prefix, 1));
1433 gnu_field_offset
1434 = byte_position (TREE_OPERAND (gnu_prefix, 1));
1435
1436 for (gnu_inner = TREE_OPERAND (gnu_prefix, 0);
1437 TREE_CODE (gnu_inner) == COMPONENT_REF
1438 && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1));
1439 gnu_inner = TREE_OPERAND (gnu_inner, 0))
1440 {
1441 gnu_field_bitpos
1442 = size_binop (PLUS_EXPR, gnu_field_bitpos,
1443 bit_position (TREE_OPERAND (gnu_inner,
1444 1)));
1445 gnu_field_offset
1446 = size_binop (PLUS_EXPR, gnu_field_offset,
1447 byte_position (TREE_OPERAND (gnu_inner,
1448 1)));
1449 }
1450 }
1451 else if (TREE_CODE (gnu_prefix) == FIELD_DECL)
1452 {
1453 gnu_field_bitpos = bit_position (gnu_prefix);
1454 gnu_field_offset = byte_position (gnu_prefix);
1455 }
1456 else
1457 {
1458 gnu_field_bitpos = bitsize_zero_node;
1459 gnu_field_offset = size_zero_node;
1460 }
1461
1462 switch (attribute)
1463 {
1464 case Attr_Position:
1465 gnu_result = gnu_field_offset;
1466 break;
1467
1468 case Attr_First_Bit:
1469 case Attr_Bit:
1470 gnu_result = size_int (bitpos % BITS_PER_UNIT);
1471 break;
1472
1473 case Attr_Last_Bit:
1474 gnu_result = bitsize_int (bitpos % BITS_PER_UNIT);
1475 gnu_result
1476 = size_binop (PLUS_EXPR, gnu_result,
1477 TYPE_SIZE (TREE_TYPE (gnu_prefix)));
1478 gnu_result = size_binop (MINUS_EXPR, gnu_result,
1479 bitsize_one_node);
1480 break;
1481
1482 case Attr_Bit_Position:
1483 gnu_result = gnu_field_bitpos;
1484 break;
1485 }
1486
1487 /* If this has a PLACEHOLDER_EXPR, qualify it by the object
1488 we are handling. */
1489 if (CONTAINS_PLACEHOLDER_P (gnu_result))
1490 gnu_result = build (WITH_RECORD_EXPR, TREE_TYPE (gnu_result),
1491 gnu_result, gnu_prefix);
1492
1493 break;
1494 }
1495
1496 case Attr_Min:
1497 case Attr_Max:
1498 gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node)));
1499 gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node))));
1500
1501 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1502 gnu_result = build_binary_op (attribute == Attr_Min
1503 ? MIN_EXPR : MAX_EXPR,
1504 gnu_result_type, gnu_lhs, gnu_rhs);
1505 break;
1506
1507 case Attr_Passed_By_Reference:
1508 gnu_result = size_int (default_pass_by_ref (gnu_type)
1509 || must_pass_by_ref (gnu_type));
1510 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1511 break;
1512
1513 case Attr_Component_Size:
1514 if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1515 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))
1516 == RECORD_TYPE)
1517 && (TYPE_IS_PADDING_P
1518 (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))))
1519 gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1520
1521 gnu_prefix = maybe_implicit_deref (gnu_prefix);
1522 gnu_type = TREE_TYPE (gnu_prefix);
1523
1524 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1525 gnu_type
1526 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type))));
1527
1528 while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
1529 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
1530 gnu_type = TREE_TYPE (gnu_type);
1531
1532 if (TREE_CODE (gnu_type) != ARRAY_TYPE)
1533 gigi_abort (330);
1534
1535 /* Note this size cannot be self-referential. */
1536 gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type));
1537 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1538 prefix_unused = 1;
1539 break;
1540
1541 case Attr_Null_Parameter:
1542 /* This is just a zero cast to the pointer type for
1543 our prefix and dereferenced. */
1544 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1545 gnu_result
1546 = build_unary_op (INDIRECT_REF, NULL_TREE,
1547 convert (build_pointer_type (gnu_result_type),
1548 integer_zero_node));
1549 TREE_PRIVATE (gnu_result) = 1;
1550 break;
1551
1552 case Attr_Mechanism_Code:
1553 {
1554 int code;
1555 Entity_Id gnat_obj = Entity (Prefix (gnat_node));
1556
1557 prefix_unused = 1;
1558 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1559 if (Present (Expressions (gnat_node)))
1560 {
1561 int i = UI_To_Int (Intval (First (Expressions (gnat_node))));
1562
1563 for (gnat_obj = First_Formal (gnat_obj); i > 1;
1564 i--, gnat_obj = Next_Formal (gnat_obj))
1565 ;
1566 }
1567
1568 code = Mechanism (gnat_obj);
1569 if (code == Default)
1570 code = ((present_gnu_tree (gnat_obj)
1571 && (DECL_BY_REF_P (get_gnu_tree (gnat_obj))
1572 || ((TREE_CODE (get_gnu_tree (gnat_obj))
1573 == PARM_DECL)
1574 && (DECL_BY_COMPONENT_PTR_P
1575 (get_gnu_tree (gnat_obj))))))
1576 ? By_Reference : By_Copy);
1577 gnu_result = convert (gnu_result_type, size_int (- code));
1578 }
1579 break;
1580
1581 default:
1582 /* Say we have an unimplemented attribute. Then set the
1583 value to be returned to be a zero and hope that's something
1584 we can convert to the type of this attribute. */
1585
1586 post_error ("unimplemented attribute", gnat_node);
1587 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1588 gnu_result = integer_zero_node;
1589 break;
1590 }
1591
1592 /* If this is an attribute where the prefix was unused,
1593 force a use of it if it has a side-effect. But don't do it if
1594 the prefix is just an entity name. However, if an access check
1595 is needed, we must do it. See second example in AARM 11.6(5.e). */
1596 if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix)
1597 && ! Is_Entity_Name (Prefix (gnat_node)))
1598 gnu_result = fold (build (COMPOUND_EXPR, TREE_TYPE (gnu_result),
1599 gnu_prefix, gnu_result));
1600 }
1601 break;
1602
1603 case N_Reference:
1604 /* Like 'Access as far as we are concerned. */
1605 gnu_result = gnat_to_gnu (Prefix (gnat_node));
1606 gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result);
1607 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1608 break;
1609
1610 case N_Aggregate:
1611 case N_Extension_Aggregate:
1612 {
1613 tree gnu_aggr_type;
1614
1615 /* ??? It is wrong to evaluate the type now, but there doesn't
1616 seem to be any other practical way of doing it. */
1617
1618 gnu_aggr_type = gnu_result_type
1619 = get_unpadded_type (Etype (gnat_node));
1620
1621 if (TREE_CODE (gnu_result_type) == RECORD_TYPE
1622 && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type))
1623 gnu_aggr_type
1624 = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_result_type)));
1625
1626 if (Null_Record_Present (gnat_node))
1627 gnu_result = gnat_build_constructor (gnu_aggr_type, NULL_TREE);
1628
1629 else if (TREE_CODE (gnu_aggr_type) == RECORD_TYPE)
1630 gnu_result
1631 = assoc_to_constructor (First (Component_Associations (gnat_node)),
1632 gnu_aggr_type);
1633 else if (TREE_CODE (gnu_aggr_type) == UNION_TYPE)
1634 {
1635 /* The first element is the discrimant, which we ignore. The
1636 next is the field we're building. Convert the expression
1637 to the type of the field and then to the union type. */
1638 Node_Id gnat_assoc
1639 = Next (First (Component_Associations (gnat_node)));
1640 Entity_Id gnat_field = Entity (First (Choices (gnat_assoc)));
1641 tree gnu_field_type
1642 = TREE_TYPE (gnat_to_gnu_entity (gnat_field, NULL_TREE, 0));
1643
1644 gnu_result = convert (gnu_field_type,
1645 gnat_to_gnu (Expression (gnat_assoc)));
1646 }
1647 else if (TREE_CODE (gnu_aggr_type) == ARRAY_TYPE)
1648 gnu_result = pos_to_constructor (First (Expressions (gnat_node)),
1649 gnu_aggr_type,
1650 Component_Type (Etype (gnat_node)));
1651 else if (TREE_CODE (gnu_aggr_type) == COMPLEX_TYPE)
1652 gnu_result
1653 = build_binary_op
1654 (COMPLEX_EXPR, gnu_aggr_type,
1655 gnat_to_gnu (Expression (First
1656 (Component_Associations (gnat_node)))),
1657 gnat_to_gnu (Expression
1658 (Next
1659 (First (Component_Associations (gnat_node))))));
1660 else
1661 gigi_abort (312);
1662
1663 gnu_result = convert (gnu_result_type, gnu_result);
1664 }
1665 break;
1666
1667 case N_Null:
1668 gnu_result = null_pointer_node;
1669 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1670 break;
1671
1672 case N_Type_Conversion:
1673 case N_Qualified_Expression:
1674 /* Get the operand expression. */
1675 gnu_result = gnat_to_gnu (Expression (gnat_node));
1676 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1677
1678 gnu_result
1679 = convert_with_check (Etype (gnat_node), gnu_result,
1680 Do_Overflow_Check (gnat_node),
1681 Do_Range_Check (Expression (gnat_node)),
1682 Nkind (gnat_node) == N_Type_Conversion
1683 && Float_Truncate (gnat_node));
1684 break;
1685
1686 case N_Unchecked_Type_Conversion:
1687 gnu_result = gnat_to_gnu (Expression (gnat_node));
1688 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1689
1690 /* If the result is a pointer type, see if we are improperly
1691 converting to a stricter alignment. */
1692
1693 if (STRICT_ALIGNMENT && POINTER_TYPE_P (gnu_result_type)
1694 && IN (Ekind (Etype (gnat_node)), Access_Kind))
1695 {
1696 unsigned int align = known_alignment (gnu_result);
1697 tree gnu_obj_type = TREE_TYPE (gnu_result_type);
1698 unsigned int oalign
1699 = TREE_CODE (gnu_obj_type) == FUNCTION_TYPE
1700 ? FUNCTION_BOUNDARY : TYPE_ALIGN (gnu_obj_type);
1701
1702 if (align != 0 && align < oalign && ! TYPE_ALIGN_OK (gnu_obj_type))
1703 post_error_ne_tree_2
1704 ("?source alignment (^) < alignment of & (^)",
1705 gnat_node, Designated_Type (Etype (gnat_node)),
1706 size_int (align / BITS_PER_UNIT), oalign / BITS_PER_UNIT);
1707 }
1708
1709 gnu_result = unchecked_convert (gnu_result_type, gnu_result,
1710 No_Truncation (gnat_node));
1711 break;
1712
1713 case N_In:
1714 case N_Not_In:
1715 {
1716 tree gnu_object = gnat_to_gnu (Left_Opnd (gnat_node));
1717 Node_Id gnat_range = Right_Opnd (gnat_node);
1718 tree gnu_low;
1719 tree gnu_high;
1720
1721 /* GNAT_RANGE is either an N_Range node or an identifier
1722 denoting a subtype. */
1723 if (Nkind (gnat_range) == N_Range)
1724 {
1725 gnu_low = gnat_to_gnu (Low_Bound (gnat_range));
1726 gnu_high = gnat_to_gnu (High_Bound (gnat_range));
1727 }
1728 else if (Nkind (gnat_range) == N_Identifier
1729 || Nkind (gnat_range) == N_Expanded_Name)
1730 {
1731 tree gnu_range_type = get_unpadded_type (Entity (gnat_range));
1732
1733 gnu_low = TYPE_MIN_VALUE (gnu_range_type);
1734 gnu_high = TYPE_MAX_VALUE (gnu_range_type);
1735 }
1736 else
1737 gigi_abort (313);
1738
1739 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1740
1741 /* If LOW and HIGH are identical, perform an equality test.
1742 Otherwise, ensure that GNU_OBJECT is only evaluated once
1743 and perform a full range test. */
1744 if (operand_equal_p (gnu_low, gnu_high, 0))
1745 gnu_result = build_binary_op (EQ_EXPR, gnu_result_type,
1746 gnu_object, gnu_low);
1747 else
1748 {
1749 gnu_object = protect_multiple_eval (gnu_object);
1750 gnu_result
1751 = build_binary_op (TRUTH_ANDIF_EXPR, gnu_result_type,
1752 build_binary_op (GE_EXPR, gnu_result_type,
1753 gnu_object, gnu_low),
1754 build_binary_op (LE_EXPR, gnu_result_type,
1755 gnu_object, gnu_high));
1756 }
1757
1758 if (Nkind (gnat_node) == N_Not_In)
1759 gnu_result = invert_truthvalue (gnu_result);
1760 }
1761 break;
1762
1763 case N_Op_Divide:
1764 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
1765 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
1766 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1767 gnu_result = build_binary_op (FLOAT_TYPE_P (gnu_result_type)
1768 ? RDIV_EXPR
1769 : (Rounded_Result (gnat_node)
1770 ? ROUND_DIV_EXPR : TRUNC_DIV_EXPR),
1771 gnu_result_type, gnu_lhs, gnu_rhs);
1772 break;
1773
1774 case N_And_Then: case N_Or_Else:
1775 {
1776 /* Some processing below (e.g. clear_last_expr) requires access to
1777 status fields now maintained in the current function context, so
1778 we'll setup a dummy one if needed. We cannot use global_binding_p,
1779 since it might be true due to force_global and making a dummy
1780 context would kill the current function context. */
1781 bool make_dummy_context = (cfun == 0);
1782 enum tree_code code = gnu_codes[Nkind (gnat_node)];
1783 tree gnu_rhs_side;
1784
1785 if (make_dummy_context)
1786 init_dummy_function_start ();
1787
1788 /* The elaboration of the RHS may generate code. If so,
1789 we need to make sure it gets executed after the LHS. */
1790 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
1791 clear_last_expr ();
1792
1793 gnu_rhs_side = expand_start_stmt_expr (1 /*has_scope*/);
1794 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
1795 expand_end_stmt_expr (gnu_rhs_side);
1796
1797 if (make_dummy_context)
1798 expand_dummy_function_end ();
1799
1800 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1801
1802 if (RTL_EXPR_SEQUENCE (gnu_rhs_side) != 0)
1803 gnu_rhs = build (COMPOUND_EXPR, gnu_result_type, gnu_rhs_side,
1804 gnu_rhs);
1805
1806 gnu_result = build_binary_op (code, gnu_result_type, gnu_lhs, gnu_rhs);
1807 }
1808 break;
1809
1810 case N_Op_Or: case N_Op_And: case N_Op_Xor:
1811 /* These can either be operations on booleans or on modular types.
1812 Fall through for boolean types since that's the way GNU_CODES is
1813 set up. */
1814 if (IN (Ekind (Underlying_Type (Etype (gnat_node))),
1815 Modular_Integer_Kind))
1816 {
1817 enum tree_code code
1818 = (Nkind (gnat_node) == N_Op_Or ? BIT_IOR_EXPR
1819 : Nkind (gnat_node) == N_Op_And ? BIT_AND_EXPR
1820 : BIT_XOR_EXPR);
1821
1822 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
1823 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
1824 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1825 gnu_result = build_binary_op (code, gnu_result_type,
1826 gnu_lhs, gnu_rhs);
1827 break;
1828 }
1829
1830 /* ... fall through ... */
1831
1832 case N_Op_Eq: case N_Op_Ne: case N_Op_Lt:
1833 case N_Op_Le: case N_Op_Gt: case N_Op_Ge:
1834 case N_Op_Add: case N_Op_Subtract: case N_Op_Multiply:
1835 case N_Op_Mod: case N_Op_Rem:
1836 case N_Op_Rotate_Left:
1837 case N_Op_Rotate_Right:
1838 case N_Op_Shift_Left:
1839 case N_Op_Shift_Right:
1840 case N_Op_Shift_Right_Arithmetic:
1841 {
1842 enum tree_code code = gnu_codes[Nkind (gnat_node)];
1843 tree gnu_type;
1844
1845 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
1846 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
1847 gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
1848
1849 /* If this is a comparison operator, convert any references to
1850 an unconstrained array value into a reference to the
1851 actual array. */
1852 if (TREE_CODE_CLASS (code) == '<')
1853 {
1854 gnu_lhs = maybe_unconstrained_array (gnu_lhs);
1855 gnu_rhs = maybe_unconstrained_array (gnu_rhs);
1856 }
1857
1858 /* If the result type is a private type, its full view may be a
1859 numeric subtype. The representation we need is that of its base
1860 type, given that it is the result of an arithmetic operation. */
1861 else if (Is_Private_Type (Etype (gnat_node)))
1862 gnu_type = gnu_result_type
1863 = get_unpadded_type (Base_Type (Full_View (Etype (gnat_node))));
1864
1865 /* If this is a shift whose count is not guaranteed to be correct,
1866 we need to adjust the shift count. */
1867 if (IN (Nkind (gnat_node), N_Op_Shift)
1868 && ! Shift_Count_OK (gnat_node))
1869 {
1870 tree gnu_count_type = get_base_type (TREE_TYPE (gnu_rhs));
1871 tree gnu_max_shift
1872 = convert (gnu_count_type, TYPE_SIZE (gnu_type));
1873
1874 if (Nkind (gnat_node) == N_Op_Rotate_Left
1875 || Nkind (gnat_node) == N_Op_Rotate_Right)
1876 gnu_rhs = build_binary_op (TRUNC_MOD_EXPR, gnu_count_type,
1877 gnu_rhs, gnu_max_shift);
1878 else if (Nkind (gnat_node) == N_Op_Shift_Right_Arithmetic)
1879 gnu_rhs
1880 = build_binary_op
1881 (MIN_EXPR, gnu_count_type,
1882 build_binary_op (MINUS_EXPR,
1883 gnu_count_type,
1884 gnu_max_shift,
1885 convert (gnu_count_type,
1886 integer_one_node)),
1887 gnu_rhs);
1888 }
1889
1890 /* For right shifts, the type says what kind of shift to do,
1891 so we may need to choose a different type. */
1892 if (Nkind (gnat_node) == N_Op_Shift_Right
1893 && ! TREE_UNSIGNED (gnu_type))
1894 gnu_type = gnat_unsigned_type (gnu_type);
1895 else if (Nkind (gnat_node) == N_Op_Shift_Right_Arithmetic
1896 && TREE_UNSIGNED (gnu_type))
1897 gnu_type = gnat_signed_type (gnu_type);
1898
1899 if (gnu_type != gnu_result_type)
1900 {
1901 gnu_lhs = convert (gnu_type, gnu_lhs);
1902 gnu_rhs = convert (gnu_type, gnu_rhs);
1903 }
1904
1905 gnu_result = build_binary_op (code, gnu_type, gnu_lhs, gnu_rhs);
1906
1907 /* If this is a logical shift with the shift count not verified,
1908 we must return zero if it is too large. We cannot compensate
1909 above in this case. */
1910 if ((Nkind (gnat_node) == N_Op_Shift_Left
1911 || Nkind (gnat_node) == N_Op_Shift_Right)
1912 && ! Shift_Count_OK (gnat_node))
1913 gnu_result
1914 = build_cond_expr
1915 (gnu_type,
1916 build_binary_op (GE_EXPR, integer_type_node,
1917 gnu_rhs,
1918 convert (TREE_TYPE (gnu_rhs),
1919 TYPE_SIZE (gnu_type))),
1920 convert (gnu_type, integer_zero_node),
1921 gnu_result);
1922 }
1923 break;
1924
1925 case N_Conditional_Expression:
1926 {
1927 tree gnu_cond = gnat_to_gnu (First (Expressions (gnat_node)));
1928 tree gnu_true = gnat_to_gnu (Next (First (Expressions (gnat_node))));
1929 tree gnu_false
1930 = gnat_to_gnu (Next (Next (First (Expressions (gnat_node)))));
1931
1932 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1933 gnu_result = build_cond_expr (gnu_result_type,
1934 gnat_truthvalue_conversion (gnu_cond),
1935 gnu_true, gnu_false);
1936 }
1937 break;
1938
1939 case N_Op_Plus:
1940 gnu_result = gnat_to_gnu (Right_Opnd (gnat_node));
1941 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1942 break;
1943
1944 case N_Op_Not:
1945 /* This case can apply to a boolean or a modular type.
1946 Fall through for a boolean operand since GNU_CODES is set
1947 up to handle this. */
1948 if (IN (Ekind (Etype (gnat_node)), Modular_Integer_Kind))
1949 {
1950 gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
1951 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1952 gnu_result = build_unary_op (BIT_NOT_EXPR, gnu_result_type,
1953 gnu_expr);
1954 break;
1955 }
1956
1957 /* ... fall through ... */
1958
1959 case N_Op_Minus: case N_Op_Abs:
1960 gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
1961
1962 if (Ekind (Etype (gnat_node)) != E_Private_Type)
1963 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1964 else
1965 gnu_result_type = get_unpadded_type (Base_Type
1966 (Full_View (Etype (gnat_node))));
1967
1968 gnu_result = build_unary_op (gnu_codes[Nkind (gnat_node)],
1969 gnu_result_type, gnu_expr);
1970 break;
1971
1972 case N_Allocator:
1973 {
1974 tree gnu_init = 0;
1975 tree gnu_type;
1976
1977 gnat_temp = Expression (gnat_node);
1978
1979 /* The Expression operand can either be an N_Identifier or
1980 Expanded_Name, which must represent a type, or a
1981 N_Qualified_Expression, which contains both the object type and an
1982 initial value for the object. */
1983 if (Nkind (gnat_temp) == N_Identifier
1984 || Nkind (gnat_temp) == N_Expanded_Name)
1985 gnu_type = gnat_to_gnu_type (Entity (gnat_temp));
1986 else if (Nkind (gnat_temp) == N_Qualified_Expression)
1987 {
1988 Entity_Id gnat_desig_type
1989 = Designated_Type (Underlying_Type (Etype (gnat_node)));
1990
1991 gnu_init = gnat_to_gnu (Expression (gnat_temp));
1992
1993 gnu_init = maybe_unconstrained_array (gnu_init);
1994 if (Do_Range_Check (Expression (gnat_temp)))
1995 gnu_init = emit_range_check (gnu_init, gnat_desig_type);
1996
1997 if (Is_Elementary_Type (gnat_desig_type)
1998 || Is_Constrained (gnat_desig_type))
1999 {
2000 gnu_type = gnat_to_gnu_type (gnat_desig_type);
2001 gnu_init = convert (gnu_type, gnu_init);
2002 }
2003 else
2004 {
2005 gnu_type = gnat_to_gnu_type (Etype (Expression (gnat_temp)));
2006 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
2007 gnu_type = TREE_TYPE (gnu_init);
2008
2009 gnu_init = convert (gnu_type, gnu_init);
2010 }
2011 }
2012 else
2013 gigi_abort (315);
2014
2015 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2016 return build_allocator (gnu_type, gnu_init, gnu_result_type,
2017 Procedure_To_Call (gnat_node),
2018 Storage_Pool (gnat_node), gnat_node);
2019 }
2020 break;
2021
2022 /***************************/
2023 /* Chapter 5: Statements: */
2024 /***************************/
2025
2026 case N_Label:
2027 if (! type_annotate_only)
2028 {
2029 tree gnu_label = gnat_to_gnu (Identifier (gnat_node));
2030 Node_Id gnat_parent = Parent (gnat_node);
2031
2032 expand_label (gnu_label);
2033
2034 /* If this is the first label of an exception handler, we must
2035 mark that any CALL_INSN can jump to it. */
2036 if (Present (gnat_parent)
2037 && Nkind (gnat_parent) == N_Exception_Handler
2038 && First (Statements (gnat_parent)) == gnat_node)
2039 nonlocal_goto_handler_labels
2040 = gen_rtx_EXPR_LIST (VOIDmode, label_rtx (gnu_label),
2041 nonlocal_goto_handler_labels);
2042 }
2043 break;
2044
2045 case N_Null_Statement:
2046 break;
2047
2048 case N_Assignment_Statement:
2049 if (type_annotate_only)
2050 break;
2051
2052 /* Get the LHS and RHS of the statement and convert any reference to an
2053 unconstrained array into a reference to the underlying array. */
2054 gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node)));
2055 gnu_rhs
2056 = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node)));
2057
2058 /* If range check is needed, emit code to generate it */
2059 if (Do_Range_Check (Expression (gnat_node)))
2060 gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node)));
2061
2062 /* If either side's type has a size that overflows, convert this
2063 into raise of Storage_Error: execution shouldn't have gotten
2064 here anyway. */
2065 if ((TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_lhs))) == INTEGER_CST
2066 && TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_lhs))))
2067 || (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_rhs))) == INTEGER_CST
2068 && TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_rhs)))))
2069 gnu_result = build_call_raise (SE_Object_Too_Large);
2070 else
2071 gnu_result
2072 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs);
2073
2074 gnu_result = build_nt (EXPR_STMT, gnu_result);
2075 break;
2076
2077 case N_If_Statement:
2078 /* Start an IF statement giving the condition. */
2079 gnu_expr = gnat_to_gnu (Condition (gnat_node));
2080 set_lineno (gnat_node, 1);
2081 expand_start_cond (gnu_expr, 0);
2082
2083 /* Generate code for the statements to be executed if the condition
2084 is true. */
2085
2086 for (gnat_temp = First (Then_Statements (gnat_node));
2087 Present (gnat_temp);
2088 gnat_temp = Next (gnat_temp))
2089 gnat_to_code (gnat_temp);
2090
2091 /* Generate each of the "else if" parts. */
2092 if (Present (Elsif_Parts (gnat_node)))
2093 {
2094 for (gnat_temp = First (Elsif_Parts (gnat_node));
2095 Present (gnat_temp);
2096 gnat_temp = Next (gnat_temp))
2097 {
2098 Node_Id gnat_statement;
2099
2100 expand_start_else ();
2101
2102 /* Set up the line numbers for each condition we test. */
2103 set_lineno (Condition (gnat_temp), 1);
2104 expand_elseif (gnat_to_gnu (Condition (gnat_temp)));
2105
2106 for (gnat_statement = First (Then_Statements (gnat_temp));
2107 Present (gnat_statement);
2108 gnat_statement = Next (gnat_statement))
2109 gnat_to_code (gnat_statement);
2110 }
2111 }
2112
2113 /* Finally, handle any statements in the "else" part. */
2114 if (Present (Else_Statements (gnat_node)))
2115 {
2116 expand_start_else ();
2117
2118 for (gnat_temp = First (Else_Statements (gnat_node));
2119 Present (gnat_temp);
2120 gnat_temp = Next (gnat_temp))
2121 gnat_to_code (gnat_temp);
2122 }
2123
2124 expand_end_cond ();
2125 break;
2126
2127 case N_Case_Statement:
2128 {
2129 Node_Id gnat_when;
2130 Node_Id gnat_choice;
2131 tree gnu_label;
2132 Node_Id gnat_statement;
2133
2134 gnu_expr = gnat_to_gnu (Expression (gnat_node));
2135 gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
2136
2137 /* The range of values in a case statement is determined by the
2138 rules in RM 5.4(7-9). In almost all cases, this range is
2139 represented by the Etype of the expression. One exception arises
2140 in the case of a simple name that is parenthesized. This still
2141 has the Etype of the name, but since it is not a name, para 7
2142 does not apply, and we need to go to the base type. This is the
2143 only case where parenthesization affects the dynamic semantics
2144 (i.e. the range of possible values at runtime that is covered by
2145 the others alternative.
2146
2147 Another exception is if the subtype of the expression is
2148 non-static. In that case, we also have to use the base type. */
2149 if (Paren_Count (Expression (gnat_node)) != 0
2150 || !Is_OK_Static_Subtype (Underlying_Type
2151 (Etype (Expression (gnat_node)))))
2152 gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
2153
2154 set_lineno (gnat_node, 1);
2155 expand_start_case (1, gnu_expr, TREE_TYPE (gnu_expr), "case");
2156
2157 for (gnat_when = First_Non_Pragma (Alternatives (gnat_node));
2158 Present (gnat_when);
2159 gnat_when = Next_Non_Pragma (gnat_when))
2160 {
2161 /* First compile all the different case choices for the current
2162 WHEN alternative. */
2163
2164 for (gnat_choice = First (Discrete_Choices (gnat_when));
2165 Present (gnat_choice); gnat_choice = Next (gnat_choice))
2166 {
2167 int error_code;
2168
2169 gnu_label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
2170
2171 set_lineno (gnat_choice, 1);
2172 switch (Nkind (gnat_choice))
2173 {
2174 case N_Range:
2175 /* Abort on all errors except range empty, which
2176 means we ignore this alternative. */
2177 error_code
2178 = pushcase_range (gnat_to_gnu (Low_Bound (gnat_choice)),
2179 gnat_to_gnu (High_Bound (gnat_choice)),
2180 convert, gnu_label, 0);
2181
2182 if (error_code != 0 && error_code != 4)
2183 gigi_abort (332);
2184 break;
2185
2186 case N_Subtype_Indication:
2187 error_code
2188 = pushcase_range
2189 (gnat_to_gnu (Low_Bound (Range_Expression
2190 (Constraint (gnat_choice)))),
2191 gnat_to_gnu (High_Bound (Range_Expression
2192 (Constraint (gnat_choice)))),
2193 convert, gnu_label, 0);
2194
2195 if (error_code != 0 && error_code != 4)
2196 gigi_abort (332);
2197 break;
2198
2199 case N_Identifier:
2200 case N_Expanded_Name:
2201 /* This represents either a subtype range or a static value
2202 of some kind; Ekind says which. If a static value,
2203 fall through to the next case. */
2204 if (IN (Ekind (Entity (gnat_choice)), Type_Kind))
2205 {
2206 tree type = get_unpadded_type (Entity (gnat_choice));
2207
2208 error_code
2209 = pushcase_range (fold (TYPE_MIN_VALUE (type)),
2210 fold (TYPE_MAX_VALUE (type)),
2211 convert, gnu_label, 0);
2212
2213 if (error_code != 0 && error_code != 4)
2214 gigi_abort (332);
2215 break;
2216 }
2217 /* ... fall through ... */
2218 case N_Character_Literal:
2219 case N_Integer_Literal:
2220 if (pushcase (gnat_to_gnu (gnat_choice), convert,
2221 gnu_label, 0))
2222 gigi_abort (332);
2223 break;
2224
2225 case N_Others_Choice:
2226 if (pushcase (NULL_TREE, convert, gnu_label, 0))
2227 gigi_abort (332);
2228 break;
2229
2230 default:
2231 gigi_abort (316);
2232 }
2233 }
2234
2235 /* After compiling the choices attached to the WHEN compile the
2236 body of statements that have to be executed, should the
2237 "WHEN ... =>" be taken. Push a binding level here in case
2238 variables are declared since we want them to be local to this
2239 set of statements instead of the block containing the Case
2240 statement. */
2241 pushlevel (0);
2242 expand_start_bindings (0);
2243 for (gnat_statement = First (Statements (gnat_when));
2244 Present (gnat_statement);
2245 gnat_statement = Next (gnat_statement))
2246 gnat_to_code (gnat_statement);
2247
2248 /* Communicate to GCC that we are done with the current WHEN,
2249 i.e. insert a "break" statement. */
2250 expand_exit_something ();
2251 expand_end_bindings (getdecls (), kept_level_p (), -1);
2252 poplevel (kept_level_p (), 1, 0);
2253 }
2254
2255 expand_end_case (gnu_expr);
2256 }
2257 break;
2258
2259 case N_Loop_Statement:
2260 {
2261 /* The loop variable in GCC form, if any. */
2262 tree gnu_loop_var = NULL_TREE;
2263 /* PREINCREMENT_EXPR or PREDECREMENT_EXPR. */
2264 enum tree_code gnu_update = ERROR_MARK;
2265 /* Used if this is a named loop for so EXIT can work. */
2266 struct nesting *loop_id;
2267 /* Condition to continue loop tested at top of loop. */
2268 tree gnu_top_condition = integer_one_node;
2269 /* Similar, but tested at bottom of loop. */
2270 tree gnu_bottom_condition = integer_one_node;
2271 Node_Id gnat_statement;
2272 Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node);
2273 Node_Id gnat_top_condition = Empty;
2274 int enclosing_if_p = 0;
2275
2276 /* Set the condition that under which the loop should continue.
2277 For "LOOP .... END LOOP;" the condition is always true. */
2278 if (No (gnat_iter_scheme))
2279 ;
2280 /* The case "WHILE condition LOOP ..... END LOOP;" */
2281 else if (Present (Condition (gnat_iter_scheme)))
2282 gnat_top_condition = Condition (gnat_iter_scheme);
2283 else
2284 {
2285 /* We have an iteration scheme. */
2286 Node_Id gnat_loop_spec
2287 = Loop_Parameter_Specification (gnat_iter_scheme);
2288 Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec);
2289 Entity_Id gnat_type = Etype (gnat_loop_var);
2290 tree gnu_type = get_unpadded_type (gnat_type);
2291 tree gnu_low = TYPE_MIN_VALUE (gnu_type);
2292 tree gnu_high = TYPE_MAX_VALUE (gnu_type);
2293 int reversep = Reverse_Present (gnat_loop_spec);
2294 tree gnu_first = reversep ? gnu_high : gnu_low;
2295 tree gnu_last = reversep ? gnu_low : gnu_high;
2296 enum tree_code end_code = reversep ? GE_EXPR : LE_EXPR;
2297 tree gnu_base_type = get_base_type (gnu_type);
2298 tree gnu_limit
2299 = (reversep ? TYPE_MIN_VALUE (gnu_base_type)
2300 : TYPE_MAX_VALUE (gnu_base_type));
2301
2302 /* We know the loop variable will not overflow if GNU_LAST is
2303 a constant and is not equal to GNU_LIMIT. If it might
2304 overflow, we have to move the limit test to the end of
2305 the loop. In that case, we have to test for an
2306 empty loop outside the loop. */
2307 if (TREE_CODE (gnu_last) != INTEGER_CST
2308 || TREE_CODE (gnu_limit) != INTEGER_CST
2309 || tree_int_cst_equal (gnu_last, gnu_limit))
2310 {
2311 gnu_expr = build_binary_op (LE_EXPR, integer_type_node,
2312 gnu_low, gnu_high);
2313 set_lineno (gnat_loop_spec, 1);
2314 expand_start_cond (gnu_expr, 0);
2315 enclosing_if_p = 1;
2316 }
2317
2318 /* Open a new nesting level that will surround the loop to declare
2319 the loop index variable. */
2320 pushlevel (0);
2321 expand_start_bindings (0);
2322
2323 /* Declare the loop index and set it to its initial value. */
2324 gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1);
2325 if (DECL_BY_REF_P (gnu_loop_var))
2326 gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE,
2327 gnu_loop_var);
2328
2329 /* The loop variable might be a padded type, so use `convert' to
2330 get a reference to the inner variable if so. */
2331 gnu_loop_var = convert (get_base_type (gnu_type), gnu_loop_var);
2332
2333 /* Set either the top or bottom exit condition as
2334 appropriate depending on whether we know an overflow
2335 cannot occur or not. */
2336 if (enclosing_if_p)
2337 gnu_bottom_condition
2338 = build_binary_op (NE_EXPR, integer_type_node,
2339 gnu_loop_var, gnu_last);
2340 else
2341 gnu_top_condition
2342 = build_binary_op (end_code, integer_type_node,
2343 gnu_loop_var, gnu_last);
2344
2345 gnu_update = reversep ? PREDECREMENT_EXPR : PREINCREMENT_EXPR;
2346 }
2347
2348 set_lineno (gnat_node, 1);
2349 if (gnu_loop_var)
2350 loop_id = expand_start_loop_continue_elsewhere (1);
2351 else
2352 loop_id = expand_start_loop (1);
2353
2354 /* If the loop was named, have the name point to this loop. In this
2355 case, the association is not a ..._DECL node; in fact, it isn't
2356 a GCC tree node at all. Since this name is referenced inside
2357 the loop, do it before we process the statements of the loop. */
2358 if (Present (Identifier (gnat_node)))
2359 {
2360 tree gnu_loop_id = make_node (GNAT_LOOP_ID);
2361
2362 TREE_LOOP_ID (gnu_loop_id) = loop_id;
2363 save_gnu_tree (Entity (Identifier (gnat_node)), gnu_loop_id, 1);
2364 }
2365
2366 set_lineno (gnat_node, 1);
2367
2368 /* We must evaluate the condition after we've entered the
2369 loop so that any expression actions get done in the right
2370 place. */
2371 if (Present (gnat_top_condition))
2372 gnu_top_condition = gnat_to_gnu (gnat_top_condition);
2373
2374 expand_exit_loop_top_cond (0, gnu_top_condition);
2375
2376 /* Make the loop body into its own block, so any allocated
2377 storage will be released every iteration. This is needed
2378 for stack allocation. */
2379
2380 pushlevel (0);
2381 gnu_block_stack
2382 = tree_cons (gnu_bottom_condition, NULL_TREE, gnu_block_stack);
2383 expand_start_bindings (0);
2384
2385 for (gnat_statement = First (Statements (gnat_node));
2386 Present (gnat_statement);
2387 gnat_statement = Next (gnat_statement))
2388 gnat_to_code (gnat_statement);
2389
2390 expand_end_bindings (getdecls (), kept_level_p (), -1);
2391 poplevel (kept_level_p (), 1, 0);
2392 gnu_block_stack = TREE_CHAIN (gnu_block_stack);
2393
2394 set_lineno (gnat_node, 1);
2395 expand_exit_loop_if_false (0, gnu_bottom_condition);
2396
2397 if (gnu_loop_var)
2398 {
2399 expand_loop_continue_here ();
2400 gnu_expr = build_binary_op (gnu_update, TREE_TYPE (gnu_loop_var),
2401 gnu_loop_var,
2402 convert (TREE_TYPE (gnu_loop_var),
2403 integer_one_node));
2404 set_lineno (gnat_iter_scheme, 1);
2405 expand_expr_stmt (gnu_expr);
2406 }
2407
2408 set_lineno (gnat_node, 1);
2409 expand_end_loop ();
2410
2411 if (gnu_loop_var)
2412 {
2413 /* Close the nesting level that sourround the loop that was used to
2414 declare the loop index variable. */
2415 set_lineno (gnat_node, 1);
2416 expand_end_bindings (getdecls (), 1, -1);
2417 poplevel (1, 1, 0);
2418 }
2419
2420 if (enclosing_if_p)
2421 {
2422 set_lineno (gnat_node, 1);
2423 expand_end_cond ();
2424 }
2425 }
2426 break;
2427
2428 case N_Block_Statement:
2429 pushlevel (0);
2430 gnu_block_stack = tree_cons (NULL_TREE, NULL_TREE, gnu_block_stack);
2431 expand_start_bindings (0);
2432 process_decls (Declarations (gnat_node), Empty, Empty, 1, 1);
2433 gnat_to_code (Handled_Statement_Sequence (gnat_node));
2434 expand_end_bindings (getdecls (), kept_level_p (), -1);
2435 poplevel (kept_level_p (), 1, 0);
2436 gnu_block_stack = TREE_CHAIN (gnu_block_stack);
2437 if (Present (Identifier (gnat_node)))
2438 mark_out_of_scope (Entity (Identifier (gnat_node)));
2439 break;
2440
2441 case N_Exit_Statement:
2442 {
2443 /* Which loop to exit, NULL if the current loop. */
2444 struct nesting *loop_id = 0;
2445 /* The GCC version of the optional GNAT condition node attached to the
2446 exit statement. Exit the loop if this is false. */
2447 tree gnu_cond = integer_zero_node;
2448
2449 if (Present (Name (gnat_node)))
2450 loop_id
2451 = TREE_LOOP_ID (get_gnu_tree (Entity (Name (gnat_node))));
2452
2453 if (Present (Condition (gnat_node)))
2454 gnu_cond = invert_truthvalue (gnat_truthvalue_conversion
2455 (gnat_to_gnu (Condition (gnat_node))));
2456
2457 set_lineno (gnat_node, 1);
2458 expand_exit_loop_if_false (loop_id, gnu_cond);
2459 }
2460 break;
2461
2462 case N_Return_Statement:
2463 if (type_annotate_only)
2464 break;
2465
2466 {
2467 /* The gnu function type of the subprogram currently processed. */
2468 tree gnu_subprog_type = TREE_TYPE (current_function_decl);
2469 /* The return value from the subprogram. */
2470 tree gnu_ret_val = 0;
2471
2472 /* If we are dealing with a "return;" from an Ada procedure with
2473 parameters passed by copy in copy out, we need to return a record
2474 containing the final values of these parameters. If the list
2475 contains only one entry, return just that entry.
2476
2477 For a full description of the copy in copy out parameter mechanism,
2478 see the part of the gnat_to_gnu_entity routine dealing with the
2479 translation of subprograms.
2480
2481 But if we have a return label defined, convert this into
2482 a branch to that label. */
2483
2484 if (TREE_VALUE (gnu_return_label_stack) != 0)
2485 expand_goto (TREE_VALUE (gnu_return_label_stack));
2486
2487 else if (TYPE_CI_CO_LIST (gnu_subprog_type) != NULL_TREE)
2488 {
2489 if (list_length (TYPE_CI_CO_LIST (gnu_subprog_type)) == 1)
2490 gnu_ret_val = TREE_VALUE (TYPE_CI_CO_LIST (gnu_subprog_type));
2491 else
2492 gnu_ret_val
2493 = gnat_build_constructor (TREE_TYPE (gnu_subprog_type),
2494 TYPE_CI_CO_LIST (gnu_subprog_type));
2495 }
2496
2497 /* If the Ada subprogram is a function, we just need to return the
2498 expression. If the subprogram returns an unconstrained
2499 array, we have to allocate a new version of the result and
2500 return it. If we return by reference, return a pointer. */
2501
2502 else if (Present (Expression (gnat_node)))
2503 {
2504 gnu_ret_val = gnat_to_gnu (Expression (gnat_node));
2505
2506 /* Do not remove the padding from GNU_RET_VAL if the inner
2507 type is self-referential since we want to allocate the fixed
2508 size in that case. */
2509 if (TREE_CODE (gnu_ret_val) == COMPONENT_REF
2510 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0)))
2511 == RECORD_TYPE)
2512 && (TYPE_IS_PADDING_P
2513 (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0))))
2514 && (CONTAINS_PLACEHOLDER_P
2515 (TYPE_SIZE (TREE_TYPE (gnu_ret_val)))))
2516 gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0);
2517
2518 if (TYPE_RETURNS_BY_REF_P (gnu_subprog_type)
2519 || By_Ref (gnat_node))
2520 gnu_ret_val = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val);
2521
2522 else if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type))
2523 {
2524 gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
2525
2526 /* We have two cases: either the function returns with
2527 depressed stack or not. If not, we allocate on the
2528 secondary stack. If so, we allocate in the stack frame.
2529 if no copy is needed, the front end will set By_Ref,
2530 which we handle in the case above. */
2531 if (TYPE_RETURNS_STACK_DEPRESSED (gnu_subprog_type))
2532 gnu_ret_val
2533 = build_allocator (TREE_TYPE (gnu_ret_val), gnu_ret_val,
2534 TREE_TYPE (gnu_subprog_type), 0, -1,
2535 gnat_node);
2536 else
2537 gnu_ret_val
2538 = build_allocator (TREE_TYPE (gnu_ret_val), gnu_ret_val,
2539 TREE_TYPE (gnu_subprog_type),
2540 Procedure_To_Call (gnat_node),
2541 Storage_Pool (gnat_node), gnat_node);
2542 }
2543 }
2544
2545 set_lineno (gnat_node, 1);
2546 if (gnu_ret_val)
2547 expand_return (build_binary_op (MODIFY_EXPR, NULL_TREE,
2548 DECL_RESULT (current_function_decl),
2549 gnu_ret_val));
2550 else
2551 expand_null_return ();
2552
2553 }
2554 break;
2555
2556 case N_Goto_Statement:
2557 if (type_annotate_only)
2558 break;
2559
2560 gnu_expr = gnat_to_gnu (Name (gnat_node));
2561 TREE_USED (gnu_expr) = 1;
2562 set_lineno (gnat_node, 1);
2563 expand_goto (gnu_expr);
2564 break;
2565
2566 /****************************/
2567 /* Chapter 6: Subprograms: */
2568 /****************************/
2569
2570 case N_Subprogram_Declaration:
2571 /* Unless there is a freeze node, declare the subprogram. We consider
2572 this a "definition" even though we're not generating code for
2573 the subprogram because we will be making the corresponding GCC
2574 node here. */
2575
2576 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
2577 gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node)),
2578 NULL_TREE, 1);
2579
2580 break;
2581
2582 case N_Abstract_Subprogram_Declaration:
2583 /* This subprogram doesn't exist for code generation purposes, but we
2584 have to elaborate the types of any parameters, unless they are
2585 imported types (nothing to generate in this case). */
2586 for (gnat_temp
2587 = First_Formal (Defining_Entity (Specification (gnat_node)));
2588 Present (gnat_temp);
2589 gnat_temp = Next_Formal_With_Extras (gnat_temp))
2590 if (Is_Itype (Etype (gnat_temp))
2591 && !From_With_Type (Etype (gnat_temp)))
2592 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
2593
2594 break;
2595
2596 case N_Defining_Program_Unit_Name:
2597 /* For a child unit identifier go up a level to get the
2598 specificaton. We get this when we try to find the spec of
2599 a child unit package that is the compilation unit being compiled. */
2600 gnat_to_code (Parent (gnat_node));
2601 break;
2602
2603 case N_Subprogram_Body:
2604 {
2605 /* Save debug output mode in case it is reset. */
2606 enum debug_info_type save_write_symbols = write_symbols;
2607 const struct gcc_debug_hooks *const save_debug_hooks = debug_hooks;
2608 /* Definining identifier of a parameter to the subprogram. */
2609 Entity_Id gnat_param;
2610 /* The defining identifier for the subprogram body. Note that if a
2611 specification has appeared before for this body, then the identifier
2612 occurring in that specification will also be a defining identifier
2613 and all the calls to this subprogram will point to that
2614 specification. */
2615 Entity_Id gnat_subprog_id
2616 = (Present (Corresponding_Spec (gnat_node))
2617 ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node));
2618
2619 /* The FUNCTION_DECL node corresponding to the subprogram spec. */
2620 tree gnu_subprog_decl;
2621 /* The FUNCTION_TYPE node corresponding to the subprogram spec. */
2622 tree gnu_subprog_type;
2623 tree gnu_cico_list;
2624
2625 /* If this is a generic object or if it has been eliminated,
2626 ignore it. */
2627
2628 if (Ekind (gnat_subprog_id) == E_Generic_Procedure
2629 || Ekind (gnat_subprog_id) == E_Generic_Function
2630 || Is_Eliminated (gnat_subprog_id))
2631 break;
2632
2633 /* If debug information is suppressed for the subprogram,
2634 turn debug mode off for the duration of processing. */
2635 if (!Needs_Debug_Info (gnat_subprog_id))
2636 {
2637 write_symbols = NO_DEBUG;
2638 debug_hooks = &do_nothing_debug_hooks;
2639 }
2640
2641 /* If this subprogram acts as its own spec, define it. Otherwise,
2642 just get the already-elaborated tree node. However, if this
2643 subprogram had its elaboration deferred, we will already have
2644 made a tree node for it. So treat it as not being defined in
2645 that case. Such a subprogram cannot have an address clause or
2646 a freeze node, so this test is safe, though it does disable
2647 some otherwise-useful error checking. */
2648 gnu_subprog_decl
2649 = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE,
2650 Acts_As_Spec (gnat_node)
2651 && ! present_gnu_tree (gnat_subprog_id));
2652
2653 gnu_subprog_type = TREE_TYPE (gnu_subprog_decl);
2654
2655 /* Set the line number in the decl to correspond to that of
2656 the body so that the line number notes are written
2657 correctly. */
2658 set_lineno (gnat_node, 0);
2659 DECL_SOURCE_LOCATION (gnu_subprog_decl) = input_location;
2660
2661 begin_subprog_body (gnu_subprog_decl);
2662
2663 /* There used to be a second call to set_lineno here, with
2664 write_note_p set, but begin_subprog_body actually already emits the
2665 note we want (via init_function_start).
2666
2667 Emitting a second note here was necessary for -ftest-coverage with
2668 GCC 2.8.1, as the first one was skipped by branch_prob. This is no
2669 longer the case with GCC 3.x, so emitting a second note here would
2670 result in having the first line of the subprogram counted twice by
2671 gcov. */
2672
2673 pushlevel (0);
2674 gnu_block_stack = tree_cons (NULL_TREE, NULL_TREE, gnu_block_stack);
2675 expand_start_bindings (0);
2676
2677 gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
2678
2679 /* If there are OUT parameters, we need to ensure that the
2680 return statement properly copies them out. We do this by
2681 making a new block and converting any inner return into a goto
2682 to a label at the end of the block. */
2683
2684 if (gnu_cico_list != 0)
2685 {
2686 gnu_return_label_stack
2687 = tree_cons (NULL_TREE,
2688 build_decl (LABEL_DECL, NULL_TREE, NULL_TREE),
2689 gnu_return_label_stack);
2690 pushlevel (0);
2691 expand_start_bindings (0);
2692 }
2693 else
2694 gnu_return_label_stack
2695 = tree_cons (NULL_TREE, NULL_TREE, gnu_return_label_stack);
2696
2697 /* See if there are any parameters for which we don't yet have
2698 GCC entities. These must be for OUT parameters for which we
2699 will be making VAR_DECL nodes here. Fill them in to
2700 TYPE_CI_CO_LIST, which must contain the empty entry as well.
2701 We can match up the entries because TYPE_CI_CO_LIST is in the
2702 order of the parameters. */
2703
2704 for (gnat_param = First_Formal (gnat_subprog_id);
2705 Present (gnat_param);
2706 gnat_param = Next_Formal_With_Extras (gnat_param))
2707 if (present_gnu_tree (gnat_param))
2708 adjust_decl_rtl (get_gnu_tree (gnat_param));
2709 else
2710 {
2711 /* Skip any entries that have been already filled in; they
2712 must correspond to IN OUT parameters. */
2713 for (; gnu_cico_list != 0 && TREE_VALUE (gnu_cico_list) != 0;
2714 gnu_cico_list = TREE_CHAIN (gnu_cico_list))
2715 ;
2716
2717 /* Do any needed references for padded types. */
2718 TREE_VALUE (gnu_cico_list)
2719 = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_list)),
2720 gnat_to_gnu_entity (gnat_param, NULL_TREE, 1));
2721 }
2722
2723 process_decls (Declarations (gnat_node), Empty, Empty, 1, 1);
2724
2725 /* Generate the code of the subprogram itself. A return statement
2726 will be present and any OUT parameters will be handled there. */
2727 gnat_to_code (Handled_Statement_Sequence (gnat_node));
2728
2729 expand_end_bindings (getdecls (), kept_level_p (), -1);
2730 poplevel (kept_level_p (), 1, 0);
2731 gnu_block_stack = TREE_CHAIN (gnu_block_stack);
2732
2733 if (TREE_VALUE (gnu_return_label_stack) != 0)
2734 {
2735 tree gnu_retval;
2736
2737 expand_end_bindings (NULL_TREE, kept_level_p (), -1);
2738 poplevel (kept_level_p (), 1, 0);
2739 expand_label (TREE_VALUE (gnu_return_label_stack));
2740
2741 gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
2742 set_lineno (gnat_node, 1);
2743 if (list_length (gnu_cico_list) == 1)
2744 gnu_retval = TREE_VALUE (gnu_cico_list);
2745 else
2746 gnu_retval = gnat_build_constructor (TREE_TYPE (gnu_subprog_type),
2747 gnu_cico_list);
2748
2749 if (DECL_P (gnu_retval) && DECL_BY_REF_P (gnu_retval))
2750 gnu_retval
2751 = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_retval);
2752
2753 expand_return
2754 (build_binary_op (MODIFY_EXPR, NULL_TREE,
2755 DECL_RESULT (current_function_decl),
2756 gnu_retval));
2757
2758 }
2759
2760 gnu_return_label_stack = TREE_CHAIN (gnu_return_label_stack);
2761
2762 /* Disconnect the trees for parameters that we made variables for
2763 from the GNAT entities since these will become unusable after
2764 we end the function. */
2765 for (gnat_param = First_Formal (gnat_subprog_id);
2766 Present (gnat_param);
2767 gnat_param = Next_Formal_With_Extras (gnat_param))
2768 if (TREE_CODE (get_gnu_tree (gnat_param)) == VAR_DECL)
2769 save_gnu_tree (gnat_param, NULL_TREE, 0);
2770
2771 end_subprog_body ();
2772 mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node)));
2773 write_symbols = save_write_symbols;
2774 debug_hooks = save_debug_hooks;
2775 }
2776 break;
2777
2778 case N_Function_Call:
2779 case N_Procedure_Call_Statement:
2780
2781 if (type_annotate_only)
2782 break;
2783
2784 {
2785 /* The GCC node corresponding to the GNAT subprogram name. This can
2786 either be a FUNCTION_DECL node if we are dealing with a standard
2787 subprogram call, or an indirect reference expression (an
2788 INDIRECT_REF node) pointing to a subprogram. */
2789 tree gnu_subprog_node = gnat_to_gnu (Name (gnat_node));
2790 /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */
2791 tree gnu_subprog_type = TREE_TYPE (gnu_subprog_node);
2792 tree gnu_subprog_addr
2793 = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_subprog_node);
2794 Entity_Id gnat_formal;
2795 Node_Id gnat_actual;
2796 tree gnu_actual_list = NULL_TREE;
2797 tree gnu_name_list = NULL_TREE;
2798 tree gnu_after_list = NULL_TREE;
2799 tree gnu_subprog_call;
2800
2801 switch (Nkind (Name (gnat_node)))
2802 {
2803 case N_Identifier:
2804 case N_Operator_Symbol:
2805 case N_Expanded_Name:
2806 case N_Attribute_Reference:
2807 if (Is_Eliminated (Entity (Name (gnat_node))))
2808 Eliminate_Error_Msg (gnat_node, Entity (Name (gnat_node)));
2809 }
2810
2811 if (TREE_CODE (gnu_subprog_type) != FUNCTION_TYPE)
2812 gigi_abort (317);
2813
2814 /* If we are calling a stubbed function, make this into a
2815 raise of Program_Error. Elaborate all our args first. */
2816
2817 if (TREE_CODE (gnu_subprog_node) == FUNCTION_DECL
2818 && DECL_STUBBED_P (gnu_subprog_node))
2819 {
2820 for (gnat_actual = First_Actual (gnat_node);
2821 Present (gnat_actual);
2822 gnat_actual = Next_Actual (gnat_actual))
2823 expand_expr_stmt (gnat_to_gnu (gnat_actual));
2824
2825 if (Nkind (gnat_node) == N_Function_Call)
2826 {
2827 gnu_result_type = TREE_TYPE (gnu_subprog_type);
2828 gnu_result
2829 = build1 (NULL_EXPR, gnu_result_type,
2830 build_call_raise (PE_Stubbed_Subprogram_Called));
2831 }
2832 else
2833 expand_expr_stmt
2834 (build_call_raise (PE_Stubbed_Subprogram_Called));
2835 break;
2836 }
2837
2838 /* The only way we can be making a call via an access type is
2839 if Name is an explicit dereference. In that case, get the
2840 list of formal args from the type the access type is pointing
2841 to. Otherwise, get the formals from entity being called. */
2842 if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
2843 gnat_formal = First_Formal (Etype (Name (gnat_node)));
2844 else if (Nkind (Name (gnat_node)) == N_Attribute_Reference)
2845 /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
2846 gnat_formal = 0;
2847 else
2848 gnat_formal = First_Formal (Entity (Name (gnat_node)));
2849
2850 /* Create the list of the actual parameters as GCC expects it, namely
2851 a chain of TREE_LIST nodes in which the TREE_VALUE field of each
2852 node is a parameter-expression and the TREE_PURPOSE field is
2853 null. Skip OUT parameters that are not passed by reference and
2854 don't need to be copied in. */
2855
2856 for (gnat_actual = First_Actual (gnat_node);
2857 Present (gnat_actual);
2858 gnat_formal = Next_Formal_With_Extras (gnat_formal),
2859 gnat_actual = Next_Actual (gnat_actual))
2860 {
2861 tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal));
2862 /* We treat a conversion between aggregate types as if it
2863 is an unchecked conversion. */
2864 int unchecked_convert_p
2865 = (Nkind (gnat_actual) == N_Unchecked_Type_Conversion
2866 || (Nkind (gnat_actual) == N_Type_Conversion
2867 && Is_Composite_Type (Underlying_Type
2868 (Etype (gnat_formal)))));
2869 Node_Id gnat_name
2870 = unchecked_convert_p ? Expression (gnat_actual) : gnat_actual;
2871 tree gnu_name = gnat_to_gnu (gnat_name);
2872 tree gnu_name_type = gnat_to_gnu_type (Etype (gnat_name));
2873 tree gnu_actual;
2874
2875 /* If it's possible we may need to use this expression twice,
2876 make sure than any side-effects are handled via SAVE_EXPRs.
2877 Likewise if we need to force side-effects before the call.
2878 ??? This is more conservative than we need since we don't
2879 need to do this for pass-by-ref with no conversion.
2880 If we are passing a non-addressable Out or In Out parameter by
2881 reference, pass the address of a copy and set up to copy back
2882 out after the call. */
2883
2884 if (Ekind (gnat_formal) != E_In_Parameter)
2885 {
2886 gnu_name = gnat_stabilize_reference (gnu_name, 1);
2887 if (! addressable_p (gnu_name)
2888 && present_gnu_tree (gnat_formal)
2889 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
2890 || (TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
2891 && (DECL_BY_COMPONENT_PTR_P
2892 (get_gnu_tree (gnat_formal))
2893 || DECL_BY_DESCRIPTOR_P
2894 (get_gnu_tree (gnat_formal))))))
2895 {
2896 tree gnu_copy = gnu_name;
2897 tree gnu_temp;
2898
2899 /* Remove any unpadding on the actual and make a copy.
2900 But if the actual is a left-justified modular type,
2901 first convert to it. */
2902 if (TREE_CODE (gnu_name) == COMPONENT_REF
2903 && ((TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_name, 0)))
2904 == RECORD_TYPE)
2905 && (TYPE_IS_PADDING_P
2906 (TREE_TYPE (TREE_OPERAND (gnu_name, 0))))))
2907 gnu_name = gnu_copy = TREE_OPERAND (gnu_name, 0);
2908 else if (TREE_CODE (gnu_name_type) == RECORD_TYPE
2909 && (TYPE_LEFT_JUSTIFIED_MODULAR_P
2910 (gnu_name_type)))
2911 gnu_name = convert (gnu_name_type, gnu_name);
2912
2913 gnu_actual = save_expr (gnu_name);
2914
2915 /* Since we're going to take the address of the SAVE_EXPR,
2916 we don't want it to be marked as unchanging.
2917 So set TREE_ADDRESSABLE. */
2918 gnu_temp = skip_simple_arithmetic (gnu_actual);
2919 if (TREE_CODE (gnu_temp) == SAVE_EXPR)
2920 {
2921 TREE_ADDRESSABLE (gnu_temp) = 1;
2922 TREE_READONLY (gnu_temp) = 0;
2923 }
2924
2925 /* Set up to move the copy back to the original. */
2926 gnu_after_list = tree_cons (gnu_copy, gnu_actual,
2927 gnu_after_list);
2928
2929 gnu_name = gnu_actual;
2930 }
2931 }
2932
2933 /* If this was a procedure call, we may not have removed any
2934 padding. So do it here for the part we will use as an
2935 input, if any. */
2936 gnu_actual = gnu_name;
2937 if (Ekind (gnat_formal) != E_Out_Parameter
2938 && TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
2939 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
2940 gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
2941 gnu_actual);
2942
2943 if (Ekind (gnat_formal) != E_Out_Parameter
2944 && ! unchecked_convert_p
2945 && Do_Range_Check (gnat_actual))
2946 gnu_actual = emit_range_check (gnu_actual, Etype (gnat_formal));
2947
2948 /* Do any needed conversions. We need only check for
2949 unchecked conversion since normal conversions will be handled
2950 by just converting to the formal type. */
2951 if (unchecked_convert_p)
2952 {
2953 gnu_actual
2954 = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)),
2955 gnu_actual,
2956 (Nkind (gnat_actual)
2957 == N_Unchecked_Type_Conversion)
2958 && No_Truncation (gnat_actual));
2959
2960 /* One we've done the unchecked conversion, we still
2961 must ensure that the object is in range of the formal's
2962 type. */
2963 if (Ekind (gnat_formal) != E_Out_Parameter
2964 && Do_Range_Check (gnat_actual))
2965 gnu_actual = emit_range_check (gnu_actual,
2966 Etype (gnat_formal));
2967 }
2968 else if (TREE_CODE (gnu_actual) != SAVE_EXPR)
2969 /* We may have suppressed a conversion to the Etype of the
2970 actual since the parent is a procedure call. So add the
2971 conversion here. */
2972 gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
2973 gnu_actual);
2974
2975 if (TREE_CODE (gnu_actual) != SAVE_EXPR)
2976 gnu_actual = convert (gnu_formal_type, gnu_actual);
2977
2978 /* If we have not saved a GCC object for the formal, it means it
2979 is an OUT parameter not passed by reference and that does not
2980 need to be copied in. Otherwise, look at the PARM_DECL to see
2981 if it is passed by reference. */
2982 if (present_gnu_tree (gnat_formal)
2983 && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
2984 && DECL_BY_REF_P (get_gnu_tree (gnat_formal)))
2985 {
2986 if (Ekind (gnat_formal) != E_In_Parameter)
2987 {
2988 gnu_actual = gnu_name;
2989
2990 /* If we have a padded type, be sure we've removed the
2991 padding. */
2992 if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
2993 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual))
2994 && TREE_CODE (gnu_actual) != SAVE_EXPR)
2995 gnu_actual
2996 = convert (get_unpadded_type (Etype (gnat_actual)),
2997 gnu_actual);
2998 }
2999
3000 /* The symmetry of the paths to the type of an entity is
3001 broken here since arguments don't know that they will
3002 be passed by ref. */
3003 gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
3004 gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type,
3005 gnu_actual);
3006 }
3007 else if (present_gnu_tree (gnat_formal)
3008 && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
3009 && DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal)))
3010 {
3011 gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
3012 gnu_actual = maybe_implicit_deref (gnu_actual);
3013 gnu_actual = maybe_unconstrained_array (gnu_actual);
3014
3015 if (TREE_CODE (gnu_formal_type) == RECORD_TYPE
3016 && TYPE_IS_PADDING_P (gnu_formal_type))
3017 {
3018 gnu_formal_type
3019 = TREE_TYPE (TYPE_FIELDS (gnu_formal_type));
3020 gnu_actual = convert (gnu_formal_type, gnu_actual);
3021 }
3022
3023 /* Take the address of the object and convert to the
3024 proper pointer type. We'd like to actually compute
3025 the address of the beginning of the array using
3026 an ADDR_EXPR of an ARRAY_REF, but there's a possibility
3027 that the ARRAY_REF might return a constant and we'd
3028 be getting the wrong address. Neither approach is
3029 exactly correct, but this is the most likely to work
3030 in all cases. */
3031 gnu_actual = convert (gnu_formal_type,
3032 build_unary_op (ADDR_EXPR, NULL_TREE,
3033 gnu_actual));
3034 }
3035 else if (present_gnu_tree (gnat_formal)
3036 && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
3037 && DECL_BY_DESCRIPTOR_P (get_gnu_tree (gnat_formal)))
3038 {
3039 /* If arg is 'Null_Parameter, pass zero descriptor. */
3040 if ((TREE_CODE (gnu_actual) == INDIRECT_REF
3041 || TREE_CODE (gnu_actual) == UNCONSTRAINED_ARRAY_REF)
3042 && TREE_PRIVATE (gnu_actual))
3043 gnu_actual
3044 = convert (DECL_ARG_TYPE (get_gnu_tree (gnat_formal)),
3045 integer_zero_node);
3046 else
3047 gnu_actual
3048 = build_unary_op (ADDR_EXPR, NULL_TREE,
3049 fill_vms_descriptor (gnu_actual,
3050 gnat_formal));
3051 }
3052 else
3053 {
3054 tree gnu_actual_size = TYPE_SIZE (TREE_TYPE (gnu_actual));
3055
3056 if (Ekind (gnat_formal) != E_In_Parameter)
3057 gnu_name_list
3058 = chainon (gnu_name_list,
3059 build_tree_list (NULL_TREE, gnu_name));
3060
3061 if (! present_gnu_tree (gnat_formal)
3062 || TREE_CODE (get_gnu_tree (gnat_formal)) != PARM_DECL)
3063 continue;
3064
3065 /* If this is 'Null_Parameter, pass a zero even though we are
3066 dereferencing it. */
3067 else if (TREE_CODE (gnu_actual) == INDIRECT_REF
3068 && TREE_PRIVATE (gnu_actual)
3069 && host_integerp (gnu_actual_size, 1)
3070 && 0 >= compare_tree_int (gnu_actual_size,
3071 BITS_PER_WORD))
3072 gnu_actual
3073 = unchecked_convert
3074 (DECL_ARG_TYPE (get_gnu_tree (gnat_formal)),
3075 convert (gnat_type_for_size
3076 (tree_low_cst (gnu_actual_size, 1), 1),
3077 integer_zero_node), 0);
3078 else
3079 gnu_actual
3080 = convert (TYPE_MAIN_VARIANT
3081 (DECL_ARG_TYPE (get_gnu_tree (gnat_formal))),
3082 gnu_actual);
3083 }
3084
3085 gnu_actual_list
3086 = chainon (gnu_actual_list,
3087 build_tree_list (NULL_TREE, gnu_actual));
3088 }
3089
3090 gnu_subprog_call = build (CALL_EXPR, TREE_TYPE (gnu_subprog_type),
3091 gnu_subprog_addr, gnu_actual_list,
3092 NULL_TREE);
3093 TREE_SIDE_EFFECTS (gnu_subprog_call) = 1;
3094
3095 /* If it is a function call, the result is the call expression. */
3096 if (Nkind (gnat_node) == N_Function_Call)
3097 {
3098 gnu_result = gnu_subprog_call;
3099
3100 /* If the function returns an unconstrained array or by reference,
3101 we have to de-dereference the pointer. */
3102 if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type)
3103 || TYPE_RETURNS_BY_REF_P (gnu_subprog_type))
3104 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE,
3105 gnu_result);
3106
3107 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3108 }
3109
3110 /* If this is the case where the GNAT tree contains a procedure call
3111 but the Ada procedure has copy in copy out parameters, the special
3112 parameter passing mechanism must be used. */
3113 else if (TYPE_CI_CO_LIST (gnu_subprog_type) != NULL_TREE)
3114 {
3115 /* List of FIELD_DECLs associated with the PARM_DECLs of the copy
3116 in copy out parameters. */
3117 tree scalar_return_list = TYPE_CI_CO_LIST (gnu_subprog_type);
3118 int length = list_length (scalar_return_list);
3119
3120 if (length > 1)
3121 {
3122 tree gnu_name;
3123
3124 gnu_subprog_call = protect_multiple_eval (gnu_subprog_call);
3125
3126 /* If any of the names had side-effects, ensure they are
3127 all evaluated before the call. */
3128 for (gnu_name = gnu_name_list; gnu_name;
3129 gnu_name = TREE_CHAIN (gnu_name))
3130 if (TREE_SIDE_EFFECTS (TREE_VALUE (gnu_name)))
3131 gnu_subprog_call
3132 = build (COMPOUND_EXPR, TREE_TYPE (gnu_subprog_call),
3133 TREE_VALUE (gnu_name), gnu_subprog_call);
3134 }
3135
3136 if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
3137 gnat_formal = First_Formal (Etype (Name (gnat_node)));
3138 else
3139 gnat_formal = First_Formal (Entity (Name (gnat_node)));
3140
3141 for (gnat_actual = First_Actual (gnat_node);
3142 Present (gnat_actual);
3143 gnat_formal = Next_Formal_With_Extras (gnat_formal),
3144 gnat_actual = Next_Actual (gnat_actual))
3145 /* If we are dealing with a copy in copy out parameter, we must
3146 retrieve its value from the record returned in the function
3147 call. */
3148 if (! (present_gnu_tree (gnat_formal)
3149 && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
3150 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
3151 || ((TREE_CODE (get_gnu_tree (gnat_formal))
3152 == PARM_DECL)
3153 && ((DECL_BY_COMPONENT_PTR_P
3154 (get_gnu_tree (gnat_formal))
3155 || (DECL_BY_DESCRIPTOR_P
3156 (get_gnu_tree (gnat_formal))))))))
3157 && Ekind (gnat_formal) != E_In_Parameter)
3158 {
3159 /* Get the value to assign to this OUT or IN OUT
3160 parameter. It is either the result of the function if
3161 there is only a single such parameter or the appropriate
3162 field from the record returned. */
3163 tree gnu_result
3164 = length == 1 ? gnu_subprog_call
3165 : build_component_ref
3166 (gnu_subprog_call, NULL_TREE,
3167 TREE_PURPOSE (scalar_return_list), 0);
3168 int unchecked_conversion
3169 = Nkind (gnat_actual) == N_Unchecked_Type_Conversion;
3170 /* If the actual is a conversion, get the inner expression,
3171 which will be the real destination, and convert the
3172 result to the type of the actual parameter. */
3173 tree gnu_actual
3174 = maybe_unconstrained_array (TREE_VALUE (gnu_name_list));
3175
3176 /* If the result is a padded type, remove the padding. */
3177 if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
3178 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
3179 gnu_result
3180 = convert (TREE_TYPE (TYPE_FIELDS
3181 (TREE_TYPE (gnu_result))),
3182 gnu_result);
3183
3184 /* If the result is a type conversion, do it. */
3185 if (Nkind (gnat_actual) == N_Type_Conversion)
3186 gnu_result
3187 = convert_with_check
3188 (Etype (Expression (gnat_actual)), gnu_result,
3189 Do_Overflow_Check (gnat_actual),
3190 Do_Range_Check (Expression (gnat_actual)),
3191 Float_Truncate (gnat_actual));
3192
3193 else if (unchecked_conversion)
3194 gnu_result
3195 = unchecked_convert (TREE_TYPE (gnu_actual), gnu_result,
3196 No_Truncation (gnat_actual));
3197 else
3198 {
3199 if (Do_Range_Check (gnat_actual))
3200 gnu_result = emit_range_check (gnu_result,
3201 Etype (gnat_actual));
3202
3203 if (! (! TREE_CONSTANT (TYPE_SIZE
3204 (TREE_TYPE (gnu_actual)))
3205 && TREE_CONSTANT (TYPE_SIZE
3206 (TREE_TYPE (gnu_result)))))
3207 gnu_result = convert (TREE_TYPE (gnu_actual),
3208 gnu_result);
3209 }
3210
3211 set_lineno (gnat_node, 1);
3212 expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE,
3213 gnu_actual, gnu_result));
3214 scalar_return_list = TREE_CHAIN (scalar_return_list);
3215 gnu_name_list = TREE_CHAIN (gnu_name_list);
3216 }
3217 }
3218 else
3219 {
3220 set_lineno (gnat_node, 1);
3221 expand_expr_stmt (gnu_subprog_call);
3222 }
3223
3224 /* Handle anything we need to assign back. */
3225 for (gnu_expr = gnu_after_list;
3226 gnu_expr;
3227 gnu_expr = TREE_CHAIN (gnu_expr))
3228 expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE,
3229 TREE_PURPOSE (gnu_expr),
3230 TREE_VALUE (gnu_expr)));
3231 }
3232 break;
3233
3234 /*************************/
3235 /* Chapter 7: Packages: */
3236 /*************************/
3237
3238 case N_Package_Declaration:
3239 gnat_to_code (Specification (gnat_node));
3240 break;
3241
3242 case N_Package_Specification:
3243
3244 process_decls (Visible_Declarations (gnat_node),
3245 Private_Declarations (gnat_node), Empty, 1, 1);
3246 break;
3247
3248 case N_Package_Body:
3249
3250 /* If this is the body of a generic package - do nothing */
3251 if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package)
3252 break;
3253
3254 process_decls (Declarations (gnat_node), Empty, Empty, 1, 1);
3255
3256 if (Present (Handled_Statement_Sequence (gnat_node)))
3257 {
3258 gnu_block_stack = tree_cons (NULL_TREE, NULL_TREE, gnu_block_stack);
3259 gnat_to_code (Handled_Statement_Sequence (gnat_node));
3260 gnu_block_stack = TREE_CHAIN (gnu_block_stack);
3261 }
3262 break;
3263
3264 /*********************************/
3265 /* Chapter 8: Visibility Rules: */
3266 /*********************************/
3267
3268 case N_Use_Package_Clause:
3269 case N_Use_Type_Clause:
3270 /* Nothing to do here - but these may appear in list of declarations */
3271 break;
3272
3273 /***********************/
3274 /* Chapter 9: Tasks: */
3275 /***********************/
3276
3277 case N_Protected_Type_Declaration:
3278 break;
3279
3280 case N_Single_Task_Declaration:
3281 gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
3282 break;
3283
3284 /***********************************************************/
3285 /* Chapter 10: Program Structure and Compilation Issues: */
3286 /***********************************************************/
3287
3288 case N_Compilation_Unit:
3289
3290 /* For a body, first process the spec if there is one. */
3291 if (Nkind (Unit (gnat_node)) == N_Package_Body
3292 || (Nkind (Unit (gnat_node)) == N_Subprogram_Body
3293 && ! Acts_As_Spec (gnat_node)))
3294 gnat_to_code (Library_Unit (gnat_node));
3295
3296 process_inlined_subprograms (gnat_node);
3297
3298 if (type_annotate_only && gnat_node == Cunit (Main_Unit))
3299 {
3300 elaborate_all_entities (gnat_node);
3301
3302 if (Nkind (Unit (gnat_node)) == N_Subprogram_Declaration
3303 || Nkind (Unit (gnat_node)) == N_Generic_Package_Declaration
3304 || Nkind (Unit (gnat_node)) == N_Generic_Subprogram_Declaration)
3305 break;
3306 };
3307
3308 process_decls (Declarations (Aux_Decls_Node (gnat_node)),
3309 Empty, Empty, 1, 1);
3310
3311 gnat_to_code (Unit (gnat_node));
3312
3313 /* Process any pragmas following the unit. */
3314 if (Present (Pragmas_After (Aux_Decls_Node (gnat_node))))
3315 for (gnat_temp = First (Pragmas_After (Aux_Decls_Node (gnat_node)));
3316 gnat_temp; gnat_temp = Next (gnat_temp))
3317 gnat_to_code (gnat_temp);
3318
3319 /* Put all the Actions into the elaboration routine if we already had
3320 elaborations. This will happen anyway if they are statements, but we
3321 want to force declarations there too due to order-of-elaboration
3322 issues. Most should have Is_Statically_Allocated set. If we
3323 have had no elaborations, we have no order-of-elaboration issue and
3324 don't want to create elaborations here. */
3325 if (Is_Non_Empty_List (Actions (Aux_Decls_Node (gnat_node))))
3326 for (gnat_temp = First (Actions (Aux_Decls_Node (gnat_node)));
3327 Present (gnat_temp); gnat_temp = Next (gnat_temp))
3328 {
3329 if (pending_elaborations_p ())
3330 add_pending_elaborations (NULL_TREE,
3331 make_transform_expr (gnat_temp));
3332 else
3333 gnat_to_code (gnat_temp);
3334 }
3335
3336 /* Generate elaboration code for this unit, if necessary, and
3337 say whether we did or not. */
3338 Set_Has_No_Elaboration_Code
3339 (gnat_node,
3340 build_unit_elab
3341 (Defining_Entity (Unit (gnat_node)),
3342 Nkind (Unit (gnat_node)) == N_Package_Body
3343 || Nkind (Unit (gnat_node)) == N_Subprogram_Body,
3344 get_pending_elaborations ()));
3345
3346 break;
3347
3348 case N_Subprogram_Body_Stub:
3349 case N_Package_Body_Stub:
3350 case N_Protected_Body_Stub:
3351 case N_Task_Body_Stub:
3352 /* Simply process whatever unit is being inserted. */
3353 gnat_to_code (Unit (Library_Unit (gnat_node)));
3354 break;
3355
3356 case N_Subunit:
3357 gnat_to_code (Proper_Body (gnat_node));
3358 break;
3359
3360 /***************************/
3361 /* Chapter 11: Exceptions: */
3362 /***************************/
3363
3364 case N_Handled_Sequence_Of_Statements:
3365
3366 /* The GCC exception handling mechanism can handle both ZCX and SJLJ
3367 schemes and we have our own SJLJ mechanism. To call the GCC
3368 mechanism, we first call expand_eh_region_start if there is at least
3369 one handler associated with the region. We then generate code for
3370 the region and call expand_start_all_catch to announce that the
3371 associated handlers are going to be generated.
3372
3373 For each handler we call expand_start_catch, generate code for the
3374 handler, and then call expand_end_catch.
3375
3376 After all the handlers, we call expand_end_all_catch.
3377
3378 Here we deal with the region level calls and the
3379 N_Exception_Handler branch deals with the handler level calls
3380 (start_catch/end_catch).
3381
3382 ??? The region level calls down there have been specifically put in
3383 place for a ZCX context and currently the order in which things are
3384 emitted (region/handlers) is different from the SJLJ case. Instead of
3385 putting other calls with different conditions at other places for the
3386 SJLJ case, it seems cleaner to reorder things for the SJLJ case and
3387 generalize the condition to make it not ZCX specific. */
3388
3389 /* If there is an At_End procedure attached to this node, and the eh
3390 mechanism is GNAT oriented (SJLJ or ZCX with front end tables), we
3391 must have at least a corresponding At_End handler, unless the
3392 No_Exception_Handlers restriction is set. */
3393 if (! type_annotate_only
3394 && Exception_Mechanism != GCC_ZCX
3395 && Present (At_End_Proc (gnat_node))
3396 && ! Present (Exception_Handlers (gnat_node))
3397 && ! No_Exception_Handlers_Set())
3398 gigi_abort (335);
3399
3400 {
3401 /* Need a binding level that we can exit for this sequence if there is
3402 at least one exception handler for this block (since each handler
3403 needs an identified exit point) or there is an At_End procedure
3404 attached to this node (in order to have an attachment point for a
3405 GCC cleanup). */
3406 bool exitable_binding_for_block
3407 = (! type_annotate_only
3408 && (Present (Exception_Handlers (gnat_node))
3409 || Present (At_End_Proc (gnat_node))));
3410
3411 /* Make a binding level that we can exit if we need one. */
3412 if (exitable_binding_for_block)
3413 {
3414 pushlevel (0);
3415 expand_start_bindings (1);
3416 }
3417
3418 /* If we are to call a function when exiting this block, expand a GCC
3419 cleanup to take care. We have made a binding level for this cleanup
3420 above. */
3421 if (Present (At_End_Proc (gnat_node)))
3422 {
3423 tree gnu_cleanup_call
3424 = build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node)));
3425
3426 tree gnu_cleanup_decl
3427 = create_var_decl (get_identifier ("CLEANUP"), NULL_TREE,
3428 integer_type_node, NULL_TREE, 0, 0, 0, 0,
3429 0);
3430
3431 expand_decl_cleanup (gnu_cleanup_decl, gnu_cleanup_call);
3432 }
3433
3434 /* Now we generate the code for this block, with a different layout
3435 for GNAT SJLJ and for GCC or front end ZCX. The handlers come first
3436 in the GNAT SJLJ case, while they come after the handled sequence
3437 in the other cases. */
3438
3439 /* First deal with possible handlers for the GNAT SJLJ scheme. */
3440 if (! type_annotate_only
3441 && Exception_Mechanism == Setjmp_Longjmp
3442 && Present (Exception_Handlers (gnat_node)))
3443 {
3444 /* We already have a fresh binding level at hand. Declare a
3445 variable to save the old __gnat_jmpbuf value and a variable for
3446 our jmpbuf. Call setjmp and handle each of the possible
3447 exceptions if it returns one. */
3448
3449 tree gnu_jmpsave_decl
3450 = create_var_decl (get_identifier ("JMPBUF_SAVE"), NULL_TREE,
3451 jmpbuf_ptr_type,
3452 build_call_0_expr (get_jmpbuf_decl),
3453 0, 0, 0, 0, 0);
3454
3455 tree gnu_jmpbuf_decl
3456 = create_var_decl (get_identifier ("JMP_BUF"),
3457 NULL_TREE, jmpbuf_type,
3458 NULL_TREE, 0, 0, 0, 0,
3459 0);
3460
3461 TREE_VALUE (gnu_block_stack) = gnu_jmpbuf_decl;
3462
3463 /* When we exit this block, restore the saved value. */
3464 expand_decl_cleanup (gnu_jmpsave_decl,
3465 build_call_1_expr (set_jmpbuf_decl,
3466 gnu_jmpsave_decl));
3467
3468 /* Call setjmp and handle exceptions if it returns one. */
3469 set_lineno (gnat_node, 1);
3470 expand_start_cond
3471 (build_call_1_expr (setjmp_decl,
3472 build_unary_op (ADDR_EXPR, NULL_TREE,
3473 gnu_jmpbuf_decl)),
3474 0);
3475
3476 /* Restore our incoming longjmp value before we do anything. */
3477 expand_expr_stmt
3478 (build_call_1_expr (set_jmpbuf_decl, gnu_jmpsave_decl));
3479
3480 /* Make a binding level for the exception handling declarations
3481 and code. Don't assign it an exit label, since this is the
3482 outer block we want to exit at the end of each handler. */
3483 pushlevel (0);
3484 expand_start_bindings (0);
3485
3486 gnu_except_ptr_stack
3487 = tree_cons (NULL_TREE,
3488 create_var_decl
3489 (get_identifier ("EXCEPT_PTR"), NULL_TREE,
3490 build_pointer_type (except_type_node),
3491 build_call_0_expr (get_excptr_decl),
3492 0, 0, 0, 0, 0),
3493 gnu_except_ptr_stack);
3494
3495 /* Generate code for each handler. The N_Exception_Handler case
3496 below does the real work. We ignore the dummy exception handler
3497 for the identifier case, as this is used only by the front
3498 end. */
3499 for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
3500 Present (gnat_temp);
3501 gnat_temp = Next_Non_Pragma (gnat_temp))
3502 gnat_to_code (gnat_temp);
3503
3504 /* If none of the exception handlers did anything, re-raise
3505 but do not defer abortion. */
3506 set_lineno (gnat_node, 1);
3507 expand_expr_stmt
3508 (build_call_1_expr (raise_nodefer_decl,
3509 TREE_VALUE (gnu_except_ptr_stack)));
3510
3511 gnu_except_ptr_stack = TREE_CHAIN (gnu_except_ptr_stack);
3512
3513 /* End the binding level dedicated to the exception handlers. */
3514 expand_end_bindings (getdecls (), kept_level_p (), -1);
3515 poplevel (kept_level_p (), 1, 0);
3516
3517 /* End the "if" on setjmp. Note that we have arranged things so
3518 control never returns here. */
3519 expand_end_cond ();
3520
3521 /* This is now immediately before the body proper. Set our jmp_buf
3522 as the current buffer. */
3523 expand_expr_stmt
3524 (build_call_1_expr (set_jmpbuf_decl,
3525 build_unary_op (ADDR_EXPR, NULL_TREE,
3526 gnu_jmpbuf_decl)));
3527 }
3528
3529 /* Now comes the processing for the sequence body. */
3530
3531 /* If we use the back-end eh support, tell the back-end we are
3532 starting a new exception region. */
3533 if (! type_annotate_only
3534 && Exception_Mechanism == GCC_ZCX
3535 && Present (Exception_Handlers (gnat_node)))
3536 expand_eh_region_start ();
3537
3538 /* Generate code and declarations for the prefix of this block,
3539 if any. */
3540 if (Present (First_Real_Statement (gnat_node)))
3541 process_decls (Statements (gnat_node), Empty,
3542 First_Real_Statement (gnat_node), 1, 1);
3543
3544 /* Generate code for each statement in the block. */
3545 for (gnat_temp = (Present (First_Real_Statement (gnat_node))
3546 ? First_Real_Statement (gnat_node)
3547 : First (Statements (gnat_node)));
3548 Present (gnat_temp);
3549 gnat_temp = Next (gnat_temp))
3550 gnat_to_code (gnat_temp);
3551
3552 /* Exit the binding level we made, if any. */
3553 if (exitable_binding_for_block)
3554 expand_exit_something ();
3555
3556 /* Compile the handlers for front end ZCX or back-end supported
3557 exceptions. */
3558 if (! type_annotate_only
3559 && Exception_Mechanism != Setjmp_Longjmp
3560 && Present (Exception_Handlers (gnat_node)))
3561 {
3562 if (Exception_Mechanism == GCC_ZCX)
3563 expand_start_all_catch ();
3564
3565 for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
3566 Present (gnat_temp);
3567 gnat_temp = Next_Non_Pragma (gnat_temp))
3568 gnat_to_code (gnat_temp);
3569
3570 if (Exception_Mechanism == GCC_ZCX)
3571 expand_end_all_catch ();
3572 }
3573
3574 /* Close the binding level we made, if any. */
3575 if (exitable_binding_for_block)
3576 {
3577 expand_end_bindings (getdecls (), kept_level_p (), -1);
3578 poplevel (kept_level_p (), 1, 0);
3579 }
3580 }
3581
3582 break;
3583
3584 case N_Exception_Handler:
3585 if (Exception_Mechanism == Setjmp_Longjmp)
3586 {
3587 /* Unless this is "Others" or the special "Non-Ada" exception
3588 for Ada, make an "if" statement to select the proper
3589 exceptions. For "Others", exclude exceptions where
3590 Handled_By_Others is nonzero unless the All_Others flag is set.
3591 For "Non-ada", accept an exception if "Lang" is 'V'. */
3592 tree gnu_choice = integer_zero_node;
3593
3594 for (gnat_temp = First (Exception_Choices (gnat_node));
3595 gnat_temp; gnat_temp = Next (gnat_temp))
3596 {
3597 tree this_choice;
3598
3599 if (Nkind (gnat_temp) == N_Others_Choice)
3600 {
3601 if (All_Others (gnat_temp))
3602 this_choice = integer_one_node;
3603 else
3604 this_choice
3605 = build_binary_op
3606 (EQ_EXPR, integer_type_node,
3607 convert
3608 (integer_type_node,
3609 build_component_ref
3610 (build_unary_op
3611 (INDIRECT_REF, NULL_TREE,
3612 TREE_VALUE (gnu_except_ptr_stack)),
3613 get_identifier ("not_handled_by_others"), NULL_TREE,
3614 0)),
3615 integer_zero_node);
3616 }
3617
3618 else if (Nkind (gnat_temp) == N_Identifier
3619 || Nkind (gnat_temp) == N_Expanded_Name)
3620 {
3621 Entity_Id gnat_ex_id = Entity (gnat_temp);
3622
3623 /* Exception may be a renaming. Recover original exception
3624 which is the one elaborated and registered. */
3625 if (Present (Renamed_Object (gnat_ex_id)))
3626 gnat_ex_id = Renamed_Object (gnat_ex_id);
3627
3628 /* ??? Note that we have to use gnat_to_gnu_entity here
3629 since the type of the exception will be wrong in the
3630 VMS case and that's exactly what this test is for. */
3631 gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
3632
3633 /* If this was a VMS exception, check import_code
3634 against the value of the exception. */
3635 if (TREE_CODE (TREE_TYPE (gnu_expr)) == INTEGER_TYPE)
3636 this_choice
3637 = build_binary_op
3638 (EQ_EXPR, integer_type_node,
3639 build_component_ref
3640 (build_unary_op
3641 (INDIRECT_REF, NULL_TREE,
3642 TREE_VALUE (gnu_except_ptr_stack)),
3643 get_identifier ("import_code"), NULL_TREE, 0),
3644 gnu_expr);
3645 else
3646 this_choice
3647 = build_binary_op
3648 (EQ_EXPR, integer_type_node,
3649 TREE_VALUE (gnu_except_ptr_stack),
3650 convert
3651 (TREE_TYPE (TREE_VALUE (gnu_except_ptr_stack)),
3652 build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr)));
3653
3654 /* If this is the distinguished exception "Non_Ada_Error"
3655 (and we are in VMS mode), also allow a non-Ada
3656 exception (a VMS condition) to match. */
3657 if (Is_Non_Ada_Error (Entity (gnat_temp)))
3658 {
3659 tree gnu_comp
3660 = build_component_ref
3661 (build_unary_op
3662 (INDIRECT_REF, NULL_TREE,
3663 TREE_VALUE (gnu_except_ptr_stack)),
3664 get_identifier ("lang"), NULL_TREE, 0);
3665
3666 this_choice
3667 = build_binary_op
3668 (TRUTH_ORIF_EXPR, integer_type_node,
3669 build_binary_op
3670 (EQ_EXPR, integer_type_node, gnu_comp,
3671 convert (TREE_TYPE (gnu_comp),
3672 build_int_2 ('V', 0))),
3673 this_choice);
3674 }
3675 }
3676 else
3677 gigi_abort (318);
3678
3679 gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
3680 gnu_choice, this_choice);
3681 }
3682
3683 set_lineno (gnat_node, 1);
3684
3685 expand_start_cond (gnu_choice, 0);
3686 }
3687
3688 /* Tell the back end that we start an exception handler if necessary. */
3689 if (Exception_Mechanism == GCC_ZCX)
3690 {
3691 /* We build a TREE_LIST of nodes representing what exception
3692 types this handler is able to catch, with special cases
3693 for others and all others cases.
3694
3695 Each exception type is actually identified by a pointer to the
3696 exception id, with special value zero for "others" and one for
3697 "all others". Beware that these special values are known and used
3698 by the personality routine to identify the corresponding specific
3699 kinds of handlers.
3700
3701 ??? For initial time frame reasons, the others and all_others
3702 cases have been handled using specific type trees, but this
3703 somehow hides information to the back-end, which expects NULL to
3704 be passed for catch all and end_cleanup to be used for cleanups.
3705
3706 Care should be taken to ensure that the control flow impact of
3707 such clauses is rendered in some way. lang_eh_type_covers is
3708 doing the trick currently. */
3709
3710 tree gnu_expr, gnu_etype;
3711 tree gnu_etypes_list = NULL_TREE;
3712
3713 for (gnat_temp = First (Exception_Choices (gnat_node));
3714 gnat_temp; gnat_temp = Next (gnat_temp))
3715 {
3716 if (Nkind (gnat_temp) == N_Others_Choice)
3717 gnu_etype
3718 = All_Others (gnat_temp) ? integer_one_node
3719 : integer_zero_node;
3720 else if (Nkind (gnat_temp) == N_Identifier
3721 || Nkind (gnat_temp) == N_Expanded_Name)
3722 {
3723 Entity_Id gnat_ex_id = Entity (gnat_temp);
3724
3725 /* Exception may be a renaming. Recover original exception
3726 which is the one elaborated and registered. */
3727 if (Present (Renamed_Object (gnat_ex_id)))
3728 gnat_ex_id = Renamed_Object (gnat_ex_id);
3729
3730 gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
3731
3732 gnu_etype
3733 = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
3734 }
3735 else
3736 gigi_abort (337);
3737
3738 /* The GCC interface expects NULL to be passed for catch all
3739 handlers, so it would be quite tempting to set gnu_etypes_list
3740 to NULL if gnu_etype is integer_zero_node. It would not work,
3741 however, because GCC's notion of "catch all" is stronger than
3742 our notion of "others". Until we correctly use the cleanup
3743 interface as well, the doing tht would prevent the "all
3744 others" handlers from beeing seen, because nothing can be
3745 caught beyond a catch all from GCC's point of view. */
3746 gnu_etypes_list
3747 = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list);
3748
3749 }
3750
3751 expand_start_catch (gnu_etypes_list);
3752
3753 pushlevel (0);
3754 expand_start_bindings (0);
3755
3756 {
3757 /* Expand a call to the begin_handler hook at the beginning of the
3758 handler, and arrange for a call to the end_handler hook to
3759 occur on every possible exit path.
3760
3761 The hooks expect a pointer to the low level occurrence. This
3762 is required for our stack management scheme because a raise
3763 inside the handler pushes a new occurrence on top of the
3764 stack, which means that this top does not necessarily match
3765 the occurrence this handler was dealing with.
3766
3767 The EXC_PTR_EXPR object references the exception occurrence
3768 beeing propagated. Upon handler entry, this is the exception
3769 for which the handler is triggered. This might not be the case
3770 upon handler exit, however, as we might have a new occurrence
3771 propagated by the handler's body, and the end_handler hook
3772 called as a cleanup in this context.
3773
3774 We use a local variable to retrieve the incoming value at
3775 handler entry time, and reuse it to feed the end_handler
3776 hook's argument at exit time. */
3777 tree gnu_current_exc_ptr
3778 = build (EXC_PTR_EXPR, ptr_type_node);
3779 tree gnu_incoming_exc_ptr
3780 = create_var_decl (get_identifier ("EXPTR"), NULL_TREE,
3781 ptr_type_node, gnu_current_exc_ptr,
3782 0, 0, 0, 0, 0);
3783
3784 expand_expr_stmt
3785 (build_call_1_expr (begin_handler_decl, gnu_incoming_exc_ptr));
3786 expand_decl_cleanup
3787 (0, build_call_1_expr (end_handler_decl, gnu_incoming_exc_ptr));
3788 }
3789 }
3790
3791 for (gnat_temp = First (Statements (gnat_node));
3792 gnat_temp; gnat_temp = Next (gnat_temp))
3793 gnat_to_code (gnat_temp);
3794
3795 if (Exception_Mechanism == GCC_ZCX)
3796 {
3797 /* Tell the back end that we're done with the current handler. */
3798 expand_end_bindings (getdecls (), kept_level_p (), -1);
3799 poplevel (kept_level_p (), 1, 0);
3800
3801 expand_end_catch ();
3802 }
3803 else
3804 /* At the end of the handler, exit the block. We made this block in
3805 N_Handled_Sequence_Of_Statements. */
3806 expand_exit_something ();
3807
3808 if (Exception_Mechanism == Setjmp_Longjmp)
3809 expand_end_cond ();
3810
3811 break;
3812
3813 /*******************************/
3814 /* Chapter 12: Generic Units: */
3815 /*******************************/
3816
3817 case N_Generic_Function_Renaming_Declaration:
3818 case N_Generic_Package_Renaming_Declaration:
3819 case N_Generic_Procedure_Renaming_Declaration:
3820 case N_Generic_Package_Declaration:
3821 case N_Generic_Subprogram_Declaration:
3822 case N_Package_Instantiation:
3823 case N_Procedure_Instantiation:
3824 case N_Function_Instantiation:
3825 /* These nodes can appear on a declaration list but there is nothing to
3826 to be done with them. */
3827 break;
3828
3829 /***************************************************/
3830 /* Chapter 13: Representation Clauses and */
3831 /* Implementation-Dependent Features: */
3832 /***************************************************/
3833
3834 case N_Attribute_Definition_Clause:
3835
3836 /* The only one we need deal with is for 'Address. For the others, SEM
3837 puts the information elsewhere. We need only deal with 'Address
3838 if the object has a Freeze_Node (which it never will currently). */
3839 if (Get_Attribute_Id (Chars (gnat_node)) != Attr_Address
3840 || No (Freeze_Node (Entity (Name (gnat_node)))))
3841 break;
3842
3843 /* Get the value to use as the address and save it as the
3844 equivalent for GNAT_TEMP. When the object is frozen,
3845 gnat_to_gnu_entity will do the right thing. */
3846 gnu_expr = gnat_to_gnu (Expression (gnat_node));
3847 save_gnu_tree (Entity (Name (gnat_node)), gnu_expr, 1);
3848 break;
3849
3850 case N_Enumeration_Representation_Clause:
3851 case N_Record_Representation_Clause:
3852 case N_At_Clause:
3853 /* We do nothing with these. SEM puts the information elsewhere. */
3854 break;
3855
3856 case N_Code_Statement:
3857 if (! type_annotate_only)
3858 {
3859 tree gnu_template = gnat_to_gnu (Asm_Template (gnat_node));
3860 tree gnu_input_list = 0, gnu_output_list = 0, gnu_orig_out_list = 0;
3861 tree gnu_clobber_list = 0;
3862 char *clobber;
3863
3864 /* First process inputs, then outputs, then clobbers. */
3865 Setup_Asm_Inputs (gnat_node);
3866 while (Present (gnat_temp = Asm_Input_Value ()))
3867 {
3868 tree gnu_value = gnat_to_gnu (gnat_temp);
3869 tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
3870 (Asm_Input_Constraint ()));
3871
3872 gnu_input_list
3873 = tree_cons (gnu_constr, gnu_value, gnu_input_list);
3874 Next_Asm_Input ();
3875 }
3876
3877 Setup_Asm_Outputs (gnat_node);
3878 while (Present (gnat_temp = Asm_Output_Variable ()))
3879 {
3880 tree gnu_value = gnat_to_gnu (gnat_temp);
3881 tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
3882 (Asm_Output_Constraint ()));
3883
3884 gnu_orig_out_list
3885 = tree_cons (gnu_constr, gnu_value, gnu_orig_out_list);
3886 gnu_output_list
3887 = tree_cons (gnu_constr, gnu_value, gnu_output_list);
3888 Next_Asm_Output ();
3889 }
3890
3891 Clobber_Setup (gnat_node);
3892 while ((clobber = Clobber_Get_Next ()) != 0)
3893 gnu_clobber_list
3894 = tree_cons (NULL_TREE,
3895 build_string (strlen (clobber) + 1, clobber),
3896 gnu_clobber_list);
3897
3898 gnu_input_list = nreverse (gnu_input_list);
3899 gnu_output_list = nreverse (gnu_output_list);
3900 gnu_orig_out_list = nreverse (gnu_orig_out_list);
3901 expand_asm_operands (gnu_template, gnu_output_list, gnu_input_list,
3902 gnu_clobber_list, Is_Asm_Volatile (gnat_node),
3903 input_location);
3904
3905 /* Copy all the intermediate outputs into the specified outputs. */
3906 for (; gnu_output_list;
3907 (gnu_output_list = TREE_CHAIN (gnu_output_list),
3908 gnu_orig_out_list = TREE_CHAIN (gnu_orig_out_list)))
3909 if (TREE_VALUE (gnu_orig_out_list) != TREE_VALUE (gnu_output_list))
3910 {
3911 expand_expr_stmt
3912 (build_binary_op (MODIFY_EXPR, NULL_TREE,
3913 TREE_VALUE (gnu_orig_out_list),
3914 TREE_VALUE (gnu_output_list)));
3915 free_temp_slots ();
3916 }
3917 }
3918 break;
3919
3920 /***************************************************/
3921 /* Added Nodes */
3922 /***************************************************/
3923
3924 case N_Freeze_Entity:
3925 process_freeze_entity (gnat_node);
3926 process_decls (Actions (gnat_node), Empty, Empty, 1, 1);
3927 break;
3928
3929 case N_Itype_Reference:
3930 if (! present_gnu_tree (Itype (gnat_node)))
3931 process_type (Itype (gnat_node));
3932 break;
3933
3934 case N_Free_Statement:
3935 if (! type_annotate_only)
3936 {
3937 tree gnu_ptr = gnat_to_gnu (Expression (gnat_node));
3938 tree gnu_obj_type;
3939 tree gnu_obj_size;
3940 int align;
3941
3942 /* If this is a thin pointer, we must dereference it to create
3943 a fat pointer, then go back below to a thin pointer. The
3944 reason for this is that we need a fat pointer someplace in
3945 order to properly compute the size. */
3946 if (TYPE_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
3947 gnu_ptr = build_unary_op (ADDR_EXPR, NULL_TREE,
3948 build_unary_op (INDIRECT_REF, NULL_TREE,
3949 gnu_ptr));
3950
3951 /* If this is an unconstrained array, we know the object must
3952 have been allocated with the template in front of the object.
3953 So pass the template address, but get the total size. Do this
3954 by converting to a thin pointer. */
3955 if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
3956 gnu_ptr
3957 = convert (build_pointer_type
3958 (TYPE_OBJECT_RECORD_TYPE
3959 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
3960 gnu_ptr);
3961
3962 gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
3963 gnu_obj_size = TYPE_SIZE_UNIT (gnu_obj_type);
3964 align = TYPE_ALIGN (gnu_obj_type);
3965
3966 if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
3967 && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
3968 {
3969 tree gnu_char_ptr_type = build_pointer_type (char_type_node);
3970 tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
3971 tree gnu_byte_offset
3972 = convert (gnu_char_ptr_type,
3973 size_diffop (size_zero_node, gnu_pos));
3974
3975 gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
3976 gnu_ptr = build_binary_op (MINUS_EXPR, gnu_char_ptr_type,
3977 gnu_ptr, gnu_byte_offset);
3978 }
3979
3980 set_lineno (gnat_node, 1);
3981 expand_expr_stmt
3982 (build_call_alloc_dealloc (gnu_ptr, gnu_obj_size, align,
3983 Procedure_To_Call (gnat_node),
3984 Storage_Pool (gnat_node), gnat_node));
3985 }
3986 break;
3987
3988 case N_Raise_Constraint_Error:
3989 case N_Raise_Program_Error:
3990 case N_Raise_Storage_Error:
3991
3992 if (type_annotate_only)
3993 break;
3994
3995 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3996 gnu_result = build_call_raise (UI_To_Int (Reason (gnat_node)));
3997
3998 /* If the type is VOID, this is a statement, so we need to
3999 generate the code for the call. Handle a Condition, if there
4000 is one. */
4001 if (TREE_CODE (gnu_result_type) == VOID_TYPE)
4002 {
4003 set_lineno (gnat_node, 1);
4004
4005 if (Present (Condition (gnat_node)))
4006 expand_start_cond (gnat_to_gnu (Condition (gnat_node)), 0);
4007
4008 expand_expr_stmt (gnu_result);
4009 if (Present (Condition (gnat_node)))
4010 expand_end_cond ();
4011 gnu_result = error_mark_node;
4012 }
4013 else
4014 gnu_result = build1 (NULL_EXPR, gnu_result_type, gnu_result);
4015 break;
4016
4017 /* Nothing to do, since front end does all validation using the
4018 values that Gigi back-annotates. */
4019 case N_Validate_Unchecked_Conversion:
4020 break;
4021
4022 case N_Raise_Statement:
4023 case N_Function_Specification:
4024 case N_Procedure_Specification:
4025 case N_Op_Concat:
4026 case N_Component_Association:
4027 case N_Task_Body:
4028 default:
4029 if (! type_annotate_only)
4030 gigi_abort (321);
4031 }
4032
4033 /* If the result is a statement, set needed flags and return it. */
4034 if (IS_STMT (gnu_result))
4035 {
4036 TREE_TYPE (gnu_result) = void_type_node;
4037 TREE_THIS_VOLATILE (gnu_result) = TREE_SIDE_EFFECTS (gnu_result) = 1;
4038 TREE_SLOC (gnu_result) = Sloc (gnat_node);
4039 return gnu_result;
4040 }
4041
4042 /* If the result is a constant that overflows, raise constraint error. */
4043 else if (TREE_CODE (gnu_result) == INTEGER_CST
4044 && TREE_CONSTANT_OVERFLOW (gnu_result))
4045 {
4046 post_error ("Constraint_Error will be raised at run-time?", gnat_node);
4047
4048 gnu_result
4049 = build1 (NULL_EXPR, gnu_result_type,
4050 build_call_raise (CE_Overflow_Check_Failed));
4051 }
4052
4053 /* If our result has side-effects and is of an unconstrained type,
4054 make a SAVE_EXPR so that we can be sure it will only be referenced
4055 once. Note we must do this before any conversions. */
4056 if (TREE_SIDE_EFFECTS (gnu_result)
4057 && (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE
4058 || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))))
4059 gnu_result = gnat_stabilize_reference (gnu_result, 0);
4060
4061 /* Now convert the result to the proper type. If the type is void or if
4062 we have no result, return error_mark_node to show we have no result.
4063 If the type of the result is correct or if we have a label (which doesn't
4064 have any well-defined type), return our result. Also don't do the
4065 conversion if the "desired" type involves a PLACEHOLDER_EXPR in its size
4066 since those are the cases where the front end may have the type wrong due
4067 to "instantiating" the unconstrained record with discriminant values
4068 or if this is a FIELD_DECL. If this is the Name of an assignment
4069 statement or a parameter of a procedure call, return what we have since
4070 the RHS has to be converted to our type there in that case, unless
4071 GNU_RESULT_TYPE has a simpler size. Similarly, if the two types are
4072 record types with the same name, the expression type has integral mode,
4073 and GNU_RESULT_TYPE BLKmode, don't convert. This will be the case when
4074 we are converting from a packable type to its actual type and we need
4075 those conversions to be NOPs in order for assignments into these types to
4076 work properly if the inner object is a bitfield and hence can't have
4077 its address taken. Finally, don't convert integral types that are the
4078 operand of an unchecked conversion since we need to ignore those
4079 conversions (for 'Valid). Otherwise, convert the result to the proper
4080 type. */
4081
4082 if (Present (Parent (gnat_node))
4083 && ((Nkind (Parent (gnat_node)) == N_Assignment_Statement
4084 && Name (Parent (gnat_node)) == gnat_node)
4085 || (Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement
4086 && Name (Parent (gnat_node)) != gnat_node)
4087 || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
4088 && ! AGGREGATE_TYPE_P (gnu_result_type)
4089 && ! AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))
4090 || Nkind (Parent (gnat_node)) == N_Parameter_Association)
4091 && ! (TYPE_SIZE (gnu_result_type) != 0
4092 && TYPE_SIZE (TREE_TYPE (gnu_result)) != 0
4093 && (AGGREGATE_TYPE_P (gnu_result_type)
4094 == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))
4095 && ((TREE_CODE (TYPE_SIZE (gnu_result_type)) == INTEGER_CST
4096 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result)))
4097 != INTEGER_CST))
4098 || (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
4099 && ! CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))
4100 && (CONTAINS_PLACEHOLDER_P
4101 (TYPE_SIZE (TREE_TYPE (gnu_result))))))
4102 && ! (TREE_CODE (gnu_result_type) == RECORD_TYPE
4103 && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_result_type))))
4104 {
4105 /* In this case remove padding only if the inner object is of
4106 self-referential size: in that case it must be an object of
4107 unconstrained type with a default discriminant. In other cases,
4108 we want to avoid copying too much data. */
4109 if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
4110 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))
4111 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE
4112 (TREE_TYPE (TYPE_FIELDS
4113 (TREE_TYPE (gnu_result))))))
4114 gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
4115 gnu_result);
4116 }
4117
4118 else if (TREE_CODE (gnu_result) == LABEL_DECL
4119 || TREE_CODE (gnu_result) == FIELD_DECL
4120 || TREE_CODE (gnu_result) == ERROR_MARK
4121 || (TYPE_SIZE (gnu_result_type) != 0
4122 && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
4123 && TREE_CODE (gnu_result) != INDIRECT_REF
4124 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type)))
4125 || ((TYPE_NAME (gnu_result_type)
4126 == TYPE_NAME (TREE_TYPE (gnu_result)))
4127 && TREE_CODE (gnu_result_type) == RECORD_TYPE
4128 && TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
4129 && TYPE_MODE (gnu_result_type) == BLKmode
4130 && (GET_MODE_CLASS (TYPE_MODE (TREE_TYPE (gnu_result)))
4131 == MODE_INT)))
4132 {
4133 /* Remove any padding record, but do nothing more in this case. */
4134 if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
4135 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
4136 gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
4137 gnu_result);
4138 }
4139
4140 else if (gnu_result == error_mark_node
4141 || gnu_result_type == void_type_node)
4142 gnu_result = error_mark_node;
4143 else if (gnu_result_type != TREE_TYPE (gnu_result))
4144 gnu_result = convert (gnu_result_type, gnu_result);
4145
4146 /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on GNU_RESULT. */
4147 while ((TREE_CODE (gnu_result) == NOP_EXPR
4148 || TREE_CODE (gnu_result) == NON_LVALUE_EXPR)
4149 && TREE_TYPE (TREE_OPERAND (gnu_result, 0)) == TREE_TYPE (gnu_result))
4150 gnu_result = TREE_OPERAND (gnu_result, 0);
4151
4152 return gnu_result;
4153 }
4154
4155 /* GNU_STMT is a statement. We generate code for that statement. */
4156
4157 void
gnat_expand_stmt(tree gnu_stmt)4158 gnat_expand_stmt (tree gnu_stmt)
4159 {
4160 set_lineno_from_sloc (TREE_SLOC (gnu_stmt), 1);
4161
4162 switch (TREE_CODE (gnu_stmt))
4163 {
4164 case EXPR_STMT:
4165 expand_expr_stmt (EXPR_STMT_EXPR (gnu_stmt));
4166 break;
4167
4168 default:
4169 abort ();
4170 }
4171 }
4172
4173 /* Force references to each of the entities in packages GNAT_NODE with's
4174 so that the debugging information for all of them are identical
4175 in all clients. Operate recursively on anything it with's, but check
4176 that we aren't elaborating something more than once. */
4177
4178 /* The reason for this routine's existence is two-fold.
4179 First, with some debugging formats, notably MDEBUG on SGI
4180 IRIX, the linker will remove duplicate debugging information if two
4181 clients have identical debugguing information. With the normal scheme
4182 of elaboration, this does not usually occur, since entities in with'ed
4183 packages are elaborated on demand, and if clients have different usage
4184 patterns, the normal case, then the order and selection of entities
4185 will differ. In most cases however, it seems that linkers do not know
4186 how to eliminate duplicate debugging information, even if it is
4187 identical, so the use of this routine would increase the total amount
4188 of debugging information in the final executable.
4189
4190 Second, this routine is called in type_annotate mode, to compute DDA
4191 information for types in withed units, for ASIS use */
4192
4193 static void
elaborate_all_entities(Node_Id gnat_node)4194 elaborate_all_entities (Node_Id gnat_node)
4195 {
4196 Entity_Id gnat_with_clause, gnat_entity;
4197
4198 /* Process each unit only once. As we trace the context of all relevant
4199 units transitively, including generic bodies, we may encounter the
4200 same generic unit repeatedly */
4201
4202 if (!present_gnu_tree (gnat_node))
4203 save_gnu_tree (gnat_node, integer_zero_node, 1);
4204
4205 /* Save entities in all context units. A body may have an implicit_with
4206 on its own spec, if the context includes a child unit, so don't save
4207 the spec twice. */
4208
4209 for (gnat_with_clause = First (Context_Items (gnat_node));
4210 Present (gnat_with_clause);
4211 gnat_with_clause = Next (gnat_with_clause))
4212 if (Nkind (gnat_with_clause) == N_With_Clause
4213 && ! present_gnu_tree (Library_Unit (gnat_with_clause))
4214 && Library_Unit (gnat_with_clause) != Library_Unit (Cunit (Main_Unit)))
4215 {
4216 elaborate_all_entities (Library_Unit (gnat_with_clause));
4217
4218 if (Ekind (Entity (Name (gnat_with_clause))) == E_Package)
4219 {
4220 for (gnat_entity = First_Entity (Entity (Name (gnat_with_clause)));
4221 Present (gnat_entity);
4222 gnat_entity = Next_Entity (gnat_entity))
4223 if (Is_Public (gnat_entity)
4224 && Convention (gnat_entity) != Convention_Intrinsic
4225 && Ekind (gnat_entity) != E_Package
4226 && Ekind (gnat_entity) != E_Package_Body
4227 && Ekind (gnat_entity) != E_Operator
4228 && ! (IN (Ekind (gnat_entity), Type_Kind)
4229 && ! Is_Frozen (gnat_entity))
4230 && ! ((Ekind (gnat_entity) == E_Procedure
4231 || Ekind (gnat_entity) == E_Function)
4232 && Is_Intrinsic_Subprogram (gnat_entity))
4233 && ! IN (Ekind (gnat_entity), Named_Kind)
4234 && ! IN (Ekind (gnat_entity), Generic_Unit_Kind))
4235 gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
4236 }
4237 else if (Ekind (Entity (Name (gnat_with_clause))) == E_Generic_Package)
4238 {
4239 Node_Id gnat_body
4240 = Corresponding_Body (Unit (Library_Unit (gnat_with_clause)));
4241
4242 /* Retrieve compilation unit node of generic body. */
4243 while (Present (gnat_body)
4244 && Nkind (gnat_body) != N_Compilation_Unit)
4245 gnat_body = Parent (gnat_body);
4246
4247 /* If body is available, elaborate its context. */
4248 if (Present (gnat_body))
4249 elaborate_all_entities (gnat_body);
4250 }
4251 }
4252
4253 if (Nkind (Unit (gnat_node)) == N_Package_Body && type_annotate_only)
4254 elaborate_all_entities (Library_Unit (gnat_node));
4255 }
4256
4257 /* Do the processing of N_Freeze_Entity, GNAT_NODE. */
4258
4259 static void
process_freeze_entity(Node_Id gnat_node)4260 process_freeze_entity (Node_Id gnat_node)
4261 {
4262 Entity_Id gnat_entity = Entity (gnat_node);
4263 tree gnu_old;
4264 tree gnu_new;
4265 tree gnu_init
4266 = (Nkind (Declaration_Node (gnat_entity)) == N_Object_Declaration
4267 && present_gnu_tree (Declaration_Node (gnat_entity)))
4268 ? get_gnu_tree (Declaration_Node (gnat_entity)) : NULL_TREE;
4269
4270 /* If this is a package, need to generate code for the package. */
4271 if (Ekind (gnat_entity) == E_Package)
4272 {
4273 insert_code_for
4274 (Parent (Corresponding_Body
4275 (Parent (Declaration_Node (gnat_entity)))));
4276 return;
4277 }
4278
4279 /* Check for old definition after the above call. This Freeze_Node
4280 might be for one its Itypes. */
4281 gnu_old
4282 = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
4283
4284 /* If this entity has an Address representation clause, GNU_OLD is the
4285 address, so discard it here. */
4286 if (Present (Address_Clause (gnat_entity)))
4287 gnu_old = 0;
4288
4289 /* Don't do anything for class-wide types they are always
4290 transformed into their root type. */
4291 if (Ekind (gnat_entity) == E_Class_Wide_Type
4292 || (Ekind (gnat_entity) == E_Class_Wide_Subtype
4293 && Present (Equivalent_Type (gnat_entity))))
4294 return;
4295
4296 /* Don't do anything for subprograms that may have been elaborated before
4297 their freeze nodes. This can happen, for example because of an inner call
4298 in an instance body. */
4299 if (gnu_old != 0
4300 && TREE_CODE (gnu_old) == FUNCTION_DECL
4301 && (Ekind (gnat_entity) == E_Function
4302 || Ekind (gnat_entity) == E_Procedure))
4303 return;
4304
4305 /* If we have a non-dummy type old tree, we have nothing to do. Unless
4306 this is the public view of a private type whose full view was not
4307 delayed, this node was never delayed as it should have been.
4308 Also allow this to happen for concurrent types since we may have
4309 frozen both the Corresponding_Record_Type and this type. */
4310 if (gnu_old != 0
4311 && ! (TREE_CODE (gnu_old) == TYPE_DECL
4312 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))))
4313 {
4314 if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
4315 && Present (Full_View (gnat_entity))
4316 && No (Freeze_Node (Full_View (gnat_entity))))
4317 return;
4318 else if (Is_Concurrent_Type (gnat_entity))
4319 return;
4320 else
4321 gigi_abort (320);
4322 }
4323
4324 /* Reset the saved tree, if any, and elaborate the object or type for real.
4325 If there is a full declaration, elaborate it and copy the type to
4326 GNAT_ENTITY. Likewise if this is the record subtype corresponding to
4327 a class wide type or subtype. */
4328 if (gnu_old != 0)
4329 {
4330 save_gnu_tree (gnat_entity, NULL_TREE, 0);
4331 if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
4332 && Present (Full_View (gnat_entity))
4333 && present_gnu_tree (Full_View (gnat_entity)))
4334 save_gnu_tree (Full_View (gnat_entity), NULL_TREE, 0);
4335 if (Present (Class_Wide_Type (gnat_entity))
4336 && Class_Wide_Type (gnat_entity) != gnat_entity)
4337 save_gnu_tree (Class_Wide_Type (gnat_entity), NULL_TREE, 0);
4338 }
4339
4340 if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
4341 && Present (Full_View (gnat_entity)))
4342 {
4343 gnu_new = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 1);
4344
4345 /* The above call may have defined this entity (the simplest example
4346 of this is when we have a private enumeral type since the bounds
4347 will have the public view. */
4348 if (! present_gnu_tree (gnat_entity))
4349 save_gnu_tree (gnat_entity, gnu_new, 0);
4350 if (Present (Class_Wide_Type (gnat_entity))
4351 && Class_Wide_Type (gnat_entity) != gnat_entity)
4352 save_gnu_tree (Class_Wide_Type (gnat_entity), gnu_new, 0);
4353 }
4354 else
4355 gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, 1);
4356
4357 /* If we've made any pointers to the old version of this type, we
4358 have to update them. */
4359 if (gnu_old != 0)
4360 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
4361 TREE_TYPE (gnu_new));
4362 }
4363
4364 /* Process the list of inlined subprograms of GNAT_NODE, which is an
4365 N_Compilation_Unit. */
4366
4367 static void
process_inlined_subprograms(Node_Id gnat_node)4368 process_inlined_subprograms (Node_Id gnat_node)
4369 {
4370 Entity_Id gnat_entity;
4371 Node_Id gnat_body;
4372
4373 /* If we can inline, generate RTL for all the inlined subprograms.
4374 Define the entity first so we set DECL_EXTERNAL. */
4375 if (optimize > 0 && ! flag_no_inline)
4376 for (gnat_entity = First_Inlined_Subprogram (gnat_node);
4377 Present (gnat_entity);
4378 gnat_entity = Next_Inlined_Subprogram (gnat_entity))
4379 {
4380 gnat_body = Parent (Declaration_Node (gnat_entity));
4381
4382 if (Nkind (gnat_body) != N_Subprogram_Body)
4383 {
4384 /* ??? This really should always be Present. */
4385 if (No (Corresponding_Body (gnat_body)))
4386 continue;
4387
4388 gnat_body
4389 = Parent (Declaration_Node (Corresponding_Body (gnat_body)));
4390 }
4391
4392 if (Present (gnat_body))
4393 {
4394 gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
4395 gnat_to_code (gnat_body);
4396 }
4397 }
4398 }
4399
4400 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
4401 We make two passes, one to elaborate anything other than bodies (but
4402 we declare a function if there was no spec). The second pass
4403 elaborates the bodies.
4404
4405 GNAT_END_LIST gives the element in the list past the end. Normally,
4406 this is Empty, but can be First_Real_Statement for a
4407 Handled_Sequence_Of_Statements.
4408
4409 We make a complete pass through both lists if PASS1P is true, then make
4410 the second pass over both lists if PASS2P is true. The lists usually
4411 correspond to the public and private parts of a package. */
4412
4413 static void
process_decls(List_Id gnat_decls,List_Id gnat_decls2,Node_Id gnat_end_list,int pass1p,int pass2p)4414 process_decls (List_Id gnat_decls,
4415 List_Id gnat_decls2,
4416 Node_Id gnat_end_list,
4417 int pass1p,
4418 int pass2p)
4419 {
4420 List_Id gnat_decl_array[2];
4421 Node_Id gnat_decl;
4422 int i;
4423
4424 gnat_decl_array[0] = gnat_decls, gnat_decl_array[1] = gnat_decls2;
4425
4426 if (pass1p)
4427 for (i = 0; i <= 1; i++)
4428 if (Present (gnat_decl_array[i]))
4429 for (gnat_decl = First (gnat_decl_array[i]);
4430 gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
4431 {
4432 set_lineno (gnat_decl, 0);
4433
4434 /* For package specs, we recurse inside the declarations,
4435 thus taking the two pass approach inside the boundary. */
4436 if (Nkind (gnat_decl) == N_Package_Declaration
4437 && (Nkind (Specification (gnat_decl)
4438 == N_Package_Specification)))
4439 process_decls (Visible_Declarations (Specification (gnat_decl)),
4440 Private_Declarations (Specification (gnat_decl)),
4441 Empty, 1, 0);
4442
4443 /* Similarly for any declarations in the actions of a
4444 freeze node. */
4445 else if (Nkind (gnat_decl) == N_Freeze_Entity)
4446 {
4447 process_freeze_entity (gnat_decl);
4448 process_decls (Actions (gnat_decl), Empty, Empty, 1, 0);
4449 }
4450
4451 /* Package bodies with freeze nodes get their elaboration deferred
4452 until the freeze node, but the code must be placed in the right
4453 place, so record the code position now. */
4454 else if (Nkind (gnat_decl) == N_Package_Body
4455 && Present (Freeze_Node (Corresponding_Spec (gnat_decl))))
4456 record_code_position (gnat_decl);
4457
4458 else if (Nkind (gnat_decl) == N_Package_Body_Stub
4459 && Present (Library_Unit (gnat_decl))
4460 && Present (Freeze_Node
4461 (Corresponding_Spec
4462 (Proper_Body (Unit
4463 (Library_Unit (gnat_decl)))))))
4464 record_code_position
4465 (Proper_Body (Unit (Library_Unit (gnat_decl))));
4466
4467 /* We defer most subprogram bodies to the second pass. */
4468 else if (Nkind (gnat_decl) == N_Subprogram_Body)
4469 {
4470 if (Acts_As_Spec (gnat_decl))
4471 {
4472 Node_Id gnat_subprog_id = Defining_Entity (gnat_decl);
4473
4474 if (Ekind (gnat_subprog_id) != E_Generic_Procedure
4475 && Ekind (gnat_subprog_id) != E_Generic_Function)
4476 gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
4477 }
4478 }
4479 /* For bodies and stubs that act as their own specs, the entity
4480 itself must be elaborated in the first pass, because it may
4481 be used in other declarations. */
4482 else if (Nkind (gnat_decl) == N_Subprogram_Body_Stub)
4483 {
4484 Node_Id gnat_subprog_id =
4485 Defining_Entity (Specification (gnat_decl));
4486
4487 if (Ekind (gnat_subprog_id) != E_Subprogram_Body
4488 && Ekind (gnat_subprog_id) != E_Generic_Procedure
4489 && Ekind (gnat_subprog_id) != E_Generic_Function)
4490 gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
4491 }
4492
4493 /* Concurrent stubs stand for the corresponding subprogram bodies,
4494 which are deferred like other bodies. */
4495 else if (Nkind (gnat_decl) == N_Task_Body_Stub
4496 || Nkind (gnat_decl) == N_Protected_Body_Stub)
4497 ;
4498
4499 else
4500 gnat_to_code (gnat_decl);
4501 }
4502
4503 /* Here we elaborate everything we deferred above except for package bodies,
4504 which are elaborated at their freeze nodes. Note that we must also
4505 go inside things (package specs and freeze nodes) the first pass did. */
4506 if (pass2p)
4507 for (i = 0; i <= 1; i++)
4508 if (Present (gnat_decl_array[i]))
4509 for (gnat_decl = First (gnat_decl_array[i]);
4510 gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
4511 {
4512 if (Nkind (gnat_decl) == N_Subprogram_Body
4513 || Nkind (gnat_decl) == N_Subprogram_Body_Stub
4514 || Nkind (gnat_decl) == N_Task_Body_Stub
4515 || Nkind (gnat_decl) == N_Protected_Body_Stub)
4516 gnat_to_code (gnat_decl);
4517
4518 else if (Nkind (gnat_decl) == N_Package_Declaration
4519 && (Nkind (Specification (gnat_decl)
4520 == N_Package_Specification)))
4521 process_decls (Visible_Declarations (Specification (gnat_decl)),
4522 Private_Declarations (Specification (gnat_decl)),
4523 Empty, 0, 1);
4524
4525 else if (Nkind (gnat_decl) == N_Freeze_Entity)
4526 process_decls (Actions (gnat_decl), Empty, Empty, 0, 1);
4527 }
4528 }
4529
4530 /* Emit code for a range check. GNU_EXPR is the expression to be checked,
4531 GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
4532 which we have to check. */
4533
4534 static tree
emit_range_check(tree gnu_expr,Entity_Id gnat_range_type)4535 emit_range_check (tree gnu_expr, Entity_Id gnat_range_type)
4536 {
4537 tree gnu_range_type = get_unpadded_type (gnat_range_type);
4538 tree gnu_low = TYPE_MIN_VALUE (gnu_range_type);
4539 tree gnu_high = TYPE_MAX_VALUE (gnu_range_type);
4540 tree gnu_compare_type = get_base_type (TREE_TYPE (gnu_expr));
4541
4542 /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE,
4543 we can't do anything since we might be truncating the bounds. No
4544 check is needed in this case. */
4545 if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr))
4546 && (TYPE_PRECISION (gnu_compare_type)
4547 < TYPE_PRECISION (get_base_type (gnu_range_type))))
4548 return gnu_expr;
4549
4550 /* Checked expressions must be evaluated only once. */
4551 gnu_expr = protect_multiple_eval (gnu_expr);
4552
4553 /* There's no good type to use here, so we might as well use
4554 integer_type_node. Note that the form of the check is
4555 (not (expr >= lo)) or (not (expr >= hi))
4556 the reason for this slightly convoluted form is that NaN's
4557 are not considered to be in range in the float case. */
4558 return emit_check
4559 (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
4560 invert_truthvalue
4561 (build_binary_op (GE_EXPR, integer_type_node,
4562 convert (gnu_compare_type, gnu_expr),
4563 convert (gnu_compare_type, gnu_low))),
4564 invert_truthvalue
4565 (build_binary_op (LE_EXPR, integer_type_node,
4566 convert (gnu_compare_type, gnu_expr),
4567 convert (gnu_compare_type,
4568 gnu_high)))),
4569 gnu_expr, CE_Range_Check_Failed);
4570 }
4571
4572 /* Emit code for an index check. GNU_ARRAY_OBJECT is the array object
4573 which we are about to index, GNU_EXPR is the index expression to be
4574 checked, GNU_LOW and GNU_HIGH are the lower and upper bounds
4575 against which GNU_EXPR has to be checked. Note that for index
4576 checking we cannot use the emit_range_check function (although very
4577 similar code needs to be generated in both cases) since for index
4578 checking the array type against which we are checking the indeces
4579 may be unconstrained and consequently we need to retrieve the
4580 actual index bounds from the array object itself
4581 (GNU_ARRAY_OBJECT). The place where we need to do that is in
4582 subprograms having unconstrained array formal parameters */
4583
4584 static tree
emit_index_check(tree gnu_array_object,tree gnu_expr,tree gnu_low,tree gnu_high)4585 emit_index_check (tree gnu_array_object,
4586 tree gnu_expr,
4587 tree gnu_low,
4588 tree gnu_high)
4589 {
4590 tree gnu_expr_check;
4591
4592 /* Checked expressions must be evaluated only once. */
4593 gnu_expr = protect_multiple_eval (gnu_expr);
4594
4595 /* Must do this computation in the base type in case the expression's
4596 type is an unsigned subtypes. */
4597 gnu_expr_check = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
4598
4599 /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by
4600 the object we are handling. */
4601 if (CONTAINS_PLACEHOLDER_P (gnu_low))
4602 gnu_low = build (WITH_RECORD_EXPR, TREE_TYPE (gnu_low),
4603 gnu_low, gnu_array_object);
4604
4605 if (CONTAINS_PLACEHOLDER_P (gnu_high))
4606 gnu_high = build (WITH_RECORD_EXPR, TREE_TYPE (gnu_high),
4607 gnu_high, gnu_array_object);
4608
4609 /* There's no good type to use here, so we might as well use
4610 integer_type_node. */
4611 return emit_check
4612 (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
4613 build_binary_op (LT_EXPR, integer_type_node,
4614 gnu_expr_check,
4615 convert (TREE_TYPE (gnu_expr_check),
4616 gnu_low)),
4617 build_binary_op (GT_EXPR, integer_type_node,
4618 gnu_expr_check,
4619 convert (TREE_TYPE (gnu_expr_check),
4620 gnu_high))),
4621 gnu_expr, CE_Index_Check_Failed);
4622 }
4623
4624 /* Given GNU_COND which contains the condition corresponding to an access,
4625 discriminant or range check, of value GNU_EXPR, build a COND_EXPR
4626 that returns GNU_EXPR if GNU_COND is false and raises a
4627 CONSTRAINT_ERROR if GNU_COND is true. REASON is the code that says
4628 why the exception was raised. */
4629
4630 static tree
emit_check(tree gnu_cond,tree gnu_expr,int reason)4631 emit_check (tree gnu_cond, tree gnu_expr, int reason)
4632 {
4633 tree gnu_call;
4634 tree gnu_result;
4635
4636 gnu_call = build_call_raise (reason);
4637
4638 /* Use an outer COMPOUND_EXPR to make sure that GNU_EXPR will get evaluated
4639 in front of the comparison in case it ends up being a SAVE_EXPR. Put the
4640 whole thing inside its own SAVE_EXPR so the inner SAVE_EXPR doesn't leak
4641 out. */
4642 gnu_result = fold (build (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond,
4643 build (COMPOUND_EXPR, TREE_TYPE (gnu_expr),
4644 gnu_call, gnu_expr),
4645 gnu_expr));
4646
4647 /* If GNU_EXPR has side effects, make the outer COMPOUND_EXPR and
4648 protect it. Otherwise, show GNU_RESULT has no side effects: we
4649 don't need to evaluate it just for the check. */
4650 if (TREE_SIDE_EFFECTS (gnu_expr))
4651 gnu_result
4652 = build (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_expr, gnu_result);
4653 else
4654 TREE_SIDE_EFFECTS (gnu_result) = 0;
4655
4656 /* ??? Unfortunately, if we don't put a SAVE_EXPR around this whole thing,
4657 we will repeatedly do the test. It would be nice if GCC was able
4658 to optimize this and only do it once. */
4659 return save_expr (gnu_result);
4660 }
4661
4662 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing
4663 overflow checks if OVERFLOW_P is nonzero and range checks if
4664 RANGE_P is nonzero. GNAT_TYPE is known to be an integral type.
4665 If TRUNCATE_P is nonzero, do a float to integer conversion with
4666 truncation; otherwise round. */
4667
4668 static tree
convert_with_check(Entity_Id gnat_type,tree gnu_expr,int overflow_p,int range_p,int truncate_p)4669 convert_with_check (Entity_Id gnat_type,
4670 tree gnu_expr,
4671 int overflow_p,
4672 int range_p,
4673 int truncate_p)
4674 {
4675 tree gnu_type = get_unpadded_type (gnat_type);
4676 tree gnu_in_type = TREE_TYPE (gnu_expr);
4677 tree gnu_in_basetype = get_base_type (gnu_in_type);
4678 tree gnu_base_type = get_base_type (gnu_type);
4679 tree gnu_ada_base_type = get_ada_base_type (gnu_type);
4680 tree gnu_in_lb = TYPE_MIN_VALUE (gnu_in_basetype);
4681 tree gnu_in_ub = TYPE_MAX_VALUE (gnu_in_basetype);
4682 tree gnu_out_lb = TYPE_MIN_VALUE (gnu_base_type);
4683 tree gnu_out_ub = TYPE_MAX_VALUE (gnu_base_type);
4684 tree gnu_result = gnu_expr;
4685
4686 /* If we are not doing any checks, the output is an integral type, and
4687 the input is not a floating type, just do the conversion. This
4688 shortcut is required to avoid problems with packed array types
4689 and simplifies code in all cases anyway. */
4690 if (! range_p && ! overflow_p && INTEGRAL_TYPE_P (gnu_base_type)
4691 && ! FLOAT_TYPE_P (gnu_in_type))
4692 return convert (gnu_type, gnu_expr);
4693
4694 /* First convert the expression to its base type. This
4695 will never generate code, but makes the tests below much simpler.
4696 But don't do this if converting from an integer type to an unconstrained
4697 array type since then we need to get the bounds from the original
4698 (unpacked) type. */
4699 if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE)
4700 gnu_result = convert (gnu_in_basetype, gnu_result);
4701
4702 /* If overflow checks are requested, we need to be sure the result will
4703 fit in the output base type. But don't do this if the input
4704 is integer and the output floating-point. */
4705 if (overflow_p
4706 && ! (FLOAT_TYPE_P (gnu_base_type) && INTEGRAL_TYPE_P (gnu_in_basetype)))
4707 {
4708 /* Ensure GNU_EXPR only gets evaluated once. */
4709 tree gnu_input = protect_multiple_eval (gnu_result);
4710 tree gnu_cond = integer_zero_node;
4711
4712 /* Convert the lower bounds to signed types, so we're sure we're
4713 comparing them properly. Likewise, convert the upper bounds
4714 to unsigned types. */
4715 if (INTEGRAL_TYPE_P (gnu_in_basetype) && TREE_UNSIGNED (gnu_in_basetype))
4716 gnu_in_lb = convert (gnat_signed_type (gnu_in_basetype), gnu_in_lb);
4717
4718 if (INTEGRAL_TYPE_P (gnu_in_basetype)
4719 && ! TREE_UNSIGNED (gnu_in_basetype))
4720 gnu_in_ub = convert (gnat_unsigned_type (gnu_in_basetype), gnu_in_ub);
4721
4722 if (INTEGRAL_TYPE_P (gnu_base_type) && TREE_UNSIGNED (gnu_base_type))
4723 gnu_out_lb = convert (gnat_signed_type (gnu_base_type), gnu_out_lb);
4724
4725 if (INTEGRAL_TYPE_P (gnu_base_type) && ! TREE_UNSIGNED (gnu_base_type))
4726 gnu_out_ub = convert (gnat_unsigned_type (gnu_base_type), gnu_out_ub);
4727
4728 /* Check each bound separately and only if the result bound
4729 is tighter than the bound on the input type. Note that all the
4730 types are base types, so the bounds must be constant. Also,
4731 the comparison is done in the base type of the input, which
4732 always has the proper signedness. First check for input
4733 integer (which means output integer), output float (which means
4734 both float), or mixed, in which case we always compare.
4735 Note that we have to do the comparison which would *fail* in the
4736 case of an error since if it's an FP comparison and one of the
4737 values is a NaN or Inf, the comparison will fail. */
4738 if (INTEGRAL_TYPE_P (gnu_in_basetype)
4739 ? tree_int_cst_lt (gnu_in_lb, gnu_out_lb)
4740 : (FLOAT_TYPE_P (gnu_base_type)
4741 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_in_lb),
4742 TREE_REAL_CST (gnu_out_lb))
4743 : 1))
4744 gnu_cond
4745 = invert_truthvalue
4746 (build_binary_op (GE_EXPR, integer_type_node,
4747 gnu_input, convert (gnu_in_basetype,
4748 gnu_out_lb)));
4749
4750 if (INTEGRAL_TYPE_P (gnu_in_basetype)
4751 ? tree_int_cst_lt (gnu_out_ub, gnu_in_ub)
4752 : (FLOAT_TYPE_P (gnu_base_type)
4753 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_out_ub),
4754 TREE_REAL_CST (gnu_in_lb))
4755 : 1))
4756 gnu_cond
4757 = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, gnu_cond,
4758 invert_truthvalue
4759 (build_binary_op (LE_EXPR, integer_type_node,
4760 gnu_input,
4761 convert (gnu_in_basetype,
4762 gnu_out_ub))));
4763
4764 if (! integer_zerop (gnu_cond))
4765 gnu_result = emit_check (gnu_cond, gnu_input,
4766 CE_Overflow_Check_Failed);
4767 }
4768
4769 /* Now convert to the result base type. If this is a non-truncating
4770 float-to-integer conversion, round. */
4771 if (INTEGRAL_TYPE_P (gnu_ada_base_type) && FLOAT_TYPE_P (gnu_in_basetype)
4772 && ! truncate_p)
4773 {
4774 tree gnu_point_5 = build_real (gnu_in_basetype, dconstp5);
4775 tree gnu_minus_point_5 = build_real (gnu_in_basetype, dconstmp5);
4776 tree gnu_zero = convert (gnu_in_basetype, integer_zero_node);
4777 tree gnu_saved_result = save_expr (gnu_result);
4778 tree gnu_comp = build (GE_EXPR, integer_type_node,
4779 gnu_saved_result, gnu_zero);
4780 tree gnu_adjust = build (COND_EXPR, gnu_in_basetype, gnu_comp,
4781 gnu_point_5, gnu_minus_point_5);
4782
4783 gnu_result
4784 = build (PLUS_EXPR, gnu_in_basetype, gnu_saved_result, gnu_adjust);
4785 }
4786
4787 if (TREE_CODE (gnu_ada_base_type) == INTEGER_TYPE
4788 && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_ada_base_type)
4789 && TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
4790 gnu_result = unchecked_convert (gnu_ada_base_type, gnu_result, 0);
4791 else
4792 gnu_result = convert (gnu_ada_base_type, gnu_result);
4793
4794 /* Finally, do the range check if requested. Note that if the
4795 result type is a modular type, the range check is actually
4796 an overflow check. */
4797
4798 if (range_p
4799 || (TREE_CODE (gnu_base_type) == INTEGER_TYPE
4800 && TYPE_MODULAR_P (gnu_base_type) && overflow_p))
4801 gnu_result = emit_range_check (gnu_result, gnat_type);
4802
4803 return convert (gnu_type, gnu_result);
4804 }
4805
4806 /* Return 1 if GNU_EXPR can be directly addressed. This is the case unless
4807 it is an expression involving computation or if it involves a bitfield
4808 reference. This returns the same as gnat_mark_addressable in most
4809 cases. */
4810
4811 static int
addressable_p(tree gnu_expr)4812 addressable_p (tree gnu_expr)
4813 {
4814 switch (TREE_CODE (gnu_expr))
4815 {
4816 case VAR_DECL:
4817 case PARM_DECL:
4818 case FUNCTION_DECL:
4819 case RESULT_DECL:
4820 /* All DECLs are addressable: if they are in a register, we can force
4821 them to memory. */
4822 return 1;
4823
4824 case UNCONSTRAINED_ARRAY_REF:
4825 case INDIRECT_REF:
4826 case CONSTRUCTOR:
4827 case NULL_EXPR:
4828 case SAVE_EXPR:
4829 return 1;
4830
4831 case COMPONENT_REF:
4832 return (! DECL_BIT_FIELD (TREE_OPERAND (gnu_expr, 1))
4833 && (! DECL_NONADDRESSABLE_P (TREE_OPERAND (gnu_expr, 1))
4834 || ! flag_strict_aliasing)
4835 && addressable_p (TREE_OPERAND (gnu_expr, 0)));
4836
4837 case ARRAY_REF: case ARRAY_RANGE_REF:
4838 case REALPART_EXPR: case IMAGPART_EXPR:
4839 case NOP_EXPR:
4840 return addressable_p (TREE_OPERAND (gnu_expr, 0));
4841
4842 case CONVERT_EXPR:
4843 return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr))
4844 && addressable_p (TREE_OPERAND (gnu_expr, 0)));
4845
4846 case VIEW_CONVERT_EXPR:
4847 {
4848 /* This is addressable if we can avoid a copy. */
4849 tree type = TREE_TYPE (gnu_expr);
4850 tree inner_type = TREE_TYPE (TREE_OPERAND (gnu_expr, 0));
4851
4852 return (((TYPE_MODE (type) == TYPE_MODE (inner_type)
4853 && (TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
4854 || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT))
4855 || ((TYPE_MODE (type) == BLKmode
4856 || TYPE_MODE (inner_type) == BLKmode)
4857 && (TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
4858 || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT
4859 || TYPE_ALIGN_OK (type)
4860 || TYPE_ALIGN_OK (inner_type))))
4861 && addressable_p (TREE_OPERAND (gnu_expr, 0)));
4862 }
4863
4864 default:
4865 return 0;
4866 }
4867 }
4868
4869 /* Do the processing for the declaration of a GNAT_ENTITY, a type. If
4870 a separate Freeze node exists, delay the bulk of the processing. Otherwise
4871 make a GCC type for GNAT_ENTITY and set up the correspondance. */
4872
4873 void
process_type(Entity_Id gnat_entity)4874 process_type (Entity_Id gnat_entity)
4875 {
4876 tree gnu_old
4877 = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
4878 tree gnu_new;
4879
4880 /* If we are to delay elaboration of this type, just do any
4881 elaborations needed for expressions within the declaration and
4882 make a dummy type entry for this node and its Full_View (if
4883 any) in case something points to it. Don't do this if it
4884 has already been done (the only way that can happen is if
4885 the private completion is also delayed). */
4886 if (Present (Freeze_Node (gnat_entity))
4887 || (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
4888 && Present (Full_View (gnat_entity))
4889 && Freeze_Node (Full_View (gnat_entity))
4890 && ! present_gnu_tree (Full_View (gnat_entity))))
4891 {
4892 elaborate_entity (gnat_entity);
4893
4894 if (gnu_old == 0)
4895 {
4896 tree gnu_decl = create_type_decl (get_entity_name (gnat_entity),
4897 make_dummy_type (gnat_entity),
4898 0, 0, 0);
4899
4900 save_gnu_tree (gnat_entity, gnu_decl, 0);
4901 if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
4902 && Present (Full_View (gnat_entity)))
4903 save_gnu_tree (Full_View (gnat_entity), gnu_decl, 0);
4904 }
4905
4906 return;
4907 }
4908
4909 /* If we saved away a dummy type for this node it means that this
4910 made the type that corresponds to the full type of an incomplete
4911 type. Clear that type for now and then update the type in the
4912 pointers. */
4913 if (gnu_old != 0)
4914 {
4915 if (TREE_CODE (gnu_old) != TYPE_DECL
4916 || ! TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old)))
4917 {
4918 /* If this was a withed access type, this is not an error
4919 and merely indicates we've already elaborated the type
4920 already. */
4921 if (Is_Type (gnat_entity) && From_With_Type (gnat_entity))
4922 return;
4923
4924 gigi_abort (323);
4925 }
4926
4927 save_gnu_tree (gnat_entity, NULL_TREE, 0);
4928 }
4929
4930 /* Now fully elaborate the type. */
4931 gnu_new = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 1);
4932 if (TREE_CODE (gnu_new) != TYPE_DECL)
4933 gigi_abort (324);
4934
4935 /* If we have an old type and we've made pointers to this type,
4936 update those pointers. */
4937 if (gnu_old != 0)
4938 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
4939 TREE_TYPE (gnu_new));
4940
4941 /* If this is a record type corresponding to a task or protected type
4942 that is a completion of an incomplete type, perform a similar update
4943 on the type. */
4944 /* ??? Including protected types here is a guess. */
4945
4946 if (IN (Ekind (gnat_entity), Record_Kind)
4947 && Is_Concurrent_Record_Type (gnat_entity)
4948 && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity)))
4949 {
4950 tree gnu_task_old
4951 = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity));
4952
4953 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
4954 NULL_TREE, 0);
4955 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
4956 gnu_new, 0);
4957
4958 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old)),
4959 TREE_TYPE (gnu_new));
4960 }
4961 }
4962
4963 /* GNAT_ASSOC is the front of the Component_Associations of an N_Aggregate.
4964 GNU_TYPE is the GCC type of the corresponding record.
4965
4966 Return a CONSTRUCTOR to build the record. */
4967
4968 static tree
assoc_to_constructor(Node_Id gnat_assoc,tree gnu_type)4969 assoc_to_constructor (Node_Id gnat_assoc, tree gnu_type)
4970 {
4971 tree gnu_field, gnu_list, gnu_result;
4972
4973 /* We test for GNU_FIELD being empty in the case where a variant
4974 was the last thing since we don't take things off GNAT_ASSOC in
4975 that case. We check GNAT_ASSOC in case we have a variant, but it
4976 has no fields. */
4977
4978 for (gnu_list = NULL_TREE; Present (gnat_assoc);
4979 gnat_assoc = Next (gnat_assoc))
4980 {
4981 Node_Id gnat_field = First (Choices (gnat_assoc));
4982 tree gnu_field = gnat_to_gnu_entity (Entity (gnat_field), NULL_TREE, 0);
4983 tree gnu_expr = gnat_to_gnu (Expression (gnat_assoc));
4984
4985 /* The expander is supposed to put a single component selector name
4986 in every record component association */
4987 if (Next (gnat_field))
4988 gigi_abort (328);
4989
4990 /* Before assigning a value in an aggregate make sure range checks
4991 are done if required. Then convert to the type of the field. */
4992 if (Do_Range_Check (Expression (gnat_assoc)))
4993 gnu_expr = emit_range_check (gnu_expr, Etype (gnat_field));
4994
4995 gnu_expr = convert (TREE_TYPE (gnu_field), gnu_expr);
4996
4997 /* Add the field and expression to the list. */
4998 gnu_list = tree_cons (gnu_field, gnu_expr, gnu_list);
4999 }
5000
5001 gnu_result = extract_values (gnu_list, gnu_type);
5002
5003 /* Verify every enty in GNU_LIST was used. */
5004 for (gnu_field = gnu_list; gnu_field; gnu_field = TREE_CHAIN (gnu_field))
5005 if (! TREE_ADDRESSABLE (gnu_field))
5006 gigi_abort (311);
5007
5008 return gnu_result;
5009 }
5010
5011 /* Builds a possibly nested constructor for array aggregates. GNAT_EXPR
5012 is the first element of an array aggregate. It may itself be an
5013 aggregate (an array or record aggregate). GNU_ARRAY_TYPE is the gnu type
5014 corresponding to the array aggregate. GNAT_COMPONENT_TYPE is the type
5015 of the array component. It is needed for range checking. */
5016
5017 static tree
pos_to_constructor(Node_Id gnat_expr,tree gnu_array_type,Entity_Id gnat_component_type)5018 pos_to_constructor (Node_Id gnat_expr,
5019 tree gnu_array_type,
5020 Entity_Id gnat_component_type)
5021 {
5022 tree gnu_expr;
5023 tree gnu_expr_list = NULL_TREE;
5024
5025 for ( ; Present (gnat_expr); gnat_expr = Next (gnat_expr))
5026 {
5027 /* If the expression is itself an array aggregate then first build the
5028 innermost constructor if it is part of our array (multi-dimensional
5029 case). */
5030
5031 if (Nkind (gnat_expr) == N_Aggregate
5032 && TREE_CODE (TREE_TYPE (gnu_array_type)) == ARRAY_TYPE
5033 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type)))
5034 gnu_expr = pos_to_constructor (First (Expressions (gnat_expr)),
5035 TREE_TYPE (gnu_array_type),
5036 gnat_component_type);
5037 else
5038 {
5039 gnu_expr = gnat_to_gnu (gnat_expr);
5040
5041 /* before assigning the element to the array make sure it is
5042 in range */
5043 if (Do_Range_Check (gnat_expr))
5044 gnu_expr = emit_range_check (gnu_expr, gnat_component_type);
5045 }
5046
5047 gnu_expr_list
5048 = tree_cons (NULL_TREE, convert (TREE_TYPE (gnu_array_type), gnu_expr),
5049 gnu_expr_list);
5050 }
5051
5052 return gnat_build_constructor (gnu_array_type, nreverse (gnu_expr_list));
5053 }
5054
5055 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
5056 some of which are from RECORD_TYPE. Return a CONSTRUCTOR consisting
5057 of the associations that are from RECORD_TYPE. If we see an internal
5058 record, make a recursive call to fill it in as well. */
5059
5060 static tree
extract_values(tree values,tree record_type)5061 extract_values (tree values, tree record_type)
5062 {
5063 tree result = NULL_TREE;
5064 tree field, tem;
5065
5066 for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field))
5067 {
5068 tree value = 0;
5069
5070 /* _Parent is an internal field, but may have values in the aggregate,
5071 so check for values first. */
5072 if ((tem = purpose_member (field, values)) != 0)
5073 {
5074 value = TREE_VALUE (tem);
5075 TREE_ADDRESSABLE (tem) = 1;
5076 }
5077
5078 else if (DECL_INTERNAL_P (field))
5079 {
5080 value = extract_values (values, TREE_TYPE (field));
5081 if (TREE_CODE (value) == CONSTRUCTOR
5082 && CONSTRUCTOR_ELTS (value) == 0)
5083 value = 0;
5084 }
5085 else
5086 /* If we have a record subtype, the names will match, but not the
5087 actual FIELD_DECLs. */
5088 for (tem = values; tem; tem = TREE_CHAIN (tem))
5089 if (DECL_NAME (TREE_PURPOSE (tem)) == DECL_NAME (field))
5090 {
5091 value = convert (TREE_TYPE (field), TREE_VALUE (tem));
5092 TREE_ADDRESSABLE (tem) = 1;
5093 }
5094
5095 if (value == 0)
5096 continue;
5097
5098 result = tree_cons (field, value, result);
5099 }
5100
5101 return gnat_build_constructor (record_type, nreverse (result));
5102 }
5103
5104 /* EXP is to be treated as an array or record. Handle the cases when it is
5105 an access object and perform the required dereferences. */
5106
5107 static tree
maybe_implicit_deref(tree exp)5108 maybe_implicit_deref (tree exp)
5109 {
5110 /* If the type is a pointer, dereference it. */
5111
5112 if (POINTER_TYPE_P (TREE_TYPE (exp)) || TYPE_FAT_POINTER_P (TREE_TYPE (exp)))
5113 exp = build_unary_op (INDIRECT_REF, NULL_TREE, exp);
5114
5115 /* If we got a padded type, remove it too. */
5116 if (TREE_CODE (TREE_TYPE (exp)) == RECORD_TYPE
5117 && TYPE_IS_PADDING_P (TREE_TYPE (exp)))
5118 exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
5119
5120 return exp;
5121 }
5122
5123 /* Protect EXP from multiple evaluation. This may make a SAVE_EXPR. */
5124
5125 tree
protect_multiple_eval(tree exp)5126 protect_multiple_eval (tree exp)
5127 {
5128 tree type = TREE_TYPE (exp);
5129
5130 /* If this has no side effects, we don't need to do anything. */
5131 if (! TREE_SIDE_EFFECTS (exp))
5132 return exp;
5133
5134 /* If it is a conversion, protect what's inside the conversion.
5135 Similarly, if we're indirectly referencing something, we only
5136 actually need to protect the address since the data itself can't
5137 change in these situations. */
5138 else if (TREE_CODE (exp) == NON_LVALUE_EXPR
5139 || TREE_CODE (exp) == NOP_EXPR || TREE_CODE (exp) == CONVERT_EXPR
5140 || TREE_CODE (exp) == VIEW_CONVERT_EXPR
5141 || TREE_CODE (exp) == INDIRECT_REF
5142 || TREE_CODE (exp) == UNCONSTRAINED_ARRAY_REF)
5143 return build1 (TREE_CODE (exp), type,
5144 protect_multiple_eval (TREE_OPERAND (exp, 0)));
5145
5146 /* If EXP is a fat pointer or something that can be placed into a register,
5147 just make a SAVE_EXPR. */
5148 if (TYPE_FAT_POINTER_P (type) || TYPE_MODE (type) != BLKmode)
5149 return save_expr (exp);
5150
5151 /* Otherwise, dereference, protect the address, and re-reference. */
5152 else
5153 return
5154 build_unary_op (INDIRECT_REF, type,
5155 save_expr (build_unary_op (ADDR_EXPR,
5156 build_reference_type (type),
5157 exp)));
5158 }
5159
5160 /* This is equivalent to stabilize_reference in GCC's tree.c, but we know
5161 how to handle our new nodes and we take an extra argument that says
5162 whether to force evaluation of everything. */
5163
5164 tree
gnat_stabilize_reference(tree ref,int force)5165 gnat_stabilize_reference (tree ref, int force)
5166 {
5167 tree type = TREE_TYPE (ref);
5168 enum tree_code code = TREE_CODE (ref);
5169 tree result;
5170
5171 switch (code)
5172 {
5173 case VAR_DECL:
5174 case PARM_DECL:
5175 case RESULT_DECL:
5176 /* No action is needed in this case. */
5177 return ref;
5178
5179 case NOP_EXPR:
5180 case CONVERT_EXPR:
5181 case FLOAT_EXPR:
5182 case FIX_TRUNC_EXPR:
5183 case FIX_FLOOR_EXPR:
5184 case FIX_ROUND_EXPR:
5185 case FIX_CEIL_EXPR:
5186 case VIEW_CONVERT_EXPR:
5187 case ADDR_EXPR:
5188 result
5189 = build1 (code, type,
5190 gnat_stabilize_reference (TREE_OPERAND (ref, 0), force));
5191 break;
5192
5193 case INDIRECT_REF:
5194 case UNCONSTRAINED_ARRAY_REF:
5195 result = build1 (code, type,
5196 gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0),
5197 force));
5198 break;
5199
5200 case COMPONENT_REF:
5201 result = build (COMPONENT_REF, type,
5202 gnat_stabilize_reference (TREE_OPERAND (ref, 0),
5203 force),
5204 TREE_OPERAND (ref, 1));
5205 break;
5206
5207 case BIT_FIELD_REF:
5208 result = build (BIT_FIELD_REF, type,
5209 gnat_stabilize_reference (TREE_OPERAND (ref, 0), force),
5210 gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
5211 force),
5212 gnat_stabilize_reference_1 (TREE_OPERAND (ref, 2),
5213 force));
5214 break;
5215
5216 case ARRAY_REF:
5217 result = build (ARRAY_REF, type,
5218 gnat_stabilize_reference (TREE_OPERAND (ref, 0), force),
5219 gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
5220 force));
5221 break;
5222
5223 case ARRAY_RANGE_REF:
5224 result = build (ARRAY_RANGE_REF, type,
5225 gnat_stabilize_reference (TREE_OPERAND (ref, 0), force),
5226 gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
5227 force));
5228 break;
5229
5230 case COMPOUND_EXPR:
5231 result = build (COMPOUND_EXPR, type,
5232 gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0),
5233 force),
5234 gnat_stabilize_reference (TREE_OPERAND (ref, 1),
5235 force));
5236 break;
5237
5238 case RTL_EXPR:
5239 result = build1 (INDIRECT_REF, type,
5240 save_expr (build1 (ADDR_EXPR,
5241 build_reference_type (type), ref)));
5242 break;
5243
5244 /* If arg isn't a kind of lvalue we recognize, make no change.
5245 Caller should recognize the error for an invalid lvalue. */
5246 default:
5247 return ref;
5248
5249 case ERROR_MARK:
5250 return error_mark_node;
5251 }
5252
5253 TREE_READONLY (result) = TREE_READONLY (ref);
5254 return result;
5255 }
5256
5257 /* Similar to stabilize_reference_1 in tree.c, but supports an extra
5258 arg to force a SAVE_EXPR for everything. */
5259
5260 static tree
gnat_stabilize_reference_1(tree e,int force)5261 gnat_stabilize_reference_1 (tree e, int force)
5262 {
5263 enum tree_code code = TREE_CODE (e);
5264 tree type = TREE_TYPE (e);
5265 tree result;
5266
5267 /* We cannot ignore const expressions because it might be a reference
5268 to a const array but whose index contains side-effects. But we can
5269 ignore things that are actual constant or that already have been
5270 handled by this function. */
5271
5272 if (TREE_CONSTANT (e) || code == SAVE_EXPR)
5273 return e;
5274
5275 switch (TREE_CODE_CLASS (code))
5276 {
5277 case 'x':
5278 case 't':
5279 case 'd':
5280 case 'b':
5281 case '<':
5282 case 's':
5283 case 'e':
5284 case 'r':
5285 if (TREE_SIDE_EFFECTS (e) || force)
5286 return save_expr (e);
5287 return e;
5288
5289 case 'c':
5290 /* Constants need no processing. In fact, we should never reach
5291 here. */
5292 return e;
5293
5294 case '2':
5295 /* Recursively stabilize each operand. */
5296 result = build (code, type,
5297 gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force),
5298 gnat_stabilize_reference_1 (TREE_OPERAND (e, 1), force));
5299 break;
5300
5301 case '1':
5302 /* Recursively stabilize each operand. */
5303 result = build1 (code, type,
5304 gnat_stabilize_reference_1 (TREE_OPERAND (e, 0),
5305 force));
5306 break;
5307
5308 default:
5309 abort ();
5310 }
5311
5312 TREE_READONLY (result) = TREE_READONLY (e);
5313 return result;
5314 }
5315
5316 /* GNAT_UNIT is the Defining_Identifier for some package or subprogram,
5317 either a spec or a body, BODY_P says which. If needed, make a function
5318 to be the elaboration routine for that object and perform the elaborations
5319 in GNU_ELAB_LIST.
5320
5321 Return 1 if we didn't need an elaboration function, zero otherwise. */
5322
5323 static int
build_unit_elab(Entity_Id gnat_unit,int body_p,tree gnu_elab_list)5324 build_unit_elab (Entity_Id gnat_unit, int body_p, tree gnu_elab_list)
5325 {
5326 tree gnu_decl;
5327 rtx insn;
5328 int result = 1;
5329
5330 /* If we have nothing to do, return. */
5331 if (gnu_elab_list == 0)
5332 return 1;
5333
5334 /* Prevent the elaboration list from being reclaimed by the GC. */
5335 gnu_pending_elaboration_lists = chainon (gnu_pending_elaboration_lists,
5336 gnu_elab_list);
5337
5338 /* Set our file and line number to that of the object and set up the
5339 elaboration routine. */
5340 gnu_decl = create_subprog_decl (create_concat_name (gnat_unit,
5341 body_p ?
5342 "elabb" : "elabs"),
5343 NULL_TREE, void_ftype, NULL_TREE, 0, 1, 0,
5344 0);
5345 DECL_ELABORATION_PROC_P (gnu_decl) = 1;
5346
5347 begin_subprog_body (gnu_decl);
5348 set_lineno (gnat_unit, 1);
5349 pushlevel (0);
5350 gnu_block_stack = tree_cons (NULL_TREE, NULL_TREE, gnu_block_stack);
5351 expand_start_bindings (0);
5352
5353 /* Emit the assignments for the elaborations we have to do. If there
5354 is no destination, this is just a call to execute some statement
5355 that was placed within the declarative region. But first save a
5356 pointer so we can see if any insns were generated. */
5357
5358 insn = get_last_insn ();
5359
5360 for (; gnu_elab_list; gnu_elab_list = TREE_CHAIN (gnu_elab_list))
5361 if (TREE_PURPOSE (gnu_elab_list) == NULL_TREE)
5362 {
5363 if (TREE_VALUE (gnu_elab_list) != 0)
5364 expand_expr_stmt (TREE_VALUE (gnu_elab_list));
5365 }
5366 else
5367 {
5368 tree lhs = TREE_PURPOSE (gnu_elab_list);
5369
5370 input_location = DECL_SOURCE_LOCATION (lhs);
5371
5372 /* If LHS has a padded type, convert it to the unpadded type
5373 so the assignment is done properly. */
5374 if (TREE_CODE (TREE_TYPE (lhs)) == RECORD_TYPE
5375 && TYPE_IS_PADDING_P (TREE_TYPE (lhs)))
5376 lhs = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (lhs))), lhs);
5377
5378 emit_line_note (input_location);
5379 expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE,
5380 TREE_PURPOSE (gnu_elab_list),
5381 TREE_VALUE (gnu_elab_list)));
5382 }
5383
5384 /* See if any non-NOTE insns were generated. */
5385 for (insn = NEXT_INSN (insn); insn; insn = NEXT_INSN (insn))
5386 if (GET_RTX_CLASS (GET_CODE (insn)) == 'i')
5387 {
5388 result = 0;
5389 break;
5390 }
5391
5392 expand_end_bindings (getdecls (), kept_level_p (), -1);
5393 poplevel (kept_level_p (), 1, 0);
5394 gnu_block_stack = TREE_CHAIN (gnu_block_stack);
5395 end_subprog_body ();
5396
5397 /* We are finished with the elaboration list it can now be discarded. */
5398 gnu_pending_elaboration_lists = TREE_CHAIN (gnu_pending_elaboration_lists);
5399
5400 /* If there were no insns, we don't need an elab routine. It would
5401 be nice to not output this one, but there's no good way to do that. */
5402 return result;
5403 }
5404
5405 extern char *__gnat_to_canonical_file_spec (char *);
5406
5407 /* Determine the input_filename and the input_line from the source location
5408 (Sloc) of GNAT_NODE node. Set the global variable input_filename and
5409 input_line. If WRITE_NOTE_P is true, emit a line number note. */
5410
5411 void
set_lineno(Node_Id gnat_node,int write_note_p)5412 set_lineno (Node_Id gnat_node, int write_note_p)
5413 {
5414 Source_Ptr source_location = Sloc (gnat_node);
5415
5416 set_lineno_from_sloc (source_location, write_note_p);
5417 }
5418
5419 /* Likewise, but passed a Sloc. */
5420
5421 void
set_lineno_from_sloc(Source_Ptr source_location,int write_note_p)5422 set_lineno_from_sloc (Source_Ptr source_location, int write_note_p)
5423 {
5424 /* If node not from source code, ignore. */
5425 if (source_location < 0)
5426 return;
5427
5428 /* Use the identifier table to make a hashed, permanent copy of the filename,
5429 since the name table gets reallocated after Gigi returns but before all
5430 the debugging information is output. The __gnat_to_canonical_file_spec
5431 call translates filenames from pragmas Source_Reference that contain host
5432 style syntax not understood by gdb. */
5433 input_filename
5434 = IDENTIFIER_POINTER
5435 (get_identifier
5436 (__gnat_to_canonical_file_spec
5437 (Get_Name_String
5438 (Full_Debug_Name (Get_Source_File_Index (source_location))))));
5439
5440 /* ref_filename is the reference file name as given by sinput (i.e no
5441 directory) */
5442 ref_filename
5443 = IDENTIFIER_POINTER
5444 (get_identifier
5445 (Get_Name_String
5446 (Debug_Source_Name (Get_Source_File_Index (source_location)))));;
5447 input_line = Get_Logical_Line_Number (source_location);
5448
5449 if (write_note_p)
5450 emit_line_note (input_location);
5451 }
5452
5453 /* Post an error message. MSG is the error message, properly annotated.
5454 NODE is the node at which to post the error and the node to use for the
5455 "&" substitution. */
5456
5457 void
post_error(const char * msg,Node_Id node)5458 post_error (const char *msg, Node_Id node)
5459 {
5460 String_Template temp;
5461 Fat_Pointer fp;
5462
5463 temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
5464 fp.Array = msg, fp.Bounds = &temp;
5465 if (Present (node))
5466 Error_Msg_N (fp, node);
5467 }
5468
5469 /* Similar, but NODE is the node at which to post the error and ENT
5470 is the node to use for the "&" substitution. */
5471
5472 void
post_error_ne(const char * msg,Node_Id node,Entity_Id ent)5473 post_error_ne (const char *msg, Node_Id node, Entity_Id ent)
5474 {
5475 String_Template temp;
5476 Fat_Pointer fp;
5477
5478 temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
5479 fp.Array = msg, fp.Bounds = &temp;
5480 if (Present (node))
5481 Error_Msg_NE (fp, node, ent);
5482 }
5483
5484 /* Similar, but NODE is the node at which to post the error, ENT is the node
5485 to use for the "&" substitution, and N is the number to use for the ^. */
5486
5487 void
post_error_ne_num(const char * msg,Node_Id node,Entity_Id ent,int n)5488 post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent, int n)
5489 {
5490 String_Template temp;
5491 Fat_Pointer fp;
5492
5493 temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
5494 fp.Array = msg, fp.Bounds = &temp;
5495 Error_Msg_Uint_1 = UI_From_Int (n);
5496
5497 if (Present (node))
5498 Error_Msg_NE (fp, node, ent);
5499 }
5500
5501 /* Similar to post_error_ne_num, but T is a GCC tree representing the
5502 number to write. If the tree represents a constant that fits within
5503 a host integer, the text inside curly brackets in MSG will be output
5504 (presumably including a '^'). Otherwise that text will not be output
5505 and the text inside square brackets will be output instead. */
5506
5507 void
post_error_ne_tree(const char * msg,Node_Id node,Entity_Id ent,tree t)5508 post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent, tree t)
5509 {
5510 char *newmsg = alloca (strlen (msg) + 1);
5511 String_Template temp = {1, 0};
5512 Fat_Pointer fp;
5513 char start_yes, end_yes, start_no, end_no;
5514 const char *p;
5515 char *q;
5516
5517 fp.Array = newmsg, fp.Bounds = &temp;
5518
5519 if (host_integerp (t, 1)
5520 #if HOST_BITS_PER_WIDE_INT > HOST_BITS_PER_INT
5521 &&
5522 compare_tree_int
5523 (t, (((unsigned HOST_WIDE_INT) 1 << (HOST_BITS_PER_INT - 1)) - 1)) < 0
5524 #endif
5525 )
5526 {
5527 Error_Msg_Uint_1 = UI_From_Int (tree_low_cst (t, 1));
5528 start_yes = '{', end_yes = '}', start_no = '[', end_no = ']';
5529 }
5530 else
5531 start_yes = '[', end_yes = ']', start_no = '{', end_no = '}';
5532
5533 for (p = msg, q = newmsg; *p != 0; p++)
5534 {
5535 if (*p == start_yes)
5536 for (p++; *p != end_yes; p++)
5537 *q++ = *p;
5538 else if (*p == start_no)
5539 for (p++; *p != end_no; p++)
5540 ;
5541 else
5542 *q++ = *p;
5543 }
5544
5545 *q = 0;
5546
5547 temp.High_Bound = strlen (newmsg);
5548 if (Present (node))
5549 Error_Msg_NE (fp, node, ent);
5550 }
5551
5552 /* Similar to post_error_ne_tree, except that NUM is a second
5553 integer to write in the message. */
5554
5555 void
post_error_ne_tree_2(const char * msg,Node_Id node,Entity_Id ent,tree t,int num)5556 post_error_ne_tree_2 (const char *msg,
5557 Node_Id node,
5558 Entity_Id ent,
5559 tree t,
5560 int num)
5561 {
5562 Error_Msg_Uint_2 = UI_From_Int (num);
5563 post_error_ne_tree (msg, node, ent, t);
5564 }
5565
5566 /* Set the node for a second '&' in the error message. */
5567
5568 void
set_second_error_entity(Entity_Id e)5569 set_second_error_entity (Entity_Id e)
5570 {
5571 Error_Msg_Node_2 = e;
5572 }
5573
5574 /* Signal abort, with "Gigi abort" as the error label, and error_gnat_node
5575 as the relevant node that provides the location info for the error */
5576
5577 void
gigi_abort(int code)5578 gigi_abort (int code)
5579 {
5580 String_Template temp = {1, 10};
5581 Fat_Pointer fp;
5582
5583 fp.Array = "Gigi abort", fp.Bounds = &temp;
5584
5585 Current_Error_Node = error_gnat_node;
5586 Compiler_Abort (fp, code);
5587 }
5588
5589 /* Initialize the table that maps GNAT codes to GCC codes for simple
5590 binary and unary operations. */
5591
5592 void
init_code_table(void)5593 init_code_table (void)
5594 {
5595 gnu_codes[N_And_Then] = TRUTH_ANDIF_EXPR;
5596 gnu_codes[N_Or_Else] = TRUTH_ORIF_EXPR;
5597
5598 gnu_codes[N_Op_And] = TRUTH_AND_EXPR;
5599 gnu_codes[N_Op_Or] = TRUTH_OR_EXPR;
5600 gnu_codes[N_Op_Xor] = TRUTH_XOR_EXPR;
5601 gnu_codes[N_Op_Eq] = EQ_EXPR;
5602 gnu_codes[N_Op_Ne] = NE_EXPR;
5603 gnu_codes[N_Op_Lt] = LT_EXPR;
5604 gnu_codes[N_Op_Le] = LE_EXPR;
5605 gnu_codes[N_Op_Gt] = GT_EXPR;
5606 gnu_codes[N_Op_Ge] = GE_EXPR;
5607 gnu_codes[N_Op_Add] = PLUS_EXPR;
5608 gnu_codes[N_Op_Subtract] = MINUS_EXPR;
5609 gnu_codes[N_Op_Multiply] = MULT_EXPR;
5610 gnu_codes[N_Op_Mod] = FLOOR_MOD_EXPR;
5611 gnu_codes[N_Op_Rem] = TRUNC_MOD_EXPR;
5612 gnu_codes[N_Op_Minus] = NEGATE_EXPR;
5613 gnu_codes[N_Op_Abs] = ABS_EXPR;
5614 gnu_codes[N_Op_Not] = TRUTH_NOT_EXPR;
5615 gnu_codes[N_Op_Rotate_Left] = LROTATE_EXPR;
5616 gnu_codes[N_Op_Rotate_Right] = RROTATE_EXPR;
5617 gnu_codes[N_Op_Shift_Left] = LSHIFT_EXPR;
5618 gnu_codes[N_Op_Shift_Right] = RSHIFT_EXPR;
5619 gnu_codes[N_Op_Shift_Right_Arithmetic] = RSHIFT_EXPR;
5620 }
5621
5622 #include "gt-ada-trans.h"
5623