Line data Source code
1 : /* Common block and equivalence list handling
2 : Copyright (C) 2000-2026 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 "cgraph.h"
102 : #include "context.h"
103 : #include "omp-offload.h"
104 : #include "gfortran.h"
105 : #include "trans.h"
106 : #include "stringpool.h"
107 : #include "fold-const.h"
108 : #include "stor-layout.h"
109 : #include "varasm.h"
110 : #include "trans-types.h"
111 : #include "trans-const.h"
112 : #include "target-memory.h"
113 :
114 :
115 : /* Holds a single variable in an equivalence set. */
116 : typedef struct segment_info
117 : {
118 : gfc_symbol *sym;
119 : HOST_WIDE_INT offset;
120 : HOST_WIDE_INT length;
121 : /* This will contain the field type until the field is created. */
122 : tree field;
123 : struct segment_info *next;
124 : } segment_info;
125 :
126 : static segment_info * current_segment;
127 :
128 : /* Store decl of all common blocks in this translation unit; the first
129 : tree is the identifier. */
130 : static std::map<tree, tree> gfc_map_of_all_commons;
131 :
132 :
133 : /* Make a segment_info based on a symbol. */
134 :
135 : static segment_info *
136 8117 : get_segment_info (gfc_symbol * sym, HOST_WIDE_INT offset)
137 : {
138 8117 : segment_info *s;
139 :
140 : /* Make sure we've got the character length. */
141 8117 : if (sym->ts.type == BT_CHARACTER)
142 641 : gfc_conv_const_charlen (sym->ts.u.cl);
143 :
144 : /* Create the segment_info and fill it in. */
145 8117 : s = XCNEW (segment_info);
146 8117 : s->sym = sym;
147 : /* We will use this type when building the segment aggregate type. */
148 8117 : s->field = gfc_sym_type (sym);
149 8117 : s->length = int_size_in_bytes (s->field);
150 8117 : s->offset = offset;
151 :
152 8117 : return s;
153 : }
154 :
155 :
156 : /* Add a copy of a segment list to the namespace. This is specifically for
157 : equivalence segments, so that dependency checking can be done on
158 : equivalence group members. */
159 :
160 : static void
161 6556 : copy_equiv_list_to_ns (segment_info *c)
162 : {
163 6556 : segment_info *f;
164 6556 : gfc_equiv_info *s;
165 6556 : gfc_equiv_list *l;
166 :
167 6556 : l = XCNEW (gfc_equiv_list);
168 :
169 6556 : l->next = c->sym->ns->equiv_lists;
170 6556 : c->sym->ns->equiv_lists = l;
171 :
172 14673 : for (f = c; f; f = f->next)
173 : {
174 8117 : s = XCNEW (gfc_equiv_info);
175 8117 : s->next = l->equiv;
176 8117 : l->equiv = s;
177 8117 : s->sym = f->sym;
178 8117 : s->offset = f->offset;
179 8117 : s->length = f->length;
180 : }
181 6556 : }
182 :
183 :
184 : /* Add combine segment V and segment LIST. */
185 :
186 : static segment_info *
187 7324 : add_segments (segment_info *list, segment_info *v)
188 : {
189 7324 : segment_info *s;
190 7324 : segment_info *p;
191 7324 : segment_info *next;
192 :
193 7324 : p = NULL;
194 7324 : s = list;
195 :
196 14995 : while (v)
197 : {
198 : /* Find the location of the new element. */
199 42138 : while (s)
200 : {
201 35575 : if (v->offset < s->offset)
202 : break;
203 35153 : if (v->offset == s->offset
204 732 : && v->length <= s->length)
205 : break;
206 :
207 34467 : p = s;
208 34467 : s = s->next;
209 : }
210 :
211 : /* Insert the new element in between p and s. */
212 7671 : next = v->next;
213 7671 : v->next = s;
214 7671 : if (p == NULL)
215 : list = v;
216 : else
217 4770 : p->next = v;
218 :
219 7671 : p = v;
220 7671 : v = next;
221 : }
222 :
223 7324 : return list;
224 : }
225 :
226 :
227 : /* Construct mangled common block name from symbol name. */
228 :
229 : /* We need the bind(c) flag to tell us how/if we should mangle the symbol
230 : name. There are few calls to this function, so few places that this
231 : would need to be added. At the moment, there is only one call, in
232 : build_common_decl(). We can't attempt to look up the common block
233 : because we may be building it for the first time and therefore, it won't
234 : be in the common_root. We also need the binding label, if it's bind(c).
235 : Therefore, send in the pointer to the common block, so whatever info we
236 : have so far can be used. All of the necessary info should be available
237 : in the gfc_common_head by now, so it should be accurate to test the
238 : isBindC flag and use the binding label given if it is bind(c).
239 :
240 : We may NOT know yet if it's bind(c) or not, but we can try at least.
241 : Will have to figure out what to do later if it's labeled bind(c)
242 : after this is called. */
243 :
244 : static tree
245 2063 : gfc_sym_mangled_common_id (gfc_common_head *com)
246 : {
247 2063 : int has_underscore;
248 : /* Provide sufficient space to hold "symbol.symbol.eq.1234567890__". */
249 2063 : char mangled_name[2*GFC_MAX_MANGLED_SYMBOL_LEN + 1 + 16 + 1];
250 2063 : char name[sizeof (mangled_name) - 2];
251 :
252 : /* Get the name out of the common block pointer. */
253 2063 : size_t len = strlen (com->name);
254 2063 : gcc_assert (len < sizeof (name));
255 2063 : strcpy (name, com->name);
256 :
257 : /* If we're suppose to do a bind(c). */
258 2063 : if (com->is_bind_c == 1 && com->binding_label)
259 69 : return get_identifier (com->binding_label);
260 :
261 1994 : if (strcmp (name, BLANK_COMMON_NAME) == 0)
262 193 : return get_identifier (name);
263 :
264 1801 : if (flag_underscoring)
265 : {
266 1801 : has_underscore = strchr (name, '_') != 0;
267 1801 : if (flag_second_underscore && has_underscore)
268 4 : snprintf (mangled_name, sizeof mangled_name, "%s__", name);
269 : else
270 1797 : snprintf (mangled_name, sizeof mangled_name, "%s_", name);
271 :
272 1801 : return get_identifier (mangled_name);
273 : }
274 : else
275 0 : return get_identifier (name);
276 : }
277 :
278 :
279 : /* Build a field declaration for a common variable or a local equivalence
280 : object. */
281 :
282 : static void
283 8117 : build_field (segment_info *h, tree union_type, record_layout_info rli)
284 : {
285 8117 : tree field;
286 8117 : tree name;
287 8117 : HOST_WIDE_INT offset = h->offset;
288 8117 : unsigned HOST_WIDE_INT desired_align, known_align;
289 :
290 8117 : name = get_identifier (h->sym->name);
291 8117 : field = build_decl (gfc_get_location (&h->sym->declared_at),
292 : FIELD_DECL, name, h->field);
293 8117 : known_align = (offset & -offset) * BITS_PER_UNIT;
294 12889 : if (known_align == 0 || known_align > BIGGEST_ALIGNMENT)
295 4902 : known_align = BIGGEST_ALIGNMENT;
296 :
297 8117 : desired_align = update_alignment_for_field (rli, field, known_align);
298 8117 : if (desired_align > known_align)
299 7 : DECL_PACKED (field) = 1;
300 :
301 8117 : DECL_FIELD_CONTEXT (field) = union_type;
302 8117 : DECL_FIELD_OFFSET (field) = size_int (offset);
303 8117 : DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node;
304 8117 : SET_DECL_OFFSET_ALIGN (field, known_align);
305 :
306 8117 : rli->offset = size_binop (MAX_EXPR, rli->offset,
307 : size_binop (PLUS_EXPR,
308 : DECL_FIELD_OFFSET (field),
309 : DECL_SIZE_UNIT (field)));
310 : /* If this field is assigned to a label, we create another two variables.
311 : One will hold the address of target label or format label. The other will
312 : hold the length of format label string. */
313 8117 : if (h->sym->attr.assign)
314 : {
315 14 : tree len;
316 14 : tree addr;
317 :
318 14 : gfc_allocate_lang_decl (field);
319 14 : GFC_DECL_ASSIGN (field) = 1;
320 14 : len = gfc_create_var_np (gfc_charlen_type_node,h->sym->name);
321 14 : addr = gfc_create_var_np (pvoid_type_node, h->sym->name);
322 14 : TREE_STATIC (len) = 1;
323 14 : TREE_STATIC (addr) = 1;
324 14 : DECL_INITIAL (len) = build_int_cst (gfc_charlen_type_node, -2);
325 14 : gfc_set_decl_location (len, &h->sym->declared_at);
326 14 : gfc_set_decl_location (addr, &h->sym->declared_at);
327 14 : GFC_DECL_STRING_LEN (field) = pushdecl_top_level (len);
328 14 : GFC_DECL_ASSIGN_ADDR (field) = pushdecl_top_level (addr);
329 : }
330 :
331 : /* If this field is volatile, mark it. */
332 8117 : if (h->sym->attr.volatile_)
333 : {
334 3 : tree new_type;
335 3 : TREE_THIS_VOLATILE (field) = 1;
336 3 : TREE_SIDE_EFFECTS (field) = 1;
337 3 : new_type = build_qualified_type (TREE_TYPE (field), TYPE_QUAL_VOLATILE);
338 3 : TREE_TYPE (field) = new_type;
339 : }
340 :
341 8117 : h->field = field;
342 8117 : }
343 :
344 : #if !defined (NO_DOT_IN_LABEL)
345 : #define GFC_EQUIV_FMT "equiv.%d"
346 : #elif !defined (NO_DOLLAR_IN_LABEL)
347 : #define GFC_EQUIV_FMT "_Equiv$%d"
348 : #else
349 : #define GFC_EQUIV_FMT "_Equiv_%d"
350 : #endif
351 :
352 : /* Get storage for local equivalence. */
353 :
354 : static tree
355 688 : build_equiv_decl (tree union_type, bool is_init, bool is_saved, bool is_auto)
356 : {
357 688 : tree decl;
358 688 : char name[18];
359 688 : static int serial = 0;
360 :
361 688 : if (is_init)
362 : {
363 141 : decl = gfc_create_var (union_type, "equiv");
364 141 : TREE_STATIC (decl) = 1;
365 141 : GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
366 141 : return decl;
367 : }
368 :
369 547 : snprintf (name, sizeof (name), GFC_EQUIV_FMT, serial++);
370 547 : decl = build_decl (input_location,
371 : VAR_DECL, get_identifier (name), union_type);
372 547 : DECL_ARTIFICIAL (decl) = 1;
373 547 : DECL_IGNORED_P (decl) = 1;
374 :
375 547 : if (!is_auto && (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
376 526 : || is_saved))
377 27 : TREE_STATIC (decl) = 1;
378 :
379 547 : TREE_ADDRESSABLE (decl) = 1;
380 547 : TREE_USED (decl) = 1;
381 547 : GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
382 :
383 : /* The source location has been lost, and doesn't really matter.
384 : We need to set it to something though. */
385 547 : DECL_SOURCE_LOCATION (decl) = input_location;
386 :
387 547 : gfc_add_decl_to_function (decl);
388 :
389 547 : return decl;
390 : }
391 :
392 :
393 : /* Get storage for common block. */
394 :
395 : static tree
396 2063 : build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
397 : {
398 2063 : tree decl, identifier;
399 :
400 2063 : identifier = gfc_sym_mangled_common_id (com);
401 2063 : decl = gfc_map_of_all_commons.count(identifier)
402 969 : ? gfc_map_of_all_commons[identifier] : NULL_TREE;
403 :
404 : /* Update the size of this common block as needed. */
405 2063 : if (decl != NULL_TREE)
406 : {
407 969 : tree size = TYPE_SIZE_UNIT (union_type);
408 :
409 : /* Named common blocks of the same name shall be of the same size
410 : in all scoping units of a program in which they appear, but
411 : blank common blocks may be of different sizes. */
412 969 : if (!tree_int_cst_equal (DECL_SIZE_UNIT (decl), size)
413 969 : && strcmp (com->name, BLANK_COMMON_NAME))
414 45 : gfc_warning (0, "Named COMMON block %qs at %L shall be of the "
415 : "same size as elsewhere (%wu vs %wu bytes)", com->name,
416 : &com->where,
417 15 : TREE_INT_CST_LOW (size),
418 15 : TREE_INT_CST_LOW (DECL_SIZE_UNIT (decl)));
419 :
420 969 : if (tree_int_cst_lt (DECL_SIZE_UNIT (decl), size))
421 : {
422 11 : DECL_SIZE (decl) = TYPE_SIZE (union_type);
423 11 : DECL_SIZE_UNIT (decl) = size;
424 11 : SET_DECL_MODE (decl, TYPE_MODE (union_type));
425 11 : TREE_TYPE (decl) = union_type;
426 11 : layout_decl (decl, 0);
427 : }
428 : }
429 :
430 : /* If this common block has been declared in a previous program unit,
431 : and either it is already initialized or there is no new initialization
432 : for it, just return. */
433 969 : if ((decl != NULL_TREE) && (!is_init || DECL_INITIAL (decl)))
434 : return decl;
435 :
436 : /* If there is no backend_decl for the common block, build it. */
437 1112 : if (decl == NULL_TREE)
438 : {
439 1094 : if (com->is_bind_c == 1 && com->binding_label)
440 51 : decl = build_decl (input_location, VAR_DECL, identifier, union_type);
441 : else
442 : {
443 1043 : decl = build_decl (input_location, VAR_DECL, get_identifier (com->name),
444 : union_type);
445 1043 : gfc_set_decl_assembler_name (decl, identifier);
446 : }
447 :
448 1094 : TREE_PUBLIC (decl) = 1;
449 1094 : TREE_STATIC (decl) = 1;
450 1094 : DECL_IGNORED_P (decl) = 1;
451 1094 : if (!com->is_bind_c)
452 2057 : SET_DECL_ALIGN (decl, BIGGEST_ALIGNMENT);
453 : else
454 : {
455 : /* Do not set the alignment for bind(c) common blocks to
456 : BIGGEST_ALIGNMENT because that won't match what C does. Also,
457 : for common blocks with one element, the alignment must be
458 : that of the field within the common block in order to match
459 : what C will do. */
460 59 : tree field = NULL_TREE;
461 59 : field = TYPE_FIELDS (TREE_TYPE (decl));
462 59 : if (DECL_CHAIN (field) == NULL_TREE)
463 23 : SET_DECL_ALIGN (decl, TYPE_ALIGN (TREE_TYPE (field)));
464 : }
465 1094 : DECL_USER_ALIGN (decl) = 0;
466 1094 : GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
467 :
468 1094 : gfc_set_decl_location (decl, &com->where);
469 :
470 1094 : if (com->omp_groupprivate)
471 6 : DECL_ATTRIBUTES (decl) = tree_cons (get_identifier ("omp groupprivate"),
472 6 : NULL_TREE, DECL_ATTRIBUTES (decl));
473 1094 : tree arg_list = NULL_TREE;
474 1094 : if (com->omp_device_type != OMP_DEVICE_TYPE_UNSET)
475 : {
476 16 : const char *arg_str = NULL;
477 16 : switch (com->omp_device_type)
478 : {
479 : case OMP_DEVICE_TYPE_HOST:
480 : arg_str = "device_type(host)";
481 : break;
482 2 : case OMP_DEVICE_TYPE_NOHOST:
483 2 : arg_str = "device_type(nohost)";
484 2 : break;
485 10 : case OMP_DEVICE_TYPE_ANY:
486 10 : arg_str = "device_type(any)";
487 10 : break;
488 0 : default:
489 0 : gcc_unreachable ();
490 : }
491 16 : arg_list = tree_cons (NULL_TREE, get_identifier (arg_str), arg_list);
492 : }
493 :
494 1094 : if (com->omp_declare_target_link)
495 3 : DECL_ATTRIBUTES (decl)
496 6 : = tree_cons (get_identifier ("omp declare target link"),
497 3 : arg_list, DECL_ATTRIBUTES (decl));
498 1091 : else if (com->omp_declare_target)
499 6 : DECL_ATTRIBUTES (decl)
500 12 : = tree_cons (get_identifier ("omp declare target"),
501 6 : arg_list, DECL_ATTRIBUTES (decl));
502 1085 : else if (com->omp_declare_target_local)
503 : {
504 7 : arg_list = tree_cons (NULL_TREE, get_identifier ("local"), arg_list);
505 7 : DECL_ATTRIBUTES (decl)
506 14 : = tree_cons (get_identifier ("omp declare target"),
507 7 : arg_list, DECL_ATTRIBUTES (decl));
508 : }
509 :
510 1094 : if (com->omp_declare_target_link || com->omp_declare_target
511 1085 : || com->omp_declare_target_local)
512 : {
513 : /* Add to offload_vars; get_create does so for omp_declare_target
514 : and omp_declare_target_local, omp_declare_target_link requires
515 : manual work. */
516 16 : gcc_assert (symtab_node::get (decl) == 0);
517 16 : symtab_node *node = symtab_node::get_create (decl);
518 16 : if (node != NULL && com->omp_declare_target_link)
519 : {
520 3 : node->offloadable = 1;
521 3 : if (ENABLE_OFFLOADING)
522 : {
523 : g->have_offload = true;
524 : if (is_a <varpool_node *> (node))
525 : vec_safe_push (offload_vars, decl);
526 : }
527 : }
528 : }
529 :
530 : /* Place the back end declaration for this common block in
531 : GLOBAL_BINDING_LEVEL. */
532 1094 : gfc_map_of_all_commons[identifier] = pushdecl_top_level (decl);
533 : }
534 :
535 : /* Has no initial values. */
536 1112 : if (!is_init)
537 : {
538 1010 : DECL_INITIAL (decl) = NULL_TREE;
539 1010 : DECL_COMMON (decl) = 1;
540 1010 : DECL_DEFER_OUTPUT (decl) = 1;
541 : }
542 : else
543 : {
544 102 : DECL_INITIAL (decl) = error_mark_node;
545 102 : DECL_COMMON (decl) = 0;
546 102 : DECL_DEFER_OUTPUT (decl) = 0;
547 : }
548 :
549 1112 : if (com->threadprivate)
550 43 : set_decl_tls_model (decl, decl_default_tls_model (decl));
551 :
552 : return decl;
553 : }
554 :
555 :
556 : /* Return a field that is the size of the union, if an equivalence has
557 : overlapping initializers. Merge the initializers into a single
558 : initializer for this new field, then free the old ones. */
559 :
560 : static tree
561 941 : get_init_field (segment_info *head, tree union_type, tree *field_init,
562 : record_layout_info rli)
563 : {
564 941 : segment_info *s;
565 941 : HOST_WIDE_INT length = 0;
566 941 : HOST_WIDE_INT offset = 0;
567 941 : unsigned HOST_WIDE_INT known_align, desired_align;
568 941 : bool overlap = false;
569 941 : tree tmp, field;
570 941 : tree init;
571 941 : unsigned char *data, *chk;
572 941 : vec<constructor_elt, va_gc> *v = NULL;
573 :
574 941 : tree type = unsigned_char_type_node;
575 941 : int i;
576 :
577 : /* Obtain the size of the union and check if there are any overlapping
578 : initializers. */
579 4070 : for (s = head; s; s = s->next)
580 : {
581 3129 : HOST_WIDE_INT slen = s->offset + s->length;
582 3129 : if (s->sym->value)
583 : {
584 229 : if (s->offset < offset)
585 50 : overlap = true;
586 : offset = slen;
587 : }
588 3129 : length = length < slen ? slen : length;
589 : }
590 :
591 941 : if (!overlap)
592 : return NULL_TREE;
593 :
594 : /* Now absorb all the initializer data into a single vector,
595 : whilst checking for overlapping, unequal values. */
596 46 : data = XCNEWVEC (unsigned char, (size_t)length);
597 46 : chk = XCNEWVEC (unsigned char, (size_t)length);
598 :
599 : /* TODO - change this when default initialization is implemented. */
600 46 : memset (data, '\0', (size_t)length);
601 46 : memset (chk, '\0', (size_t)length);
602 156 : for (s = head; s; s = s->next)
603 110 : if (s->sym->value)
604 : {
605 96 : locus *loc = NULL;
606 96 : if (s->sym->ns->equiv && s->sym->ns->equiv->eq)
607 96 : loc = &s->sym->ns->equiv->eq->expr->where;
608 96 : gfc_merge_initializers (s->sym->ts, s->sym->value, loc,
609 : &data[s->offset],
610 96 : &chk[s->offset],
611 96 : (size_t)s->length);
612 : }
613 :
614 1142 : for (i = 0; i < length; i++)
615 1096 : CONSTRUCTOR_APPEND_ELT (v, NULL, build_int_cst (type, data[i]));
616 :
617 46 : free (data);
618 46 : free (chk);
619 :
620 : /* Build a char[length] array to hold the initializers. Much of what
621 : follows is borrowed from build_field, above. */
622 :
623 46 : tmp = build_int_cst (gfc_array_index_type, length - 1);
624 46 : tmp = build_range_type (gfc_array_index_type,
625 : gfc_index_zero_node, tmp);
626 46 : tmp = build_array_type (type, tmp);
627 46 : field = build_decl (input_location, FIELD_DECL, NULL_TREE, tmp);
628 :
629 46 : known_align = BIGGEST_ALIGNMENT;
630 :
631 46 : desired_align = update_alignment_for_field (rli, field, known_align);
632 46 : if (desired_align > known_align)
633 0 : DECL_PACKED (field) = 1;
634 :
635 46 : DECL_FIELD_CONTEXT (field) = union_type;
636 46 : DECL_FIELD_OFFSET (field) = size_int (0);
637 46 : DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node;
638 46 : SET_DECL_OFFSET_ALIGN (field, known_align);
639 :
640 46 : rli->offset = size_binop (MAX_EXPR, rli->offset,
641 : size_binop (PLUS_EXPR,
642 : DECL_FIELD_OFFSET (field),
643 : DECL_SIZE_UNIT (field)));
644 :
645 46 : init = build_constructor (TREE_TYPE (field), v);
646 46 : TREE_CONSTANT (init) = 1;
647 :
648 46 : *field_init = init;
649 :
650 156 : for (s = head; s; s = s->next)
651 : {
652 110 : if (s->sym->value == NULL)
653 14 : continue;
654 :
655 96 : gfc_free_expr (s->sym->value);
656 96 : s->sym->value = NULL;
657 : }
658 :
659 : return field;
660 : }
661 :
662 :
663 : /* Declare memory for the common block or local equivalence, and create
664 : backend declarations for all of the elements. */
665 :
666 : static void
667 2751 : create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)
668 : {
669 2751 : segment_info *s, *next_s;
670 2751 : tree union_type;
671 2751 : tree *field_link;
672 2751 : tree field;
673 2751 : tree field_init = NULL_TREE;
674 2751 : record_layout_info rli;
675 2751 : tree decl;
676 2751 : bool is_init = false;
677 2751 : bool is_saved = false;
678 2751 : bool is_auto = false;
679 :
680 : /* Declare the variables inside the common block.
681 : If the current common block contains any equivalence object, then
682 : make a UNION_TYPE node, otherwise RECORD_TYPE. This will let the
683 : alias analyzer work well when there is no address overlapping for
684 : common variables in the current common block. */
685 2751 : if (saw_equiv)
686 941 : union_type = make_node (UNION_TYPE);
687 : else
688 1810 : union_type = make_node (RECORD_TYPE);
689 :
690 2751 : rli = start_record_layout (union_type);
691 2751 : field_link = &TYPE_FIELDS (union_type);
692 :
693 : /* Check for overlapping initializers and replace them with a single,
694 : artificial field that contains all the data. */
695 2751 : if (saw_equiv)
696 941 : field = get_init_field (head, union_type, &field_init, rli);
697 : else
698 : field = NULL_TREE;
699 :
700 941 : if (field != NULL_TREE)
701 : {
702 46 : is_init = true;
703 46 : *field_link = field;
704 46 : field_link = &DECL_CHAIN (field);
705 : }
706 :
707 10868 : for (s = head; s; s = s->next)
708 : {
709 8117 : build_field (s, union_type, rli);
710 :
711 : /* Link the field into the type. */
712 8117 : *field_link = s->field;
713 8117 : field_link = &DECL_CHAIN (s->field);
714 :
715 : /* Has initial value. */
716 8117 : if (s->sym->value)
717 254 : is_init = true;
718 :
719 : /* Has SAVE attribute. */
720 8117 : if (s->sym->attr.save)
721 582 : is_saved = true;
722 :
723 : /* Has AUTOMATIC attribute. */
724 8117 : if (s->sym->attr.automatic)
725 14 : is_auto = true;
726 : }
727 :
728 2751 : finish_record_layout (rli, true);
729 :
730 2751 : if (com)
731 2063 : decl = build_common_decl (com, union_type, is_init);
732 : else
733 688 : decl = build_equiv_decl (union_type, is_init, is_saved, is_auto);
734 :
735 2751 : if (is_init)
736 : {
737 243 : tree ctor, tmp;
738 243 : vec<constructor_elt, va_gc> *v = NULL;
739 :
740 243 : if (field != NULL_TREE && field_init != NULL_TREE)
741 46 : CONSTRUCTOR_APPEND_ELT (v, field, field_init);
742 : else
743 605 : for (s = head; s; s = s->next)
744 : {
745 408 : if (s->sym->value)
746 : {
747 : /* Add the initializer for this field. */
748 254 : tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts,
749 254 : TREE_TYPE (s->field),
750 : s->sym->attr.dimension,
751 254 : s->sym->attr.pointer
752 253 : || s->sym->attr.allocatable, false);
753 :
754 254 : CONSTRUCTOR_APPEND_ELT (v, s->field, tmp);
755 : }
756 : }
757 :
758 243 : gcc_assert (!v->is_empty ());
759 243 : ctor = build_constructor (union_type, v);
760 243 : TREE_CONSTANT (ctor) = 1;
761 243 : TREE_STATIC (ctor) = 1;
762 243 : DECL_INITIAL (decl) = ctor;
763 :
764 243 : if (flag_checking)
765 : {
766 : tree field, value;
767 : unsigned HOST_WIDE_INT idx;
768 543 : FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor), idx, field, value)
769 300 : gcc_assert (TREE_CODE (field) == FIELD_DECL);
770 : }
771 : }
772 :
773 : /* Build component reference for each variable. */
774 10868 : for (s = head; s; s = next_s)
775 : {
776 8117 : tree var_decl;
777 :
778 8117 : var_decl = build_decl (gfc_get_location (&s->sym->declared_at),
779 8117 : VAR_DECL, DECL_NAME (s->field),
780 8117 : TREE_TYPE (s->field));
781 8117 : TREE_STATIC (var_decl) = TREE_STATIC (decl);
782 : /* Mark the variable as used in order to avoid warnings about
783 : unused variables. */
784 8117 : TREE_USED (var_decl) = 1;
785 8117 : if (s->sym->attr.use_assoc)
786 436 : DECL_IGNORED_P (var_decl) = 1;
787 8117 : if (s->sym->attr.target)
788 66 : TREE_ADDRESSABLE (var_decl) = 1;
789 : /* Fake variables are not visible from other translation units. */
790 8117 : TREE_PUBLIC (var_decl) = 0;
791 8117 : gfc_finish_decl_attrs (var_decl, &s->sym->attr);
792 :
793 : /* To preserve identifier names in COMMON, chain to procedure
794 : scope unless at top level in a module definition. */
795 8117 : if (com
796 6357 : && s->sym->ns->proc_name
797 6286 : && s->sym->ns->proc_name->attr.flavor == FL_MODULE)
798 491 : var_decl = pushdecl_top_level (var_decl);
799 : else
800 7626 : gfc_add_decl_to_function (var_decl);
801 :
802 8117 : tree comp = build3_loc (input_location, COMPONENT_REF,
803 8117 : TREE_TYPE (s->field), decl, s->field, NULL_TREE);
804 8117 : if (TREE_THIS_VOLATILE (s->field))
805 3 : TREE_THIS_VOLATILE (comp) = 1;
806 8117 : SET_DECL_VALUE_EXPR (var_decl, comp);
807 8117 : DECL_HAS_VALUE_EXPR_P (var_decl) = 1;
808 8117 : GFC_DECL_COMMON_OR_EQUIV (var_decl) = 1;
809 :
810 8117 : if (s->sym->attr.assign)
811 : {
812 14 : gfc_allocate_lang_decl (var_decl);
813 14 : GFC_DECL_ASSIGN (var_decl) = 1;
814 14 : GFC_DECL_STRING_LEN (var_decl) = GFC_DECL_STRING_LEN (s->field);
815 14 : GFC_DECL_ASSIGN_ADDR (var_decl) = GFC_DECL_ASSIGN_ADDR (s->field);
816 : }
817 :
818 8117 : s->sym->backend_decl = var_decl;
819 :
820 8117 : next_s = s->next;
821 8117 : free (s);
822 : }
823 2751 : }
824 :
825 :
826 : /* Given a symbol, find it in the current segment list. Returns NULL if
827 : not found. */
828 :
829 : static segment_info *
830 7333 : find_segment_info (gfc_symbol *symbol)
831 : {
832 7333 : segment_info *n;
833 :
834 43387 : for (n = current_segment; n; n = n->next)
835 : {
836 36063 : if (n->sym == symbol)
837 : return n;
838 : }
839 :
840 : return NULL;
841 : }
842 :
843 :
844 : /* Given an expression node, make sure it is a constant integer and return
845 : the mpz_t value. */
846 :
847 : static mpz_t *
848 6084 : get_mpz (gfc_expr *e)
849 : {
850 :
851 0 : if (e->expr_type != EXPR_CONSTANT)
852 0 : gfc_internal_error ("get_mpz(): Not an integer constant");
853 :
854 6084 : return &e->value.integer;
855 : }
856 :
857 :
858 : /* Given an array specification and an array reference, figure out the
859 : array element number (zero based). Bounds and elements are guaranteed
860 : to be constants. If something goes wrong we generate an error and
861 : return zero. */
862 :
863 : static HOST_WIDE_INT
864 1427 : element_number (gfc_array_ref *ar)
865 : {
866 1427 : mpz_t multiplier, offset, extent, n;
867 1427 : gfc_array_spec *as;
868 1427 : HOST_WIDE_INT i, rank;
869 :
870 1427 : as = ar->as;
871 1427 : rank = as->rank;
872 1427 : mpz_init_set_ui (multiplier, 1);
873 1427 : mpz_init_set_ui (offset, 0);
874 1427 : mpz_init (extent);
875 1427 : mpz_init (n);
876 :
877 4291 : for (i = 0; i < rank; i++)
878 : {
879 1437 : if (ar->dimen_type[i] != DIMEN_ELEMENT)
880 0 : gfc_internal_error ("element_number(): Bad dimension type");
881 :
882 1437 : if (as && as->lower[i])
883 1436 : mpz_sub (n, *get_mpz (ar->start[i]), *get_mpz (as->lower[i]));
884 : else
885 1 : mpz_sub_ui (n, *get_mpz (ar->start[i]), 1);
886 :
887 1437 : mpz_mul (n, n, multiplier);
888 1437 : mpz_add (offset, offset, n);
889 :
890 1437 : if (as && as->upper[i] && as->lower[i])
891 : {
892 1436 : mpz_sub (extent, *get_mpz (as->upper[i]), *get_mpz (as->lower[i]));
893 1436 : mpz_add_ui (extent, extent, 1);
894 : }
895 : else
896 1 : mpz_set_ui (extent, 0);
897 :
898 1437 : if (mpz_sgn (extent) < 0)
899 0 : mpz_set_ui (extent, 0);
900 :
901 1437 : mpz_mul (multiplier, multiplier, extent);
902 : }
903 :
904 1427 : i = mpz_get_ui (offset);
905 :
906 1427 : mpz_clear (multiplier);
907 1427 : mpz_clear (offset);
908 1427 : mpz_clear (extent);
909 1427 : mpz_clear (n);
910 :
911 1427 : return i;
912 : }
913 :
914 :
915 : /* Given a single element of an equivalence list, figure out the offset
916 : from the base symbol. For simple variables or full arrays, this is
917 : simply zero. For an array element we have to calculate the array
918 : element number and multiply by the element size. For a substring we
919 : have to calculate the further reference. */
920 :
921 : static HOST_WIDE_INT
922 3126 : calculate_offset (gfc_expr *e)
923 : {
924 3126 : HOST_WIDE_INT n, element_size, offset;
925 3126 : gfc_typespec *element_type;
926 3126 : gfc_ref *reference;
927 :
928 3126 : offset = 0;
929 3126 : element_type = &e->symtree->n.sym->ts;
930 :
931 5320 : for (reference = e->ref; reference; reference = reference->next)
932 2194 : switch (reference->type)
933 : {
934 1855 : case REF_ARRAY:
935 1855 : switch (reference->u.ar.type)
936 : {
937 : case AR_FULL:
938 : break;
939 :
940 1427 : case AR_ELEMENT:
941 1427 : n = element_number (&reference->u.ar);
942 1427 : if (element_type->type == BT_CHARACTER)
943 221 : gfc_conv_const_charlen (element_type->u.cl);
944 1427 : element_size =
945 1427 : int_size_in_bytes (gfc_typenode_for_spec (element_type));
946 1427 : offset += n * element_size;
947 1427 : break;
948 :
949 0 : default:
950 0 : gfc_error ("Bad array reference at %L", &e->where);
951 : }
952 : break;
953 339 : case REF_SUBSTRING:
954 339 : if (reference->u.ss.start != NULL)
955 339 : offset += mpz_get_ui (*get_mpz (reference->u.ss.start)) - 1;
956 : break;
957 0 : default:
958 0 : gfc_error ("Illegal reference type at %L as EQUIVALENCE object",
959 : &e->where);
960 : }
961 3126 : return offset;
962 : }
963 :
964 :
965 : /* Add a new segment_info structure to the current segment. eq1 is already
966 : in the list, eq2 is not. */
967 :
968 : static void
969 1561 : new_condition (segment_info *v, gfc_equiv *eq1, gfc_equiv *eq2)
970 : {
971 1561 : HOST_WIDE_INT offset1, offset2;
972 1561 : segment_info *a;
973 :
974 1561 : offset1 = calculate_offset (eq1->expr);
975 1561 : offset2 = calculate_offset (eq2->expr);
976 :
977 3122 : a = get_segment_info (eq2->expr->symtree->n.sym,
978 1561 : v->offset + offset1 - offset2);
979 :
980 1561 : current_segment = add_segments (current_segment, a);
981 1561 : }
982 :
983 :
984 : /* Given two equivalence structures that are both already in the list, make
985 : sure that this new condition is not violated, generating an error if it
986 : is. */
987 :
988 : static void
989 2 : confirm_condition (segment_info *s1, gfc_equiv *eq1, segment_info *s2,
990 : gfc_equiv *eq2)
991 : {
992 2 : HOST_WIDE_INT offset1, offset2;
993 :
994 2 : offset1 = calculate_offset (eq1->expr);
995 2 : offset2 = calculate_offset (eq2->expr);
996 :
997 2 : if (s1->offset + offset1 != s2->offset + offset2)
998 2 : gfc_error ("Inconsistent equivalence rules involving %qs at %L and "
999 2 : "%qs at %L", s1->sym->name, &s1->sym->declared_at,
1000 2 : s2->sym->name, &s2->sym->declared_at);
1001 2 : }
1002 :
1003 :
1004 : /* Process a new equivalence condition. eq1 is know to be in segment f.
1005 : If eq2 is also present then confirm that the condition holds.
1006 : Otherwise add a new variable to the segment list. */
1007 :
1008 : static void
1009 1563 : add_condition (segment_info *f, gfc_equiv *eq1, gfc_equiv *eq2)
1010 : {
1011 1563 : segment_info *n;
1012 :
1013 1563 : n = find_segment_info (eq2->expr->symtree->n.sym);
1014 :
1015 1563 : if (n == NULL)
1016 1561 : new_condition (f, eq1, eq2);
1017 : else
1018 2 : confirm_condition (f, eq1, n, eq2);
1019 1563 : }
1020 :
1021 : static void
1022 44745 : accumulate_equivalence_attributes (symbol_attribute *dummy_symbol, gfc_equiv *e)
1023 : {
1024 44745 : symbol_attribute attr = e->expr->symtree->n.sym->attr;
1025 :
1026 44745 : dummy_symbol->dummy |= attr.dummy;
1027 44745 : dummy_symbol->pointer |= attr.pointer;
1028 44745 : dummy_symbol->target |= attr.target;
1029 44745 : dummy_symbol->external |= attr.external;
1030 44745 : dummy_symbol->intrinsic |= attr.intrinsic;
1031 44745 : dummy_symbol->allocatable |= attr.allocatable;
1032 44745 : dummy_symbol->elemental |= attr.elemental;
1033 44745 : dummy_symbol->recursive |= attr.recursive;
1034 44745 : dummy_symbol->in_common |= attr.in_common;
1035 44745 : dummy_symbol->result |= attr.result;
1036 44745 : dummy_symbol->in_namelist |= attr.in_namelist;
1037 44745 : dummy_symbol->optional |= attr.optional;
1038 44745 : dummy_symbol->entry |= attr.entry;
1039 44745 : dummy_symbol->function |= attr.function;
1040 44745 : dummy_symbol->subroutine |= attr.subroutine;
1041 44745 : dummy_symbol->dimension |= attr.dimension;
1042 44745 : dummy_symbol->in_equivalence |= attr.in_equivalence;
1043 44745 : dummy_symbol->use_assoc |= attr.use_assoc;
1044 44745 : dummy_symbol->cray_pointer |= attr.cray_pointer;
1045 44745 : dummy_symbol->cray_pointee |= attr.cray_pointee;
1046 44745 : dummy_symbol->data |= attr.data;
1047 44745 : dummy_symbol->value |= attr.value;
1048 44745 : dummy_symbol->volatile_ |= attr.volatile_;
1049 44745 : dummy_symbol->is_protected |= attr.is_protected;
1050 44745 : dummy_symbol->is_bind_c |= attr.is_bind_c;
1051 44745 : dummy_symbol->procedure |= attr.procedure;
1052 44745 : dummy_symbol->proc_pointer |= attr.proc_pointer;
1053 44745 : dummy_symbol->abstract |= attr.abstract;
1054 44745 : dummy_symbol->asynchronous |= attr.asynchronous;
1055 44745 : dummy_symbol->codimension |= attr.codimension;
1056 44745 : dummy_symbol->contiguous |= attr.contiguous;
1057 44745 : dummy_symbol->generic |= attr.generic;
1058 44745 : dummy_symbol->automatic |= attr.automatic;
1059 44745 : dummy_symbol->threadprivate |= attr.threadprivate;
1060 44745 : dummy_symbol->omp_groupprivate |= attr.omp_groupprivate;
1061 44745 : dummy_symbol->omp_declare_target |= attr.omp_declare_target;
1062 44745 : dummy_symbol->omp_declare_target_link |= attr.omp_declare_target_link;
1063 44745 : dummy_symbol->omp_declare_target_local |= attr.omp_declare_target_local;
1064 44745 : dummy_symbol->oacc_declare_copyin |= attr.oacc_declare_copyin;
1065 44745 : dummy_symbol->oacc_declare_create |= attr.oacc_declare_create;
1066 44745 : dummy_symbol->oacc_declare_deviceptr |= attr.oacc_declare_deviceptr;
1067 44745 : dummy_symbol->oacc_declare_device_resident
1068 44745 : |= attr.oacc_declare_device_resident;
1069 :
1070 : /* Not strictly correct, but probably close enough. */
1071 44745 : if (attr.save > dummy_symbol->save)
1072 691 : dummy_symbol->save = attr.save;
1073 44745 : if (attr.access > dummy_symbol->access)
1074 4 : dummy_symbol->access = attr.access;
1075 44745 : }
1076 :
1077 : /* Given a segment element, search through the equivalence lists for unused
1078 : conditions that involve the symbol. Add these rules to the segment. */
1079 :
1080 : static bool
1081 8105 : find_equivalence (segment_info *n)
1082 : {
1083 8105 : gfc_equiv *e1, *e2, *eq;
1084 8105 : bool found;
1085 :
1086 8105 : found = false;
1087 :
1088 31012 : for (e1 = n->sym->ns->equiv; e1; e1 = e1->next)
1089 : {
1090 22907 : eq = NULL;
1091 :
1092 : /* Search the equivalence list, including the root (first) element
1093 : for the symbol that owns the segment. */
1094 22907 : symbol_attribute dummy_symbol;
1095 22907 : memset (&dummy_symbol, 0, sizeof (dummy_symbol));
1096 66136 : for (e2 = e1; e2; e2 = e2->eq)
1097 : {
1098 44745 : accumulate_equivalence_attributes (&dummy_symbol, e2);
1099 44745 : if (!e2->used && e2->expr->symtree->n.sym == n->sym)
1100 : {
1101 : eq = e2;
1102 : break;
1103 : }
1104 : }
1105 :
1106 22907 : gfc_check_conflict (&dummy_symbol, e1->expr->symtree->name, &e1->expr->where);
1107 :
1108 : /* Go to the next root element. */
1109 22907 : if (eq == NULL)
1110 21391 : continue;
1111 :
1112 1516 : eq->used = 1;
1113 :
1114 : /* Now traverse the equivalence list matching the offsets. */
1115 4595 : for (e2 = e1; e2; e2 = e2->eq)
1116 : {
1117 3079 : if (!e2->used && e2 != eq)
1118 : {
1119 1563 : add_condition (n, eq, e2);
1120 1563 : e2->used = 1;
1121 1563 : found = true;
1122 : }
1123 : }
1124 : }
1125 8105 : return found;
1126 : }
1127 :
1128 :
1129 : /* Add all symbols equivalenced within a segment. We need to scan the
1130 : segment list multiple times to include indirect equivalences. Since
1131 : a new segment_info can inserted at the beginning of the segment list,
1132 : depending on its offset, we have to force a final pass through the
1133 : loop by demanding that completion sees a pass with no matches; i.e.,
1134 : all symbols with equiv_built set and no new equivalences found. */
1135 :
1136 : static void
1137 6556 : add_equivalences (bool *saw_equiv)
1138 : {
1139 6556 : segment_info *f;
1140 6556 : bool more = true;
1141 :
1142 14268 : while (more)
1143 : {
1144 7712 : more = false;
1145 17703 : for (f = current_segment; f; f = f->next)
1146 : {
1147 9991 : if (!f->sym->equiv_built)
1148 : {
1149 8105 : f->sym->equiv_built = 1;
1150 8105 : bool seen_one = find_equivalence (f);
1151 8105 : if (seen_one)
1152 : {
1153 1163 : *saw_equiv = true;
1154 1163 : more = true;
1155 : }
1156 : }
1157 : }
1158 : }
1159 :
1160 : /* Add a copy of this segment list to the namespace. */
1161 6556 : copy_equiv_list_to_ns (current_segment);
1162 6556 : }
1163 :
1164 :
1165 : /* Returns the offset necessary to properly align the current equivalence.
1166 : Sets *palign to the required alignment. */
1167 :
1168 : static HOST_WIDE_INT
1169 6538 : align_segment (unsigned HOST_WIDE_INT *palign)
1170 : {
1171 6538 : segment_info *s;
1172 6538 : unsigned HOST_WIDE_INT offset;
1173 6538 : unsigned HOST_WIDE_INT max_align;
1174 6538 : unsigned HOST_WIDE_INT this_align;
1175 6538 : unsigned HOST_WIDE_INT this_offset;
1176 :
1177 6538 : max_align = 1;
1178 6538 : offset = 0;
1179 14637 : for (s = current_segment; s; s = s->next)
1180 : {
1181 8099 : this_align = TYPE_ALIGN_UNIT (s->field);
1182 8099 : if (s->offset & (this_align - 1))
1183 : {
1184 : /* Field is misaligned. */
1185 128 : this_offset = this_align - ((s->offset + offset) & (this_align - 1));
1186 128 : if (this_offset & (max_align - 1))
1187 : {
1188 : /* Aligning this field would misalign a previous field. */
1189 0 : gfc_error ("The equivalence set for variable %qs "
1190 : "declared at %L violates alignment requirements",
1191 0 : s->sym->name, &s->sym->declared_at);
1192 : }
1193 128 : offset += this_offset;
1194 : }
1195 8099 : max_align = this_align;
1196 : }
1197 6538 : if (palign)
1198 6538 : *palign = max_align;
1199 6538 : return offset;
1200 : }
1201 :
1202 :
1203 : /* Adjust segment offsets by the given amount. */
1204 :
1205 : static void
1206 6556 : apply_segment_offset (segment_info *s, HOST_WIDE_INT offset)
1207 : {
1208 14673 : for (; s; s = s->next)
1209 8117 : s->offset += offset;
1210 0 : }
1211 :
1212 :
1213 : /* Lay out a symbol in a common block. If the symbol has already been seen
1214 : then check the location is consistent. Otherwise create segments
1215 : for that symbol and all the symbols equivalenced with it. */
1216 :
1217 : /* Translate a single common block. */
1218 :
1219 : static void
1220 1959 : translate_common (gfc_common_head *common, gfc_symbol *var_list)
1221 : {
1222 1959 : gfc_symbol *sym;
1223 1959 : segment_info *s;
1224 1959 : segment_info *common_segment;
1225 1959 : HOST_WIDE_INT offset;
1226 1959 : HOST_WIDE_INT current_offset;
1227 1959 : unsigned HOST_WIDE_INT align;
1228 1959 : bool saw_equiv;
1229 :
1230 1959 : common_segment = NULL;
1231 1959 : offset = 0;
1232 1959 : current_offset = 0;
1233 1959 : align = 1;
1234 1959 : saw_equiv = false;
1235 :
1236 1959 : if (var_list && var_list->attr.omp_allocate)
1237 6 : gfc_error ("Sorry, !$OMP allocate for COMMON block variable %qs at %L "
1238 6 : "not supported", common->name, &common->where);
1239 :
1240 : /* Add symbols to the segment. */
1241 7729 : for (sym = var_list; sym; sym = sym->common_next)
1242 : {
1243 5770 : current_segment = common_segment;
1244 5770 : s = find_segment_info (sym);
1245 :
1246 : /* Symbol has already been added via an equivalence. Multiple
1247 : use associations of the same common block result in equiv_built
1248 : being set but no information about the symbol in the segment. */
1249 5770 : if (s && sym->equiv_built)
1250 : {
1251 : /* Ensure the current location is properly aligned. */
1252 7 : align = TYPE_ALIGN_UNIT (s->field);
1253 7 : current_offset = (current_offset + align - 1) &~ (align - 1);
1254 :
1255 : /* Verify that it ended up where we expect it. */
1256 7 : if (s->offset != current_offset)
1257 : {
1258 1 : gfc_error ("Equivalence for %qs does not match ordering of "
1259 : "COMMON %qs at %L", sym->name,
1260 1 : common->name, &common->where);
1261 : }
1262 : }
1263 : else
1264 : {
1265 : /* A symbol we haven't seen before. */
1266 5763 : s = current_segment = get_segment_info (sym, current_offset);
1267 :
1268 : /* Add all objects directly or indirectly equivalenced with this
1269 : symbol. */
1270 5763 : add_equivalences (&saw_equiv);
1271 :
1272 5763 : if (current_segment->offset < 0)
1273 0 : gfc_error ("The equivalence set for %qs cause an invalid "
1274 : "extension to COMMON %qs at %L", sym->name,
1275 0 : common->name, &common->where);
1276 :
1277 5763 : if (flag_align_commons)
1278 5745 : offset = align_segment (&align);
1279 :
1280 5763 : if (offset)
1281 : {
1282 : /* The required offset conflicts with previous alignment
1283 : requirements. Insert padding immediately before this
1284 : segment. */
1285 37 : if (warn_align_commons)
1286 : {
1287 35 : if (strcmp (common->name, BLANK_COMMON_NAME))
1288 23 : gfc_warning (OPT_Walign_commons,
1289 : "Padding of %d bytes required before %qs in "
1290 : "COMMON %qs at %L; reorder elements or use "
1291 : "%<-fno-align-commons%>", (int)offset,
1292 23 : s->sym->name, common->name, &common->where);
1293 : else
1294 12 : gfc_warning (OPT_Walign_commons,
1295 : "Padding of %d bytes required before %qs in "
1296 : "COMMON at %L; reorder elements or use "
1297 : "%<-fno-align-commons%>", (int)offset,
1298 12 : s->sym->name, &common->where);
1299 : }
1300 : }
1301 :
1302 : /* Apply the offset to the new segments. */
1303 5763 : apply_segment_offset (current_segment, offset);
1304 5763 : current_offset += offset;
1305 :
1306 : /* Add the new segments to the common block. */
1307 5763 : common_segment = add_segments (common_segment, current_segment);
1308 : }
1309 :
1310 : /* The offset of the next common variable. */
1311 5770 : current_offset += s->length;
1312 : }
1313 :
1314 1959 : if (common_segment == NULL)
1315 : {
1316 1 : gfc_error ("COMMON %qs at %L does not exist",
1317 1 : common->name, &common->where);
1318 1 : return;
1319 : }
1320 :
1321 1958 : if (common_segment->offset != 0 && warn_align_commons)
1322 : {
1323 0 : if (strcmp (common->name, BLANK_COMMON_NAME))
1324 0 : gfc_warning (OPT_Walign_commons,
1325 : "COMMON %qs at %L requires %d bytes of padding; "
1326 : "reorder elements or use %<-fno-align-commons%>",
1327 : common->name, &common->where, (int)common_segment->offset);
1328 : else
1329 0 : gfc_warning (OPT_Walign_commons,
1330 : "COMMON at %L requires %d bytes of padding; "
1331 : "reorder elements or use %<-fno-align-commons%>",
1332 : &common->where, (int)common_segment->offset);
1333 : }
1334 :
1335 1958 : create_common (common, common_segment, saw_equiv);
1336 : }
1337 :
1338 :
1339 : /* Create a new block for each merged equivalence list. */
1340 :
1341 : static void
1342 97362 : finish_equivalences (gfc_namespace *ns)
1343 : {
1344 97362 : gfc_equiv *z, *y;
1345 97362 : gfc_symbol *sym;
1346 97362 : gfc_common_head * c;
1347 97362 : HOST_WIDE_INT offset;
1348 97362 : unsigned HOST_WIDE_INT align;
1349 97362 : bool dummy;
1350 :
1351 98878 : for (z = ns->equiv; z; z = z->next)
1352 2269 : for (y = z->eq; y; y = y->eq)
1353 : {
1354 1546 : if (y->used)
1355 753 : continue;
1356 793 : sym = z->expr->symtree->n.sym;
1357 793 : current_segment = get_segment_info (sym, 0);
1358 :
1359 : /* All objects directly or indirectly equivalenced with this
1360 : symbol. */
1361 793 : add_equivalences (&dummy);
1362 :
1363 : /* Align the block. */
1364 793 : offset = align_segment (&align);
1365 :
1366 : /* Ensure all offsets are positive. */
1367 793 : offset -= current_segment->offset & ~(align - 1);
1368 :
1369 793 : apply_segment_offset (current_segment, offset);
1370 :
1371 : /* Create the decl. If this is a module equivalence, it has a
1372 : unique name, pointed to by z->module. This is written to a
1373 : gfc_common_header to push create_common into using
1374 : build_common_decl, so that the equivalence appears as an
1375 : external symbol. Otherwise, a local declaration is built using
1376 : build_equiv_decl. */
1377 793 : if (z->module)
1378 : {
1379 105 : c = gfc_get_common_head ();
1380 : /* We've lost the real location, so use the location of the
1381 : enclosing procedure. If we're in a BLOCK DATA block, then
1382 : use the location in the sym_root. */
1383 105 : if (ns->proc_name)
1384 104 : c->where = ns->proc_name->declared_at;
1385 1 : else if (ns->is_block_data)
1386 1 : c->where = ns->sym_root->n.sym->declared_at;
1387 :
1388 105 : size_t len = strlen (z->module);
1389 105 : gcc_assert (len < sizeof (c->name));
1390 105 : memcpy (c->name, z->module, len);
1391 105 : c->name[len] = '\0';
1392 : }
1393 : else
1394 : c = NULL;
1395 :
1396 793 : create_common (c, current_segment, true);
1397 793 : break;
1398 : }
1399 97362 : }
1400 :
1401 :
1402 : /* Work function for translating a named common block. */
1403 :
1404 : static void
1405 1772 : named_common (gfc_symtree *st)
1406 : {
1407 1772 : translate_common (st->n.common, st->n.common->head);
1408 1772 : }
1409 :
1410 :
1411 : /* Translate the common blocks in a namespace. Unlike other variables,
1412 : these have to be created before code, because the backend_decl depends
1413 : on the rest of the common block. */
1414 :
1415 : void
1416 97362 : gfc_trans_common (gfc_namespace *ns)
1417 : {
1418 97362 : gfc_common_head *c;
1419 :
1420 : /* Translate the blank common block. */
1421 97362 : if (ns->blank_common.head != NULL)
1422 : {
1423 187 : c = gfc_get_common_head ();
1424 187 : c->where = ns->blank_common.head->common_head->where;
1425 187 : strcpy (c->name, BLANK_COMMON_NAME);
1426 187 : translate_common (c, ns->blank_common.head);
1427 : }
1428 :
1429 : /* Translate all named common blocks. */
1430 97362 : gfc_traverse_symtree (ns->common_root, named_common);
1431 :
1432 : /* Translate local equivalence. */
1433 97362 : finish_equivalences (ns);
1434 :
1435 : /* Commit the newly created symbols for common blocks and module
1436 : equivalences. */
1437 97362 : gfc_commit_symbols ();
1438 97362 : }
|
