1 | /* Common block and equivalence list handling |
2 | Copyright (C) 2000-2023 Free Software Foundation, Inc. |
3 | Contributed by Canqun Yang <canqun@nudt.edu.cn> |
4 | |
5 | This file is part of GCC. |
6 | |
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 |
9 | Software Foundation; either version 3, or (at your option) any later |
10 | version. |
11 | |
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. |
16 | |
17 | You should have received a copy of the GNU General Public License |
18 | along with GCC; see the file COPYING3. If not see |
19 | <http://www.gnu.org/licenses/>. */ |
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 |
25 | equivalence variables. Equivalenced variables that are not in a |
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 | |
84 | Each segment is described by a chain of segment_info structures. Each |
85 | segment_info structure describes the extents of a single variable within |
86 | the segment. This list is maintained in the order the elements are |
87 | positioned within the segment. If two elements have the same starting |
88 | offset the smaller will come first. If they also have the same size their |
89 | ordering is undefined. |
90 | |
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" |
96 | #define INCLUDE_MAP |
97 | #include "system.h" |
98 | #include "coretypes.h" |
99 | #include "tm.h" |
100 | #include "tree.h" |
101 | #include "gfortran.h" |
102 | #include "trans.h" |
103 | #include "stringpool.h" |
104 | #include "fold-const.h" |
105 | #include "stor-layout.h" |
106 | #include "varasm.h" |
107 | #include "trans-types.h" |
108 | #include "trans-const.h" |
109 | #include "target-memory.h" |
110 | |
111 | |
112 | /* Holds a single variable in an equivalence set. */ |
113 | typedef struct segment_info |
114 | { |
115 | gfc_symbol *sym; |
116 | HOST_WIDE_INT offset; |
117 | HOST_WIDE_INT length; |
118 | /* This will contain the field type until the field is created. */ |
119 | tree field; |
120 | struct segment_info *next; |
121 | } segment_info; |
122 | |
123 | static segment_info * current_segment; |
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; |
128 | |
129 | |
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) |
139 | gfc_conv_const_charlen (sym->ts.u.cl); |
140 | |
141 | /* Create the segment_info and fill it in. */ |
142 | s = XCNEW (segment_info); |
143 | s->sym = sym; |
144 | /* We will use this type when building the segment aggregate type. */ |
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 | |
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 | |
164 | l = XCNEW (gfc_equiv_list); |
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 | { |
171 | s = XCNEW (gfc_equiv_info); |
172 | s->next = l->equiv; |
173 | l->equiv = s; |
174 | s->sym = f->sym; |
175 | s->offset = f->offset; |
176 | s->length = f->length; |
177 | } |
178 | } |
179 | |
180 | |
181 | /* Add combine segment V and segment LIST. */ |
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; |
189 | |
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 | } |
219 | |
220 | return list; |
221 | } |
222 | |
223 | |
224 | /* Construct mangled common block name from symbol name. */ |
225 | |
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 | |
241 | static tree |
242 | gfc_sym_mangled_common_id (gfc_common_head *com) |
243 | { |
244 | int has_underscore; |
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]; |
248 | |
249 | /* Get the name out of the common block pointer. */ |
250 | size_t len = strlen (s: com->name); |
251 | gcc_assert (len < sizeof (name)); |
252 | strcpy (dest: name, src: com->name); |
253 | |
254 | /* If we're suppose to do a bind(c). */ |
255 | if (com->is_bind_c == 1 && com->binding_label) |
256 | return get_identifier (com->binding_label); |
257 | |
258 | if (strcmp (s1: name, BLANK_COMMON_NAME) == 0) |
259 | return get_identifier (name); |
260 | |
261 | if (flag_underscoring) |
262 | { |
263 | has_underscore = strchr (s: name, c: '_') != 0; |
264 | if (flag_second_underscore && has_underscore) |
265 | snprintf (s: mangled_name, maxlen: sizeof mangled_name, format: "%s__" , name); |
266 | else |
267 | snprintf (s: mangled_name, maxlen: sizeof mangled_name, format: "%s_" , name); |
268 | |
269 | return get_identifier (mangled_name); |
270 | } |
271 | else |
272 | return get_identifier (name); |
273 | } |
274 | |
275 | |
276 | /* Build a field declaration for a common variable or a local equivalence |
277 | object. */ |
278 | |
279 | static void |
280 | build_field (segment_info *h, tree union_type, record_layout_info rli) |
281 | { |
282 | tree field; |
283 | tree name; |
284 | HOST_WIDE_INT offset = h->offset; |
285 | unsigned HOST_WIDE_INT desired_align, known_align; |
286 | |
287 | name = get_identifier (h->sym->name); |
288 | field = build_decl (gfc_get_location (&h->sym->declared_at), |
289 | FIELD_DECL, name, h->field); |
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))); |
307 | /* If this field is assigned to a label, we create another two variables. |
308 | One will hold the address of target label or format label. The other will |
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; |
321 | DECL_INITIAL (len) = build_int_cst (gfc_charlen_type_node, -2); |
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 | |
328 | /* If this field is volatile, mark it. */ |
329 | if (h->sym->attr.volatile_) |
330 | { |
331 | tree new_type; |
332 | TREE_THIS_VOLATILE (field) = 1; |
333 | TREE_SIDE_EFFECTS (field) = 1; |
334 | new_type = build_qualified_type (TREE_TYPE (field), TYPE_QUAL_VOLATILE); |
335 | TREE_TYPE (field) = new_type; |
336 | } |
337 | |
338 | h->field = field; |
339 | } |
340 | |
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 |
348 | |
349 | /* Get storage for local equivalence. */ |
350 | |
351 | static tree |
352 | build_equiv_decl (tree union_type, bool is_init, bool is_saved, bool is_auto) |
353 | { |
354 | tree decl; |
355 | char name[18]; |
356 | static int serial = 0; |
357 | |
358 | if (is_init) |
359 | { |
360 | decl = gfc_create_var (union_type, "equiv" ); |
361 | TREE_STATIC (decl) = 1; |
362 | GFC_DECL_COMMON_OR_EQUIV (decl) = 1; |
363 | return decl; |
364 | } |
365 | |
366 | snprintf (s: name, maxlen: sizeof (name), GFC_EQUIV_FMT, serial++); |
367 | decl = build_decl (input_location, |
368 | VAR_DECL, get_identifier (name), union_type); |
369 | DECL_ARTIFICIAL (decl) = 1; |
370 | DECL_IGNORED_P (decl) = 1; |
371 | |
372 | if (!is_auto && (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)) |
373 | || is_saved)) |
374 | TREE_STATIC (decl) = 1; |
375 | |
376 | TREE_ADDRESSABLE (decl) = 1; |
377 | TREE_USED (decl) = 1; |
378 | GFC_DECL_COMMON_OR_EQUIV (decl) = 1; |
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 | |
384 | gfc_add_decl_to_function (decl); |
385 | |
386 | return decl; |
387 | } |
388 | |
389 | |
390 | /* Get storage for common block. */ |
391 | |
392 | static tree |
393 | build_common_decl (gfc_common_head *com, tree union_type, bool is_init) |
394 | { |
395 | tree decl, identifier; |
396 | |
397 | identifier = gfc_sym_mangled_common_id (com); |
398 | decl = gfc_map_of_all_commons.count(x: identifier) |
399 | ? gfc_map_of_all_commons[identifier] : NULL_TREE; |
400 | |
401 | /* Update the size of this common block as needed. */ |
402 | if (decl != NULL_TREE) |
403 | { |
404 | tree size = TYPE_SIZE_UNIT (union_type); |
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 (s1: com->name, BLANK_COMMON_NAME)) |
411 | gfc_warning (opt: 0, "Named COMMON block %qs at %L shall be of the " |
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 | |
417 | if (tree_int_cst_lt (DECL_SIZE_UNIT (decl), t2: size)) |
418 | { |
419 | DECL_SIZE (decl) = TYPE_SIZE (union_type); |
420 | DECL_SIZE_UNIT (decl) = size; |
421 | SET_DECL_MODE (decl, TYPE_MODE (union_type)); |
422 | TREE_TYPE (decl) = union_type; |
423 | layout_decl (decl, 0); |
424 | } |
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 | { |
436 | tree omp_clauses = NULL_TREE; |
437 | |
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 | |
447 | TREE_PUBLIC (decl) = 1; |
448 | TREE_STATIC (decl) = 1; |
449 | DECL_IGNORED_P (decl) = 1; |
450 | if (!com->is_bind_c) |
451 | SET_DECL_ALIGN (decl, BIGGEST_ALIGNMENT); |
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)); |
461 | if (DECL_CHAIN (field) == NULL_TREE) |
462 | SET_DECL_ALIGN (decl, TYPE_ALIGN (TREE_TYPE (field))); |
463 | } |
464 | DECL_USER_ALIGN (decl) = 0; |
465 | GFC_DECL_COMMON_OR_EQUIV (decl) = 1; |
466 | |
467 | gfc_set_decl_location (decl, &com->where); |
468 | |
469 | if (com->threadprivate) |
470 | set_decl_tls_model (decl, decl_default_tls_model (decl)); |
471 | |
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 | } |
491 | if (com->omp_declare_target_link) |
492 | DECL_ATTRIBUTES (decl) |
493 | = tree_cons (get_identifier ("omp declare target link" ), |
494 | omp_clauses, DECL_ATTRIBUTES (decl)); |
495 | else if (com->omp_declare_target) |
496 | DECL_ATTRIBUTES (decl) |
497 | = tree_cons (get_identifier ("omp declare target" ), |
498 | omp_clauses, DECL_ATTRIBUTES (decl)); |
499 | |
500 | /* Place the back end declaration for this common block in |
501 | GLOBAL_BINDING_LEVEL. */ |
502 | gfc_map_of_all_commons[identifier] = pushdecl_top_level (decl); |
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; |
511 | } |
512 | else |
513 | { |
514 | DECL_INITIAL (decl) = error_mark_node; |
515 | DECL_COMMON (decl) = 0; |
516 | DECL_DEFER_OUTPUT (decl) = 0; |
517 | } |
518 | return decl; |
519 | } |
520 | |
521 | |
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; |
538 | vec<constructor_elt, va_gc> *v = NULL; |
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. */ |
562 | data = XCNEWVEC (unsigned char, (size_t)length); |
563 | chk = XCNEWVEC (unsigned char, (size_t)length); |
564 | |
565 | /* TODO - change this when default initialization is implemented. */ |
566 | memset (s: data, c: '\0', n: (size_t)length); |
567 | memset (s: chk, c: '\0', n: (size_t)length); |
568 | for (s = head; s; s = s->next) |
569 | if (s->sym->value) |
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, |
575 | &data[s->offset], |
576 | &chk[s->offset], |
577 | (size_t)s->length); |
578 | } |
579 | |
580 | for (i = 0; i < length; i++) |
581 | CONSTRUCTOR_APPEND_ELT (v, NULL, build_int_cst (type, data[i])); |
582 | |
583 | free (ptr: data); |
584 | free (ptr: chk); |
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); |
593 | field = build_decl (gfc_get_location (&gfc_current_locus), |
594 | FIELD_DECL, NULL_TREE, tmp); |
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; |
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 | |
630 | /* Declare memory for the common block or local equivalence, and create |
631 | backend declarations for all of the elements. */ |
632 | |
633 | static void |
634 | create_common (gfc_common_head *com, segment_info *head, bool saw_equiv) |
635 | { |
636 | segment_info *s, *next_s; |
637 | tree union_type; |
638 | tree *field_link; |
639 | tree field; |
640 | tree field_init = NULL_TREE; |
641 | record_layout_info rli; |
642 | tree decl; |
643 | bool is_init = false; |
644 | bool is_saved = false; |
645 | bool is_auto = false; |
646 | |
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 | |
657 | rli = start_record_layout (union_type); |
658 | field_link = &TYPE_FIELDS (union_type); |
659 | |
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: &field_init, rli); |
664 | else |
665 | field = NULL_TREE; |
666 | |
667 | if (field != NULL_TREE) |
668 | { |
669 | is_init = true; |
670 | *field_link = field; |
671 | field_link = &DECL_CHAIN (field); |
672 | } |
673 | |
674 | for (s = head; s; s = s->next) |
675 | { |
676 | build_field (h: s, union_type, rli); |
677 | |
678 | /* Link the field into the type. */ |
679 | *field_link = s->field; |
680 | field_link = &DECL_CHAIN (s->field); |
681 | |
682 | /* Has initial value. */ |
683 | if (s->sym->value) |
684 | is_init = true; |
685 | |
686 | /* Has SAVE attribute. */ |
687 | if (s->sym->attr.save) |
688 | is_saved = true; |
689 | |
690 | /* Has AUTOMATIC attribute. */ |
691 | if (s->sym->attr.automatic) |
692 | is_auto = true; |
693 | } |
694 | |
695 | finish_record_layout (rli, true); |
696 | |
697 | if (com) |
698 | decl = build_common_decl (com, union_type, is_init); |
699 | else |
700 | decl = build_equiv_decl (union_type, is_init, is_saved, is_auto); |
701 | |
702 | if (is_init) |
703 | { |
704 | tree ctor, tmp; |
705 | vec<constructor_elt, va_gc> *v = NULL; |
706 | |
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, |
716 | TREE_TYPE (s->field), |
717 | s->sym->attr.dimension, |
718 | s->sym->attr.pointer |
719 | || s->sym->attr.allocatable, false); |
720 | |
721 | CONSTRUCTOR_APPEND_ELT (v, s->field, tmp); |
722 | } |
723 | } |
724 | |
725 | gcc_assert (!v->is_empty ()); |
726 | ctor = build_constructor (union_type, v); |
727 | TREE_CONSTANT (ctor) = 1; |
728 | TREE_STATIC (ctor) = 1; |
729 | DECL_INITIAL (decl) = ctor; |
730 | |
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 | } |
738 | } |
739 | |
740 | /* Build component reference for each variable. */ |
741 | for (s = head; s; s = next_s) |
742 | { |
743 | tree var_decl; |
744 | |
745 | var_decl = build_decl (gfc_get_location (&s->sym->declared_at), |
746 | VAR_DECL, DECL_NAME (s->field), |
747 | TREE_TYPE (s->field)); |
748 | TREE_STATIC (var_decl) = TREE_STATIC (decl); |
749 | /* Mark the variable as used in order to avoid warnings about |
750 | unused variables. */ |
751 | TREE_USED (var_decl) = 1; |
752 | if (s->sym->attr.use_assoc) |
753 | DECL_IGNORED_P (var_decl) = 1; |
754 | if (s->sym->attr.target) |
755 | TREE_ADDRESSABLE (var_decl) = 1; |
756 | /* Fake variables are not visible from other translation units. */ |
757 | TREE_PUBLIC (var_decl) = 0; |
758 | gfc_finish_decl_attrs (var_decl, &s->sym->attr); |
759 | |
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) |
765 | var_decl = pushdecl_top_level (var_decl); |
766 | else |
767 | gfc_add_decl_to_function (var_decl); |
768 | |
769 | tree comp = build3_loc (loc: input_location, code: COMPONENT_REF, |
770 | TREE_TYPE (s->field), arg0: decl, arg1: 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); |
774 | DECL_HAS_VALUE_EXPR_P (var_decl) = 1; |
775 | GFC_DECL_COMMON_OR_EQUIV (var_decl) = 1; |
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; |
786 | |
787 | next_s = s->next; |
788 | free (ptr: s); |
789 | } |
790 | } |
791 | |
792 | |
793 | /* Given a symbol, find it in the current segment list. Returns NULL if |
794 | not found. */ |
795 | |
796 | static segment_info * |
797 | find_segment_info (gfc_symbol *symbol) |
798 | { |
799 | segment_info *n; |
800 | |
801 | for (n = current_segment; n; n = n->next) |
802 | { |
803 | if (n->sym == symbol) |
804 | return n; |
805 | } |
806 | |
807 | return NULL; |
808 | } |
809 | |
810 | |
811 | /* Given an expression node, make sure it is a constant integer and return |
812 | the mpz_t value. */ |
813 | |
814 | static mpz_t * |
815 | get_mpz (gfc_expr *e) |
816 | { |
817 | |
818 | if (e->expr_type != EXPR_CONSTANT) |
819 | gfc_internal_error ("get_mpz(): Not an integer constant" ); |
820 | |
821 | return &e->value.integer; |
822 | } |
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 |
828 | return zero. */ |
829 | |
830 | static HOST_WIDE_INT |
831 | element_number (gfc_array_ref *ar) |
832 | { |
833 | mpz_t multiplier, offset, extent, n; |
834 | gfc_array_spec *as; |
835 | HOST_WIDE_INT i, rank; |
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); |
842 | mpz_init (n); |
843 | |
844 | for (i = 0; i < rank; i++) |
845 | { |
846 | if (ar->dimen_type[i] != DIMEN_ELEMENT) |
847 | gfc_internal_error ("element_number(): Bad dimension type" ); |
848 | |
849 | if (as && as->lower[i]) |
850 | mpz_sub (n, *get_mpz (e: ar->start[i]), *get_mpz (e: as->lower[i])); |
851 | else |
852 | mpz_sub_ui (n, *get_mpz (e: ar->start[i]), 1); |
853 | |
854 | mpz_mul (n, n, multiplier); |
855 | mpz_add (offset, offset, n); |
856 | |
857 | if (as && as->upper[i] && as->lower[i]) |
858 | { |
859 | mpz_sub (extent, *get_mpz (e: as->upper[i]), *get_mpz (e: as->lower[i])); |
860 | mpz_add_ui (extent, extent, 1); |
861 | } |
862 | else |
863 | mpz_set_ui (extent, 0); |
864 | |
865 | if (mpz_sgn (extent) < 0) |
866 | mpz_set_ui (extent, 0); |
867 | |
868 | mpz_mul (multiplier, multiplier, extent); |
869 | } |
870 | |
871 | i = mpz_get_ui (gmp_z: offset); |
872 | |
873 | mpz_clear (multiplier); |
874 | mpz_clear (offset); |
875 | mpz_clear (extent); |
876 | mpz_clear (n); |
877 | |
878 | return i; |
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 | |
888 | static HOST_WIDE_INT |
889 | calculate_offset (gfc_expr *e) |
890 | { |
891 | HOST_WIDE_INT n, element_size, offset; |
892 | gfc_typespec *element_type; |
893 | gfc_ref *reference; |
894 | |
895 | offset = 0; |
896 | element_type = &e->symtree->n.sym->ts; |
897 | |
898 | for (reference = e->ref; reference; reference = reference->next) |
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: |
908 | n = element_number (ar: &reference->u.ar); |
909 | if (element_type->type == BT_CHARACTER) |
910 | gfc_conv_const_charlen (element_type->u.cl); |
911 | element_size = |
912 | int_size_in_bytes (gfc_typenode_for_spec (element_type)); |
913 | offset += n * element_size; |
914 | break; |
915 | |
916 | default: |
917 | gfc_error ("Bad array reference at %L" , &e->where); |
918 | } |
919 | break; |
920 | case REF_SUBSTRING: |
921 | if (reference->u.ss.start != NULL) |
922 | offset += mpz_get_ui (gmp_z: *get_mpz (e: reference->u.ss.start)) - 1; |
923 | break; |
924 | default: |
925 | gfc_error ("Illegal reference type at %L as EQUIVALENCE object" , |
926 | &e->where); |
927 | } |
928 | return offset; |
929 | } |
930 | |
931 | |
932 | /* Add a new segment_info structure to the current segment. eq1 is already |
933 | in the list, eq2 is not. */ |
934 | |
935 | static void |
936 | new_condition (segment_info *v, gfc_equiv *eq1, gfc_equiv *eq2) |
937 | { |
938 | HOST_WIDE_INT offset1, offset2; |
939 | segment_info *a; |
940 | |
941 | offset1 = calculate_offset (e: eq1->expr); |
942 | offset2 = calculate_offset (e: eq2->expr); |
943 | |
944 | a = get_segment_info (sym: eq2->expr->symtree->n.sym, |
945 | offset: v->offset + offset1 - offset2); |
946 | |
947 | current_segment = add_segments (list: current_segment, v: a); |
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 |
956 | confirm_condition (segment_info *s1, gfc_equiv *eq1, segment_info *s2, |
957 | gfc_equiv *eq2) |
958 | { |
959 | HOST_WIDE_INT offset1, offset2; |
960 | |
961 | offset1 = calculate_offset (e: eq1->expr); |
962 | offset2 = calculate_offset (e: eq2->expr); |
963 | |
964 | if (s1->offset + offset1 != s2->offset + offset2) |
965 | gfc_error ("Inconsistent equivalence rules involving %qs at %L and " |
966 | "%qs at %L" , s1->sym->name, &s1->sym->declared_at, |
967 | s2->sym->name, &s2->sym->declared_at); |
968 | } |
969 | |
970 | |
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. */ |
974 | |
975 | static void |
976 | add_condition (segment_info *f, gfc_equiv *eq1, gfc_equiv *eq2) |
977 | { |
978 | segment_info *n; |
979 | |
980 | n = find_segment_info (symbol: eq2->expr->symtree->n.sym); |
981 | |
982 | if (n == NULL) |
983 | new_condition (v: f, eq1, eq2); |
984 | else |
985 | confirm_condition (s1: f, eq1, s2: n, eq2); |
986 | } |
987 | |
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 | } |
1041 | |
1042 | /* Given a segment element, search through the equivalence lists for unused |
1043 | conditions that involve the symbol. Add these rules to the segment. */ |
1044 | |
1045 | static bool |
1046 | find_equivalence (segment_info *n) |
1047 | { |
1048 | gfc_equiv *e1, *e2, *eq; |
1049 | bool found; |
1050 | |
1051 | found = false; |
1052 | |
1053 | for (e1 = n->sym->ns->equiv; e1; e1 = e1->next) |
1054 | { |
1055 | eq = NULL; |
1056 | |
1057 | /* Search the equivalence list, including the root (first) element |
1058 | for the symbol that owns the segment. */ |
1059 | symbol_attribute dummy_symbol; |
1060 | memset (s: &dummy_symbol, c: 0, n: sizeof (dummy_symbol)); |
1061 | for (e2 = e1; e2; e2 = e2->eq) |
1062 | { |
1063 | accumulate_equivalence_attributes (dummy_symbol: &dummy_symbol, e: e2); |
1064 | if (!e2->used && e2->expr->symtree->n.sym == n->sym) |
1065 | { |
1066 | eq = e2; |
1067 | break; |
1068 | } |
1069 | } |
1070 | |
1071 | gfc_check_conflict (&dummy_symbol, e1->expr->symtree->name, &e1->expr->where); |
1072 | |
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) |
1083 | { |
1084 | add_condition (f: n, eq1: eq, eq2: e2); |
1085 | e2->used = 1; |
1086 | found = true; |
1087 | } |
1088 | } |
1089 | } |
1090 | return found; |
1091 | } |
1092 | |
1093 | |
1094 | /* Add all symbols equivalenced within a segment. We need to scan the |
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 |
1098 | loop by demanding that completion sees a pass with no matches; i.e., |
1099 | all symbols with equiv_built set and no new equivalences found. */ |
1100 | |
1101 | static void |
1102 | add_equivalences (bool *saw_equiv) |
1103 | { |
1104 | segment_info *f; |
1105 | bool more = true; |
1106 | |
1107 | while (more) |
1108 | { |
1109 | more = false; |
1110 | for (f = current_segment; f; f = f->next) |
1111 | { |
1112 | if (!f->sym->equiv_built) |
1113 | { |
1114 | f->sym->equiv_built = 1; |
1115 | bool seen_one = find_equivalence (n: f); |
1116 | if (seen_one) |
1117 | { |
1118 | *saw_equiv = true; |
1119 | more = true; |
1120 | } |
1121 | } |
1122 | } |
1123 | } |
1124 | |
1125 | /* Add a copy of this segment list to the namespace. */ |
1126 | copy_equiv_list_to_ns (c: current_segment); |
1127 | } |
1128 | |
1129 | |
1130 | /* Returns the offset necessary to properly align the current equivalence. |
1131 | Sets *palign to the required alignment. */ |
1132 | |
1133 | static HOST_WIDE_INT |
1134 | align_segment (unsigned HOST_WIDE_INT *palign) |
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. */ |
1154 | gfc_error ("The equivalence set for variable %qs " |
1155 | "declared at %L violates alignment requirements" , |
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. */ |
1169 | |
1170 | static void |
1171 | apply_segment_offset (segment_info *s, HOST_WIDE_INT offset) |
1172 | { |
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; |
1193 | bool saw_equiv; |
1194 | |
1195 | common_segment = NULL; |
1196 | offset = 0; |
1197 | current_offset = 0; |
1198 | align = 1; |
1199 | saw_equiv = false; |
1200 | |
1201 | /* Add symbols to the segment. */ |
1202 | for (sym = var_list; sym; sym = sym->common_next) |
1203 | { |
1204 | current_segment = common_segment; |
1205 | s = find_segment_info (symbol: sym); |
1206 | |
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 | { |
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 | { |
1219 | gfc_error ("Equivalence for %qs does not match ordering of " |
1220 | "COMMON %qs at %L" , sym->name, |
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, offset: current_offset); |
1228 | |
1229 | /* Add all objects directly or indirectly equivalenced with this |
1230 | symbol. */ |
1231 | add_equivalences (saw_equiv: &saw_equiv); |
1232 | |
1233 | if (current_segment->offset < 0) |
1234 | gfc_error ("The equivalence set for %qs cause an invalid " |
1235 | "extension to COMMON %qs at %L" , sym->name, |
1236 | common->name, &common->where); |
1237 | |
1238 | if (flag_align_commons) |
1239 | offset = align_segment (palign: &align); |
1240 | |
1241 | if (offset) |
1242 | { |
1243 | /* The required offset conflicts with previous alignment |
1244 | requirements. Insert padding immediately before this |
1245 | segment. */ |
1246 | if (warn_align_commons) |
1247 | { |
1248 | if (strcmp (s1: common->name, BLANK_COMMON_NAME)) |
1249 | gfc_warning (opt: OPT_Walign_commons, |
1250 | "Padding of %d bytes required before %qs in " |
1251 | "COMMON %qs at %L; reorder elements or use " |
1252 | "%<-fno-align-commons%>" , (int)offset, |
1253 | s->sym->name, common->name, &common->where); |
1254 | else |
1255 | gfc_warning (opt: OPT_Walign_commons, |
1256 | "Padding of %d bytes required before %qs in " |
1257 | "COMMON at %L; reorder elements or use " |
1258 | "%<-fno-align-commons%>" , (int)offset, |
1259 | s->sym->name, &common->where); |
1260 | } |
1261 | } |
1262 | |
1263 | /* Apply the offset to the new segments. */ |
1264 | apply_segment_offset (s: current_segment, offset); |
1265 | current_offset += offset; |
1266 | |
1267 | /* Add the new segments to the common block. */ |
1268 | common_segment = add_segments (list: common_segment, v: current_segment); |
1269 | } |
1270 | |
1271 | /* The offset of the next common variable. */ |
1272 | current_offset += s->length; |
1273 | } |
1274 | |
1275 | if (common_segment == NULL) |
1276 | { |
1277 | gfc_error ("COMMON %qs at %L does not exist" , |
1278 | common->name, &common->where); |
1279 | return; |
1280 | } |
1281 | |
1282 | if (common_segment->offset != 0 && warn_align_commons) |
1283 | { |
1284 | if (strcmp (s1: common->name, BLANK_COMMON_NAME)) |
1285 | gfc_warning (opt: OPT_Walign_commons, |
1286 | "COMMON %qs at %L requires %d bytes of padding; " |
1287 | "reorder elements or use %<-fno-align-commons%>" , |
1288 | common->name, &common->where, (int)common_segment->offset); |
1289 | else |
1290 | gfc_warning (opt: OPT_Walign_commons, |
1291 | "COMMON at %L requires %d bytes of padding; " |
1292 | "reorder elements or use %<-fno-align-commons%>" , |
1293 | &common->where, (int)common_segment->offset); |
1294 | } |
1295 | |
1296 | create_common (com: common, head: common_segment, saw_equiv); |
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; |
1307 | gfc_common_head * c; |
1308 | HOST_WIDE_INT offset; |
1309 | unsigned HOST_WIDE_INT align; |
1310 | bool dummy; |
1311 | |
1312 | for (z = ns->equiv; z; z = z->next) |
1313 | for (y = z->eq; y; y = y->eq) |
1314 | { |
1315 | if (y->used) |
1316 | continue; |
1317 | sym = z->expr->symtree->n.sym; |
1318 | current_segment = get_segment_info (sym, offset: 0); |
1319 | |
1320 | /* All objects directly or indirectly equivalenced with this |
1321 | symbol. */ |
1322 | add_equivalences (saw_equiv: &dummy); |
1323 | |
1324 | /* Align the block. */ |
1325 | offset = align_segment (palign: &align); |
1326 | |
1327 | /* Ensure all offsets are positive. */ |
1328 | offset -= current_segment->offset & ~(align - 1); |
1329 | |
1330 | apply_segment_offset (s: current_segment, offset); |
1331 | |
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. */ |
1338 | if (z->module) |
1339 | { |
1340 | c = gfc_get_common_head (); |
1341 | /* We've lost the real location, so use the location of the |
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; |
1348 | |
1349 | size_t len = strlen (s: z->module); |
1350 | gcc_assert (len < sizeof (c->name)); |
1351 | memcpy (dest: c->name, src: z->module, n: len); |
1352 | c->name[len] = '\0'; |
1353 | } |
1354 | else |
1355 | c = NULL; |
1356 | |
1357 | create_common (com: c, head: current_segment, saw_equiv: true); |
1358 | break; |
1359 | } |
1360 | } |
1361 | |
1362 | |
1363 | /* Work function for translating a named common block. */ |
1364 | |
1365 | static void |
1366 | named_common (gfc_symtree *st) |
1367 | { |
1368 | translate_common (common: st->n.common, var_list: st->n.common->head); |
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. */ |
1375 | |
1376 | void |
1377 | gfc_trans_common (gfc_namespace *ns) |
1378 | { |
1379 | gfc_common_head *c; |
1380 | |
1381 | /* Translate the blank common block. */ |
1382 | if (ns->blank_common.head != NULL) |
1383 | { |
1384 | c = gfc_get_common_head (); |
1385 | c->where = ns->blank_common.head->common_head->where; |
1386 | strcpy (dest: c->name, BLANK_COMMON_NAME); |
1387 | translate_common (common: c, var_list: ns->blank_common.head); |
1388 | } |
1389 | |
1390 | /* Translate all named common blocks. */ |
1391 | gfc_traverse_symtree (ns->common_root, named_common); |
1392 | |
1393 | /* Translate local equivalence. */ |
1394 | finish_equivalences (ns); |
1395 | |
1396 | /* Commit the newly created symbols for common blocks and module |
1397 | equivalences. */ |
1398 | gfc_commit_symbols (); |
1399 | } |
1400 | |