1 /* Common block and equivalence list handling
2 Copyright (C) 2000-2022 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 *
get_segment_info(gfc_symbol * sym,HOST_WIDE_INT offset)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
copy_equiv_list_to_ns(segment_info * c)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 *
add_segments(segment_info * list,segment_info * v)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
gfc_sym_mangled_common_id(gfc_common_head * com)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 (com->name);
251 gcc_assert (len < sizeof (name));
252 strcpy (name, 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 (name, BLANK_COMMON_NAME) == 0)
259 return get_identifier (name);
260
261 if (flag_underscoring)
262 {
263 has_underscore = strchr (name, '_') != 0;
264 if (flag_second_underscore && has_underscore)
265 snprintf (mangled_name, sizeof mangled_name, "%s__", name);
266 else
267 snprintf (mangled_name, sizeof mangled_name, "%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
build_field(segment_info * h,tree union_type,record_layout_info rli)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
build_equiv_decl(tree union_type,bool is_init,bool is_saved,bool is_auto)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 (name, 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
build_common_decl(gfc_common_head * com,tree union_type,bool is_init)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(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 (com->name, BLANK_COMMON_NAME))
411 gfc_warning (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), 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
get_init_field(segment_info * head,tree union_type,tree * field_init,record_layout_info rli)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 (data, '\0', (size_t)length);
567 memset (chk, '\0', (size_t)length);
568 for (s = head; s; s = s->next)
569 if (s->sym->value)
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 (data);
584 free (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
create_common(gfc_common_head * com,segment_info * head,bool saw_equiv)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, 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 (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 (input_location, COMPONENT_REF,
770 TREE_TYPE (s->field), decl, s->field, NULL_TREE);
771 if (TREE_THIS_VOLATILE (s->field))
772 TREE_THIS_VOLATILE (comp) = 1;
773 SET_DECL_VALUE_EXPR (var_decl, comp);
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 (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 *
find_segment_info(gfc_symbol * symbol)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 *
get_mpz(gfc_expr * e)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
element_number(gfc_array_ref * ar)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 (ar->start[i]), *get_mpz (as->lower[i]));
851 else
852 mpz_sub_ui (n, *get_mpz (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 (as->upper[i]), *get_mpz (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 (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
calculate_offset(gfc_expr * e)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 (&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 (*get_mpz (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
new_condition(segment_info * v,gfc_equiv * eq1,gfc_equiv * eq2)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 (eq1->expr);
942 offset2 = calculate_offset (eq2->expr);
943
944 a = get_segment_info (eq2->expr->symtree->n.sym,
945 v->offset + offset1 - offset2);
946
947 current_segment = add_segments (current_segment, 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
confirm_condition(segment_info * s1,gfc_equiv * eq1,segment_info * s2,gfc_equiv * eq2)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 (eq1->expr);
962 offset2 = calculate_offset (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
add_condition(segment_info * f,gfc_equiv * eq1,gfc_equiv * eq2)976 add_condition (segment_info *f, gfc_equiv *eq1, gfc_equiv *eq2)
977 {
978 segment_info *n;
979
980 n = find_segment_info (eq2->expr->symtree->n.sym);
981
982 if (n == NULL)
983 new_condition (f, eq1, eq2);
984 else
985 confirm_condition (f, eq1, n, eq2);
986 }
987
988 static void
accumulate_equivalence_attributes(symbol_attribute * dummy_symbol,gfc_equiv * e)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
find_equivalence(segment_info * n)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 (&dummy_symbol, 0, sizeof (dummy_symbol));
1061 for (e2 = e1; e2; e2 = e2->eq)
1062 {
1063 accumulate_equivalence_attributes (&dummy_symbol, 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 (n, eq, 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
add_equivalences(bool * saw_equiv)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 (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 (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
align_segment(unsigned HOST_WIDE_INT * palign)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
apply_segment_offset(segment_info * s,HOST_WIDE_INT offset)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
translate_common(gfc_common_head * common,gfc_symbol * var_list)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 (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, current_offset);
1228
1229 /* Add all objects directly or indirectly equivalenced with this
1230 symbol. */
1231 add_equivalences (&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 (&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 (common->name, BLANK_COMMON_NAME))
1249 gfc_warning (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_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 (current_segment, offset);
1265 current_offset += offset;
1266
1267 /* Add the new segments to the common block. */
1268 common_segment = add_segments (common_segment, current_segment);
1269 }
1270
1271 /* The offset of the next common variable. */
1272 current_offset += s->length;
1273 }
1274
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 (common->name, BLANK_COMMON_NAME))
1285 gfc_warning (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_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 (common, common_segment, saw_equiv);
1297 }
1298
1299
1300 /* Create a new block for each merged equivalence list. */
1301
1302 static void
finish_equivalences(gfc_namespace * ns)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, 0);
1319
1320 /* All objects directly or indirectly equivalenced with this
1321 symbol. */
1322 add_equivalences (&dummy);
1323
1324 /* Align the block. */
1325 offset = align_segment (&align);
1326
1327 /* Ensure all offsets are positive. */
1328 offset -= current_segment->offset & ~(align - 1);
1329
1330 apply_segment_offset (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 (z->module);
1350 gcc_assert (len < sizeof (c->name));
1351 memcpy (c->name, z->module, len);
1352 c->name[len] = '\0';
1353 }
1354 else
1355 c = NULL;
1356
1357 create_common (c, current_segment, true);
1358 break;
1359 }
1360 }
1361
1362
1363 /* Work function for translating a named common block. */
1364
1365 static void
named_common(gfc_symtree * st)1366 named_common (gfc_symtree *st)
1367 {
1368 translate_common (st->n.common, 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
gfc_trans_common(gfc_namespace * ns)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 (c->name, BLANK_COMMON_NAME);
1387 translate_common (c, 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