]>
Commit | Line | Data |
---|---|---|
6de9cd9a | 1 | /* Common block and equivalence list handling |
83ffe9cd | 2 | Copyright (C) 2000-2023 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; | |
3345e742 HA |
245 | /* Provide sufficient space to hold "symbol.symbol.eq.1234567890__". */ |
246 | char mangled_name[2*GFC_MAX_MANGLED_SYMBOL_LEN + 1 + 16 + 1]; | |
247 | char name[sizeof (mangled_name) - 2]; | |
a8b3b0b6 CR |
248 | |
249 | /* Get the name out of the common block pointer. */ | |
3345e742 HA |
250 | size_t len = strlen (com->name); |
251 | gcc_assert (len < sizeof (name)); | |
a8b3b0b6 CR |
252 | strcpy (name, com->name); |
253 | ||
254 | /* If we're suppose to do a bind(c). */ | |
62603fae | 255 | if (com->is_bind_c == 1 && com->binding_label) |
a8b3b0b6 | 256 | return get_identifier (com->binding_label); |
6de9cd9a | 257 | |
9056bd70 TS |
258 | if (strcmp (name, BLANK_COMMON_NAME) == 0) |
259 | return get_identifier (name); | |
a8a6b603 | 260 | |
c61819ff | 261 | if (flag_underscoring) |
6de9cd9a | 262 | { |
9056bd70 | 263 | has_underscore = strchr (name, '_') != 0; |
203c7ebf | 264 | if (flag_second_underscore && has_underscore) |
9056bd70 | 265 | snprintf (mangled_name, sizeof mangled_name, "%s__", name); |
6de9cd9a | 266 | else |
9056bd70 | 267 | snprintf (mangled_name, sizeof mangled_name, "%s_", name); |
a8a6b603 | 268 | |
9056bd70 | 269 | return get_identifier (mangled_name); |
6de9cd9a DN |
270 | } |
271 | else | |
9056bd70 | 272 | return get_identifier (name); |
6de9cd9a DN |
273 | } |
274 | ||
275 | ||
ad6e2a18 | 276 | /* Build a field declaration for a common variable or a local equivalence |
6de9cd9a DN |
277 | object. */ |
278 | ||
ad6e2a18 | 279 | static void |
6de9cd9a DN |
280 | build_field (segment_info *h, tree union_type, record_layout_info rli) |
281 | { | |
ad6e2a18 TS |
282 | tree field; |
283 | tree name; | |
6de9cd9a | 284 | HOST_WIDE_INT offset = h->offset; |
5291e69a | 285 | unsigned HOST_WIDE_INT desired_align, known_align; |
6de9cd9a | 286 | |
ad6e2a18 | 287 | name = get_identifier (h->sym->name); |
9c81750c | 288 | field = build_decl (gfc_get_location (&h->sym->declared_at), |
c2255bc4 | 289 | FIELD_DECL, name, h->field); |
6de9cd9a DN |
290 | known_align = (offset & -offset) * BITS_PER_UNIT; |
291 | if (known_align == 0 || known_align > BIGGEST_ALIGNMENT) | |
292 | known_align = BIGGEST_ALIGNMENT; | |
293 | ||
294 | desired_align = update_alignment_for_field (rli, field, known_align); | |
295 | if (desired_align > known_align) | |
296 | DECL_PACKED (field) = 1; | |
297 | ||
298 | DECL_FIELD_CONTEXT (field) = union_type; | |
299 | DECL_FIELD_OFFSET (field) = size_int (offset); | |
300 | DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node; | |
301 | SET_DECL_OFFSET_ALIGN (field, known_align); | |
302 | ||
303 | rli->offset = size_binop (MAX_EXPR, rli->offset, | |
304 | size_binop (PLUS_EXPR, | |
305 | DECL_FIELD_OFFSET (field), | |
306 | DECL_SIZE_UNIT (field))); | |
ce2df7c6 | 307 | /* If this field is assigned to a label, we create another two variables. |
81871c2a | 308 | One will hold the address of target label or format label. The other will |
ce2df7c6 FW |
309 | hold the length of format label string. */ |
310 | if (h->sym->attr.assign) | |
311 | { | |
312 | tree len; | |
313 | tree addr; | |
314 | ||
315 | gfc_allocate_lang_decl (field); | |
316 | GFC_DECL_ASSIGN (field) = 1; | |
317 | len = gfc_create_var_np (gfc_charlen_type_node,h->sym->name); | |
318 | addr = gfc_create_var_np (pvoid_type_node, h->sym->name); | |
319 | TREE_STATIC (len) = 1; | |
320 | TREE_STATIC (addr) = 1; | |
df09d1d5 | 321 | DECL_INITIAL (len) = build_int_cst (gfc_charlen_type_node, -2); |
ce2df7c6 FW |
322 | gfc_set_decl_location (len, &h->sym->declared_at); |
323 | gfc_set_decl_location (addr, &h->sym->declared_at); | |
324 | GFC_DECL_STRING_LEN (field) = pushdecl_top_level (len); | |
325 | GFC_DECL_ASSIGN_ADDR (field) = pushdecl_top_level (addr); | |
326 | } | |
327 | ||
e3ac9b24 FXC |
328 | /* If this field is volatile, mark it. */ |
329 | if (h->sym->attr.volatile_) | |
330 | { | |
7b901ac4 | 331 | tree new_type; |
e3ac9b24 | 332 | TREE_THIS_VOLATILE (field) = 1; |
c28d1d9b | 333 | TREE_SIDE_EFFECTS (field) = 1; |
7b901ac4 KG |
334 | new_type = build_qualified_type (TREE_TYPE (field), TYPE_QUAL_VOLATILE); |
335 | TREE_TYPE (field) = new_type; | |
e3ac9b24 FXC |
336 | } |
337 | ||
ad6e2a18 | 338 | h->field = field; |
6de9cd9a DN |
339 | } |
340 | ||
3881e182 RS |
341 | #if !defined (NO_DOT_IN_LABEL) |
342 | #define GFC_EQUIV_FMT "equiv.%d" | |
343 | #elif !defined (NO_DOLLAR_IN_LABEL) | |
344 | #define GFC_EQUIV_FMT "_Equiv$%d" | |
345 | #else | |
346 | #define GFC_EQUIV_FMT "_Equiv_%d" | |
347 | #endif | |
6de9cd9a DN |
348 | |
349 | /* Get storage for local equivalence. */ | |
350 | ||
351 | static tree | |
b323be61 | 352 | build_equiv_decl (tree union_type, bool is_init, bool is_saved, bool is_auto) |
6de9cd9a DN |
353 | { |
354 | tree decl; | |
efcc8d38 | 355 | char name[18]; |
bae88af6 | 356 | static int serial = 0; |
5291e69a PB |
357 | |
358 | if (is_init) | |
359 | { | |
360 | decl = gfc_create_var (union_type, "equiv"); | |
361 | TREE_STATIC (decl) = 1; | |
6c7a4dfd | 362 | GFC_DECL_COMMON_OR_EQUIV (decl) = 1; |
5291e69a PB |
363 | return decl; |
364 | } | |
365 | ||
3881e182 | 366 | snprintf (name, sizeof (name), GFC_EQUIV_FMT, serial++); |
c2255bc4 AH |
367 | decl = build_decl (input_location, |
368 | VAR_DECL, get_identifier (name), union_type); | |
6de9cd9a | 369 | DECL_ARTIFICIAL (decl) = 1; |
bae88af6 | 370 | DECL_IGNORED_P (decl) = 1; |
6de9cd9a | 371 | |
b323be61 ME |
372 | if (!is_auto && (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)) |
373 | || is_saved)) | |
bae88af6 | 374 | TREE_STATIC (decl) = 1; |
6de9cd9a DN |
375 | |
376 | TREE_ADDRESSABLE (decl) = 1; | |
377 | TREE_USED (decl) = 1; | |
6c7a4dfd | 378 | GFC_DECL_COMMON_OR_EQUIV (decl) = 1; |
c8cc8542 PB |
379 | |
380 | /* The source location has been lost, and doesn't really matter. | |
381 | We need to set it to something though. */ | |
382 | gfc_set_decl_location (decl, &gfc_current_locus); | |
383 | ||
6de9cd9a DN |
384 | gfc_add_decl_to_function (decl); |
385 | ||
386 | return decl; | |
387 | } | |
388 | ||
389 | ||
390 | /* Get storage for common block. */ | |
391 | ||
392 | static tree | |
53814b8f | 393 | build_common_decl (gfc_common_head *com, tree union_type, bool is_init) |
6de9cd9a | 394 | { |
878cdb7b | 395 | tree decl, identifier; |
6de9cd9a | 396 | |
878cdb7b TB |
397 | identifier = gfc_sym_mangled_common_id (com); |
398 | decl = gfc_map_of_all_commons.count(identifier) | |
399 | ? gfc_map_of_all_commons[identifier] : NULL_TREE; | |
6de9cd9a DN |
400 | |
401 | /* Update the size of this common block as needed. */ | |
402 | if (decl != NULL_TREE) | |
403 | { | |
5291e69a | 404 | tree size = TYPE_SIZE_UNIT (union_type); |
dc8c7978 TB |
405 | |
406 | /* Named common blocks of the same name shall be of the same size | |
407 | in all scoping units of a program in which they appear, but | |
408 | blank common blocks may be of different sizes. */ | |
409 | if (!tree_int_cst_equal (DECL_SIZE_UNIT (decl), size) | |
410 | && strcmp (com->name, BLANK_COMMON_NAME)) | |
db30e21c | 411 | gfc_warning (0, "Named COMMON block %qs at %L shall be of the " |
dc8c7978 TB |
412 | "same size as elsewhere (%lu vs %lu bytes)", com->name, |
413 | &com->where, | |
414 | (unsigned long) TREE_INT_CST_LOW (size), | |
415 | (unsigned long) TREE_INT_CST_LOW (DECL_SIZE_UNIT (decl))); | |
416 | ||
6de9cd9a | 417 | if (tree_int_cst_lt (DECL_SIZE_UNIT (decl), size)) |
dc8c7978 | 418 | { |
06796564 | 419 | DECL_SIZE (decl) = TYPE_SIZE (union_type); |
d8158369 | 420 | DECL_SIZE_UNIT (decl) = size; |
899ca90e | 421 | SET_DECL_MODE (decl, TYPE_MODE (union_type)); |
d8158369 | 422 | TREE_TYPE (decl) = union_type; |
06796564 | 423 | layout_decl (decl, 0); |
d8158369 | 424 | } |
6de9cd9a DN |
425 | } |
426 | ||
427 | /* If this common block has been declared in a previous program unit, | |
428 | and either it is already initialized or there is no new initialization | |
429 | for it, just return. */ | |
430 | if ((decl != NULL_TREE) && (!is_init || DECL_INITIAL (decl))) | |
431 | return decl; | |
432 | ||
433 | /* If there is no backend_decl for the common block, build it. */ | |
434 | if (decl == NULL_TREE) | |
435 | { | |
d58e7173 TB |
436 | tree omp_clauses = NULL_TREE; |
437 | ||
878cdb7b TB |
438 | if (com->is_bind_c == 1 && com->binding_label) |
439 | decl = build_decl (input_location, VAR_DECL, identifier, union_type); | |
440 | else | |
441 | { | |
442 | decl = build_decl (input_location, VAR_DECL, get_identifier (com->name), | |
443 | union_type); | |
444 | gfc_set_decl_assembler_name (decl, identifier); | |
445 | } | |
446 | ||
6de9cd9a DN |
447 | TREE_PUBLIC (decl) = 1; |
448 | TREE_STATIC (decl) = 1; | |
a64f5186 | 449 | DECL_IGNORED_P (decl) = 1; |
af90c10f | 450 | if (!com->is_bind_c) |
fe37c7af | 451 | SET_DECL_ALIGN (decl, BIGGEST_ALIGNMENT); |
af90c10f CR |
452 | else |
453 | { | |
454 | /* Do not set the alignment for bind(c) common blocks to | |
455 | BIGGEST_ALIGNMENT because that won't match what C does. Also, | |
456 | for common blocks with one element, the alignment must be | |
457 | that of the field within the common block in order to match | |
458 | what C will do. */ | |
459 | tree field = NULL_TREE; | |
460 | field = TYPE_FIELDS (TREE_TYPE (decl)); | |
910ad8de | 461 | if (DECL_CHAIN (field) == NULL_TREE) |
fe37c7af | 462 | SET_DECL_ALIGN (decl, TYPE_ALIGN (TREE_TYPE (field))); |
af90c10f | 463 | } |
6de9cd9a | 464 | DECL_USER_ALIGN (decl) = 0; |
6c7a4dfd | 465 | GFC_DECL_COMMON_OR_EQUIV (decl) = 1; |
5291e69a | 466 | |
c8cc8542 PB |
467 | gfc_set_decl_location (decl, &com->where); |
468 | ||
8893239d | 469 | if (com->threadprivate) |
56363ffd | 470 | set_decl_tls_model (decl, decl_default_tls_model (decl)); |
6c7a4dfd | 471 | |
d58e7173 TB |
472 | if (com->omp_device_type != OMP_DEVICE_TYPE_UNSET) |
473 | { | |
474 | tree c = build_omp_clause (UNKNOWN_LOCATION, OMP_CLAUSE_DEVICE_TYPE); | |
475 | switch (com->omp_device_type) | |
476 | { | |
477 | case OMP_DEVICE_TYPE_HOST: | |
478 | OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_HOST; | |
479 | break; | |
480 | case OMP_DEVICE_TYPE_NOHOST: | |
481 | OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_NOHOST; | |
482 | break; | |
483 | case OMP_DEVICE_TYPE_ANY: | |
484 | OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_ANY; | |
485 | break; | |
486 | default: | |
487 | gcc_unreachable (); | |
488 | } | |
489 | omp_clauses = c; | |
490 | } | |
b4c3a85b JJ |
491 | if (com->omp_declare_target_link) |
492 | DECL_ATTRIBUTES (decl) | |
493 | = tree_cons (get_identifier ("omp declare target link"), | |
d58e7173 | 494 | omp_clauses, DECL_ATTRIBUTES (decl)); |
b4c3a85b | 495 | else if (com->omp_declare_target) |
f014c653 JJ |
496 | DECL_ATTRIBUTES (decl) |
497 | = tree_cons (get_identifier ("omp declare target"), | |
d58e7173 | 498 | omp_clauses, DECL_ATTRIBUTES (decl)); |
f014c653 | 499 | |
5291e69a PB |
500 | /* Place the back end declaration for this common block in |
501 | GLOBAL_BINDING_LEVEL. */ | |
878cdb7b | 502 | gfc_map_of_all_commons[identifier] = pushdecl_top_level (decl); |
6de9cd9a DN |
503 | } |
504 | ||
505 | /* Has no initial values. */ | |
506 | if (!is_init) | |
507 | { | |
508 | DECL_INITIAL (decl) = NULL_TREE; | |
509 | DECL_COMMON (decl) = 1; | |
510 | DECL_DEFER_OUTPUT (decl) = 1; | |
6de9cd9a DN |
511 | } |
512 | else | |
513 | { | |
514 | DECL_INITIAL (decl) = error_mark_node; | |
515 | DECL_COMMON (decl) = 0; | |
516 | DECL_DEFER_OUTPUT (decl) = 0; | |
6de9cd9a DN |
517 | } |
518 | return decl; | |
519 | } | |
520 | ||
521 | ||
9d99ee7b PT |
522 | /* Return a field that is the size of the union, if an equivalence has |
523 | overlapping initializers. Merge the initializers into a single | |
524 | initializer for this new field, then free the old ones. */ | |
525 | ||
526 | static tree | |
527 | get_init_field (segment_info *head, tree union_type, tree *field_init, | |
528 | record_layout_info rli) | |
529 | { | |
530 | segment_info *s; | |
531 | HOST_WIDE_INT length = 0; | |
532 | HOST_WIDE_INT offset = 0; | |
533 | unsigned HOST_WIDE_INT known_align, desired_align; | |
534 | bool overlap = false; | |
535 | tree tmp, field; | |
536 | tree init; | |
537 | unsigned char *data, *chk; | |
9771b263 | 538 | vec<constructor_elt, va_gc> *v = NULL; |
9d99ee7b PT |
539 | |
540 | tree type = unsigned_char_type_node; | |
541 | int i; | |
542 | ||
543 | /* Obtain the size of the union and check if there are any overlapping | |
544 | initializers. */ | |
545 | for (s = head; s; s = s->next) | |
546 | { | |
547 | HOST_WIDE_INT slen = s->offset + s->length; | |
548 | if (s->sym->value) | |
549 | { | |
550 | if (s->offset < offset) | |
551 | overlap = true; | |
552 | offset = slen; | |
553 | } | |
554 | length = length < slen ? slen : length; | |
555 | } | |
556 | ||
557 | if (!overlap) | |
558 | return NULL_TREE; | |
559 | ||
560 | /* Now absorb all the initializer data into a single vector, | |
561 | whilst checking for overlapping, unequal values. */ | |
93acb62c JB |
562 | data = XCNEWVEC (unsigned char, (size_t)length); |
563 | chk = XCNEWVEC (unsigned char, (size_t)length); | |
9d99ee7b PT |
564 | |
565 | /* TODO - change this when default initialization is implemented. */ | |
566 | memset (data, '\0', (size_t)length); | |
567 | memset (chk, '\0', (size_t)length); | |
568 | for (s = head; s; s = s->next) | |
569 | if (s->sym->value) | |
93cb9a5a SK |
570 | { |
571 | locus *loc = NULL; | |
572 | if (s->sym->ns->equiv && s->sym->ns->equiv->eq) | |
573 | loc = &s->sym->ns->equiv->eq->expr->where; | |
574 | gfc_merge_initializers (s->sym->ts, s->sym->value, loc, | |
9d99ee7b PT |
575 | &data[s->offset], |
576 | &chk[s->offset], | |
577 | (size_t)s->length); | |
93cb9a5a | 578 | } |
9d99ee7b PT |
579 | |
580 | for (i = 0; i < length; i++) | |
581 | CONSTRUCTOR_APPEND_ELT (v, NULL, build_int_cst (type, data[i])); | |
582 | ||
cede9502 JM |
583 | free (data); |
584 | free (chk); | |
9d99ee7b PT |
585 | |
586 | /* Build a char[length] array to hold the initializers. Much of what | |
587 | follows is borrowed from build_field, above. */ | |
588 | ||
589 | tmp = build_int_cst (gfc_array_index_type, length - 1); | |
590 | tmp = build_range_type (gfc_array_index_type, | |
591 | gfc_index_zero_node, tmp); | |
592 | tmp = build_array_type (type, tmp); | |
9c81750c | 593 | field = build_decl (gfc_get_location (&gfc_current_locus), |
c2255bc4 | 594 | FIELD_DECL, NULL_TREE, tmp); |
9d99ee7b PT |
595 | |
596 | known_align = BIGGEST_ALIGNMENT; | |
597 | ||
598 | desired_align = update_alignment_for_field (rli, field, known_align); | |
599 | if (desired_align > known_align) | |
600 | DECL_PACKED (field) = 1; | |
601 | ||
602 | DECL_FIELD_CONTEXT (field) = union_type; | |
603 | DECL_FIELD_OFFSET (field) = size_int (0); | |
604 | DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node; | |
605 | SET_DECL_OFFSET_ALIGN (field, known_align); | |
606 | ||
607 | rli->offset = size_binop (MAX_EXPR, rli->offset, | |
608 | size_binop (PLUS_EXPR, | |
609 | DECL_FIELD_OFFSET (field), | |
610 | DECL_SIZE_UNIT (field))); | |
611 | ||
612 | init = build_constructor (TREE_TYPE (field), v); | |
613 | TREE_CONSTANT (init) = 1; | |
9d99ee7b PT |
614 | |
615 | *field_init = init; | |
616 | ||
617 | for (s = head; s; s = s->next) | |
618 | { | |
619 | if (s->sym->value == NULL) | |
620 | continue; | |
621 | ||
622 | gfc_free_expr (s->sym->value); | |
623 | s->sym->value = NULL; | |
624 | } | |
625 | ||
626 | return field; | |
627 | } | |
628 | ||
629 | ||
6de9cd9a DN |
630 | /* Declare memory for the common block or local equivalence, and create |
631 | backend declarations for all of the elements. */ | |
632 | ||
633 | static void | |
66e4ab31 | 634 | create_common (gfc_common_head *com, segment_info *head, bool saw_equiv) |
a8a6b603 TS |
635 | { |
636 | segment_info *s, *next_s; | |
6de9cd9a DN |
637 | tree union_type; |
638 | tree *field_link; | |
9d99ee7b | 639 | tree field; |
f84c7ed9 | 640 | tree field_init = NULL_TREE; |
6de9cd9a DN |
641 | record_layout_info rli; |
642 | tree decl; | |
643 | bool is_init = false; | |
57f0d086 | 644 | bool is_saved = false; |
b323be61 | 645 | bool is_auto = false; |
6de9cd9a | 646 | |
a3122424 CY |
647 | /* Declare the variables inside the common block. |
648 | If the current common block contains any equivalence object, then | |
649 | make a UNION_TYPE node, otherwise RECORD_TYPE. This will let the | |
650 | alias analyzer work well when there is no address overlapping for | |
651 | common variables in the current common block. */ | |
652 | if (saw_equiv) | |
653 | union_type = make_node (UNION_TYPE); | |
654 | else | |
655 | union_type = make_node (RECORD_TYPE); | |
656 | ||
6de9cd9a DN |
657 | rli = start_record_layout (union_type); |
658 | field_link = &TYPE_FIELDS (union_type); | |
659 | ||
9d99ee7b PT |
660 | /* Check for overlapping initializers and replace them with a single, |
661 | artificial field that contains all the data. */ | |
662 | if (saw_equiv) | |
663 | field = get_init_field (head, union_type, &field_init, rli); | |
664 | else | |
665 | field = NULL_TREE; | |
666 | ||
667 | if (field != NULL_TREE) | |
668 | { | |
669 | is_init = true; | |
670 | *field_link = field; | |
910ad8de | 671 | field_link = &DECL_CHAIN (field); |
9d99ee7b PT |
672 | } |
673 | ||
832ef1ce | 674 | for (s = head; s; s = s->next) |
6de9cd9a | 675 | { |
a8a6b603 | 676 | build_field (s, union_type, rli); |
6de9cd9a DN |
677 | |
678 | /* Link the field into the type. */ | |
a8a6b603 | 679 | *field_link = s->field; |
910ad8de | 680 | field_link = &DECL_CHAIN (s->field); |
ad6e2a18 | 681 | |
a8a6b603 TS |
682 | /* Has initial value. */ |
683 | if (s->sym->value) | |
6de9cd9a | 684 | is_init = true; |
57f0d086 JJ |
685 | |
686 | /* Has SAVE attribute. */ | |
687 | if (s->sym->attr.save) | |
688 | is_saved = true; | |
b323be61 ME |
689 | |
690 | /* Has AUTOMATIC attribute. */ | |
691 | if (s->sym->attr.automatic) | |
692 | is_auto = true; | |
6de9cd9a | 693 | } |
9d99ee7b | 694 | |
6de9cd9a DN |
695 | finish_record_layout (rli, true); |
696 | ||
9056bd70 | 697 | if (com) |
53814b8f | 698 | decl = build_common_decl (com, union_type, is_init); |
6de9cd9a | 699 | else |
b323be61 | 700 | decl = build_equiv_decl (union_type, is_init, is_saved, is_auto); |
6de9cd9a | 701 | |
5291e69a PB |
702 | if (is_init) |
703 | { | |
4038c495 | 704 | tree ctor, tmp; |
9771b263 | 705 | vec<constructor_elt, va_gc> *v = NULL; |
5291e69a | 706 | |
9d99ee7b PT |
707 | if (field != NULL_TREE && field_init != NULL_TREE) |
708 | CONSTRUCTOR_APPEND_ELT (v, field, field_init); | |
709 | else | |
710 | for (s = head; s; s = s->next) | |
711 | { | |
712 | if (s->sym->value) | |
713 | { | |
714 | /* Add the initializer for this field. */ | |
715 | tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts, | |
1d0134b3 JW |
716 | TREE_TYPE (s->field), |
717 | s->sym->attr.dimension, | |
718 | s->sym->attr.pointer | |
719 | || s->sym->attr.allocatable, false); | |
9d99ee7b PT |
720 | |
721 | CONSTRUCTOR_APPEND_ELT (v, s->field, tmp); | |
9d99ee7b PT |
722 | } |
723 | } | |
724 | ||
9771b263 | 725 | gcc_assert (!v->is_empty ()); |
4038c495 | 726 | ctor = build_constructor (union_type, v); |
5291e69a | 727 | TREE_CONSTANT (ctor) = 1; |
5291e69a PB |
728 | TREE_STATIC (ctor) = 1; |
729 | DECL_INITIAL (decl) = ctor; | |
730 | ||
c86db055 MM |
731 | if (flag_checking) |
732 | { | |
733 | tree field, value; | |
734 | unsigned HOST_WIDE_INT idx; | |
735 | FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor), idx, field, value) | |
736 | gcc_assert (TREE_CODE (field) == FIELD_DECL); | |
737 | } | |
5291e69a PB |
738 | } |
739 | ||
6de9cd9a | 740 | /* Build component reference for each variable. */ |
832ef1ce | 741 | for (s = head; s; s = next_s) |
6de9cd9a | 742 | { |
81871c2a JJ |
743 | tree var_decl; |
744 | ||
9c81750c | 745 | var_decl = build_decl (gfc_get_location (&s->sym->declared_at), |
c2255bc4 | 746 | VAR_DECL, DECL_NAME (s->field), |
81871c2a | 747 | TREE_TYPE (s->field)); |
81871c2a | 748 | TREE_STATIC (var_decl) = TREE_STATIC (decl); |
74d1a34e TK |
749 | /* Mark the variable as used in order to avoid warnings about |
750 | unused variables. */ | |
751 | TREE_USED (var_decl) = 1; | |
a64f5186 JJ |
752 | if (s->sym->attr.use_assoc) |
753 | DECL_IGNORED_P (var_decl) = 1; | |
81871c2a JJ |
754 | if (s->sym->attr.target) |
755 | TREE_ADDRESSABLE (var_decl) = 1; | |
1cc0e193 | 756 | /* Fake variables are not visible from other translation units. */ |
4d62b56a | 757 | TREE_PUBLIC (var_decl) = 0; |
92d28cbb | 758 | gfc_finish_decl_attrs (var_decl, &s->sym->attr); |
4d62b56a | 759 | |
da69cc91 GH |
760 | /* To preserve identifier names in COMMON, chain to procedure |
761 | scope unless at top level in a module definition. */ | |
762 | if (com | |
763 | && s->sym->ns->proc_name | |
764 | && s->sym->ns->proc_name->attr.flavor == FL_MODULE) | |
6c0c6ecc JD |
765 | var_decl = pushdecl_top_level (var_decl); |
766 | else | |
da69cc91 | 767 | gfc_add_decl_to_function (var_decl); |
81871c2a | 768 | |
e8426554 RB |
769 | tree comp = build3_loc (input_location, COMPONENT_REF, |
770 | TREE_TYPE (s->field), decl, s->field, NULL_TREE); | |
771 | if (TREE_THIS_VOLATILE (s->field)) | |
772 | TREE_THIS_VOLATILE (comp) = 1; | |
773 | SET_DECL_VALUE_EXPR (var_decl, comp); | |
81871c2a | 774 | DECL_HAS_VALUE_EXPR_P (var_decl) = 1; |
6c7a4dfd | 775 | GFC_DECL_COMMON_OR_EQUIV (var_decl) = 1; |
81871c2a JJ |
776 | |
777 | if (s->sym->attr.assign) | |
778 | { | |
779 | gfc_allocate_lang_decl (var_decl); | |
780 | GFC_DECL_ASSIGN (var_decl) = 1; | |
781 | GFC_DECL_STRING_LEN (var_decl) = GFC_DECL_STRING_LEN (s->field); | |
782 | GFC_DECL_ASSIGN_ADDR (var_decl) = GFC_DECL_ASSIGN_ADDR (s->field); | |
783 | } | |
784 | ||
785 | s->sym->backend_decl = var_decl; | |
6de9cd9a | 786 | |
a8a6b603 | 787 | next_s = s->next; |
cede9502 | 788 | free (s); |
6de9cd9a | 789 | } |
a8a6b603 | 790 | } |
6de9cd9a DN |
791 | |
792 | ||
793 | /* Given a symbol, find it in the current segment list. Returns NULL if | |
a8a6b603 | 794 | not found. */ |
6de9cd9a | 795 | |
a8a6b603 | 796 | static segment_info * |
6de9cd9a | 797 | find_segment_info (gfc_symbol *symbol) |
a8a6b603 | 798 | { |
6de9cd9a DN |
799 | segment_info *n; |
800 | ||
801 | for (n = current_segment; n; n = n->next) | |
5291e69a PB |
802 | { |
803 | if (n->sym == symbol) | |
804 | return n; | |
805 | } | |
6de9cd9a | 806 | |
a8a6b603 TS |
807 | return NULL; |
808 | } | |
6de9cd9a DN |
809 | |
810 | ||
6de9cd9a | 811 | /* Given an expression node, make sure it is a constant integer and return |
a8a6b603 | 812 | the mpz_t value. */ |
6de9cd9a | 813 | |
a8a6b603 TS |
814 | static mpz_t * |
815 | get_mpz (gfc_expr *e) | |
6de9cd9a | 816 | { |
a8a6b603 TS |
817 | |
818 | if (e->expr_type != EXPR_CONSTANT) | |
6de9cd9a DN |
819 | gfc_internal_error ("get_mpz(): Not an integer constant"); |
820 | ||
a8a6b603 TS |
821 | return &e->value.integer; |
822 | } | |
6de9cd9a DN |
823 | |
824 | ||
825 | /* Given an array specification and an array reference, figure out the | |
826 | array element number (zero based). Bounds and elements are guaranteed | |
827 | to be constants. If something goes wrong we generate an error and | |
a8a6b603 | 828 | return zero. */ |
6de9cd9a | 829 | |
5291e69a | 830 | static HOST_WIDE_INT |
6de9cd9a | 831 | element_number (gfc_array_ref *ar) |
a8a6b603 TS |
832 | { |
833 | mpz_t multiplier, offset, extent, n; | |
6de9cd9a | 834 | gfc_array_spec *as; |
a8a6b603 | 835 | HOST_WIDE_INT i, rank; |
6de9cd9a DN |
836 | |
837 | as = ar->as; | |
838 | rank = as->rank; | |
839 | mpz_init_set_ui (multiplier, 1); | |
840 | mpz_init_set_ui (offset, 0); | |
841 | mpz_init (extent); | |
a8a6b603 | 842 | mpz_init (n); |
6de9cd9a | 843 | |
a8a6b603 | 844 | for (i = 0; i < rank; i++) |
6de9cd9a | 845 | { |
a8a6b603 | 846 | if (ar->dimen_type[i] != DIMEN_ELEMENT) |
6de9cd9a DN |
847 | gfc_internal_error ("element_number(): Bad dimension type"); |
848 | ||
a184e37f SK |
849 | if (as && as->lower[i]) |
850 | mpz_sub (n, *get_mpz (ar->start[i]), *get_mpz (as->lower[i])); | |
851 | else | |
852 | mpz_sub_ui (n, *get_mpz (ar->start[i]), 1); | |
6de9cd9a | 853 | |
a8a6b603 TS |
854 | mpz_mul (n, n, multiplier); |
855 | mpz_add (offset, offset, n); | |
6de9cd9a | 856 | |
a184e37f SK |
857 | if (as && as->upper[i] && as->lower[i]) |
858 | { | |
859 | mpz_sub (extent, *get_mpz (as->upper[i]), *get_mpz (as->lower[i])); | |
860 | mpz_add_ui (extent, extent, 1); | |
861 | } | |
862 | else | |
863 | mpz_set_ui (extent, 0); | |
6de9cd9a DN |
864 | |
865 | if (mpz_sgn (extent) < 0) | |
866 | mpz_set_ui (extent, 0); | |
867 | ||
868 | mpz_mul (multiplier, multiplier, extent); | |
869 | } | |
870 | ||
a8a6b603 | 871 | i = mpz_get_ui (offset); |
6de9cd9a DN |
872 | |
873 | mpz_clear (multiplier); | |
874 | mpz_clear (offset); | |
875 | mpz_clear (extent); | |
a8a6b603 | 876 | mpz_clear (n); |
6de9cd9a | 877 | |
a8a6b603 | 878 | return i; |
6de9cd9a DN |
879 | } |
880 | ||
881 | ||
882 | /* Given a single element of an equivalence list, figure out the offset | |
883 | from the base symbol. For simple variables or full arrays, this is | |
884 | simply zero. For an array element we have to calculate the array | |
885 | element number and multiply by the element size. For a substring we | |
886 | have to calculate the further reference. */ | |
887 | ||
5291e69a | 888 | static HOST_WIDE_INT |
a8a6b603 | 889 | calculate_offset (gfc_expr *e) |
6de9cd9a | 890 | { |
a8a6b603 | 891 | HOST_WIDE_INT n, element_size, offset; |
6de9cd9a DN |
892 | gfc_typespec *element_type; |
893 | gfc_ref *reference; | |
894 | ||
895 | offset = 0; | |
a8a6b603 | 896 | element_type = &e->symtree->n.sym->ts; |
6de9cd9a | 897 | |
a8a6b603 | 898 | for (reference = e->ref; reference; reference = reference->next) |
6de9cd9a DN |
899 | switch (reference->type) |
900 | { | |
901 | case REF_ARRAY: | |
902 | switch (reference->u.ar.type) | |
903 | { | |
904 | case AR_FULL: | |
905 | break; | |
906 | ||
907 | case AR_ELEMENT: | |
a8a6b603 | 908 | n = element_number (&reference->u.ar); |
6de9cd9a | 909 | if (element_type->type == BT_CHARACTER) |
bc21d315 | 910 | gfc_conv_const_charlen (element_type->u.cl); |
6de9cd9a DN |
911 | element_size = |
912 | int_size_in_bytes (gfc_typenode_for_spec (element_type)); | |
a8a6b603 | 913 | offset += n * element_size; |
6de9cd9a DN |
914 | break; |
915 | ||
916 | default: | |
a8a6b603 | 917 | gfc_error ("Bad array reference at %L", &e->where); |
6de9cd9a DN |
918 | } |
919 | break; | |
920 | case REF_SUBSTRING: | |
921 | if (reference->u.ss.start != NULL) | |
922 | offset += mpz_get_ui (*get_mpz (reference->u.ss.start)) - 1; | |
923 | break; | |
924 | default: | |
5291e69a | 925 | gfc_error ("Illegal reference type at %L as EQUIVALENCE object", |
a8a6b603 TS |
926 | &e->where); |
927 | } | |
6de9cd9a DN |
928 | return offset; |
929 | } | |
930 | ||
a8a6b603 | 931 | |
5291e69a PB |
932 | /* Add a new segment_info structure to the current segment. eq1 is already |
933 | in the list, eq2 is not. */ | |
6de9cd9a DN |
934 | |
935 | static void | |
936 | new_condition (segment_info *v, gfc_equiv *eq1, gfc_equiv *eq2) | |
937 | { | |
5291e69a | 938 | HOST_WIDE_INT offset1, offset2; |
6de9cd9a | 939 | segment_info *a; |
a8a6b603 | 940 | |
6de9cd9a DN |
941 | offset1 = calculate_offset (eq1->expr); |
942 | offset2 = calculate_offset (eq2->expr); | |
943 | ||
ad6e2a18 TS |
944 | a = get_segment_info (eq2->expr->symtree->n.sym, |
945 | v->offset + offset1 - offset2); | |
6de9cd9a | 946 | |
5291e69a | 947 | current_segment = add_segments (current_segment, a); |
6de9cd9a DN |
948 | } |
949 | ||
950 | ||
951 | /* Given two equivalence structures that are both already in the list, make | |
952 | sure that this new condition is not violated, generating an error if it | |
953 | is. */ | |
954 | ||
955 | static void | |
a8a6b603 | 956 | confirm_condition (segment_info *s1, gfc_equiv *eq1, segment_info *s2, |
6de9cd9a DN |
957 | gfc_equiv *eq2) |
958 | { | |
5291e69a | 959 | HOST_WIDE_INT offset1, offset2; |
6de9cd9a DN |
960 | |
961 | offset1 = calculate_offset (eq1->expr); | |
962 | offset2 = calculate_offset (eq2->expr); | |
a8a6b603 TS |
963 | |
964 | if (s1->offset + offset1 != s2->offset + offset2) | |
fea70c99 MLI |
965 | gfc_error ("Inconsistent equivalence rules involving %qs at %L and " |
966 | "%qs at %L", s1->sym->name, &s1->sym->declared_at, | |
a8a6b603 TS |
967 | s2->sym->name, &s2->sym->declared_at); |
968 | } | |
969 | ||
6de9cd9a | 970 | |
5291e69a PB |
971 | /* Process a new equivalence condition. eq1 is know to be in segment f. |
972 | If eq2 is also present then confirm that the condition holds. | |
973 | Otherwise add a new variable to the segment list. */ | |
6de9cd9a DN |
974 | |
975 | static void | |
5291e69a | 976 | add_condition (segment_info *f, gfc_equiv *eq1, gfc_equiv *eq2) |
6de9cd9a | 977 | { |
5291e69a | 978 | segment_info *n; |
6de9cd9a | 979 | |
5291e69a | 980 | n = find_segment_info (eq2->expr->symtree->n.sym); |
6de9cd9a | 981 | |
5291e69a PB |
982 | if (n == NULL) |
983 | new_condition (f, eq1, eq2); | |
984 | else | |
985 | confirm_condition (f, eq1, n, eq2); | |
6de9cd9a DN |
986 | } |
987 | ||
b323be61 ME |
988 | static void |
989 | accumulate_equivalence_attributes (symbol_attribute *dummy_symbol, gfc_equiv *e) | |
990 | { | |
991 | symbol_attribute attr = e->expr->symtree->n.sym->attr; | |
992 | ||
993 | dummy_symbol->dummy |= attr.dummy; | |
994 | dummy_symbol->pointer |= attr.pointer; | |
995 | dummy_symbol->target |= attr.target; | |
996 | dummy_symbol->external |= attr.external; | |
997 | dummy_symbol->intrinsic |= attr.intrinsic; | |
998 | dummy_symbol->allocatable |= attr.allocatable; | |
999 | dummy_symbol->elemental |= attr.elemental; | |
1000 | dummy_symbol->recursive |= attr.recursive; | |
1001 | dummy_symbol->in_common |= attr.in_common; | |
1002 | dummy_symbol->result |= attr.result; | |
1003 | dummy_symbol->in_namelist |= attr.in_namelist; | |
1004 | dummy_symbol->optional |= attr.optional; | |
1005 | dummy_symbol->entry |= attr.entry; | |
1006 | dummy_symbol->function |= attr.function; | |
1007 | dummy_symbol->subroutine |= attr.subroutine; | |
1008 | dummy_symbol->dimension |= attr.dimension; | |
1009 | dummy_symbol->in_equivalence |= attr.in_equivalence; | |
1010 | dummy_symbol->use_assoc |= attr.use_assoc; | |
1011 | dummy_symbol->cray_pointer |= attr.cray_pointer; | |
1012 | dummy_symbol->cray_pointee |= attr.cray_pointee; | |
1013 | dummy_symbol->data |= attr.data; | |
1014 | dummy_symbol->value |= attr.value; | |
1015 | dummy_symbol->volatile_ |= attr.volatile_; | |
1016 | dummy_symbol->is_protected |= attr.is_protected; | |
1017 | dummy_symbol->is_bind_c |= attr.is_bind_c; | |
1018 | dummy_symbol->procedure |= attr.procedure; | |
1019 | dummy_symbol->proc_pointer |= attr.proc_pointer; | |
1020 | dummy_symbol->abstract |= attr.abstract; | |
1021 | dummy_symbol->asynchronous |= attr.asynchronous; | |
1022 | dummy_symbol->codimension |= attr.codimension; | |
1023 | dummy_symbol->contiguous |= attr.contiguous; | |
1024 | dummy_symbol->generic |= attr.generic; | |
1025 | dummy_symbol->automatic |= attr.automatic; | |
1026 | dummy_symbol->threadprivate |= attr.threadprivate; | |
1027 | dummy_symbol->omp_declare_target |= attr.omp_declare_target; | |
1028 | dummy_symbol->omp_declare_target_link |= attr.omp_declare_target_link; | |
1029 | dummy_symbol->oacc_declare_copyin |= attr.oacc_declare_copyin; | |
1030 | dummy_symbol->oacc_declare_create |= attr.oacc_declare_create; | |
1031 | dummy_symbol->oacc_declare_deviceptr |= attr.oacc_declare_deviceptr; | |
1032 | dummy_symbol->oacc_declare_device_resident | |
1033 | |= attr.oacc_declare_device_resident; | |
1034 | ||
1035 | /* Not strictly correct, but probably close enough. */ | |
1036 | if (attr.save > dummy_symbol->save) | |
1037 | dummy_symbol->save = attr.save; | |
1038 | if (attr.access > dummy_symbol->access) | |
1039 | dummy_symbol->access = attr.access; | |
1040 | } | |
6de9cd9a | 1041 | |
5291e69a | 1042 | /* Given a segment element, search through the equivalence lists for unused |
30aabb86 PT |
1043 | conditions that involve the symbol. Add these rules to the segment. */ |
1044 | ||
5291e69a | 1045 | static bool |
a8a6b603 | 1046 | find_equivalence (segment_info *n) |
6de9cd9a | 1047 | { |
30aabb86 | 1048 | gfc_equiv *e1, *e2, *eq; |
5291e69a | 1049 | bool found; |
30aabb86 | 1050 | |
54cc21ea | 1051 | found = false; |
30aabb86 | 1052 | |
a8a6b603 | 1053 | for (e1 = n->sym->ns->equiv; e1; e1 = e1->next) |
5291e69a | 1054 | { |
30aabb86 | 1055 | eq = NULL; |
5291e69a | 1056 | |
30aabb86 | 1057 | /* Search the equivalence list, including the root (first) element |
b323be61 ME |
1058 | for the symbol that owns the segment. */ |
1059 | symbol_attribute dummy_symbol; | |
1060 | memset (&dummy_symbol, 0, sizeof (dummy_symbol)); | |
30aabb86 PT |
1061 | for (e2 = e1; e2; e2 = e2->eq) |
1062 | { | |
b323be61 | 1063 | accumulate_equivalence_attributes (&dummy_symbol, e2); |
30aabb86 | 1064 | if (!e2->used && e2->expr->symtree->n.sym == n->sym) |
5291e69a | 1065 | { |
a8a6b603 | 1066 | eq = e2; |
30aabb86 | 1067 | break; |
5291e69a | 1068 | } |
30aabb86 PT |
1069 | } |
1070 | ||
b323be61 ME |
1071 | gfc_check_conflict (&dummy_symbol, e1->expr->symtree->name, &e1->expr->where); |
1072 | ||
30aabb86 PT |
1073 | /* Go to the next root element. */ |
1074 | if (eq == NULL) | |
1075 | continue; | |
1076 | ||
1077 | eq->used = 1; | |
1078 | ||
1079 | /* Now traverse the equivalence list matching the offsets. */ | |
1080 | for (e2 = e1; e2; e2 = e2->eq) | |
1081 | { | |
1082 | if (!e2->used && e2 != eq) | |
5291e69a | 1083 | { |
30aabb86 PT |
1084 | add_condition (n, eq, e2); |
1085 | e2->used = 1; | |
54cc21ea | 1086 | found = true; |
5291e69a PB |
1087 | } |
1088 | } | |
1089 | } | |
1090 | return found; | |
6de9cd9a DN |
1091 | } |
1092 | ||
a8a6b603 | 1093 | |
66e4ab31 | 1094 | /* Add all symbols equivalenced within a segment. We need to scan the |
8a0b57b3 PT |
1095 | segment list multiple times to include indirect equivalences. Since |
1096 | a new segment_info can inserted at the beginning of the segment list, | |
1097 | depending on its offset, we have to force a final pass through the | |
df2fba9e | 1098 | loop by demanding that completion sees a pass with no matches; i.e., |
8a0b57b3 | 1099 | all symbols with equiv_built set and no new equivalences found. */ |
6de9cd9a | 1100 | |
5291e69a | 1101 | static void |
a3122424 | 1102 | add_equivalences (bool *saw_equiv) |
6de9cd9a | 1103 | { |
6de9cd9a | 1104 | segment_info *f; |
54cc21ea | 1105 | bool more = true; |
6de9cd9a | 1106 | |
5291e69a | 1107 | while (more) |
6de9cd9a | 1108 | { |
54cc21ea | 1109 | more = false; |
5291e69a PB |
1110 | for (f = current_segment; f; f = f->next) |
1111 | { | |
1112 | if (!f->sym->equiv_built) | |
1113 | { | |
1114 | f->sym->equiv_built = 1; | |
8ba6ea87 | 1115 | bool seen_one = find_equivalence (f); |
8a0b57b3 PT |
1116 | if (seen_one) |
1117 | { | |
1118 | *saw_equiv = true; | |
1119 | more = true; | |
1120 | } | |
5291e69a PB |
1121 | } |
1122 | } | |
6de9cd9a | 1123 | } |
61321991 PT |
1124 | |
1125 | /* Add a copy of this segment list to the namespace. */ | |
1126 | copy_equiv_list_to_ns (current_segment); | |
6de9cd9a | 1127 | } |
a8a6b603 TS |
1128 | |
1129 | ||
43a5ef69 | 1130 | /* Returns the offset necessary to properly align the current equivalence. |
832ef1ce PB |
1131 | Sets *palign to the required alignment. */ |
1132 | ||
1133 | static HOST_WIDE_INT | |
66e4ab31 | 1134 | align_segment (unsigned HOST_WIDE_INT *palign) |
832ef1ce PB |
1135 | { |
1136 | segment_info *s; | |
1137 | unsigned HOST_WIDE_INT offset; | |
1138 | unsigned HOST_WIDE_INT max_align; | |
1139 | unsigned HOST_WIDE_INT this_align; | |
1140 | unsigned HOST_WIDE_INT this_offset; | |
1141 | ||
1142 | max_align = 1; | |
1143 | offset = 0; | |
1144 | for (s = current_segment; s; s = s->next) | |
1145 | { | |
1146 | this_align = TYPE_ALIGN_UNIT (s->field); | |
1147 | if (s->offset & (this_align - 1)) | |
1148 | { | |
1149 | /* Field is misaligned. */ | |
1150 | this_offset = this_align - ((s->offset + offset) & (this_align - 1)); | |
1151 | if (this_offset & (max_align - 1)) | |
1152 | { | |
1153 | /* Aligning this field would misalign a previous field. */ | |
a4d9b221 | 1154 | gfc_error ("The equivalence set for variable %qs " |
eb6d74fa | 1155 | "declared at %L violates alignment requirements", |
832ef1ce PB |
1156 | s->sym->name, &s->sym->declared_at); |
1157 | } | |
1158 | offset += this_offset; | |
1159 | } | |
1160 | max_align = this_align; | |
1161 | } | |
1162 | if (palign) | |
1163 | *palign = max_align; | |
1164 | return offset; | |
1165 | } | |
1166 | ||
1167 | ||
1168 | /* Adjust segment offsets by the given amount. */ | |
a8a6b603 | 1169 | |
6de9cd9a | 1170 | static void |
66e4ab31 | 1171 | apply_segment_offset (segment_info *s, HOST_WIDE_INT offset) |
6de9cd9a | 1172 | { |
832ef1ce PB |
1173 | for (; s; s = s->next) |
1174 | s->offset += offset; | |
1175 | } | |
1176 | ||
1177 | ||
1178 | /* Lay out a symbol in a common block. If the symbol has already been seen | |
1179 | then check the location is consistent. Otherwise create segments | |
1180 | for that symbol and all the symbols equivalenced with it. */ | |
1181 | ||
1182 | /* Translate a single common block. */ | |
1183 | ||
1184 | static void | |
1185 | translate_common (gfc_common_head *common, gfc_symbol *var_list) | |
1186 | { | |
1187 | gfc_symbol *sym; | |
1188 | segment_info *s; | |
1189 | segment_info *common_segment; | |
1190 | HOST_WIDE_INT offset; | |
1191 | HOST_WIDE_INT current_offset; | |
1192 | unsigned HOST_WIDE_INT align; | |
a3122424 | 1193 | bool saw_equiv; |
832ef1ce PB |
1194 | |
1195 | common_segment = NULL; | |
f613cea7 | 1196 | offset = 0; |
832ef1ce | 1197 | current_offset = 0; |
f613cea7 | 1198 | align = 1; |
a3122424 | 1199 | saw_equiv = false; |
832ef1ce PB |
1200 | |
1201 | /* Add symbols to the segment. */ | |
1202 | for (sym = var_list; sym; sym = sym->common_next) | |
1203 | { | |
30aabb86 PT |
1204 | current_segment = common_segment; |
1205 | s = find_segment_info (sym); | |
832ef1ce | 1206 | |
30aabb86 PT |
1207 | /* Symbol has already been added via an equivalence. Multiple |
1208 | use associations of the same common block result in equiv_built | |
1209 | being set but no information about the symbol in the segment. */ | |
1210 | if (s && sym->equiv_built) | |
1211 | { | |
832ef1ce PB |
1212 | /* Ensure the current location is properly aligned. */ |
1213 | align = TYPE_ALIGN_UNIT (s->field); | |
1214 | current_offset = (current_offset + align - 1) &~ (align - 1); | |
1215 | ||
1216 | /* Verify that it ended up where we expect it. */ | |
1217 | if (s->offset != current_offset) | |
1218 | { | |
a4d9b221 TB |
1219 | gfc_error ("Equivalence for %qs does not match ordering of " |
1220 | "COMMON %qs at %L", sym->name, | |
832ef1ce PB |
1221 | common->name, &common->where); |
1222 | } | |
1223 | } | |
1224 | else | |
1225 | { | |
1226 | /* A symbol we haven't seen before. */ | |
1227 | s = current_segment = get_segment_info (sym, current_offset); | |
a8a6b603 | 1228 | |
832ef1ce PB |
1229 | /* Add all objects directly or indirectly equivalenced with this |
1230 | symbol. */ | |
a3122424 | 1231 | add_equivalences (&saw_equiv); |
ad6e2a18 | 1232 | |
832ef1ce | 1233 | if (current_segment->offset < 0) |
a4d9b221 TB |
1234 | gfc_error ("The equivalence set for %qs cause an invalid " |
1235 | "extension to COMMON %qs at %L", sym->name, | |
832ef1ce | 1236 | common->name, &common->where); |
6de9cd9a | 1237 | |
c61819ff | 1238 | if (flag_align_commons) |
f613cea7 | 1239 | offset = align_segment (&align); |
6de9cd9a | 1240 | |
7de61dc6 | 1241 | if (offset) |
832ef1ce PB |
1242 | { |
1243 | /* The required offset conflicts with previous alignment | |
1244 | requirements. Insert padding immediately before this | |
1245 | segment. */ | |
73e42eef | 1246 | if (warn_align_commons) |
f613cea7 JW |
1247 | { |
1248 | if (strcmp (common->name, BLANK_COMMON_NAME)) | |
28ce22e6 | 1249 | gfc_warning (OPT_Walign_commons, |
db30e21c | 1250 | "Padding of %d bytes required before %qs in " |
48749dbc | 1251 | "COMMON %qs at %L; reorder elements or use " |
a3f9f006 | 1252 | "%<-fno-align-commons%>", (int)offset, |
f613cea7 JW |
1253 | s->sym->name, common->name, &common->where); |
1254 | else | |
28ce22e6 | 1255 | gfc_warning (OPT_Walign_commons, |
db30e21c | 1256 | "Padding of %d bytes required before %qs in " |
f613cea7 | 1257 | "COMMON at %L; reorder elements or use " |
a3f9f006 | 1258 | "%<-fno-align-commons%>", (int)offset, |
f613cea7 JW |
1259 | s->sym->name, &common->where); |
1260 | } | |
832ef1ce | 1261 | } |
6de9cd9a | 1262 | |
832ef1ce PB |
1263 | /* Apply the offset to the new segments. */ |
1264 | apply_segment_offset (current_segment, offset); | |
1265 | current_offset += offset; | |
832ef1ce PB |
1266 | |
1267 | /* Add the new segments to the common block. */ | |
1268 | common_segment = add_segments (common_segment, current_segment); | |
1269 | } | |
1270 | ||
1271 | /* The offset of the next common variable. */ | |
1272 | current_offset += s->length; | |
1273 | } | |
1274 | ||
b8ea6dbc PT |
1275 | if (common_segment == NULL) |
1276 | { | |
811582ec | 1277 | gfc_error ("COMMON %qs at %L does not exist", |
b8ea6dbc PT |
1278 | common->name, &common->where); |
1279 | return; | |
1280 | } | |
1281 | ||
73e42eef | 1282 | if (common_segment->offset != 0 && warn_align_commons) |
832ef1ce | 1283 | { |
f613cea7 | 1284 | if (strcmp (common->name, BLANK_COMMON_NAME)) |
48749dbc MLI |
1285 | gfc_warning (OPT_Walign_commons, |
1286 | "COMMON %qs at %L requires %d bytes of padding; " | |
1287 | "reorder elements or use %<-fno-align-commons%>", | |
f613cea7 JW |
1288 | common->name, &common->where, (int)common_segment->offset); |
1289 | else | |
48749dbc MLI |
1290 | gfc_warning (OPT_Walign_commons, |
1291 | "COMMON at %L requires %d bytes of padding; " | |
1292 | "reorder elements or use %<-fno-align-commons%>", | |
f613cea7 | 1293 | &common->where, (int)common_segment->offset); |
832ef1ce PB |
1294 | } |
1295 | ||
a3122424 | 1296 | create_common (common, common_segment, saw_equiv); |
6de9cd9a DN |
1297 | } |
1298 | ||
1299 | ||
1300 | /* Create a new block for each merged equivalence list. */ | |
1301 | ||
1302 | static void | |
1303 | finish_equivalences (gfc_namespace *ns) | |
1304 | { | |
1305 | gfc_equiv *z, *y; | |
1306 | gfc_symbol *sym; | |
30aabb86 | 1307 | gfc_common_head * c; |
36c028f6 PB |
1308 | HOST_WIDE_INT offset; |
1309 | unsigned HOST_WIDE_INT align; | |
a3122424 | 1310 | bool dummy; |
6de9cd9a DN |
1311 | |
1312 | for (z = ns->equiv; z; z = z->next) | |
a8a6b603 | 1313 | for (y = z->eq; y; y = y->eq) |
6de9cd9a | 1314 | { |
a8a6b603 TS |
1315 | if (y->used) |
1316 | continue; | |
6de9cd9a | 1317 | sym = z->expr->symtree->n.sym; |
ad6e2a18 | 1318 | current_segment = get_segment_info (sym, 0); |
6de9cd9a | 1319 | |
66e4ab31 SK |
1320 | /* All objects directly or indirectly equivalenced with this |
1321 | symbol. */ | |
a3122424 | 1322 | add_equivalences (&dummy); |
6de9cd9a | 1323 | |
36c028f6 PB |
1324 | /* Align the block. */ |
1325 | offset = align_segment (&align); | |
832ef1ce | 1326 | |
36c028f6 PB |
1327 | /* Ensure all offsets are positive. */ |
1328 | offset -= current_segment->offset & ~(align - 1); | |
6de9cd9a | 1329 | |
36c028f6 | 1330 | apply_segment_offset (current_segment, offset); |
6de9cd9a | 1331 | |
66e4ab31 SK |
1332 | /* Create the decl. If this is a module equivalence, it has a |
1333 | unique name, pointed to by z->module. This is written to a | |
1334 | gfc_common_header to push create_common into using | |
1335 | build_common_decl, so that the equivalence appears as an | |
1336 | external symbol. Otherwise, a local declaration is built using | |
1337 | build_equiv_decl. */ | |
30aabb86 PT |
1338 | if (z->module) |
1339 | { | |
1340 | c = gfc_get_common_head (); | |
1341 | /* We've lost the real location, so use the location of the | |
91c9fb42 SK |
1342 | enclosing procedure. If we're in a BLOCK DATA block, then |
1343 | use the location in the sym_root. */ | |
1344 | if (ns->proc_name) | |
1345 | c->where = ns->proc_name->declared_at; | |
1346 | else if (ns->is_block_data) | |
1347 | c->where = ns->sym_root->n.sym->declared_at; | |
bcd96c9c HA |
1348 | |
1349 | size_t len = strlen (z->module); | |
1350 | gcc_assert (len < sizeof (c->name)); | |
1351 | memcpy (c->name, z->module, len); | |
1352 | c->name[len] = '\0'; | |
30aabb86 PT |
1353 | } |
1354 | else | |
1355 | c = NULL; | |
1356 | ||
1357 | create_common (c, current_segment, true); | |
6de9cd9a DN |
1358 | break; |
1359 | } | |
1360 | } | |
1361 | ||
1362 | ||
6de9cd9a DN |
1363 | /* Work function for translating a named common block. */ |
1364 | ||
1365 | static void | |
9056bd70 | 1366 | named_common (gfc_symtree *st) |
6de9cd9a | 1367 | { |
53814b8f | 1368 | translate_common (st->n.common, st->n.common->head); |
6de9cd9a DN |
1369 | } |
1370 | ||
1371 | ||
1372 | /* Translate the common blocks in a namespace. Unlike other variables, | |
1373 | these have to be created before code, because the backend_decl depends | |
1374 | on the rest of the common block. */ | |
a8a6b603 TS |
1375 | |
1376 | void | |
6de9cd9a DN |
1377 | gfc_trans_common (gfc_namespace *ns) |
1378 | { | |
9056bd70 | 1379 | gfc_common_head *c; |
6de9cd9a DN |
1380 | |
1381 | /* Translate the blank common block. */ | |
9056bd70 | 1382 | if (ns->blank_common.head != NULL) |
6de9cd9a | 1383 | { |
9056bd70 | 1384 | c = gfc_get_common_head (); |
f613cea7 | 1385 | c->where = ns->blank_common.head->common_head->where; |
53814b8f TS |
1386 | strcpy (c->name, BLANK_COMMON_NAME); |
1387 | translate_common (c, ns->blank_common.head); | |
6de9cd9a | 1388 | } |
41433497 | 1389 | |
6de9cd9a | 1390 | /* Translate all named common blocks. */ |
a8a6b603 | 1391 | gfc_traverse_symtree (ns->common_root, named_common); |
6de9cd9a | 1392 | |
6de9cd9a DN |
1393 | /* Translate local equivalence. */ |
1394 | finish_equivalences (ns); | |
613e2ac8 PT |
1395 | |
1396 | /* Commit the newly created symbols for common blocks and module | |
1397 | equivalences. */ | |
1398 | gfc_commit_symbols (); | |
6de9cd9a | 1399 | } |