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