]>
Commit | Line | Data |
---|---|---|
6de9cd9a | 1 | /* Common block and equivalence list handling |
06796564 | 2 | Copyright (C) 2000, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 |
6c7a4dfd | 3 | Free Software Foundation, Inc. |
6de9cd9a DN |
4 | Contributed by Canqun Yang <canqun@nudt.edu.cn> |
5 | ||
9fc4d79b | 6 | This file is part of GCC. |
6de9cd9a | 7 | |
9fc4d79b TS |
8 | GCC is free software; you can redistribute it and/or modify it under |
9 | the terms of the GNU General Public License as published by the Free | |
d234d788 | 10 | Software Foundation; either version 3, or (at your option) any later |
9fc4d79b | 11 | version. |
6de9cd9a | 12 | |
9fc4d79b TS |
13 | GCC is distributed in the hope that it will be useful, but WITHOUT ANY |
14 | WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
15 | FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
16 | for more details. | |
6de9cd9a DN |
17 | |
18 | You should have received a copy of the GNU General Public License | |
d234d788 NC |
19 | along with GCC; see the file COPYING3. If not see |
20 | <http://www.gnu.org/licenses/>. */ | |
6de9cd9a DN |
21 | |
22 | /* The core algorithm is based on Andy Vaught's g95 tree. Also the | |
23 | way to build UNION_TYPE is borrowed from Richard Henderson. | |
24 | ||
25 | Transform common blocks. An integral part of this is processing | |
1f2959f0 | 26 | equivalence variables. Equivalenced variables that are not in a |
6de9cd9a DN |
27 | common block end up in a private block of their own. |
28 | ||
29 | Each common block or local equivalence list is declared as a union. | |
30 | Variables within the block are represented as a field within the | |
31 | block with the proper offset. | |
32 | ||
33 | So if two variables are equivalenced, they just point to a common | |
34 | area in memory. | |
35 | ||
36 | Mathematically, laying out an equivalence block is equivalent to | |
37 | solving a linear system of equations. The matrix is usually a | |
38 | sparse matrix in which each row contains all zero elements except | |
39 | for a +1 and a -1, a sort of a generalized Vandermonde matrix. The | |
40 | matrix is usually block diagonal. The system can be | |
41 | overdetermined, underdetermined or have a unique solution. If the | |
42 | system is inconsistent, the program is not standard conforming. | |
43 | The solution vector is integral, since all of the pivots are +1 or -1. | |
44 | ||
45 | How we lay out an equivalence block is a little less complicated. | |
46 | In an equivalence list with n elements, there are n-1 conditions to | |
47 | be satisfied. The conditions partition the variables into what we | |
48 | will call segments. If A and B are equivalenced then A and B are | |
49 | in the same segment. If B and C are equivalenced as well, then A, | |
50 | B and C are in a segment and so on. Each segment is a block of | |
51 | memory that has one or more variables equivalenced in some way. A | |
52 | common block is made up of a series of segments that are joined one | |
53 | after the other. In the linear system, a segment is a block | |
54 | diagonal. | |
55 | ||
56 | To lay out a segment we first start with some variable and | |
57 | determine its length. The first variable is assumed to start at | |
58 | offset one and extends to however long it is. We then traverse the | |
59 | list of equivalences to find an unused condition that involves at | |
60 | least one of the variables currently in the segment. | |
61 | ||
62 | Each equivalence condition amounts to the condition B+b=C+c where B | |
63 | and C are the offsets of the B and C variables, and b and c are | |
64 | constants which are nonzero for array elements, substrings or | |
65 | structure components. So for | |
66 | ||
67 | EQUIVALENCE(B(2), C(3)) | |
68 | we have | |
69 | B + 2*size of B's elements = C + 3*size of C's elements. | |
70 | ||
71 | If B and C are known we check to see if the condition already | |
72 | holds. If B is known we can solve for C. Since we know the length | |
73 | of C, we can see if the minimum and maximum extents of the segment | |
74 | are affected. Eventually, we make a full pass through the | |
75 | equivalence list without finding any new conditions and the segment | |
76 | is fully specified. | |
77 | ||
78 | At this point, the segment is added to the current common block. | |
79 | Since we know the minimum extent of the segment, everything in the | |
80 | segment is translated to its position in the common block. The | |
81 | usual case here is that there are no equivalence statements and the | |
82 | common block is series of segments with one variable each, which is | |
83 | a diagonal matrix in the matrix formulation. | |
84 | ||
5291e69a | 85 | Each segment is described by a chain of segment_info structures. Each |
e2ae1407 | 86 | segment_info structure describes the extents of a single variable within |
5291e69a PB |
87 | the segment. This list is maintained in the order the elements are |
88 | positioned withing the segment. If two elements have the same starting | |
89 | offset the smaller will come first. If they also have the same size their | |
90 | ordering is undefined. | |
91 | ||
6de9cd9a DN |
92 | Once all common blocks have been created, the list of equivalences |
93 | is examined for still-unused equivalence conditions. We create a | |
94 | block for each merged equivalence list. */ | |
95 | ||
96 | #include "config.h" | |
97 | #include "system.h" | |
98 | #include "coretypes.h" | |
d347d97e | 99 | #include "tm.h" |
6de9cd9a | 100 | #include "tree.h" |
d347d97e | 101 | #include "output.h" /* For decl_default_tls_model. */ |
6de9cd9a DN |
102 | #include "gfortran.h" |
103 | #include "trans.h" | |
104 | #include "trans-types.h" | |
105 | #include "trans-const.h" | |
9d99ee7b | 106 | #include "target-memory.h" |
6de9cd9a DN |
107 | |
108 | ||
49de9e73 | 109 | /* Holds a single variable in an equivalence set. */ |
6de9cd9a DN |
110 | typedef struct segment_info |
111 | { | |
112 | gfc_symbol *sym; | |
5291e69a PB |
113 | HOST_WIDE_INT offset; |
114 | HOST_WIDE_INT length; | |
ad6e2a18 | 115 | /* This will contain the field type until the field is created. */ |
a8a6b603 | 116 | tree field; |
6de9cd9a DN |
117 | struct segment_info *next; |
118 | } segment_info; | |
119 | ||
832ef1ce | 120 | static segment_info * current_segment; |
6de9cd9a DN |
121 | static gfc_namespace *gfc_common_ns = NULL; |
122 | ||
61321991 | 123 | |
ad6e2a18 TS |
124 | /* Make a segment_info based on a symbol. */ |
125 | ||
126 | static segment_info * | |
127 | get_segment_info (gfc_symbol * sym, HOST_WIDE_INT offset) | |
128 | { | |
129 | segment_info *s; | |
130 | ||
131 | /* Make sure we've got the character length. */ | |
132 | if (sym->ts.type == BT_CHARACTER) | |
bc21d315 | 133 | gfc_conv_const_charlen (sym->ts.u.cl); |
ad6e2a18 TS |
134 | |
135 | /* Create the segment_info and fill it in. */ | |
136 | s = (segment_info *) gfc_getmem (sizeof (segment_info)); | |
137 | s->sym = sym; | |
13795658 | 138 | /* We will use this type when building the segment aggregate type. */ |
ad6e2a18 TS |
139 | s->field = gfc_sym_type (sym); |
140 | s->length = int_size_in_bytes (s->field); | |
141 | s->offset = offset; | |
142 | ||
143 | return s; | |
144 | } | |
145 | ||
61321991 PT |
146 | |
147 | /* Add a copy of a segment list to the namespace. This is specifically for | |
148 | equivalence segments, so that dependency checking can be done on | |
149 | equivalence group members. */ | |
150 | ||
151 | static void | |
152 | copy_equiv_list_to_ns (segment_info *c) | |
153 | { | |
154 | segment_info *f; | |
155 | gfc_equiv_info *s; | |
156 | gfc_equiv_list *l; | |
157 | ||
158 | l = (gfc_equiv_list *) gfc_getmem (sizeof (gfc_equiv_list)); | |
159 | ||
160 | l->next = c->sym->ns->equiv_lists; | |
161 | c->sym->ns->equiv_lists = l; | |
162 | ||
163 | for (f = c; f; f = f->next) | |
164 | { | |
165 | s = (gfc_equiv_info *) gfc_getmem (sizeof (gfc_equiv_info)); | |
166 | s->next = l->equiv; | |
167 | l->equiv = s; | |
168 | s->sym = f->sym; | |
169 | s->offset = f->offset; | |
37311e71 | 170 | s->length = f->length; |
61321991 PT |
171 | } |
172 | } | |
173 | ||
174 | ||
a8a6b603 | 175 | /* Add combine segment V and segment LIST. */ |
5291e69a PB |
176 | |
177 | static segment_info * | |
178 | add_segments (segment_info *list, segment_info *v) | |
179 | { | |
180 | segment_info *s; | |
181 | segment_info *p; | |
182 | segment_info *next; | |
a8a6b603 | 183 | |
5291e69a PB |
184 | p = NULL; |
185 | s = list; | |
186 | ||
187 | while (v) | |
188 | { | |
189 | /* Find the location of the new element. */ | |
190 | while (s) | |
191 | { | |
192 | if (v->offset < s->offset) | |
193 | break; | |
194 | if (v->offset == s->offset | |
195 | && v->length <= s->length) | |
196 | break; | |
197 | ||
198 | p = s; | |
199 | s = s->next; | |
200 | } | |
201 | ||
202 | /* Insert the new element in between p and s. */ | |
203 | next = v->next; | |
204 | v->next = s; | |
205 | if (p == NULL) | |
206 | list = v; | |
207 | else | |
208 | p->next = v; | |
209 | ||
210 | p = v; | |
211 | v = next; | |
212 | } | |
a8a6b603 | 213 | |
5291e69a PB |
214 | return list; |
215 | } | |
216 | ||
a8b3b0b6 | 217 | |
6de9cd9a DN |
218 | /* Construct mangled common block name from symbol name. */ |
219 | ||
a8b3b0b6 CR |
220 | /* We need the bind(c) flag to tell us how/if we should mangle the symbol |
221 | name. There are few calls to this function, so few places that this | |
222 | would need to be added. At the moment, there is only one call, in | |
223 | build_common_decl(). We can't attempt to look up the common block | |
224 | because we may be building it for the first time and therefore, it won't | |
225 | be in the common_root. We also need the binding label, if it's bind(c). | |
226 | Therefore, send in the pointer to the common block, so whatever info we | |
227 | have so far can be used. All of the necessary info should be available | |
228 | in the gfc_common_head by now, so it should be accurate to test the | |
229 | isBindC flag and use the binding label given if it is bind(c). | |
230 | ||
231 | We may NOT know yet if it's bind(c) or not, but we can try at least. | |
232 | Will have to figure out what to do later if it's labeled bind(c) | |
233 | after this is called. */ | |
234 | ||
6de9cd9a | 235 | static tree |
a8b3b0b6 | 236 | gfc_sym_mangled_common_id (gfc_common_head *com) |
6de9cd9a DN |
237 | { |
238 | int has_underscore; | |
9056bd70 | 239 | char mangled_name[GFC_MAX_MANGLED_SYMBOL_LEN + 1]; |
a8b3b0b6 CR |
240 | char name[GFC_MAX_SYMBOL_LEN + 1]; |
241 | ||
242 | /* Get the name out of the common block pointer. */ | |
243 | strcpy (name, com->name); | |
244 | ||
245 | /* If we're suppose to do a bind(c). */ | |
246 | if (com->is_bind_c == 1 && com->binding_label[0] != '\0') | |
247 | return get_identifier (com->binding_label); | |
6de9cd9a | 248 | |
9056bd70 TS |
249 | if (strcmp (name, BLANK_COMMON_NAME) == 0) |
250 | return get_identifier (name); | |
a8a6b603 | 251 | |
6de9cd9a DN |
252 | if (gfc_option.flag_underscoring) |
253 | { | |
9056bd70 | 254 | has_underscore = strchr (name, '_') != 0; |
6de9cd9a | 255 | if (gfc_option.flag_second_underscore && has_underscore) |
9056bd70 | 256 | snprintf (mangled_name, sizeof mangled_name, "%s__", name); |
6de9cd9a | 257 | else |
9056bd70 | 258 | snprintf (mangled_name, sizeof mangled_name, "%s_", name); |
a8a6b603 | 259 | |
9056bd70 | 260 | return get_identifier (mangled_name); |
6de9cd9a DN |
261 | } |
262 | else | |
9056bd70 | 263 | return get_identifier (name); |
6de9cd9a DN |
264 | } |
265 | ||
266 | ||
ad6e2a18 | 267 | /* Build a field declaration for a common variable or a local equivalence |
6de9cd9a DN |
268 | object. */ |
269 | ||
ad6e2a18 | 270 | static void |
6de9cd9a DN |
271 | build_field (segment_info *h, tree union_type, record_layout_info rli) |
272 | { | |
ad6e2a18 TS |
273 | tree field; |
274 | tree name; | |
6de9cd9a | 275 | HOST_WIDE_INT offset = h->offset; |
5291e69a | 276 | unsigned HOST_WIDE_INT desired_align, known_align; |
6de9cd9a | 277 | |
ad6e2a18 | 278 | name = get_identifier (h->sym->name); |
c2255bc4 AH |
279 | field = build_decl (h->sym->declared_at.lb->location, |
280 | FIELD_DECL, name, h->field); | |
6de9cd9a DN |
281 | known_align = (offset & -offset) * BITS_PER_UNIT; |
282 | if (known_align == 0 || known_align > BIGGEST_ALIGNMENT) | |
283 | known_align = BIGGEST_ALIGNMENT; | |
284 | ||
285 | desired_align = update_alignment_for_field (rli, field, known_align); | |
286 | if (desired_align > known_align) | |
287 | DECL_PACKED (field) = 1; | |
288 | ||
289 | DECL_FIELD_CONTEXT (field) = union_type; | |
290 | DECL_FIELD_OFFSET (field) = size_int (offset); | |
291 | DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node; | |
292 | SET_DECL_OFFSET_ALIGN (field, known_align); | |
293 | ||
294 | rli->offset = size_binop (MAX_EXPR, rli->offset, | |
295 | size_binop (PLUS_EXPR, | |
296 | DECL_FIELD_OFFSET (field), | |
297 | DECL_SIZE_UNIT (field))); | |
ce2df7c6 | 298 | /* If this field is assigned to a label, we create another two variables. |
81871c2a | 299 | One will hold the address of target label or format label. The other will |
ce2df7c6 FW |
300 | hold the length of format label string. */ |
301 | if (h->sym->attr.assign) | |
302 | { | |
303 | tree len; | |
304 | tree addr; | |
305 | ||
306 | gfc_allocate_lang_decl (field); | |
307 | GFC_DECL_ASSIGN (field) = 1; | |
308 | len = gfc_create_var_np (gfc_charlen_type_node,h->sym->name); | |
309 | addr = gfc_create_var_np (pvoid_type_node, h->sym->name); | |
310 | TREE_STATIC (len) = 1; | |
311 | TREE_STATIC (addr) = 1; | |
312 | DECL_INITIAL (len) = build_int_cst (NULL_TREE, -2); | |
313 | gfc_set_decl_location (len, &h->sym->declared_at); | |
314 | gfc_set_decl_location (addr, &h->sym->declared_at); | |
315 | GFC_DECL_STRING_LEN (field) = pushdecl_top_level (len); | |
316 | GFC_DECL_ASSIGN_ADDR (field) = pushdecl_top_level (addr); | |
317 | } | |
318 | ||
e3ac9b24 FXC |
319 | /* If this field is volatile, mark it. */ |
320 | if (h->sym->attr.volatile_) | |
321 | { | |
7b901ac4 | 322 | tree new_type; |
e3ac9b24 | 323 | TREE_THIS_VOLATILE (field) = 1; |
c28d1d9b | 324 | TREE_SIDE_EFFECTS (field) = 1; |
7b901ac4 KG |
325 | new_type = build_qualified_type (TREE_TYPE (field), TYPE_QUAL_VOLATILE); |
326 | TREE_TYPE (field) = new_type; | |
e3ac9b24 FXC |
327 | } |
328 | ||
ad6e2a18 | 329 | h->field = field; |
6de9cd9a DN |
330 | } |
331 | ||
332 | ||
333 | /* Get storage for local equivalence. */ | |
334 | ||
335 | static tree | |
57f0d086 | 336 | build_equiv_decl (tree union_type, bool is_init, bool is_saved) |
6de9cd9a DN |
337 | { |
338 | tree decl; | |
bae88af6 TS |
339 | char name[15]; |
340 | static int serial = 0; | |
5291e69a PB |
341 | |
342 | if (is_init) | |
343 | { | |
344 | decl = gfc_create_var (union_type, "equiv"); | |
345 | TREE_STATIC (decl) = 1; | |
6c7a4dfd | 346 | GFC_DECL_COMMON_OR_EQUIV (decl) = 1; |
5291e69a PB |
347 | return decl; |
348 | } | |
349 | ||
bae88af6 | 350 | snprintf (name, sizeof (name), "equiv.%d", serial++); |
c2255bc4 AH |
351 | decl = build_decl (input_location, |
352 | VAR_DECL, get_identifier (name), union_type); | |
6de9cd9a | 353 | DECL_ARTIFICIAL (decl) = 1; |
bae88af6 | 354 | DECL_IGNORED_P (decl) = 1; |
6de9cd9a | 355 | |
57f0d086 JJ |
356 | if (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)) |
357 | || is_saved) | |
bae88af6 | 358 | TREE_STATIC (decl) = 1; |
6de9cd9a DN |
359 | |
360 | TREE_ADDRESSABLE (decl) = 1; | |
361 | TREE_USED (decl) = 1; | |
6c7a4dfd | 362 | GFC_DECL_COMMON_OR_EQUIV (decl) = 1; |
c8cc8542 PB |
363 | |
364 | /* The source location has been lost, and doesn't really matter. | |
365 | We need to set it to something though. */ | |
366 | gfc_set_decl_location (decl, &gfc_current_locus); | |
367 | ||
6de9cd9a DN |
368 | gfc_add_decl_to_function (decl); |
369 | ||
370 | return decl; | |
371 | } | |
372 | ||
373 | ||
374 | /* Get storage for common block. */ | |
375 | ||
376 | static tree | |
53814b8f | 377 | build_common_decl (gfc_common_head *com, tree union_type, bool is_init) |
6de9cd9a DN |
378 | { |
379 | gfc_symbol *common_sym; | |
380 | tree decl; | |
381 | ||
382 | /* Create a namespace to store symbols for common blocks. */ | |
383 | if (gfc_common_ns == NULL) | |
0366dfe9 | 384 | gfc_common_ns = gfc_get_namespace (NULL, 0); |
6de9cd9a | 385 | |
53814b8f | 386 | gfc_get_symbol (com->name, gfc_common_ns, &common_sym); |
6de9cd9a DN |
387 | decl = common_sym->backend_decl; |
388 | ||
389 | /* Update the size of this common block as needed. */ | |
390 | if (decl != NULL_TREE) | |
391 | { | |
5291e69a | 392 | tree size = TYPE_SIZE_UNIT (union_type); |
6de9cd9a DN |
393 | if (tree_int_cst_lt (DECL_SIZE_UNIT (decl), size)) |
394 | { | |
d8158369 PT |
395 | /* Named common blocks of the same name shall be of the same size |
396 | in all scoping units of a program in which they appear, but | |
397 | blank common blocks may be of different sizes. */ | |
398 | if (strcmp (com->name, BLANK_COMMON_NAME)) | |
a8a6b603 | 399 | gfc_warning ("Named COMMON block '%s' at %L shall be of the " |
53814b8f | 400 | "same size", com->name, &com->where); |
06796564 | 401 | DECL_SIZE (decl) = TYPE_SIZE (union_type); |
d8158369 | 402 | DECL_SIZE_UNIT (decl) = size; |
06796564 | 403 | DECL_MODE (decl) = TYPE_MODE (union_type); |
d8158369 | 404 | TREE_TYPE (decl) = union_type; |
06796564 | 405 | layout_decl (decl, 0); |
d8158369 | 406 | } |
6de9cd9a DN |
407 | } |
408 | ||
409 | /* If this common block has been declared in a previous program unit, | |
410 | and either it is already initialized or there is no new initialization | |
411 | for it, just return. */ | |
412 | if ((decl != NULL_TREE) && (!is_init || DECL_INITIAL (decl))) | |
413 | return decl; | |
414 | ||
415 | /* If there is no backend_decl for the common block, build it. */ | |
416 | if (decl == NULL_TREE) | |
417 | { | |
c2255bc4 AH |
418 | decl = build_decl (input_location, |
419 | VAR_DECL, get_identifier (com->name), union_type); | |
43ce5e52 | 420 | gfc_set_decl_assembler_name (decl, gfc_sym_mangled_common_id (com)); |
6de9cd9a DN |
421 | TREE_PUBLIC (decl) = 1; |
422 | TREE_STATIC (decl) = 1; | |
a64f5186 | 423 | DECL_IGNORED_P (decl) = 1; |
af90c10f CR |
424 | if (!com->is_bind_c) |
425 | DECL_ALIGN (decl) = BIGGEST_ALIGNMENT; | |
426 | else | |
427 | { | |
428 | /* Do not set the alignment for bind(c) common blocks to | |
429 | BIGGEST_ALIGNMENT because that won't match what C does. Also, | |
430 | for common blocks with one element, the alignment must be | |
431 | that of the field within the common block in order to match | |
432 | what C will do. */ | |
433 | tree field = NULL_TREE; | |
434 | field = TYPE_FIELDS (TREE_TYPE (decl)); | |
910ad8de | 435 | if (DECL_CHAIN (field) == NULL_TREE) |
af90c10f CR |
436 | DECL_ALIGN (decl) = TYPE_ALIGN (TREE_TYPE (field)); |
437 | } | |
6de9cd9a | 438 | DECL_USER_ALIGN (decl) = 0; |
6c7a4dfd | 439 | GFC_DECL_COMMON_OR_EQUIV (decl) = 1; |
5291e69a | 440 | |
c8cc8542 PB |
441 | gfc_set_decl_location (decl, &com->where); |
442 | ||
8893239d | 443 | if (com->threadprivate) |
6c7a4dfd JJ |
444 | DECL_TLS_MODEL (decl) = decl_default_tls_model (decl); |
445 | ||
5291e69a PB |
446 | /* Place the back end declaration for this common block in |
447 | GLOBAL_BINDING_LEVEL. */ | |
448 | common_sym->backend_decl = pushdecl_top_level (decl); | |
6de9cd9a DN |
449 | } |
450 | ||
451 | /* Has no initial values. */ | |
452 | if (!is_init) | |
453 | { | |
454 | DECL_INITIAL (decl) = NULL_TREE; | |
455 | DECL_COMMON (decl) = 1; | |
456 | DECL_DEFER_OUTPUT (decl) = 1; | |
6de9cd9a DN |
457 | } |
458 | else | |
459 | { | |
460 | DECL_INITIAL (decl) = error_mark_node; | |
461 | DECL_COMMON (decl) = 0; | |
462 | DECL_DEFER_OUTPUT (decl) = 0; | |
6de9cd9a DN |
463 | } |
464 | return decl; | |
465 | } | |
466 | ||
467 | ||
9d99ee7b PT |
468 | /* Return a field that is the size of the union, if an equivalence has |
469 | overlapping initializers. Merge the initializers into a single | |
470 | initializer for this new field, then free the old ones. */ | |
471 | ||
472 | static tree | |
473 | get_init_field (segment_info *head, tree union_type, tree *field_init, | |
474 | record_layout_info rli) | |
475 | { | |
476 | segment_info *s; | |
477 | HOST_WIDE_INT length = 0; | |
478 | HOST_WIDE_INT offset = 0; | |
479 | unsigned HOST_WIDE_INT known_align, desired_align; | |
480 | bool overlap = false; | |
481 | tree tmp, field; | |
482 | tree init; | |
483 | unsigned char *data, *chk; | |
484 | VEC(constructor_elt,gc) *v = NULL; | |
485 | ||
486 | tree type = unsigned_char_type_node; | |
487 | int i; | |
488 | ||
489 | /* Obtain the size of the union and check if there are any overlapping | |
490 | initializers. */ | |
491 | for (s = head; s; s = s->next) | |
492 | { | |
493 | HOST_WIDE_INT slen = s->offset + s->length; | |
494 | if (s->sym->value) | |
495 | { | |
496 | if (s->offset < offset) | |
497 | overlap = true; | |
498 | offset = slen; | |
499 | } | |
500 | length = length < slen ? slen : length; | |
501 | } | |
502 | ||
503 | if (!overlap) | |
504 | return NULL_TREE; | |
505 | ||
506 | /* Now absorb all the initializer data into a single vector, | |
507 | whilst checking for overlapping, unequal values. */ | |
508 | data = (unsigned char*)gfc_getmem ((size_t)length); | |
509 | chk = (unsigned char*)gfc_getmem ((size_t)length); | |
510 | ||
511 | /* TODO - change this when default initialization is implemented. */ | |
512 | memset (data, '\0', (size_t)length); | |
513 | memset (chk, '\0', (size_t)length); | |
514 | for (s = head; s; s = s->next) | |
515 | if (s->sym->value) | |
516 | gfc_merge_initializers (s->sym->ts, s->sym->value, | |
517 | &data[s->offset], | |
518 | &chk[s->offset], | |
519 | (size_t)s->length); | |
520 | ||
521 | for (i = 0; i < length; i++) | |
522 | CONSTRUCTOR_APPEND_ELT (v, NULL, build_int_cst (type, data[i])); | |
523 | ||
524 | gfc_free (data); | |
525 | gfc_free (chk); | |
526 | ||
527 | /* Build a char[length] array to hold the initializers. Much of what | |
528 | follows is borrowed from build_field, above. */ | |
529 | ||
530 | tmp = build_int_cst (gfc_array_index_type, length - 1); | |
531 | tmp = build_range_type (gfc_array_index_type, | |
532 | gfc_index_zero_node, tmp); | |
533 | tmp = build_array_type (type, tmp); | |
c2255bc4 AH |
534 | field = build_decl (gfc_current_locus.lb->location, |
535 | FIELD_DECL, NULL_TREE, tmp); | |
9d99ee7b PT |
536 | |
537 | known_align = BIGGEST_ALIGNMENT; | |
538 | ||
539 | desired_align = update_alignment_for_field (rli, field, known_align); | |
540 | if (desired_align > known_align) | |
541 | DECL_PACKED (field) = 1; | |
542 | ||
543 | DECL_FIELD_CONTEXT (field) = union_type; | |
544 | DECL_FIELD_OFFSET (field) = size_int (0); | |
545 | DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node; | |
546 | SET_DECL_OFFSET_ALIGN (field, known_align); | |
547 | ||
548 | rli->offset = size_binop (MAX_EXPR, rli->offset, | |
549 | size_binop (PLUS_EXPR, | |
550 | DECL_FIELD_OFFSET (field), | |
551 | DECL_SIZE_UNIT (field))); | |
552 | ||
553 | init = build_constructor (TREE_TYPE (field), v); | |
554 | TREE_CONSTANT (init) = 1; | |
9d99ee7b PT |
555 | |
556 | *field_init = init; | |
557 | ||
558 | for (s = head; s; s = s->next) | |
559 | { | |
560 | if (s->sym->value == NULL) | |
561 | continue; | |
562 | ||
563 | gfc_free_expr (s->sym->value); | |
564 | s->sym->value = NULL; | |
565 | } | |
566 | ||
567 | return field; | |
568 | } | |
569 | ||
570 | ||
6de9cd9a DN |
571 | /* Declare memory for the common block or local equivalence, and create |
572 | backend declarations for all of the elements. */ | |
573 | ||
574 | static void | |
66e4ab31 | 575 | create_common (gfc_common_head *com, segment_info *head, bool saw_equiv) |
a8a6b603 TS |
576 | { |
577 | segment_info *s, *next_s; | |
6de9cd9a DN |
578 | tree union_type; |
579 | tree *field_link; | |
9d99ee7b | 580 | tree field; |
f84c7ed9 | 581 | tree field_init = NULL_TREE; |
6de9cd9a DN |
582 | record_layout_info rli; |
583 | tree decl; | |
584 | bool is_init = false; | |
57f0d086 | 585 | bool is_saved = false; |
6de9cd9a | 586 | |
a3122424 CY |
587 | /* Declare the variables inside the common block. |
588 | If the current common block contains any equivalence object, then | |
589 | make a UNION_TYPE node, otherwise RECORD_TYPE. This will let the | |
590 | alias analyzer work well when there is no address overlapping for | |
591 | common variables in the current common block. */ | |
592 | if (saw_equiv) | |
593 | union_type = make_node (UNION_TYPE); | |
594 | else | |
595 | union_type = make_node (RECORD_TYPE); | |
596 | ||
6de9cd9a DN |
597 | rli = start_record_layout (union_type); |
598 | field_link = &TYPE_FIELDS (union_type); | |
599 | ||
9d99ee7b PT |
600 | /* Check for overlapping initializers and replace them with a single, |
601 | artificial field that contains all the data. */ | |
602 | if (saw_equiv) | |
603 | field = get_init_field (head, union_type, &field_init, rli); | |
604 | else | |
605 | field = NULL_TREE; | |
606 | ||
607 | if (field != NULL_TREE) | |
608 | { | |
609 | is_init = true; | |
610 | *field_link = field; | |
910ad8de | 611 | field_link = &DECL_CHAIN (field); |
9d99ee7b PT |
612 | } |
613 | ||
832ef1ce | 614 | for (s = head; s; s = s->next) |
6de9cd9a | 615 | { |
a8a6b603 | 616 | build_field (s, union_type, rli); |
6de9cd9a DN |
617 | |
618 | /* Link the field into the type. */ | |
a8a6b603 | 619 | *field_link = s->field; |
910ad8de | 620 | field_link = &DECL_CHAIN (s->field); |
ad6e2a18 | 621 | |
a8a6b603 TS |
622 | /* Has initial value. */ |
623 | if (s->sym->value) | |
6de9cd9a | 624 | is_init = true; |
57f0d086 JJ |
625 | |
626 | /* Has SAVE attribute. */ | |
627 | if (s->sym->attr.save) | |
628 | is_saved = true; | |
6de9cd9a | 629 | } |
9d99ee7b | 630 | |
6de9cd9a DN |
631 | finish_record_layout (rli, true); |
632 | ||
9056bd70 | 633 | if (com) |
53814b8f | 634 | decl = build_common_decl (com, union_type, is_init); |
6de9cd9a | 635 | else |
57f0d086 | 636 | decl = build_equiv_decl (union_type, is_init, is_saved); |
6de9cd9a | 637 | |
5291e69a PB |
638 | if (is_init) |
639 | { | |
4038c495 | 640 | tree ctor, tmp; |
4038c495 | 641 | VEC(constructor_elt,gc) *v = NULL; |
5291e69a | 642 | |
9d99ee7b PT |
643 | if (field != NULL_TREE && field_init != NULL_TREE) |
644 | CONSTRUCTOR_APPEND_ELT (v, field, field_init); | |
645 | else | |
646 | for (s = head; s; s = s->next) | |
647 | { | |
648 | if (s->sym->value) | |
649 | { | |
650 | /* Add the initializer for this field. */ | |
651 | tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts, | |
1d0134b3 JW |
652 | TREE_TYPE (s->field), |
653 | s->sym->attr.dimension, | |
654 | s->sym->attr.pointer | |
655 | || s->sym->attr.allocatable, false); | |
9d99ee7b PT |
656 | |
657 | CONSTRUCTOR_APPEND_ELT (v, s->field, tmp); | |
9d99ee7b PT |
658 | } |
659 | } | |
660 | ||
4038c495 GB |
661 | gcc_assert (!VEC_empty (constructor_elt, v)); |
662 | ctor = build_constructor (union_type, v); | |
5291e69a | 663 | TREE_CONSTANT (ctor) = 1; |
5291e69a PB |
664 | TREE_STATIC (ctor) = 1; |
665 | DECL_INITIAL (decl) = ctor; | |
666 | ||
667 | #ifdef ENABLE_CHECKING | |
4038c495 GB |
668 | { |
669 | tree field, value; | |
670 | unsigned HOST_WIDE_INT idx; | |
671 | FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor), idx, field, value) | |
672 | gcc_assert (TREE_CODE (field) == FIELD_DECL); | |
673 | } | |
5291e69a PB |
674 | #endif |
675 | } | |
676 | ||
6de9cd9a | 677 | /* Build component reference for each variable. */ |
832ef1ce | 678 | for (s = head; s; s = next_s) |
6de9cd9a | 679 | { |
81871c2a JJ |
680 | tree var_decl; |
681 | ||
c2255bc4 AH |
682 | var_decl = build_decl (s->sym->declared_at.lb->location, |
683 | VAR_DECL, DECL_NAME (s->field), | |
81871c2a | 684 | TREE_TYPE (s->field)); |
81871c2a JJ |
685 | TREE_STATIC (var_decl) = TREE_STATIC (decl); |
686 | TREE_USED (var_decl) = TREE_USED (decl); | |
a64f5186 JJ |
687 | if (s->sym->attr.use_assoc) |
688 | DECL_IGNORED_P (var_decl) = 1; | |
81871c2a JJ |
689 | if (s->sym->attr.target) |
690 | TREE_ADDRESSABLE (var_decl) = 1; | |
691 | /* This is a fake variable just for debugging purposes. */ | |
692 | TREE_ASM_WRITTEN (var_decl) = 1; | |
4d62b56a RAE |
693 | /* Fake variables are not visible from other translation units. */ |
694 | TREE_PUBLIC (var_decl) = 0; | |
695 | ||
da69cc91 GH |
696 | /* To preserve identifier names in COMMON, chain to procedure |
697 | scope unless at top level in a module definition. */ | |
698 | if (com | |
699 | && s->sym->ns->proc_name | |
700 | && s->sym->ns->proc_name->attr.flavor == FL_MODULE) | |
6c0c6ecc JD |
701 | var_decl = pushdecl_top_level (var_decl); |
702 | else | |
da69cc91 | 703 | gfc_add_decl_to_function (var_decl); |
81871c2a JJ |
704 | |
705 | SET_DECL_VALUE_EXPR (var_decl, | |
bc98ed60 TB |
706 | fold_build3_loc (input_location, COMPONENT_REF, |
707 | TREE_TYPE (s->field), | |
708 | decl, s->field, NULL_TREE)); | |
81871c2a | 709 | DECL_HAS_VALUE_EXPR_P (var_decl) = 1; |
6c7a4dfd | 710 | GFC_DECL_COMMON_OR_EQUIV (var_decl) = 1; |
81871c2a JJ |
711 | |
712 | if (s->sym->attr.assign) | |
713 | { | |
714 | gfc_allocate_lang_decl (var_decl); | |
715 | GFC_DECL_ASSIGN (var_decl) = 1; | |
716 | GFC_DECL_STRING_LEN (var_decl) = GFC_DECL_STRING_LEN (s->field); | |
717 | GFC_DECL_ASSIGN_ADDR (var_decl) = GFC_DECL_ASSIGN_ADDR (s->field); | |
718 | } | |
719 | ||
720 | s->sym->backend_decl = var_decl; | |
6de9cd9a | 721 | |
a8a6b603 TS |
722 | next_s = s->next; |
723 | gfc_free (s); | |
6de9cd9a | 724 | } |
a8a6b603 | 725 | } |
6de9cd9a DN |
726 | |
727 | ||
728 | /* Given a symbol, find it in the current segment list. Returns NULL if | |
a8a6b603 | 729 | not found. */ |
6de9cd9a | 730 | |
a8a6b603 | 731 | static segment_info * |
6de9cd9a | 732 | find_segment_info (gfc_symbol *symbol) |
a8a6b603 | 733 | { |
6de9cd9a DN |
734 | segment_info *n; |
735 | ||
736 | for (n = current_segment; n; n = n->next) | |
5291e69a PB |
737 | { |
738 | if (n->sym == symbol) | |
739 | return n; | |
740 | } | |
6de9cd9a | 741 | |
a8a6b603 TS |
742 | return NULL; |
743 | } | |
6de9cd9a DN |
744 | |
745 | ||
6de9cd9a | 746 | /* Given an expression node, make sure it is a constant integer and return |
a8a6b603 | 747 | the mpz_t value. */ |
6de9cd9a | 748 | |
a8a6b603 TS |
749 | static mpz_t * |
750 | get_mpz (gfc_expr *e) | |
6de9cd9a | 751 | { |
a8a6b603 TS |
752 | |
753 | if (e->expr_type != EXPR_CONSTANT) | |
6de9cd9a DN |
754 | gfc_internal_error ("get_mpz(): Not an integer constant"); |
755 | ||
a8a6b603 TS |
756 | return &e->value.integer; |
757 | } | |
6de9cd9a DN |
758 | |
759 | ||
760 | /* Given an array specification and an array reference, figure out the | |
761 | array element number (zero based). Bounds and elements are guaranteed | |
762 | to be constants. If something goes wrong we generate an error and | |
a8a6b603 | 763 | return zero. */ |
6de9cd9a | 764 | |
5291e69a | 765 | static HOST_WIDE_INT |
6de9cd9a | 766 | element_number (gfc_array_ref *ar) |
a8a6b603 TS |
767 | { |
768 | mpz_t multiplier, offset, extent, n; | |
6de9cd9a | 769 | gfc_array_spec *as; |
a8a6b603 | 770 | HOST_WIDE_INT i, rank; |
6de9cd9a DN |
771 | |
772 | as = ar->as; | |
773 | rank = as->rank; | |
774 | mpz_init_set_ui (multiplier, 1); | |
775 | mpz_init_set_ui (offset, 0); | |
776 | mpz_init (extent); | |
a8a6b603 | 777 | mpz_init (n); |
6de9cd9a | 778 | |
a8a6b603 | 779 | for (i = 0; i < rank; i++) |
6de9cd9a | 780 | { |
a8a6b603 | 781 | if (ar->dimen_type[i] != DIMEN_ELEMENT) |
6de9cd9a DN |
782 | gfc_internal_error ("element_number(): Bad dimension type"); |
783 | ||
a8a6b603 | 784 | mpz_sub (n, *get_mpz (ar->start[i]), *get_mpz (as->lower[i])); |
6de9cd9a | 785 | |
a8a6b603 TS |
786 | mpz_mul (n, n, multiplier); |
787 | mpz_add (offset, offset, n); | |
6de9cd9a | 788 | |
a8a6b603 | 789 | mpz_sub (extent, *get_mpz (as->upper[i]), *get_mpz (as->lower[i])); |
6de9cd9a DN |
790 | mpz_add_ui (extent, extent, 1); |
791 | ||
792 | if (mpz_sgn (extent) < 0) | |
793 | mpz_set_ui (extent, 0); | |
794 | ||
795 | mpz_mul (multiplier, multiplier, extent); | |
796 | } | |
797 | ||
a8a6b603 | 798 | i = mpz_get_ui (offset); |
6de9cd9a DN |
799 | |
800 | mpz_clear (multiplier); | |
801 | mpz_clear (offset); | |
802 | mpz_clear (extent); | |
a8a6b603 | 803 | mpz_clear (n); |
6de9cd9a | 804 | |
a8a6b603 | 805 | return i; |
6de9cd9a DN |
806 | } |
807 | ||
808 | ||
809 | /* Given a single element of an equivalence list, figure out the offset | |
810 | from the base symbol. For simple variables or full arrays, this is | |
811 | simply zero. For an array element we have to calculate the array | |
812 | element number and multiply by the element size. For a substring we | |
813 | have to calculate the further reference. */ | |
814 | ||
5291e69a | 815 | static HOST_WIDE_INT |
a8a6b603 | 816 | calculate_offset (gfc_expr *e) |
6de9cd9a | 817 | { |
a8a6b603 | 818 | HOST_WIDE_INT n, element_size, offset; |
6de9cd9a DN |
819 | gfc_typespec *element_type; |
820 | gfc_ref *reference; | |
821 | ||
822 | offset = 0; | |
a8a6b603 | 823 | element_type = &e->symtree->n.sym->ts; |
6de9cd9a | 824 | |
a8a6b603 | 825 | for (reference = e->ref; reference; reference = reference->next) |
6de9cd9a DN |
826 | switch (reference->type) |
827 | { | |
828 | case REF_ARRAY: | |
829 | switch (reference->u.ar.type) | |
830 | { | |
831 | case AR_FULL: | |
832 | break; | |
833 | ||
834 | case AR_ELEMENT: | |
a8a6b603 | 835 | n = element_number (&reference->u.ar); |
6de9cd9a | 836 | if (element_type->type == BT_CHARACTER) |
bc21d315 | 837 | gfc_conv_const_charlen (element_type->u.cl); |
6de9cd9a DN |
838 | element_size = |
839 | int_size_in_bytes (gfc_typenode_for_spec (element_type)); | |
a8a6b603 | 840 | offset += n * element_size; |
6de9cd9a DN |
841 | break; |
842 | ||
843 | default: | |
a8a6b603 | 844 | gfc_error ("Bad array reference at %L", &e->where); |
6de9cd9a DN |
845 | } |
846 | break; | |
847 | case REF_SUBSTRING: | |
848 | if (reference->u.ss.start != NULL) | |
849 | offset += mpz_get_ui (*get_mpz (reference->u.ss.start)) - 1; | |
850 | break; | |
851 | default: | |
5291e69a | 852 | gfc_error ("Illegal reference type at %L as EQUIVALENCE object", |
a8a6b603 TS |
853 | &e->where); |
854 | } | |
6de9cd9a DN |
855 | return offset; |
856 | } | |
857 | ||
a8a6b603 | 858 | |
5291e69a PB |
859 | /* Add a new segment_info structure to the current segment. eq1 is already |
860 | in the list, eq2 is not. */ | |
6de9cd9a DN |
861 | |
862 | static void | |
863 | new_condition (segment_info *v, gfc_equiv *eq1, gfc_equiv *eq2) | |
864 | { | |
5291e69a | 865 | HOST_WIDE_INT offset1, offset2; |
6de9cd9a | 866 | segment_info *a; |
a8a6b603 | 867 | |
6de9cd9a DN |
868 | offset1 = calculate_offset (eq1->expr); |
869 | offset2 = calculate_offset (eq2->expr); | |
870 | ||
ad6e2a18 TS |
871 | a = get_segment_info (eq2->expr->symtree->n.sym, |
872 | v->offset + offset1 - offset2); | |
6de9cd9a | 873 | |
5291e69a | 874 | current_segment = add_segments (current_segment, a); |
6de9cd9a DN |
875 | } |
876 | ||
877 | ||
878 | /* Given two equivalence structures that are both already in the list, make | |
879 | sure that this new condition is not violated, generating an error if it | |
880 | is. */ | |
881 | ||
882 | static void | |
a8a6b603 | 883 | confirm_condition (segment_info *s1, gfc_equiv *eq1, segment_info *s2, |
6de9cd9a DN |
884 | gfc_equiv *eq2) |
885 | { | |
5291e69a | 886 | HOST_WIDE_INT offset1, offset2; |
6de9cd9a DN |
887 | |
888 | offset1 = calculate_offset (eq1->expr); | |
889 | offset2 = calculate_offset (eq2->expr); | |
a8a6b603 TS |
890 | |
891 | if (s1->offset + offset1 != s2->offset + offset2) | |
5291e69a | 892 | gfc_error ("Inconsistent equivalence rules involving '%s' at %L and " |
a8a6b603 TS |
893 | "'%s' at %L", s1->sym->name, &s1->sym->declared_at, |
894 | s2->sym->name, &s2->sym->declared_at); | |
895 | } | |
896 | ||
6de9cd9a | 897 | |
5291e69a PB |
898 | /* Process a new equivalence condition. eq1 is know to be in segment f. |
899 | If eq2 is also present then confirm that the condition holds. | |
900 | Otherwise add a new variable to the segment list. */ | |
6de9cd9a DN |
901 | |
902 | static void | |
5291e69a | 903 | add_condition (segment_info *f, gfc_equiv *eq1, gfc_equiv *eq2) |
6de9cd9a | 904 | { |
5291e69a | 905 | segment_info *n; |
6de9cd9a | 906 | |
5291e69a | 907 | n = find_segment_info (eq2->expr->symtree->n.sym); |
6de9cd9a | 908 | |
5291e69a PB |
909 | if (n == NULL) |
910 | new_condition (f, eq1, eq2); | |
911 | else | |
912 | confirm_condition (f, eq1, n, eq2); | |
6de9cd9a DN |
913 | } |
914 | ||
915 | ||
5291e69a | 916 | /* Given a segment element, search through the equivalence lists for unused |
30aabb86 PT |
917 | conditions that involve the symbol. Add these rules to the segment. */ |
918 | ||
5291e69a | 919 | static bool |
a8a6b603 | 920 | find_equivalence (segment_info *n) |
6de9cd9a | 921 | { |
30aabb86 | 922 | gfc_equiv *e1, *e2, *eq; |
5291e69a | 923 | bool found; |
30aabb86 | 924 | |
5291e69a | 925 | found = FALSE; |
30aabb86 | 926 | |
a8a6b603 | 927 | for (e1 = n->sym->ns->equiv; e1; e1 = e1->next) |
5291e69a | 928 | { |
30aabb86 | 929 | eq = NULL; |
5291e69a | 930 | |
30aabb86 PT |
931 | /* Search the equivalence list, including the root (first) element |
932 | for the symbol that owns the segment. */ | |
933 | for (e2 = e1; e2; e2 = e2->eq) | |
934 | { | |
935 | if (!e2->used && e2->expr->symtree->n.sym == n->sym) | |
5291e69a | 936 | { |
a8a6b603 | 937 | eq = e2; |
30aabb86 | 938 | break; |
5291e69a | 939 | } |
30aabb86 PT |
940 | } |
941 | ||
942 | /* Go to the next root element. */ | |
943 | if (eq == NULL) | |
944 | continue; | |
945 | ||
946 | eq->used = 1; | |
947 | ||
948 | /* Now traverse the equivalence list matching the offsets. */ | |
949 | for (e2 = e1; e2; e2 = e2->eq) | |
950 | { | |
951 | if (!e2->used && e2 != eq) | |
5291e69a | 952 | { |
30aabb86 PT |
953 | add_condition (n, eq, e2); |
954 | e2->used = 1; | |
5291e69a | 955 | found = TRUE; |
5291e69a PB |
956 | } |
957 | } | |
958 | } | |
959 | return found; | |
6de9cd9a DN |
960 | } |
961 | ||
a8a6b603 | 962 | |
66e4ab31 | 963 | /* Add all symbols equivalenced within a segment. We need to scan the |
8a0b57b3 PT |
964 | segment list multiple times to include indirect equivalences. Since |
965 | a new segment_info can inserted at the beginning of the segment list, | |
966 | depending on its offset, we have to force a final pass through the | |
df2fba9e | 967 | loop by demanding that completion sees a pass with no matches; i.e., |
8a0b57b3 | 968 | all symbols with equiv_built set and no new equivalences found. */ |
6de9cd9a | 969 | |
5291e69a | 970 | static void |
a3122424 | 971 | add_equivalences (bool *saw_equiv) |
6de9cd9a | 972 | { |
6de9cd9a | 973 | segment_info *f; |
8a0b57b3 | 974 | bool seen_one, more; |
6de9cd9a | 975 | |
8a0b57b3 | 976 | seen_one = false; |
5291e69a PB |
977 | more = TRUE; |
978 | while (more) | |
6de9cd9a | 979 | { |
5291e69a PB |
980 | more = FALSE; |
981 | for (f = current_segment; f; f = f->next) | |
982 | { | |
983 | if (!f->sym->equiv_built) | |
984 | { | |
985 | f->sym->equiv_built = 1; | |
8a0b57b3 PT |
986 | seen_one = find_equivalence (f); |
987 | if (seen_one) | |
988 | { | |
989 | *saw_equiv = true; | |
990 | more = true; | |
991 | } | |
5291e69a PB |
992 | } |
993 | } | |
6de9cd9a | 994 | } |
61321991 PT |
995 | |
996 | /* Add a copy of this segment list to the namespace. */ | |
997 | copy_equiv_list_to_ns (current_segment); | |
6de9cd9a | 998 | } |
a8a6b603 TS |
999 | |
1000 | ||
43a5ef69 | 1001 | /* Returns the offset necessary to properly align the current equivalence. |
832ef1ce PB |
1002 | Sets *palign to the required alignment. */ |
1003 | ||
1004 | static HOST_WIDE_INT | |
66e4ab31 | 1005 | align_segment (unsigned HOST_WIDE_INT *palign) |
832ef1ce PB |
1006 | { |
1007 | segment_info *s; | |
1008 | unsigned HOST_WIDE_INT offset; | |
1009 | unsigned HOST_WIDE_INT max_align; | |
1010 | unsigned HOST_WIDE_INT this_align; | |
1011 | unsigned HOST_WIDE_INT this_offset; | |
1012 | ||
1013 | max_align = 1; | |
1014 | offset = 0; | |
1015 | for (s = current_segment; s; s = s->next) | |
1016 | { | |
1017 | this_align = TYPE_ALIGN_UNIT (s->field); | |
1018 | if (s->offset & (this_align - 1)) | |
1019 | { | |
1020 | /* Field is misaligned. */ | |
1021 | this_offset = this_align - ((s->offset + offset) & (this_align - 1)); | |
1022 | if (this_offset & (max_align - 1)) | |
1023 | { | |
1024 | /* Aligning this field would misalign a previous field. */ | |
1025 | gfc_error ("The equivalence set for variable '%s' " | |
eb6d74fa | 1026 | "declared at %L violates alignment requirements", |
832ef1ce PB |
1027 | s->sym->name, &s->sym->declared_at); |
1028 | } | |
1029 | offset += this_offset; | |
1030 | } | |
1031 | max_align = this_align; | |
1032 | } | |
1033 | if (palign) | |
1034 | *palign = max_align; | |
1035 | return offset; | |
1036 | } | |
1037 | ||
1038 | ||
1039 | /* Adjust segment offsets by the given amount. */ | |
a8a6b603 | 1040 | |
6de9cd9a | 1041 | static void |
66e4ab31 | 1042 | apply_segment_offset (segment_info *s, HOST_WIDE_INT offset) |
6de9cd9a | 1043 | { |
832ef1ce PB |
1044 | for (; s; s = s->next) |
1045 | s->offset += offset; | |
1046 | } | |
1047 | ||
1048 | ||
1049 | /* Lay out a symbol in a common block. If the symbol has already been seen | |
1050 | then check the location is consistent. Otherwise create segments | |
1051 | for that symbol and all the symbols equivalenced with it. */ | |
1052 | ||
1053 | /* Translate a single common block. */ | |
1054 | ||
1055 | static void | |
1056 | translate_common (gfc_common_head *common, gfc_symbol *var_list) | |
1057 | { | |
1058 | gfc_symbol *sym; | |
1059 | segment_info *s; | |
1060 | segment_info *common_segment; | |
1061 | HOST_WIDE_INT offset; | |
1062 | HOST_WIDE_INT current_offset; | |
1063 | unsigned HOST_WIDE_INT align; | |
1064 | unsigned HOST_WIDE_INT max_align; | |
a3122424 | 1065 | bool saw_equiv; |
832ef1ce PB |
1066 | |
1067 | common_segment = NULL; | |
f613cea7 | 1068 | offset = 0; |
832ef1ce | 1069 | current_offset = 0; |
f613cea7 | 1070 | align = 1; |
832ef1ce | 1071 | max_align = 1; |
a3122424 | 1072 | saw_equiv = false; |
832ef1ce PB |
1073 | |
1074 | /* Add symbols to the segment. */ | |
1075 | for (sym = var_list; sym; sym = sym->common_next) | |
1076 | { | |
30aabb86 PT |
1077 | current_segment = common_segment; |
1078 | s = find_segment_info (sym); | |
832ef1ce | 1079 | |
30aabb86 PT |
1080 | /* Symbol has already been added via an equivalence. Multiple |
1081 | use associations of the same common block result in equiv_built | |
1082 | being set but no information about the symbol in the segment. */ | |
1083 | if (s && sym->equiv_built) | |
1084 | { | |
832ef1ce PB |
1085 | /* Ensure the current location is properly aligned. */ |
1086 | align = TYPE_ALIGN_UNIT (s->field); | |
1087 | current_offset = (current_offset + align - 1) &~ (align - 1); | |
1088 | ||
1089 | /* Verify that it ended up where we expect it. */ | |
1090 | if (s->offset != current_offset) | |
1091 | { | |
1092 | gfc_error ("Equivalence for '%s' does not match ordering of " | |
1093 | "COMMON '%s' at %L", sym->name, | |
1094 | common->name, &common->where); | |
1095 | } | |
1096 | } | |
1097 | else | |
1098 | { | |
1099 | /* A symbol we haven't seen before. */ | |
1100 | s = current_segment = get_segment_info (sym, current_offset); | |
a8a6b603 | 1101 | |
832ef1ce PB |
1102 | /* Add all objects directly or indirectly equivalenced with this |
1103 | symbol. */ | |
a3122424 | 1104 | add_equivalences (&saw_equiv); |
ad6e2a18 | 1105 | |
832ef1ce PB |
1106 | if (current_segment->offset < 0) |
1107 | gfc_error ("The equivalence set for '%s' cause an invalid " | |
1108 | "extension to COMMON '%s' at %L", sym->name, | |
1109 | common->name, &common->where); | |
6de9cd9a | 1110 | |
f613cea7 JW |
1111 | if (gfc_option.flag_align_commons) |
1112 | offset = align_segment (&align); | |
6de9cd9a | 1113 | |
832ef1ce PB |
1114 | if (offset & (max_align - 1)) |
1115 | { | |
1116 | /* The required offset conflicts with previous alignment | |
1117 | requirements. Insert padding immediately before this | |
1118 | segment. */ | |
f613cea7 JW |
1119 | if (gfc_option.warn_align_commons) |
1120 | { | |
1121 | if (strcmp (common->name, BLANK_COMMON_NAME)) | |
1122 | gfc_warning ("Padding of %d bytes required before '%s' in " | |
1123 | "COMMON '%s' at %L; reorder elements or use " | |
1124 | "-fno-align-commons", (int)offset, | |
1125 | s->sym->name, common->name, &common->where); | |
1126 | else | |
1127 | gfc_warning ("Padding of %d bytes required before '%s' in " | |
1128 | "COMMON at %L; reorder elements or use " | |
1129 | "-fno-align-commons", (int)offset, | |
1130 | s->sym->name, &common->where); | |
1131 | } | |
832ef1ce | 1132 | } |
6de9cd9a | 1133 | |
832ef1ce PB |
1134 | /* Apply the offset to the new segments. */ |
1135 | apply_segment_offset (current_segment, offset); | |
1136 | current_offset += offset; | |
1137 | if (max_align < align) | |
1138 | max_align = align; | |
1139 | ||
1140 | /* Add the new segments to the common block. */ | |
1141 | common_segment = add_segments (common_segment, current_segment); | |
1142 | } | |
1143 | ||
1144 | /* The offset of the next common variable. */ | |
1145 | current_offset += s->length; | |
1146 | } | |
1147 | ||
b8ea6dbc PT |
1148 | if (common_segment == NULL) |
1149 | { | |
1150 | gfc_error ("COMMON '%s' at %L does not exist", | |
1151 | common->name, &common->where); | |
1152 | return; | |
1153 | } | |
1154 | ||
f613cea7 | 1155 | if (common_segment->offset != 0 && gfc_option.warn_align_commons) |
832ef1ce | 1156 | { |
f613cea7 JW |
1157 | if (strcmp (common->name, BLANK_COMMON_NAME)) |
1158 | gfc_warning ("COMMON '%s' at %L requires %d bytes of padding at start; " | |
1159 | "reorder elements or use -fno-align-commons", | |
1160 | common->name, &common->where, (int)common_segment->offset); | |
1161 | else | |
1162 | gfc_warning ("COMMON at %L requires %d bytes of padding at start; " | |
1163 | "reorder elements or use -fno-align-commons", | |
1164 | &common->where, (int)common_segment->offset); | |
832ef1ce PB |
1165 | } |
1166 | ||
a3122424 | 1167 | create_common (common, common_segment, saw_equiv); |
6de9cd9a DN |
1168 | } |
1169 | ||
1170 | ||
1171 | /* Create a new block for each merged equivalence list. */ | |
1172 | ||
1173 | static void | |
1174 | finish_equivalences (gfc_namespace *ns) | |
1175 | { | |
1176 | gfc_equiv *z, *y; | |
1177 | gfc_symbol *sym; | |
30aabb86 | 1178 | gfc_common_head * c; |
36c028f6 PB |
1179 | HOST_WIDE_INT offset; |
1180 | unsigned HOST_WIDE_INT align; | |
a3122424 | 1181 | bool dummy; |
6de9cd9a DN |
1182 | |
1183 | for (z = ns->equiv; z; z = z->next) | |
a8a6b603 | 1184 | for (y = z->eq; y; y = y->eq) |
6de9cd9a | 1185 | { |
a8a6b603 TS |
1186 | if (y->used) |
1187 | continue; | |
6de9cd9a | 1188 | sym = z->expr->symtree->n.sym; |
ad6e2a18 | 1189 | current_segment = get_segment_info (sym, 0); |
6de9cd9a | 1190 | |
66e4ab31 SK |
1191 | /* All objects directly or indirectly equivalenced with this |
1192 | symbol. */ | |
a3122424 | 1193 | add_equivalences (&dummy); |
6de9cd9a | 1194 | |
36c028f6 PB |
1195 | /* Align the block. */ |
1196 | offset = align_segment (&align); | |
832ef1ce | 1197 | |
36c028f6 PB |
1198 | /* Ensure all offsets are positive. */ |
1199 | offset -= current_segment->offset & ~(align - 1); | |
6de9cd9a | 1200 | |
36c028f6 | 1201 | apply_segment_offset (current_segment, offset); |
6de9cd9a | 1202 | |
66e4ab31 SK |
1203 | /* Create the decl. If this is a module equivalence, it has a |
1204 | unique name, pointed to by z->module. This is written to a | |
1205 | gfc_common_header to push create_common into using | |
1206 | build_common_decl, so that the equivalence appears as an | |
1207 | external symbol. Otherwise, a local declaration is built using | |
1208 | build_equiv_decl. */ | |
30aabb86 PT |
1209 | if (z->module) |
1210 | { | |
1211 | c = gfc_get_common_head (); | |
1212 | /* We've lost the real location, so use the location of the | |
66e4ab31 | 1213 | enclosing procedure. */ |
30aabb86 PT |
1214 | c->where = ns->proc_name->declared_at; |
1215 | strcpy (c->name, z->module); | |
1216 | } | |
1217 | else | |
1218 | c = NULL; | |
1219 | ||
1220 | create_common (c, current_segment, true); | |
6de9cd9a DN |
1221 | break; |
1222 | } | |
1223 | } | |
1224 | ||
1225 | ||
6de9cd9a DN |
1226 | /* Work function for translating a named common block. */ |
1227 | ||
1228 | static void | |
9056bd70 | 1229 | named_common (gfc_symtree *st) |
6de9cd9a | 1230 | { |
53814b8f | 1231 | translate_common (st->n.common, st->n.common->head); |
6de9cd9a DN |
1232 | } |
1233 | ||
1234 | ||
1235 | /* Translate the common blocks in a namespace. Unlike other variables, | |
1236 | these have to be created before code, because the backend_decl depends | |
1237 | on the rest of the common block. */ | |
a8a6b603 TS |
1238 | |
1239 | void | |
6de9cd9a DN |
1240 | gfc_trans_common (gfc_namespace *ns) |
1241 | { | |
9056bd70 | 1242 | gfc_common_head *c; |
6de9cd9a DN |
1243 | |
1244 | /* Translate the blank common block. */ | |
9056bd70 | 1245 | if (ns->blank_common.head != NULL) |
6de9cd9a | 1246 | { |
9056bd70 | 1247 | c = gfc_get_common_head (); |
f613cea7 | 1248 | c->where = ns->blank_common.head->common_head->where; |
53814b8f TS |
1249 | strcpy (c->name, BLANK_COMMON_NAME); |
1250 | translate_common (c, ns->blank_common.head); | |
6de9cd9a | 1251 | } |
41433497 | 1252 | |
6de9cd9a | 1253 | /* Translate all named common blocks. */ |
a8a6b603 | 1254 | gfc_traverse_symtree (ns->common_root, named_common); |
6de9cd9a | 1255 | |
6de9cd9a DN |
1256 | /* Translate local equivalence. */ |
1257 | finish_equivalences (ns); | |
613e2ac8 PT |
1258 | |
1259 | /* Commit the newly created symbols for common blocks and module | |
1260 | equivalences. */ | |
1261 | gfc_commit_symbols (); | |
6de9cd9a | 1262 | } |