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