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