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