2015-12-18 Paul Thomas <pault@gcc.gnu.org>
[official-gcc.git] / gcc / fortran / trans-common.c
blobbbbc7267517a6ed40d43f0353d5e13ab1da1e160
1 /* Common block and equivalence list handling
2 Copyright (C) 2000-2015 Free Software Foundation, Inc.
3 Contributed by Canqun Yang <canqun@nudt.edu.cn>
5 This file is part of GCC.
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.
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.
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/>. */
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.
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.
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.
32 So if two variables are equivalenced, they just point to a common
33 area in memory.
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.
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.
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.
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
66 EQUIVALENCE(B(2), C(3))
67 we have
68 B + 2*size of B's elements = C + 3*size of C's elements.
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.
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.
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.
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. */
95 #include "config.h"
96 #include "system.h"
97 #include "coretypes.h"
98 #include "tm.h"
99 #include "tree.h"
100 #include "gfortran.h"
101 #include "trans.h"
102 #include "stringpool.h"
104 #include <map>
106 #include "fold-const.h"
107 #include "stor-layout.h"
108 #include "varasm.h"
109 #include "trans-types.h"
110 #include "trans-const.h"
111 #include "target-memory.h"
114 /* Holds a single variable in an equivalence set. */
115 typedef struct segment_info
117 gfc_symbol *sym;
118 HOST_WIDE_INT offset;
119 HOST_WIDE_INT length;
120 /* This will contain the field type until the field is created. */
121 tree field;
122 struct segment_info *next;
123 } segment_info;
125 static segment_info * current_segment;
127 /* Store decl of all common blocks in this translation unit; the first
128 tree is the identifier. */
129 static std::map<tree, tree> gfc_map_of_all_commons;
132 /* Make a segment_info based on a symbol. */
134 static segment_info *
135 get_segment_info (gfc_symbol * sym, HOST_WIDE_INT offset)
137 segment_info *s;
139 /* Make sure we've got the character length. */
140 if (sym->ts.type == BT_CHARACTER)
141 gfc_conv_const_charlen (sym->ts.u.cl);
143 /* Create the segment_info and fill it in. */
144 s = XCNEW (segment_info);
145 s->sym = sym;
146 /* We will use this type when building the segment aggregate type. */
147 s->field = gfc_sym_type (sym);
148 s->length = int_size_in_bytes (s->field);
149 s->offset = offset;
151 return s;
155 /* Add a copy of a segment list to the namespace. This is specifically for
156 equivalence segments, so that dependency checking can be done on
157 equivalence group members. */
159 static void
160 copy_equiv_list_to_ns (segment_info *c)
162 segment_info *f;
163 gfc_equiv_info *s;
164 gfc_equiv_list *l;
166 l = XCNEW (gfc_equiv_list);
168 l->next = c->sym->ns->equiv_lists;
169 c->sym->ns->equiv_lists = l;
171 for (f = c; f; f = f->next)
173 s = XCNEW (gfc_equiv_info);
174 s->next = l->equiv;
175 l->equiv = s;
176 s->sym = f->sym;
177 s->offset = f->offset;
178 s->length = f->length;
183 /* Add combine segment V and segment LIST. */
185 static segment_info *
186 add_segments (segment_info *list, segment_info *v)
188 segment_info *s;
189 segment_info *p;
190 segment_info *next;
192 p = NULL;
193 s = list;
195 while (v)
197 /* Find the location of the new element. */
198 while (s)
200 if (v->offset < s->offset)
201 break;
202 if (v->offset == s->offset
203 && v->length <= s->length)
204 break;
206 p = s;
207 s = s->next;
210 /* Insert the new element in between p and s. */
211 next = v->next;
212 v->next = s;
213 if (p == NULL)
214 list = v;
215 else
216 p->next = v;
218 p = v;
219 v = next;
222 return list;
226 /* Construct mangled common block name from symbol name. */
228 /* We need the bind(c) flag to tell us how/if we should mangle the symbol
229 name. There are few calls to this function, so few places that this
230 would need to be added. At the moment, there is only one call, in
231 build_common_decl(). We can't attempt to look up the common block
232 because we may be building it for the first time and therefore, it won't
233 be in the common_root. We also need the binding label, if it's bind(c).
234 Therefore, send in the pointer to the common block, so whatever info we
235 have so far can be used. All of the necessary info should be available
236 in the gfc_common_head by now, so it should be accurate to test the
237 isBindC flag and use the binding label given if it is bind(c).
239 We may NOT know yet if it's bind(c) or not, but we can try at least.
240 Will have to figure out what to do later if it's labeled bind(c)
241 after this is called. */
243 static tree
244 gfc_sym_mangled_common_id (gfc_common_head *com)
246 int has_underscore;
247 char mangled_name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
248 char name[GFC_MAX_SYMBOL_LEN + 1];
250 /* Get the name out of the common block pointer. */
251 strcpy (name, com->name);
253 /* If we're suppose to do a bind(c). */
254 if (com->is_bind_c == 1 && com->binding_label)
255 return get_identifier (com->binding_label);
257 if (strcmp (name, BLANK_COMMON_NAME) == 0)
258 return get_identifier (name);
260 if (flag_underscoring)
262 has_underscore = strchr (name, '_') != 0;
263 if (flag_second_underscore && has_underscore)
264 snprintf (mangled_name, sizeof mangled_name, "%s__", name);
265 else
266 snprintf (mangled_name, sizeof mangled_name, "%s_", name);
268 return get_identifier (mangled_name);
270 else
271 return get_identifier (name);
275 /* Build a field declaration for a common variable or a local equivalence
276 object. */
278 static void
279 build_field (segment_info *h, tree union_type, record_layout_info rli)
281 tree field;
282 tree name;
283 HOST_WIDE_INT offset = h->offset;
284 unsigned HOST_WIDE_INT desired_align, known_align;
286 name = get_identifier (h->sym->name);
287 field = build_decl (h->sym->declared_at.lb->location,
288 FIELD_DECL, name, h->field);
289 known_align = (offset & -offset) * BITS_PER_UNIT;
290 if (known_align == 0 || known_align > BIGGEST_ALIGNMENT)
291 known_align = BIGGEST_ALIGNMENT;
293 desired_align = update_alignment_for_field (rli, field, known_align);
294 if (desired_align > known_align)
295 DECL_PACKED (field) = 1;
297 DECL_FIELD_CONTEXT (field) = union_type;
298 DECL_FIELD_OFFSET (field) = size_int (offset);
299 DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node;
300 SET_DECL_OFFSET_ALIGN (field, known_align);
302 rli->offset = size_binop (MAX_EXPR, rli->offset,
303 size_binop (PLUS_EXPR,
304 DECL_FIELD_OFFSET (field),
305 DECL_SIZE_UNIT (field)));
306 /* If this field is assigned to a label, we create another two variables.
307 One will hold the address of target label or format label. The other will
308 hold the length of format label string. */
309 if (h->sym->attr.assign)
311 tree len;
312 tree addr;
314 gfc_allocate_lang_decl (field);
315 GFC_DECL_ASSIGN (field) = 1;
316 len = gfc_create_var_np (gfc_charlen_type_node,h->sym->name);
317 addr = gfc_create_var_np (pvoid_type_node, h->sym->name);
318 TREE_STATIC (len) = 1;
319 TREE_STATIC (addr) = 1;
320 DECL_INITIAL (len) = build_int_cst (gfc_charlen_type_node, -2);
321 gfc_set_decl_location (len, &h->sym->declared_at);
322 gfc_set_decl_location (addr, &h->sym->declared_at);
323 GFC_DECL_STRING_LEN (field) = pushdecl_top_level (len);
324 GFC_DECL_ASSIGN_ADDR (field) = pushdecl_top_level (addr);
327 /* If this field is volatile, mark it. */
328 if (h->sym->attr.volatile_)
330 tree new_type;
331 TREE_THIS_VOLATILE (field) = 1;
332 TREE_SIDE_EFFECTS (field) = 1;
333 new_type = build_qualified_type (TREE_TYPE (field), TYPE_QUAL_VOLATILE);
334 TREE_TYPE (field) = new_type;
337 h->field = field;
341 /* Get storage for local equivalence. */
343 static tree
344 build_equiv_decl (tree union_type, bool is_init, bool is_saved)
346 tree decl;
347 char name[15];
348 static int serial = 0;
350 if (is_init)
352 decl = gfc_create_var (union_type, "equiv");
353 TREE_STATIC (decl) = 1;
354 GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
355 return decl;
358 snprintf (name, sizeof (name), "equiv.%d", serial++);
359 decl = build_decl (input_location,
360 VAR_DECL, get_identifier (name), union_type);
361 DECL_ARTIFICIAL (decl) = 1;
362 DECL_IGNORED_P (decl) = 1;
364 if (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
365 || is_saved)
366 TREE_STATIC (decl) = 1;
368 TREE_ADDRESSABLE (decl) = 1;
369 TREE_USED (decl) = 1;
370 GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
372 /* The source location has been lost, and doesn't really matter.
373 We need to set it to something though. */
374 gfc_set_decl_location (decl, &gfc_current_locus);
376 gfc_add_decl_to_function (decl);
378 return decl;
382 /* Get storage for common block. */
384 static tree
385 build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
387 tree decl, identifier;
389 identifier = gfc_sym_mangled_common_id (com);
390 decl = gfc_map_of_all_commons.count(identifier)
391 ? gfc_map_of_all_commons[identifier] : NULL_TREE;
393 /* Update the size of this common block as needed. */
394 if (decl != NULL_TREE)
396 tree size = TYPE_SIZE_UNIT (union_type);
398 /* Named common blocks of the same name shall be of the same size
399 in all scoping units of a program in which they appear, but
400 blank common blocks may be of different sizes. */
401 if (!tree_int_cst_equal (DECL_SIZE_UNIT (decl), size)
402 && strcmp (com->name, BLANK_COMMON_NAME))
403 gfc_warning (0, "Named COMMON block %qs at %L shall be of the "
404 "same size as elsewhere (%lu vs %lu bytes)", com->name,
405 &com->where,
406 (unsigned long) TREE_INT_CST_LOW (size),
407 (unsigned long) TREE_INT_CST_LOW (DECL_SIZE_UNIT (decl)));
409 if (tree_int_cst_lt (DECL_SIZE_UNIT (decl), size))
411 DECL_SIZE (decl) = TYPE_SIZE (union_type);
412 DECL_SIZE_UNIT (decl) = size;
413 DECL_MODE (decl) = TYPE_MODE (union_type);
414 TREE_TYPE (decl) = union_type;
415 layout_decl (decl, 0);
419 /* If this common block has been declared in a previous program unit,
420 and either it is already initialized or there is no new initialization
421 for it, just return. */
422 if ((decl != NULL_TREE) && (!is_init || DECL_INITIAL (decl)))
423 return decl;
425 /* If there is no backend_decl for the common block, build it. */
426 if (decl == NULL_TREE)
428 if (com->is_bind_c == 1 && com->binding_label)
429 decl = build_decl (input_location, VAR_DECL, identifier, union_type);
430 else
432 decl = build_decl (input_location, VAR_DECL, get_identifier (com->name),
433 union_type);
434 gfc_set_decl_assembler_name (decl, identifier);
437 TREE_PUBLIC (decl) = 1;
438 TREE_STATIC (decl) = 1;
439 DECL_IGNORED_P (decl) = 1;
440 if (!com->is_bind_c)
441 DECL_ALIGN (decl) = BIGGEST_ALIGNMENT;
442 else
444 /* Do not set the alignment for bind(c) common blocks to
445 BIGGEST_ALIGNMENT because that won't match what C does. Also,
446 for common blocks with one element, the alignment must be
447 that of the field within the common block in order to match
448 what C will do. */
449 tree field = NULL_TREE;
450 field = TYPE_FIELDS (TREE_TYPE (decl));
451 if (DECL_CHAIN (field) == NULL_TREE)
452 DECL_ALIGN (decl) = TYPE_ALIGN (TREE_TYPE (field));
454 DECL_USER_ALIGN (decl) = 0;
455 GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
457 gfc_set_decl_location (decl, &com->where);
459 if (com->threadprivate)
460 set_decl_tls_model (decl, decl_default_tls_model (decl));
462 if (com->omp_declare_target)
463 DECL_ATTRIBUTES (decl)
464 = tree_cons (get_identifier ("omp declare target"),
465 NULL_TREE, DECL_ATTRIBUTES (decl));
467 /* Place the back end declaration for this common block in
468 GLOBAL_BINDING_LEVEL. */
469 gfc_map_of_all_commons[identifier] = pushdecl_top_level (decl);
472 /* Has no initial values. */
473 if (!is_init)
475 DECL_INITIAL (decl) = NULL_TREE;
476 DECL_COMMON (decl) = 1;
477 DECL_DEFER_OUTPUT (decl) = 1;
479 else
481 DECL_INITIAL (decl) = error_mark_node;
482 DECL_COMMON (decl) = 0;
483 DECL_DEFER_OUTPUT (decl) = 0;
485 return decl;
489 /* Return a field that is the size of the union, if an equivalence has
490 overlapping initializers. Merge the initializers into a single
491 initializer for this new field, then free the old ones. */
493 static tree
494 get_init_field (segment_info *head, tree union_type, tree *field_init,
495 record_layout_info rli)
497 segment_info *s;
498 HOST_WIDE_INT length = 0;
499 HOST_WIDE_INT offset = 0;
500 unsigned HOST_WIDE_INT known_align, desired_align;
501 bool overlap = false;
502 tree tmp, field;
503 tree init;
504 unsigned char *data, *chk;
505 vec<constructor_elt, va_gc> *v = NULL;
507 tree type = unsigned_char_type_node;
508 int i;
510 /* Obtain the size of the union and check if there are any overlapping
511 initializers. */
512 for (s = head; s; s = s->next)
514 HOST_WIDE_INT slen = s->offset + s->length;
515 if (s->sym->value)
517 if (s->offset < offset)
518 overlap = true;
519 offset = slen;
521 length = length < slen ? slen : length;
524 if (!overlap)
525 return NULL_TREE;
527 /* Now absorb all the initializer data into a single vector,
528 whilst checking for overlapping, unequal values. */
529 data = XCNEWVEC (unsigned char, (size_t)length);
530 chk = XCNEWVEC (unsigned char, (size_t)length);
532 /* TODO - change this when default initialization is implemented. */
533 memset (data, '\0', (size_t)length);
534 memset (chk, '\0', (size_t)length);
535 for (s = head; s; s = s->next)
536 if (s->sym->value)
537 gfc_merge_initializers (s->sym->ts, s->sym->value,
538 &data[s->offset],
539 &chk[s->offset],
540 (size_t)s->length);
542 for (i = 0; i < length; i++)
543 CONSTRUCTOR_APPEND_ELT (v, NULL, build_int_cst (type, data[i]));
545 free (data);
546 free (chk);
548 /* Build a char[length] array to hold the initializers. Much of what
549 follows is borrowed from build_field, above. */
551 tmp = build_int_cst (gfc_array_index_type, length - 1);
552 tmp = build_range_type (gfc_array_index_type,
553 gfc_index_zero_node, tmp);
554 tmp = build_array_type (type, tmp);
555 field = build_decl (gfc_current_locus.lb->location,
556 FIELD_DECL, NULL_TREE, tmp);
558 known_align = BIGGEST_ALIGNMENT;
560 desired_align = update_alignment_for_field (rli, field, known_align);
561 if (desired_align > known_align)
562 DECL_PACKED (field) = 1;
564 DECL_FIELD_CONTEXT (field) = union_type;
565 DECL_FIELD_OFFSET (field) = size_int (0);
566 DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node;
567 SET_DECL_OFFSET_ALIGN (field, known_align);
569 rli->offset = size_binop (MAX_EXPR, rli->offset,
570 size_binop (PLUS_EXPR,
571 DECL_FIELD_OFFSET (field),
572 DECL_SIZE_UNIT (field)));
574 init = build_constructor (TREE_TYPE (field), v);
575 TREE_CONSTANT (init) = 1;
577 *field_init = init;
579 for (s = head; s; s = s->next)
581 if (s->sym->value == NULL)
582 continue;
584 gfc_free_expr (s->sym->value);
585 s->sym->value = NULL;
588 return field;
592 /* Declare memory for the common block or local equivalence, and create
593 backend declarations for all of the elements. */
595 static void
596 create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)
598 segment_info *s, *next_s;
599 tree union_type;
600 tree *field_link;
601 tree field;
602 tree field_init = NULL_TREE;
603 record_layout_info rli;
604 tree decl;
605 bool is_init = false;
606 bool is_saved = false;
608 /* Declare the variables inside the common block.
609 If the current common block contains any equivalence object, then
610 make a UNION_TYPE node, otherwise RECORD_TYPE. This will let the
611 alias analyzer work well when there is no address overlapping for
612 common variables in the current common block. */
613 if (saw_equiv)
614 union_type = make_node (UNION_TYPE);
615 else
616 union_type = make_node (RECORD_TYPE);
618 rli = start_record_layout (union_type);
619 field_link = &TYPE_FIELDS (union_type);
621 /* Check for overlapping initializers and replace them with a single,
622 artificial field that contains all the data. */
623 if (saw_equiv)
624 field = get_init_field (head, union_type, &field_init, rli);
625 else
626 field = NULL_TREE;
628 if (field != NULL_TREE)
630 is_init = true;
631 *field_link = field;
632 field_link = &DECL_CHAIN (field);
635 for (s = head; s; s = s->next)
637 build_field (s, union_type, rli);
639 /* Link the field into the type. */
640 *field_link = s->field;
641 field_link = &DECL_CHAIN (s->field);
643 /* Has initial value. */
644 if (s->sym->value)
645 is_init = true;
647 /* Has SAVE attribute. */
648 if (s->sym->attr.save)
649 is_saved = true;
652 finish_record_layout (rli, true);
654 if (com)
655 decl = build_common_decl (com, union_type, is_init);
656 else
657 decl = build_equiv_decl (union_type, is_init, is_saved);
659 if (is_init)
661 tree ctor, tmp;
662 vec<constructor_elt, va_gc> *v = NULL;
664 if (field != NULL_TREE && field_init != NULL_TREE)
665 CONSTRUCTOR_APPEND_ELT (v, field, field_init);
666 else
667 for (s = head; s; s = s->next)
669 if (s->sym->value)
671 /* Add the initializer for this field. */
672 tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts,
673 TREE_TYPE (s->field),
674 s->sym->attr.dimension,
675 s->sym->attr.pointer
676 || s->sym->attr.allocatable, false);
678 CONSTRUCTOR_APPEND_ELT (v, s->field, tmp);
682 gcc_assert (!v->is_empty ());
683 ctor = build_constructor (union_type, v);
684 TREE_CONSTANT (ctor) = 1;
685 TREE_STATIC (ctor) = 1;
686 DECL_INITIAL (decl) = ctor;
688 if (flag_checking)
690 tree field, value;
691 unsigned HOST_WIDE_INT idx;
692 FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor), idx, field, value)
693 gcc_assert (TREE_CODE (field) == FIELD_DECL);
697 /* Build component reference for each variable. */
698 for (s = head; s; s = next_s)
700 tree var_decl;
702 var_decl = build_decl (s->sym->declared_at.lb->location,
703 VAR_DECL, DECL_NAME (s->field),
704 TREE_TYPE (s->field));
705 TREE_STATIC (var_decl) = TREE_STATIC (decl);
706 /* Mark the variable as used in order to avoid warnings about
707 unused variables. */
708 TREE_USED (var_decl) = 1;
709 if (s->sym->attr.use_assoc)
710 DECL_IGNORED_P (var_decl) = 1;
711 if (s->sym->attr.target)
712 TREE_ADDRESSABLE (var_decl) = 1;
713 /* Fake variables are not visible from other translation units. */
714 TREE_PUBLIC (var_decl) = 0;
715 gfc_finish_decl_attrs (var_decl, &s->sym->attr);
717 /* To preserve identifier names in COMMON, chain to procedure
718 scope unless at top level in a module definition. */
719 if (com
720 && s->sym->ns->proc_name
721 && s->sym->ns->proc_name->attr.flavor == FL_MODULE)
722 var_decl = pushdecl_top_level (var_decl);
723 else
724 gfc_add_decl_to_function (var_decl);
726 SET_DECL_VALUE_EXPR (var_decl,
727 fold_build3_loc (input_location, COMPONENT_REF,
728 TREE_TYPE (s->field),
729 decl, s->field, NULL_TREE));
730 DECL_HAS_VALUE_EXPR_P (var_decl) = 1;
731 GFC_DECL_COMMON_OR_EQUIV (var_decl) = 1;
733 if (s->sym->attr.assign)
735 gfc_allocate_lang_decl (var_decl);
736 GFC_DECL_ASSIGN (var_decl) = 1;
737 GFC_DECL_STRING_LEN (var_decl) = GFC_DECL_STRING_LEN (s->field);
738 GFC_DECL_ASSIGN_ADDR (var_decl) = GFC_DECL_ASSIGN_ADDR (s->field);
741 s->sym->backend_decl = var_decl;
743 next_s = s->next;
744 free (s);
749 /* Given a symbol, find it in the current segment list. Returns NULL if
750 not found. */
752 static segment_info *
753 find_segment_info (gfc_symbol *symbol)
755 segment_info *n;
757 for (n = current_segment; n; n = n->next)
759 if (n->sym == symbol)
760 return n;
763 return NULL;
767 /* Given an expression node, make sure it is a constant integer and return
768 the mpz_t value. */
770 static mpz_t *
771 get_mpz (gfc_expr *e)
774 if (e->expr_type != EXPR_CONSTANT)
775 gfc_internal_error ("get_mpz(): Not an integer constant");
777 return &e->value.integer;
781 /* Given an array specification and an array reference, figure out the
782 array element number (zero based). Bounds and elements are guaranteed
783 to be constants. If something goes wrong we generate an error and
784 return zero. */
786 static HOST_WIDE_INT
787 element_number (gfc_array_ref *ar)
789 mpz_t multiplier, offset, extent, n;
790 gfc_array_spec *as;
791 HOST_WIDE_INT i, rank;
793 as = ar->as;
794 rank = as->rank;
795 mpz_init_set_ui (multiplier, 1);
796 mpz_init_set_ui (offset, 0);
797 mpz_init (extent);
798 mpz_init (n);
800 for (i = 0; i < rank; i++)
802 if (ar->dimen_type[i] != DIMEN_ELEMENT)
803 gfc_internal_error ("element_number(): Bad dimension type");
805 mpz_sub (n, *get_mpz (ar->start[i]), *get_mpz (as->lower[i]));
807 mpz_mul (n, n, multiplier);
808 mpz_add (offset, offset, n);
810 mpz_sub (extent, *get_mpz (as->upper[i]), *get_mpz (as->lower[i]));
811 mpz_add_ui (extent, extent, 1);
813 if (mpz_sgn (extent) < 0)
814 mpz_set_ui (extent, 0);
816 mpz_mul (multiplier, multiplier, extent);
819 i = mpz_get_ui (offset);
821 mpz_clear (multiplier);
822 mpz_clear (offset);
823 mpz_clear (extent);
824 mpz_clear (n);
826 return i;
830 /* Given a single element of an equivalence list, figure out the offset
831 from the base symbol. For simple variables or full arrays, this is
832 simply zero. For an array element we have to calculate the array
833 element number and multiply by the element size. For a substring we
834 have to calculate the further reference. */
836 static HOST_WIDE_INT
837 calculate_offset (gfc_expr *e)
839 HOST_WIDE_INT n, element_size, offset;
840 gfc_typespec *element_type;
841 gfc_ref *reference;
843 offset = 0;
844 element_type = &e->symtree->n.sym->ts;
846 for (reference = e->ref; reference; reference = reference->next)
847 switch (reference->type)
849 case REF_ARRAY:
850 switch (reference->u.ar.type)
852 case AR_FULL:
853 break;
855 case AR_ELEMENT:
856 n = element_number (&reference->u.ar);
857 if (element_type->type == BT_CHARACTER)
858 gfc_conv_const_charlen (element_type->u.cl);
859 element_size =
860 int_size_in_bytes (gfc_typenode_for_spec (element_type));
861 offset += n * element_size;
862 break;
864 default:
865 gfc_error ("Bad array reference at %L", &e->where);
867 break;
868 case REF_SUBSTRING:
869 if (reference->u.ss.start != NULL)
870 offset += mpz_get_ui (*get_mpz (reference->u.ss.start)) - 1;
871 break;
872 default:
873 gfc_error ("Illegal reference type at %L as EQUIVALENCE object",
874 &e->where);
876 return offset;
880 /* Add a new segment_info structure to the current segment. eq1 is already
881 in the list, eq2 is not. */
883 static void
884 new_condition (segment_info *v, gfc_equiv *eq1, gfc_equiv *eq2)
886 HOST_WIDE_INT offset1, offset2;
887 segment_info *a;
889 offset1 = calculate_offset (eq1->expr);
890 offset2 = calculate_offset (eq2->expr);
892 a = get_segment_info (eq2->expr->symtree->n.sym,
893 v->offset + offset1 - offset2);
895 current_segment = add_segments (current_segment, a);
899 /* Given two equivalence structures that are both already in the list, make
900 sure that this new condition is not violated, generating an error if it
901 is. */
903 static void
904 confirm_condition (segment_info *s1, gfc_equiv *eq1, segment_info *s2,
905 gfc_equiv *eq2)
907 HOST_WIDE_INT offset1, offset2;
909 offset1 = calculate_offset (eq1->expr);
910 offset2 = calculate_offset (eq2->expr);
912 if (s1->offset + offset1 != s2->offset + offset2)
913 gfc_error ("Inconsistent equivalence rules involving %qs at %L and "
914 "%qs at %L", s1->sym->name, &s1->sym->declared_at,
915 s2->sym->name, &s2->sym->declared_at);
919 /* Process a new equivalence condition. eq1 is know to be in segment f.
920 If eq2 is also present then confirm that the condition holds.
921 Otherwise add a new variable to the segment list. */
923 static void
924 add_condition (segment_info *f, gfc_equiv *eq1, gfc_equiv *eq2)
926 segment_info *n;
928 n = find_segment_info (eq2->expr->symtree->n.sym);
930 if (n == NULL)
931 new_condition (f, eq1, eq2);
932 else
933 confirm_condition (f, eq1, n, eq2);
937 /* Given a segment element, search through the equivalence lists for unused
938 conditions that involve the symbol. Add these rules to the segment. */
940 static bool
941 find_equivalence (segment_info *n)
943 gfc_equiv *e1, *e2, *eq;
944 bool found;
946 found = FALSE;
948 for (e1 = n->sym->ns->equiv; e1; e1 = e1->next)
950 eq = NULL;
952 /* Search the equivalence list, including the root (first) element
953 for the symbol that owns the segment. */
954 for (e2 = e1; e2; e2 = e2->eq)
956 if (!e2->used && e2->expr->symtree->n.sym == n->sym)
958 eq = e2;
959 break;
963 /* Go to the next root element. */
964 if (eq == NULL)
965 continue;
967 eq->used = 1;
969 /* Now traverse the equivalence list matching the offsets. */
970 for (e2 = e1; e2; e2 = e2->eq)
972 if (!e2->used && e2 != eq)
974 add_condition (n, eq, e2);
975 e2->used = 1;
976 found = TRUE;
980 return found;
984 /* Add all symbols equivalenced within a segment. We need to scan the
985 segment list multiple times to include indirect equivalences. Since
986 a new segment_info can inserted at the beginning of the segment list,
987 depending on its offset, we have to force a final pass through the
988 loop by demanding that completion sees a pass with no matches; i.e.,
989 all symbols with equiv_built set and no new equivalences found. */
991 static void
992 add_equivalences (bool *saw_equiv)
994 segment_info *f;
995 bool seen_one, more;
997 seen_one = false;
998 more = TRUE;
999 while (more)
1001 more = FALSE;
1002 for (f = current_segment; f; f = f->next)
1004 if (!f->sym->equiv_built)
1006 f->sym->equiv_built = 1;
1007 seen_one = find_equivalence (f);
1008 if (seen_one)
1010 *saw_equiv = true;
1011 more = true;
1017 /* Add a copy of this segment list to the namespace. */
1018 copy_equiv_list_to_ns (current_segment);
1022 /* Returns the offset necessary to properly align the current equivalence.
1023 Sets *palign to the required alignment. */
1025 static HOST_WIDE_INT
1026 align_segment (unsigned HOST_WIDE_INT *palign)
1028 segment_info *s;
1029 unsigned HOST_WIDE_INT offset;
1030 unsigned HOST_WIDE_INT max_align;
1031 unsigned HOST_WIDE_INT this_align;
1032 unsigned HOST_WIDE_INT this_offset;
1034 max_align = 1;
1035 offset = 0;
1036 for (s = current_segment; s; s = s->next)
1038 this_align = TYPE_ALIGN_UNIT (s->field);
1039 if (s->offset & (this_align - 1))
1041 /* Field is misaligned. */
1042 this_offset = this_align - ((s->offset + offset) & (this_align - 1));
1043 if (this_offset & (max_align - 1))
1045 /* Aligning this field would misalign a previous field. */
1046 gfc_error ("The equivalence set for variable %qs "
1047 "declared at %L violates alignment requirements",
1048 s->sym->name, &s->sym->declared_at);
1050 offset += this_offset;
1052 max_align = this_align;
1054 if (palign)
1055 *palign = max_align;
1056 return offset;
1060 /* Adjust segment offsets by the given amount. */
1062 static void
1063 apply_segment_offset (segment_info *s, HOST_WIDE_INT offset)
1065 for (; s; s = s->next)
1066 s->offset += offset;
1070 /* Lay out a symbol in a common block. If the symbol has already been seen
1071 then check the location is consistent. Otherwise create segments
1072 for that symbol and all the symbols equivalenced with it. */
1074 /* Translate a single common block. */
1076 static void
1077 translate_common (gfc_common_head *common, gfc_symbol *var_list)
1079 gfc_symbol *sym;
1080 segment_info *s;
1081 segment_info *common_segment;
1082 HOST_WIDE_INT offset;
1083 HOST_WIDE_INT current_offset;
1084 unsigned HOST_WIDE_INT align;
1085 bool saw_equiv;
1087 common_segment = NULL;
1088 offset = 0;
1089 current_offset = 0;
1090 align = 1;
1091 saw_equiv = false;
1093 /* Add symbols to the segment. */
1094 for (sym = var_list; sym; sym = sym->common_next)
1096 current_segment = common_segment;
1097 s = find_segment_info (sym);
1099 /* Symbol has already been added via an equivalence. Multiple
1100 use associations of the same common block result in equiv_built
1101 being set but no information about the symbol in the segment. */
1102 if (s && sym->equiv_built)
1104 /* Ensure the current location is properly aligned. */
1105 align = TYPE_ALIGN_UNIT (s->field);
1106 current_offset = (current_offset + align - 1) &~ (align - 1);
1108 /* Verify that it ended up where we expect it. */
1109 if (s->offset != current_offset)
1111 gfc_error ("Equivalence for %qs does not match ordering of "
1112 "COMMON %qs at %L", sym->name,
1113 common->name, &common->where);
1116 else
1118 /* A symbol we haven't seen before. */
1119 s = current_segment = get_segment_info (sym, current_offset);
1121 /* Add all objects directly or indirectly equivalenced with this
1122 symbol. */
1123 add_equivalences (&saw_equiv);
1125 if (current_segment->offset < 0)
1126 gfc_error ("The equivalence set for %qs cause an invalid "
1127 "extension to COMMON %qs at %L", sym->name,
1128 common->name, &common->where);
1130 if (flag_align_commons)
1131 offset = align_segment (&align);
1133 if (offset)
1135 /* The required offset conflicts with previous alignment
1136 requirements. Insert padding immediately before this
1137 segment. */
1138 if (warn_align_commons)
1140 if (strcmp (common->name, BLANK_COMMON_NAME))
1141 gfc_warning (0,
1142 "Padding of %d bytes required before %qs in "
1143 "COMMON %qs at %L; reorder elements or use "
1144 "-fno-align-commons", (int)offset,
1145 s->sym->name, common->name, &common->where);
1146 else
1147 gfc_warning (0,
1148 "Padding of %d bytes required before %qs in "
1149 "COMMON at %L; reorder elements or use "
1150 "-fno-align-commons", (int)offset,
1151 s->sym->name, &common->where);
1155 /* Apply the offset to the new segments. */
1156 apply_segment_offset (current_segment, offset);
1157 current_offset += offset;
1159 /* Add the new segments to the common block. */
1160 common_segment = add_segments (common_segment, current_segment);
1163 /* The offset of the next common variable. */
1164 current_offset += s->length;
1167 if (common_segment == NULL)
1169 gfc_error ("COMMON %qs at %L does not exist",
1170 common->name, &common->where);
1171 return;
1174 if (common_segment->offset != 0 && warn_align_commons)
1176 if (strcmp (common->name, BLANK_COMMON_NAME))
1177 gfc_warning (OPT_Walign_commons,
1178 "COMMON %qs at %L requires %d bytes of padding; "
1179 "reorder elements or use %<-fno-align-commons%>",
1180 common->name, &common->where, (int)common_segment->offset);
1181 else
1182 gfc_warning (OPT_Walign_commons,
1183 "COMMON at %L requires %d bytes of padding; "
1184 "reorder elements or use %<-fno-align-commons%>",
1185 &common->where, (int)common_segment->offset);
1188 create_common (common, common_segment, saw_equiv);
1192 /* Create a new block for each merged equivalence list. */
1194 static void
1195 finish_equivalences (gfc_namespace *ns)
1197 gfc_equiv *z, *y;
1198 gfc_symbol *sym;
1199 gfc_common_head * c;
1200 HOST_WIDE_INT offset;
1201 unsigned HOST_WIDE_INT align;
1202 bool dummy;
1204 for (z = ns->equiv; z; z = z->next)
1205 for (y = z->eq; y; y = y->eq)
1207 if (y->used)
1208 continue;
1209 sym = z->expr->symtree->n.sym;
1210 current_segment = get_segment_info (sym, 0);
1212 /* All objects directly or indirectly equivalenced with this
1213 symbol. */
1214 add_equivalences (&dummy);
1216 /* Align the block. */
1217 offset = align_segment (&align);
1219 /* Ensure all offsets are positive. */
1220 offset -= current_segment->offset & ~(align - 1);
1222 apply_segment_offset (current_segment, offset);
1224 /* Create the decl. If this is a module equivalence, it has a
1225 unique name, pointed to by z->module. This is written to a
1226 gfc_common_header to push create_common into using
1227 build_common_decl, so that the equivalence appears as an
1228 external symbol. Otherwise, a local declaration is built using
1229 build_equiv_decl. */
1230 if (z->module)
1232 c = gfc_get_common_head ();
1233 /* We've lost the real location, so use the location of the
1234 enclosing procedure. */
1235 c->where = ns->proc_name->declared_at;
1236 strcpy (c->name, z->module);
1238 else
1239 c = NULL;
1241 create_common (c, current_segment, true);
1242 break;
1247 /* Work function for translating a named common block. */
1249 static void
1250 named_common (gfc_symtree *st)
1252 translate_common (st->n.common, st->n.common->head);
1256 /* Translate the common blocks in a namespace. Unlike other variables,
1257 these have to be created before code, because the backend_decl depends
1258 on the rest of the common block. */
1260 void
1261 gfc_trans_common (gfc_namespace *ns)
1263 gfc_common_head *c;
1265 /* Translate the blank common block. */
1266 if (ns->blank_common.head != NULL)
1268 c = gfc_get_common_head ();
1269 c->where = ns->blank_common.head->common_head->where;
1270 strcpy (c->name, BLANK_COMMON_NAME);
1271 translate_common (c, ns->blank_common.head);
1274 /* Translate all named common blocks. */
1275 gfc_traverse_symtree (ns->common_root, named_common);
1277 /* Translate local equivalence. */
1278 finish_equivalences (ns);
1280 /* Commit the newly created symbols for common blocks and module
1281 equivalences. */
1282 gfc_commit_symbols ();