]>
Commit | Line | Data |
---|---|---|
70482933 RK |
1 | /**************************************************************************** |
2 | * * | |
3 | * GNAT COMPILER COMPONENTS * | |
4 | * * | |
984bc4c3 | 5 | * D E C L * |
70482933 RK |
6 | * * |
7 | * C Implementation File * | |
8 | * * | |
acd47d2a | 9 | * Copyright (C) 1992-2004, Free Software Foundation, Inc. * |
70482933 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. * |
70482933 RK |
24 | * * |
25 | ****************************************************************************/ | |
26 | ||
27 | #include "config.h" | |
28 | #include "system.h" | |
4977bab6 ZW |
29 | #include "coretypes.h" |
30 | #include "tm.h" | |
70482933 RK |
31 | #include "tree.h" |
32 | #include "flags.h" | |
33 | #include "toplev.h" | |
34 | #include "convert.h" | |
35 | #include "ggc.h" | |
36 | #include "obstack.h" | |
37 | ||
38 | #include "ada.h" | |
39 | #include "types.h" | |
40 | #include "atree.h" | |
41 | #include "elists.h" | |
42 | #include "namet.h" | |
43 | #include "nlists.h" | |
44 | #include "repinfo.h" | |
45 | #include "snames.h" | |
46 | #include "stringt.h" | |
47 | #include "uintp.h" | |
48 | #include "fe.h" | |
49 | #include "sinfo.h" | |
50 | #include "einfo.h" | |
51 | #include "ada-tree.h" | |
52 | #include "gigi.h" | |
53 | ||
54 | /* Setting this to 1 suppresses hashing of types. */ | |
55 | extern int debug_no_type_hash; | |
56 | ||
57 | /* Provide default values for the macros controlling stack checking. | |
58 | This is copied from GCC's expr.h. */ | |
59 | ||
60 | #ifndef STACK_CHECK_BUILTIN | |
61 | #define STACK_CHECK_BUILTIN 0 | |
62 | #endif | |
63 | #ifndef STACK_CHECK_PROBE_INTERVAL | |
64 | #define STACK_CHECK_PROBE_INTERVAL 4096 | |
65 | #endif | |
66 | #ifndef STACK_CHECK_MAX_FRAME_SIZE | |
67 | #define STACK_CHECK_MAX_FRAME_SIZE \ | |
68 | (STACK_CHECK_PROBE_INTERVAL - UNITS_PER_WORD) | |
69 | #endif | |
70 | #ifndef STACK_CHECK_MAX_VAR_SIZE | |
71 | #define STACK_CHECK_MAX_VAR_SIZE (STACK_CHECK_MAX_FRAME_SIZE / 100) | |
72 | #endif | |
73 | ||
74 | /* These two variables are used to defer recursively expanding incomplete | |
75 | types while we are processing a record or subprogram type. */ | |
76 | ||
77 | static int defer_incomplete_level = 0; | |
78 | static struct incomplete | |
79 | { | |
80 | struct incomplete *next; | |
81 | tree old_type; | |
82 | Entity_Id full_type; | |
83 | } *defer_incomplete_list = 0; | |
84 | ||
b7e429ab | 85 | static void copy_alias_set (tree, tree); |
9373164a KC |
86 | static tree substitution_list (Entity_Id, Entity_Id, tree, int); |
87 | static int allocatable_size_p (tree, int); | |
88 | static struct attrib *build_attr_list (Entity_Id); | |
89 | static tree elaborate_expression (Node_Id, Entity_Id, tree, int, int, int); | |
90 | static int is_variable_size (tree); | |
91 | static tree elaborate_expression_1 (Node_Id, Entity_Id, tree, tree, int, int); | |
92 | static tree make_packable_type (tree); | |
93 | static tree maybe_pad_type (tree, tree, unsigned int, Entity_Id, const char *, | |
94 | int, int, int); | |
95 | static tree gnat_to_gnu_field (Entity_Id, tree, int, int); | |
96 | static void components_to_record (tree, Node_Id, tree, int, int, tree *, | |
97 | int, int); | |
98 | static int compare_field_bitpos (const PTR, const PTR); | |
99 | static Uint annotate_value (tree); | |
100 | static void annotate_rep (Entity_Id, tree); | |
101 | static tree compute_field_positions (tree, tree, tree, tree, unsigned int); | |
102 | static tree validate_size (Uint, tree, Entity_Id, enum tree_code, int, int); | |
103 | static void set_rm_size (Uint, tree, Entity_Id); | |
104 | static tree make_type_from_size (tree, tree, int); | |
105 | static unsigned int validate_alignment (Uint, Entity_Id, unsigned int); | |
106 | static void check_ok_for_atomic (tree, Entity_Id, int); | |
70482933 RK |
107 | \f |
108 | /* Given GNAT_ENTITY, an entity in the incoming GNAT tree, return a | |
109 | GCC type corresponding to that entity. GNAT_ENTITY is assumed to | |
110 | refer to an Ada type. */ | |
111 | ||
112 | tree | |
9373164a | 113 | gnat_to_gnu_type (Entity_Id gnat_entity) |
70482933 RK |
114 | { |
115 | tree gnu_decl; | |
116 | ||
117 | /* Convert the ada entity type into a GCC TYPE_DECL node. */ | |
118 | gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0); | |
119 | if (TREE_CODE (gnu_decl) != TYPE_DECL) | |
120 | gigi_abort (101); | |
121 | ||
122 | return TREE_TYPE (gnu_decl); | |
123 | } | |
124 | \f | |
125 | /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada | |
126 | entity, this routine returns the equivalent GCC tree for that entity | |
127 | (an ..._DECL node) and associates the ..._DECL node with the input GNAT | |
128 | defining identifier. | |
129 | ||
130 | If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its | |
131 | initial value (in GCC tree form). This is optional for variables. | |
132 | For renamed entities, GNU_EXPR gives the object being renamed. | |
133 | ||
134 | DEFINITION is nonzero if this call is intended for a definition. This is | |
135 | used for separate compilation where it necessary to know whether an | |
136 | external declaration or a definition should be created if the GCC equivalent | |
137 | was not created previously. The value of 1 is normally used for a non-zero | |
138 | DEFINITION, but a value of 2 is used in special circumstances, defined in | |
139 | the code. */ | |
140 | ||
141 | tree | |
9373164a | 142 | gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) |
70482933 RK |
143 | { |
144 | tree gnu_entity_id; | |
145 | tree gnu_type = 0; | |
146 | /* Contains the gnu XXXX_DECL tree node which is equivalent to the input | |
147 | GNAT tree. This node will be associated with the GNAT node by calling | |
148 | the save_gnu_tree routine at the end of the `switch' statement. */ | |
149 | tree gnu_decl = 0; | |
150 | /* Nonzero if we have already saved gnu_decl as a gnat association. */ | |
151 | int saved = 0; | |
152 | /* Nonzero if we incremented defer_incomplete_level. */ | |
153 | int this_deferred = 0; | |
154 | /* Nonzero if we incremented force_global. */ | |
155 | int this_global = 0; | |
156 | /* Nonzero if we should check to see if elaborated during processing. */ | |
157 | int maybe_present = 0; | |
158 | /* Nonzero if we made GNU_DECL and its type here. */ | |
159 | int this_made_decl = 0; | |
160 | struct attrib *attr_list = 0; | |
161 | int debug_info_p = (Needs_Debug_Info (gnat_entity) | |
162 | || debug_info_level == DINFO_LEVEL_VERBOSE); | |
163 | Entity_Kind kind = Ekind (gnat_entity); | |
164 | Entity_Id gnat_temp; | |
165 | unsigned int esize | |
166 | = ((Known_Esize (gnat_entity) | |
167 | && UI_Is_In_Int_Range (Esize (gnat_entity))) | |
168 | ? MIN (UI_To_Int (Esize (gnat_entity)), | |
169 | IN (kind, Float_Kind) | |
12e0c41c | 170 | ? fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE) |
70482933 RK |
171 | : IN (kind, Access_Kind) ? POINTER_SIZE * 2 |
172 | : LONG_LONG_TYPE_SIZE) | |
173 | : LONG_LONG_TYPE_SIZE); | |
174 | tree gnu_size = 0; | |
175 | int imported_p | |
176 | = ((Is_Imported (gnat_entity) && No (Address_Clause (gnat_entity))) | |
177 | || From_With_Type (gnat_entity)); | |
178 | unsigned int align = 0; | |
179 | ||
180 | /* Since a use of an Itype is a definition, process it as such if it | |
181 | is not in a with'ed unit. */ | |
182 | ||
183 | if (! definition && Is_Itype (gnat_entity) | |
184 | && ! present_gnu_tree (gnat_entity) | |
185 | && In_Extended_Main_Code_Unit (gnat_entity)) | |
186 | { | |
187 | /* Ensure that we are in a subprogram mentioned in the Scope | |
188 | chain of this entity, our current scope is global, | |
189 | or that we encountered a task or entry (where we can't currently | |
190 | accurately check scoping). */ | |
191 | if (current_function_decl == 0 | |
192 | || DECL_ELABORATION_PROC_P (current_function_decl)) | |
193 | { | |
194 | process_type (gnat_entity); | |
195 | return get_gnu_tree (gnat_entity); | |
196 | } | |
197 | ||
198 | for (gnat_temp = Scope (gnat_entity); | |
199 | Present (gnat_temp); gnat_temp = Scope (gnat_temp)) | |
200 | { | |
201 | if (Is_Type (gnat_temp)) | |
202 | gnat_temp = Underlying_Type (gnat_temp); | |
203 | ||
204 | if (Ekind (gnat_temp) == E_Subprogram_Body) | |
205 | gnat_temp | |
206 | = Corresponding_Spec (Parent (Declaration_Node (gnat_temp))); | |
207 | ||
208 | if (IN (Ekind (gnat_temp), Subprogram_Kind) | |
209 | && Present (Protected_Body_Subprogram (gnat_temp))) | |
210 | gnat_temp = Protected_Body_Subprogram (gnat_temp); | |
211 | ||
212 | if (Ekind (gnat_temp) == E_Entry | |
213 | || Ekind (gnat_temp) == E_Entry_Family | |
214 | || Ekind (gnat_temp) == E_Task_Type | |
215 | || (IN (Ekind (gnat_temp), Subprogram_Kind) | |
216 | && present_gnu_tree (gnat_temp) | |
217 | && (current_function_decl | |
218 | == gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0)))) | |
219 | { | |
220 | process_type (gnat_entity); | |
221 | return get_gnu_tree (gnat_entity); | |
222 | } | |
223 | } | |
224 | ||
225 | /* gigi abort 122 means that the entity "gnat_entity" has an incorrect | |
226 | scope, i.e. that its scope does not correspond to the subprogram | |
227 | in which it is declared */ | |
228 | gigi_abort (122); | |
229 | } | |
230 | ||
231 | /* If this is entity 0, something went badly wrong. */ | |
232 | if (gnat_entity == 0) | |
233 | gigi_abort (102); | |
234 | ||
235 | /* If we've already processed this entity, return what we got last time. | |
236 | If we are defining the node, we should not have already processed it. | |
237 | In that case, we will abort below when we try to save a new GCC tree for | |
238 | this object. We also need to handle the case of getting a dummy type | |
239 | when a Full_View exists. */ | |
240 | ||
241 | if (present_gnu_tree (gnat_entity) | |
242 | && (! definition | |
243 | || (Is_Type (gnat_entity) && imported_p))) | |
244 | { | |
245 | gnu_decl = get_gnu_tree (gnat_entity); | |
246 | ||
247 | if (TREE_CODE (gnu_decl) == TYPE_DECL | |
248 | && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)) | |
249 | && IN (kind, Incomplete_Or_Private_Kind) | |
250 | && Present (Full_View (gnat_entity))) | |
251 | { | |
252 | gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity), | |
253 | NULL_TREE, 0); | |
254 | ||
255 | save_gnu_tree (gnat_entity, NULL_TREE, 0); | |
256 | save_gnu_tree (gnat_entity, gnu_decl, 0); | |
257 | } | |
258 | ||
259 | return gnu_decl; | |
260 | } | |
261 | ||
262 | /* If this is a numeric or enumeral type, or an access type, a nonzero | |
263 | Esize must be specified unless it was specified by the programmer. */ | |
264 | if ((IN (kind, Numeric_Kind) || IN (kind, Enumeration_Kind) | |
265 | || (IN (kind, Access_Kind) | |
266 | && kind != E_Access_Protected_Subprogram_Type | |
267 | && kind != E_Access_Subtype)) | |
268 | && Unknown_Esize (gnat_entity) | |
269 | && ! Has_Size_Clause (gnat_entity)) | |
270 | gigi_abort (109); | |
271 | ||
272 | /* Likewise, RM_Size must be specified for all discrete and fixed-point | |
273 | types. */ | |
274 | if (IN (kind, Discrete_Or_Fixed_Point_Kind) | |
275 | && Unknown_RM_Size (gnat_entity)) | |
276 | gigi_abort (123); | |
277 | ||
278 | /* Get the name of the entity and set up the line number and filename of | |
279 | the original definition for use in any decl we make. */ | |
280 | ||
281 | gnu_entity_id = get_entity_name (gnat_entity); | |
282 | set_lineno (gnat_entity, 0); | |
283 | ||
284 | /* If we get here, it means we have not yet done anything with this | |
285 | entity. If we are not defining it here, it must be external, | |
286 | otherwise we should have defined it already. */ | |
287 | if (! definition && ! Is_Public (gnat_entity) | |
288 | && ! type_annotate_only | |
289 | && kind != E_Discriminant && kind != E_Component | |
290 | && kind != E_Label | |
291 | && ! (kind == E_Constant && Present (Full_View (gnat_entity))) | |
292 | #if 1 | |
293 | && !IN (kind, Type_Kind) | |
294 | #endif | |
295 | ) | |
296 | gigi_abort (116); | |
297 | ||
298 | /* For cases when we are not defining (i.e., we are referencing from | |
299 | another compilation unit) Public entities, show we are at global level | |
300 | for the purpose of computing sizes. Don't do this for components or | |
301 | discriminants since the relevant test is whether or not the record is | |
302 | being defined. */ | |
303 | if (! definition && Is_Public (gnat_entity) | |
304 | && ! Is_Statically_Allocated (gnat_entity) | |
305 | && kind != E_Discriminant && kind != E_Component) | |
306 | force_global++, this_global = 1; | |
307 | ||
308 | /* Handle any attributes. */ | |
309 | if (Has_Gigi_Rep_Item (gnat_entity)) | |
310 | attr_list = build_attr_list (gnat_entity); | |
311 | ||
312 | switch (kind) | |
313 | { | |
314 | case E_Constant: | |
315 | /* If this is a use of a deferred constant, get its full | |
316 | declaration. */ | |
317 | if (! definition && Present (Full_View (gnat_entity))) | |
318 | { | |
319 | gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity), | |
320 | gnu_expr, definition); | |
321 | saved = 1; | |
322 | break; | |
323 | } | |
324 | ||
325 | /* If we have an external constant that we are not defining, | |
326 | get the expression that is was defined to represent. We | |
327 | may throw that expression away later if it is not a | |
fbf5a39b AC |
328 | constant. |
329 | Do not retrieve the expression if it is an aggregate, because | |
330 | in complex instantiation contexts it may not be expanded */ | |
331 | ||
70482933 RK |
332 | if (! definition |
333 | && Present (Expression (Declaration_Node (gnat_entity))) | |
fbf5a39b AC |
334 | && ! No_Initialization (Declaration_Node (gnat_entity)) |
335 | && Nkind (Expression (Declaration_Node (gnat_entity))) | |
336 | != N_Aggregate) | |
70482933 RK |
337 | gnu_expr = gnat_to_gnu (Expression (Declaration_Node (gnat_entity))); |
338 | ||
339 | /* Ignore deferred constant definitions; they are processed fully in the | |
340 | front-end. For deferred constant references, get the full | |
341 | definition. On the other hand, constants that are renamings are | |
342 | handled like variable renamings. If No_Initialization is set, this is | |
343 | not a deferred constant but a constant whose value is built | |
344 | manually. */ | |
345 | ||
346 | if (definition && gnu_expr == 0 | |
347 | && ! No_Initialization (Declaration_Node (gnat_entity)) | |
348 | && No (Renamed_Object (gnat_entity))) | |
349 | { | |
350 | gnu_decl = error_mark_node; | |
351 | saved = 1; | |
352 | break; | |
353 | } | |
354 | else if (! definition && IN (kind, Incomplete_Or_Private_Kind) | |
355 | && Present (Full_View (gnat_entity))) | |
356 | { | |
357 | gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity), | |
358 | NULL_TREE, 0); | |
359 | saved = 1; | |
360 | break; | |
361 | } | |
362 | ||
363 | goto object; | |
364 | ||
365 | case E_Exception: | |
366 | /* If this is not a VMS exception, treat it as a normal object. | |
367 | Otherwise, make an object at the specific address of character | |
368 | type, point to it, and convert it to integer, and mask off | |
369 | the lower 3 bits. */ | |
370 | if (! Is_VMS_Exception (gnat_entity)) | |
371 | goto object; | |
372 | ||
373 | /* Allocate the global object that we use to get the value of the | |
374 | exception. */ | |
375 | gnu_decl = create_var_decl (gnu_entity_id, | |
376 | (Present (Interface_Name (gnat_entity)) | |
377 | ? create_concat_name (gnat_entity, 0) | |
378 | : NULL_TREE), | |
379 | char_type_node, NULL_TREE, 0, 0, 1, 1, | |
380 | 0); | |
381 | ||
382 | /* Now return the expression giving the desired value. */ | |
383 | gnu_decl | |
384 | = build_binary_op (BIT_AND_EXPR, integer_type_node, | |
385 | convert (integer_type_node, | |
386 | build_unary_op (ADDR_EXPR, NULL_TREE, | |
387 | gnu_decl)), | |
388 | build_unary_op (NEGATE_EXPR, integer_type_node, | |
389 | build_int_2 (7, 0))); | |
390 | ||
391 | save_gnu_tree (gnat_entity, gnu_decl, 1); | |
392 | saved = 1; | |
393 | break; | |
394 | ||
395 | case E_Discriminant: | |
396 | case E_Component: | |
397 | { | |
398 | /* The GNAT record where the component was defined. */ | |
399 | Entity_Id gnat_record = Underlying_Type (Scope (gnat_entity)); | |
400 | ||
401 | /* If the variable is an inherited record component (in the case of | |
402 | extended record types), just return the inherited entity, which | |
403 | must be a FIELD_DECL. Likewise for discriminants. | |
404 | For discriminants of untagged records which have explicit | |
fbf5a39b AC |
405 | stored discriminants, return the entity for the corresponding |
406 | stored discriminant. Also use Original_Record_Component | |
70482933 RK |
407 | if the record has a private extension. */ |
408 | ||
409 | if ((Base_Type (gnat_record) == gnat_record | |
fbf5a39b | 410 | || Ekind (Scope (gnat_entity)) == E_Private_Subtype |
70482933 RK |
411 | || Ekind (Scope (gnat_entity)) == E_Record_Subtype_With_Private |
412 | || Ekind (Scope (gnat_entity)) == E_Record_Type_With_Private) | |
413 | && Present (Original_Record_Component (gnat_entity)) | |
414 | && Original_Record_Component (gnat_entity) != gnat_entity) | |
415 | { | |
416 | gnu_decl | |
417 | = gnat_to_gnu_entity (Original_Record_Component (gnat_entity), | |
418 | gnu_expr, definition); | |
419 | saved = 1; | |
420 | break; | |
421 | } | |
422 | ||
fbf5a39b | 423 | /* If the enclosing record has explicit stored discriminants, |
70482933 RK |
424 | then it is an untagged record. If the Corresponding_Discriminant |
425 | is not empty then this must be a renamed discriminant and its | |
426 | Original_Record_Component must point to the corresponding explicit | |
fbf5a39b | 427 | stored discriminant (i.e., we should have taken the previous |
70482933 RK |
428 | branch). */ |
429 | ||
430 | else if (Present (Corresponding_Discriminant (gnat_entity)) | |
431 | && Is_Tagged_Type (gnat_record)) | |
432 | { | |
fbf5a39b | 433 | /* A tagged record has no explicit stored discriminants. */ |
70482933 RK |
434 | |
435 | if (First_Discriminant (gnat_record) | |
fbf5a39b | 436 | != First_Stored_Discriminant (gnat_record)) |
70482933 RK |
437 | gigi_abort (119); |
438 | ||
439 | gnu_decl | |
440 | = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity), | |
441 | gnu_expr, definition); | |
442 | saved = 1; | |
443 | break; | |
444 | } | |
445 | ||
fbf5a39b | 446 | /* If the enclosing record has explicit stored discriminants, |
70482933 RK |
447 | then it is an untagged record. If the Corresponding_Discriminant |
448 | is not empty then this must be a renamed discriminant and its | |
449 | Original_Record_Component must point to the corresponding explicit | |
fbf5a39b | 450 | stored discriminant (i.e., we should have taken the first |
70482933 RK |
451 | branch). */ |
452 | ||
453 | else if (Present (Corresponding_Discriminant (gnat_entity)) | |
454 | && (First_Discriminant (gnat_record) | |
fbf5a39b | 455 | != First_Stored_Discriminant (gnat_record))) |
70482933 RK |
456 | gigi_abort (120); |
457 | ||
458 | /* Otherwise, if we are not defining this and we have no GCC type | |
459 | for the containing record, make one for it. Then we should | |
460 | have made our own equivalent. */ | |
461 | else if (! definition && ! present_gnu_tree (gnat_record)) | |
462 | { | |
463 | /* ??? If this is in a record whose scope is a protected | |
464 | type and we have an Original_Record_Component, use it. | |
465 | This is a workaround for major problems in protected type | |
466 | handling. */ | |
fbf5a39b AC |
467 | |
468 | Entity_Id Scop = Scope (Scope (gnat_entity)); | |
469 | if ((Is_Protected_Type (Scop) | |
470 | || (Is_Private_Type (Scop) | |
471 | && Present (Full_View (Scop)) | |
472 | && Is_Protected_Type (Full_View (Scop)))) | |
70482933 | 473 | && Present (Original_Record_Component (gnat_entity))) |
fbf5a39b | 474 | { |
70482933 RK |
475 | gnu_decl |
476 | = gnat_to_gnu_entity (Original_Record_Component | |
477 | (gnat_entity), | |
478 | gnu_expr, definition); | |
479 | saved = 1; | |
480 | break; | |
481 | } | |
482 | ||
483 | gnat_to_gnu_entity (Scope (gnat_entity), NULL_TREE, 0); | |
484 | gnu_decl = get_gnu_tree (gnat_entity); | |
485 | saved = 1; | |
486 | break; | |
487 | } | |
488 | ||
489 | /* Here we have no GCC type and this is a reference rather than a | |
490 | definition. This should never happen. Most likely the cause is a | |
491 | reference before declaration in the gnat tree for gnat_entity. */ | |
492 | else | |
493 | gigi_abort (103); | |
494 | } | |
495 | ||
496 | case E_Loop_Parameter: | |
497 | case E_Out_Parameter: | |
498 | case E_Variable: | |
499 | ||
500 | /* Simple variables, loop variables, OUT parameters, and exceptions. */ | |
501 | object: | |
502 | { | |
503 | int used_by_ref = 0; | |
504 | int const_flag | |
505 | = ((kind == E_Constant || kind == E_Variable) | |
506 | && ! Is_Statically_Allocated (gnat_entity) | |
507 | && Is_True_Constant (gnat_entity) | |
508 | && (((Nkind (Declaration_Node (gnat_entity)) | |
509 | == N_Object_Declaration) | |
510 | && Present (Expression (Declaration_Node (gnat_entity)))) | |
511 | || Present (Renamed_Object (gnat_entity)))); | |
512 | int inner_const_flag = const_flag; | |
513 | int static_p = Is_Statically_Allocated (gnat_entity); | |
514 | tree gnu_ext_name = NULL_TREE; | |
515 | ||
516 | if (Present (Renamed_Object (gnat_entity)) && ! definition) | |
517 | { | |
518 | if (kind == E_Exception) | |
519 | gnu_expr = gnat_to_gnu_entity (Renamed_Entity (gnat_entity), | |
520 | NULL_TREE, 0); | |
521 | else | |
522 | gnu_expr = gnat_to_gnu (Renamed_Object (gnat_entity)); | |
523 | } | |
524 | ||
525 | /* Get the type after elaborating the renamed object. */ | |
526 | gnu_type = gnat_to_gnu_type (Etype (gnat_entity)); | |
527 | ||
528 | /* If this is a loop variable, its type should be the base type. | |
529 | This is because the code for processing a loop determines whether | |
530 | a normal loop end test can be done by comparing the bounds of the | |
531 | loop against those of the base type, which is presumed to be the | |
532 | size used for computation. But this is not correct when the size | |
533 | of the subtype is smaller than the type. */ | |
534 | if (kind == E_Loop_Parameter) | |
535 | gnu_type = get_base_type (gnu_type); | |
536 | ||
537 | /* Reject non-renamed objects whose types are unconstrained arrays or | |
538 | any object whose type is a dummy type or VOID_TYPE. */ | |
539 | ||
540 | if ((TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE | |
541 | && No (Renamed_Object (gnat_entity))) | |
542 | || TYPE_IS_DUMMY_P (gnu_type) | |
543 | || TREE_CODE (gnu_type) == VOID_TYPE) | |
544 | { | |
545 | if (type_annotate_only) | |
546 | return error_mark_node; | |
547 | else | |
548 | gigi_abort (104); | |
549 | } | |
550 | ||
551 | /* If we are defining the object, see if it has a Size value and | |
acd47d2a AC |
552 | validate it if so. If we are not defining the object and a Size |
553 | clause applies, simply retrieve the value. We don't want to ignore | |
554 | the clause and it is expected to have been validated already. Then | |
555 | get the new type, if any. */ | |
70482933 RK |
556 | if (definition) |
557 | gnu_size = validate_size (Esize (gnat_entity), gnu_type, | |
558 | gnat_entity, VAR_DECL, 0, | |
559 | Has_Size_Clause (gnat_entity)); | |
acd47d2a AC |
560 | else if (Has_Size_Clause (gnat_entity)) |
561 | gnu_size = UI_To_gnu (Esize (gnat_entity), bitsizetype); | |
70482933 RK |
562 | |
563 | if (gnu_size != 0) | |
564 | { | |
565 | gnu_type | |
566 | = make_type_from_size (gnu_type, gnu_size, | |
567 | Has_Biased_Representation (gnat_entity)); | |
568 | ||
569 | if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0)) | |
570 | gnu_size = 0; | |
571 | } | |
572 | ||
573 | /* If this object has self-referential size, it must be a record with | |
574 | a default value. We are supposed to allocate an object of the | |
575 | maximum size in this case unless it is a constant with an | |
576 | initializing expression, in which case we can get the size from | |
577 | that. Note that the resulting size may still be a variable, so | |
578 | this may end up with an indirect allocation. */ | |
579 | ||
580 | if (No (Renamed_Object (gnat_entity)) | |
fbf5a39b | 581 | && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))) |
70482933 RK |
582 | { |
583 | if (gnu_expr != 0 && kind == E_Constant) | |
584 | { | |
585 | gnu_size = TYPE_SIZE (TREE_TYPE (gnu_expr)); | |
fbf5a39b AC |
586 | if (CONTAINS_PLACEHOLDER_P (gnu_size)) |
587 | gnu_size = build (WITH_RECORD_EXPR, bitsizetype, | |
588 | gnu_size, gnu_expr); | |
70482933 RK |
589 | } |
590 | ||
591 | /* We may have no GNU_EXPR because No_Initialization is | |
592 | set even though there's an Expression. */ | |
593 | else if (kind == E_Constant | |
594 | && (Nkind (Declaration_Node (gnat_entity)) | |
595 | == N_Object_Declaration) | |
596 | && Present (Expression (Declaration_Node (gnat_entity)))) | |
597 | gnu_size | |
598 | = TYPE_SIZE (gnat_to_gnu_type | |
599 | (Etype | |
600 | (Expression (Declaration_Node (gnat_entity))))); | |
601 | else | |
602 | gnu_size = max_size (TYPE_SIZE (gnu_type), 1); | |
603 | } | |
604 | ||
fbf5a39b AC |
605 | /* If the size is zero bytes, make it one byte since some linkers have |
606 | trouble with zero-sized objects. If the object will have a | |
607 | template, that will make it nonzero so don't bother. Also avoid | |
608 | doing that for an object renaming or an object with an address | |
609 | clause, as we would lose useful information on the view size | |
610 | (e.g. for null array slices) and we are not allocating the object | |
611 | here anyway. */ | |
70482933 RK |
612 | if (((gnu_size != 0 && integer_zerop (gnu_size)) |
613 | || (TYPE_SIZE (gnu_type) != 0 | |
614 | && integer_zerop (TYPE_SIZE (gnu_type)))) | |
615 | && (! Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity)) | |
fbf5a39b AC |
616 | || ! Is_Array_Type (Etype (gnat_entity))) |
617 | && ! Present (Renamed_Object (gnat_entity)) | |
618 | && ! Present (Address_Clause (gnat_entity))) | |
70482933 RK |
619 | gnu_size = bitsize_unit_node; |
620 | ||
621 | /* If an alignment is specified, use it if valid. Note that | |
622 | exceptions are objects but don't have alignments. */ | |
623 | if (kind != E_Exception && Known_Alignment (gnat_entity)) | |
624 | { | |
625 | if (No (Alignment (gnat_entity))) | |
626 | gigi_abort (125); | |
627 | ||
628 | align | |
629 | = validate_alignment (Alignment (gnat_entity), gnat_entity, | |
630 | TYPE_ALIGN (gnu_type)); | |
631 | } | |
632 | ||
633 | /* If this is an atomic object with no specified size and alignment, | |
634 | but where the size of the type is a constant, set the alignment to | |
635 | the lowest power of two greater than the size, or to the | |
636 | biggest meaningful alignment, whichever is smaller. */ | |
637 | ||
638 | if (Is_Atomic (gnat_entity) && gnu_size == 0 && align == 0 | |
639 | && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST) | |
640 | { | |
641 | if (! host_integerp (TYPE_SIZE (gnu_type), 1) | |
642 | || 0 <= compare_tree_int (TYPE_SIZE (gnu_type), | |
643 | BIGGEST_ALIGNMENT)) | |
644 | align = BIGGEST_ALIGNMENT; | |
645 | else | |
646 | align = ((unsigned int) 1 | |
647 | << (floor_log2 (tree_low_cst | |
648 | (TYPE_SIZE (gnu_type), 1) - 1) | |
649 | + 1)); | |
650 | } | |
651 | ||
70482933 RK |
652 | /* If the object is set to have atomic components, find the component |
653 | type and validate it. | |
654 | ||
655 | ??? Note that we ignore Has_Volatile_Components on objects; it's | |
656 | not at all clear what to do in that case. */ | |
657 | ||
658 | if (Has_Atomic_Components (gnat_entity)) | |
659 | { | |
660 | tree gnu_inner | |
661 | = (TREE_CODE (gnu_type) == ARRAY_TYPE | |
662 | ? TREE_TYPE (gnu_type) : gnu_type); | |
663 | ||
664 | while (TREE_CODE (gnu_inner) == ARRAY_TYPE | |
665 | && TYPE_MULTI_ARRAY_P (gnu_inner)) | |
666 | gnu_inner = TREE_TYPE (gnu_inner); | |
667 | ||
668 | check_ok_for_atomic (gnu_inner, gnat_entity, 1); | |
669 | } | |
670 | ||
07fc65c4 GB |
671 | /* Now check if the type of the object allows atomic access. Note |
672 | that we must test the type, even if this object has size and | |
673 | alignment to allow such access, because we will be going | |
674 | inside the padded record to assign to the object. We could fix | |
675 | this by always copying via an intermediate value, but it's not | |
676 | clear it's worth the effort. */ | |
677 | if (Is_Atomic (gnat_entity)) | |
678 | check_ok_for_atomic (gnu_type, gnat_entity, 0); | |
679 | ||
70482933 RK |
680 | /* If this is an aliased object with an unconstrained nominal subtype, |
681 | make a type that includes the template. */ | |
682 | if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity)) | |
683 | && Is_Array_Type (Etype (gnat_entity)) | |
684 | && ! type_annotate_only) | |
685 | { | |
686 | tree gnu_fat | |
687 | = TREE_TYPE (gnat_to_gnu_type (Base_Type (Etype (gnat_entity)))); | |
688 | tree gnu_temp_type | |
689 | = TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_fat)))); | |
690 | ||
691 | gnu_type | |
692 | = build_unc_object_type (gnu_temp_type, gnu_type, | |
693 | concat_id_with_name (gnu_entity_id, | |
694 | "UNC")); | |
695 | } | |
696 | ||
fbf5a39b AC |
697 | #ifdef MINIMUM_ATOMIC_ALIGNMENT |
698 | /* If the size is a constant and no alignment is specified, force | |
699 | the alignment to be the minimum valid atomic alignment. The | |
700 | restriction on constant size avoids problems with variable-size | |
701 | temporaries; if the size is variable, there's no issue with | |
702 | atomic access. Also don't do this for a constant, since it isn't | |
703 | necessary and can interfere with constant replacement. Finally, | |
704 | do not do it for Out parameters since that creates an | |
705 | size inconsistency with In parameters. */ | |
706 | if (align == 0 && MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type) | |
707 | && ! FLOAT_TYPE_P (gnu_type) | |
708 | && ! const_flag && No (Renamed_Object (gnat_entity)) | |
709 | && ! imported_p && No (Address_Clause (gnat_entity)) | |
710 | && kind != E_Out_Parameter | |
711 | && (gnu_size != 0 ? TREE_CODE (gnu_size) == INTEGER_CST | |
712 | : TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST)) | |
713 | align = MINIMUM_ATOMIC_ALIGNMENT; | |
714 | #endif | |
715 | ||
716 | /* Make a new type with the desired size and alignment, if needed. */ | |
717 | gnu_type = maybe_pad_type (gnu_type, gnu_size, align, | |
718 | gnat_entity, "PAD", 0, definition, 1); | |
719 | ||
720 | /* Make a volatile version of this object's type if we are to | |
721 | make the object volatile. Note that 13.3(19) says that we | |
722 | should treat other types of objects as volatile as well. */ | |
723 | if ((Treat_As_Volatile (gnat_entity) | |
724 | || Is_Exported (gnat_entity) | |
725 | || Is_Imported (gnat_entity) | |
726 | || Present (Address_Clause (gnat_entity))) | |
727 | && ! TYPE_VOLATILE (gnu_type)) | |
728 | gnu_type = build_qualified_type (gnu_type, | |
729 | (TYPE_QUALS (gnu_type) | |
730 | | TYPE_QUAL_VOLATILE)); | |
731 | ||
70482933 RK |
732 | /* Convert the expression to the type of the object except in the |
733 | case where the object's type is unconstrained or the object's type | |
734 | is a padded record whose field is of self-referential size. In | |
735 | the former case, converting will generate unnecessary evaluations | |
736 | of the CONSTRUCTOR to compute the size and in the latter case, we | |
737 | want to only copy the actual data. */ | |
738 | if (gnu_expr != 0 | |
739 | && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE | |
fbf5a39b | 740 | && ! CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)) |
70482933 RK |
741 | && ! (TREE_CODE (gnu_type) == RECORD_TYPE |
742 | && TYPE_IS_PADDING_P (gnu_type) | |
fbf5a39b | 743 | && (CONTAINS_PLACEHOLDER_P |
70482933 RK |
744 | (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type))))))) |
745 | gnu_expr = convert (gnu_type, gnu_expr); | |
746 | ||
747 | /* See if this is a renaming. If this is a constant renaming, | |
748 | treat it as a normal variable whose initial value is what | |
749 | is being renamed. We cannot do this if the type is | |
750 | unconstrained or class-wide. | |
751 | ||
752 | Otherwise, if what we are renaming is a reference, we can simply | |
753 | return a stabilized version of that reference, after forcing | |
754 | any SAVE_EXPRs to be evaluated. But, if this is at global level, | |
755 | we can only do this if we know no SAVE_EXPRs will be made. | |
756 | Otherwise, make this into a constant pointer to the object we are | |
757 | to rename. */ | |
758 | ||
759 | if (Present (Renamed_Object (gnat_entity))) | |
760 | { | |
761 | /* If the renamed object had padding, strip off the reference | |
762 | to the inner object and reset our type. */ | |
763 | if (TREE_CODE (gnu_expr) == COMPONENT_REF | |
764 | && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))) | |
765 | == RECORD_TYPE) | |
766 | && (TYPE_IS_PADDING_P | |
767 | (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))) | |
768 | { | |
769 | gnu_expr = TREE_OPERAND (gnu_expr, 0); | |
770 | gnu_type = TREE_TYPE (gnu_expr); | |
771 | } | |
772 | ||
773 | if (const_flag | |
774 | && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE | |
775 | && TYPE_MODE (gnu_type) != BLKmode | |
776 | && Ekind (Etype (gnat_entity)) != E_Class_Wide_Type | |
777 | && !Is_Array_Type (Etype (gnat_entity))) | |
778 | ; | |
779 | ||
780 | /* If this is a declaration or reference, we can just use that | |
781 | declaration or reference as this entity. */ | |
782 | else if ((DECL_P (gnu_expr) | |
783 | || TREE_CODE_CLASS (TREE_CODE (gnu_expr)) == 'r') | |
784 | && ! Materialize_Entity (gnat_entity) | |
785 | && (! global_bindings_p () | |
786 | || (staticp (gnu_expr) | |
787 | && ! TREE_SIDE_EFFECTS (gnu_expr)))) | |
788 | { | |
789 | set_lineno (gnat_entity, ! global_bindings_p ()); | |
790 | gnu_decl = gnat_stabilize_reference (gnu_expr, 1); | |
791 | save_gnu_tree (gnat_entity, gnu_decl, 1); | |
792 | saved = 1; | |
793 | ||
794 | if (! global_bindings_p ()) | |
795 | expand_expr_stmt (build1 (CONVERT_EXPR, void_type_node, | |
796 | gnu_decl)); | |
797 | break; | |
798 | } | |
799 | else | |
800 | { | |
801 | inner_const_flag = TREE_READONLY (gnu_expr); | |
802 | const_flag = 1; | |
803 | gnu_type = build_reference_type (gnu_type); | |
804 | gnu_expr = build_unary_op (ADDR_EXPR, gnu_type, gnu_expr); | |
805 | gnu_size = 0; | |
806 | used_by_ref = 1; | |
807 | } | |
808 | } | |
809 | ||
810 | /* If this is an aliased object whose nominal subtype is unconstrained, | |
811 | the object is a record that contains both the template and | |
812 | the object. If there is an initializer, it will have already | |
813 | been converted to the right type, but we need to create the | |
814 | template if there is no initializer. */ | |
815 | else if (definition && TREE_CODE (gnu_type) == RECORD_TYPE | |
fbf5a39b AC |
816 | && (TYPE_CONTAINS_TEMPLATE_P (gnu_type) |
817 | /* Beware that padding might have been introduced | |
818 | via maybe_pad_type above. */ | |
819 | || (TYPE_IS_PADDING_P (gnu_type) | |
820 | && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type))) | |
821 | == RECORD_TYPE | |
822 | && TYPE_CONTAINS_TEMPLATE_P | |
823 | (TREE_TYPE (TYPE_FIELDS (gnu_type))))) | |
70482933 | 824 | && gnu_expr == 0) |
fbf5a39b AC |
825 | { |
826 | tree template_field | |
827 | = TYPE_IS_PADDING_P (gnu_type) | |
828 | ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type))) | |
829 | : TYPE_FIELDS (gnu_type); | |
830 | ||
831 | gnu_expr | |
832 | = gnat_build_constructor | |
70482933 RK |
833 | (gnu_type, |
834 | tree_cons | |
fbf5a39b AC |
835 | (template_field, |
836 | build_template (TREE_TYPE (template_field), | |
837 | TREE_TYPE (TREE_CHAIN (template_field)), | |
838 | NULL_TREE), | |
70482933 | 839 | NULL_TREE)); |
fbf5a39b | 840 | } |
70482933 RK |
841 | |
842 | /* If this is a pointer and it does not have an initializing | |
fbf5a39b AC |
843 | expression, initialize it to NULL, unless the obect is |
844 | imported. */ | |
70482933 RK |
845 | if (definition |
846 | && (POINTER_TYPE_P (gnu_type) || TYPE_FAT_POINTER_P (gnu_type)) | |
fbf5a39b | 847 | && !Is_Imported (gnat_entity) |
70482933 RK |
848 | && gnu_expr == 0) |
849 | gnu_expr = integer_zero_node; | |
850 | ||
851 | /* If we are defining the object and it has an Address clause we must | |
852 | get the address expression from the saved GCC tree for the | |
853 | object if the object has a Freeze_Node. Otherwise, we elaborate | |
854 | the address expression here since the front-end has guaranteed | |
855 | in that case that the elaboration has no effects. Note that | |
856 | only the latter mechanism is currently in use. */ | |
857 | if (definition && Present (Address_Clause (gnat_entity))) | |
858 | { | |
859 | tree gnu_address | |
860 | = (present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) | |
861 | : gnat_to_gnu (Expression (Address_Clause (gnat_entity)))); | |
862 | ||
863 | save_gnu_tree (gnat_entity, NULL_TREE, 0); | |
864 | ||
865 | /* Ignore the size. It's either meaningless or was handled | |
866 | above. */ | |
867 | gnu_size = 0; | |
868 | gnu_type = build_reference_type (gnu_type); | |
869 | gnu_address = convert (gnu_type, gnu_address); | |
870 | used_by_ref = 1; | |
871 | const_flag = ! Is_Public (gnat_entity); | |
872 | ||
873 | /* If we don't have an initializing expression for the underlying | |
874 | variable, the initializing expression for the pointer is the | |
875 | specified address. Otherwise, we have to make a COMPOUND_EXPR | |
876 | to assign both the address and the initial value. */ | |
877 | if (gnu_expr == 0) | |
878 | gnu_expr = gnu_address; | |
879 | else | |
880 | gnu_expr | |
881 | = build (COMPOUND_EXPR, gnu_type, | |
882 | build_binary_op | |
883 | (MODIFY_EXPR, NULL_TREE, | |
884 | build_unary_op (INDIRECT_REF, NULL_TREE, | |
885 | gnu_address), | |
886 | gnu_expr), | |
887 | gnu_address); | |
888 | } | |
889 | ||
890 | /* If it has an address clause and we are not defining it, mark it | |
891 | as an indirect object. Likewise for Stdcall objects that are | |
892 | imported. */ | |
893 | if ((! definition && Present (Address_Clause (gnat_entity))) | |
894 | || (Is_Imported (gnat_entity) | |
895 | && Convention (gnat_entity) == Convention_Stdcall)) | |
896 | { | |
897 | gnu_type = build_reference_type (gnu_type); | |
898 | gnu_size = 0; | |
899 | used_by_ref = 1; | |
900 | } | |
901 | ||
902 | /* If we are at top level and this object is of variable size, | |
903 | make the actual type a hidden pointer to the real type and | |
904 | make the initializer be a memory allocation and initialization. | |
905 | Likewise for objects we aren't defining (presumed to be | |
906 | external references from other packages), but there we do | |
907 | not set up an initialization. | |
908 | ||
909 | If the object's size overflows, make an allocator too, so that | |
910 | Storage_Error gets raised. Note that we will never free | |
911 | such memory, so we presume it never will get allocated. */ | |
912 | ||
913 | if (! allocatable_size_p (TYPE_SIZE_UNIT (gnu_type), | |
914 | global_bindings_p () || ! definition | |
915 | || static_p) | |
916 | || (gnu_size != 0 | |
917 | && ! allocatable_size_p (gnu_size, | |
918 | global_bindings_p () || ! definition | |
919 | || static_p))) | |
920 | { | |
921 | gnu_type = build_reference_type (gnu_type); | |
922 | gnu_size = 0; | |
923 | used_by_ref = 1; | |
924 | const_flag = 1; | |
925 | ||
926 | /* Get the data part of GNU_EXPR in case this was a | |
927 | aliased object whose nominal subtype is unconstrained. | |
928 | In that case the pointer above will be a thin pointer and | |
929 | build_allocator will automatically make the template and | |
930 | constructor already made above. */ | |
931 | ||
932 | if (definition) | |
933 | { | |
934 | tree gnu_alloc_type = TREE_TYPE (gnu_type); | |
935 | ||
936 | if (TREE_CODE (gnu_alloc_type) == RECORD_TYPE | |
937 | && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type)) | |
938 | { | |
939 | gnu_alloc_type | |
940 | = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_alloc_type))); | |
941 | gnu_expr | |
942 | = build_component_ref | |
943 | (gnu_expr, NULL_TREE, | |
657a9dd9 | 944 | TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))), 0); |
70482933 RK |
945 | } |
946 | ||
947 | if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST | |
948 | && TREE_CONSTANT_OVERFLOW (TYPE_SIZE_UNIT (gnu_alloc_type)) | |
949 | && ! Is_Imported (gnat_entity)) | |
950 | post_error ("Storage_Error will be raised at run-time?", | |
951 | gnat_entity); | |
952 | ||
953 | gnu_expr = build_allocator (gnu_alloc_type, gnu_expr, | |
fbf5a39b | 954 | gnu_type, 0, 0, gnat_entity); |
70482933 RK |
955 | } |
956 | else | |
957 | { | |
958 | gnu_expr = 0; | |
959 | const_flag = 0; | |
960 | } | |
961 | } | |
962 | ||
963 | /* If this object would go into the stack and has an alignment | |
964 | larger than the default largest alignment, make a variable | |
965 | to hold the "aligning type" with a modified initial value, | |
966 | if any, then point to it and make that the value of this | |
967 | variable, which is now indirect. */ | |
968 | ||
969 | if (! global_bindings_p () && ! static_p && definition | |
970 | && ! imported_p && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT) | |
971 | { | |
972 | tree gnu_new_type | |
973 | = make_aligning_type (gnu_type, TYPE_ALIGN (gnu_type), | |
974 | TYPE_SIZE_UNIT (gnu_type)); | |
975 | tree gnu_new_var; | |
976 | ||
70482933 RK |
977 | set_lineno (gnat_entity, 1); |
978 | gnu_new_var | |
979 | = create_var_decl (create_concat_name (gnat_entity, "ALIGN"), | |
980 | NULL_TREE, gnu_new_type, gnu_expr, | |
981 | 0, 0, 0, 0, 0); | |
982 | ||
fbf5a39b AC |
983 | if (gnu_expr != 0) |
984 | expand_expr_stmt | |
985 | (build_binary_op | |
986 | (MODIFY_EXPR, NULL_TREE, | |
987 | build_component_ref (gnu_new_var, NULL_TREE, | |
657a9dd9 | 988 | TYPE_FIELDS (gnu_new_type), 0), |
fbf5a39b AC |
989 | gnu_expr)); |
990 | ||
70482933 RK |
991 | gnu_type = build_reference_type (gnu_type); |
992 | gnu_expr | |
993 | = build_unary_op | |
994 | (ADDR_EXPR, gnu_type, | |
995 | build_component_ref (gnu_new_var, NULL_TREE, | |
657a9dd9 | 996 | TYPE_FIELDS (gnu_new_type), 0)); |
70482933 RK |
997 | |
998 | gnu_size = 0; | |
999 | used_by_ref = 1; | |
1000 | const_flag = 1; | |
1001 | } | |
1002 | ||
1003 | /* Convert the expression to the type of the object except in the | |
1004 | case where the object's type is unconstrained or the object's type | |
1005 | is a padded record whose field is of self-referential size. In | |
1006 | the former case, converting will generate unnecessary evaluations | |
1007 | of the CONSTRUCTOR to compute the size and in the latter case, we | |
1008 | want to only copy the actual data. */ | |
1009 | if (gnu_expr != 0 | |
1010 | && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE | |
fbf5a39b | 1011 | && ! CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)) |
70482933 RK |
1012 | && ! (TREE_CODE (gnu_type) == RECORD_TYPE |
1013 | && TYPE_IS_PADDING_P (gnu_type) | |
fbf5a39b | 1014 | && (CONTAINS_PLACEHOLDER_P |
70482933 RK |
1015 | (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type))))))) |
1016 | gnu_expr = convert (gnu_type, gnu_expr); | |
1017 | ||
1018 | /* This name is external or there was a name specified, use it. | |
1019 | Don't use the Interface_Name if there is an address clause. | |
1020 | (see CD30005). */ | |
1021 | if ((Present (Interface_Name (gnat_entity)) | |
1022 | && No (Address_Clause (gnat_entity))) | |
1023 | || (Is_Public (gnat_entity) | |
1024 | && (! Is_Imported (gnat_entity) || Is_Exported (gnat_entity)))) | |
1025 | gnu_ext_name = create_concat_name (gnat_entity, 0); | |
1026 | ||
1027 | if (const_flag) | |
1028 | gnu_type = build_qualified_type (gnu_type, (TYPE_QUALS (gnu_type) | |
1029 | | TYPE_QUAL_CONST)); | |
1030 | ||
1031 | /* If this is constant initialized to a static constant and the | |
1032 | object has an aggregrate type, force it to be statically | |
1033 | allocated. */ | |
1034 | if (const_flag && gnu_expr && TREE_CONSTANT (gnu_expr) | |
1035 | && host_integerp (TYPE_SIZE_UNIT (gnu_type), 1) | |
1036 | && (AGGREGATE_TYPE_P (gnu_type) | |
1037 | && ! (TREE_CODE (gnu_type) == RECORD_TYPE | |
1038 | && TYPE_IS_PADDING_P (gnu_type)))) | |
1039 | static_p = 1; | |
1040 | ||
1041 | set_lineno (gnat_entity, ! global_bindings_p ()); | |
1042 | gnu_decl = create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type, | |
1043 | gnu_expr, const_flag, | |
1044 | Is_Public (gnat_entity), | |
1045 | imported_p || !definition, | |
1046 | static_p, attr_list); | |
1047 | ||
1048 | DECL_BY_REF_P (gnu_decl) = used_by_ref; | |
1049 | DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag; | |
1050 | ||
5c1c8a03 AC |
1051 | /* If we have an address clause and we've made this indirect, it's |
1052 | not enough to merely mark the type as volatile since volatile | |
1053 | references only conflict with other volatile references while this | |
1054 | reference must conflict with all other references. So ensure that | |
1055 | the dereferenced value has alias set 0. */ | |
1056 | if (Present (Address_Clause (gnat_entity)) && used_by_ref) | |
1057 | DECL_POINTER_ALIAS_SET (gnu_decl) = 0; | |
1058 | ||
70482933 RK |
1059 | if (definition && DECL_SIZE (gnu_decl) != 0 |
1060 | && gnu_block_stack != 0 | |
1061 | && TREE_VALUE (gnu_block_stack) != 0 | |
1062 | && (TREE_CODE (DECL_SIZE (gnu_decl)) != INTEGER_CST | |
1063 | || (flag_stack_check && ! STACK_CHECK_BUILTIN | |
1064 | && 0 < compare_tree_int (DECL_SIZE_UNIT (gnu_decl), | |
1065 | STACK_CHECK_MAX_VAR_SIZE)))) | |
1066 | update_setjmp_buf (TREE_VALUE (gnu_block_stack)); | |
1067 | ||
c2d7fe59 RK |
1068 | /* If this is a public constant or we're not optimizing and we're not |
1069 | making a VAR_DECL for it, make one just for export or debugger | |
1070 | use. Likewise if the address is taken or if the object or type is | |
1071 | aliased. */ | |
70482933 RK |
1072 | if (definition && TREE_CODE (gnu_decl) == CONST_DECL |
1073 | && (Is_Public (gnat_entity) | |
c2d7fe59 | 1074 | || optimize == 0 |
70482933 RK |
1075 | || Address_Taken (gnat_entity) |
1076 | || Is_Aliased (gnat_entity) | |
1077 | || Is_Aliased (Etype (gnat_entity)))) | |
fbf5a39b | 1078 | SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, |
e2500fed | 1079 | create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type, |
70482933 | 1080 | gnu_expr, 0, Is_Public (gnat_entity), 0, |
e2500fed | 1081 | static_p, 0)); |
70482933 | 1082 | |
70482933 RK |
1083 | /* If this is declared in a block that contains an block with an |
1084 | exception handler, we must force this variable in memory to | |
1085 | suppress an invalid optimization. */ | |
07fc65c4 GB |
1086 | if (Has_Nested_Block_With_Handler (Scope (gnat_entity)) |
1087 | && Exception_Mechanism != GCC_ZCX) | |
70482933 | 1088 | { |
dffd7eb6 | 1089 | gnat_mark_addressable (gnu_decl); |
70482933 RK |
1090 | flush_addressof (gnu_decl); |
1091 | } | |
1092 | ||
1093 | /* Back-annotate the Alignment of the object if not already in the | |
79503fdd GB |
1094 | tree. Likewise for Esize if the object is of a constant size. |
1095 | But if the "object" is actually a pointer to an object, the | |
1096 | alignment and size are the same as teh type, so don't back-annotate | |
1097 | the values for the pointer. */ | |
1098 | if (! used_by_ref && Unknown_Alignment (gnat_entity)) | |
70482933 RK |
1099 | Set_Alignment (gnat_entity, |
1100 | UI_From_Int (DECL_ALIGN (gnu_decl) / BITS_PER_UNIT)); | |
1101 | ||
79503fdd | 1102 | if (! used_by_ref && Unknown_Esize (gnat_entity) |
70482933 RK |
1103 | && DECL_SIZE (gnu_decl) != 0) |
1104 | { | |
1105 | tree gnu_back_size = DECL_SIZE (gnu_decl); | |
1106 | ||
1107 | if (TREE_CODE (TREE_TYPE (gnu_decl)) == RECORD_TYPE | |
1108 | && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_decl))) | |
1109 | gnu_back_size | |
1110 | = TYPE_SIZE (TREE_TYPE (TREE_CHAIN | |
1111 | (TYPE_FIELDS (TREE_TYPE (gnu_decl))))); | |
1112 | ||
1113 | Set_Esize (gnat_entity, annotate_value (gnu_back_size)); | |
1114 | } | |
1115 | } | |
1116 | break; | |
1117 | ||
1118 | case E_Void: | |
1119 | /* Return a TYPE_DECL for "void" that we previously made. */ | |
1120 | gnu_decl = void_type_decl_node; | |
1121 | break; | |
1122 | ||
1123 | case E_Enumeration_Type: | |
1124 | /* A special case, for the types Character and Wide_Character in | |
1125 | Standard, we do not list all the literals. So if the literals | |
1126 | are not specified, make this an unsigned type. */ | |
1127 | if (No (First_Literal (gnat_entity))) | |
1128 | { | |
1129 | gnu_type = make_unsigned_type (esize); | |
1130 | break; | |
1131 | } | |
1132 | ||
1133 | /* Normal case of non-character type, or non-Standard character type */ | |
1134 | { | |
1135 | /* Here we have a list of enumeral constants in First_Literal. | |
1136 | We make a CONST_DECL for each and build into GNU_LITERAL_LIST | |
1137 | the list to be places into TYPE_FIELDS. Each node in the list | |
1138 | is a TREE_LIST node whose TREE_VALUE is the literal name | |
1139 | and whose TREE_PURPOSE is the value of the literal. | |
1140 | ||
1141 | Esize contains the number of bits needed to represent the enumeral | |
1142 | type, Type_Low_Bound also points to the first literal and | |
1143 | Type_High_Bound points to the last literal. */ | |
1144 | ||
1145 | Entity_Id gnat_literal; | |
1146 | tree gnu_literal_list = NULL_TREE; | |
1147 | ||
1148 | if (Is_Unsigned_Type (gnat_entity)) | |
1149 | gnu_type = make_unsigned_type (esize); | |
1150 | else | |
1151 | gnu_type = make_signed_type (esize); | |
1152 | ||
1153 | TREE_SET_CODE (gnu_type, ENUMERAL_TYPE); | |
1154 | ||
1155 | for (gnat_literal = First_Literal (gnat_entity); | |
1156 | Present (gnat_literal); | |
1157 | gnat_literal = Next_Literal (gnat_literal)) | |
1158 | { | |
1159 | tree gnu_value = UI_To_gnu (Enumeration_Rep (gnat_literal), | |
1160 | gnu_type); | |
1161 | tree gnu_literal | |
1162 | = create_var_decl (get_entity_name (gnat_literal), | |
1163 | 0, gnu_type, gnu_value, 1, 0, 0, 0, 0); | |
1164 | ||
1165 | save_gnu_tree (gnat_literal, gnu_literal, 0); | |
1166 | gnu_literal_list = tree_cons (DECL_NAME (gnu_literal), | |
1167 | gnu_value, gnu_literal_list); | |
1168 | } | |
1169 | ||
1170 | TYPE_FIELDS (gnu_type) = nreverse (gnu_literal_list); | |
1171 | ||
1172 | /* Note that the bounds are updated at the end of this function | |
1173 | because to avoid an infinite recursion when we get the bounds of | |
1174 | this type, since those bounds are objects of this type. */ | |
1175 | } | |
1176 | break; | |
1177 | ||
1178 | case E_Signed_Integer_Type: | |
1179 | case E_Ordinary_Fixed_Point_Type: | |
1180 | case E_Decimal_Fixed_Point_Type: | |
1181 | /* For integer types, just make a signed type the appropriate number | |
1182 | of bits. */ | |
1183 | gnu_type = make_signed_type (esize); | |
1184 | break; | |
1185 | ||
1186 | case E_Modular_Integer_Type: | |
1187 | /* For modular types, make the unsigned type of the proper number of | |
1188 | bits and then set up the modulus, if required. */ | |
1189 | { | |
1190 | enum machine_mode mode; | |
1191 | tree gnu_modulus; | |
1192 | tree gnu_high = 0; | |
1193 | ||
1194 | if (Is_Packed_Array_Type (gnat_entity)) | |
1195 | esize = UI_To_Int (RM_Size (gnat_entity)); | |
1196 | ||
1197 | /* Find the smallest mode at least ESIZE bits wide and make a class | |
1198 | using that mode. */ | |
1199 | ||
1200 | for (mode = GET_CLASS_NARROWEST_MODE (MODE_INT); | |
1201 | GET_MODE_BITSIZE (mode) < esize; | |
1202 | mode = GET_MODE_WIDER_MODE (mode)) | |
1203 | ; | |
1204 | ||
1205 | gnu_type = make_unsigned_type (GET_MODE_BITSIZE (mode)); | |
1206 | TYPE_PACKED_ARRAY_TYPE_P (gnu_type) | |
1207 | = Is_Packed_Array_Type (gnat_entity); | |
1208 | ||
1209 | /* Get the modulus in this type. If it overflows, assume it is because | |
1210 | it is equal to 2**Esize. Note that there is no overflow checking | |
1211 | done on unsigned type, so we detect the overflow by looking for | |
1212 | a modulus of zero, which is otherwise invalid. */ | |
1213 | gnu_modulus = UI_To_gnu (Modulus (gnat_entity), gnu_type); | |
1214 | ||
1215 | if (! integer_zerop (gnu_modulus)) | |
1216 | { | |
1217 | TYPE_MODULAR_P (gnu_type) = 1; | |
e2500fed | 1218 | SET_TYPE_MODULUS (gnu_type, gnu_modulus); |
70482933 RK |
1219 | gnu_high = fold (build (MINUS_EXPR, gnu_type, gnu_modulus, |
1220 | convert (gnu_type, integer_one_node))); | |
1221 | } | |
1222 | ||
1223 | /* If we have to set TYPE_PRECISION different from its natural value, | |
1224 | make a subtype to do do. Likewise if there is a modulus and | |
1225 | it is not one greater than TYPE_MAX_VALUE. */ | |
1226 | if (TYPE_PRECISION (gnu_type) != esize | |
1227 | || (TYPE_MODULAR_P (gnu_type) | |
1228 | && ! tree_int_cst_equal (TYPE_MAX_VALUE (gnu_type), gnu_high))) | |
1229 | { | |
1230 | tree gnu_subtype = make_node (INTEGER_TYPE); | |
1231 | ||
1232 | TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "UMT"); | |
1233 | TREE_TYPE (gnu_subtype) = gnu_type; | |
1234 | TYPE_MIN_VALUE (gnu_subtype) = TYPE_MIN_VALUE (gnu_type); | |
1235 | TYPE_MAX_VALUE (gnu_subtype) | |
1236 | = TYPE_MODULAR_P (gnu_type) | |
1237 | ? gnu_high : TYPE_MAX_VALUE (gnu_type); | |
1238 | TYPE_PRECISION (gnu_subtype) = esize; | |
1239 | TREE_UNSIGNED (gnu_subtype) = 1; | |
1240 | TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1; | |
1241 | TYPE_PACKED_ARRAY_TYPE_P (gnu_subtype) | |
1242 | = Is_Packed_Array_Type (gnat_entity); | |
1243 | layout_type (gnu_subtype); | |
1244 | ||
1245 | gnu_type = gnu_subtype; | |
1246 | } | |
1247 | } | |
1248 | break; | |
1249 | ||
1250 | case E_Signed_Integer_Subtype: | |
1251 | case E_Enumeration_Subtype: | |
1252 | case E_Modular_Integer_Subtype: | |
1253 | case E_Ordinary_Fixed_Point_Subtype: | |
1254 | case E_Decimal_Fixed_Point_Subtype: | |
1255 | ||
1256 | /* For integral subtypes, we make a new INTEGER_TYPE. Note | |
1257 | that we do not want to call build_range_type since we would | |
1258 | like each subtype node to be distinct. This will be important | |
1259 | when memory aliasing is implemented. | |
1260 | ||
1261 | The TREE_TYPE field of the INTEGER_TYPE we make points to the | |
1262 | parent type; this fact is used by the arithmetic conversion | |
1263 | functions. | |
1264 | ||
1265 | We elaborate the Ancestor_Subtype if it is not in the current | |
1266 | unit and one of our bounds is non-static. We do this to ensure | |
1267 | consistent naming in the case where several subtypes share the same | |
1268 | bounds by always elaborating the first such subtype first, thus | |
1269 | using its name. */ | |
1270 | ||
1271 | if (definition == 0 | |
1272 | && Present (Ancestor_Subtype (gnat_entity)) | |
1273 | && ! In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity)) | |
1274 | && (! Compile_Time_Known_Value (Type_Low_Bound (gnat_entity)) | |
1275 | || ! Compile_Time_Known_Value (Type_High_Bound (gnat_entity)))) | |
1276 | gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), | |
1277 | gnu_expr, definition); | |
1278 | ||
1279 | gnu_type = make_node (INTEGER_TYPE); | |
1280 | if (Is_Packed_Array_Type (gnat_entity)) | |
1281 | { | |
70482933 RK |
1282 | esize = UI_To_Int (RM_Size (gnat_entity)); |
1283 | TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1; | |
1284 | } | |
1285 | ||
1286 | TYPE_PRECISION (gnu_type) = esize; | |
1287 | TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity)); | |
1288 | ||
1289 | TYPE_MIN_VALUE (gnu_type) | |
1290 | = convert (TREE_TYPE (gnu_type), | |
1291 | elaborate_expression (Type_Low_Bound (gnat_entity), | |
1292 | gnat_entity, | |
1293 | get_identifier ("L"), definition, 1, | |
1294 | Needs_Debug_Info (gnat_entity))); | |
1295 | ||
1296 | TYPE_MAX_VALUE (gnu_type) | |
1297 | = convert (TREE_TYPE (gnu_type), | |
1298 | elaborate_expression (Type_High_Bound (gnat_entity), | |
1299 | gnat_entity, | |
1300 | get_identifier ("U"), definition, 1, | |
1301 | Needs_Debug_Info (gnat_entity))); | |
1302 | ||
1303 | /* One of the above calls might have caused us to be elaborated, | |
1304 | so don't blow up if so. */ | |
1305 | if (present_gnu_tree (gnat_entity)) | |
1306 | { | |
1307 | maybe_present = 1; | |
1308 | break; | |
1309 | } | |
1310 | ||
1311 | TYPE_BIASED_REPRESENTATION_P (gnu_type) | |
1312 | = Has_Biased_Representation (gnat_entity); | |
1313 | ||
1314 | /* This should be an unsigned type if the lower bound is constant | |
1315 | and non-negative or if the base type is unsigned; a signed type | |
1316 | otherwise. */ | |
1317 | TREE_UNSIGNED (gnu_type) | |
1318 | = (TREE_UNSIGNED (TREE_TYPE (gnu_type)) | |
1319 | || (TREE_CODE (TYPE_MIN_VALUE (gnu_type)) == INTEGER_CST | |
1320 | && TREE_INT_CST_HIGH (TYPE_MIN_VALUE (gnu_type)) >= 0) | |
1321 | || TYPE_BIASED_REPRESENTATION_P (gnu_type) | |
1322 | || Is_Unsigned_Type (gnat_entity)); | |
1323 | ||
1324 | layout_type (gnu_type); | |
1325 | ||
6e937c1c AC |
1326 | /* If the type we are dealing with is to represent a packed array, |
1327 | we need to have the bits left justified on big-endian targets | |
1328 | (see exp_packd.ads). We build a record with a bitfield of the | |
1329 | appropriate size to achieve this. */ | |
70482933 RK |
1330 | if (Is_Packed_Array_Type (gnat_entity) && BYTES_BIG_ENDIAN) |
1331 | { | |
1332 | tree gnu_field_type = gnu_type; | |
1333 | tree gnu_field; | |
1334 | ||
1335 | TYPE_RM_SIZE_INT (gnu_field_type) | |
1336 | = UI_To_gnu (RM_Size (gnat_entity), bitsizetype); | |
1337 | gnu_type = make_node (RECORD_TYPE); | |
1338 | TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "LJM"); | |
1339 | TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_field_type); | |
1340 | TYPE_PACKED (gnu_type) = 1; | |
6e937c1c AC |
1341 | |
1342 | /* Don't notify the field as "addressable", since we won't be taking | |
1343 | it's address and it would prevent create_field_decl from making a | |
1344 | bitfield. */ | |
70482933 | 1345 | gnu_field = create_field_decl (get_identifier ("OBJECT"), |
6e937c1c AC |
1346 | gnu_field_type, gnu_type, 1, 0, 0, 0); |
1347 | ||
70482933 RK |
1348 | finish_record_type (gnu_type, gnu_field, 0, 0); |
1349 | TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_type) = 1; | |
e2500fed | 1350 | SET_TYPE_ADA_SIZE (gnu_type, bitsize_int (esize)); |
70482933 RK |
1351 | } |
1352 | ||
1353 | break; | |
1354 | ||
1355 | case E_Floating_Point_Type: | |
1356 | /* If this is a VAX floating-point type, use an integer of the proper | |
1357 | size. All the operations will be handled with ASM statements. */ | |
1358 | if (Vax_Float (gnat_entity)) | |
1359 | { | |
1360 | gnu_type = make_signed_type (esize); | |
1361 | TYPE_VAX_FLOATING_POINT_P (gnu_type) = 1; | |
fbf5a39b | 1362 | SET_TYPE_DIGITS_VALUE (gnu_type, |
12e0c41c AC |
1363 | UI_To_gnu (Digits_Value (gnat_entity), |
1364 | sizetype)); | |
70482933 RK |
1365 | break; |
1366 | } | |
1367 | ||
1368 | /* The type of the Low and High bounds can be our type if this is | |
1369 | a type from Standard, so set them at the end of the function. */ | |
1370 | gnu_type = make_node (REAL_TYPE); | |
12e0c41c | 1371 | TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize); |
70482933 RK |
1372 | layout_type (gnu_type); |
1373 | break; | |
1374 | ||
1375 | case E_Floating_Point_Subtype: | |
1376 | if (Vax_Float (gnat_entity)) | |
1377 | { | |
1378 | gnu_type = gnat_to_gnu_type (Etype (gnat_entity)); | |
1379 | break; | |
1380 | } | |
1381 | ||
1382 | { | |
70482933 RK |
1383 | if (definition == 0 |
1384 | && Present (Ancestor_Subtype (gnat_entity)) | |
1385 | && ! In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity)) | |
1386 | && (! Compile_Time_Known_Value (Type_Low_Bound (gnat_entity)) | |
1387 | || ! Compile_Time_Known_Value (Type_High_Bound (gnat_entity)))) | |
1388 | gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), | |
1389 | gnu_expr, definition); | |
1390 | ||
70482933 RK |
1391 | gnu_type = make_node (REAL_TYPE); |
1392 | TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity)); | |
0d77ab84 | 1393 | TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize); |
70482933 RK |
1394 | |
1395 | TYPE_MIN_VALUE (gnu_type) | |
1396 | = convert (TREE_TYPE (gnu_type), | |
1397 | elaborate_expression (Type_Low_Bound (gnat_entity), | |
1398 | gnat_entity, get_identifier ("L"), | |
1399 | definition, 1, | |
1400 | Needs_Debug_Info (gnat_entity))); | |
1401 | ||
1402 | TYPE_MAX_VALUE (gnu_type) | |
1403 | = convert (TREE_TYPE (gnu_type), | |
1404 | elaborate_expression (Type_High_Bound (gnat_entity), | |
1405 | gnat_entity, get_identifier ("U"), | |
1406 | definition, 1, | |
1407 | Needs_Debug_Info (gnat_entity))); | |
1408 | ||
1409 | /* One of the above calls might have caused us to be elaborated, | |
1410 | so don't blow up if so. */ | |
1411 | if (present_gnu_tree (gnat_entity)) | |
1412 | { | |
1413 | maybe_present = 1; | |
1414 | break; | |
1415 | } | |
1416 | ||
1417 | layout_type (gnu_type); | |
1418 | } | |
1419 | break; | |
1420 | ||
1421 | /* Array and String Types and Subtypes | |
1422 | ||
1423 | Unconstrained array types are represented by E_Array_Type and | |
1424 | constrained array types are represented by E_Array_Subtype. There | |
1425 | are no actual objects of an unconstrained array type; all we have | |
1426 | are pointers to that type. | |
1427 | ||
1428 | The following fields are defined on array types and subtypes: | |
1429 | ||
1430 | Component_Type Component type of the array. | |
1431 | Number_Dimensions Number of dimensions (an int). | |
1432 | First_Index Type of first index. */ | |
1433 | ||
1434 | case E_String_Type: | |
1435 | case E_Array_Type: | |
1436 | { | |
1437 | tree gnu_template_fields = NULL_TREE; | |
1438 | tree gnu_template_type = make_node (RECORD_TYPE); | |
1439 | tree gnu_ptr_template = build_pointer_type (gnu_template_type); | |
1440 | tree gnu_fat_type = make_node (RECORD_TYPE); | |
1441 | int ndim = Number_Dimensions (gnat_entity); | |
1442 | int firstdim | |
1443 | = (Convention (gnat_entity) == Convention_Fortran) ? ndim - 1 : 0; | |
1444 | int nextdim | |
1445 | = (Convention (gnat_entity) == Convention_Fortran) ? - 1 : 1; | |
1446 | tree *gnu_index_types = (tree *) alloca (ndim * sizeof (tree *)); | |
1447 | tree *gnu_temp_fields = (tree *) alloca (ndim * sizeof (tree *)); | |
1448 | tree gnu_comp_size = 0; | |
1449 | tree gnu_max_size = size_one_node; | |
1450 | tree gnu_max_size_unit; | |
1451 | int index; | |
1452 | Entity_Id gnat_ind_subtype; | |
1453 | Entity_Id gnat_ind_base_subtype; | |
1454 | tree gnu_template_reference; | |
1455 | tree tem; | |
1456 | ||
1457 | TYPE_NAME (gnu_template_type) | |
1458 | = create_concat_name (gnat_entity, "XUB"); | |
1459 | TYPE_NAME (gnu_fat_type) = create_concat_name (gnat_entity, "XUP"); | |
1460 | TYPE_IS_FAT_POINTER_P (gnu_fat_type) = 1; | |
1461 | TREE_READONLY (gnu_template_type) = 1; | |
1462 | ||
1463 | /* Make a node for the array. If we are not defining the array | |
1464 | suppress expanding incomplete types and save the node as the type | |
1465 | for GNAT_ENTITY. */ | |
1466 | gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE); | |
1467 | if (! definition) | |
1468 | { | |
1469 | defer_incomplete_level++; | |
1470 | this_deferred = this_made_decl = 1; | |
1471 | gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, | |
1472 | ! Comes_From_Source (gnat_entity), | |
1473 | debug_info_p); | |
1474 | save_gnu_tree (gnat_entity, gnu_decl, 0); | |
1475 | saved = 1; | |
1476 | } | |
1477 | ||
1478 | /* Build the fat pointer type. Use a "void *" object instead of | |
1479 | a pointer to the array type since we don't have the array type | |
1480 | yet (it will reference the fat pointer via the bounds). */ | |
1481 | tem = chainon (chainon (NULL_TREE, | |
1482 | create_field_decl (get_identifier ("P_ARRAY"), | |
1483 | ptr_void_type_node, | |
1484 | gnu_fat_type, 0, 0, 0, 0)), | |
1485 | create_field_decl (get_identifier ("P_BOUNDS"), | |
1486 | gnu_ptr_template, | |
1487 | gnu_fat_type, 0, 0, 0, 0)); | |
1488 | ||
1489 | /* Make sure we can put this into a register. */ | |
1490 | TYPE_ALIGN (gnu_fat_type) = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE); | |
1491 | finish_record_type (gnu_fat_type, tem, 0, 1); | |
1492 | ||
1493 | /* Build a reference to the template from a PLACEHOLDER_EXPR that | |
1494 | is the fat pointer. This will be used to access the individual | |
1495 | fields once we build them. */ | |
1496 | tem = build (COMPONENT_REF, gnu_ptr_template, | |
1497 | build (PLACEHOLDER_EXPR, gnu_fat_type), | |
1498 | TREE_CHAIN (TYPE_FIELDS (gnu_fat_type))); | |
1499 | gnu_template_reference | |
1500 | = build_unary_op (INDIRECT_REF, gnu_template_type, tem); | |
1501 | TREE_READONLY (gnu_template_reference) = 1; | |
1502 | ||
1503 | /* Now create the GCC type for each index and add the fields for | |
1504 | that index to the template. */ | |
1505 | for (index = firstdim, gnat_ind_subtype = First_Index (gnat_entity), | |
1506 | gnat_ind_base_subtype | |
1507 | = First_Index (Implementation_Base_Type (gnat_entity)); | |
1508 | index < ndim && index >= 0; | |
1509 | index += nextdim, | |
1510 | gnat_ind_subtype = Next_Index (gnat_ind_subtype), | |
1511 | gnat_ind_base_subtype = Next_Index (gnat_ind_base_subtype)) | |
1512 | { | |
1513 | char field_name[10]; | |
1514 | tree gnu_ind_subtype | |
1515 | = get_unpadded_type (Base_Type (Etype (gnat_ind_subtype))); | |
1516 | tree gnu_base_subtype | |
1517 | = get_unpadded_type (Etype (gnat_ind_base_subtype)); | |
1518 | tree gnu_base_min | |
1519 | = convert (sizetype, TYPE_MIN_VALUE (gnu_base_subtype)); | |
1520 | tree gnu_base_max | |
1521 | = convert (sizetype, TYPE_MAX_VALUE (gnu_base_subtype)); | |
1522 | tree gnu_min_field, gnu_max_field, gnu_min, gnu_max; | |
1523 | ||
1524 | /* Make the FIELD_DECLs for the minimum and maximum of this | |
1525 | type and then make extractions of that field from the | |
1526 | template. */ | |
1527 | set_lineno (gnat_entity, 0); | |
1528 | sprintf (field_name, "LB%d", index); | |
1529 | gnu_min_field = create_field_decl (get_identifier (field_name), | |
1530 | gnu_ind_subtype, | |
1531 | gnu_template_type, 0, 0, 0, 0); | |
1532 | field_name[0] = 'U'; | |
1533 | gnu_max_field = create_field_decl (get_identifier (field_name), | |
1534 | gnu_ind_subtype, | |
1535 | gnu_template_type, 0, 0, 0, 0); | |
1536 | ||
1537 | gnu_temp_fields[index] = chainon (gnu_min_field, gnu_max_field); | |
1538 | ||
1539 | /* We can't use build_component_ref here since the template | |
1540 | type isn't complete yet. */ | |
1541 | gnu_min = build (COMPONENT_REF, gnu_ind_subtype, | |
1542 | gnu_template_reference, gnu_min_field); | |
1543 | gnu_max = build (COMPONENT_REF, gnu_ind_subtype, | |
1544 | gnu_template_reference, gnu_max_field); | |
1545 | TREE_READONLY (gnu_min) = TREE_READONLY (gnu_max) = 1; | |
1546 | ||
1547 | /* Make a range type with the new ranges, but using | |
1548 | the Ada subtype. Then we convert to sizetype. */ | |
1549 | gnu_index_types[index] | |
1550 | = create_index_type (convert (sizetype, gnu_min), | |
1551 | convert (sizetype, gnu_max), | |
1552 | build_range_type (gnu_ind_subtype, | |
1553 | gnu_min, gnu_max)); | |
1554 | /* Update the maximum size of the array, in elements. */ | |
1555 | gnu_max_size | |
1556 | = size_binop (MULT_EXPR, gnu_max_size, | |
1557 | size_binop (PLUS_EXPR, size_one_node, | |
1558 | size_binop (MINUS_EXPR, gnu_base_max, | |
1559 | gnu_base_min))); | |
1560 | ||
70482933 RK |
1561 | TYPE_NAME (gnu_index_types[index]) |
1562 | = create_concat_name (gnat_entity, field_name); | |
1563 | } | |
1564 | ||
1565 | for (index = 0; index < ndim; index++) | |
1566 | gnu_template_fields | |
1567 | = chainon (gnu_template_fields, gnu_temp_fields[index]); | |
1568 | ||
1569 | /* Install all the fields into the template. */ | |
1570 | finish_record_type (gnu_template_type, gnu_template_fields, 0, 0); | |
1571 | TREE_READONLY (gnu_template_type) = 1; | |
1572 | ||
1573 | /* Now make the array of arrays and update the pointer to the array | |
1574 | in the fat pointer. Note that it is the first field. */ | |
1575 | ||
1576 | tem = gnat_to_gnu_type (Component_Type (gnat_entity)); | |
1577 | ||
1578 | /* Get and validate any specified Component_Size, but if Packed, | |
12e0c41c | 1579 | ignore it since the front end will have taken care of it. */ |
70482933 RK |
1580 | gnu_comp_size |
1581 | = validate_size (Component_Size (gnat_entity), tem, | |
1582 | gnat_entity, | |
1583 | (Is_Bit_Packed_Array (gnat_entity) | |
1584 | ? TYPE_DECL : VAR_DECL), 1, | |
1585 | Has_Component_Size_Clause (gnat_entity)); | |
1586 | ||
1587 | if (Has_Atomic_Components (gnat_entity)) | |
1588 | check_ok_for_atomic (tem, gnat_entity, 1); | |
1589 | ||
1590 | /* If the component type is a RECORD_TYPE that has a self-referential | |
1591 | size, use the maxium size. */ | |
1592 | if (gnu_comp_size == 0 && TREE_CODE (tem) == RECORD_TYPE | |
fbf5a39b | 1593 | && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (tem))) |
70482933 RK |
1594 | gnu_comp_size = max_size (TYPE_SIZE (tem), 1); |
1595 | ||
1596 | if (! Is_Bit_Packed_Array (gnat_entity) && gnu_comp_size != 0) | |
1597 | { | |
1598 | tem = make_type_from_size (tem, gnu_comp_size, 0); | |
1599 | tem = maybe_pad_type (tem, gnu_comp_size, 0, gnat_entity, | |
1600 | "C_PAD", 0, definition, 1); | |
1601 | } | |
1602 | ||
1603 | if (Has_Volatile_Components (gnat_entity)) | |
1604 | tem = build_qualified_type (tem, | |
1605 | TYPE_QUALS (tem) | TYPE_QUAL_VOLATILE); | |
1606 | ||
1607 | /* If Component_Size is not already specified, annotate it with the | |
1608 | size of the component. */ | |
1609 | if (Unknown_Component_Size (gnat_entity)) | |
1610 | Set_Component_Size (gnat_entity, annotate_value (TYPE_SIZE (tem))); | |
1611 | ||
1612 | gnu_max_size_unit = size_binop (MAX_EXPR, size_zero_node, | |
1613 | size_binop (MULT_EXPR, gnu_max_size, | |
1614 | TYPE_SIZE_UNIT (tem))); | |
1615 | gnu_max_size = size_binop (MAX_EXPR, bitsize_zero_node, | |
1616 | size_binop (MULT_EXPR, | |
1617 | convert (bitsizetype, | |
1618 | gnu_max_size), | |
1619 | TYPE_SIZE (tem))); | |
1620 | ||
1621 | for (index = ndim - 1; index >= 0; index--) | |
1622 | { | |
1623 | tem = build_array_type (tem, gnu_index_types[index]); | |
1624 | TYPE_MULTI_ARRAY_P (tem) = (index > 0); | |
fbf5a39b | 1625 | |
b7e429ab AC |
1626 | /* If the type below this an multi-array type, then this |
1627 | does not not have aliased components. | |
1628 | ||
1629 | ??? Otherwise, for now, we say that any component of aggregate | |
1630 | type is addressable because the front end may take 'Reference | |
1631 | of it. But we have to make it addressable if it must be passed | |
1632 | by reference or it that is the default. */ | |
70482933 | 1633 | TYPE_NONALIASED_COMPONENT (tem) |
b7e429ab AC |
1634 | = ((TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE |
1635 | && TYPE_MULTI_ARRAY_P (TREE_TYPE (tem))) ? 1 | |
1636 | : (! Has_Aliased_Components (gnat_entity) | |
1637 | && ! AGGREGATE_TYPE_P (TREE_TYPE (tem)))); | |
70482933 RK |
1638 | } |
1639 | ||
1640 | /* If an alignment is specified, use it if valid. But ignore it for | |
1641 | types that represent the unpacked base type for packed arrays. */ | |
1642 | if (No (Packed_Array_Type (gnat_entity)) | |
1643 | && Known_Alignment (gnat_entity)) | |
1644 | { | |
1645 | if (No (Alignment (gnat_entity))) | |
1646 | gigi_abort (124); | |
1647 | ||
1648 | TYPE_ALIGN (tem) | |
1649 | = validate_alignment (Alignment (gnat_entity), gnat_entity, | |
1650 | TYPE_ALIGN (tem)); | |
1651 | } | |
1652 | ||
1653 | TYPE_CONVENTION_FORTRAN_P (tem) | |
1654 | = (Convention (gnat_entity) == Convention_Fortran); | |
1655 | TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem); | |
1656 | ||
1657 | /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the | |
1658 | corresponding fat pointer. */ | |
1659 | TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) | |
1660 | = TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type; | |
1661 | TYPE_MODE (gnu_type) = BLKmode; | |
1662 | TYPE_ALIGN (gnu_type) = TYPE_ALIGN (tem); | |
e2500fed | 1663 | SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type); |
70482933 RK |
1664 | |
1665 | /* If the maximum size doesn't overflow, use it. */ | |
1666 | if (TREE_CODE (gnu_max_size) == INTEGER_CST | |
1667 | && ! TREE_OVERFLOW (gnu_max_size)) | |
07fc65c4 GB |
1668 | TYPE_SIZE (tem) |
1669 | = size_binop (MIN_EXPR, gnu_max_size, TYPE_SIZE (tem)); | |
1670 | if (TREE_CODE (gnu_max_size_unit) == INTEGER_CST | |
1671 | && ! TREE_OVERFLOW (gnu_max_size_unit)) | |
1672 | TYPE_SIZE_UNIT (tem) | |
1673 | = size_binop (MIN_EXPR, gnu_max_size_unit, | |
1674 | TYPE_SIZE_UNIT (tem)); | |
70482933 RK |
1675 | |
1676 | create_type_decl (create_concat_name (gnat_entity, "XUA"), | |
1677 | tem, 0, ! Comes_From_Source (gnat_entity), | |
1678 | debug_info_p); | |
1679 | rest_of_type_compilation (gnu_fat_type, global_bindings_p ()); | |
1680 | ||
70482933 RK |
1681 | /* Create a record type for the object and its template and |
1682 | set the template at a negative offset. */ | |
1683 | tem = build_unc_object_type (gnu_template_type, tem, | |
1684 | create_concat_name (gnat_entity, "XUT")); | |
1685 | DECL_FIELD_OFFSET (TYPE_FIELDS (tem)) | |
1686 | = size_binop (MINUS_EXPR, size_zero_node, | |
1687 | byte_position (TREE_CHAIN (TYPE_FIELDS (tem)))); | |
1688 | DECL_FIELD_OFFSET (TREE_CHAIN (TYPE_FIELDS (tem))) = size_zero_node; | |
1689 | DECL_FIELD_BIT_OFFSET (TREE_CHAIN (TYPE_FIELDS (tem))) | |
1690 | = bitsize_zero_node; | |
e2500fed | 1691 | SET_TYPE_UNCONSTRAINED_ARRAY (tem, gnu_type); |
70482933 RK |
1692 | TYPE_OBJECT_RECORD_TYPE (gnu_type) = tem; |
1693 | ||
1694 | /* Give the thin pointer type a name. */ | |
1695 | create_type_decl (create_concat_name (gnat_entity, "XUX"), | |
1696 | build_pointer_type (tem), 0, | |
1697 | ! Comes_From_Source (gnat_entity), debug_info_p); | |
1698 | } | |
1699 | break; | |
1700 | ||
1701 | case E_String_Subtype: | |
1702 | case E_Array_Subtype: | |
1703 | ||
1704 | /* This is the actual data type for array variables. Multidimensional | |
1705 | arrays are implemented in the gnu tree as arrays of arrays. Note | |
1706 | that for the moment arrays which have sparse enumeration subtypes as | |
1707 | index components create sparse arrays, which is obviously space | |
1708 | inefficient but so much easier to code for now. | |
1709 | ||
1710 | Also note that the subtype never refers to the unconstrained | |
1711 | array type, which is somewhat at variance with Ada semantics. | |
1712 | ||
1713 | First check to see if this is simply a renaming of the array | |
1714 | type. If so, the result is the array type. */ | |
1715 | ||
1716 | gnu_type = gnat_to_gnu_type (Etype (gnat_entity)); | |
1717 | if (! Is_Constrained (gnat_entity)) | |
1718 | break; | |
1719 | else | |
1720 | { | |
1721 | int index; | |
1722 | int array_dim = Number_Dimensions (gnat_entity); | |
1723 | int first_dim | |
1724 | = ((Convention (gnat_entity) == Convention_Fortran) | |
1725 | ? array_dim - 1 : 0); | |
1726 | int next_dim | |
1727 | = (Convention (gnat_entity) == Convention_Fortran) ? -1 : 1; | |
1728 | Entity_Id gnat_ind_subtype; | |
1729 | Entity_Id gnat_ind_base_subtype; | |
1730 | tree gnu_base_type = gnu_type; | |
1731 | tree *gnu_index_type = (tree *) alloca (array_dim * sizeof (tree *)); | |
1732 | tree gnu_comp_size = 0; | |
1733 | tree gnu_max_size = size_one_node; | |
1734 | tree gnu_max_size_unit; | |
1735 | int need_index_type_struct = 0; | |
1736 | int max_overflow = 0; | |
1737 | ||
1738 | /* First create the gnu types for each index. Create types for | |
1739 | debugging information to point to the index types if the | |
1740 | are not integer types, have variable bounds, or are | |
1741 | wider than sizetype. */ | |
1742 | ||
1743 | for (index = first_dim, gnat_ind_subtype = First_Index (gnat_entity), | |
1744 | gnat_ind_base_subtype | |
1745 | = First_Index (Implementation_Base_Type (gnat_entity)); | |
1746 | index < array_dim && index >= 0; | |
1747 | index += next_dim, | |
1748 | gnat_ind_subtype = Next_Index (gnat_ind_subtype), | |
1749 | gnat_ind_base_subtype = Next_Index (gnat_ind_base_subtype)) | |
1750 | { | |
1751 | tree gnu_index_subtype | |
1752 | = get_unpadded_type (Etype (gnat_ind_subtype)); | |
1753 | tree gnu_min | |
1754 | = convert (sizetype, TYPE_MIN_VALUE (gnu_index_subtype)); | |
1755 | tree gnu_max | |
1756 | = convert (sizetype, TYPE_MAX_VALUE (gnu_index_subtype)); | |
1757 | tree gnu_base_subtype | |
1758 | = get_unpadded_type (Etype (gnat_ind_base_subtype)); | |
1759 | tree gnu_base_min | |
1760 | = convert (sizetype, TYPE_MIN_VALUE (gnu_base_subtype)); | |
1761 | tree gnu_base_max | |
1762 | = convert (sizetype, TYPE_MAX_VALUE (gnu_base_subtype)); | |
1763 | tree gnu_base_type = get_base_type (gnu_base_subtype); | |
1764 | tree gnu_base_base_min | |
1765 | = convert (sizetype, TYPE_MIN_VALUE (gnu_base_type)); | |
1766 | tree gnu_base_base_max | |
1767 | = convert (sizetype, TYPE_MAX_VALUE (gnu_base_type)); | |
1768 | tree gnu_high; | |
1769 | tree gnu_this_max; | |
1770 | ||
1771 | /* If the minimum and maximum values both overflow in | |
1772 | SIZETYPE, but the difference in the original type | |
1773 | does not overflow in SIZETYPE, ignore the overflow | |
1774 | indications. */ | |
1775 | if ((TYPE_PRECISION (gnu_index_subtype) | |
1776 | > TYPE_PRECISION (sizetype)) | |
1777 | && TREE_CODE (gnu_min) == INTEGER_CST | |
1778 | && TREE_CODE (gnu_max) == INTEGER_CST | |
1779 | && TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max) | |
1780 | && (! TREE_OVERFLOW | |
1781 | (fold (build (MINUS_EXPR, gnu_index_subtype, | |
1782 | TYPE_MAX_VALUE (gnu_index_subtype), | |
1783 | TYPE_MIN_VALUE (gnu_index_subtype)))))) | |
1784 | TREE_OVERFLOW (gnu_min) = TREE_OVERFLOW (gnu_max) | |
1785 | = TREE_CONSTANT_OVERFLOW (gnu_min) | |
1786 | = TREE_CONSTANT_OVERFLOW (gnu_max) = 0; | |
1787 | ||
1788 | /* Similarly, if the range is null, use bounds of 1..0 for | |
1789 | the sizetype bounds. */ | |
1790 | else if ((TYPE_PRECISION (gnu_index_subtype) | |
1791 | > TYPE_PRECISION (sizetype)) | |
1792 | && TREE_CODE (gnu_min) == INTEGER_CST | |
1793 | && TREE_CODE (gnu_max) == INTEGER_CST | |
1794 | && (TREE_OVERFLOW (gnu_min) || TREE_OVERFLOW (gnu_max)) | |
1795 | && tree_int_cst_lt (TYPE_MAX_VALUE (gnu_index_subtype), | |
1796 | TYPE_MIN_VALUE (gnu_index_subtype))) | |
1797 | gnu_min = size_one_node, gnu_max = size_zero_node; | |
1798 | ||
1799 | /* Now compute the size of this bound. We need to provide | |
1800 | GCC with an upper bound to use but have to deal with the | |
1801 | "superflat" case. There are three ways to do this. If we | |
1802 | can prove that the array can never be superflat, we can | |
1803 | just use the high bound of the index subtype. If we can | |
1804 | prove that the low bound minus one can't overflow, we | |
1805 | can do this as MAX (hb, lb - 1). Otherwise, we have to use | |
1806 | the expression hb >= lb ? hb : lb - 1. */ | |
1807 | gnu_high = size_binop (MINUS_EXPR, gnu_min, size_one_node); | |
1808 | ||
1809 | /* See if the base array type is already flat. If it is, we | |
1810 | are probably compiling an ACVC test, but it will cause the | |
1811 | code below to malfunction if we don't handle it specially. */ | |
1812 | if (TREE_CODE (gnu_base_min) == INTEGER_CST | |
1813 | && TREE_CODE (gnu_base_max) == INTEGER_CST | |
1814 | && ! TREE_CONSTANT_OVERFLOW (gnu_base_min) | |
1815 | && ! TREE_CONSTANT_OVERFLOW (gnu_base_max) | |
1816 | && tree_int_cst_lt (gnu_base_max, gnu_base_min)) | |
1817 | gnu_high = size_zero_node, gnu_min = size_one_node; | |
1818 | ||
1819 | /* If gnu_high is now an integer which overflowed, the array | |
1820 | cannot be superflat. */ | |
1821 | else if (TREE_CODE (gnu_high) == INTEGER_CST | |
1822 | && TREE_OVERFLOW (gnu_high)) | |
1823 | gnu_high = gnu_max; | |
1824 | else if (TREE_UNSIGNED (gnu_base_subtype) | |
1825 | || TREE_CODE (gnu_high) == INTEGER_CST) | |
1826 | gnu_high = size_binop (MAX_EXPR, gnu_max, gnu_high); | |
1827 | else | |
1828 | gnu_high | |
1829 | = build_cond_expr | |
1830 | (sizetype, build_binary_op (GE_EXPR, integer_type_node, | |
1831 | gnu_max, gnu_min), | |
1832 | gnu_max, gnu_high); | |
1833 | ||
1834 | gnu_index_type[index] | |
1835 | = create_index_type (gnu_min, gnu_high, gnu_index_subtype); | |
1836 | ||
1837 | /* Also compute the maximum size of the array. Here we | |
1838 | see if any constraint on the index type of the base type | |
1839 | can be used in the case of self-referential bound on | |
1840 | the index type of the subtype. We look for a non-"infinite" | |
1841 | and non-self-referential bound from any type involved and | |
1842 | handle each bound separately. */ | |
1843 | ||
1844 | if ((TREE_CODE (gnu_min) == INTEGER_CST | |
1845 | && ! TREE_OVERFLOW (gnu_min) | |
1846 | && ! operand_equal_p (gnu_min, gnu_base_base_min, 0)) | |
fbf5a39b | 1847 | || ! CONTAINS_PLACEHOLDER_P (gnu_min)) |
70482933 RK |
1848 | gnu_base_min = gnu_min; |
1849 | ||
1850 | if ((TREE_CODE (gnu_max) == INTEGER_CST | |
1851 | && ! TREE_OVERFLOW (gnu_max) | |
1852 | && ! operand_equal_p (gnu_max, gnu_base_base_max, 0)) | |
fbf5a39b | 1853 | || ! CONTAINS_PLACEHOLDER_P (gnu_max)) |
70482933 RK |
1854 | gnu_base_max = gnu_max; |
1855 | ||
1856 | if ((TREE_CODE (gnu_base_min) == INTEGER_CST | |
1857 | && TREE_CONSTANT_OVERFLOW (gnu_base_min)) | |
1858 | || operand_equal_p (gnu_base_min, gnu_base_base_min, 0) | |
1859 | || (TREE_CODE (gnu_base_max) == INTEGER_CST | |
1860 | && TREE_CONSTANT_OVERFLOW (gnu_base_max)) | |
1861 | || operand_equal_p (gnu_base_max, gnu_base_base_max, 0)) | |
1862 | max_overflow = 1; | |
1863 | ||
1864 | gnu_base_min = size_binop (MAX_EXPR, gnu_base_min, gnu_min); | |
1865 | gnu_base_max = size_binop (MIN_EXPR, gnu_base_max, gnu_max); | |
1866 | ||
1867 | gnu_this_max | |
1868 | = size_binop (MAX_EXPR, | |
1869 | size_binop (PLUS_EXPR, size_one_node, | |
1870 | size_binop (MINUS_EXPR, gnu_base_max, | |
1871 | gnu_base_min)), | |
1872 | size_zero_node); | |
1873 | ||
1874 | if (TREE_CODE (gnu_this_max) == INTEGER_CST | |
1875 | && TREE_CONSTANT_OVERFLOW (gnu_this_max)) | |
1876 | max_overflow = 1; | |
1877 | ||
1878 | gnu_max_size | |
1879 | = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max); | |
1880 | ||
1881 | if (! integer_onep (TYPE_MIN_VALUE (gnu_index_subtype)) | |
1882 | || (TREE_CODE (TYPE_MAX_VALUE (gnu_index_subtype)) | |
1883 | != INTEGER_CST) | |
1884 | || TREE_CODE (gnu_index_subtype) != INTEGER_TYPE | |
1885 | || (TREE_TYPE (gnu_index_subtype) != 0 | |
1886 | && (TREE_CODE (TREE_TYPE (gnu_index_subtype)) | |
1887 | != INTEGER_TYPE)) | |
1888 | || TYPE_BIASED_REPRESENTATION_P (gnu_index_subtype) | |
1889 | || (TYPE_PRECISION (gnu_index_subtype) | |
1890 | > TYPE_PRECISION (sizetype))) | |
1891 | need_index_type_struct = 1; | |
1892 | } | |
1893 | ||
1894 | /* Then flatten: create the array of arrays. */ | |
1895 | ||
1896 | gnu_type = gnat_to_gnu_type (Component_Type (gnat_entity)); | |
1897 | ||
1898 | /* One of the above calls might have caused us to be elaborated, | |
1899 | so don't blow up if so. */ | |
1900 | if (present_gnu_tree (gnat_entity)) | |
1901 | { | |
1902 | maybe_present = 1; | |
1903 | break; | |
1904 | } | |
1905 | ||
1906 | /* Get and validate any specified Component_Size, but if Packed, | |
12e0c41c | 1907 | ignore it since the front end will have taken care of it. */ |
70482933 RK |
1908 | gnu_comp_size |
1909 | = validate_size (Component_Size (gnat_entity), gnu_type, | |
1910 | gnat_entity, | |
1911 | (Is_Bit_Packed_Array (gnat_entity) | |
1912 | ? TYPE_DECL : VAR_DECL), | |
1913 | 1, Has_Component_Size_Clause (gnat_entity)); | |
1914 | ||
1915 | /* If the component type is a RECORD_TYPE that has a self-referential | |
1916 | size, use the maxium size. */ | |
1917 | if (gnu_comp_size == 0 && TREE_CODE (gnu_type) == RECORD_TYPE | |
fbf5a39b | 1918 | && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))) |
70482933 RK |
1919 | gnu_comp_size = max_size (TYPE_SIZE (gnu_type), 1); |
1920 | ||
1921 | if (! Is_Bit_Packed_Array (gnat_entity) && gnu_comp_size != 0) | |
1922 | { | |
1923 | gnu_type = make_type_from_size (gnu_type, gnu_comp_size, 0); | |
1924 | gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0, | |
1925 | gnat_entity, "C_PAD", 0, | |
1926 | definition, 1); | |
1927 | } | |
1928 | ||
1929 | if (Has_Volatile_Components (Base_Type (gnat_entity))) | |
1930 | gnu_type = build_qualified_type (gnu_type, | |
1931 | (TYPE_QUALS (gnu_type) | |
1932 | | TYPE_QUAL_VOLATILE)); | |
1933 | ||
1934 | gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size, | |
1935 | TYPE_SIZE_UNIT (gnu_type)); | |
1936 | gnu_max_size = size_binop (MULT_EXPR, | |
1937 | convert (bitsizetype, gnu_max_size), | |
1938 | TYPE_SIZE (gnu_type)); | |
1939 | ||
1940 | /* We don't want any array types shared for two reasons: first, | |
1941 | we want to keep differently-named types distinct; second, | |
1942 | setting TYPE_MULTI_ARRAY_TYPE of one type can clobber | |
1943 | another. */ | |
1944 | debug_no_type_hash = 1; | |
1945 | for (index = array_dim - 1; index >= 0; index --) | |
1946 | { | |
1947 | gnu_type = build_array_type (gnu_type, gnu_index_type[index]); | |
1948 | TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0); | |
b7e429ab AC |
1949 | /* If the type below this an multi-array type, then this |
1950 | does not not have aliased components. | |
1951 | ||
1952 | ??? Otherwise, for now, we say that any component of aggregate | |
1953 | type is addressable because the front end may take 'Reference | |
1954 | of it. But we have to make it addressable if it must be passed | |
1955 | by reference or it that is the default. */ | |
70482933 | 1956 | TYPE_NONALIASED_COMPONENT (gnu_type) |
b7e429ab AC |
1957 | = ((TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE |
1958 | && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type))) ? 1 | |
1959 | : (! Has_Aliased_Components (gnat_entity) | |
1960 | && ! AGGREGATE_TYPE_P (TREE_TYPE (gnu_type)))); | |
70482933 RK |
1961 | } |
1962 | ||
1963 | /* If we are at file level and this is a multi-dimensional array, we | |
1964 | need to make a variable corresponding to the stride of the | |
1965 | inner dimensions. */ | |
1966 | if (global_bindings_p () && array_dim > 1) | |
1967 | { | |
1968 | tree gnu_str_name = get_identifier ("ST"); | |
1969 | tree gnu_arr_type; | |
1970 | ||
1971 | for (gnu_arr_type = TREE_TYPE (gnu_type); | |
1972 | TREE_CODE (gnu_arr_type) == ARRAY_TYPE; | |
1973 | gnu_arr_type = TREE_TYPE (gnu_arr_type), | |
1974 | gnu_str_name = concat_id_with_name (gnu_str_name, "ST")) | |
1975 | { | |
1976 | TYPE_SIZE (gnu_arr_type) | |
1977 | = elaborate_expression_1 (gnat_entity, gnat_entity, | |
1978 | TYPE_SIZE (gnu_arr_type), | |
1979 | gnu_str_name, definition, 0); | |
1980 | TYPE_SIZE_UNIT (gnu_arr_type) | |
1981 | = elaborate_expression_1 | |
1982 | (gnat_entity, gnat_entity, TYPE_SIZE_UNIT (gnu_arr_type), | |
1983 | concat_id_with_name (gnu_str_name, "U"), definition, 0); | |
1984 | } | |
1985 | } | |
1986 | ||
1987 | /* If we need to write out a record type giving the names of | |
1988 | the bounds, do it now. */ | |
1989 | if (need_index_type_struct && debug_info_p) | |
1990 | { | |
1991 | tree gnu_bound_rec_type = make_node (RECORD_TYPE); | |
1992 | tree gnu_field_list = 0; | |
1993 | tree gnu_field; | |
1994 | ||
1995 | TYPE_NAME (gnu_bound_rec_type) | |
1996 | = create_concat_name (gnat_entity, "XA"); | |
1997 | ||
1998 | for (index = array_dim - 1; index >= 0; index--) | |
1999 | { | |
2000 | tree gnu_type_name | |
2001 | = TYPE_NAME (TYPE_INDEX_TYPE (gnu_index_type[index])); | |
2002 | ||
2003 | if (TREE_CODE (gnu_type_name) == TYPE_DECL) | |
2004 | gnu_type_name = DECL_NAME (gnu_type_name); | |
2005 | ||
2006 | gnu_field = create_field_decl (gnu_type_name, | |
2007 | integer_type_node, | |
2008 | gnu_bound_rec_type, | |
2009 | 0, NULL_TREE, NULL_TREE, 0); | |
2010 | TREE_CHAIN (gnu_field) = gnu_field_list; | |
2011 | gnu_field_list = gnu_field; | |
2012 | } | |
2013 | ||
2014 | finish_record_type (gnu_bound_rec_type, gnu_field_list, 0, 0); | |
2015 | } | |
2016 | ||
2017 | debug_no_type_hash = 0; | |
2018 | TYPE_CONVENTION_FORTRAN_P (gnu_type) | |
2019 | = (Convention (gnat_entity) == Convention_Fortran); | |
d05ef0ab AC |
2020 | TYPE_PACKED_ARRAY_TYPE_P (gnu_type) |
2021 | = Is_Packed_Array_Type (gnat_entity); | |
70482933 RK |
2022 | |
2023 | /* If our size depends on a placeholder and the maximum size doesn't | |
2024 | overflow, use it. */ | |
fbf5a39b | 2025 | if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)) |
70482933 RK |
2026 | && ! (TREE_CODE (gnu_max_size) == INTEGER_CST |
2027 | && TREE_OVERFLOW (gnu_max_size)) | |
07fc65c4 GB |
2028 | && ! (TREE_CODE (gnu_max_size_unit) == INTEGER_CST |
2029 | && TREE_OVERFLOW (gnu_max_size_unit)) | |
70482933 RK |
2030 | && ! max_overflow) |
2031 | { | |
2032 | TYPE_SIZE (gnu_type) = size_binop (MIN_EXPR, gnu_max_size, | |
2033 | TYPE_SIZE (gnu_type)); | |
2034 | TYPE_SIZE_UNIT (gnu_type) | |
2035 | = size_binop (MIN_EXPR, gnu_max_size_unit, | |
2036 | TYPE_SIZE_UNIT (gnu_type)); | |
2037 | } | |
2038 | ||
2039 | /* Set our alias set to that of our base type. This gives all | |
2040 | array subtypes the same alias set. */ | |
b7e429ab | 2041 | copy_alias_set (gnu_type, gnu_base_type); |
70482933 RK |
2042 | } |
2043 | ||
2044 | /* If this is a packed type, make this type the same as the packed | |
2045 | array type, but do some adjusting in the type first. */ | |
2046 | ||
2047 | if (Present (Packed_Array_Type (gnat_entity))) | |
2048 | { | |
2049 | Entity_Id gnat_index; | |
2050 | tree gnu_inner_type; | |
2051 | ||
2052 | /* First finish the type we had been making so that we output | |
2053 | debugging information for it */ | |
2054 | gnu_type = build_qualified_type (gnu_type, | |
2055 | (TYPE_QUALS (gnu_type) | |
2056 | | (TYPE_QUAL_VOLATILE | |
fbf5a39b | 2057 | * Treat_As_Volatile (gnat_entity)))); |
70482933 RK |
2058 | set_lineno (gnat_entity, 0); |
2059 | gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, | |
2060 | ! Comes_From_Source (gnat_entity), | |
2061 | debug_info_p); | |
2062 | if (! Comes_From_Source (gnat_entity)) | |
2063 | DECL_ARTIFICIAL (gnu_decl) = 1; | |
2064 | ||
2065 | /* Save it as our equivalent in case the call below elaborates | |
2066 | this type again. */ | |
2067 | save_gnu_tree (gnat_entity, gnu_decl, 0); | |
2068 | ||
2069 | gnu_decl = gnat_to_gnu_entity (Packed_Array_Type (gnat_entity), | |
2070 | NULL_TREE, 0); | |
2071 | this_made_decl = 1; | |
2072 | gnu_inner_type = gnu_type = TREE_TYPE (gnu_decl); | |
2073 | save_gnu_tree (gnat_entity, NULL_TREE, 0); | |
2074 | ||
07fc65c4 GB |
2075 | while (TREE_CODE (gnu_inner_type) == RECORD_TYPE |
2076 | && (TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_inner_type) | |
2077 | || TYPE_IS_PADDING_P (gnu_inner_type))) | |
70482933 RK |
2078 | gnu_inner_type = TREE_TYPE (TYPE_FIELDS (gnu_inner_type)); |
2079 | ||
2080 | /* We need to point the type we just made to our index type so | |
2081 | the actual bounds can be put into a template. */ | |
2082 | ||
2083 | if ((TREE_CODE (gnu_inner_type) == ARRAY_TYPE | |
2084 | && TYPE_ACTUAL_BOUNDS (gnu_inner_type) == 0) | |
2085 | || (TREE_CODE (gnu_inner_type) == INTEGER_TYPE | |
2086 | && ! TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type))) | |
2087 | { | |
2088 | if (TREE_CODE (gnu_inner_type) == INTEGER_TYPE) | |
2089 | { | |
2090 | /* The TYPE_ACTUAL_BOUNDS field is also used for the modulus. | |
2091 | If it is, we need to make another type. */ | |
2092 | if (TYPE_MODULAR_P (gnu_inner_type)) | |
2093 | { | |
2094 | tree gnu_subtype; | |
2095 | ||
2096 | gnu_subtype = make_node (INTEGER_TYPE); | |
2097 | ||
2098 | TREE_TYPE (gnu_subtype) = gnu_inner_type; | |
2099 | TYPE_MIN_VALUE (gnu_subtype) | |
2100 | = TYPE_MIN_VALUE (gnu_inner_type); | |
2101 | TYPE_MAX_VALUE (gnu_subtype) | |
2102 | = TYPE_MAX_VALUE (gnu_inner_type); | |
2103 | TYPE_PRECISION (gnu_subtype) | |
2104 | = TYPE_PRECISION (gnu_inner_type); | |
2105 | TREE_UNSIGNED (gnu_subtype) | |
2106 | = TREE_UNSIGNED (gnu_inner_type); | |
2107 | TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1; | |
2108 | layout_type (gnu_subtype); | |
2109 | ||
2110 | gnu_inner_type = gnu_subtype; | |
2111 | } | |
2112 | ||
2113 | TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type) = 1; | |
2114 | } | |
2115 | ||
e2500fed | 2116 | SET_TYPE_ACTUAL_BOUNDS (gnu_inner_type, NULL_TREE); |
70482933 RK |
2117 | |
2118 | for (gnat_index = First_Index (gnat_entity); | |
2119 | Present (gnat_index); gnat_index = Next_Index (gnat_index)) | |
e2500fed GK |
2120 | SET_TYPE_ACTUAL_BOUNDS (gnu_inner_type, |
2121 | tree_cons (NULL_TREE, | |
70482933 | 2122 | get_unpadded_type (Etype (gnat_index)), |
e2500fed | 2123 | TYPE_ACTUAL_BOUNDS (gnu_inner_type))); |
70482933 RK |
2124 | |
2125 | if (Convention (gnat_entity) != Convention_Fortran) | |
e2500fed GK |
2126 | SET_TYPE_ACTUAL_BOUNDS (gnu_inner_type, |
2127 | nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner_type))); | |
70482933 RK |
2128 | |
2129 | if (TREE_CODE (gnu_type) == RECORD_TYPE | |
2130 | && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_type)) | |
2131 | TREE_TYPE (TYPE_FIELDS (gnu_type)) = gnu_inner_type; | |
2132 | } | |
2133 | } | |
2134 | ||
2135 | /* Abort if packed array with no packed array type field set. */ | |
2136 | else if (Is_Packed (gnat_entity)) | |
2137 | gigi_abort (107); | |
2138 | ||
2139 | break; | |
2140 | ||
2141 | case E_String_Literal_Subtype: | |
2142 | /* Create the type for a string literal. */ | |
2143 | { | |
2144 | Entity_Id gnat_full_type | |
2145 | = (IN (Ekind (Etype (gnat_entity)), Private_Kind) | |
2146 | && Present (Full_View (Etype (gnat_entity))) | |
2147 | ? Full_View (Etype (gnat_entity)) : Etype (gnat_entity)); | |
2148 | tree gnu_string_type = get_unpadded_type (gnat_full_type); | |
2149 | tree gnu_string_array_type | |
2150 | = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type)))); | |
2151 | tree gnu_string_index_type | |
fbf5a39b AC |
2152 | = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE |
2153 | (TYPE_DOMAIN (gnu_string_array_type)))); | |
70482933 RK |
2154 | tree gnu_lower_bound |
2155 | = convert (gnu_string_index_type, | |
2156 | gnat_to_gnu (String_Literal_Low_Bound (gnat_entity))); | |
2157 | int length = UI_To_Int (String_Literal_Length (gnat_entity)); | |
2158 | tree gnu_length = ssize_int (length - 1); | |
2159 | tree gnu_upper_bound | |
2160 | = build_binary_op (PLUS_EXPR, gnu_string_index_type, | |
2161 | gnu_lower_bound, | |
2162 | convert (gnu_string_index_type, gnu_length)); | |
2163 | tree gnu_range_type | |
2164 | = build_range_type (gnu_string_index_type, | |
2165 | gnu_lower_bound, gnu_upper_bound); | |
2166 | tree gnu_index_type | |
2167 | = create_index_type (convert (sizetype, | |
2168 | TYPE_MIN_VALUE (gnu_range_type)), | |
2169 | convert (sizetype, | |
2170 | TYPE_MAX_VALUE (gnu_range_type)), | |
2171 | gnu_range_type); | |
2172 | ||
2173 | gnu_type | |
2174 | = build_array_type (gnat_to_gnu_type (Component_Type (gnat_entity)), | |
2175 | gnu_index_type); | |
2176 | } | |
2177 | break; | |
2178 | ||
2179 | /* Record Types and Subtypes | |
2180 | ||
2181 | The following fields are defined on record types: | |
2182 | ||
2183 | Has_Discriminants True if the record has discriminants | |
2184 | First_Discriminant Points to head of list of discriminants | |
2185 | First_Entity Points to head of list of fields | |
2186 | Is_Tagged_Type True if the record is tagged | |
2187 | ||
2188 | Implementation of Ada records and discriminated records: | |
2189 | ||
2190 | A record type definition is transformed into the equivalent of a C | |
2191 | struct definition. The fields that are the discriminants which are | |
2192 | found in the Full_Type_Declaration node and the elements of the | |
2193 | Component_List found in the Record_Type_Definition node. The | |
2194 | Component_List can be a recursive structure since each Variant of | |
2195 | the Variant_Part of the Component_List has a Component_List. | |
2196 | ||
2197 | Processing of a record type definition comprises starting the list of | |
2198 | field declarations here from the discriminants and the calling the | |
2199 | function components_to_record to add the rest of the fields from the | |
2200 | component list and return the gnu type node. The function | |
2201 | components_to_record will call itself recursively as it traverses | |
2202 | the tree. */ | |
2203 | ||
2204 | case E_Record_Type: | |
70482933 RK |
2205 | if (Has_Complex_Representation (gnat_entity)) |
2206 | { | |
2207 | gnu_type | |
2208 | = build_complex_type | |
2209 | (get_unpadded_type | |
2210 | (Etype (Defining_Entity | |
2211 | (First (Component_Items | |
2212 | (Component_List | |
2213 | (Type_Definition | |
2214 | (Declaration_Node (gnat_entity))))))))); | |
2215 | ||
07fc65c4 | 2216 | break; |
70482933 | 2217 | } |
70482933 RK |
2218 | |
2219 | { | |
2220 | Node_Id full_definition = Declaration_Node (gnat_entity); | |
2221 | Node_Id record_definition = Type_Definition (full_definition); | |
2222 | Entity_Id gnat_field; | |
2223 | tree gnu_field; | |
2224 | tree gnu_field_list = NULL_TREE; | |
2225 | tree gnu_get_parent; | |
2226 | int packed = (Is_Packed (gnat_entity) ? 1 | |
2227 | : (Component_Alignment (gnat_entity) | |
2228 | == Calign_Storage_Unit) ? -1 | |
2229 | : 0); | |
2230 | int has_rep = Has_Specified_Layout (gnat_entity); | |
2231 | int all_rep = has_rep; | |
2232 | int is_extension | |
2233 | = (Is_Tagged_Type (gnat_entity) | |
2234 | && Nkind (record_definition) == N_Derived_Type_Definition); | |
2235 | ||
2236 | /* See if all fields have a rep clause. Stop when we find one | |
2237 | that doesn't. */ | |
2238 | for (gnat_field = First_Entity (gnat_entity); | |
2239 | Present (gnat_field) && all_rep; | |
2240 | gnat_field = Next_Entity (gnat_field)) | |
2241 | if ((Ekind (gnat_field) == E_Component | |
2242 | || Ekind (gnat_field) == E_Discriminant) | |
2243 | && No (Component_Clause (gnat_field))) | |
2244 | all_rep = 0; | |
2245 | ||
2246 | /* If this is a record extension, go a level further to find the | |
2247 | record definition. Also, verify we have a Parent_Subtype. */ | |
2248 | if (is_extension) | |
2249 | { | |
2250 | if (! type_annotate_only | |
2251 | || Present (Record_Extension_Part (record_definition))) | |
2252 | record_definition = Record_Extension_Part (record_definition); | |
2253 | ||
2254 | if (! type_annotate_only && No (Parent_Subtype (gnat_entity))) | |
2255 | gigi_abort (121); | |
2256 | } | |
2257 | ||
2258 | /* Make a node for the record. If we are not defining the record, | |
2259 | suppress expanding incomplete types and save the node as the type | |
fbf5a39b AC |
2260 | for GNAT_ENTITY. We use the same RECORD_TYPE as for a dummy type |
2261 | and reset TYPE_DUMMY_P to show it's no longer a dummy. | |
2262 | ||
2263 | It is very tempting to delay resetting this bit until we are done | |
2264 | with completing the type, e.g. to let possible intermediate | |
2265 | elaboration of access types designating the record know it is not | |
2266 | complete and arrange for update_pointer_to to fix things up later. | |
2267 | ||
2268 | It would be wrong, however, because dummy types are expected only | |
2269 | to be created for Ada incomplete or private types, which is not | |
2270 | what we have here. Doing so would make other parts of gigi think | |
2271 | we are dealing with a really incomplete or private type, and have | |
2272 | nasty side effects, typically on the generation of the associated | |
2273 | debugging information. */ | |
70482933 RK |
2274 | gnu_type = make_dummy_type (gnat_entity); |
2275 | TYPE_DUMMY_P (gnu_type) = 0; | |
fbf5a39b | 2276 | |
70482933 RK |
2277 | if (TREE_CODE (TYPE_NAME (gnu_type)) == TYPE_DECL && debug_info_p) |
2278 | DECL_IGNORED_P (TYPE_NAME (gnu_type)) = 0; | |
2279 | ||
2280 | TYPE_ALIGN (gnu_type) = 0; | |
2281 | TYPE_PACKED (gnu_type) = packed != 0 || has_rep; | |
2282 | ||
2283 | if (! definition) | |
2284 | { | |
2285 | defer_incomplete_level++; | |
2286 | this_deferred = 1; | |
2287 | set_lineno (gnat_entity, 0); | |
2288 | gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, | |
2289 | ! Comes_From_Source (gnat_entity), | |
2290 | debug_info_p); | |
2291 | save_gnu_tree (gnat_entity, gnu_decl, 0); | |
2292 | this_made_decl = saved = 1; | |
2293 | } | |
2294 | ||
2295 | /* If both a size and rep clause was specified, put the size in | |
2296 | the record type now so that it can get the proper mode. */ | |
2297 | if (has_rep && Known_Esize (gnat_entity)) | |
2298 | TYPE_SIZE (gnu_type) = UI_To_gnu (Esize (gnat_entity), sizetype); | |
2299 | ||
2300 | /* Always set the alignment here so that it can be used to | |
2301 | set the mode, if it is making the alignment stricter. If | |
2302 | it is invalid, it will be checked again below. If this is to | |
fbf5a39b AC |
2303 | be Atomic, choose a default alignment of a word unless we know |
2304 | the size and it's smaller. */ | |
70482933 RK |
2305 | if (Known_Alignment (gnat_entity)) |
2306 | TYPE_ALIGN (gnu_type) | |
2307 | = validate_alignment (Alignment (gnat_entity), gnat_entity, 0); | |
2308 | else if (Is_Atomic (gnat_entity)) | |
fbf5a39b AC |
2309 | TYPE_ALIGN (gnu_type) |
2310 | = (esize >= BITS_PER_WORD ? BITS_PER_WORD | |
2311 | : 1 << ((floor_log2 (esize) - 1) + 1)); | |
70482933 RK |
2312 | |
2313 | /* If we have a Parent_Subtype, make a field for the parent. If | |
2314 | this record has rep clauses, force the position to zero. */ | |
2315 | if (Present (Parent_Subtype (gnat_entity))) | |
2316 | { | |
2317 | tree gnu_parent; | |
2318 | ||
2319 | /* A major complexity here is that the parent subtype will | |
2320 | reference our discriminants. But those must reference | |
2321 | the parent component of this record. So here we will | |
2322 | initialize each of those components to a COMPONENT_REF. | |
2323 | The first operand of that COMPONENT_REF is another | |
2324 | COMPONENT_REF which will be filled in below, once | |
2325 | the parent type can be safely built. */ | |
2326 | ||
2327 | gnu_get_parent = build (COMPONENT_REF, void_type_node, | |
2328 | build (PLACEHOLDER_EXPR, gnu_type), | |
2329 | build_decl (FIELD_DECL, NULL_TREE, | |
2330 | NULL_TREE)); | |
2331 | ||
2332 | if (Has_Discriminants (gnat_entity)) | |
fbf5a39b | 2333 | for (gnat_field = First_Stored_Discriminant (gnat_entity); |
70482933 | 2334 | Present (gnat_field); |
fbf5a39b | 2335 | gnat_field = Next_Stored_Discriminant (gnat_field)) |
70482933 RK |
2336 | if (Present (Corresponding_Discriminant (gnat_field))) |
2337 | save_gnu_tree | |
2338 | (gnat_field, | |
2339 | build (COMPONENT_REF, | |
2340 | get_unpadded_type (Etype (gnat_field)), | |
2341 | gnu_get_parent, | |
2342 | gnat_to_gnu_entity (Corresponding_Discriminant | |
2343 | (gnat_field), | |
2344 | NULL_TREE, 0)), | |
2345 | 1); | |
2346 | ||
2347 | gnu_parent = gnat_to_gnu_type (Parent_Subtype (gnat_entity)); | |
2348 | ||
2349 | gnu_field_list | |
2350 | = create_field_decl (get_identifier | |
2351 | (Get_Name_String (Name_uParent)), | |
2352 | gnu_parent, gnu_type, 0, | |
2353 | has_rep ? TYPE_SIZE (gnu_parent) : 0, | |
2354 | has_rep ? bitsize_zero_node : 0, 1); | |
2355 | DECL_INTERNAL_P (gnu_field_list) = 1; | |
2356 | ||
2357 | TREE_TYPE (gnu_get_parent) = gnu_parent; | |
2358 | TREE_OPERAND (gnu_get_parent, 1) = gnu_field_list; | |
2359 | } | |
2360 | ||
2361 | /* Add the fields for the discriminants into the record. */ | |
2362 | if (! Is_Unchecked_Union (gnat_entity) | |
2363 | && Has_Discriminants (gnat_entity)) | |
fbf5a39b | 2364 | for (gnat_field = First_Stored_Discriminant (gnat_entity); |
70482933 | 2365 | Present (gnat_field); |
fbf5a39b | 2366 | gnat_field = Next_Stored_Discriminant (gnat_field)) |
70482933 RK |
2367 | { |
2368 | /* If this is a record extension and this discriminant | |
2369 | is the renaming of another discriminant, we've already | |
2370 | handled the discriminant above. */ | |
2371 | if (Present (Parent_Subtype (gnat_entity)) | |
2372 | && Present (Corresponding_Discriminant (gnat_field))) | |
2373 | continue; | |
2374 | ||
2375 | gnu_field | |
2376 | = gnat_to_gnu_field (gnat_field, gnu_type, packed, definition); | |
2377 | ||
2378 | /* Make an expression using a PLACEHOLDER_EXPR from the | |
2379 | FIELD_DECL node just created and link that with the | |
2380 | corresponding GNAT defining identifier. Then add to the | |
2381 | list of fields. */ | |
2382 | save_gnu_tree (gnat_field, | |
2383 | build (COMPONENT_REF, TREE_TYPE (gnu_field), | |
2384 | build (PLACEHOLDER_EXPR, | |
2385 | DECL_CONTEXT (gnu_field)), | |
2386 | gnu_field), | |
2387 | 1); | |
2388 | ||
2389 | TREE_CHAIN (gnu_field) = gnu_field_list; | |
2390 | gnu_field_list = gnu_field; | |
2391 | } | |
2392 | ||
2393 | /* Put the discriminants into the record (backwards), so we can | |
2394 | know the appropriate discriminant to use for the names of the | |
2395 | variants. */ | |
2396 | TYPE_FIELDS (gnu_type) = gnu_field_list; | |
2397 | ||
2398 | /* Add the listed fields into the record and finish up. */ | |
2399 | components_to_record (gnu_type, Component_List (record_definition), | |
2400 | gnu_field_list, packed, definition, 0, | |
2401 | 0, all_rep); | |
2402 | ||
fbf5a39b | 2403 | TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity); |
70482933 RK |
2404 | TYPE_BY_REFERENCE_P (gnu_type) = Is_By_Reference_Type (gnat_entity); |
2405 | ||
2406 | /* If this is an extension type, reset the tree for any | |
2407 | inherited discriminants. Also remove the PLACEHOLDER_EXPR | |
2408 | for non-inherited discriminants. */ | |
2409 | if (! Is_Unchecked_Union (gnat_entity) | |
2410 | && Has_Discriminants (gnat_entity)) | |
fbf5a39b | 2411 | for (gnat_field = First_Stored_Discriminant (gnat_entity); |
70482933 | 2412 | Present (gnat_field); |
fbf5a39b | 2413 | gnat_field = Next_Stored_Discriminant (gnat_field)) |
70482933 RK |
2414 | { |
2415 | if (Present (Parent_Subtype (gnat_entity)) | |
2416 | && Present (Corresponding_Discriminant (gnat_field))) | |
2417 | save_gnu_tree (gnat_field, NULL_TREE, 0); | |
2418 | else | |
2419 | { | |
2420 | gnu_field = get_gnu_tree (gnat_field); | |
2421 | save_gnu_tree (gnat_field, NULL_TREE, 0); | |
2422 | save_gnu_tree (gnat_field, TREE_OPERAND (gnu_field, 1), 0); | |
2423 | } | |
2424 | } | |
2425 | ||
2426 | /* If it is a tagged record force the type to BLKmode to insure | |
2427 | that these objects will always be placed in memory. Do the | |
2428 | same thing for limited record types. */ | |
70482933 RK |
2429 | if (Is_Tagged_Type (gnat_entity) || Is_Limited_Record (gnat_entity)) |
2430 | TYPE_MODE (gnu_type) = BLKmode; | |
2431 | ||
fbf5a39b AC |
2432 | /* If this is a derived type, we must make the alias set of this type |
2433 | the same as that of the type we are derived from. We assume here | |
2434 | that the other type is already frozen. */ | |
2435 | if (Etype (gnat_entity) != gnat_entity | |
2436 | && ! (Is_Private_Type (Etype (gnat_entity)) | |
2437 | && Full_View (Etype (gnat_entity)) == gnat_entity)) | |
b7e429ab | 2438 | copy_alias_set (gnu_type, gnat_to_gnu_type (Etype (gnat_entity))); |
fbf5a39b | 2439 | |
70482933 RK |
2440 | /* Fill in locations of fields. */ |
2441 | annotate_rep (gnat_entity, gnu_type); | |
2442 | ||
2443 | /* If there are any entities in the chain corresponding to | |
2444 | components that we did not elaborate, ensure we elaborate their | |
2445 | types if they are Itypes. */ | |
2446 | for (gnat_temp = First_Entity (gnat_entity); | |
2447 | Present (gnat_temp); gnat_temp = Next_Entity (gnat_temp)) | |
2448 | if ((Ekind (gnat_temp) == E_Component | |
2449 | || Ekind (gnat_temp) == E_Discriminant) | |
2450 | && Is_Itype (Etype (gnat_temp)) | |
2451 | && ! present_gnu_tree (gnat_temp)) | |
2452 | gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0); | |
2453 | } | |
2454 | break; | |
2455 | ||
2456 | case E_Class_Wide_Subtype: | |
2457 | /* If an equivalent type is present, that is what we should use. | |
2458 | Otherwise, fall through to handle this like a record subtype | |
2459 | since it may have constraints. */ | |
2460 | ||
2461 | if (Present (Equivalent_Type (gnat_entity))) | |
2462 | { | |
fbf5a39b AC |
2463 | gnu_decl = gnat_to_gnu_entity (Equivalent_Type (gnat_entity), |
2464 | NULL_TREE, 0); | |
70482933 RK |
2465 | maybe_present = 1; |
2466 | break; | |
2467 | } | |
2468 | ||
2469 | /* ... fall through ... */ | |
2470 | ||
2471 | case E_Record_Subtype: | |
2472 | ||
2473 | /* If Cloned_Subtype is Present it means this record subtype has | |
2474 | identical layout to that type or subtype and we should use | |
2475 | that GCC type for this one. The front end guarantees that | |
2476 | the component list is shared. */ | |
2477 | if (Present (Cloned_Subtype (gnat_entity))) | |
2478 | { | |
2479 | gnu_decl = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity), | |
2480 | NULL_TREE, 0); | |
2481 | maybe_present = 1; | |
2482 | } | |
2483 | ||
2484 | /* Otherwise, first ensure the base type is elaborated. Then, if we are | |
2485 | changing the type, make a new type with each field having the | |
2486 | type of the field in the new subtype but having the position | |
2487 | computed by transforming every discriminant reference according | |
2488 | to the constraints. We don't see any difference between | |
2489 | private and nonprivate type here since derivations from types should | |
2490 | have been deferred until the completion of the private type. */ | |
2491 | else | |
2492 | { | |
2493 | Entity_Id gnat_base_type = Implementation_Base_Type (gnat_entity); | |
2494 | tree gnu_base_type; | |
2495 | tree gnu_orig_type; | |
2496 | ||
2497 | if (! definition) | |
2498 | defer_incomplete_level++, this_deferred = 1; | |
2499 | ||
2500 | /* Get the base type initially for its alignment and sizes. But | |
2501 | if it is a padded type, we do all the other work with the | |
2502 | unpadded type. */ | |
2503 | gnu_type = gnu_orig_type = gnu_base_type | |
2504 | = gnat_to_gnu_type (gnat_base_type); | |
2505 | ||
2506 | if (TREE_CODE (gnu_type) == RECORD_TYPE | |
2507 | && TYPE_IS_PADDING_P (gnu_type)) | |
2508 | gnu_type = gnu_orig_type = TREE_TYPE (TYPE_FIELDS (gnu_type)); | |
2509 | ||
2510 | if (present_gnu_tree (gnat_entity)) | |
2511 | { | |
2512 | maybe_present = 1; | |
2513 | break; | |
2514 | } | |
2515 | ||
2516 | /* When the type has discriminants, and these discriminants | |
2517 | affect the shape of what it built, factor them in. | |
2518 | ||
2519 | If we are making a subtype of an Unchecked_Union (must be an | |
2520 | Itype), just return the type. | |
2521 | ||
2522 | We can't just use Is_Constrained because private subtypes without | |
2523 | discriminants of full types with discriminants with default | |
2524 | expressions are Is_Constrained but aren't constrained! */ | |
2525 | ||
2526 | if (IN (Ekind (gnat_base_type), Record_Kind) | |
2527 | && ! Is_For_Access_Subtype (gnat_entity) | |
2528 | && ! Is_Unchecked_Union (gnat_base_type) | |
2529 | && Is_Constrained (gnat_entity) | |
fbf5a39b | 2530 | && Stored_Constraint (gnat_entity) != No_Elist |
70482933 RK |
2531 | && Present (Discriminant_Constraint (gnat_entity))) |
2532 | { | |
2533 | Entity_Id gnat_field; | |
2534 | Entity_Id gnat_root_type; | |
2535 | tree gnu_field_list = 0; | |
2536 | tree gnu_pos_list | |
2537 | = compute_field_positions (gnu_orig_type, NULL_TREE, | |
07fc65c4 GB |
2538 | size_zero_node, bitsize_zero_node, |
2539 | BIGGEST_ALIGNMENT); | |
70482933 RK |
2540 | tree gnu_subst_list |
2541 | = substitution_list (gnat_entity, gnat_base_type, NULL_TREE, | |
2542 | definition); | |
2543 | tree gnu_temp; | |
2544 | ||
2545 | /* If this is a derived type, we may be seeing fields from any | |
2546 | original records, so add those positions and discriminant | |
2547 | substitutions to our lists. */ | |
2548 | for (gnat_root_type = gnat_base_type; | |
2549 | Underlying_Type (Etype (gnat_root_type)) != gnat_root_type; | |
2550 | gnat_root_type = Underlying_Type (Etype (gnat_root_type))) | |
2551 | { | |
2552 | gnu_pos_list | |
2553 | = compute_field_positions | |
2554 | (gnat_to_gnu_type (Etype (gnat_root_type)), | |
07fc65c4 GB |
2555 | gnu_pos_list, size_zero_node, bitsize_zero_node, |
2556 | BIGGEST_ALIGNMENT); | |
70482933 RK |
2557 | |
2558 | if (Present (Parent_Subtype (gnat_root_type))) | |
2559 | gnu_subst_list | |
2560 | = substitution_list (Parent_Subtype (gnat_root_type), | |
2561 | Empty, gnu_subst_list, definition); | |
2562 | } | |
2563 | ||
2564 | gnu_type = make_node (RECORD_TYPE); | |
2565 | TYPE_NAME (gnu_type) = gnu_entity_id; | |
2566 | TYPE_STUB_DECL (gnu_type) | |
2567 | = pushdecl (build_decl (TYPE_DECL, NULL_TREE, gnu_type)); | |
2568 | TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_base_type); | |
2569 | ||
2570 | for (gnat_field = First_Entity (gnat_entity); | |
2571 | Present (gnat_field); gnat_field = Next_Entity (gnat_field)) | |
2572 | if (Ekind (gnat_field) == E_Component | |
2573 | || Ekind (gnat_field) == E_Discriminant) | |
2574 | { | |
2575 | tree gnu_old_field | |
2576 | = gnat_to_gnu_entity | |
2577 | (Original_Record_Component (gnat_field), NULL_TREE, 0); | |
2578 | tree gnu_offset | |
2579 | = TREE_VALUE (purpose_member (gnu_old_field, | |
2580 | gnu_pos_list)); | |
2581 | tree gnu_pos = TREE_PURPOSE (gnu_offset); | |
07fc65c4 | 2582 | tree gnu_bitpos = TREE_VALUE (TREE_VALUE (gnu_offset)); |
70482933 RK |
2583 | tree gnu_field_type |
2584 | = gnat_to_gnu_type (Etype (gnat_field)); | |
2585 | tree gnu_size = TYPE_SIZE (gnu_field_type); | |
2586 | tree gnu_new_pos = 0; | |
07fc65c4 GB |
2587 | unsigned int offset_align |
2588 | = tree_low_cst (TREE_PURPOSE (TREE_VALUE (gnu_offset)), | |
2589 | 1); | |
70482933 RK |
2590 | tree gnu_field; |
2591 | ||
2592 | /* If there was a component clause, the field types must be | |
2593 | the same for the type and subtype, so copy the data from | |
2594 | the old field to avoid recomputation here. */ | |
2595 | if (Present (Component_Clause | |
2596 | (Original_Record_Component (gnat_field)))) | |
2597 | { | |
2598 | gnu_size = DECL_SIZE (gnu_old_field); | |
2599 | gnu_field_type = TREE_TYPE (gnu_old_field); | |
2600 | } | |
2601 | ||
2602 | /* If this was a bitfield, get the size from the old field. | |
2603 | Also ensure the type can be placed into a bitfield. */ | |
2604 | else if (DECL_BIT_FIELD (gnu_old_field)) | |
2605 | { | |
2606 | gnu_size = DECL_SIZE (gnu_old_field); | |
2607 | if (TYPE_MODE (gnu_field_type) == BLKmode | |
2608 | && TREE_CODE (gnu_field_type) == RECORD_TYPE | |
2609 | && host_integerp (TYPE_SIZE (gnu_field_type), 1)) | |
2610 | gnu_field_type = make_packable_type (gnu_field_type); | |
2611 | } | |
2612 | ||
fbf5a39b | 2613 | if (CONTAINS_PLACEHOLDER_P (gnu_pos)) |
70482933 RK |
2614 | for (gnu_temp = gnu_subst_list; |
2615 | gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp)) | |
2616 | gnu_pos = substitute_in_expr (gnu_pos, | |
2617 | TREE_PURPOSE (gnu_temp), | |
2618 | TREE_VALUE (gnu_temp)); | |
2619 | ||
2620 | /* If the size is now a constant, we can set it as the | |
2621 | size of the field when we make it. Otherwise, we need | |
2622 | to deal with it specially. */ | |
2623 | if (TREE_CONSTANT (gnu_pos)) | |
2624 | gnu_new_pos = bit_from_pos (gnu_pos, gnu_bitpos); | |
2625 | ||
2626 | gnu_field | |
2627 | = create_field_decl | |
2628 | (DECL_NAME (gnu_old_field), gnu_field_type, gnu_type, | |
2629 | 0, gnu_size, gnu_new_pos, | |
2630 | ! DECL_NONADDRESSABLE_P (gnu_old_field)); | |
2631 | ||
2632 | if (! TREE_CONSTANT (gnu_pos)) | |
2633 | { | |
07fc65c4 | 2634 | normalize_offset (&gnu_pos, &gnu_bitpos, offset_align); |
70482933 RK |
2635 | DECL_FIELD_OFFSET (gnu_field) = gnu_pos; |
2636 | DECL_FIELD_BIT_OFFSET (gnu_field) = gnu_bitpos; | |
07fc65c4 | 2637 | SET_DECL_OFFSET_ALIGN (gnu_field, offset_align); |
70482933 RK |
2638 | DECL_SIZE (gnu_field) = gnu_size; |
2639 | DECL_SIZE_UNIT (gnu_field) | |
2640 | = convert (sizetype, | |
2641 | size_binop (CEIL_DIV_EXPR, gnu_size, | |
2642 | bitsize_unit_node)); | |
2643 | layout_decl (gnu_field, DECL_OFFSET_ALIGN (gnu_field)); | |
2644 | } | |
2645 | ||
2646 | DECL_INTERNAL_P (gnu_field) | |
2647 | = DECL_INTERNAL_P (gnu_old_field); | |
e2500fed GK |
2648 | SET_DECL_ORIGINAL_FIELD (gnu_field, |
2649 | (DECL_ORIGINAL_FIELD (gnu_old_field) != 0 | |
fbf5a39b | 2650 | ? DECL_ORIGINAL_FIELD (gnu_old_field) |
e2500fed | 2651 | : gnu_old_field)); |
70482933 RK |
2652 | DECL_DISCRIMINANT_NUMBER (gnu_field) |
2653 | = DECL_DISCRIMINANT_NUMBER (gnu_old_field); | |
2654 | TREE_THIS_VOLATILE (gnu_field) | |
2655 | = TREE_THIS_VOLATILE (gnu_old_field); | |
2656 | TREE_CHAIN (gnu_field) = gnu_field_list; | |
2657 | gnu_field_list = gnu_field; | |
2658 | save_gnu_tree (gnat_field, gnu_field, 0); | |
2659 | } | |
2660 | ||
2661 | finish_record_type (gnu_type, nreverse (gnu_field_list), 1, 0); | |
2662 | ||
2663 | /* Now set the size, alignment and alias set of the new type to | |
2664 | match that of the old one, doing any substitutions, as | |
2665 | above. */ | |
70482933 RK |
2666 | TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_base_type); |
2667 | TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_base_type); | |
2668 | TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_base_type); | |
e2500fed | 2669 | SET_TYPE_ADA_SIZE (gnu_type, TYPE_ADA_SIZE (gnu_base_type)); |
b7e429ab | 2670 | copy_alias_set (gnu_type, gnu_base_type); |
70482933 | 2671 | |
fbf5a39b | 2672 | if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))) |
70482933 RK |
2673 | for (gnu_temp = gnu_subst_list; |
2674 | gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp)) | |
2675 | TYPE_SIZE (gnu_type) | |
2676 | = substitute_in_expr (TYPE_SIZE (gnu_type), | |
2677 | TREE_PURPOSE (gnu_temp), | |
2678 | TREE_VALUE (gnu_temp)); | |
2679 | ||
fbf5a39b | 2680 | if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (gnu_type))) |
70482933 RK |
2681 | for (gnu_temp = gnu_subst_list; |
2682 | gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp)) | |
2683 | TYPE_SIZE_UNIT (gnu_type) | |
2684 | = substitute_in_expr (TYPE_SIZE_UNIT (gnu_type), | |
2685 | TREE_PURPOSE (gnu_temp), | |
2686 | TREE_VALUE (gnu_temp)); | |
2687 | ||
2688 | if (TYPE_ADA_SIZE (gnu_type) != 0 | |
fbf5a39b | 2689 | && CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (gnu_type))) |
70482933 RK |
2690 | for (gnu_temp = gnu_subst_list; |
2691 | gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp)) | |
e2500fed GK |
2692 | SET_TYPE_ADA_SIZE (gnu_type, |
2693 | substitute_in_expr (TYPE_ADA_SIZE (gnu_type), | |
70482933 | 2694 | TREE_PURPOSE (gnu_temp), |
e2500fed | 2695 | TREE_VALUE (gnu_temp))); |
70482933 RK |
2696 | |
2697 | /* Recompute the mode of this record type now that we know its | |
2698 | actual size. */ | |
2699 | compute_record_mode (gnu_type); | |
2700 | ||
2701 | /* Fill in locations of fields. */ | |
2702 | annotate_rep (gnat_entity, gnu_type); | |
2703 | } | |
2704 | ||
2705 | /* If we've made a new type, record it and make an XVS type to show | |
2706 | what this is a subtype of. Some debuggers require the XVS | |
2707 | type to be output first, so do it in that order. */ | |
2708 | if (gnu_type != gnu_orig_type) | |
2709 | { | |
2710 | if (debug_info_p) | |
2711 | { | |
2712 | tree gnu_subtype_marker = make_node (RECORD_TYPE); | |
2713 | tree gnu_orig_name = TYPE_NAME (gnu_orig_type); | |
2714 | ||
2715 | if (TREE_CODE (gnu_orig_name) == TYPE_DECL) | |
2716 | gnu_orig_name = DECL_NAME (gnu_orig_name); | |
2717 | ||
2718 | TYPE_NAME (gnu_subtype_marker) | |
2719 | = create_concat_name (gnat_entity, "XVS"); | |
2720 | finish_record_type (gnu_subtype_marker, | |
2721 | create_field_decl (gnu_orig_name, | |
2722 | integer_type_node, | |
2723 | gnu_subtype_marker, | |
2724 | 0, NULL_TREE, | |
2725 | NULL_TREE, 0), | |
2726 | 0, 0); | |
2727 | } | |
2728 | ||
fbf5a39b | 2729 | TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity); |
70482933 RK |
2730 | TYPE_NAME (gnu_type) = gnu_entity_id; |
2731 | TYPE_STUB_DECL (gnu_type) | |
2732 | = pushdecl (build_decl (TYPE_DECL, TYPE_NAME (gnu_type), | |
2733 | gnu_type)); | |
2734 | DECL_ARTIFICIAL (TYPE_STUB_DECL (gnu_type)) = 1; | |
2735 | DECL_IGNORED_P (TYPE_STUB_DECL (gnu_type)) = ! debug_info_p; | |
2736 | rest_of_type_compilation (gnu_type, global_bindings_p ()); | |
2737 | } | |
2738 | ||
2739 | /* Otherwise, go down all the components in the new type and | |
2740 | make them equivalent to those in the base type. */ | |
2741 | else | |
2742 | for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp); | |
2743 | gnat_temp = Next_Entity (gnat_temp)) | |
2744 | if ((Ekind (gnat_temp) == E_Discriminant | |
2745 | && ! Is_Unchecked_Union (gnat_base_type)) | |
2746 | || Ekind (gnat_temp) == E_Component) | |
2747 | save_gnu_tree (gnat_temp, | |
2748 | get_gnu_tree | |
2749 | (Original_Record_Component (gnat_temp)), 0); | |
2750 | } | |
2751 | break; | |
2752 | ||
2753 | case E_Access_Subprogram_Type: | |
2754 | /* If we are not defining this entity, and we have incomplete | |
2755 | entities being processed above us, make a dummy type and | |
2756 | fill it in later. */ | |
2757 | if (! definition && defer_incomplete_level != 0) | |
2758 | { | |
2759 | struct incomplete *p | |
2760 | = (struct incomplete *) xmalloc (sizeof (struct incomplete)); | |
2761 | ||
2762 | gnu_type | |
2763 | = build_pointer_type | |
2764 | (make_dummy_type (Directly_Designated_Type (gnat_entity))); | |
2765 | gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, | |
2766 | ! Comes_From_Source (gnat_entity), | |
2767 | debug_info_p); | |
2768 | save_gnu_tree (gnat_entity, gnu_decl, 0); | |
2769 | this_made_decl = saved = 1; | |
2770 | ||
2771 | p->old_type = TREE_TYPE (gnu_type); | |
2772 | p->full_type = Directly_Designated_Type (gnat_entity); | |
2773 | p->next = defer_incomplete_list; | |
2774 | defer_incomplete_list = p; | |
2775 | break; | |
2776 | } | |
2777 | ||
2778 | /* ... fall through ... */ | |
2779 | ||
2780 | case E_Allocator_Type: | |
2781 | case E_Access_Type: | |
2782 | case E_Access_Attribute_Type: | |
2783 | case E_Anonymous_Access_Type: | |
2784 | case E_General_Access_Type: | |
2785 | { | |
2786 | Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity); | |
2787 | Entity_Id gnat_desig_full | |
2788 | = ((IN (Ekind (Etype (gnat_desig_type)), | |
2789 | Incomplete_Or_Private_Kind)) | |
2790 | ? Full_View (gnat_desig_type) : 0); | |
2791 | /* We want to know if we'll be seeing the freeze node for any | |
2792 | incomplete type we may be pointing to. */ | |
2793 | int in_main_unit | |
2794 | = (Present (gnat_desig_full) | |
2795 | ? In_Extended_Main_Code_Unit (gnat_desig_full) | |
2796 | : In_Extended_Main_Code_Unit (gnat_desig_type)); | |
2797 | int got_fat_p = 0; | |
2798 | int made_dummy = 0; | |
7a3a8c06 | 2799 | tree gnu_desig_type = 0; |
70482933 RK |
2800 | |
2801 | if (No (gnat_desig_full) | |
2802 | && (Ekind (gnat_desig_type) == E_Class_Wide_Type | |
2803 | || (Ekind (gnat_desig_type) == E_Class_Wide_Subtype | |
2804 | && Present (Equivalent_Type (gnat_desig_type))))) | |
2805 | { | |
2806 | if (Present (Equivalent_Type (gnat_desig_type))) | |
2807 | { | |
2808 | gnat_desig_full = Equivalent_Type (gnat_desig_type); | |
2809 | if (IN (Ekind (gnat_desig_full), Incomplete_Or_Private_Kind)) | |
2810 | gnat_desig_full = Full_View (gnat_desig_full); | |
2811 | } | |
2812 | else if (IN (Ekind (Root_Type (gnat_desig_type)), | |
2813 | Incomplete_Or_Private_Kind)) | |
2814 | gnat_desig_full = Full_View (Root_Type (gnat_desig_type)); | |
2815 | } | |
2816 | ||
2817 | if (Present (gnat_desig_full) && Is_Concurrent_Type (gnat_desig_full)) | |
2818 | gnat_desig_full = Corresponding_Record_Type (gnat_desig_full); | |
2819 | ||
2820 | /* If either the designated type or its full view is an | |
2821 | unconstrained array subtype, replace it with the type it's a | |
2822 | subtype of. This avoids problems with multiple copies of | |
2823 | unconstrained array types. */ | |
2824 | if (Ekind (gnat_desig_type) == E_Array_Subtype | |
2825 | && ! Is_Constrained (gnat_desig_type)) | |
2826 | gnat_desig_type = Etype (gnat_desig_type); | |
2827 | if (Present (gnat_desig_full) | |
2828 | && Ekind (gnat_desig_full) == E_Array_Subtype | |
2829 | && ! Is_Constrained (gnat_desig_full)) | |
2830 | gnat_desig_full = Etype (gnat_desig_full); | |
2831 | ||
07fc65c4 GB |
2832 | /* If the designated type is a subtype of an incomplete record type, |
2833 | use the parent type to avoid order of elaboration issues. This | |
2834 | can lose some code efficiency, but there is no alternative. */ | |
2835 | if (Present (gnat_desig_full) | |
2836 | && Ekind (gnat_desig_full) == E_Record_Subtype | |
2837 | && Ekind (Etype (gnat_desig_full)) == E_Record_Type) | |
2838 | gnat_desig_full = Etype (gnat_desig_full); | |
2839 | ||
70482933 RK |
2840 | /* If we are pointing to an incomplete type whose completion is an |
2841 | unconstrained array, make a fat pointer type instead of a pointer | |
2842 | to VOID. The two types in our fields will be pointers to VOID and | |
2843 | will be replaced in update_pointer_to. Similiarly, if the type | |
2844 | itself is a dummy type or an unconstrained array. Also make | |
2845 | a dummy TYPE_OBJECT_RECORD_TYPE in case we have any thin | |
2846 | pointers to it. */ | |
2847 | ||
2848 | if ((Present (gnat_desig_full) | |
2849 | && Is_Array_Type (gnat_desig_full) | |
2850 | && ! Is_Constrained (gnat_desig_full)) | |
2851 | || (present_gnu_tree (gnat_desig_type) | |
2852 | && TYPE_IS_DUMMY_P (TREE_TYPE | |
2853 | (get_gnu_tree (gnat_desig_type))) | |
2854 | && Is_Array_Type (gnat_desig_type) | |
2855 | && ! Is_Constrained (gnat_desig_type)) | |
2856 | || (present_gnu_tree (gnat_desig_type) | |
2857 | && (TREE_CODE (TREE_TYPE (get_gnu_tree (gnat_desig_type))) | |
2858 | == UNCONSTRAINED_ARRAY_TYPE) | |
2859 | && (TYPE_POINTER_TO (TREE_TYPE | |
2860 | (get_gnu_tree (gnat_desig_type))) | |
2861 | == 0)) | |
2862 | || (No (gnat_desig_full) && ! in_main_unit | |
2863 | && defer_incomplete_level != 0 | |
2864 | && ! present_gnu_tree (gnat_desig_type) | |
2865 | && Is_Array_Type (gnat_desig_type) | |
2866 | && ! Is_Constrained (gnat_desig_type))) | |
2867 | { | |
2868 | tree gnu_old | |
2869 | = (present_gnu_tree (gnat_desig_type) | |
2870 | ? gnat_to_gnu_type (gnat_desig_type) | |
2871 | : make_dummy_type (gnat_desig_type)); | |
2872 | tree fields; | |
2873 | ||
2874 | /* Show the dummy we get will be a fat pointer. */ | |
2875 | got_fat_p = made_dummy = 1; | |
2876 | ||
2877 | /* If the call above got something that has a pointer, that | |
2878 | pointer is our type. This could have happened either | |
2879 | because the type was elaborated or because somebody | |
2880 | else executed the code below. */ | |
2881 | gnu_type = TYPE_POINTER_TO (gnu_old); | |
2882 | if (gnu_type == 0) | |
2883 | { | |
2884 | gnu_type = make_node (RECORD_TYPE); | |
e2500fed | 2885 | SET_TYPE_UNCONSTRAINED_ARRAY (gnu_type, gnu_old); |
70482933 RK |
2886 | TYPE_POINTER_TO (gnu_old) = gnu_type; |
2887 | ||
2888 | set_lineno (gnat_entity, 0); | |
2889 | fields | |
2890 | = chainon (chainon (NULL_TREE, | |
2891 | create_field_decl | |
2892 | (get_identifier ("P_ARRAY"), | |
2893 | ptr_void_type_node, gnu_type, | |
2894 | 0, 0, 0, 0)), | |
2895 | create_field_decl (get_identifier ("P_BOUNDS"), | |
2896 | ptr_void_type_node, | |
2897 | gnu_type, 0, 0, 0, 0)); | |
2898 | ||
2899 | /* Make sure we can place this into a register. */ | |
2900 | TYPE_ALIGN (gnu_type) | |
2901 | = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE); | |
2902 | TYPE_IS_FAT_POINTER_P (gnu_type) = 1; | |
2903 | finish_record_type (gnu_type, fields, 0, 1); | |
2904 | ||
2905 | TYPE_OBJECT_RECORD_TYPE (gnu_old) = make_node (RECORD_TYPE); | |
2906 | TYPE_NAME (TYPE_OBJECT_RECORD_TYPE (gnu_old)) | |
2907 | = concat_id_with_name (get_entity_name (gnat_desig_type), | |
2908 | "XUT"); | |
2909 | TYPE_DUMMY_P (TYPE_OBJECT_RECORD_TYPE (gnu_old)) = 1; | |
2910 | } | |
2911 | } | |
2912 | ||
2913 | /* If we already know what the full type is, use it. */ | |
2914 | else if (Present (gnat_desig_full) | |
2915 | && present_gnu_tree (gnat_desig_full)) | |
7a3a8c06 | 2916 | gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_full)); |
70482933 RK |
2917 | |
2918 | /* Get the type of the thing we are to point to and build a pointer | |
2919 | to it. If it is a reference to an incomplete or private type with a | |
2920 | full view that is a record, make a dummy type node and get the | |
2921 | actual type later when we have verified it is safe. */ | |
2922 | else if (! in_main_unit | |
2923 | && ! present_gnu_tree (gnat_desig_type) | |
2924 | && Present (gnat_desig_full) | |
2925 | && ! present_gnu_tree (gnat_desig_full) | |
2926 | && Is_Record_Type (gnat_desig_full)) | |
2927 | { | |
7a3a8c06 | 2928 | gnu_desig_type = make_dummy_type (gnat_desig_type); |
70482933 RK |
2929 | made_dummy = 1; |
2930 | } | |
2931 | ||
2932 | /* Likewise if we are pointing to a record or array and we are to defer | |
2933 | elaborating incomplete types. We do this since this access type | |
2934 | may be the full view of some private type. Note that the | |
2935 | unconstrained array case is handled above. */ | |
2936 | else if ((! in_main_unit || imported_p) && defer_incomplete_level != 0 | |
2937 | && ! present_gnu_tree (gnat_desig_type) | |
2938 | && ((Is_Record_Type (gnat_desig_type) | |
2939 | || Is_Array_Type (gnat_desig_type)) | |
2940 | || (Present (gnat_desig_full) | |
2941 | && (Is_Record_Type (gnat_desig_full) | |
2942 | || Is_Array_Type (gnat_desig_full))))) | |
2943 | { | |
7a3a8c06 | 2944 | gnu_desig_type = make_dummy_type (gnat_desig_type); |
70482933 RK |
2945 | made_dummy = 1; |
2946 | } | |
2947 | else if (gnat_desig_type == gnat_entity) | |
2948 | { | |
2949 | gnu_type = build_pointer_type (make_node (VOID_TYPE)); | |
2950 | TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) = gnu_type; | |
2951 | } | |
2952 | else | |
7a3a8c06 | 2953 | gnu_desig_type = gnat_to_gnu_type (gnat_desig_type); |
70482933 RK |
2954 | |
2955 | /* It is possible that the above call to gnat_to_gnu_type resolved our | |
2956 | type. If so, just return it. */ | |
2957 | if (present_gnu_tree (gnat_entity)) | |
2958 | { | |
2959 | maybe_present = 1; | |
2960 | break; | |
2961 | } | |
2962 | ||
fbf5a39b AC |
2963 | /* If we have a GCC type for the designated type, possibly modify it |
2964 | if we are pointing only to constant objects and then make a pointer | |
2965 | to it. Don't do this for unconstrained arrays. */ | |
7a3a8c06 RK |
2966 | if (gnu_type == 0 && gnu_desig_type != 0) |
2967 | { | |
2968 | if (Is_Access_Constant (gnat_entity) | |
2969 | && TREE_CODE (gnu_desig_type) != UNCONSTRAINED_ARRAY_TYPE) | |
fbf5a39b AC |
2970 | { |
2971 | gnu_desig_type | |
2972 | = build_qualified_type | |
2973 | (gnu_desig_type, | |
2974 | TYPE_QUALS (gnu_desig_type) | TYPE_QUAL_CONST); | |
2975 | ||
2976 | /* Some extra processing is required if we are building a | |
2977 | pointer to an incomplete type (in the GCC sense). We might | |
2978 | have such a type if we just made a dummy, or directly out | |
2979 | of the call to gnat_to_gnu_type above if we are processing | |
2980 | an access type for a record component designating the | |
2981 | record type itself. */ | |
2982 | if (! COMPLETE_TYPE_P (gnu_desig_type)) | |
2983 | { | |
2984 | /* We must ensure that the pointer to variant we make will | |
2985 | be processed by update_pointer_to when the initial type | |
2986 | is completed. Pretend we made a dummy and let further | |
2987 | processing act as usual. */ | |
2988 | made_dummy = 1; | |
2989 | ||
2990 | /* We must ensure that update_pointer_to will not retrieve | |
2991 | the dummy variant when building a properly qualified | |
2992 | version of the complete type. We take advantage of the | |
2993 | fact that get_qualified_type is requiring TYPE_NAMEs to | |
2994 | match to influence build_qualified_type and then also | |
2995 | update_pointer_to here. */ | |
2996 | TYPE_NAME (gnu_desig_type) | |
2997 | = create_concat_name (gnat_desig_type, "INCOMPLETE_CST"); | |
2998 | } | |
2999 | } | |
7a3a8c06 RK |
3000 | |
3001 | gnu_type = build_pointer_type (gnu_desig_type); | |
3002 | } | |
3003 | ||
70482933 RK |
3004 | /* If we are not defining this object and we made a dummy pointer, |
3005 | save our current definition, evaluate the actual type, and replace | |
3006 | the tentative type we made with the actual one. If we are to defer | |
3007 | actually looking up the actual type, make an entry in the | |
3008 | deferred list. */ | |
3009 | ||
3010 | if (! in_main_unit && made_dummy) | |
3011 | { | |
3012 | tree gnu_old_type | |
3013 | = TYPE_FAT_POINTER_P (gnu_type) | |
3014 | ? TYPE_UNCONSTRAINED_ARRAY (gnu_type) : TREE_TYPE (gnu_type); | |
3015 | ||
3016 | if (esize == POINTER_SIZE | |
3017 | && (got_fat_p || TYPE_FAT_POINTER_P (gnu_type))) | |
3018 | gnu_type | |
3019 | = build_pointer_type | |
3020 | (TYPE_OBJECT_RECORD_TYPE | |
3021 | (TYPE_UNCONSTRAINED_ARRAY (gnu_type))); | |
3022 | ||
3023 | gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, | |
3024 | ! Comes_From_Source (gnat_entity), | |
3025 | debug_info_p); | |
3026 | save_gnu_tree (gnat_entity, gnu_decl, 0); | |
3027 | this_made_decl = saved = 1; | |
3028 | ||
3029 | if (defer_incomplete_level == 0) | |
fbf5a39b AC |
3030 | { |
3031 | update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_type), | |
3032 | gnat_to_gnu_type (gnat_desig_type)); | |
3033 | /* Note that the call to gnat_to_gnu_type here might have | |
3034 | updated gnu_old_type directly, in which case it is not a | |
3035 | dummy type any more when we get into update_pointer_to. | |
3036 | ||
3037 | This may happen for instance when the designated type is a | |
3038 | record type, because their elaboration starts with an | |
3039 | initial node from make_dummy_type, which may yield the same | |
3040 | node as the one we got. | |
3041 | ||
3042 | Besides, variants of this non-dummy type might have been | |
3043 | created along the way. update_pointer_to is expected to | |
3044 | properly take care of those situations. */ | |
3045 | } | |
70482933 RK |
3046 | else |
3047 | { | |
3048 | struct incomplete *p | |
3049 | = (struct incomplete *) xmalloc (sizeof (struct incomplete)); | |
3050 | ||
3051 | p->old_type = gnu_old_type; | |
3052 | p->full_type = gnat_desig_type; | |
3053 | p->next = defer_incomplete_list; | |
3054 | defer_incomplete_list = p; | |
3055 | } | |
3056 | } | |
3057 | } | |
3058 | break; | |
3059 | ||
3060 | case E_Access_Protected_Subprogram_Type: | |
3061 | if (type_annotate_only && No (Equivalent_Type (gnat_entity))) | |
3062 | gnu_type = build_pointer_type (void_type_node); | |
3063 | else | |
3064 | /* The runtime representation is the equivalent type. */ | |
3065 | gnu_type = gnat_to_gnu_type (Equivalent_Type (gnat_entity)); | |
3066 | ||
3067 | if (Is_Itype (Directly_Designated_Type (gnat_entity)) | |
3068 | && ! present_gnu_tree (Directly_Designated_Type (gnat_entity)) | |
3069 | && No (Freeze_Node (Directly_Designated_Type (gnat_entity))) | |
3070 | && ! Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity)))) | |
3071 | gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity), | |
3072 | NULL_TREE, 0); | |
3073 | ||
3074 | break; | |
3075 | ||
3076 | case E_Access_Subtype: | |
3077 | ||
3078 | /* We treat this as identical to its base type; any constraint is | |
3079 | meaningful only to the front end. | |
3080 | ||
3081 | The designated type must be elaborated as well, if it does | |
3082 | not have its own freeze node. Designated (sub)types created | |
3083 | for constrained components of records with discriminants are | |
3084 | not frozen by the front end and thus not elaborated by gigi, | |
3085 | because their use may appear before the base type is frozen, | |
3086 | and because it is not clear that they are needed anywhere in | |
3087 | Gigi. With the current model, there is no correct place where | |
3088 | they could be elaborated. */ | |
3089 | ||
3090 | gnu_type = gnat_to_gnu_type (Etype (gnat_entity)); | |
3091 | if (Is_Itype (Directly_Designated_Type (gnat_entity)) | |
3092 | && ! present_gnu_tree (Directly_Designated_Type (gnat_entity)) | |
3093 | && Is_Frozen (Directly_Designated_Type (gnat_entity)) | |
3094 | && No (Freeze_Node (Directly_Designated_Type (gnat_entity)))) | |
3095 | { | |
3096 | /* If we are not defining this entity, and we have incomplete | |
3097 | entities being processed above us, make a dummy type and | |
3098 | elaborate it later. */ | |
3099 | if (! definition && defer_incomplete_level != 0) | |
3100 | { | |
3101 | struct incomplete *p | |
3102 | = (struct incomplete *) xmalloc (sizeof (struct incomplete)); | |
3103 | tree gnu_ptr_type | |
3104 | = build_pointer_type | |
3105 | (make_dummy_type (Directly_Designated_Type (gnat_entity))); | |
3106 | ||
3107 | p->old_type = TREE_TYPE (gnu_ptr_type); | |
3108 | p->full_type = Directly_Designated_Type (gnat_entity); | |
3109 | p->next = defer_incomplete_list; | |
3110 | defer_incomplete_list = p; | |
3111 | } | |
fbf5a39b AC |
3112 | else if |
3113 | (IN (Ekind (Base_Type (Directly_Designated_Type (gnat_entity))), | |
3114 | Incomplete_Or_Private_Kind)) | |
3115 | { ;} | |
70482933 RK |
3116 | else |
3117 | gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity), | |
3118 | NULL_TREE, 0); | |
3119 | } | |
3120 | ||
3121 | maybe_present = 1; | |
3122 | break; | |
3123 | ||
3124 | /* Subprogram Entities | |
3125 | ||
3126 | The following access functions are defined for subprograms (functions | |
3127 | or procedures): | |
3128 | ||
3129 | First_Formal The first formal parameter. | |
3130 | Is_Imported Indicates that the subprogram has appeared in | |
3131 | an INTERFACE or IMPORT pragma. For now we | |
3132 | assume that the external language is C. | |
3133 | Is_Inlined True if the subprogram is to be inlined. | |
3134 | ||
3135 | In addition for function subprograms we have: | |
3136 | ||
3137 | Etype Return type of the function. | |
3138 | ||
3139 | Each parameter is first checked by calling must_pass_by_ref on its | |
3140 | type to determine if it is passed by reference. For parameters which | |
3141 | are copied in, if they are Ada IN OUT or OUT parameters, their return | |
3142 | value becomes part of a record which becomes the return type of the | |
3143 | function (C function - note that this applies only to Ada procedures | |
3144 | so there is no Ada return type). Additional code to store back the | |
3145 | parameters will be generated on the caller side. This transformation | |
3146 | is done here, not in the front-end. | |
3147 | ||
3148 | The intended result of the transformation can be seen from the | |
3149 | equivalent source rewritings that follow: | |
3150 | ||
3151 | struct temp {int a,b}; | |
3152 | procedure P (A,B: IN OUT ...) is temp P (int A,B) { | |
3153 | .. .. | |
3154 | end P; return {A,B}; | |
3155 | } | |
3156 | procedure call | |
3157 | ||
3158 | { | |
3159 | temp t; | |
3160 | P(X,Y); t = P(X,Y); | |
3161 | X = t.a , Y = t.b; | |
3162 | } | |
3163 | ||
3164 | For subprogram types we need to perform mainly the same conversions to | |
3165 | GCC form that are needed for procedures and function declarations. The | |
3166 | only difference is that at the end, we make a type declaration instead | |
3167 | of a function declaration. */ | |
3168 | ||
3169 | case E_Subprogram_Type: | |
3170 | case E_Function: | |
3171 | case E_Procedure: | |
3172 | { | |
3173 | /* The first GCC parameter declaration (a PARM_DECL node). The | |
3174 | PARM_DECL nodes are chained through the TREE_CHAIN field, so this | |
3175 | actually is the head of this parameter list. */ | |
3176 | tree gnu_param_list = NULL_TREE; | |
3177 | /* The type returned by a function. If the subprogram is a procedure | |
3178 | this type should be void_type_node. */ | |
3179 | tree gnu_return_type = void_type_node; | |
3180 | /* List of fields in return type of procedure with copy in copy out | |
3181 | parameters. */ | |
3182 | tree gnu_field_list = NULL_TREE; | |
3183 | /* Non-null for subprograms containing parameters passed by copy in | |
3184 | copy out (Ada IN OUT or OUT parameters not passed by reference), | |
3185 | in which case it is the list of nodes used to specify the values of | |
3186 | the in out/out parameters that are returned as a record upon | |
3187 | procedure return. The TREE_PURPOSE of an element of this list is | |
3188 | a field of the record and the TREE_VALUE is the PARM_DECL | |
3189 | corresponding to that field. This list will be saved in the | |
3190 | TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */ | |
3191 | tree gnu_return_list = NULL_TREE; | |
3192 | Entity_Id gnat_param; | |
3193 | int inline_flag = Is_Inlined (gnat_entity); | |
3194 | int public_flag = Is_Public (gnat_entity); | |
3195 | int extern_flag | |
3196 | = (Is_Public (gnat_entity) && !definition) || imported_p; | |
3197 | int pure_flag = Is_Pure (gnat_entity); | |
3198 | int volatile_flag = No_Return (gnat_entity); | |
3199 | int returns_by_ref = 0; | |
3200 | int returns_unconstrained = 0; | |
fbf5a39b | 3201 | tree gnu_ext_name = create_concat_name (gnat_entity, 0); |
70482933 RK |
3202 | int has_copy_in_out = 0; |
3203 | int parmnum; | |
3204 | ||
3205 | if (kind == E_Subprogram_Type && ! definition) | |
3206 | /* A parameter may refer to this type, so defer completion | |
3207 | of any incomplete types. */ | |
3208 | defer_incomplete_level++, this_deferred = 1; | |
3209 | ||
3210 | /* If the subprogram has an alias, it is probably inherited, so | |
3211 | we can use the original one. If the original "subprogram" | |
3212 | is actually an enumeration literal, it may be the first use | |
3213 | of its type, so we must elaborate that type now. */ | |
3214 | if (Present (Alias (gnat_entity))) | |
3215 | { | |
3216 | if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal) | |
3217 | gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE, 0); | |
3218 | ||
3219 | gnu_decl = gnat_to_gnu_entity (Alias (gnat_entity), | |
3220 | gnu_expr, 0); | |
3221 | ||
3222 | /* Elaborate any Itypes in the parameters of this entity. */ | |
3223 | for (gnat_temp = First_Formal (gnat_entity); | |
3224 | Present (gnat_temp); | |
3225 | gnat_temp = Next_Formal_With_Extras (gnat_temp)) | |
3226 | if (Is_Itype (Etype (gnat_temp))) | |
3227 | gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0); | |
3228 | ||
3229 | break; | |
3230 | } | |
3231 | ||
3232 | if (kind == E_Function || kind == E_Subprogram_Type) | |
3233 | gnu_return_type = gnat_to_gnu_type (Etype (gnat_entity)); | |
3234 | ||
3235 | /* If this function returns by reference, make the actual | |
3236 | return type of this function the pointer and mark the decl. */ | |
3237 | if (Returns_By_Ref (gnat_entity)) | |
3238 | { | |
3239 | returns_by_ref = 1; | |
70482933 RK |
3240 | gnu_return_type = build_pointer_type (gnu_return_type); |
3241 | } | |
3242 | ||
fbf5a39b AC |
3243 | /* If the Mechanism is By_Reference, ensure the return type uses |
3244 | the machine's by-reference mechanism, which may not the same | |
3245 | as above (e.g., it might be by passing a fake parameter). */ | |
3246 | else if (kind == E_Function | |
3247 | && Mechanism (gnat_entity) == By_Reference) | |
3248 | { | |
3249 | gnu_return_type = copy_type (gnu_return_type); | |
3250 | TREE_ADDRESSABLE (gnu_return_type) = 1; | |
3251 | } | |
3252 | ||
70482933 RK |
3253 | /* If we are supposed to return an unconstrained array, |
3254 | actually return a fat pointer and make a note of that. Return | |
3255 | a pointer to an unconstrained record of variable size. */ | |
3256 | else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE) | |
3257 | { | |
3258 | gnu_return_type = TREE_TYPE (gnu_return_type); | |
3259 | returns_unconstrained = 1; | |
3260 | } | |
3261 | ||
fbf5a39b AC |
3262 | /* If the type requires a transient scope, the result is allocated |
3263 | on the secondary stack, so the result type of the function is | |
3264 | just a pointer. */ | |
70482933 RK |
3265 | else if (Requires_Transient_Scope (Etype (gnat_entity))) |
3266 | { | |
3267 | gnu_return_type = build_pointer_type (gnu_return_type); | |
3268 | returns_unconstrained = 1; | |
3269 | } | |
3270 | ||
3271 | /* If the type is a padded type and the underlying type would not | |
3272 | be passed by reference or this function has a foreign convention, | |
3273 | return the underlying type. */ | |
3274 | else if (TREE_CODE (gnu_return_type) == RECORD_TYPE | |
3275 | && TYPE_IS_PADDING_P (gnu_return_type) | |
3276 | && (! default_pass_by_ref (TREE_TYPE | |
3277 | (TYPE_FIELDS (gnu_return_type))) | |
3278 | || Has_Foreign_Convention (gnat_entity))) | |
3279 | gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type)); | |
3280 | ||
3281 | /* Look at all our parameters and get the type of | |
3282 | each. While doing this, build a copy-out structure if | |
3283 | we need one. */ | |
3284 | ||
91b1417d AC |
3285 | /* If the return type has a size that overflows, we cannot have |
3286 | a function that returns that type. This usage doesn't make | |
3287 | sense anyway, so give an error here. */ | |
3288 | if (TYPE_SIZE_UNIT (gnu_return_type) | |
3289 | && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_return_type))) | |
3290 | { | |
3291 | post_error ("cannot return type whose size overflows", | |
3292 | gnat_entity); | |
3293 | gnu_return_type = copy_node (gnu_return_type); | |
3294 | TYPE_SIZE (gnu_return_type) = bitsize_zero_node; | |
3295 | TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node; | |
3296 | TYPE_MAIN_VARIANT (gnu_return_type) = gnu_return_type; | |
3297 | TYPE_NEXT_VARIANT (gnu_return_type) = 0; | |
3298 | } | |
3299 | ||
70482933 RK |
3300 | for (gnat_param = First_Formal (gnat_entity), parmnum = 0; |
3301 | Present (gnat_param); | |
3302 | gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++) | |
3303 | { | |
3304 | tree gnu_param_name = get_entity_name (gnat_param); | |
3305 | tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param)); | |
3306 | tree gnu_param, gnu_field; | |
3307 | int by_ref_p = 0; | |
3308 | int by_descr_p = 0; | |
3309 | int by_component_ptr_p = 0; | |
3310 | int copy_in_copy_out_flag = 0; | |
3311 | int req_by_copy = 0, req_by_ref = 0; | |
3312 | ||
3313 | /* See if a Mechanism was supplied that forced this | |
3314 | parameter to be passed one way or another. */ | |
3315 | if (Is_Valued_Procedure (gnat_entity) && parmnum == 0) | |
3316 | req_by_copy = 1; | |
3317 | else if (Mechanism (gnat_param) == Default) | |
3318 | ; | |
3319 | else if (Mechanism (gnat_param) == By_Copy) | |
3320 | req_by_copy = 1; | |
3321 | else if (Mechanism (gnat_param) == By_Reference) | |
3322 | req_by_ref = 1; | |
3323 | else if (Mechanism (gnat_param) <= By_Descriptor) | |
3324 | by_descr_p = 1; | |
3325 | else if (Mechanism (gnat_param) > 0) | |
3326 | { | |
3327 | if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE | |
3328 | || TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST | |
3329 | || 0 < compare_tree_int (TYPE_SIZE (gnu_param_type), | |
3330 | Mechanism (gnat_param))) | |
3331 | req_by_ref = 1; | |
3332 | else | |
3333 | req_by_copy = 1; | |
3334 | } | |
3335 | else | |
3336 | post_error ("unsupported mechanism for&", gnat_param); | |
3337 | ||
3338 | /* If this is either a foreign function or if the | |
3339 | underlying type won't be passed by refererence, strip off | |
3340 | possible padding type. */ | |
3341 | if (TREE_CODE (gnu_param_type) == RECORD_TYPE | |
3342 | && TYPE_IS_PADDING_P (gnu_param_type) | |
3343 | && (req_by_ref || Has_Foreign_Convention (gnat_entity) | |
3344 | || ! must_pass_by_ref (TREE_TYPE (TYPE_FIELDS | |
3345 | (gnu_param_type))))) | |
3346 | gnu_param_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type)); | |
3347 | ||
3348 | /* If this is an IN parameter it is read-only, so make a variant | |
3349 | of the type that is read-only. | |
3350 | ||
3351 | ??? However, if this is an unconstrained array, that type can | |
3352 | be very complex. So skip it for now. Likewise for any other | |
3353 | self-referential type. */ | |
3354 | if (Ekind (gnat_param) == E_In_Parameter | |
3355 | && TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE | |
3356 | && ! (TYPE_SIZE (gnu_param_type) != 0 | |
fbf5a39b | 3357 | && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type)))) |
70482933 RK |
3358 | gnu_param_type |
3359 | = build_qualified_type (gnu_param_type, | |
3360 | (TYPE_QUALS (gnu_param_type) | |
3361 | | TYPE_QUAL_CONST)); | |
3362 | ||
3363 | /* For foreign conventions, pass arrays as a pointer to the | |
3364 | underlying type. First check for unconstrained array and get | |
3365 | the underlying array. Then get the component type and build | |
3366 | a pointer to it. */ | |
3367 | if (Has_Foreign_Convention (gnat_entity) | |
3368 | && TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE) | |
3369 | gnu_param_type | |
3370 | = TREE_TYPE (TREE_TYPE (TYPE_FIELDS | |
3371 | (TREE_TYPE (gnu_param_type)))); | |
3372 | ||
3373 | if (by_descr_p) | |
3374 | gnu_param_type | |
3375 | = build_pointer_type | |
3376 | (build_vms_descriptor (gnu_param_type, | |
3377 | Mechanism (gnat_param), | |
3378 | gnat_entity)); | |
3379 | ||
3380 | else if (Has_Foreign_Convention (gnat_entity) | |
3381 | && ! req_by_copy | |
3382 | && TREE_CODE (gnu_param_type) == ARRAY_TYPE) | |
3383 | { | |
3384 | /* Strip off any multi-dimensional entries, then strip | |
3385 | off the last array to get the component type. */ | |
3386 | while (TREE_CODE (TREE_TYPE (gnu_param_type)) == ARRAY_TYPE | |
3387 | && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type))) | |
3388 | gnu_param_type = TREE_TYPE (gnu_param_type); | |
3389 | ||
3390 | by_component_ptr_p = 1; | |
3391 | gnu_param_type = TREE_TYPE (gnu_param_type); | |
3392 | ||
3393 | if (Ekind (gnat_param) == E_In_Parameter) | |
3394 | gnu_param_type | |
3395 | = build_qualified_type (gnu_param_type, | |
3396 | (TYPE_QUALS (gnu_param_type) | |
3397 | | TYPE_QUAL_CONST)); | |
3398 | ||
3399 | gnu_param_type = build_pointer_type (gnu_param_type); | |
3400 | } | |
3401 | ||
3402 | /* Fat pointers are passed as thin pointers for foreign | |
3403 | conventions. */ | |
3404 | else if (Has_Foreign_Convention (gnat_entity) | |
3405 | && TYPE_FAT_POINTER_P (gnu_param_type)) | |
3406 | gnu_param_type | |
3407 | = make_type_from_size (gnu_param_type, | |
3408 | size_int (POINTER_SIZE), 0); | |
3409 | ||
3410 | /* If we must pass or were requested to pass by reference, do so. | |
3411 | If we were requested to pass by copy, do so. | |
3412 | Otherwise, for foreign conventions, pass all in out parameters | |
3413 | or aggregates by reference. For COBOL and Fortran, pass | |
3414 | all integer and FP types that way too. For Convention Ada, | |
3415 | use the standard Ada default. */ | |
fbf5a39b | 3416 | else if (must_pass_by_ref (gnu_param_type) || req_by_ref |
70482933 RK |
3417 | || (! req_by_copy |
3418 | && ((Has_Foreign_Convention (gnat_entity) | |
3419 | && (Ekind (gnat_param) != E_In_Parameter | |
3420 | || AGGREGATE_TYPE_P (gnu_param_type))) | |
3421 | || (((Convention (gnat_entity) | |
3422 | == Convention_Fortran) | |
3423 | || (Convention (gnat_entity) | |
3424 | == Convention_COBOL)) | |
3425 | && (INTEGRAL_TYPE_P (gnu_param_type) | |
3426 | || FLOAT_TYPE_P (gnu_param_type))) | |
3427 | /* For convention Ada, see if we pass by reference | |
3428 | by default. */ | |
3429 | || (! Has_Foreign_Convention (gnat_entity) | |
3430 | && default_pass_by_ref (gnu_param_type))))) | |
3431 | { | |
3432 | gnu_param_type = build_reference_type (gnu_param_type); | |
3433 | by_ref_p = 1; | |
3434 | } | |
3435 | ||
fbf5a39b | 3436 | else if (Ekind (gnat_param) != E_In_Parameter) |
70482933 RK |
3437 | copy_in_copy_out_flag = 1; |
3438 | ||
3439 | if (req_by_copy && (by_ref_p || by_component_ptr_p)) | |
3440 | post_error ("?cannot pass & by copy", gnat_param); | |
3441 | ||
3442 | /* If this is an OUT parameter that isn't passed by reference | |
3443 | and isn't a pointer or aggregate, we don't make a PARM_DECL | |
3444 | for it. Instead, it will be a VAR_DECL created when we process | |
3445 | the procedure. For the special parameter of Valued_Procedure, | |
fbf5a39b AC |
3446 | never pass it in. |
3447 | ||
3448 | An exception is made to cover the RM-6.4.1 rule requiring "by | |
3449 | copy" out parameters with discriminants or implicit initial | |
3450 | values to be handled like in out parameters. These type are | |
3451 | normally built as aggregates, and hence passed by reference, | |
3452 | except for some packed arrays which end up encoded in special | |
3453 | integer types. | |
3454 | ||
3455 | The exception we need to make is then for packed arrays of | |
3456 | records with discriminants or implicit initial values. We have | |
3457 | no light/easy way to check for the latter case, so we merely | |
3458 | check for packed arrays of records. This may lead to useless | |
3459 | copy-in operations, but in very rare cases only, as these would | |
3460 | be exceptions in a set of already exceptional situations. */ | |
70482933 RK |
3461 | if (Ekind (gnat_param) == E_Out_Parameter && ! by_ref_p |
3462 | && ((Is_Valued_Procedure (gnat_entity) && parmnum == 0) | |
3463 | || (! by_descr_p | |
3464 | && ! POINTER_TYPE_P (gnu_param_type) | |
fbf5a39b AC |
3465 | && ! AGGREGATE_TYPE_P (gnu_param_type))) |
3466 | && ! (Is_Array_Type (Etype (gnat_param)) | |
3467 | && Is_Packed (Etype (gnat_param)) | |
3468 | && Is_Composite_Type (Component_Type | |
3469 | (Etype (gnat_param))))) | |
70482933 RK |
3470 | gnu_param = 0; |
3471 | else | |
3472 | { | |
3473 | set_lineno (gnat_param, 0); | |
3474 | gnu_param | |
3475 | = create_param_decl | |
3476 | (gnu_param_name, gnu_param_type, | |
3477 | by_ref_p || by_component_ptr_p | |
3478 | || Ekind (gnat_param) == E_In_Parameter); | |
3479 | ||
3480 | DECL_BY_REF_P (gnu_param) = by_ref_p; | |
3481 | DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr_p; | |
3482 | DECL_BY_DESCRIPTOR_P (gnu_param) = by_descr_p; | |
3483 | DECL_POINTS_TO_READONLY_P (gnu_param) | |
3484 | = (Ekind (gnat_param) == E_In_Parameter | |
3485 | && (by_ref_p || by_component_ptr_p)); | |
3486 | save_gnu_tree (gnat_param, gnu_param, 0); | |
3487 | gnu_param_list = chainon (gnu_param, gnu_param_list); | |
3488 | ||
3489 | /* If a parameter is a pointer, this function may modify | |
3490 | memory through it and thus shouldn't be considered | |
3491 | a pure function. Also, the memory may be modified | |
3492 | between two calls, so they can't be CSE'ed. The latter | |
3493 | case also handles by-ref parameters. */ | |
3494 | if (POINTER_TYPE_P (gnu_param_type) | |
3495 | || TYPE_FAT_POINTER_P (gnu_param_type)) | |
3496 | pure_flag = 0; | |
3497 | } | |
3498 | ||
fbf5a39b | 3499 | if (copy_in_copy_out_flag) |
70482933 RK |
3500 | { |
3501 | if (! has_copy_in_out) | |
3502 | { | |
3503 | if (TREE_CODE (gnu_return_type) != VOID_TYPE) | |
3504 | gigi_abort (111); | |
3505 | ||
3506 | gnu_return_type = make_node (RECORD_TYPE); | |
3507 | TYPE_NAME (gnu_return_type) = get_identifier ("RETURN"); | |
3508 | has_copy_in_out = 1; | |
3509 | } | |
3510 | ||
3511 | set_lineno (gnat_param, 0); | |
3512 | gnu_field = create_field_decl (gnu_param_name, gnu_param_type, | |
3513 | gnu_return_type, 0, 0, 0, 0); | |
3514 | TREE_CHAIN (gnu_field) = gnu_field_list; | |
3515 | gnu_field_list = gnu_field; | |
3516 | gnu_return_list = tree_cons (gnu_field, gnu_param, | |
3517 | gnu_return_list); | |
3518 | } | |
3519 | } | |
3520 | ||
fbf5a39b AC |
3521 | /* Do not compute record for out parameters if subprogram is |
3522 | stubbed since structures are incomplete for the back-end. */ | |
70482933 RK |
3523 | if (gnu_field_list != 0 |
3524 | && Convention (gnat_entity) != Convention_Stubbed) | |
3525 | finish_record_type (gnu_return_type, nreverse (gnu_field_list), | |
3526 | 0, 0); | |
3527 | ||
3528 | /* If we have a CICO list but it has only one entry, we convert | |
3529 | this function into a function that simply returns that one | |
3530 | object. */ | |
3531 | if (list_length (gnu_return_list) == 1) | |
3532 | gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_return_list)); | |
3533 | ||
fbf5a39b | 3534 | #ifdef _WIN32 |
70482933 RK |
3535 | if (Convention (gnat_entity) == Convention_Stdcall) |
3536 | { | |
3537 | struct attrib *attr | |
3538 | = (struct attrib *) xmalloc (sizeof (struct attrib)); | |
3539 | ||
3540 | attr->next = attr_list; | |
3541 | attr->type = ATTR_MACHINE_ATTRIBUTE; | |
3542 | attr->name = get_identifier ("stdcall"); | |
3543 | attr->arg = NULL_TREE; | |
3544 | attr->error_point = gnat_entity; | |
3545 | attr_list = attr; | |
3546 | } | |
fbf5a39b | 3547 | #endif |
70482933 RK |
3548 | |
3549 | /* Both lists ware built in reverse. */ | |
3550 | gnu_param_list = nreverse (gnu_param_list); | |
3551 | gnu_return_list = nreverse (gnu_return_list); | |
3552 | ||
3553 | gnu_type | |
3554 | = create_subprog_type (gnu_return_type, gnu_param_list, | |
3555 | gnu_return_list, returns_unconstrained, | |
3556 | returns_by_ref, | |
3557 | Function_Returns_With_DSP (gnat_entity)); | |
3558 | ||
638e383e | 3559 | /* ??? For now, don't consider nested functions pure. */ |
70482933 RK |
3560 | if (! global_bindings_p ()) |
3561 | pure_flag = 0; | |
657a9dd9 AC |
3562 | |
3563 | /* A subprogram (something that doesn't return anything) shouldn't | |
3564 | be considered Pure since there would be no reason for such a | |
3565 | subprogram. Note that procedures with Out (or In Out) parameters | |
3566 | have already been converted into a function with a return type. */ | |
3567 | if (TREE_CODE (gnu_return_type) == VOID_TYPE) | |
3568 | pure_flag = 0; | |
70482933 RK |
3569 | |
3570 | gnu_type | |
3571 | = build_qualified_type (gnu_type, | |
3572 | (TYPE_QUALS (gnu_type) | |
3573 | | (TYPE_QUAL_CONST * pure_flag) | |
3574 | | (TYPE_QUAL_VOLATILE * volatile_flag))); | |
3575 | ||
70482933 RK |
3576 | set_lineno (gnat_entity, 0); |
3577 | ||
fbf5a39b AC |
3578 | /* If there was no specified Interface_Name and the external and |
3579 | internal names of the subprogram are the same, only use the | |
3580 | internal name to allow disambiguation of nested subprograms. */ | |
3581 | if (No (Interface_Name (gnat_entity)) && gnu_ext_name == gnu_entity_id) | |
3582 | gnu_ext_name = 0; | |
3583 | ||
70482933 RK |
3584 | /* If we are defining the subprogram and it has an Address clause |
3585 | we must get the address expression from the saved GCC tree for the | |
3586 | subprogram if it has a Freeze_Node. Otherwise, we elaborate | |
3587 | the address expression here since the front-end has guaranteed | |
3588 | in that case that the elaboration has no effects. If there is | |
3589 | an Address clause and we are not defining the object, just | |
3590 | make it a constant. */ | |
3591 | if (Present (Address_Clause (gnat_entity))) | |
3592 | { | |
3593 | tree gnu_address = 0; | |
3594 | ||
3595 | if (definition) | |
3596 | gnu_address | |
3597 | = (present_gnu_tree (gnat_entity) | |
3598 | ? get_gnu_tree (gnat_entity) | |
3599 | : gnat_to_gnu (Expression (Address_Clause (gnat_entity)))); | |
3600 | ||
3601 | save_gnu_tree (gnat_entity, NULL_TREE, 0); | |
3602 | ||
3603 | gnu_type = build_reference_type (gnu_type); | |
3604 | if (gnu_address != 0) | |
3605 | gnu_address = convert (gnu_type, gnu_address); | |
3606 | ||
3607 | gnu_decl | |
3608 | = create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type, | |
3609 | gnu_address, 0, Is_Public (gnat_entity), | |
3610 | extern_flag, 0, 0); | |
3611 | DECL_BY_REF_P (gnu_decl) = 1; | |
3612 | } | |
3613 | ||
fbf5a39b AC |
3614 | else if (kind == E_Subprogram_Type) |
3615 | gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, | |
70482933 RK |
3616 | ! Comes_From_Source (gnat_entity), |
3617 | debug_info_p); | |
fbf5a39b | 3618 | else |
70482933 RK |
3619 | { |
3620 | gnu_decl = create_subprog_decl (gnu_entity_id, gnu_ext_name, | |
3621 | gnu_type, gnu_param_list, | |
3622 | inline_flag, public_flag, | |
3623 | extern_flag, attr_list); | |
3624 | DECL_STUBBED_P (gnu_decl) | |
3625 | = Convention (gnat_entity) == Convention_Stubbed; | |
3626 | } | |
3627 | } | |
3628 | break; | |
3629 | ||
3630 | case E_Incomplete_Type: | |
3631 | case E_Private_Type: | |
3632 | case E_Limited_Private_Type: | |
3633 | case E_Record_Type_With_Private: | |
3634 | case E_Private_Subtype: | |
3635 | case E_Limited_Private_Subtype: | |
3636 | case E_Record_Subtype_With_Private: | |
3637 | ||
3638 | /* If this type does not have a full view in the unit we are | |
3639 | compiling, then just get the type from its Etype. */ | |
3640 | if (No (Full_View (gnat_entity))) | |
3641 | { | |
3642 | /* If this is an incomplete type with no full view, it must | |
3643 | be a Taft Amendement type, so just return a dummy type. */ | |
3644 | if (kind == E_Incomplete_Type) | |
3645 | gnu_type = make_dummy_type (gnat_entity); | |
3646 | ||
3647 | else if (Present (Underlying_Full_View (gnat_entity))) | |
3648 | gnu_decl = gnat_to_gnu_entity (Underlying_Full_View (gnat_entity), | |
3649 | NULL_TREE, 0); | |
3650 | else | |
3651 | { | |
3652 | gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity), | |
3653 | NULL_TREE, 0); | |
3654 | maybe_present = 1; | |
3655 | } | |
3656 | ||
3657 | break; | |
3658 | } | |
3659 | ||
3660 | /* Otherwise, if we are not defining the type now, get the | |
3661 | type from the full view. But always get the type from the full | |
3662 | view for define on use types, since otherwise we won't see them! */ | |
3663 | ||
3664 | else if (! definition | |
3665 | || (Is_Itype (Full_View (gnat_entity)) | |
3666 | && No (Freeze_Node (gnat_entity))) | |
3667 | || (Is_Itype (gnat_entity) | |
3668 | && No (Freeze_Node (Full_View (gnat_entity))))) | |
3669 | { | |
3670 | gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity), | |
3671 | NULL_TREE, 0); | |
3672 | maybe_present = 1; | |
3673 | break; | |
3674 | } | |
3675 | ||
3676 | /* For incomplete types, make a dummy type entry which will be | |
3677 | replaced later. */ | |
3678 | gnu_type = make_dummy_type (gnat_entity); | |
3679 | ||
3680 | /* Save this type as the full declaration's type so we can do any needed | |
3681 | updates when we see it. */ | |
3682 | set_lineno (gnat_entity, 0); | |
3683 | gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, | |
3684 | ! Comes_From_Source (gnat_entity), | |
3685 | debug_info_p); | |
3686 | save_gnu_tree (Full_View (gnat_entity), gnu_decl, 0); | |
3687 | break; | |
3688 | ||
3689 | /* Simple class_wide types are always viewed as their root_type | |
3690 | by Gigi unless an Equivalent_Type is specified. */ | |
3691 | case E_Class_Wide_Type: | |
3692 | if (Present (Equivalent_Type (gnat_entity))) | |
3693 | gnu_type = gnat_to_gnu_type (Equivalent_Type (gnat_entity)); | |
3694 | else | |
3695 | gnu_type = gnat_to_gnu_type (Root_Type (gnat_entity)); | |
3696 | ||
3697 | maybe_present = 1; | |
3698 | break; | |
3699 | ||
3700 | case E_Task_Type: | |
3701 | case E_Task_Subtype: | |
3702 | case E_Protected_Type: | |
3703 | case E_Protected_Subtype: | |
3704 | if (type_annotate_only && No (Corresponding_Record_Type (gnat_entity))) | |
3705 | gnu_type = void_type_node; | |
3706 | else | |
3707 | gnu_type = gnat_to_gnu_type (Corresponding_Record_Type (gnat_entity)); | |
3708 | ||
3709 | maybe_present = 1; | |
3710 | break; | |
3711 | ||
3712 | case E_Label: | |
3713 | gnu_decl = create_label_decl (gnu_entity_id); | |
3714 | break; | |
3715 | ||
3716 | case E_Block: | |
3717 | case E_Loop: | |
3718 | /* Nothing at all to do here, so just return an ERROR_MARK and claim | |
3719 | we've already saved it, so we don't try to. */ | |
3720 | gnu_decl = error_mark_node; | |
3721 | saved = 1; | |
3722 | break; | |
3723 | ||
3724 | default: | |
3725 | gigi_abort (113); | |
3726 | } | |
3727 | ||
3728 | /* If we had a case where we evaluated another type and it might have | |
3729 | defined this one, handle it here. */ | |
3730 | if (maybe_present && present_gnu_tree (gnat_entity)) | |
3731 | { | |
3732 | gnu_decl = get_gnu_tree (gnat_entity); | |
3733 | saved = 1; | |
3734 | } | |
3735 | ||
3736 | /* If we are processing a type and there is either no decl for it or | |
3737 | we just made one, do some common processing for the type, such as | |
3738 | handling alignment and possible padding. */ | |
3739 | ||
3740 | if ((gnu_decl == 0 || this_made_decl) && IN (kind, Type_Kind)) | |
3741 | { | |
fbf5a39b AC |
3742 | if (Is_Tagged_Type (gnat_entity) |
3743 | || Is_Class_Wide_Equivalent_Type (gnat_entity)) | |
07fc65c4 | 3744 | TYPE_ALIGN_OK (gnu_type) = 1; |
70482933 RK |
3745 | |
3746 | if (AGGREGATE_TYPE_P (gnu_type) && Is_By_Reference_Type (gnat_entity)) | |
3747 | TYPE_BY_REFERENCE_P (gnu_type) = 1; | |
3748 | ||
3749 | /* ??? Don't set the size for a String_Literal since it is either | |
3750 | confirming or we don't handle it properly (if the low bound is | |
3751 | non-constant). */ | |
3752 | if (gnu_size == 0 && kind != E_String_Literal_Subtype) | |
3753 | gnu_size = validate_size (Esize (gnat_entity), gnu_type, gnat_entity, | |
3754 | TYPE_DECL, 0, Has_Size_Clause (gnat_entity)); | |
3755 | ||
3756 | /* If a size was specified, see if we can make a new type of that size | |
3757 | by rearranging the type, for example from a fat to a thin pointer. */ | |
3758 | if (gnu_size != 0) | |
3759 | { | |
3760 | gnu_type | |
3761 | = make_type_from_size (gnu_type, gnu_size, | |
3762 | Has_Biased_Representation (gnat_entity)); | |
3763 | ||
3764 | if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0) | |
3765 | && operand_equal_p (rm_size (gnu_type), gnu_size, 0)) | |
3766 | gnu_size = 0; | |
3767 | } | |
3768 | ||
3769 | /* If the alignment hasn't already been processed and this is | |
3770 | not an unconstrained array, see if an alignment is specified. | |
3771 | If not, we pick a default alignment for atomic objects. */ | |
3772 | if (align != 0 || TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE) | |
3773 | ; | |
3774 | else if (Known_Alignment (gnat_entity)) | |
3775 | align = validate_alignment (Alignment (gnat_entity), gnat_entity, | |
3776 | TYPE_ALIGN (gnu_type)); | |
3777 | else if (Is_Atomic (gnat_entity) && gnu_size == 0 | |
3778 | && host_integerp (TYPE_SIZE (gnu_type), 1) | |
3779 | && integer_pow2p (TYPE_SIZE (gnu_type))) | |
3780 | align = MIN (BIGGEST_ALIGNMENT, | |
3781 | tree_low_cst (TYPE_SIZE (gnu_type), 1)); | |
3782 | else if (Is_Atomic (gnat_entity) && gnu_size != 0 | |
3783 | && host_integerp (gnu_size, 1) | |
3784 | && integer_pow2p (gnu_size)) | |
3785 | align = MIN (BIGGEST_ALIGNMENT, tree_low_cst (gnu_size, 1)); | |
3786 | ||
3787 | /* See if we need to pad the type. If we did, and made a record, | |
3788 | the name of the new type may be changed. So get it back for | |
3789 | us when we make the new TYPE_DECL below. */ | |
3790 | gnu_type = maybe_pad_type (gnu_type, gnu_size, align, | |
3791 | gnat_entity, "PAD", 1, definition, 0); | |
3792 | if (TREE_CODE (gnu_type) == RECORD_TYPE | |
3793 | && TYPE_IS_PADDING_P (gnu_type)) | |
3794 | { | |
3795 | gnu_entity_id = TYPE_NAME (gnu_type); | |
3796 | if (TREE_CODE (gnu_entity_id) == TYPE_DECL) | |
3797 | gnu_entity_id = DECL_NAME (gnu_entity_id); | |
3798 | } | |
3799 | ||
3800 | set_rm_size (RM_Size (gnat_entity), gnu_type, gnat_entity); | |
3801 | ||
3802 | /* If we are at global level, GCC will have applied variable_size to | |
3803 | the type, but that won't have done anything. So, if it's not | |
3804 | a constant or self-referential, call elaborate_expression_1 to | |
3805 | make a variable for the size rather than calculating it each time. | |
3806 | Handle both the RM size and the actual size. */ | |
3807 | if (global_bindings_p () | |
3808 | && TYPE_SIZE (gnu_type) != 0 | |
fbf5a39b AC |
3809 | && ! TREE_CONSTANT (TYPE_SIZE (gnu_type)) |
3810 | && ! CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))) | |
70482933 RK |
3811 | { |
3812 | if (TREE_CODE (gnu_type) == RECORD_TYPE | |
3813 | && operand_equal_p (TYPE_ADA_SIZE (gnu_type), | |
3814 | TYPE_SIZE (gnu_type), 0)) | |
e2500fed GK |
3815 | { |
3816 | TYPE_SIZE (gnu_type) | |
3817 | = elaborate_expression_1 (gnat_entity, gnat_entity, | |
3818 | TYPE_SIZE (gnu_type), | |
3819 | get_identifier ("SIZE"), | |
3820 | definition, 0); | |
3821 | SET_TYPE_ADA_SIZE (gnu_type, TYPE_SIZE (gnu_type)); | |
3822 | } | |
70482933 RK |
3823 | else |
3824 | { | |
3825 | TYPE_SIZE (gnu_type) | |
3826 | = elaborate_expression_1 (gnat_entity, gnat_entity, | |
3827 | TYPE_SIZE (gnu_type), | |
3828 | get_identifier ("SIZE"), | |
3829 | definition, 0); | |
07fc65c4 GB |
3830 | |
3831 | /* ??? For now, store the size as a multiple of the alignment | |
3832 | in bytes so that we can see the alignment from the tree. */ | |
70482933 | 3833 | TYPE_SIZE_UNIT (gnu_type) |
07fc65c4 GB |
3834 | = build_binary_op |
3835 | (MULT_EXPR, sizetype, | |
3836 | elaborate_expression_1 | |
3837 | (gnat_entity, gnat_entity, | |
3838 | build_binary_op (EXACT_DIV_EXPR, sizetype, | |
3839 | TYPE_SIZE_UNIT (gnu_type), | |
3840 | size_int (TYPE_ALIGN (gnu_type) | |
3841 | / BITS_PER_UNIT)), | |
3842 | get_identifier ("SIZE_A_UNIT"), | |
3843 | definition, 0), | |
3844 | size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT)); | |
3845 | ||
3846 | if (TREE_CODE (gnu_type) == RECORD_TYPE) | |
e2500fed GK |
3847 | SET_TYPE_ADA_SIZE (gnu_type, |
3848 | elaborate_expression_1 (gnat_entity, gnat_entity, | |
07fc65c4 GB |
3849 | TYPE_ADA_SIZE (gnu_type), |
3850 | get_identifier ("RM_SIZE"), | |
e2500fed | 3851 | definition, 0)); |
70482933 RK |
3852 | } |
3853 | } | |
3854 | ||
3855 | /* If this is a record type or subtype, call elaborate_expression_1 on | |
3856 | any field position. Do this for both global and local types. | |
3857 | Skip any fields that we haven't made trees for to avoid problems with | |
3858 | class wide types. */ | |
3859 | if (IN (kind, Record_Kind)) | |
3860 | for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp); | |
3861 | gnat_temp = Next_Entity (gnat_temp)) | |
3862 | if (Ekind (gnat_temp) == E_Component && present_gnu_tree (gnat_temp)) | |
3863 | { | |
3864 | tree gnu_field = get_gnu_tree (gnat_temp); | |
3865 | ||
07fc65c4 GB |
3866 | /* ??? Unfortunately, GCC needs to be able to prove the |
3867 | alignment of this offset and if it's a variable, it can't. | |
fbf5a39b | 3868 | In GCC 3.4, we'll use DECL_OFFSET_ALIGN in some way, but |
07fc65c4 GB |
3869 | right now, we have to put in an explicit multiply and |
3870 | divide by that value. */ | |
fbf5a39b | 3871 | if (! CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field))) |
70482933 | 3872 | DECL_FIELD_OFFSET (gnu_field) |
07fc65c4 GB |
3873 | = build_binary_op |
3874 | (MULT_EXPR, sizetype, | |
3875 | elaborate_expression_1 | |
fbf5a39b | 3876 | (gnat_temp, gnat_temp, |
07fc65c4 GB |
3877 | build_binary_op (EXACT_DIV_EXPR, sizetype, |
3878 | DECL_FIELD_OFFSET (gnu_field), | |
3879 | size_int (DECL_OFFSET_ALIGN (gnu_field) | |
3880 | / BITS_PER_UNIT)), | |
3881 | get_identifier ("OFFSET"), | |
3882 | definition, 0), | |
3883 | size_int (DECL_OFFSET_ALIGN (gnu_field) / BITS_PER_UNIT)); | |
70482933 RK |
3884 | } |
3885 | ||
3886 | gnu_type = build_qualified_type (gnu_type, | |
3887 | (TYPE_QUALS (gnu_type) | |
3888 | | (TYPE_QUAL_VOLATILE | |
fbf5a39b | 3889 | * Treat_As_Volatile (gnat_entity)))); |
70482933 RK |
3890 | |
3891 | if (Is_Atomic (gnat_entity)) | |
3892 | check_ok_for_atomic (gnu_type, gnat_entity, 0); | |
3893 | ||
3894 | if (Known_Alignment (gnat_entity)) | |
3895 | TYPE_USER_ALIGN (gnu_type) = 1; | |
3896 | ||
3897 | if (gnu_decl == 0) | |
3898 | { | |
3899 | set_lineno (gnat_entity, 0); | |
3900 | gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, | |
3901 | ! Comes_From_Source (gnat_entity), | |
3902 | debug_info_p); | |
3903 | } | |
3904 | else | |
3905 | TREE_TYPE (gnu_decl) = gnu_type; | |
3906 | } | |
3907 | ||
3908 | if (IN (kind, Type_Kind) && ! TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl))) | |
3909 | { | |
3910 | gnu_type = TREE_TYPE (gnu_decl); | |
3911 | ||
3912 | /* Back-annotate the Alignment of the type if not already in the | |
3913 | tree. Likewise for sizes. */ | |
3914 | if (Unknown_Alignment (gnat_entity)) | |
3915 | Set_Alignment (gnat_entity, | |
3916 | UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT)); | |
3917 | ||
3918 | if (Unknown_Esize (gnat_entity) && TYPE_SIZE (gnu_type) != 0) | |
3919 | { | |
3920 | /* If the size is self-referential, we annotate the maximum | |
3921 | value of that size. */ | |
3922 | tree gnu_size = TYPE_SIZE (gnu_type); | |
3923 | ||
fbf5a39b | 3924 | if (CONTAINS_PLACEHOLDER_P (gnu_size)) |
70482933 RK |
3925 | gnu_size = max_size (gnu_size, 1); |
3926 | ||
3927 | Set_Esize (gnat_entity, annotate_value (gnu_size)); | |
fbf5a39b AC |
3928 | |
3929 | if (type_annotate_only && Is_Tagged_Type (gnat_entity)) | |
3930 | { | |
3931 | /* In this mode the tag and the parent components are not | |
3932 | generated by the front-end, so the sizes must be adjusted | |
3933 | explicitly now. */ | |
3934 | ||
3935 | int size_offset; | |
3936 | int new_size; | |
3937 | ||
3938 | if (Is_Derived_Type (gnat_entity)) | |
3939 | { | |
3940 | size_offset | |
3941 | = UI_To_Int (Esize (Etype (Base_Type (gnat_entity)))); | |
3942 | Set_Alignment (gnat_entity, | |
3943 | Alignment (Etype (Base_Type (gnat_entity)))); | |
3944 | } | |
3945 | else | |
3946 | size_offset = POINTER_SIZE; | |
3947 | ||
3948 | new_size = UI_To_Int (Esize (gnat_entity)) + size_offset; | |
3949 | Set_Esize (gnat_entity, | |
3950 | UI_From_Int (((new_size + (POINTER_SIZE - 1)) | |
3951 | / POINTER_SIZE) * POINTER_SIZE)); | |
3952 | Set_RM_Size (gnat_entity, Esize (gnat_entity)); | |
3953 | } | |
70482933 RK |
3954 | } |
3955 | ||
3956 | if (Unknown_RM_Size (gnat_entity) && rm_size (gnu_type) != 0) | |
3957 | Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type))); | |
3958 | } | |
3959 | ||
3960 | if (! Comes_From_Source (gnat_entity) && DECL_P (gnu_decl)) | |
3961 | DECL_ARTIFICIAL (gnu_decl) = 1; | |
3962 | ||
3963 | if (! debug_info_p && DECL_P (gnu_decl) | |
3964 | && TREE_CODE (gnu_decl) != FUNCTION_DECL) | |
3965 | DECL_IGNORED_P (gnu_decl) = 1; | |
3966 | ||
3967 | /* If this decl is really indirect, adjust it. */ | |
3968 | if (TREE_CODE (gnu_decl) == VAR_DECL) | |
3969 | adjust_decl_rtl (gnu_decl); | |
3970 | ||
3971 | /* If we haven't already, associate the ..._DECL node that we just made with | |
3972 | the input GNAT entity node. */ | |
3973 | if (! saved) | |
3974 | save_gnu_tree (gnat_entity, gnu_decl, 0); | |
3975 | ||
3976 | /* If this is an enumeral or floating-point type, we were not able to set | |
3977 | the bounds since they refer to the type. These bounds are always static. | |
3978 | ||
3979 | For enumeration types, also write debugging information and declare the | |
3980 | enumeration literal table, if needed. */ | |
3981 | ||
3982 | if ((kind == E_Enumeration_Type && Present (First_Literal (gnat_entity))) | |
3983 | || (kind == E_Floating_Point_Type && ! Vax_Float (gnat_entity))) | |
3984 | { | |
3985 | tree gnu_scalar_type = gnu_type; | |
3986 | ||
3987 | /* If this is a padded type, we need to use the underlying type. */ | |
3988 | if (TREE_CODE (gnu_scalar_type) == RECORD_TYPE | |
3989 | && TYPE_IS_PADDING_P (gnu_scalar_type)) | |
3990 | gnu_scalar_type = TREE_TYPE (TYPE_FIELDS (gnu_scalar_type)); | |
3991 | ||
3992 | /* If this is a floating point type and we haven't set a floating | |
3993 | point type yet, use this in the evaluation of the bounds. */ | |
3994 | if (longest_float_type_node == 0 && kind == E_Floating_Point_Type) | |
3995 | longest_float_type_node = gnu_type; | |
3996 | ||
3997 | TYPE_MIN_VALUE (gnu_scalar_type) | |
3998 | = gnat_to_gnu (Type_Low_Bound (gnat_entity)); | |
3999 | TYPE_MAX_VALUE (gnu_scalar_type) | |
4000 | = gnat_to_gnu (Type_High_Bound (gnat_entity)); | |
4001 | ||
4002 | if (kind == E_Enumeration_Type) | |
4003 | { | |
4004 | TYPE_STUB_DECL (gnu_scalar_type) = gnu_decl; | |
4005 | ||
4006 | /* Since this has both a typedef and a tag, avoid outputting | |
4007 | the name twice. */ | |
4008 | DECL_ARTIFICIAL (gnu_decl) = 1; | |
4009 | rest_of_type_compilation (gnu_scalar_type, global_bindings_p ()); | |
4010 | } | |
4011 | } | |
4012 | ||
4013 | /* If we deferred processing of incomplete types, re-enable it. If there | |
4014 | were no other disables and we have some to process, do so. */ | |
4015 | if (this_deferred && --defer_incomplete_level == 0 | |
4016 | && defer_incomplete_list != 0) | |
4017 | { | |
4018 | struct incomplete *incp = defer_incomplete_list; | |
4019 | struct incomplete *next; | |
4020 | ||
4021 | defer_incomplete_list = 0; | |
4022 | for (; incp; incp = next) | |
4023 | { | |
4024 | next = incp->next; | |
4025 | ||
4026 | if (incp->old_type != 0) | |
7a3a8c06 | 4027 | update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type), |
70482933 RK |
4028 | gnat_to_gnu_type (incp->full_type)); |
4029 | free (incp); | |
4030 | } | |
4031 | } | |
4032 | ||
4033 | /* If we are not defining this type, see if it's in the incomplete list. | |
4034 | If so, handle that list entry now. */ | |
4035 | else if (! definition) | |
4036 | { | |
4037 | struct incomplete *incp; | |
4038 | ||
4039 | for (incp = defer_incomplete_list; incp; incp = incp->next) | |
4040 | if (incp->old_type != 0 && incp->full_type == gnat_entity) | |
4041 | { | |
7a3a8c06 RK |
4042 | update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type), |
4043 | TREE_TYPE (gnu_decl)); | |
70482933 RK |
4044 | incp->old_type = 0; |
4045 | } | |
4046 | } | |
4047 | ||
4048 | if (this_global) | |
4049 | force_global--; | |
4050 | ||
4051 | if (Is_Packed_Array_Type (gnat_entity) | |
4052 | && Is_Itype (Associated_Node_For_Itype (gnat_entity)) | |
4053 | && No (Freeze_Node (Associated_Node_For_Itype (gnat_entity))) | |
4054 | && ! present_gnu_tree (Associated_Node_For_Itype (gnat_entity))) | |
4055 | gnat_to_gnu_entity (Associated_Node_For_Itype (gnat_entity), NULL_TREE, 0); | |
4056 | ||
4057 | return gnu_decl; | |
4058 | } | |
4059 | \f | |
4060 | /* Given GNAT_ENTITY, elaborate all expressions that are required to | |
4061 | be elaborated at the point of its definition, but do nothing else. */ | |
4062 | ||
4063 | void | |
9373164a | 4064 | elaborate_entity (Entity_Id gnat_entity) |
70482933 RK |
4065 | { |
4066 | switch (Ekind (gnat_entity)) | |
4067 | { | |
4068 | case E_Signed_Integer_Subtype: | |
4069 | case E_Modular_Integer_Subtype: | |
4070 | case E_Enumeration_Subtype: | |
4071 | case E_Ordinary_Fixed_Point_Subtype: | |
4072 | case E_Decimal_Fixed_Point_Subtype: | |
4073 | case E_Floating_Point_Subtype: | |
4074 | { | |
4075 | Node_Id gnat_lb = Type_Low_Bound (gnat_entity); | |
4076 | Node_Id gnat_hb = Type_High_Bound (gnat_entity); | |
4077 | ||
4078 | /* ??? Tests for avoiding static constaint error expression | |
4079 | is needed until the front stops generating bogus conversions | |
4080 | on bounds of real types. */ | |
4081 | ||
4082 | if (! Raises_Constraint_Error (gnat_lb)) | |
4083 | elaborate_expression (gnat_lb, gnat_entity, get_identifier ("L"), | |
4084 | 1, 0, Needs_Debug_Info (gnat_entity)); | |
4085 | if (! Raises_Constraint_Error (gnat_hb)) | |
4086 | elaborate_expression (gnat_hb, gnat_entity, get_identifier ("U"), | |
4087 | 1, 0, Needs_Debug_Info (gnat_entity)); | |
4088 | break; | |
4089 | } | |
4090 | ||
4091 | case E_Record_Type: | |
4092 | { | |
4093 | Node_Id full_definition = Declaration_Node (gnat_entity); | |
4094 | Node_Id record_definition = Type_Definition (full_definition); | |
4095 | ||
4096 | /* If this is a record extension, go a level further to find the | |
4097 | record definition. */ | |
4098 | if (Nkind (record_definition) == N_Derived_Type_Definition) | |
4099 | record_definition = Record_Extension_Part (record_definition); | |
4100 | } | |
4101 | break; | |
4102 | ||
4103 | case E_Record_Subtype: | |
4104 | case E_Private_Subtype: | |
4105 | case E_Limited_Private_Subtype: | |
4106 | case E_Record_Subtype_With_Private: | |
4107 | if (Is_Constrained (gnat_entity) | |
4108 | && Has_Discriminants (Base_Type (gnat_entity)) | |
4109 | && Present (Discriminant_Constraint (gnat_entity))) | |
4110 | { | |
4111 | Node_Id gnat_discriminant_expr; | |
4112 | Entity_Id gnat_field; | |
4113 | ||
4114 | for (gnat_field = First_Discriminant (Base_Type (gnat_entity)), | |
4115 | gnat_discriminant_expr | |
4116 | = First_Elmt (Discriminant_Constraint (gnat_entity)); | |
4117 | Present (gnat_field); | |
4118 | gnat_field = Next_Discriminant (gnat_field), | |
4119 | gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr)) | |
4120 | /* ??? For now, ignore access discriminants. */ | |
4121 | if (! Is_Access_Type (Etype (Node (gnat_discriminant_expr)))) | |
4122 | elaborate_expression (Node (gnat_discriminant_expr), | |
4123 | gnat_entity, | |
4124 | get_entity_name (gnat_field), 1, 0, 0); | |
4125 | } | |
4126 | break; | |
4127 | ||
4128 | } | |
4129 | } | |
4130 | \f | |
4131 | /* Mark GNAT_ENTITY as going out of scope at this point. Recursively mark | |
4132 | any entities on its entity chain similarly. */ | |
4133 | ||
4134 | void | |
9373164a | 4135 | mark_out_of_scope (Entity_Id gnat_entity) |
70482933 RK |
4136 | { |
4137 | Entity_Id gnat_sub_entity; | |
4138 | unsigned int kind = Ekind (gnat_entity); | |
4139 | ||
4140 | /* If this has an entity list, process all in the list. */ | |
4141 | if (IN (kind, Class_Wide_Kind) || IN (kind, Concurrent_Kind) | |
4142 | || IN (kind, Private_Kind) | |
4143 | || kind == E_Block || kind == E_Entry || kind == E_Entry_Family | |
4144 | || kind == E_Function || kind == E_Generic_Function | |
4145 | || kind == E_Generic_Package || kind == E_Generic_Procedure | |
4146 | || kind == E_Loop || kind == E_Operator || kind == E_Package | |
4147 | || kind == E_Package_Body || kind == E_Procedure | |
4148 | || kind == E_Record_Type || kind == E_Record_Subtype | |
4149 | || kind == E_Subprogram_Body || kind == E_Subprogram_Type) | |
4150 | for (gnat_sub_entity = First_Entity (gnat_entity); | |
4151 | Present (gnat_sub_entity); | |
4152 | gnat_sub_entity = Next_Entity (gnat_sub_entity)) | |
4153 | if (Scope (gnat_sub_entity) == gnat_entity | |
4154 | && gnat_sub_entity != gnat_entity) | |
4155 | mark_out_of_scope (gnat_sub_entity); | |
4156 | ||
4157 | /* Now clear this if it has been defined, but only do so if it isn't | |
4158 | a subprogram or parameter. We could refine this, but it isn't | |
4159 | worth it. If this is statically allocated, it is supposed to | |
4160 | hang around out of cope. */ | |
4161 | if (present_gnu_tree (gnat_entity) && ! Is_Statically_Allocated (gnat_entity) | |
4162 | && kind != E_Procedure && kind != E_Function && ! IN (kind, Formal_Kind)) | |
4163 | { | |
4164 | save_gnu_tree (gnat_entity, NULL_TREE, 1); | |
4165 | save_gnu_tree (gnat_entity, error_mark_node, 1); | |
4166 | } | |
4167 | } | |
4168 | \f | |
b7e429ab AC |
4169 | /* Set the alias set of GNU_NEW_TYPE to be that of GNU_OLD_TYPE. If this |
4170 | is a multi-dimensional array type, do this recursively. */ | |
4171 | ||
4172 | static void | |
4173 | copy_alias_set (tree gnu_new_type, tree gnu_old_type) | |
4174 | { | |
4175 | if (TREE_CODE (gnu_new_type) == ARRAY_TYPE | |
4176 | && TREE_CODE (TREE_TYPE (gnu_new_type)) == ARRAY_TYPE | |
4177 | && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_new_type))) | |
4178 | { | |
4179 | /* We need to be careful here in case GNU_OLD_TYPE is an unconstrained | |
4180 | array. In that case, it doesn't have the same shape as GNU_NEW_TYPE, | |
4181 | so we need to go down to what does. */ | |
4182 | if (TREE_CODE (gnu_old_type) == UNCONSTRAINED_ARRAY_TYPE) | |
4183 | gnu_old_type | |
4184 | = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_old_type)))); | |
4185 | ||
4186 | copy_alias_set (TREE_TYPE (gnu_new_type), TREE_TYPE (gnu_old_type)); | |
4187 | } | |
4188 | ||
4189 | TYPE_ALIAS_SET (gnu_new_type) = get_alias_set (gnu_old_type); | |
4190 | record_component_aliases (gnu_new_type); | |
4191 | } | |
4192 | \f | |
70482933 RK |
4193 | /* Return a TREE_LIST describing the substitutions needed to reflect |
4194 | discriminant substitutions from GNAT_SUBTYPE to GNAT_TYPE and add | |
4195 | them to GNU_LIST. If GNAT_TYPE is not specified, use the base type | |
4196 | of GNAT_SUBTYPE. The substitions can be in any order. TREE_PURPOSE | |
4197 | gives the tree for the discriminant and TREE_VALUES is the replacement | |
4198 | value. They are in the form of operands to substitute_in_expr. | |
4199 | DEFINITION is as in gnat_to_gnu_entity. */ | |
4200 | ||
4201 | static tree | |
9373164a KC |
4202 | substitution_list (Entity_Id gnat_subtype, |
4203 | Entity_Id gnat_type, | |
4204 | tree gnu_list, | |
4205 | int definition) | |
70482933 RK |
4206 | { |
4207 | Entity_Id gnat_discrim; | |
4208 | Node_Id gnat_value; | |
4209 | ||
4210 | if (No (gnat_type)) | |
4211 | gnat_type = Implementation_Base_Type (gnat_subtype); | |
4212 | ||
4213 | if (Has_Discriminants (gnat_type)) | |
fbf5a39b AC |
4214 | for (gnat_discrim = First_Stored_Discriminant (gnat_type), |
4215 | gnat_value = First_Elmt (Stored_Constraint (gnat_subtype)); | |
70482933 | 4216 | Present (gnat_discrim); |
fbf5a39b | 4217 | gnat_discrim = Next_Stored_Discriminant (gnat_discrim), |
70482933 RK |
4218 | gnat_value = Next_Elmt (gnat_value)) |
4219 | /* Ignore access discriminants. */ | |
4220 | if (! Is_Access_Type (Etype (Node (gnat_value)))) | |
4221 | gnu_list = tree_cons (gnat_to_gnu_entity (gnat_discrim, NULL_TREE, 0), | |
4222 | elaborate_expression | |
4223 | (Node (gnat_value), gnat_subtype, | |
4224 | get_entity_name (gnat_discrim), definition, | |
4225 | 1, 0), | |
4226 | gnu_list); | |
4227 | ||
4228 | return gnu_list; | |
4229 | } | |
4230 | \f | |
4231 | /* For the following two functions: for each GNAT entity, the GCC | |
4232 | tree node used as a dummy for that entity, if any. */ | |
4233 | ||
e2500fed | 4234 | static GTY((length ("max_gnat_nodes"))) tree * dummy_node_table; |
70482933 RK |
4235 | |
4236 | /* Initialize the above table. */ | |
4237 | ||
4238 | void | |
9373164a | 4239 | init_dummy_type (void) |
70482933 RK |
4240 | { |
4241 | Node_Id gnat_node; | |
4242 | ||
e2500fed | 4243 | dummy_node_table = (tree *) ggc_alloc (max_gnat_nodes * sizeof (tree)); |
70482933 RK |
4244 | |
4245 | for (gnat_node = 0; gnat_node < max_gnat_nodes; gnat_node++) | |
4246 | dummy_node_table[gnat_node] = NULL_TREE; | |
4247 | ||
4248 | dummy_node_table -= First_Node_Id; | |
4249 | } | |
4250 | ||
4251 | /* Make a dummy type corresponding to GNAT_TYPE. */ | |
4252 | ||
4253 | tree | |
9373164a | 4254 | make_dummy_type (Entity_Id gnat_type) |
70482933 RK |
4255 | { |
4256 | Entity_Id gnat_underlying; | |
4257 | tree gnu_type; | |
4258 | ||
4259 | /* Find a full type for GNAT_TYPE, taking into account any class wide | |
4260 | types. */ | |
4261 | if (Is_Class_Wide_Type (gnat_type) && Present (Equivalent_Type (gnat_type))) | |
4262 | gnat_type = Equivalent_Type (gnat_type); | |
4263 | else if (Ekind (gnat_type) == E_Class_Wide_Type) | |
4264 | gnat_type = Root_Type (gnat_type); | |
4265 | ||
4266 | for (gnat_underlying = gnat_type; | |
4267 | (IN (Ekind (gnat_underlying), Incomplete_Or_Private_Kind) | |
4268 | && Present (Full_View (gnat_underlying))); | |
4269 | gnat_underlying = Full_View (gnat_underlying)) | |
4270 | ; | |
4271 | ||
4272 | /* If it there already a dummy type, use that one. Else make one. */ | |
4273 | if (dummy_node_table[gnat_underlying]) | |
4274 | return dummy_node_table[gnat_underlying]; | |
4275 | ||
4276 | /* If this is a record, make this a RECORD_TYPE or UNION_TYPE; else make | |
4277 | it a VOID_TYPE. */ | |
4278 | if (Is_Record_Type (gnat_underlying)) | |
4279 | gnu_type = make_node (Is_Unchecked_Union (gnat_underlying) | |
4280 | ? UNION_TYPE : RECORD_TYPE); | |
4281 | else | |
4282 | gnu_type = make_node (ENUMERAL_TYPE); | |
4283 | ||
4284 | TYPE_NAME (gnu_type) = get_entity_name (gnat_type); | |
4285 | if (AGGREGATE_TYPE_P (gnu_type)) | |
4286 | TYPE_STUB_DECL (gnu_type) | |
4287 | = pushdecl (build_decl (TYPE_DECL, NULL_TREE, gnu_type)); | |
4288 | ||
4289 | TYPE_DUMMY_P (gnu_type) = 1; | |
4290 | dummy_node_table[gnat_underlying] = gnu_type; | |
4291 | ||
4292 | return gnu_type; | |
4293 | } | |
4294 | \f | |
4295 | /* Return 1 if the size represented by GNU_SIZE can be handled by an | |
4296 | allocation. If STATIC_P is non-zero, consider only what can be | |
4297 | done with a static allocation. */ | |
4298 | ||
4299 | static int | |
9373164a | 4300 | allocatable_size_p (tree gnu_size, int static_p) |
70482933 | 4301 | { |
fbf5a39b AC |
4302 | HOST_WIDE_INT our_size; |
4303 | ||
70482933 RK |
4304 | /* If this is not a static allocation, the only case we want to forbid |
4305 | is an overflowing size. That will be converted into a raise a | |
4306 | Storage_Error. */ | |
4307 | if (! static_p) | |
4308 | return ! (TREE_CODE (gnu_size) == INTEGER_CST | |
4309 | && TREE_CONSTANT_OVERFLOW (gnu_size)); | |
4310 | ||
4311 | /* Otherwise, we need to deal with both variable sizes and constant | |
fbf5a39b AC |
4312 | sizes that won't fit in a host int. We use int instead of HOST_WIDE_INT |
4313 | since assemblers may not like very large sizes. */ | |
4314 | if (!host_integerp (gnu_size, 1)) | |
4315 | return 0; | |
4316 | ||
4317 | our_size = tree_low_cst (gnu_size, 1); | |
4318 | return (int) our_size == our_size; | |
70482933 RK |
4319 | } |
4320 | \f | |
4321 | /* Return a list of attributes for GNAT_ENTITY, if any. */ | |
4322 | ||
4323 | static struct attrib * | |
9373164a | 4324 | build_attr_list (Entity_Id gnat_entity) |
70482933 RK |
4325 | { |
4326 | struct attrib *attr_list = 0; | |
4327 | Node_Id gnat_temp; | |
4328 | ||
4329 | for (gnat_temp = First_Rep_Item (gnat_entity); Present (gnat_temp); | |
4330 | gnat_temp = Next_Rep_Item (gnat_temp)) | |
4331 | if (Nkind (gnat_temp) == N_Pragma) | |
4332 | { | |
4333 | struct attrib *attr; | |
4334 | tree gnu_arg0 = 0, gnu_arg1 = 0; | |
4335 | Node_Id gnat_assoc = Pragma_Argument_Associations (gnat_temp); | |
4336 | enum attr_type etype; | |
4337 | ||
4338 | if (Present (gnat_assoc) && Present (First (gnat_assoc)) | |
4339 | && Present (Next (First (gnat_assoc))) | |
4340 | && (Nkind (Expression (Next (First (gnat_assoc)))) | |
4341 | == N_String_Literal)) | |
4342 | { | |
4343 | gnu_arg0 = get_identifier (TREE_STRING_POINTER | |
4344 | (gnat_to_gnu | |
4345 | (Expression (Next | |
4346 | (First (gnat_assoc)))))); | |
4347 | if (Present (Next (Next (First (gnat_assoc)))) | |
4348 | && (Nkind (Expression (Next (Next (First (gnat_assoc))))) | |
4349 | == N_String_Literal)) | |
4350 | gnu_arg1 = get_identifier (TREE_STRING_POINTER | |
4351 | (gnat_to_gnu | |
4352 | (Expression | |
4353 | (Next (Next | |
4354 | (First (gnat_assoc))))))); | |
4355 | } | |
4356 | ||
4357 | switch (Get_Pragma_Id (Chars (gnat_temp))) | |
4358 | { | |
4359 | case Pragma_Machine_Attribute: | |
4360 | etype = ATTR_MACHINE_ATTRIBUTE; | |
4361 | break; | |
4362 | ||
4363 | case Pragma_Linker_Alias: | |
4364 | etype = ATTR_LINK_ALIAS; | |
4365 | break; | |
4366 | ||
4367 | case Pragma_Linker_Section: | |
4368 | etype = ATTR_LINK_SECTION; | |
4369 | break; | |
4370 | ||
4371 | case Pragma_Weak_External: | |
4372 | etype = ATTR_WEAK_EXTERNAL; | |
4373 | break; | |
4374 | ||
4375 | default: | |
4376 | continue; | |
4377 | } | |
4378 | ||
4379 | attr = (struct attrib *) xmalloc (sizeof (struct attrib)); | |
4380 | attr->next = attr_list; | |
4381 | attr->type = etype; | |
4382 | attr->name = gnu_arg0; | |
4383 | attr->arg = gnu_arg1; | |
4384 | attr->error_point | |
4385 | = Present (Next (First (gnat_assoc))) | |
4386 | ? Expression (Next (First (gnat_assoc))) : gnat_temp; | |
4387 | attr_list = attr; | |
4388 | } | |
4389 | ||
4390 | return attr_list; | |
4391 | } | |
4392 | \f | |
4393 | /* Get the unpadded version of a GNAT type. */ | |
4394 | ||
4395 | tree | |
9373164a | 4396 | get_unpadded_type (Entity_Id gnat_entity) |
70482933 RK |
4397 | { |
4398 | tree type = gnat_to_gnu_type (gnat_entity); | |
4399 | ||
4400 | if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type)) | |
4401 | type = TREE_TYPE (TYPE_FIELDS (type)); | |
4402 | ||
4403 | return type; | |
4404 | } | |
4405 | \f | |
4406 | /* Called when we need to protect a variable object using a save_expr. */ | |
4407 | ||
4408 | tree | |
9373164a | 4409 | maybe_variable (tree gnu_operand, Node_Id gnat_node) |
70482933 RK |
4410 | { |
4411 | if (TREE_CONSTANT (gnu_operand) || TREE_READONLY (gnu_operand) | |
4412 | || TREE_CODE (gnu_operand) == SAVE_EXPR | |
4413 | || TREE_CODE (gnu_operand) == NULL_EXPR) | |
4414 | return gnu_operand; | |
4415 | ||
4416 | /* If we will be generating code, make sure we are at the proper | |
4417 | line number. */ | |
fbf5a39b | 4418 | if (! global_bindings_p () && ! CONTAINS_PLACEHOLDER_P (gnu_operand)) |
70482933 RK |
4419 | set_lineno (gnat_node, 1); |
4420 | ||
4421 | if (TREE_CODE (gnu_operand) == UNCONSTRAINED_ARRAY_REF) | |
4422 | return build1 (UNCONSTRAINED_ARRAY_REF, TREE_TYPE (gnu_operand), | |
4423 | variable_size (TREE_OPERAND (gnu_operand, 0))); | |
4424 | else | |
4425 | return variable_size (gnu_operand); | |
4426 | } | |
4427 | \f | |
4428 | /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a | |
4429 | type definition (either a bound or a discriminant value) for GNAT_ENTITY, | |
4430 | return the GCC tree to use for that expression. GNU_NAME is the | |
4431 | qualification to use if an external name is appropriate and DEFINITION is | |
4432 | nonzero if this is a definition of GNAT_ENTITY. If NEED_VALUE is nonzero, | |
4433 | we need a result. Otherwise, we are just elaborating this for | |
4434 | side-effects. If NEED_DEBUG is nonzero we need the symbol for debugging | |
4435 | purposes even if it isn't needed for code generation. */ | |
4436 | ||
4437 | static tree | |
9373164a KC |
4438 | elaborate_expression (Node_Id gnat_expr, |
4439 | Entity_Id gnat_entity, | |
4440 | tree gnu_name, | |
4441 | int definition, | |
4442 | int need_value, | |
4443 | int need_debug) | |
70482933 RK |
4444 | { |
4445 | tree gnu_expr; | |
4446 | ||
4447 | /* If we already elaborated this expression (e.g., it was involved | |
4448 | in the definition of a private type), use the old value. */ | |
4449 | if (present_gnu_tree (gnat_expr)) | |
4450 | return get_gnu_tree (gnat_expr); | |
4451 | ||
4452 | /* If we don't need a value and this is static or a discriment, we | |
4453 | don't need to do anything. */ | |
4454 | else if (! need_value | |
4455 | && (Is_OK_Static_Expression (gnat_expr) | |
4456 | || (Nkind (gnat_expr) == N_Identifier | |
4457 | && Ekind (Entity (gnat_expr)) == E_Discriminant))) | |
4458 | return 0; | |
4459 | ||
4460 | /* Otherwise, convert this tree to its GCC equivalant. */ | |
4461 | gnu_expr | |
4462 | = elaborate_expression_1 (gnat_expr, gnat_entity, gnat_to_gnu (gnat_expr), | |
4463 | gnu_name, definition, need_debug); | |
4464 | ||
4465 | /* Save the expression in case we try to elaborate this entity again. | |
4466 | Since this is not a DECL, don't check it. If this is a constant, | |
4467 | don't save it since GNAT_EXPR might be used more than once. Also, | |
4468 | don't save if it's a discriminant. */ | |
fbf5a39b | 4469 | if (! CONTAINS_PLACEHOLDER_P (gnu_expr)) |
70482933 RK |
4470 | save_gnu_tree (gnat_expr, gnu_expr, 1); |
4471 | ||
4472 | return need_value ? gnu_expr : error_mark_node; | |
4473 | } | |
4474 | ||
4475 | /* Similar, but take a GNU expression. */ | |
4476 | ||
4477 | static tree | |
9373164a KC |
4478 | elaborate_expression_1 (Node_Id gnat_expr, |
4479 | Entity_Id gnat_entity, | |
4480 | tree gnu_expr, | |
4481 | tree gnu_name, | |
4482 | int definition, | |
4483 | int need_debug) | |
70482933 RK |
4484 | { |
4485 | tree gnu_decl = 0; | |
70482933 RK |
4486 | /* Strip any conversions to see if the expression is a readonly variable. |
4487 | ??? This really should remain readonly, but we have to think about | |
4488 | the typing of the tree here. */ | |
07fc65c4 GB |
4489 | tree gnu_inner_expr = remove_conversions (gnu_expr, 1); |
4490 | int expr_global = Is_Public (gnat_entity) || global_bindings_p (); | |
4491 | int expr_variable; | |
70482933 RK |
4492 | |
4493 | /* In most cases, we won't see a naked FIELD_DECL here because a | |
4494 | discriminant reference will have been replaced with a COMPONENT_REF | |
4495 | when the type is being elaborated. However, there are some cases | |
4496 | involving child types where we will. So convert it to a COMPONENT_REF | |
4497 | here. We have to hope it will be at the highest level of the | |
4498 | expression in these cases. */ | |
4499 | if (TREE_CODE (gnu_expr) == FIELD_DECL) | |
4500 | gnu_expr = build (COMPONENT_REF, TREE_TYPE (gnu_expr), | |
4501 | build (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)), | |
4502 | gnu_expr); | |
4503 | ||
70482933 RK |
4504 | /* If GNU_EXPR is neither a placeholder nor a constant, nor a variable |
4505 | that is a constant, make a variable that is initialized to contain the | |
4506 | bound when the package containing the definition is elaborated. If | |
4507 | this entity is defined at top level and a bound or discriminant value | |
4508 | isn't a constant or a reference to a discriminant, replace the bound | |
4509 | by the variable; otherwise use a SAVE_EXPR if needed. Note that we | |
4510 | rely here on the fact that an expression cannot contain both the | |
4511 | discriminant and some other variable. */ | |
4512 | ||
4513 | expr_variable = (TREE_CODE_CLASS (TREE_CODE (gnu_expr)) != 'c' | |
4514 | && ! (TREE_CODE (gnu_inner_expr) == VAR_DECL | |
4515 | && TREE_READONLY (gnu_inner_expr)) | |
fbf5a39b | 4516 | && ! CONTAINS_PLACEHOLDER_P (gnu_expr)); |
70482933 RK |
4517 | |
4518 | /* If this is a static expression or contains a discriminant, we don't | |
4519 | need the variable for debugging (and can't elaborate anyway if a | |
4520 | discriminant). */ | |
4521 | if (need_debug | |
4522 | && (Is_OK_Static_Expression (gnat_expr) | |
fbf5a39b | 4523 | || CONTAINS_PLACEHOLDER_P (gnu_expr))) |
70482933 RK |
4524 | need_debug = 0; |
4525 | ||
4526 | /* Now create the variable if we need it. */ | |
4527 | if (need_debug || (expr_variable && expr_global)) | |
4528 | { | |
4529 | set_lineno (gnat_entity, ! global_bindings_p ()); | |
4530 | gnu_decl | |
4531 | = create_var_decl (create_concat_name (gnat_entity, | |
4532 | IDENTIFIER_POINTER (gnu_name)), | |
4533 | NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr, 1, | |
4534 | Is_Public (gnat_entity), ! definition, 0, 0); | |
4535 | } | |
4536 | ||
4537 | /* We only need to use this variable if we are in global context since GCC | |
4538 | can do the right thing in the local case. */ | |
4539 | if (expr_global && expr_variable) | |
4540 | return gnu_decl; | |
07fc65c4 GB |
4541 | else if (! expr_variable) |
4542 | return gnu_expr; | |
70482933 RK |
4543 | else |
4544 | return maybe_variable (gnu_expr, gnat_expr); | |
4545 | } | |
4546 | \f | |
4547 | /* Create a record type that contains a field of TYPE with a starting bit | |
4548 | position so that it is aligned to ALIGN bits and is SIZE bytes long. */ | |
4549 | ||
4550 | tree | |
9373164a | 4551 | make_aligning_type (tree type, int align, tree size) |
70482933 RK |
4552 | { |
4553 | tree record_type = make_node (RECORD_TYPE); | |
4554 | tree place = build (PLACEHOLDER_EXPR, record_type); | |
4555 | tree size_addr_place = convert (sizetype, | |
4556 | build_unary_op (ADDR_EXPR, NULL_TREE, | |
4557 | place)); | |
4558 | tree name = TYPE_NAME (type); | |
4559 | tree pos, field; | |
4560 | ||
4561 | if (TREE_CODE (name) == TYPE_DECL) | |
4562 | name = DECL_NAME (name); | |
4563 | ||
4564 | TYPE_NAME (record_type) = concat_id_with_name (name, "_ALIGN"); | |
4565 | ||
4566 | /* The bit position is obtained by "and"ing the alignment minus 1 | |
4567 | with the two's complement of the address and multiplying | |
4568 | by the number of bits per unit. Do all this in sizetype. */ | |
4569 | ||
4570 | pos = size_binop (MULT_EXPR, | |
4571 | convert (bitsizetype, | |
fbf5a39b | 4572 | size_binop (BIT_AND_EXPR, |
70482933 RK |
4573 | size_diffop (size_zero_node, |
4574 | size_addr_place), | |
4575 | ssize_int ((align / BITS_PER_UNIT) | |
4576 | - 1))), | |
4577 | bitsize_unit_node); | |
4578 | ||
4579 | field = create_field_decl (get_identifier ("F"), type, record_type, | |
4580 | 1, size, pos, 1); | |
4581 | DECL_BIT_FIELD (field) = 0; | |
4582 | ||
4583 | finish_record_type (record_type, field, 1, 0); | |
4584 | TYPE_ALIGN (record_type) = BIGGEST_ALIGNMENT; | |
4585 | TYPE_SIZE (record_type) | |
4586 | = size_binop (PLUS_EXPR, | |
4587 | size_binop (MULT_EXPR, convert (bitsizetype, size), | |
4588 | bitsize_unit_node), | |
4589 | bitsize_int (align)); | |
4590 | TYPE_SIZE_UNIT (record_type) | |
4591 | = size_binop (PLUS_EXPR, size, size_int (align / BITS_PER_UNIT)); | |
b7e429ab | 4592 | copy_alias_set (record_type, type); |
70482933 RK |
4593 | return record_type; |
4594 | } | |
4595 | \f | |
fbf5a39b AC |
4596 | /* TYPE is a RECORD_TYPE, UNION_TYPE, or QUAL_UNION_TYPE, with BLKmode that's |
4597 | being used as the field type of a packed record. See if we can rewrite it | |
4598 | as a record that has a non-BLKmode type, which we can pack tighter. If so, | |
4599 | return the new type. If not, return the original type. */ | |
70482933 RK |
4600 | |
4601 | static tree | |
9373164a | 4602 | make_packable_type (tree type) |
70482933 | 4603 | { |
fbf5a39b | 4604 | tree new_type = make_node (TREE_CODE (type)); |
70482933 RK |
4605 | tree field_list = NULL_TREE; |
4606 | tree old_field; | |
4607 | ||
4608 | /* Copy the name and flags from the old type to that of the new and set | |
fbf5a39b AC |
4609 | the alignment to try for an integral type. For QUAL_UNION_TYPE, |
4610 | also copy the size. */ | |
70482933 RK |
4611 | TYPE_NAME (new_type) = TYPE_NAME (type); |
4612 | TYPE_LEFT_JUSTIFIED_MODULAR_P (new_type) | |
4613 | = TYPE_LEFT_JUSTIFIED_MODULAR_P (type); | |
4614 | TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type); | |
fbf5a39b AC |
4615 | TYPE_IS_PADDING_P (new_type) = TYPE_IS_PADDING_P (type); |
4616 | if (TREE_CODE (type) == QUAL_UNION_TYPE) | |
4617 | { | |
4618 | TYPE_SIZE (new_type) = TYPE_SIZE (type); | |
4619 | TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (type); | |
4620 | } | |
70482933 RK |
4621 | |
4622 | TYPE_ALIGN (new_type) | |
4623 | = ((HOST_WIDE_INT) 1 | |
4624 | << (floor_log2 (tree_low_cst (TYPE_SIZE (type), 1) - 1) + 1)); | |
4625 | ||
4626 | /* Now copy the fields, keeping the position and size. */ | |
4627 | for (old_field = TYPE_FIELDS (type); old_field != 0; | |
4628 | old_field = TREE_CHAIN (old_field)) | |
4629 | { | |
fbf5a39b AC |
4630 | tree new_field_type = TREE_TYPE (old_field); |
4631 | tree new_field; | |
4632 | ||
4633 | if (TYPE_MODE (new_field_type) == BLKmode | |
4634 | && (TREE_CODE (new_field_type) == RECORD_TYPE | |
4635 | || TREE_CODE (new_field_type) == UNION_TYPE | |
4636 | || TREE_CODE (new_field_type) == QUAL_UNION_TYPE) | |
4637 | && host_integerp (TYPE_SIZE (new_field_type), 1)) | |
4638 | new_field_type = make_packable_type (new_field_type); | |
4639 | ||
4640 | new_field = create_field_decl (DECL_NAME (old_field), new_field_type, | |
4641 | new_type, TYPE_PACKED (type), | |
4642 | DECL_SIZE (old_field), | |
4643 | bit_position (old_field), | |
4644 | ! DECL_NONADDRESSABLE_P (old_field)); | |
70482933 RK |
4645 | |
4646 | DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field); | |
e2500fed GK |
4647 | SET_DECL_ORIGINAL_FIELD (new_field, |
4648 | (DECL_ORIGINAL_FIELD (old_field) != 0 | |
4649 | ? DECL_ORIGINAL_FIELD (old_field) : old_field)); | |
fbf5a39b AC |
4650 | |
4651 | if (TREE_CODE (new_type) == QUAL_UNION_TYPE) | |
4652 | DECL_QUALIFIER (new_field) = DECL_QUALIFIER (old_field); | |
4653 | ||
70482933 RK |
4654 | TREE_CHAIN (new_field) = field_list; |
4655 | field_list = new_field; | |
4656 | } | |
4657 | ||
4658 | finish_record_type (new_type, nreverse (field_list), 1, 1); | |
b7e429ab | 4659 | copy_alias_set (new_type, type); |
70482933 RK |
4660 | return TYPE_MODE (new_type) == BLKmode ? type : new_type; |
4661 | } | |
4662 | \f | |
4663 | /* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type | |
4664 | if needed. We have already verified that SIZE and TYPE are large enough. | |
4665 | ||
4666 | GNAT_ENTITY and NAME_TRAILER are used to name the resulting record and | |
4667 | to issue a warning. | |
4668 | ||
4669 | IS_USER_TYPE is nonzero if we must be sure we complete the original type. | |
4670 | ||
4671 | DEFINITION is nonzero if this type is being defined. | |
4672 | ||
4673 | SAME_RM_SIZE is nonzero if the RM_Size of the resulting type is to be | |
4674 | set to its TYPE_SIZE; otherwise, it's set to the RM_Size of the original | |
4675 | type. */ | |
4676 | ||
4677 | static tree | |
9373164a KC |
4678 | maybe_pad_type (tree type, |
4679 | tree size, | |
4680 | unsigned int align, | |
4681 | Entity_Id gnat_entity, | |
4682 | const char *name_trailer, | |
4683 | int is_user_type, | |
4684 | int definition, | |
4685 | int same_rm_size) | |
70482933 RK |
4686 | { |
4687 | tree orig_size = TYPE_SIZE (type); | |
4688 | tree record; | |
4689 | tree field; | |
4690 | ||
4691 | /* If TYPE is a padded type, see if it agrees with any size and alignment | |
4692 | we were given. If so, return the original type. Otherwise, strip | |
4693 | off the padding, since we will either be returning the inner type | |
4694 | or repadding it. If no size or alignment is specified, use that of | |
4695 | the original padded type. */ | |
4696 | ||
4697 | if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type)) | |
4698 | { | |
4699 | if ((size == 0 | |
4700 | || operand_equal_p (round_up (size, | |
4701 | MAX (align, TYPE_ALIGN (type))), | |
4702 | round_up (TYPE_SIZE (type), | |
4703 | MAX (align, TYPE_ALIGN (type))), | |
4704 | 0)) | |
4705 | && (align == 0 || align == TYPE_ALIGN (type))) | |
4706 | return type; | |
4707 | ||
4708 | if (size == 0) | |
4709 | size = TYPE_SIZE (type); | |
4710 | if (align == 0) | |
4711 | align = TYPE_ALIGN (type); | |
4712 | ||
4713 | type = TREE_TYPE (TYPE_FIELDS (type)); | |
4714 | orig_size = TYPE_SIZE (type); | |
4715 | } | |
4716 | ||
4717 | /* If the size is either not being changed or is being made smaller (which | |
4718 | is not done here (and is only valid for bitfields anyway), show the size | |
4719 | isn't changing. Likewise, clear the alignment if it isn't being | |
4720 | changed. Then return if we aren't doing anything. */ | |
4721 | ||
4722 | if (size != 0 | |
4723 | && (operand_equal_p (size, orig_size, 0) | |
4724 | || (TREE_CODE (orig_size) == INTEGER_CST | |
4725 | && tree_int_cst_lt (size, orig_size)))) | |
4726 | size = 0; | |
4727 | ||
4728 | if (align == TYPE_ALIGN (type)) | |
4729 | align = 0; | |
4730 | ||
4731 | if (align == 0 && size == 0) | |
4732 | return type; | |
4733 | ||
4734 | /* We used to modify the record in place in some cases, but that could | |
4735 | generate incorrect debugging information. So make a new record | |
4736 | type and name. */ | |
4737 | record = make_node (RECORD_TYPE); | |
4738 | ||
4739 | if (Present (gnat_entity)) | |
4740 | TYPE_NAME (record) = create_concat_name (gnat_entity, name_trailer); | |
4741 | ||
4742 | /* If we were making a type, complete the original type and give it a | |
4743 | name. */ | |
4744 | if (is_user_type) | |
4745 | create_type_decl (get_entity_name (gnat_entity), type, | |
4746 | 0, ! Comes_From_Source (gnat_entity), | |
4747 | ! (TYPE_NAME (type) != 0 | |
4748 | && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL | |
4749 | && DECL_IGNORED_P (TYPE_NAME (type)))); | |
4750 | ||
4751 | /* If we are changing the alignment and the input type is a record with | |
4752 | BLKmode and a small constant size, try to make a form that has an | |
4753 | integral mode. That might allow this record to have an integral mode, | |
4754 | which will be much more efficient. There is no point in doing this if a | |
4755 | size is specified unless it is also smaller than the biggest alignment | |
4756 | and it is incorrect to do this if the size of the original type is not a | |
4757 | multiple of the alignment. */ | |
4758 | if (align != 0 | |
4759 | && TREE_CODE (type) == RECORD_TYPE | |
4760 | && TYPE_MODE (type) == BLKmode | |
4761 | && host_integerp (orig_size, 1) | |
4762 | && compare_tree_int (orig_size, BIGGEST_ALIGNMENT) <= 0 | |
4763 | && (size == 0 | |
4764 | || (TREE_CODE (size) == INTEGER_CST | |
4765 | && compare_tree_int (size, BIGGEST_ALIGNMENT) <= 0)) | |
4766 | && tree_low_cst (orig_size, 1) % align == 0) | |
4767 | type = make_packable_type (type); | |
4768 | ||
4769 | field = create_field_decl (get_identifier ("F"), type, record, 0, | |
4770 | NULL_TREE, bitsize_zero_node, 1); | |
4771 | ||
4772 | DECL_INTERNAL_P (field) = 1; | |
4773 | TYPE_SIZE (record) = size != 0 ? size : orig_size; | |
4774 | TYPE_SIZE_UNIT (record) | |
4775 | = convert (sizetype, | |
4776 | size_binop (CEIL_DIV_EXPR, TYPE_SIZE (record), | |
4777 | bitsize_unit_node)); | |
4778 | TYPE_ALIGN (record) = align; | |
4779 | TYPE_IS_PADDING_P (record) = 1; | |
4780 | TYPE_VOLATILE (record) | |
fbf5a39b | 4781 | = Present (gnat_entity) && Treat_As_Volatile (gnat_entity); |
70482933 RK |
4782 | finish_record_type (record, field, 1, 0); |
4783 | ||
4784 | /* Keep the RM_Size of the padded record as that of the old record | |
4785 | if requested. */ | |
e2500fed | 4786 | SET_TYPE_ADA_SIZE (record, same_rm_size ? size : rm_size (type)); |
70482933 RK |
4787 | |
4788 | /* Unless debugging information isn't being written for the input type, | |
4789 | write a record that shows what we are a subtype of and also make a | |
4790 | variable that indicates our size, if variable. */ | |
4791 | if (TYPE_NAME (record) != 0 | |
4792 | && AGGREGATE_TYPE_P (type) | |
4793 | && (TREE_CODE (TYPE_NAME (type)) != TYPE_DECL | |
4794 | || ! DECL_IGNORED_P (TYPE_NAME (type)))) | |
4795 | { | |
4796 | tree marker = make_node (RECORD_TYPE); | |
4797 | tree name = DECL_NAME (TYPE_NAME (record)); | |
4798 | tree orig_name = TYPE_NAME (type); | |
4799 | ||
4800 | if (TREE_CODE (orig_name) == TYPE_DECL) | |
4801 | orig_name = DECL_NAME (orig_name); | |
4802 | ||
4803 | TYPE_NAME (marker) = concat_id_with_name (name, "XVS"); | |
4804 | finish_record_type (marker, | |
4805 | create_field_decl (orig_name, integer_type_node, | |
4806 | marker, 0, NULL_TREE, NULL_TREE, | |
4807 | 0), | |
4808 | 0, 0); | |
4809 | ||
4810 | if (size != 0 && TREE_CODE (size) != INTEGER_CST && definition) | |
4811 | create_var_decl (concat_id_with_name (name, "XVZ"), NULL_TREE, | |
4812 | sizetype, TYPE_SIZE (record), 0, 0, 0, 0, | |
4813 | 0); | |
4814 | } | |
4815 | ||
4816 | type = record; | |
4817 | ||
fbf5a39b | 4818 | if (CONTAINS_PLACEHOLDER_P (orig_size)) |
70482933 RK |
4819 | orig_size = max_size (orig_size, 1); |
4820 | ||
4821 | /* If the size was widened explicitly, maybe give a warning. */ | |
4822 | if (size != 0 && Present (gnat_entity) | |
4823 | && ! operand_equal_p (size, orig_size, 0) | |
4824 | && ! (TREE_CODE (size) == INTEGER_CST | |
4825 | && TREE_CODE (orig_size) == INTEGER_CST | |
4826 | && tree_int_cst_lt (size, orig_size))) | |
4827 | { | |
4828 | Node_Id gnat_error_node = Empty; | |
4829 | ||
4830 | if (Is_Packed_Array_Type (gnat_entity)) | |
4831 | gnat_entity = Associated_Node_For_Itype (gnat_entity); | |
4832 | ||
4833 | if ((Ekind (gnat_entity) == E_Component | |
4834 | || Ekind (gnat_entity) == E_Discriminant) | |
4835 | && Present (Component_Clause (gnat_entity))) | |
4836 | gnat_error_node = Last_Bit (Component_Clause (gnat_entity)); | |
4837 | else if (Present (Size_Clause (gnat_entity))) | |
4838 | gnat_error_node = Expression (Size_Clause (gnat_entity)); | |
4839 | ||
4840 | /* Generate message only for entities that come from source, since | |
4841 | if we have an entity created by expansion, the message will be | |
4842 | generated for some other corresponding source entity. */ | |
4843 | if (Comes_From_Source (gnat_entity) && Present (gnat_error_node)) | |
4844 | post_error_ne_tree ("{^ }bits of & unused?", gnat_error_node, | |
4845 | gnat_entity, | |
4846 | size_diffop (size, orig_size)); | |
4847 | ||
4848 | else if (*name_trailer == 'C' && ! Is_Internal (gnat_entity)) | |
4849 | post_error_ne_tree ("component of& padded{ by ^ bits}?", | |
4850 | gnat_entity, gnat_entity, | |
4851 | size_diffop (size, orig_size)); | |
4852 | } | |
4853 | ||
4854 | return type; | |
4855 | } | |
4856 | \f | |
4857 | /* Given a GNU tree and a GNAT list of choices, generate an expression to test | |
4858 | the value passed against the list of choices. */ | |
4859 | ||
4860 | tree | |
9373164a | 4861 | choices_to_gnu (tree operand, Node_Id choices) |
70482933 RK |
4862 | { |
4863 | Node_Id choice; | |
4864 | Node_Id gnat_temp; | |
4865 | tree result = integer_zero_node; | |
4866 | tree this_test, low = 0, high = 0, single = 0; | |
4867 | ||
4868 | for (choice = First (choices); Present (choice); choice = Next (choice)) | |
4869 | { | |
4870 | switch (Nkind (choice)) | |
4871 | { | |
4872 | case N_Range: | |
4873 | low = gnat_to_gnu (Low_Bound (choice)); | |
4874 | high = gnat_to_gnu (High_Bound (choice)); | |
4875 | ||
4876 | /* There's no good type to use here, so we might as well use | |
4877 | integer_type_node. */ | |
4878 | this_test | |
4879 | = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node, | |
4880 | build_binary_op (GE_EXPR, integer_type_node, | |
4881 | operand, low), | |
4882 | build_binary_op (LE_EXPR, integer_type_node, | |
4883 | operand, high)); | |
4884 | ||
4885 | break; | |
4886 | ||
4887 | case N_Subtype_Indication: | |
4888 | gnat_temp = Range_Expression (Constraint (choice)); | |
4889 | low = gnat_to_gnu (Low_Bound (gnat_temp)); | |
4890 | high = gnat_to_gnu (High_Bound (gnat_temp)); | |
4891 | ||
4892 | this_test | |
4893 | = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node, | |
4894 | build_binary_op (GE_EXPR, integer_type_node, | |
4895 | operand, low), | |
4896 | build_binary_op (LE_EXPR, integer_type_node, | |
4897 | operand, high)); | |
4898 | break; | |
4899 | ||
4900 | case N_Identifier: | |
4901 | case N_Expanded_Name: | |
4902 | /* This represents either a subtype range, an enumeration | |
4903 | literal, or a constant Ekind says which. If an enumeration | |
4904 | literal or constant, fall through to the next case. */ | |
4905 | if (Ekind (Entity (choice)) != E_Enumeration_Literal | |
4906 | && Ekind (Entity (choice)) != E_Constant) | |
4907 | { | |
4908 | tree type = gnat_to_gnu_type (Entity (choice)); | |
4909 | ||
4910 | low = TYPE_MIN_VALUE (type); | |
4911 | high = TYPE_MAX_VALUE (type); | |
4912 | ||
4913 | this_test | |
4914 | = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node, | |
4915 | build_binary_op (GE_EXPR, integer_type_node, | |
4916 | operand, low), | |
4917 | build_binary_op (LE_EXPR, integer_type_node, | |
4918 | operand, high)); | |
4919 | break; | |
4920 | } | |
4921 | /* ... fall through ... */ | |
4922 | case N_Character_Literal: | |
4923 | case N_Integer_Literal: | |
4924 | single = gnat_to_gnu (choice); | |
4925 | this_test = build_binary_op (EQ_EXPR, integer_type_node, operand, | |
4926 | single); | |
4927 | break; | |
4928 | ||
4929 | case N_Others_Choice: | |
4930 | this_test = integer_one_node; | |
4931 | break; | |
4932 | ||
4933 | default: | |
4934 | gigi_abort (114); | |
4935 | } | |
4936 | ||
4937 | result = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, | |
4938 | result, this_test); | |
4939 | } | |
4940 | ||
4941 | return result; | |
4942 | } | |
4943 | \f | |
4944 | /* Return a GCC tree for a field corresponding to GNAT_FIELD to be | |
4945 | placed in GNU_RECORD_TYPE. | |
4946 | ||
4947 | PACKED is 1 if the enclosing record is packed and -1 if the enclosing | |
4948 | record has a Component_Alignment of Storage_Unit. | |
4949 | ||
4950 | DEFINITION is nonzero if this field is for a record being defined. */ | |
4951 | ||
4952 | static tree | |
9373164a KC |
4953 | gnat_to_gnu_field (Entity_Id gnat_field, |
4954 | tree gnu_record_type, | |
4955 | int packed, | |
4956 | int definition) | |
70482933 RK |
4957 | { |
4958 | tree gnu_field_id = get_entity_name (gnat_field); | |
4959 | tree gnu_field_type = gnat_to_gnu_type (Etype (gnat_field)); | |
4960 | tree gnu_orig_field_type = gnu_field_type; | |
4961 | tree gnu_pos = 0; | |
4962 | tree gnu_size = 0; | |
4963 | tree gnu_field; | |
4964 | int needs_strict_alignment | |
4965 | = (Is_Aliased (gnat_field) || Strict_Alignment (Etype (gnat_field)) | |
fbf5a39b | 4966 | || Treat_As_Volatile (gnat_field)); |
70482933 | 4967 | |
fbf5a39b AC |
4968 | /* If this field requires strict alignment or contains an item of |
4969 | variable sized, pretend it isn't packed. */ | |
4970 | if (needs_strict_alignment || is_variable_size (gnu_field_type)) | |
70482933 RK |
4971 | packed = 0; |
4972 | ||
4973 | /* For packed records, this is one of the few occasions on which we use | |
4974 | the official RM size for discrete or fixed-point components, instead | |
4975 | of the normal GNAT size stored in Esize. See description in Einfo: | |
4976 | "Handling of Type'Size Values" for further details. */ | |
4977 | ||
4978 | if (packed == 1) | |
4979 | gnu_size = validate_size (RM_Size (Etype (gnat_field)), gnu_field_type, | |
4980 | gnat_field, FIELD_DECL, 0, 1); | |
4981 | ||
4982 | if (Known_Static_Esize (gnat_field)) | |
4983 | gnu_size = validate_size (Esize (gnat_field), gnu_field_type, | |
4984 | gnat_field, FIELD_DECL, 0, 1); | |
4985 | ||
12e0c41c AC |
4986 | /* If the field's type is left-justified modular, the wrapper can prevent |
4987 | packing so we make the field the type of the inner object unless the | |
4988 | situation forbids it. We may not do that when the field is addressable_p, | |
4989 | typically because in that case this field may later be passed by-ref for | |
4990 | a formal argument expecting the left justification. The condition below | |
4991 | is then matching the addressable_p code for COMPONENT_REF. */ | |
4992 | if (! Is_Aliased (gnat_field) && flag_strict_aliasing | |
4993 | && TREE_CODE (gnu_field_type) == RECORD_TYPE | |
07fc65c4 GB |
4994 | && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_field_type)) |
4995 | gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type)); | |
4996 | ||
4997 | /* If we are packing this record or we have a specified size that's | |
4998 | smaller than that of the field type and the field type is also a record | |
70482933 RK |
4999 | that's BLKmode and with a small constant size, see if we can get a |
5000 | better form of the type that allows more packing. If we can, show | |
5001 | a size was specified for it if there wasn't one so we know to | |
5002 | make this a bitfield and avoid making things wider. */ | |
07fc65c4 | 5003 | if (TREE_CODE (gnu_field_type) == RECORD_TYPE |
70482933 RK |
5004 | && TYPE_MODE (gnu_field_type) == BLKmode |
5005 | && host_integerp (TYPE_SIZE (gnu_field_type), 1) | |
07fc65c4 GB |
5006 | && compare_tree_int (TYPE_SIZE (gnu_field_type), BIGGEST_ALIGNMENT) <= 0 |
5007 | && (packed | |
5008 | || (gnu_size != 0 && tree_int_cst_lt (gnu_size, | |
5009 | TYPE_SIZE (gnu_field_type))))) | |
70482933 RK |
5010 | { |
5011 | gnu_field_type = make_packable_type (gnu_field_type); | |
5012 | ||
5013 | if (gnu_field_type != gnu_orig_field_type && gnu_size == 0) | |
5014 | gnu_size = rm_size (gnu_field_type); | |
5015 | } | |
5016 | ||
fbf5a39b AC |
5017 | /* If we are packing the record and the field is BLKmode, round the |
5018 | size up to a byte boundary. */ | |
5019 | if (packed && TYPE_MODE (gnu_field_type) == BLKmode && gnu_size != 0) | |
5020 | gnu_size = round_up (gnu_size, BITS_PER_UNIT); | |
5021 | ||
70482933 RK |
5022 | if (Present (Component_Clause (gnat_field))) |
5023 | { | |
5024 | gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype); | |
5025 | gnu_size = validate_size (Esize (gnat_field), gnu_field_type, | |
5026 | gnat_field, FIELD_DECL, 0, 1); | |
5027 | ||
5028 | /* Ensure the position does not overlap with the parent subtype, | |
5029 | if there is one. */ | |
5030 | if (Present (Parent_Subtype (Underlying_Type (Scope (gnat_field))))) | |
5031 | { | |
5032 | tree gnu_parent | |
5033 | = gnat_to_gnu_type (Parent_Subtype | |
5034 | (Underlying_Type (Scope (gnat_field)))); | |
5035 | ||
5036 | if (TREE_CODE (TYPE_SIZE (gnu_parent)) == INTEGER_CST | |
5037 | && tree_int_cst_lt (gnu_pos, TYPE_SIZE (gnu_parent))) | |
5038 | { | |
5039 | post_error_ne_tree | |
5040 | ("offset of& must be beyond parent{, minimum allowed is ^}", | |
5041 | First_Bit (Component_Clause (gnat_field)), gnat_field, | |
5042 | TYPE_SIZE_UNIT (gnu_parent)); | |
5043 | } | |
5044 | } | |
5045 | ||
5046 | /* If this field needs strict alignment, ensure the record is | |
5047 | sufficiently aligned and that that position and size are | |
5048 | consistent with the alignment. */ | |
5049 | if (needs_strict_alignment) | |
5050 | { | |
5051 | tree gnu_min_size = round_up (rm_size (gnu_field_type), | |
5052 | TYPE_ALIGN (gnu_field_type)); | |
5053 | ||
5054 | TYPE_ALIGN (gnu_record_type) | |
5055 | = MAX (TYPE_ALIGN (gnu_record_type), TYPE_ALIGN (gnu_field_type)); | |
5056 | ||
5057 | /* If Atomic, the size must match exactly and if aliased, the size | |
5058 | must not be less than the rounded size. */ | |
5059 | if ((Is_Atomic (gnat_field) || Is_Atomic (Etype (gnat_field))) | |
5060 | && ! operand_equal_p (gnu_size, TYPE_SIZE (gnu_field_type), 0)) | |
5061 | { | |
5062 | post_error_ne_tree | |
5063 | ("atomic field& must be natural size of type{ (^)}", | |
5064 | Last_Bit (Component_Clause (gnat_field)), gnat_field, | |
5065 | TYPE_SIZE (gnu_field_type)); | |
5066 | ||
5067 | gnu_size = 0; | |
5068 | } | |
5069 | ||
5070 | else if (Is_Aliased (gnat_field) | |
5071 | && gnu_size != 0 | |
5072 | && tree_int_cst_lt (gnu_size, gnu_min_size)) | |
5073 | { | |
5074 | post_error_ne_tree | |
5075 | ("size of aliased field& too small{, minimum required is ^}", | |
5076 | Last_Bit (Component_Clause (gnat_field)), gnat_field, | |
5077 | gnu_min_size); | |
5078 | gnu_size = 0; | |
5079 | } | |
5080 | ||
fbf5a39b | 5081 | if (! integer_zerop (size_binop |
70482933 RK |
5082 | (TRUNC_MOD_EXPR, gnu_pos, |
5083 | bitsize_int (TYPE_ALIGN (gnu_field_type))))) | |
5084 | { | |
5085 | if (Is_Aliased (gnat_field)) | |
5086 | post_error_ne_num | |
5087 | ("position of aliased field& must be multiple of ^ bits", | |
07fc65c4 | 5088 | First_Bit (Component_Clause (gnat_field)), gnat_field, |
70482933 RK |
5089 | TYPE_ALIGN (gnu_field_type)); |
5090 | ||
fbf5a39b | 5091 | else if (Treat_As_Volatile (gnat_field)) |
70482933 RK |
5092 | post_error_ne_num |
5093 | ("position of volatile field& must be multiple of ^ bits", | |
5094 | First_Bit (Component_Clause (gnat_field)), gnat_field, | |
5095 | TYPE_ALIGN (gnu_field_type)); | |
5096 | ||
5097 | else if (Strict_Alignment (Etype (gnat_field))) | |
5098 | post_error_ne_num | |
5099 | ("position of & with aliased or tagged components not multiple of ^ bits", | |
5100 | First_Bit (Component_Clause (gnat_field)), gnat_field, | |
5101 | TYPE_ALIGN (gnu_field_type)); | |
5102 | else | |
5103 | gigi_abort (124); | |
5104 | ||
5105 | gnu_pos = 0; | |
5106 | } | |
5107 | ||
5108 | /* If an error set the size to zero, show we have no position | |
5109 | either. */ | |
5110 | if (gnu_size == 0) | |
5111 | gnu_pos = 0; | |
5112 | } | |
5113 | ||
5114 | if (Is_Atomic (gnat_field)) | |
5115 | check_ok_for_atomic (gnu_field_type, gnat_field, 0); | |
70482933 RK |
5116 | } |
5117 | ||
5118 | /* If the record has rep clauses and this is the tag field, make a rep | |
5119 | clause for it as well. */ | |
5120 | else if (Has_Specified_Layout (Scope (gnat_field)) | |
5121 | && Chars (gnat_field) == Name_uTag) | |
5122 | { | |
5123 | gnu_pos = bitsize_zero_node; | |
5124 | gnu_size = TYPE_SIZE (gnu_field_type); | |
5125 | } | |
5126 | ||
5127 | /* We need to make the size the maximum for the type if it is | |
07fc65c4 GB |
5128 | self-referential and an unconstrained type. In that case, we can't |
5129 | pack the field since we can't make a copy to align it. */ | |
70482933 RK |
5130 | if (TREE_CODE (gnu_field_type) == RECORD_TYPE |
5131 | && gnu_size == 0 | |
fbf5a39b | 5132 | && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type)) |
70482933 | 5133 | && ! Is_Constrained (Underlying_Type (Etype (gnat_field)))) |
07fc65c4 GB |
5134 | { |
5135 | gnu_size = max_size (TYPE_SIZE (gnu_field_type), 1); | |
5136 | packed = 0; | |
5137 | } | |
70482933 RK |
5138 | |
5139 | /* If no size is specified (or if there was an error), don't specify a | |
5140 | position. */ | |
5141 | if (gnu_size == 0) | |
5142 | gnu_pos = 0; | |
5143 | else | |
5144 | { | |
5145 | /* Unless this field is aliased, we can remove any left-justified | |
5146 | modular type since it's only needed in the unchecked conversion | |
5147 | case, which doesn't apply here. */ | |
5148 | if (! needs_strict_alignment | |
5149 | && TREE_CODE (gnu_field_type) == RECORD_TYPE | |
5150 | && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_field_type)) | |
5151 | gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type)); | |
5152 | ||
5153 | gnu_field_type | |
5154 | = make_type_from_size (gnu_field_type, gnu_size, | |
5155 | Has_Biased_Representation (gnat_field)); | |
5156 | gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0, | |
5157 | gnat_field, "PAD", 0, definition, 1); | |
5158 | } | |
5159 | ||
5160 | if (TREE_CODE (gnu_field_type) == RECORD_TYPE | |
5161 | && TYPE_CONTAINS_TEMPLATE_P (gnu_field_type)) | |
5162 | gigi_abort (118); | |
5163 | ||
fbf5a39b | 5164 | /* Now create the decl for the field. */ |
70482933 RK |
5165 | set_lineno (gnat_field, 0); |
5166 | gnu_field = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type, | |
5167 | packed, gnu_size, gnu_pos, | |
5168 | Is_Aliased (gnat_field)); | |
5169 | ||
fbf5a39b | 5170 | TREE_THIS_VOLATILE (gnu_field) = Treat_As_Volatile (gnat_field); |
70482933 RK |
5171 | |
5172 | if (Ekind (gnat_field) == E_Discriminant) | |
5173 | DECL_DISCRIMINANT_NUMBER (gnu_field) | |
5174 | = UI_To_gnu (Discriminant_Number (gnat_field), sizetype); | |
5175 | ||
5176 | return gnu_field; | |
5177 | } | |
5178 | \f | |
fbf5a39b AC |
5179 | /* Return 1 if TYPE is a type with variable size, a padding type with a field |
5180 | of variable size or is a record that has a field such a field. */ | |
5181 | ||
5182 | static int | |
9373164a | 5183 | is_variable_size (tree type) |
fbf5a39b AC |
5184 | { |
5185 | tree field; | |
5186 | ||
5187 | /* We need not be concerned about this at all if we don't have | |
5188 | strict alignment. */ | |
5189 | if (! STRICT_ALIGNMENT) | |
5190 | return 0; | |
5191 | else if (! TREE_CONSTANT (TYPE_SIZE (type))) | |
5192 | return 1; | |
5193 | else if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type) | |
5194 | && ! TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type)))) | |
5195 | return 1; | |
5196 | else if (TREE_CODE (type) != RECORD_TYPE | |
5197 | && TREE_CODE (type) != UNION_TYPE | |
5198 | && TREE_CODE (type) != QUAL_UNION_TYPE) | |
5199 | return 0; | |
5200 | ||
5201 | for (field = TYPE_FIELDS (type); field != 0; field = TREE_CHAIN (field)) | |
5202 | if (is_variable_size (TREE_TYPE (field))) | |
5203 | return 1; | |
5204 | ||
5205 | return 0; | |
5206 | } | |
5207 | \f | |
70482933 RK |
5208 | /* Return a GCC tree for a record type given a GNAT Component_List and a chain |
5209 | of GCC trees for fields that are in the record and have already been | |
5210 | processed. When called from gnat_to_gnu_entity during the processing of a | |
5211 | record type definition, the GCC nodes for the discriminants will be on | |
5212 | the chain. The other calls to this function are recursive calls from | |
5213 | itself for the Component_List of a variant and the chain is empty. | |
5214 | ||
5215 | PACKED is 1 if this is for a record with "pragma pack" and -1 is this is | |
5216 | for a record type with "pragma component_alignment (storage_unit)". | |
5217 | ||
5218 | FINISH_RECORD is nonzero if this call will supply all of the remaining | |
5219 | fields of the record. | |
5220 | ||
5221 | P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field | |
5222 | with a rep clause is to be added. If it is nonzero, that is all that | |
5223 | should be done with such fields. | |
5224 | ||
5225 | CANCEL_ALIGNMENT, if nonzero, means the alignment should be zeroed | |
5226 | before laying out the record. This means the alignment only serves | |
5227 | to force fields to be bitfields, but not require the record to be | |
5228 | that aligned. This is used for variants. | |
5229 | ||
5230 | ALL_REP, if nonzero, means that a rep clause was found for all the | |
5231 | fields. This simplifies the logic since we know we're not in the mixed | |
5232 | case. | |
5233 | ||
5234 | The processing of the component list fills in the chain with all of the | |
5235 | fields of the record and then the record type is finished. */ | |
5236 | ||
5237 | static void | |
9373164a KC |
5238 | components_to_record (tree gnu_record_type, |
5239 | Node_Id component_list, | |
5240 | tree gnu_field_list, | |
5241 | int packed, | |
5242 | int definition, | |
5243 | tree *p_gnu_rep_list, | |
5244 | int cancel_alignment, | |
5245 | int all_rep) | |
70482933 RK |
5246 | { |
5247 | Node_Id component_decl; | |
5248 | Entity_Id gnat_field; | |
5249 | Node_Id variant_part; | |
5250 | Node_Id variant; | |
5251 | tree gnu_our_rep_list = NULL_TREE; | |
5252 | tree gnu_field, gnu_last; | |
5253 | int layout_with_rep = 0; | |
fbf5a39b | 5254 | int all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type) != 0; |
70482933 RK |
5255 | |
5256 | /* For each variable within each component declaration create a GCC field | |
5257 | and add it to the list, skipping any pragmas in the list. */ | |
5258 | ||
5259 | if (Present (Component_Items (component_list))) | |
5260 | for (component_decl = First_Non_Pragma (Component_Items (component_list)); | |
5261 | Present (component_decl); | |
5262 | component_decl = Next_Non_Pragma (component_decl)) | |
5263 | { | |
5264 | gnat_field = Defining_Entity (component_decl); | |
5265 | ||
5266 | if (Chars (gnat_field) == Name_uParent) | |
5267 | gnu_field = tree_last (TYPE_FIELDS (gnu_record_type)); | |
5268 | else | |
5269 | { | |
5270 | gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type, | |
5271 | packed, definition); | |
5272 | ||
5273 | /* If this is the _Tag field, put it before any discriminants, | |
fbf5a39b AC |
5274 | instead of after them as is the case for all other fields. |
5275 | Ignore field of void type if only annotating. */ | |
70482933 RK |
5276 | if (Chars (gnat_field) == Name_uTag) |
5277 | gnu_field_list = chainon (gnu_field_list, gnu_field); | |
5278 | else | |
5279 | { | |
5280 | TREE_CHAIN (gnu_field) = gnu_field_list; | |
5281 | gnu_field_list = gnu_field; | |
5282 | } | |
5283 | } | |
5284 | ||
5285 | save_gnu_tree (gnat_field, gnu_field, 0); | |
5286 | } | |
5287 | ||
5288 | /* At the end of the component list there may be a variant part. */ | |
5289 | variant_part = Variant_Part (component_list); | |
5290 | ||
5291 | /* If this is an unchecked union, each variant must have exactly one | |
5292 | component, each of which becomes one component of this union. */ | |
5293 | if (TREE_CODE (gnu_record_type) == UNION_TYPE && Present (variant_part)) | |
5294 | for (variant = First_Non_Pragma (Variants (variant_part)); | |
5295 | Present (variant); | |
5296 | variant = Next_Non_Pragma (variant)) | |
5297 | { | |
5298 | component_decl | |
5299 | = First_Non_Pragma (Component_Items (Component_List (variant))); | |
5300 | gnat_field = Defining_Entity (component_decl); | |
5301 | gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type, packed, | |
5302 | definition); | |
5303 | TREE_CHAIN (gnu_field) = gnu_field_list; | |
5304 | gnu_field_list = gnu_field; | |
5305 | save_gnu_tree (gnat_field, gnu_field, 0); | |
5306 | } | |
5307 | ||
5308 | /* We create a QUAL_UNION_TYPE for the variant part since the variants are | |
5309 | mutually exclusive and should go in the same memory. To do this we need | |
5310 | to treat each variant as a record whose elements are created from the | |
5311 | component list for the variant. So here we create the records from the | |
5312 | lists for the variants and put them all into the QUAL_UNION_TYPE. */ | |
5313 | else if (Present (variant_part)) | |
5314 | { | |
5315 | tree gnu_discriminant = gnat_to_gnu (Name (variant_part)); | |
5316 | Node_Id variant; | |
5317 | tree gnu_union_type = make_node (QUAL_UNION_TYPE); | |
5318 | tree gnu_union_field; | |
5319 | tree gnu_variant_list = NULL_TREE; | |
5320 | tree gnu_name = TYPE_NAME (gnu_record_type); | |
5321 | tree gnu_var_name | |
5322 | = concat_id_with_name | |
5323 | (get_identifier (Get_Name_String (Chars (Name (variant_part)))), | |
5324 | "XVN"); | |
5325 | ||
5326 | if (TREE_CODE (gnu_name) == TYPE_DECL) | |
5327 | gnu_name = DECL_NAME (gnu_name); | |
5328 | ||
5329 | TYPE_NAME (gnu_union_type) | |
5330 | = concat_id_with_name (gnu_name, IDENTIFIER_POINTER (gnu_var_name)); | |
5331 | TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type); | |
5332 | ||
5333 | for (variant = First_Non_Pragma (Variants (variant_part)); | |
5334 | Present (variant); | |
5335 | variant = Next_Non_Pragma (variant)) | |
5336 | { | |
5337 | tree gnu_variant_type = make_node (RECORD_TYPE); | |
5338 | tree gnu_inner_name; | |
5339 | tree gnu_qual; | |
5340 | ||
5341 | Get_Variant_Encoding (variant); | |
5342 | gnu_inner_name = get_identifier (Name_Buffer); | |
5343 | TYPE_NAME (gnu_variant_type) | |
5344 | = concat_id_with_name (TYPE_NAME (gnu_union_type), | |
5345 | IDENTIFIER_POINTER (gnu_inner_name)); | |
5346 | ||
5347 | /* Set the alignment of the inner type in case we need to make | |
5348 | inner objects into bitfields, but then clear it out | |
5349 | so the record actually gets only the alignment required. */ | |
5350 | TYPE_ALIGN (gnu_variant_type) = TYPE_ALIGN (gnu_record_type); | |
5351 | TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type); | |
fbf5a39b AC |
5352 | |
5353 | /* Similarly, if the outer record has a size specified and all fields | |
5354 | have record rep clauses, we can propagate the size into the | |
5355 | variant part. */ | |
5356 | if (all_rep_and_size) | |
5357 | { | |
5358 | TYPE_SIZE (gnu_variant_type) = TYPE_SIZE (gnu_record_type); | |
5359 | TYPE_SIZE_UNIT (gnu_variant_type) | |
5360 | = TYPE_SIZE_UNIT (gnu_record_type); | |
5361 | } | |
5362 | ||
70482933 RK |
5363 | components_to_record (gnu_variant_type, Component_List (variant), |
5364 | NULL_TREE, packed, definition, | |
fbf5a39b | 5365 | &gnu_our_rep_list, !all_rep_and_size, all_rep); |
70482933 RK |
5366 | |
5367 | gnu_qual = choices_to_gnu (gnu_discriminant, | |
5368 | Discrete_Choices (variant)); | |
5369 | ||
5370 | Set_Present_Expr (variant, annotate_value (gnu_qual)); | |
5371 | gnu_field = create_field_decl (gnu_inner_name, gnu_variant_type, | |
fbf5a39b AC |
5372 | gnu_union_type, 0, |
5373 | (all_rep_and_size | |
5374 | ? TYPE_SIZE (gnu_record_type) : 0), | |
5375 | (all_rep_and_size | |
5376 | ? bitsize_zero_node : 0), | |
18c0ecbe | 5377 | 0); |
fbf5a39b | 5378 | |
70482933 RK |
5379 | DECL_INTERNAL_P (gnu_field) = 1; |
5380 | DECL_QUALIFIER (gnu_field) = gnu_qual; | |
5381 | TREE_CHAIN (gnu_field) = gnu_variant_list; | |
5382 | gnu_variant_list = gnu_field; | |
5383 | } | |
5384 | ||
12e0c41c AC |
5385 | /* We use to delete the empty variants from the end. However, |
5386 | we no longer do that because we need them to generate complete | |
5387 | debugging information for the variant record. Otherwise, | |
5388 | the union type definition will be missing the fields associated | |
5389 | to these empty variants. */ | |
70482933 RK |
5390 | |
5391 | /* Only make the QUAL_UNION_TYPE if there are any non-empty variants. */ | |
5392 | if (gnu_variant_list != 0) | |
5393 | { | |
fbf5a39b AC |
5394 | if (all_rep_and_size) |
5395 | { | |
5396 | TYPE_SIZE (gnu_union_type) = TYPE_SIZE (gnu_record_type); | |
5397 | TYPE_SIZE_UNIT (gnu_union_type) | |
5398 | = TYPE_SIZE_UNIT (gnu_record_type); | |
5399 | } | |
5400 | ||
70482933 | 5401 | finish_record_type (gnu_union_type, nreverse (gnu_variant_list), |
fbf5a39b | 5402 | all_rep_and_size, 0); |
70482933 RK |
5403 | |
5404 | gnu_union_field | |
5405 | = create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type, | |
5406 | packed, | |
5407 | all_rep ? TYPE_SIZE (gnu_union_type) : 0, | |
18c0ecbe | 5408 | all_rep ? bitsize_zero_node : 0, 0); |
70482933 RK |
5409 | |
5410 | DECL_INTERNAL_P (gnu_union_field) = 1; | |
5411 | TREE_CHAIN (gnu_union_field) = gnu_field_list; | |
5412 | gnu_field_list = gnu_union_field; | |
5413 | } | |
5414 | } | |
5415 | ||
5416 | /* Scan GNU_FIELD_LIST and see if any fields have rep clauses. If they | |
5417 | do, pull them out and put them into GNU_OUR_REP_LIST. We have to do this | |
5418 | in a separate pass since we want to handle the discriminants but can't | |
5419 | play with them until we've used them in debugging data above. | |
5420 | ||
5421 | ??? Note: if we then reorder them, debugging information will be wrong, | |
5422 | but there's nothing that can be done about this at the moment. */ | |
5423 | ||
5424 | for (gnu_field = gnu_field_list, gnu_last = 0; gnu_field; ) | |
5425 | { | |
5426 | if (DECL_FIELD_OFFSET (gnu_field) != 0) | |
5427 | { | |
5428 | tree gnu_next = TREE_CHAIN (gnu_field); | |
5429 | ||
5430 | if (gnu_last == 0) | |
5431 | gnu_field_list = gnu_next; | |
5432 | else | |
5433 | TREE_CHAIN (gnu_last) = gnu_next; | |
5434 | ||
5435 | TREE_CHAIN (gnu_field) = gnu_our_rep_list; | |
5436 | gnu_our_rep_list = gnu_field; | |
5437 | gnu_field = gnu_next; | |
5438 | } | |
5439 | else | |
5440 | { | |
5441 | gnu_last = gnu_field; | |
5442 | gnu_field = TREE_CHAIN (gnu_field); | |
5443 | } | |
5444 | } | |
5445 | ||
5446 | /* If we have any items in our rep'ed field list, it is not the case that all | |
5447 | the fields in the record have rep clauses, and P_REP_LIST is nonzero, | |
5448 | set it and ignore the items. Otherwise, sort the fields by bit position | |
5449 | and put them into their own record if we have any fields without | |
5450 | rep clauses. */ | |
5451 | if (gnu_our_rep_list != 0 && p_gnu_rep_list != 0 && ! all_rep) | |
5452 | *p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_our_rep_list); | |
5453 | else if (gnu_our_rep_list != 0) | |
5454 | { | |
5455 | tree gnu_rep_type | |
5456 | = gnu_field_list == 0 ? gnu_record_type : make_node (RECORD_TYPE); | |
5457 | int len = list_length (gnu_our_rep_list); | |
5458 | tree *gnu_arr = (tree *) alloca (sizeof (tree) * len); | |
5459 | int i; | |
5460 | ||
5461 | /* Set DECL_SECTION_NAME to increasing integers so we have a | |
5462 | stable sort. */ | |
5463 | for (i = 0, gnu_field = gnu_our_rep_list; gnu_field; | |
5464 | gnu_field = TREE_CHAIN (gnu_field), i++) | |
5465 | { | |
5466 | gnu_arr[i] = gnu_field; | |
5467 | DECL_SECTION_NAME (gnu_field) = size_int (i); | |
5468 | } | |
5469 | ||
5470 | qsort (gnu_arr, len, sizeof (tree), compare_field_bitpos); | |
5471 | ||
5472 | /* Put the fields in the list in order of increasing position, which | |
5473 | means we start from the end. */ | |
5474 | gnu_our_rep_list = NULL_TREE; | |
5475 | for (i = len - 1; i >= 0; i--) | |
5476 | { | |
5477 | TREE_CHAIN (gnu_arr[i]) = gnu_our_rep_list; | |
5478 | gnu_our_rep_list = gnu_arr[i]; | |
5479 | DECL_CONTEXT (gnu_arr[i]) = gnu_rep_type; | |
5480 | DECL_SECTION_NAME (gnu_arr[i]) = 0; | |
5481 | } | |
5482 | ||
5483 | if (gnu_field_list != 0) | |
5484 | { | |
5485 | finish_record_type (gnu_rep_type, gnu_our_rep_list, 1, 0); | |
5486 | gnu_field = create_field_decl (get_identifier ("REP"), gnu_rep_type, | |
5487 | gnu_record_type, 0, 0, 0, 1); | |
5488 | DECL_INTERNAL_P (gnu_field) = 1; | |
5489 | gnu_field_list = chainon (gnu_field_list, gnu_field); | |
5490 | } | |
5491 | else | |
5492 | { | |
5493 | layout_with_rep = 1; | |
5494 | gnu_field_list = nreverse (gnu_our_rep_list); | |
5495 | } | |
5496 | } | |
5497 | ||
5498 | if (cancel_alignment) | |
5499 | TYPE_ALIGN (gnu_record_type) = 0; | |
5500 | ||
5501 | finish_record_type (gnu_record_type, nreverse (gnu_field_list), | |
5502 | layout_with_rep, 0); | |
5503 | } | |
5504 | \f | |
5505 | /* Called via qsort from the above. Returns -1, 1, depending on the | |
5506 | bit positions and ordinals of the two fields. */ | |
5507 | ||
5508 | static int | |
9373164a | 5509 | compare_field_bitpos (const PTR rt1, const PTR rt2) |
70482933 RK |
5510 | { |
5511 | tree *t1 = (tree *) rt1; | |
5512 | tree *t2 = (tree *) rt2; | |
5513 | ||
5514 | if (tree_int_cst_equal (bit_position (*t1), bit_position (*t2))) | |
5515 | return | |
5516 | (tree_int_cst_lt (DECL_SECTION_NAME (*t1), DECL_SECTION_NAME (*t2)) | |
5517 | ? -1 : 1); | |
5518 | else if (tree_int_cst_lt (bit_position (*t1), bit_position (*t2))) | |
5519 | return -1; | |
5520 | else | |
5521 | return 1; | |
5522 | } | |
5523 | \f | |
5524 | /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be | |
5525 | placed into an Esize, Component_Bit_Offset, or Component_Size value | |
5526 | in the GNAT tree. */ | |
5527 | ||
5528 | static Uint | |
9373164a | 5529 | annotate_value (tree gnu_size) |
70482933 RK |
5530 | { |
5531 | int len = TREE_CODE_LENGTH (TREE_CODE (gnu_size)); | |
5532 | TCode tcode; | |
fbf5a39b | 5533 | Node_Ref_Or_Val ops[3], ret; |
70482933 | 5534 | int i; |
45659035 | 5535 | int size; |
70482933 | 5536 | |
fbf5a39b AC |
5537 | /* If back annotation is suppressed by the front end, return No_Uint */ |
5538 | if (!Back_Annotate_Rep_Info) | |
5539 | return No_Uint; | |
5540 | ||
5541 | /* See if we've already saved the value for this node. */ | |
5542 | if (IS_EXPR_CODE_CLASS (TREE_CODE_CLASS (TREE_CODE (gnu_size))) | |
5543 | && TREE_COMPLEXITY (gnu_size) != 0) | |
5544 | return (Node_Ref_Or_Val) TREE_COMPLEXITY (gnu_size); | |
5545 | ||
70482933 RK |
5546 | /* If we do not return inside this switch, TCODE will be set to the |
5547 | code to use for a Create_Node operand and LEN (set above) will be | |
5548 | the number of recursive calls for us to make. */ | |
5549 | ||
5550 | switch (TREE_CODE (gnu_size)) | |
5551 | { | |
5552 | case INTEGER_CST: | |
5553 | if (TREE_OVERFLOW (gnu_size)) | |
5554 | return No_Uint; | |
5555 | ||
5556 | /* This may have come from a conversion from some smaller type, | |
5557 | so ensure this is in bitsizetype. */ | |
5558 | gnu_size = convert (bitsizetype, gnu_size); | |
5559 | ||
5560 | /* For negative values, use NEGATE_EXPR of the supplied value. */ | |
5561 | if (tree_int_cst_sgn (gnu_size) < 0) | |
5562 | { | |
5563 | /* The rediculous code below is to handle the case of the largest | |
5564 | negative integer. */ | |
5565 | tree negative_size = size_diffop (bitsize_zero_node, gnu_size); | |
5566 | int adjust = 0; | |
5567 | tree temp; | |
5568 | ||
5569 | if (TREE_CONSTANT_OVERFLOW (negative_size)) | |
5570 | { | |
5571 | negative_size | |
5572 | = size_binop (MINUS_EXPR, bitsize_zero_node, | |
5573 | size_binop (PLUS_EXPR, gnu_size, | |
5574 | bitsize_one_node)); | |
5575 | adjust = 1; | |
5576 | } | |
5577 | ||
5578 | temp = build1 (NEGATE_EXPR, bitsizetype, negative_size); | |
5579 | if (adjust) | |
5580 | temp = build (MINUS_EXPR, bitsizetype, temp, bitsize_one_node); | |
5581 | ||
5582 | return annotate_value (temp); | |
5583 | } | |
5584 | ||
5585 | if (! host_integerp (gnu_size, 1)) | |
5586 | return No_Uint; | |
5587 | ||
5588 | size = tree_low_cst (gnu_size, 1); | |
5589 | ||
5590 | /* This peculiar test is to make sure that the size fits in an int | |
5591 | on machines where HOST_WIDE_INT is not "int". */ | |
5592 | if (tree_low_cst (gnu_size, 1) == size) | |
5593 | return UI_From_Int (size); | |
5594 | else | |
5595 | return No_Uint; | |
5596 | ||
5597 | case COMPONENT_REF: | |
5598 | /* The only case we handle here is a simple discriminant reference. */ | |
5599 | if (TREE_CODE (TREE_OPERAND (gnu_size, 0)) == PLACEHOLDER_EXPR | |
5600 | && TREE_CODE (TREE_OPERAND (gnu_size, 1)) == FIELD_DECL | |
5601 | && DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1)) != 0) | |
5602 | return Create_Node (Discrim_Val, | |
5603 | annotate_value (DECL_DISCRIMINANT_NUMBER | |
5604 | (TREE_OPERAND (gnu_size, 1))), | |
5605 | No_Uint, No_Uint); | |
5606 | else | |
5607 | return No_Uint; | |
5608 | ||
5609 | case NOP_EXPR: case CONVERT_EXPR: case NON_LVALUE_EXPR: | |
5610 | return annotate_value (TREE_OPERAND (gnu_size, 0)); | |
5611 | ||
5612 | /* Now just list the operations we handle. */ | |
5613 | case COND_EXPR: tcode = Cond_Expr; break; | |
5614 | case PLUS_EXPR: tcode = Plus_Expr; break; | |
5615 | case MINUS_EXPR: tcode = Minus_Expr; break; | |
5616 | case MULT_EXPR: tcode = Mult_Expr; break; | |
5617 | case TRUNC_DIV_EXPR: tcode = Trunc_Div_Expr; break; | |
5618 | case CEIL_DIV_EXPR: tcode = Ceil_Div_Expr; break; | |
5619 | case FLOOR_DIV_EXPR: tcode = Floor_Div_Expr; break; | |
5620 | case TRUNC_MOD_EXPR: tcode = Trunc_Mod_Expr; break; | |
5621 | case CEIL_MOD_EXPR: tcode = Ceil_Mod_Expr; break; | |
5622 | case FLOOR_MOD_EXPR: tcode = Floor_Mod_Expr; break; | |
5623 | case EXACT_DIV_EXPR: tcode = Exact_Div_Expr; break; | |
5624 | case NEGATE_EXPR: tcode = Negate_Expr; break; | |
5625 | case MIN_EXPR: tcode = Min_Expr; break; | |
5626 | case MAX_EXPR: tcode = Max_Expr; break; | |
5627 | case ABS_EXPR: tcode = Abs_Expr; break; | |
5628 | case TRUTH_ANDIF_EXPR: tcode = Truth_Andif_Expr; break; | |
5629 | case TRUTH_ORIF_EXPR: tcode = Truth_Orif_Expr; break; | |
5630 | case TRUTH_AND_EXPR: tcode = Truth_And_Expr; break; | |
5631 | case TRUTH_OR_EXPR: tcode = Truth_Or_Expr; break; | |
5632 | case TRUTH_XOR_EXPR: tcode = Truth_Xor_Expr; break; | |
5633 | case TRUTH_NOT_EXPR: tcode = Truth_Not_Expr; break; | |
5634 | case LT_EXPR: tcode = Lt_Expr; break; | |
5635 | case LE_EXPR: tcode = Le_Expr; break; | |
5636 | case GT_EXPR: tcode = Gt_Expr; break; | |
5637 | case GE_EXPR: tcode = Ge_Expr; break; | |
5638 | case EQ_EXPR: tcode = Eq_Expr; break; | |
5639 | case NE_EXPR: tcode = Ne_Expr; break; | |
5640 | ||
5641 | default: | |
5642 | return No_Uint; | |
5643 | } | |
5644 | ||
5645 | /* Now get each of the operands that's relevant for this code. If any | |
5646 | cannot be expressed as a repinfo node, say we can't. */ | |
5647 | for (i = 0; i < 3; i++) | |
5648 | ops[i] = No_Uint; | |
5649 | ||
5650 | for (i = 0; i < len; i++) | |
5651 | { | |
5652 | ops[i] = annotate_value (TREE_OPERAND (gnu_size, i)); | |
5653 | if (ops[i] == No_Uint) | |
5654 | return No_Uint; | |
5655 | } | |
5656 | ||
fbf5a39b AC |
5657 | ret = Create_Node (tcode, ops[0], ops[1], ops[2]); |
5658 | TREE_COMPLEXITY (gnu_size) = ret; | |
5659 | return ret; | |
70482933 RK |
5660 | } |
5661 | ||
5662 | /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding | |
5663 | GCC type, set Component_Bit_Offset and Esize to the position and size | |
5664 | used by Gigi. */ | |
5665 | ||
5666 | static void | |
9373164a | 5667 | annotate_rep (Entity_Id gnat_entity, tree gnu_type) |
70482933 RK |
5668 | { |
5669 | tree gnu_list; | |
5670 | tree gnu_entry; | |
5671 | Entity_Id gnat_field; | |
5672 | ||
5673 | /* We operate by first making a list of all field and their positions | |
5674 | (we can get the sizes easily at any time) by a recursive call | |
5675 | and then update all the sizes into the tree. */ | |
5676 | gnu_list = compute_field_positions (gnu_type, NULL_TREE, | |
07fc65c4 GB |
5677 | size_zero_node, bitsize_zero_node, |
5678 | BIGGEST_ALIGNMENT); | |
70482933 RK |
5679 | |
5680 | for (gnat_field = First_Entity (gnat_entity); Present (gnat_field); | |
5681 | gnat_field = Next_Entity (gnat_field)) | |
5682 | if ((Ekind (gnat_field) == E_Component | |
5683 | || (Ekind (gnat_field) == E_Discriminant | |
fbf5a39b | 5684 | && ! Is_Unchecked_Union (Scope (gnat_field))))) |
70482933 | 5685 | { |
fbf5a39b AC |
5686 | tree parent_offset = bitsize_zero_node; |
5687 | ||
5688 | gnu_entry | |
5689 | = purpose_member (gnat_to_gnu_entity (gnat_field, NULL_TREE, 0), | |
5690 | gnu_list); | |
5691 | ||
5692 | if (gnu_entry) | |
5693 | { | |
5694 | if (type_annotate_only && Is_Tagged_Type (gnat_entity)) | |
5695 | { | |
5696 | /* In this mode the tag and parent components have not been | |
5697 | generated, so we add the appropriate offset to each | |
5698 | component. For a component appearing in the current | |
5699 | extension, the offset is the size of the parent. */ | |
5700 | if (Is_Derived_Type (gnat_entity) | |
5701 | && Original_Record_Component (gnat_field) == gnat_field) | |
5702 | parent_offset | |
5703 | = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))), | |
5704 | bitsizetype); | |
5705 | else | |
5706 | parent_offset = bitsize_int (POINTER_SIZE); | |
5707 | } | |
5708 | ||
5709 | Set_Component_Bit_Offset | |
5710 | (gnat_field, | |
5711 | annotate_value | |
5712 | (size_binop (PLUS_EXPR, | |
5713 | bit_from_pos (TREE_PURPOSE (TREE_VALUE (gnu_entry)), | |
5714 | TREE_VALUE (TREE_VALUE | |
5715 | (TREE_VALUE (gnu_entry)))), | |
5716 | parent_offset))); | |
5717 | ||
5718 | Set_Esize (gnat_field, | |
5719 | annotate_value (DECL_SIZE (TREE_PURPOSE (gnu_entry)))); | |
5720 | } | |
5721 | else if (type_annotate_only | |
5722 | && Is_Tagged_Type (gnat_entity) | |
5723 | && Is_Derived_Type (gnat_entity)) | |
5724 | { | |
5725 | /* If there is no gnu_entry, this is an inherited component whose | |
5726 | position is the same as in the parent type. */ | |
5727 | Set_Component_Bit_Offset | |
5728 | (gnat_field, | |
5729 | Component_Bit_Offset (Original_Record_Component (gnat_field))); | |
5730 | Set_Esize (gnat_field, | |
5731 | Esize (Original_Record_Component (gnat_field))); | |
5732 | } | |
70482933 RK |
5733 | } |
5734 | } | |
5735 | ||
07fc65c4 GB |
5736 | /* Scan all fields in GNU_TYPE and build entries where TREE_PURPOSE is the |
5737 | FIELD_DECL and TREE_VALUE a TREE_LIST with TREE_PURPOSE being the byte | |
5738 | position and TREE_VALUE being a TREE_LIST with TREE_PURPOSE the value to be | |
5739 | placed into DECL_OFFSET_ALIGN and TREE_VALUE the bit position. GNU_POS is | |
5740 | to be added to the position, GNU_BITPOS to the bit position, OFFSET_ALIGN is | |
5741 | the present value of DECL_OFFSET_ALIGN and GNU_LIST is a list of the entries | |
5742 | so far. */ | |
70482933 RK |
5743 | |
5744 | static tree | |
9373164a KC |
5745 | compute_field_positions (tree gnu_type, |
5746 | tree gnu_list, | |
5747 | tree gnu_pos, | |
5748 | tree gnu_bitpos, | |
5749 | unsigned int offset_align) | |
70482933 RK |
5750 | { |
5751 | tree gnu_field; | |
5752 | tree gnu_result = gnu_list; | |
5753 | ||
5754 | for (gnu_field = TYPE_FIELDS (gnu_type); gnu_field; | |
5755 | gnu_field = TREE_CHAIN (gnu_field)) | |
5756 | { | |
5757 | tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos, | |
5758 | DECL_FIELD_BIT_OFFSET (gnu_field)); | |
07fc65c4 GB |
5759 | tree gnu_our_offset = size_binop (PLUS_EXPR, gnu_pos, |
5760 | DECL_FIELD_OFFSET (gnu_field)); | |
5761 | unsigned int our_offset_align | |
5762 | = MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field)); | |
70482933 RK |
5763 | |
5764 | gnu_result | |
5765 | = tree_cons (gnu_field, | |
07fc65c4 GB |
5766 | tree_cons (gnu_our_offset, |
5767 | tree_cons (size_int (our_offset_align), | |
5768 | gnu_our_bitpos, NULL_TREE), | |
5769 | NULL_TREE), | |
70482933 RK |
5770 | gnu_result); |
5771 | ||
5772 | if (DECL_INTERNAL_P (gnu_field)) | |
5773 | gnu_result | |
07fc65c4 GB |
5774 | = compute_field_positions (TREE_TYPE (gnu_field), gnu_result, |
5775 | gnu_our_offset, gnu_our_bitpos, | |
5776 | our_offset_align); | |
70482933 RK |
5777 | } |
5778 | ||
5779 | return gnu_result; | |
5780 | } | |
5781 | \f | |
5782 | /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE | |
5783 | corresponding to GNAT_OBJECT. If size is valid, return a tree corresponding | |
5784 | to its value. Otherwise return 0. KIND is VAR_DECL is we are specifying | |
5785 | the size for an object, TYPE_DECL for the size of a type, and FIELD_DECL | |
5786 | for the size of a field. COMPONENT_P is true if we are being called | |
5787 | to process the Component_Size of GNAT_OBJECT. This is used for error | |
5788 | message handling and to indicate to use the object size of GNU_TYPE. | |
5789 | ZERO_OK is nonzero if a size of zero is permitted; if ZERO_OK is zero, | |
5790 | it means that a size of zero should be treated as an unspecified size. */ | |
5791 | ||
5792 | static tree | |
9373164a KC |
5793 | validate_size (Uint uint_size, |
5794 | tree gnu_type, | |
5795 | Entity_Id gnat_object, | |
5796 | enum tree_code kind, | |
5797 | int component_p, | |
5798 | int zero_ok) | |
70482933 RK |
5799 | { |
5800 | Node_Id gnat_error_node; | |
5801 | tree type_size | |
5802 | = kind == VAR_DECL ? TYPE_SIZE (gnu_type) : rm_size (gnu_type); | |
5803 | tree size; | |
5804 | ||
fbf5a39b | 5805 | /* Find the node to use for errors. */ |
70482933 RK |
5806 | if ((Ekind (gnat_object) == E_Component |
5807 | || Ekind (gnat_object) == E_Discriminant) | |
5808 | && Present (Component_Clause (gnat_object))) | |
5809 | gnat_error_node = Last_Bit (Component_Clause (gnat_object)); | |
5810 | else if (Present (Size_Clause (gnat_object))) | |
5811 | gnat_error_node = Expression (Size_Clause (gnat_object)); | |
5812 | else | |
5813 | gnat_error_node = gnat_object; | |
5814 | ||
fbf5a39b AC |
5815 | /* Return 0 if no size was specified, either because Esize was not Present or |
5816 | the specified size was zero. */ | |
70482933 RK |
5817 | if (No (uint_size) || uint_size == No_Uint) |
5818 | return 0; | |
5819 | ||
fbf5a39b AC |
5820 | /* Get the size as a tree. Give an error if a size was specified, but cannot |
5821 | be represented as in sizetype. */ | |
70482933 RK |
5822 | size = UI_To_gnu (uint_size, bitsizetype); |
5823 | if (TREE_OVERFLOW (size)) | |
5824 | { | |
fbf5a39b AC |
5825 | post_error_ne (component_p ? "component size of & is too large" |
5826 | : "size of & is too large", | |
5827 | gnat_error_node, gnat_object); | |
70482933 RK |
5828 | return 0; |
5829 | } | |
70482933 RK |
5830 | /* Ignore a negative size since that corresponds to our back-annotation. |
5831 | Also ignore a zero size unless a size clause exists. */ | |
5832 | else if (tree_int_cst_sgn (size) < 0 || (integer_zerop (size) && ! zero_ok)) | |
fbf5a39b | 5833 | return 0; |
70482933 RK |
5834 | |
5835 | /* The size of objects is always a multiple of a byte. */ | |
5836 | if (kind == VAR_DECL | |
5837 | && ! integer_zerop (size_binop (TRUNC_MOD_EXPR, size, | |
5838 | bitsize_unit_node))) | |
5839 | { | |
5840 | if (component_p) | |
5841 | post_error_ne ("component size for& is not a multiple of Storage_Unit", | |
5842 | gnat_error_node, gnat_object); | |
5843 | else | |
5844 | post_error_ne ("size for& is not a multiple of Storage_Unit", | |
5845 | gnat_error_node, gnat_object); | |
5846 | return 0; | |
5847 | } | |
5848 | ||
d05ef0ab AC |
5849 | /* If this is an integral type or a packed array type, the front-end has |
5850 | verified the size, so we need not do it here (which would entail | |
5851 | checking against the bounds). However, if this is an aliased object, it | |
5852 | may not be smaller than the type of the object. */ | |
5853 | if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type)) | |
70482933 RK |
5854 | && ! (kind == VAR_DECL && Is_Aliased (gnat_object))) |
5855 | return size; | |
5856 | ||
5857 | /* If the object is a record that contains a template, add the size of | |
5858 | the template to the specified size. */ | |
5859 | if (TREE_CODE (gnu_type) == RECORD_TYPE | |
5860 | && TYPE_CONTAINS_TEMPLATE_P (gnu_type)) | |
5861 | size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size); | |
5862 | ||
fbf5a39b AC |
5863 | /* Modify the size of the type to be that of the maximum size if it has a |
5864 | discriminant or the size of a thin pointer if this is a fat pointer. */ | |
5865 | if (type_size != 0 && CONTAINS_PLACEHOLDER_P (type_size)) | |
5866 | type_size = max_size (type_size, 1); | |
5867 | else if (TYPE_FAT_POINTER_P (gnu_type)) | |
5868 | type_size = bitsize_int (POINTER_SIZE); | |
5869 | ||
70482933 RK |
5870 | /* If the size of the object is a constant, the new size must not be |
5871 | smaller. */ | |
5872 | if (TREE_CODE (type_size) != INTEGER_CST | |
5873 | || TREE_OVERFLOW (type_size) | |
5874 | || tree_int_cst_lt (size, type_size)) | |
5875 | { | |
5876 | if (component_p) | |
5877 | post_error_ne_tree | |
5878 | ("component size for& too small{, minimum allowed is ^}", | |
5879 | gnat_error_node, gnat_object, type_size); | |
5880 | else | |
5881 | post_error_ne_tree ("size for& too small{, minimum allowed is ^}", | |
5882 | gnat_error_node, gnat_object, type_size); | |
5883 | ||
5884 | if (kind == VAR_DECL && ! component_p | |
5885 | && TREE_CODE (rm_size (gnu_type)) == INTEGER_CST | |
5886 | && ! tree_int_cst_lt (size, rm_size (gnu_type))) | |
5887 | post_error_ne_tree_2 | |
5b09c153 | 5888 | ("\\size of ^ is not a multiple of alignment (^ bits)", |
70482933 RK |
5889 | gnat_error_node, gnat_object, rm_size (gnu_type), |
5890 | TYPE_ALIGN (gnu_type)); | |
5891 | ||
5892 | else if (INTEGRAL_TYPE_P (gnu_type)) | |
5893 | post_error_ne ("\\size would be legal if & were not aliased!", | |
5894 | gnat_error_node, gnat_object); | |
5895 | ||
5896 | return 0; | |
5897 | } | |
5898 | ||
5899 | return size; | |
5900 | } | |
5901 | \f | |
5902 | /* Similarly, but both validate and process a value of RM_Size. This | |
5903 | routine is only called for types. */ | |
5904 | ||
5905 | static void | |
9373164a | 5906 | set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity) |
70482933 RK |
5907 | { |
5908 | /* Only give an error if a Value_Size clause was explicitly given. | |
5909 | Otherwise, we'd be duplicating an error on the Size clause. */ | |
5910 | Node_Id gnat_attr_node | |
5911 | = Get_Attribute_Definition_Clause (gnat_entity, Attr_Value_Size); | |
5912 | tree old_size = rm_size (gnu_type); | |
5913 | tree size; | |
5914 | ||
5915 | /* Get the size as a tree. Do nothing if none was specified, either | |
5916 | because RM_Size was not Present or if the specified size was zero. | |
5917 | Give an error if a size was specified, but cannot be represented as | |
5918 | in sizetype. */ | |
5919 | if (No (uint_size) || uint_size == No_Uint) | |
5920 | return; | |
5921 | ||
5922 | size = UI_To_gnu (uint_size, bitsizetype); | |
5923 | if (TREE_OVERFLOW (size)) | |
5924 | { | |
5925 | if (Present (gnat_attr_node)) | |
5926 | post_error_ne ("Value_Size of & is too large", gnat_attr_node, | |
5927 | gnat_entity); | |
5928 | ||
5929 | return; | |
5930 | } | |
5931 | ||
5932 | /* Ignore a negative size since that corresponds to our back-annotation. | |
5933 | Also ignore a zero size unless a size clause exists, a Value_Size | |
5934 | clause exists, or this is an integer type, in which case the | |
5935 | front end will have always set it. */ | |
5936 | else if (tree_int_cst_sgn (size) < 0 | |
5937 | || (integer_zerop (size) && No (gnat_attr_node) | |
5938 | && ! Has_Size_Clause (gnat_entity) | |
5939 | && ! Is_Discrete_Or_Fixed_Point_Type (gnat_entity))) | |
5940 | return; | |
5941 | ||
5942 | /* If the old size is self-referential, get the maximum size. */ | |
fbf5a39b | 5943 | if (CONTAINS_PLACEHOLDER_P (old_size)) |
70482933 RK |
5944 | old_size = max_size (old_size, 1); |
5945 | ||
5946 | /* If the size of the object is a constant, the new size must not be | |
5947 | smaller (the front end checks this for scalar types). */ | |
5948 | if (TREE_CODE (old_size) != INTEGER_CST | |
5949 | || TREE_OVERFLOW (old_size) | |
5950 | || (AGGREGATE_TYPE_P (gnu_type) | |
5951 | && tree_int_cst_lt (size, old_size))) | |
5952 | { | |
5953 | if (Present (gnat_attr_node)) | |
5954 | post_error_ne_tree | |
5955 | ("Value_Size for& too small{, minimum allowed is ^}", | |
5956 | gnat_attr_node, gnat_entity, old_size); | |
5957 | ||
5958 | return; | |
5959 | } | |
5960 | ||
5961 | /* Otherwise, set the RM_Size. */ | |
5962 | if (TREE_CODE (gnu_type) == INTEGER_TYPE | |
5963 | && Is_Discrete_Or_Fixed_Point_Type (gnat_entity)) | |
5964 | TYPE_RM_SIZE_INT (gnu_type) = size; | |
5965 | else if (TREE_CODE (gnu_type) == ENUMERAL_TYPE) | |
e2500fed | 5966 | SET_TYPE_RM_SIZE_ENUM (gnu_type, size); |
70482933 RK |
5967 | else if ((TREE_CODE (gnu_type) == RECORD_TYPE |
5968 | || TREE_CODE (gnu_type) == UNION_TYPE | |
5969 | || TREE_CODE (gnu_type) == QUAL_UNION_TYPE) | |
5970 | && ! TYPE_IS_FAT_POINTER_P (gnu_type)) | |
e2500fed | 5971 | SET_TYPE_ADA_SIZE (gnu_type, size); |
70482933 RK |
5972 | } |
5973 | \f | |
5974 | /* Given a type TYPE, return a new type whose size is appropriate for SIZE. | |
5975 | If TYPE is the best type, return it. Otherwise, make a new type. We | |
5976 | only support new integral and pointer types. BIASED_P is nonzero if | |
5977 | we are making a biased type. */ | |
5978 | ||
5979 | static tree | |
9373164a | 5980 | make_type_from_size (tree type, tree size_tree, int biased_p) |
70482933 RK |
5981 | { |
5982 | tree new_type; | |
5983 | unsigned HOST_WIDE_INT size; | |
5984 | ||
5985 | /* If size indicates an error, just return TYPE to avoid propagating the | |
5986 | error. Likewise if it's too large to represent. */ | |
5987 | if (size_tree == 0 || ! host_integerp (size_tree, 1)) | |
5988 | return type; | |
5989 | ||
5990 | size = tree_low_cst (size_tree, 1); | |
5991 | switch (TREE_CODE (type)) | |
5992 | { | |
5993 | case INTEGER_TYPE: | |
5994 | case ENUMERAL_TYPE: | |
5995 | /* Only do something if the type is not already the proper size and is | |
5996 | not a packed array type. */ | |
5997 | if (TYPE_PACKED_ARRAY_TYPE_P (type) | |
5998 | || (TYPE_PRECISION (type) == size | |
5999 | && biased_p == (TREE_CODE (type) == INTEGER_CST | |
6000 | && TYPE_BIASED_REPRESENTATION_P (type)))) | |
6001 | break; | |
6002 | ||
6003 | size = MIN (size, LONG_LONG_TYPE_SIZE); | |
6004 | new_type = make_signed_type (size); | |
6005 | TREE_TYPE (new_type) | |
6006 | = TREE_TYPE (type) != 0 ? TREE_TYPE (type) : type; | |
6007 | TYPE_MIN_VALUE (new_type) | |
6008 | = convert (TREE_TYPE (new_type), TYPE_MIN_VALUE (type)); | |
6009 | TYPE_MAX_VALUE (new_type) | |
6010 | = convert (TREE_TYPE (new_type), TYPE_MAX_VALUE (type)); | |
6011 | TYPE_BIASED_REPRESENTATION_P (new_type) | |
6012 | = ((TREE_CODE (type) == INTEGER_TYPE | |
6013 | && TYPE_BIASED_REPRESENTATION_P (type)) | |
6014 | || biased_p); | |
6015 | TREE_UNSIGNED (new_type) | |
6016 | = TREE_UNSIGNED (type) | TYPE_BIASED_REPRESENTATION_P (new_type); | |
6017 | TYPE_RM_SIZE_INT (new_type) = bitsize_int (size); | |
6018 | return new_type; | |
6019 | ||
6020 | case RECORD_TYPE: | |
6021 | /* Do something if this is a fat pointer, in which case we | |
6022 | may need to return the thin pointer. */ | |
6023 | if (TYPE_IS_FAT_POINTER_P (type) && size < POINTER_SIZE * 2) | |
6024 | return | |
6025 | build_pointer_type | |
6026 | (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type))); | |
6027 | break; | |
6028 | ||
6029 | case POINTER_TYPE: | |
6030 | /* Only do something if this is a thin pointer, in which case we | |
6031 | may need to return the fat pointer. */ | |
6032 | if (TYPE_THIN_POINTER_P (type) && size >= POINTER_SIZE * 2) | |
6033 | return | |
6034 | build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))); | |
6035 | ||
6036 | break; | |
6037 | ||
6038 | default: | |
6039 | break; | |
6040 | } | |
6041 | ||
6042 | return type; | |
6043 | } | |
6044 | \f | |
6045 | /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY, | |
6046 | a type or object whose present alignment is ALIGN. If this alignment is | |
6047 | valid, return it. Otherwise, give an error and return ALIGN. */ | |
6048 | ||
6049 | static unsigned int | |
9373164a | 6050 | validate_alignment (Uint alignment, Entity_Id gnat_entity, unsigned int align) |
70482933 RK |
6051 | { |
6052 | Node_Id gnat_error_node = gnat_entity; | |
6053 | unsigned int new_align; | |
6054 | ||
6055 | #ifndef MAX_OFILE_ALIGNMENT | |
6056 | #define MAX_OFILE_ALIGNMENT BIGGEST_ALIGNMENT | |
6057 | #endif | |
6058 | ||
6059 | if (Present (Alignment_Clause (gnat_entity))) | |
6060 | gnat_error_node = Expression (Alignment_Clause (gnat_entity)); | |
6061 | ||
07fc65c4 GB |
6062 | /* Don't worry about checking alignment if alignment was not specified |
6063 | by the source program and we already posted an error for this entity. */ | |
6064 | ||
6065 | if (Error_Posted (gnat_entity) && !Has_Alignment_Clause (gnat_entity)) | |
6066 | return align; | |
6067 | ||
70482933 RK |
6068 | /* Within GCC, an alignment is an integer, so we must make sure a |
6069 | value is specified that fits in that range. Also, alignments of | |
6070 | more than MAX_OFILE_ALIGNMENT can't be supported. */ | |
6071 | ||
6072 | if (! UI_Is_In_Int_Range (alignment) | |
6073 | || ((new_align = UI_To_Int (alignment)) | |
6074 | > MAX_OFILE_ALIGNMENT / BITS_PER_UNIT)) | |
6075 | post_error_ne_num ("largest supported alignment for& is ^", | |
6076 | gnat_error_node, gnat_entity, | |
6077 | MAX_OFILE_ALIGNMENT / BITS_PER_UNIT); | |
6078 | else if (! (Present (Alignment_Clause (gnat_entity)) | |
6079 | && From_At_Mod (Alignment_Clause (gnat_entity))) | |
6080 | && new_align * BITS_PER_UNIT < align) | |
6081 | post_error_ne_num ("alignment for& must be at least ^", | |
6082 | gnat_error_node, gnat_entity, | |
6083 | align / BITS_PER_UNIT); | |
6084 | else | |
6085 | align = MAX (align, new_align == 0 ? 1 : new_align * BITS_PER_UNIT); | |
6086 | ||
6087 | return align; | |
6088 | } | |
6089 | \f | |
6090 | /* Verify that OBJECT, a type or decl, is something we can implement | |
6091 | atomically. If not, give an error for GNAT_ENTITY. COMP_P is nonzero | |
6092 | if we require atomic components. */ | |
6093 | ||
6094 | static void | |
9373164a | 6095 | check_ok_for_atomic (tree object, Entity_Id gnat_entity, int comp_p) |
70482933 RK |
6096 | { |
6097 | Node_Id gnat_error_point = gnat_entity; | |
6098 | Node_Id gnat_node; | |
6099 | enum machine_mode mode; | |
6100 | unsigned int align; | |
6101 | tree size; | |
6102 | ||
6103 | /* There are three case of what OBJECT can be. It can be a type, in which | |
6104 | case we take the size, alignment and mode from the type. It can be a | |
6105 | declaration that was indirect, in which case the relevant values are | |
6106 | that of the type being pointed to, or it can be a normal declaration, | |
6107 | in which case the values are of the decl. The code below assumes that | |
6108 | OBJECT is either a type or a decl. */ | |
6109 | if (TYPE_P (object)) | |
6110 | { | |
6111 | mode = TYPE_MODE (object); | |
6112 | align = TYPE_ALIGN (object); | |
6113 | size = TYPE_SIZE (object); | |
6114 | } | |
6115 | else if (DECL_BY_REF_P (object)) | |
6116 | { | |
6117 | mode = TYPE_MODE (TREE_TYPE (TREE_TYPE (object))); | |
6118 | align = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (object))); | |
6119 | size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (object))); | |
6120 | } | |
6121 | else | |
6122 | { | |
6123 | mode = DECL_MODE (object); | |
6124 | align = DECL_ALIGN (object); | |
6125 | size = DECL_SIZE (object); | |
6126 | } | |
6127 | ||
6128 | /* Consider all floating-point types atomic and any types that that are | |
6129 | represented by integers no wider than a machine word. */ | |
6130 | if (GET_MODE_CLASS (mode) == MODE_FLOAT | |
6131 | || ((GET_MODE_CLASS (mode) == MODE_INT | |
6132 | || GET_MODE_CLASS (mode) == MODE_PARTIAL_INT) | |
6133 | && GET_MODE_BITSIZE (mode) <= BITS_PER_WORD)) | |
6134 | return; | |
6135 | ||
6136 | /* For the moment, also allow anything that has an alignment equal | |
6137 | to its size and which is smaller than a word. */ | |
fbf5a39b | 6138 | if (size != 0 && TREE_CODE (size) == INTEGER_CST |
70482933 RK |
6139 | && compare_tree_int (size, align) == 0 |
6140 | && align <= BITS_PER_WORD) | |
6141 | return; | |
6142 | ||
6143 | for (gnat_node = First_Rep_Item (gnat_entity); Present (gnat_node); | |
6144 | gnat_node = Next_Rep_Item (gnat_node)) | |
6145 | { | |
6146 | if (! comp_p && Nkind (gnat_node) == N_Pragma | |
6147 | && Get_Pragma_Id (Chars (gnat_node)) == Pragma_Atomic) | |
6148 | gnat_error_point = First (Pragma_Argument_Associations (gnat_node)); | |
6149 | else if (comp_p && Nkind (gnat_node) == N_Pragma | |
6150 | && (Get_Pragma_Id (Chars (gnat_node)) | |
6151 | == Pragma_Atomic_Components)) | |
6152 | gnat_error_point = First (Pragma_Argument_Associations (gnat_node)); | |
6153 | } | |
6154 | ||
6155 | if (comp_p) | |
6156 | post_error_ne ("atomic access to component of & cannot be guaranteed", | |
6157 | gnat_error_point, gnat_entity); | |
6158 | else | |
6159 | post_error_ne ("atomic access to & cannot be guaranteed", | |
6160 | gnat_error_point, gnat_entity); | |
6161 | } | |
6162 | \f | |
6163 | /* Given a type T, a FIELD_DECL F, and a replacement value R, | |
6164 | return a new type with all size expressions that contain F | |
6165 | updated by replacing F with R. This is identical to GCC's | |
6166 | substitute_in_type except that it knows about TYPE_INDEX_TYPE. | |
6167 | If F is NULL_TREE, always make a new RECORD_TYPE, even if nothing has | |
6168 | changed. */ | |
6169 | ||
6170 | tree | |
9373164a | 6171 | gnat_substitute_in_type (tree t, tree f, tree r) |
70482933 RK |
6172 | { |
6173 | tree new = t; | |
6174 | tree tem; | |
6175 | ||
6176 | switch (TREE_CODE (t)) | |
6177 | { | |
6178 | case INTEGER_TYPE: | |
6179 | case ENUMERAL_TYPE: | |
6180 | case BOOLEAN_TYPE: | |
6181 | case CHAR_TYPE: | |
fbf5a39b AC |
6182 | if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t)) |
6183 | || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t))) | |
70482933 RK |
6184 | { |
6185 | tree low = substitute_in_expr (TYPE_MIN_VALUE (t), f, r); | |
6186 | tree high = substitute_in_expr (TYPE_MAX_VALUE (t), f, r); | |
6187 | ||
6188 | if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t)) | |
6189 | return t; | |
6190 | ||
6191 | new = build_range_type (TREE_TYPE (t), low, high); | |
6192 | if (TYPE_INDEX_TYPE (t)) | |
fbf5a39b | 6193 | SET_TYPE_INDEX_TYPE (new, |
e2500fed | 6194 | gnat_substitute_in_type (TYPE_INDEX_TYPE (t), f, r)); |
70482933 RK |
6195 | return new; |
6196 | } | |
6197 | ||
6198 | return t; | |
6199 | ||
6200 | case REAL_TYPE: | |
6201 | if ((TYPE_MIN_VALUE (t) != 0 | |
fbf5a39b | 6202 | && CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t))) |
70482933 | 6203 | || (TYPE_MAX_VALUE (t) != 0 |
fbf5a39b | 6204 | && CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t)))) |
70482933 RK |
6205 | { |
6206 | tree low = 0, high = 0; | |
6207 | ||
6208 | if (TYPE_MIN_VALUE (t)) | |
6209 | low = substitute_in_expr (TYPE_MIN_VALUE (t), f, r); | |
6210 | if (TYPE_MAX_VALUE (t)) | |
6211 | high = substitute_in_expr (TYPE_MAX_VALUE (t), f, r); | |
6212 | ||
6213 | if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t)) | |
6214 | return t; | |
6215 | ||
6216 | t = copy_type (t); | |
6217 | TYPE_MIN_VALUE (t) = low; | |
6218 | TYPE_MAX_VALUE (t) = high; | |
6219 | } | |
6220 | return t; | |
6221 | ||
6222 | case COMPLEX_TYPE: | |
6223 | tem = gnat_substitute_in_type (TREE_TYPE (t), f, r); | |
6224 | if (tem == TREE_TYPE (t)) | |
6225 | return t; | |
6226 | ||
6227 | return build_complex_type (tem); | |
6228 | ||
6229 | case OFFSET_TYPE: | |
6230 | case METHOD_TYPE: | |
6231 | case FILE_TYPE: | |
6232 | case SET_TYPE: | |
6233 | case FUNCTION_TYPE: | |
6234 | case LANG_TYPE: | |
6235 | /* Don't know how to do these yet. */ | |
6236 | abort (); | |
6237 | ||
6238 | case ARRAY_TYPE: | |
6239 | { | |
6240 | tree component = gnat_substitute_in_type (TREE_TYPE (t), f, r); | |
6241 | tree domain = gnat_substitute_in_type (TYPE_DOMAIN (t), f, r); | |
6242 | ||
6243 | if (component == TREE_TYPE (t) && domain == TYPE_DOMAIN (t)) | |
6244 | return t; | |
6245 | ||
6246 | new = build_array_type (component, domain); | |
6247 | TYPE_SIZE (new) = 0; | |
6248 | TYPE_MULTI_ARRAY_P (new) = TYPE_MULTI_ARRAY_P (t); | |
6249 | TYPE_CONVENTION_FORTRAN_P (new) = TYPE_CONVENTION_FORTRAN_P (t); | |
6250 | layout_type (new); | |
6251 | TYPE_ALIGN (new) = TYPE_ALIGN (t); | |
6252 | return new; | |
6253 | } | |
6254 | ||
6255 | case RECORD_TYPE: | |
6256 | case UNION_TYPE: | |
6257 | case QUAL_UNION_TYPE: | |
6258 | { | |
6259 | tree field; | |
6260 | int changed_field | |
6261 | = (f == NULL_TREE && ! TREE_CONSTANT (TYPE_SIZE (t))); | |
6262 | int field_has_rep = 0; | |
6263 | tree last_field = 0; | |
6264 | ||
6265 | tree new = copy_type (t); | |
6266 | ||
6267 | /* Start out with no fields, make new fields, and chain them | |
6268 | in. If we haven't actually changed the type of any field, | |
6269 | discard everything we've done and return the old type. */ | |
6270 | ||
6271 | TYPE_FIELDS (new) = 0; | |
6272 | TYPE_SIZE (new) = 0; | |
6273 | ||
6274 | for (field = TYPE_FIELDS (t); field; | |
6275 | field = TREE_CHAIN (field)) | |
6276 | { | |
6277 | tree new_field = copy_node (field); | |
6278 | ||
6279 | TREE_TYPE (new_field) | |
6280 | = gnat_substitute_in_type (TREE_TYPE (new_field), f, r); | |
6281 | ||
6282 | if (DECL_HAS_REP_P (field) && ! DECL_INTERNAL_P (field)) | |
6283 | field_has_rep = 1; | |
6284 | else if (TREE_TYPE (new_field) != TREE_TYPE (field)) | |
6285 | changed_field = 1; | |
6286 | ||
6287 | /* If this is an internal field and the type of this field is | |
6288 | a UNION_TYPE or RECORD_TYPE with no elements, ignore it. If | |
6289 | the type just has one element, treat that as the field. | |
6290 | But don't do this if we are processing a QUAL_UNION_TYPE. */ | |
6291 | if (TREE_CODE (t) != QUAL_UNION_TYPE | |
6292 | && DECL_INTERNAL_P (new_field) | |
6293 | && (TREE_CODE (TREE_TYPE (new_field)) == UNION_TYPE | |
6294 | || TREE_CODE (TREE_TYPE (new_field)) == RECORD_TYPE)) | |
6295 | { | |
6296 | if (TYPE_FIELDS (TREE_TYPE (new_field)) == 0) | |
6297 | continue; | |
6298 | ||
6299 | if (TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new_field))) == 0) | |
6300 | { | |
6301 | tree next_new_field | |
6302 | = copy_node (TYPE_FIELDS (TREE_TYPE (new_field))); | |
6303 | ||
6304 | /* Make sure omitting the union doesn't change | |
6305 | the layout. */ | |
6306 | DECL_ALIGN (next_new_field) = DECL_ALIGN (new_field); | |
6307 | new_field = next_new_field; | |
6308 | } | |
6309 | } | |
6310 | ||
6311 | DECL_CONTEXT (new_field) = new; | |
e2500fed GK |
6312 | SET_DECL_ORIGINAL_FIELD (new_field, |
6313 | (DECL_ORIGINAL_FIELD (field) != 0 | |
6314 | ? DECL_ORIGINAL_FIELD (field) : field)); | |
70482933 RK |
6315 | |
6316 | /* If the size of the old field was set at a constant, | |
6317 | propagate the size in case the type's size was variable. | |
6318 | (This occurs in the case of a variant or discriminated | |
6319 | record with a default size used as a field of another | |
6320 | record.) */ | |
6321 | DECL_SIZE (new_field) | |
6322 | = TREE_CODE (DECL_SIZE (field)) == INTEGER_CST | |
6323 | ? DECL_SIZE (field) : 0; | |
6324 | DECL_SIZE_UNIT (new_field) | |
6325 | = TREE_CODE (DECL_SIZE_UNIT (field)) == INTEGER_CST | |
6326 | ? DECL_SIZE_UNIT (field) : 0; | |
6327 | ||
6328 | if (TREE_CODE (t) == QUAL_UNION_TYPE) | |
6329 | { | |
6330 | tree new_q = substitute_in_expr (DECL_QUALIFIER (field), f, r); | |
6331 | ||
6332 | if (new_q != DECL_QUALIFIER (new_field)) | |
6333 | changed_field = 1; | |
6334 | ||
6335 | /* Do the substitution inside the qualifier and if we find | |
6336 | that this field will not be present, omit it. */ | |
6337 | DECL_QUALIFIER (new_field) = new_q; | |
6338 | ||
6339 | if (integer_zerop (DECL_QUALIFIER (new_field))) | |
6340 | continue; | |
6341 | } | |
6342 | ||
6343 | if (last_field == 0) | |
6344 | TYPE_FIELDS (new) = new_field; | |
6345 | else | |
6346 | TREE_CHAIN (last_field) = new_field; | |
6347 | ||
6348 | last_field = new_field; | |
6349 | ||
6350 | /* If this is a qualified type and this field will always be | |
6351 | present, we are done. */ | |
6352 | if (TREE_CODE (t) == QUAL_UNION_TYPE | |
6353 | && integer_onep (DECL_QUALIFIER (new_field))) | |
6354 | break; | |
6355 | } | |
6356 | ||
6357 | /* If this used to be a qualified union type, but we now know what | |
6358 | field will be present, make this a normal union. */ | |
6359 | if (changed_field && TREE_CODE (new) == QUAL_UNION_TYPE | |
6360 | && (TYPE_FIELDS (new) == 0 | |
6361 | || integer_onep (DECL_QUALIFIER (TYPE_FIELDS (new))))) | |
6362 | TREE_SET_CODE (new, UNION_TYPE); | |
6363 | else if (! changed_field) | |
6364 | return t; | |
6365 | ||
6366 | if (field_has_rep) | |
6367 | gigi_abort (117); | |
6368 | ||
6369 | layout_type (new); | |
6370 | ||
6371 | /* If the size was originally a constant use it. */ | |
6372 | if (TYPE_SIZE (t) != 0 && TREE_CODE (TYPE_SIZE (t)) == INTEGER_CST | |
6373 | && TREE_CODE (TYPE_SIZE (new)) != INTEGER_CST) | |
6374 | { | |
6375 | TYPE_SIZE (new) = TYPE_SIZE (t); | |
6376 | TYPE_SIZE_UNIT (new) = TYPE_SIZE_UNIT (t); | |
e2500fed | 6377 | SET_TYPE_ADA_SIZE (new, TYPE_ADA_SIZE (t)); |
70482933 RK |
6378 | } |
6379 | ||
6380 | return new; | |
6381 | } | |
6382 | ||
6383 | default: | |
6384 | return t; | |
6385 | } | |
6386 | } | |
6387 | \f | |
6388 | /* Return the "RM size" of GNU_TYPE. This is the actual number of bits | |
6389 | needed to represent the object. */ | |
6390 | ||
6391 | tree | |
9373164a | 6392 | rm_size (tree gnu_type) |
70482933 RK |
6393 | { |
6394 | /* For integer types, this is the precision. For record types, we store | |
6395 | the size explicitly. For other types, this is just the size. */ | |
6396 | ||
6397 | if (INTEGRAL_TYPE_P (gnu_type) && TYPE_RM_SIZE (gnu_type) != 0) | |
6398 | return TYPE_RM_SIZE (gnu_type); | |
6399 | else if (TREE_CODE (gnu_type) == RECORD_TYPE | |
6400 | && TYPE_CONTAINS_TEMPLATE_P (gnu_type)) | |
6401 | /* Return the rm_size of the actual data plus the size of the template. */ | |
6402 | return | |
6403 | size_binop (PLUS_EXPR, | |
6404 | rm_size (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)))), | |
6405 | DECL_SIZE (TYPE_FIELDS (gnu_type))); | |
6406 | else if ((TREE_CODE (gnu_type) == RECORD_TYPE | |
6407 | || TREE_CODE (gnu_type) == UNION_TYPE | |
6408 | || TREE_CODE (gnu_type) == QUAL_UNION_TYPE) | |
6409 | && ! TYPE_IS_FAT_POINTER_P (gnu_type) | |
6410 | && TYPE_ADA_SIZE (gnu_type) != 0) | |
6411 | return TYPE_ADA_SIZE (gnu_type); | |
6412 | else | |
6413 | return TYPE_SIZE (gnu_type); | |
6414 | } | |
6415 | \f | |
6416 | /* Return an identifier representing the external name to be used for | |
6417 | GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___" | |
6418 | and the specified suffix. */ | |
6419 | ||
6420 | tree | |
9373164a | 6421 | create_concat_name (Entity_Id gnat_entity, const char *suffix) |
70482933 RK |
6422 | { |
6423 | const char *str = (suffix == 0 ? "" : suffix); | |
6424 | String_Template temp = {1, strlen (str)}; | |
6425 | Fat_Pointer fp = {str, &temp}; | |
6426 | ||
6427 | Get_External_Name_With_Suffix (gnat_entity, fp); | |
6428 | ||
fbf5a39b AC |
6429 | #ifdef _WIN32 |
6430 | /* A variable using the Stdcall convention (meaning we are running | |
6431 | on a Windows box) live in a DLL. Here we adjust its name to use | |
6432 | the jump-table, the _imp__NAME contains the address for the NAME | |
6433 | variable. */ | |
6434 | ||
6435 | { | |
6436 | Entity_Kind kind = Ekind (gnat_entity); | |
25412599 | 6437 | const char *prefix = "_imp__"; |
fbf5a39b AC |
6438 | int plen = strlen (prefix); |
6439 | ||
6440 | if ((kind == E_Variable || kind == E_Constant) | |
6441 | && Convention (gnat_entity) == Convention_Stdcall) | |
6442 | { | |
6443 | int k; | |
6444 | for (k = 0; k <= Name_Len; k++) | |
6445 | Name_Buffer [Name_Len - k + plen] = Name_Buffer [Name_Len - k]; | |
6446 | strncpy (Name_Buffer, prefix, plen); | |
6447 | } | |
6448 | } | |
6449 | #endif | |
6450 | ||
70482933 RK |
6451 | return get_identifier (Name_Buffer); |
6452 | } | |
6453 | ||
6454 | /* Return the name to be used for GNAT_ENTITY. If a type, create a | |
6455 | fully-qualified name, possibly with type information encoding. | |
6456 | Otherwise, return the name. */ | |
6457 | ||
6458 | tree | |
9373164a | 6459 | get_entity_name (Entity_Id gnat_entity) |
70482933 RK |
6460 | { |
6461 | Get_Encoded_Name (gnat_entity); | |
6462 | return get_identifier (Name_Buffer); | |
6463 | } | |
6464 | ||
6465 | /* Given GNU_ID, an IDENTIFIER_NODE containing a name and SUFFIX, a | |
6466 | string, return a new IDENTIFIER_NODE that is the concatenation of | |
6467 | the name in GNU_ID and SUFFIX. */ | |
6468 | ||
6469 | tree | |
9373164a | 6470 | concat_id_with_name (tree gnu_id, const char *suffix) |
70482933 RK |
6471 | { |
6472 | int len = IDENTIFIER_LENGTH (gnu_id); | |
6473 | ||
6474 | strncpy (Name_Buffer, IDENTIFIER_POINTER (gnu_id), | |
6475 | IDENTIFIER_LENGTH (gnu_id)); | |
6476 | strncpy (Name_Buffer + len, "___", 3); | |
6477 | len += 3; | |
6478 | strcpy (Name_Buffer + len, suffix); | |
6479 | return get_identifier (Name_Buffer); | |
6480 | } | |
e2500fed GK |
6481 | |
6482 | #include "gt-ada-decl.h" |