1 /* Common block and equivalence list handling
2 Copyright (C) 2000, 2003, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
4 Contributed by Canqun Yang <canqun@nudt.edu.cn>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
23 /* The core algorithm is based on Andy Vaught's g95 tree. Also the
24 way to build UNION_TYPE is borrowed from Richard Henderson.
26 Transform common blocks. An integral part of this is processing
27 equivalence variables. Equivalenced variables that are not in a
28 common block end up in a private block of their own.
30 Each common block or local equivalence list is declared as a union.
31 Variables within the block are represented as a field within the
32 block with the proper offset.
34 So if two variables are equivalenced, they just point to a common
37 Mathematically, laying out an equivalence block is equivalent to
38 solving a linear system of equations. The matrix is usually a
39 sparse matrix in which each row contains all zero elements except
40 for a +1 and a -1, a sort of a generalized Vandermonde matrix. The
41 matrix is usually block diagonal. The system can be
42 overdetermined, underdetermined or have a unique solution. If the
43 system is inconsistent, the program is not standard conforming.
44 The solution vector is integral, since all of the pivots are +1 or -1.
46 How we lay out an equivalence block is a little less complicated.
47 In an equivalence list with n elements, there are n-1 conditions to
48 be satisfied. The conditions partition the variables into what we
49 will call segments. If A and B are equivalenced then A and B are
50 in the same segment. If B and C are equivalenced as well, then A,
51 B and C are in a segment and so on. Each segment is a block of
52 memory that has one or more variables equivalenced in some way. A
53 common block is made up of a series of segments that are joined one
54 after the other. In the linear system, a segment is a block
57 To lay out a segment we first start with some variable and
58 determine its length. The first variable is assumed to start at
59 offset one and extends to however long it is. We then traverse the
60 list of equivalences to find an unused condition that involves at
61 least one of the variables currently in the segment.
63 Each equivalence condition amounts to the condition B+b=C+c where B
64 and C are the offsets of the B and C variables, and b and c are
65 constants which are nonzero for array elements, substrings or
66 structure components. So for
68 EQUIVALENCE(B(2), C(3))
70 B + 2*size of B's elements = C + 3*size of C's elements.
72 If B and C are known we check to see if the condition already
73 holds. If B is known we can solve for C. Since we know the length
74 of C, we can see if the minimum and maximum extents of the segment
75 are affected. Eventually, we make a full pass through the
76 equivalence list without finding any new conditions and the segment
79 At this point, the segment is added to the current common block.
80 Since we know the minimum extent of the segment, everything in the
81 segment is translated to its position in the common block. The
82 usual case here is that there are no equivalence statements and the
83 common block is series of segments with one variable each, which is
84 a diagonal matrix in the matrix formulation.
86 Each segment is described by a chain of segment_info structures. Each
87 segment_info structure describes the extents of a single variable within
88 the segment. This list is maintained in the order the elements are
89 positioned withing the segment. If two elements have the same starting
90 offset the smaller will come first. If they also have the same size their
91 ordering is undefined.
93 Once all common blocks have been created, the list of equivalences
94 is examined for still-unused equivalence conditions. We create a
95 block for each merged equivalence list. */
99 #include "coretypes.h"
105 #include "gfortran.h"
107 #include "trans-types.h"
108 #include "trans-const.h"
109 #include "target-memory.h"
112 /* Holds a single variable in an equivalence set. */
113 typedef struct segment_info
116 HOST_WIDE_INT offset;
117 HOST_WIDE_INT length;
118 /* This will contain the field type until the field is created. */
120 struct segment_info *next;
123 static segment_info * current_segment;
124 static gfc_namespace *gfc_common_ns = NULL;
127 /* Make a segment_info based on a symbol. */
129 static segment_info *
130 get_segment_info (gfc_symbol * sym, HOST_WIDE_INT offset)
134 /* Make sure we've got the character length. */
135 if (sym->ts.type == BT_CHARACTER)
136 gfc_conv_const_charlen (sym->ts.cl);
138 /* Create the segment_info and fill it in. */
139 s = (segment_info *) gfc_getmem (sizeof (segment_info));
141 /* We will use this type when building the segment aggregate type. */
142 s->field = gfc_sym_type (sym);
143 s->length = int_size_in_bytes (s->field);
150 /* Add a copy of a segment list to the namespace. This is specifically for
151 equivalence segments, so that dependency checking can be done on
152 equivalence group members. */
155 copy_equiv_list_to_ns (segment_info *c)
161 l = (gfc_equiv_list *) gfc_getmem (sizeof (gfc_equiv_list));
163 l->next = c->sym->ns->equiv_lists;
164 c->sym->ns->equiv_lists = l;
166 for (f = c; f; f = f->next)
168 s = (gfc_equiv_info *) gfc_getmem (sizeof (gfc_equiv_info));
172 s->offset = f->offset;
173 s->length = f->length;
178 /* Add combine segment V and segment LIST. */
180 static segment_info *
181 add_segments (segment_info *list, segment_info *v)
192 /* Find the location of the new element. */
195 if (v->offset < s->offset)
197 if (v->offset == s->offset
198 && v->length <= s->length)
205 /* Insert the new element in between p and s. */
220 /* Construct mangled common block name from symbol name. */
223 gfc_sym_mangled_common_id (const char *name)
226 char mangled_name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
228 if (strcmp (name, BLANK_COMMON_NAME) == 0)
229 return get_identifier (name);
231 if (gfc_option.flag_underscoring)
233 has_underscore = strchr (name, '_') != 0;
234 if (gfc_option.flag_second_underscore && has_underscore)
235 snprintf (mangled_name, sizeof mangled_name, "%s__", name);
237 snprintf (mangled_name, sizeof mangled_name, "%s_", name);
239 return get_identifier (mangled_name);
242 return get_identifier (name);
246 /* Build a field declaration for a common variable or a local equivalence
250 build_field (segment_info *h, tree union_type, record_layout_info rli)
254 HOST_WIDE_INT offset = h->offset;
255 unsigned HOST_WIDE_INT desired_align, known_align;
257 name = get_identifier (h->sym->name);
258 field = build_decl (FIELD_DECL, name, h->field);
259 gfc_set_decl_location (field, &h->sym->declared_at);
260 known_align = (offset & -offset) * BITS_PER_UNIT;
261 if (known_align == 0 || known_align > BIGGEST_ALIGNMENT)
262 known_align = BIGGEST_ALIGNMENT;
264 desired_align = update_alignment_for_field (rli, field, known_align);
265 if (desired_align > known_align)
266 DECL_PACKED (field) = 1;
268 DECL_FIELD_CONTEXT (field) = union_type;
269 DECL_FIELD_OFFSET (field) = size_int (offset);
270 DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node;
271 SET_DECL_OFFSET_ALIGN (field, known_align);
273 rli->offset = size_binop (MAX_EXPR, rli->offset,
274 size_binop (PLUS_EXPR,
275 DECL_FIELD_OFFSET (field),
276 DECL_SIZE_UNIT (field)));
277 /* If this field is assigned to a label, we create another two variables.
278 One will hold the address of target label or format label. The other will
279 hold the length of format label string. */
280 if (h->sym->attr.assign)
285 gfc_allocate_lang_decl (field);
286 GFC_DECL_ASSIGN (field) = 1;
287 len = gfc_create_var_np (gfc_charlen_type_node,h->sym->name);
288 addr = gfc_create_var_np (pvoid_type_node, h->sym->name);
289 TREE_STATIC (len) = 1;
290 TREE_STATIC (addr) = 1;
291 DECL_INITIAL (len) = build_int_cst (NULL_TREE, -2);
292 gfc_set_decl_location (len, &h->sym->declared_at);
293 gfc_set_decl_location (addr, &h->sym->declared_at);
294 GFC_DECL_STRING_LEN (field) = pushdecl_top_level (len);
295 GFC_DECL_ASSIGN_ADDR (field) = pushdecl_top_level (addr);
302 /* Get storage for local equivalence. */
305 build_equiv_decl (tree union_type, bool is_init, bool is_saved)
309 static int serial = 0;
313 decl = gfc_create_var (union_type, "equiv");
314 TREE_STATIC (decl) = 1;
315 GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
319 snprintf (name, sizeof (name), "equiv.%d", serial++);
320 decl = build_decl (VAR_DECL, get_identifier (name), union_type);
321 DECL_ARTIFICIAL (decl) = 1;
322 DECL_IGNORED_P (decl) = 1;
324 if (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
326 TREE_STATIC (decl) = 1;
328 TREE_ADDRESSABLE (decl) = 1;
329 TREE_USED (decl) = 1;
330 GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
332 /* The source location has been lost, and doesn't really matter.
333 We need to set it to something though. */
334 gfc_set_decl_location (decl, &gfc_current_locus);
336 gfc_add_decl_to_function (decl);
342 /* Get storage for common block. */
345 build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
347 gfc_symbol *common_sym;
350 /* Create a namespace to store symbols for common blocks. */
351 if (gfc_common_ns == NULL)
352 gfc_common_ns = gfc_get_namespace (NULL, 0);
354 gfc_get_symbol (com->name, gfc_common_ns, &common_sym);
355 decl = common_sym->backend_decl;
357 /* Update the size of this common block as needed. */
358 if (decl != NULL_TREE)
360 tree size = TYPE_SIZE_UNIT (union_type);
361 if (tree_int_cst_lt (DECL_SIZE_UNIT (decl), size))
363 /* Named common blocks of the same name shall be of the same size
364 in all scoping units of a program in which they appear, but
365 blank common blocks may be of different sizes. */
366 if (strcmp (com->name, BLANK_COMMON_NAME))
367 gfc_warning ("Named COMMON block '%s' at %L shall be of the "
368 "same size", com->name, &com->where);
369 DECL_SIZE_UNIT (decl) = size;
370 TREE_TYPE (decl) = union_type;
374 /* If this common block has been declared in a previous program unit,
375 and either it is already initialized or there is no new initialization
376 for it, just return. */
377 if ((decl != NULL_TREE) && (!is_init || DECL_INITIAL (decl)))
380 /* If there is no backend_decl for the common block, build it. */
381 if (decl == NULL_TREE)
383 decl = build_decl (VAR_DECL, get_identifier (com->name), union_type);
384 SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_common_id (com->name));
385 TREE_PUBLIC (decl) = 1;
386 TREE_STATIC (decl) = 1;
387 DECL_ALIGN (decl) = BIGGEST_ALIGNMENT;
388 DECL_USER_ALIGN (decl) = 0;
389 GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
391 gfc_set_decl_location (decl, &com->where);
393 if (com->threadprivate)
394 DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
396 /* Place the back end declaration for this common block in
397 GLOBAL_BINDING_LEVEL. */
398 common_sym->backend_decl = pushdecl_top_level (decl);
401 /* Has no initial values. */
404 DECL_INITIAL (decl) = NULL_TREE;
405 DECL_COMMON (decl) = 1;
406 DECL_DEFER_OUTPUT (decl) = 1;
410 DECL_INITIAL (decl) = error_mark_node;
411 DECL_COMMON (decl) = 0;
412 DECL_DEFER_OUTPUT (decl) = 0;
418 /* Return a field that is the size of the union, if an equivalence has
419 overlapping initializers. Merge the initializers into a single
420 initializer for this new field, then free the old ones. */
423 get_init_field (segment_info *head, tree union_type, tree *field_init,
424 record_layout_info rli)
427 HOST_WIDE_INT length = 0;
428 HOST_WIDE_INT offset = 0;
429 unsigned HOST_WIDE_INT known_align, desired_align;
430 bool overlap = false;
433 unsigned char *data, *chk;
434 VEC(constructor_elt,gc) *v = NULL;
436 tree type = unsigned_char_type_node;
439 /* Obtain the size of the union and check if there are any overlapping
441 for (s = head; s; s = s->next)
443 HOST_WIDE_INT slen = s->offset + s->length;
446 if (s->offset < offset)
450 length = length < slen ? slen : length;
456 /* Now absorb all the initializer data into a single vector,
457 whilst checking for overlapping, unequal values. */
458 data = (unsigned char*)gfc_getmem ((size_t)length);
459 chk = (unsigned char*)gfc_getmem ((size_t)length);
461 /* TODO - change this when default initialization is implemented. */
462 memset (data, '\0', (size_t)length);
463 memset (chk, '\0', (size_t)length);
464 for (s = head; s; s = s->next)
466 gfc_merge_initializers (s->sym->ts, s->sym->value,
471 for (i = 0; i < length; i++)
472 CONSTRUCTOR_APPEND_ELT (v, NULL, build_int_cst (type, data[i]));
477 /* Build a char[length] array to hold the initializers. Much of what
478 follows is borrowed from build_field, above. */
480 tmp = build_int_cst (gfc_array_index_type, length - 1);
481 tmp = build_range_type (gfc_array_index_type,
482 gfc_index_zero_node, tmp);
483 tmp = build_array_type (type, tmp);
484 field = build_decl (FIELD_DECL, NULL_TREE, tmp);
485 gfc_set_decl_location (field, &gfc_current_locus);
487 known_align = BIGGEST_ALIGNMENT;
489 desired_align = update_alignment_for_field (rli, field, known_align);
490 if (desired_align > known_align)
491 DECL_PACKED (field) = 1;
493 DECL_FIELD_CONTEXT (field) = union_type;
494 DECL_FIELD_OFFSET (field) = size_int (0);
495 DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node;
496 SET_DECL_OFFSET_ALIGN (field, known_align);
498 rli->offset = size_binop (MAX_EXPR, rli->offset,
499 size_binop (PLUS_EXPR,
500 DECL_FIELD_OFFSET (field),
501 DECL_SIZE_UNIT (field)));
503 init = build_constructor (TREE_TYPE (field), v);
504 TREE_CONSTANT (init) = 1;
505 TREE_INVARIANT (init) = 1;
509 for (s = head; s; s = s->next)
511 if (s->sym->value == NULL)
514 gfc_free_expr (s->sym->value);
515 s->sym->value = NULL;
522 /* Declare memory for the common block or local equivalence, and create
523 backend declarations for all of the elements. */
526 create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)
528 segment_info *s, *next_s;
532 tree field_init = NULL_TREE;
533 record_layout_info rli;
535 bool is_init = false;
536 bool is_saved = false;
538 /* Declare the variables inside the common block.
539 If the current common block contains any equivalence object, then
540 make a UNION_TYPE node, otherwise RECORD_TYPE. This will let the
541 alias analyzer work well when there is no address overlapping for
542 common variables in the current common block. */
544 union_type = make_node (UNION_TYPE);
546 union_type = make_node (RECORD_TYPE);
548 rli = start_record_layout (union_type);
549 field_link = &TYPE_FIELDS (union_type);
551 /* Check for overlapping initializers and replace them with a single,
552 artificial field that contains all the data. */
554 field = get_init_field (head, union_type, &field_init, rli);
558 if (field != NULL_TREE)
562 field_link = &TREE_CHAIN (field);
565 for (s = head; s; s = s->next)
567 build_field (s, union_type, rli);
569 /* Link the field into the type. */
570 *field_link = s->field;
571 field_link = &TREE_CHAIN (s->field);
573 /* Has initial value. */
577 /* Has SAVE attribute. */
578 if (s->sym->attr.save)
582 finish_record_layout (rli, true);
585 decl = build_common_decl (com, union_type, is_init);
587 decl = build_equiv_decl (union_type, is_init, is_saved);
592 HOST_WIDE_INT offset = 0;
593 VEC(constructor_elt,gc) *v = NULL;
595 if (field != NULL_TREE && field_init != NULL_TREE)
596 CONSTRUCTOR_APPEND_ELT (v, field, field_init);
598 for (s = head; s; s = s->next)
602 /* Add the initializer for this field. */
603 tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts,
604 TREE_TYPE (s->field), s->sym->attr.dimension,
605 s->sym->attr.pointer || s->sym->attr.allocatable);
607 CONSTRUCTOR_APPEND_ELT (v, s->field, tmp);
608 offset = s->offset + s->length;
612 gcc_assert (!VEC_empty (constructor_elt, v));
613 ctor = build_constructor (union_type, v);
614 TREE_CONSTANT (ctor) = 1;
615 TREE_INVARIANT (ctor) = 1;
616 TREE_STATIC (ctor) = 1;
617 DECL_INITIAL (decl) = ctor;
619 #ifdef ENABLE_CHECKING
622 unsigned HOST_WIDE_INT idx;
623 FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor), idx, field, value)
624 gcc_assert (TREE_CODE (field) == FIELD_DECL);
629 /* Build component reference for each variable. */
630 for (s = head; s; s = next_s)
634 var_decl = build_decl (VAR_DECL, DECL_NAME (s->field),
635 TREE_TYPE (s->field));
636 gfc_set_decl_location (var_decl, &s->sym->declared_at);
637 TREE_PUBLIC (var_decl) = TREE_PUBLIC (decl);
638 TREE_STATIC (var_decl) = TREE_STATIC (decl);
639 TREE_USED (var_decl) = TREE_USED (decl);
640 if (s->sym->attr.target)
641 TREE_ADDRESSABLE (var_decl) = 1;
642 /* This is a fake variable just for debugging purposes. */
643 TREE_ASM_WRITTEN (var_decl) = 1;
646 var_decl = pushdecl_top_level (var_decl);
648 gfc_add_decl_to_function (var_decl);
650 SET_DECL_VALUE_EXPR (var_decl,
651 build3 (COMPONENT_REF, TREE_TYPE (s->field),
652 decl, s->field, NULL_TREE));
653 DECL_HAS_VALUE_EXPR_P (var_decl) = 1;
654 GFC_DECL_COMMON_OR_EQUIV (var_decl) = 1;
656 if (s->sym->attr.assign)
658 gfc_allocate_lang_decl (var_decl);
659 GFC_DECL_ASSIGN (var_decl) = 1;
660 GFC_DECL_STRING_LEN (var_decl) = GFC_DECL_STRING_LEN (s->field);
661 GFC_DECL_ASSIGN_ADDR (var_decl) = GFC_DECL_ASSIGN_ADDR (s->field);
664 s->sym->backend_decl = var_decl;
672 /* Given a symbol, find it in the current segment list. Returns NULL if
675 static segment_info *
676 find_segment_info (gfc_symbol *symbol)
680 for (n = current_segment; n; n = n->next)
682 if (n->sym == symbol)
690 /* Given an expression node, make sure it is a constant integer and return
694 get_mpz (gfc_expr *e)
697 if (e->expr_type != EXPR_CONSTANT)
698 gfc_internal_error ("get_mpz(): Not an integer constant");
700 return &e->value.integer;
704 /* Given an array specification and an array reference, figure out the
705 array element number (zero based). Bounds and elements are guaranteed
706 to be constants. If something goes wrong we generate an error and
710 element_number (gfc_array_ref *ar)
712 mpz_t multiplier, offset, extent, n;
714 HOST_WIDE_INT i, rank;
718 mpz_init_set_ui (multiplier, 1);
719 mpz_init_set_ui (offset, 0);
723 for (i = 0; i < rank; i++)
725 if (ar->dimen_type[i] != DIMEN_ELEMENT)
726 gfc_internal_error ("element_number(): Bad dimension type");
728 mpz_sub (n, *get_mpz (ar->start[i]), *get_mpz (as->lower[i]));
730 mpz_mul (n, n, multiplier);
731 mpz_add (offset, offset, n);
733 mpz_sub (extent, *get_mpz (as->upper[i]), *get_mpz (as->lower[i]));
734 mpz_add_ui (extent, extent, 1);
736 if (mpz_sgn (extent) < 0)
737 mpz_set_ui (extent, 0);
739 mpz_mul (multiplier, multiplier, extent);
742 i = mpz_get_ui (offset);
744 mpz_clear (multiplier);
753 /* Given a single element of an equivalence list, figure out the offset
754 from the base symbol. For simple variables or full arrays, this is
755 simply zero. For an array element we have to calculate the array
756 element number and multiply by the element size. For a substring we
757 have to calculate the further reference. */
760 calculate_offset (gfc_expr *e)
762 HOST_WIDE_INT n, element_size, offset;
763 gfc_typespec *element_type;
767 element_type = &e->symtree->n.sym->ts;
769 for (reference = e->ref; reference; reference = reference->next)
770 switch (reference->type)
773 switch (reference->u.ar.type)
779 n = element_number (&reference->u.ar);
780 if (element_type->type == BT_CHARACTER)
781 gfc_conv_const_charlen (element_type->cl);
783 int_size_in_bytes (gfc_typenode_for_spec (element_type));
784 offset += n * element_size;
788 gfc_error ("Bad array reference at %L", &e->where);
792 if (reference->u.ss.start != NULL)
793 offset += mpz_get_ui (*get_mpz (reference->u.ss.start)) - 1;
796 gfc_error ("Illegal reference type at %L as EQUIVALENCE object",
803 /* Add a new segment_info structure to the current segment. eq1 is already
804 in the list, eq2 is not. */
807 new_condition (segment_info *v, gfc_equiv *eq1, gfc_equiv *eq2)
809 HOST_WIDE_INT offset1, offset2;
812 offset1 = calculate_offset (eq1->expr);
813 offset2 = calculate_offset (eq2->expr);
815 a = get_segment_info (eq2->expr->symtree->n.sym,
816 v->offset + offset1 - offset2);
818 current_segment = add_segments (current_segment, a);
822 /* Given two equivalence structures that are both already in the list, make
823 sure that this new condition is not violated, generating an error if it
827 confirm_condition (segment_info *s1, gfc_equiv *eq1, segment_info *s2,
830 HOST_WIDE_INT offset1, offset2;
832 offset1 = calculate_offset (eq1->expr);
833 offset2 = calculate_offset (eq2->expr);
835 if (s1->offset + offset1 != s2->offset + offset2)
836 gfc_error ("Inconsistent equivalence rules involving '%s' at %L and "
837 "'%s' at %L", s1->sym->name, &s1->sym->declared_at,
838 s2->sym->name, &s2->sym->declared_at);
842 /* Process a new equivalence condition. eq1 is know to be in segment f.
843 If eq2 is also present then confirm that the condition holds.
844 Otherwise add a new variable to the segment list. */
847 add_condition (segment_info *f, gfc_equiv *eq1, gfc_equiv *eq2)
851 n = find_segment_info (eq2->expr->symtree->n.sym);
854 new_condition (f, eq1, eq2);
856 confirm_condition (f, eq1, n, eq2);
860 /* Given a segment element, search through the equivalence lists for unused
861 conditions that involve the symbol. Add these rules to the segment. */
864 find_equivalence (segment_info *n)
866 gfc_equiv *e1, *e2, *eq;
871 for (e1 = n->sym->ns->equiv; e1; e1 = e1->next)
875 /* Search the equivalence list, including the root (first) element
876 for the symbol that owns the segment. */
877 for (e2 = e1; e2; e2 = e2->eq)
879 if (!e2->used && e2->expr->symtree->n.sym == n->sym)
886 /* Go to the next root element. */
892 /* Now traverse the equivalence list matching the offsets. */
893 for (e2 = e1; e2; e2 = e2->eq)
895 if (!e2->used && e2 != eq)
897 add_condition (n, eq, e2);
907 /* Add all symbols equivalenced within a segment. We need to scan the
908 segment list multiple times to include indirect equivalences. Since
909 a new segment_info can inserted at the beginning of the segment list,
910 depending on its offset, we have to force a final pass through the
911 loop by demanding that completion sees a pass with no matches; ie.
912 all symbols with equiv_built set and no new equivalences found. */
915 add_equivalences (bool *saw_equiv)
925 for (f = current_segment; f; f = f->next)
927 if (!f->sym->equiv_built)
929 f->sym->equiv_built = 1;
930 seen_one = find_equivalence (f);
940 /* Add a copy of this segment list to the namespace. */
941 copy_equiv_list_to_ns (current_segment);
945 /* Returns the offset necessary to properly align the current equivalence.
946 Sets *palign to the required alignment. */
949 align_segment (unsigned HOST_WIDE_INT *palign)
952 unsigned HOST_WIDE_INT offset;
953 unsigned HOST_WIDE_INT max_align;
954 unsigned HOST_WIDE_INT this_align;
955 unsigned HOST_WIDE_INT this_offset;
959 for (s = current_segment; s; s = s->next)
961 this_align = TYPE_ALIGN_UNIT (s->field);
962 if (s->offset & (this_align - 1))
964 /* Field is misaligned. */
965 this_offset = this_align - ((s->offset + offset) & (this_align - 1));
966 if (this_offset & (max_align - 1))
968 /* Aligning this field would misalign a previous field. */
969 gfc_error ("The equivalence set for variable '%s' "
970 "declared at %L violates alignment requirements",
971 s->sym->name, &s->sym->declared_at);
973 offset += this_offset;
975 max_align = this_align;
983 /* Adjust segment offsets by the given amount. */
986 apply_segment_offset (segment_info *s, HOST_WIDE_INT offset)
988 for (; s; s = s->next)
993 /* Lay out a symbol in a common block. If the symbol has already been seen
994 then check the location is consistent. Otherwise create segments
995 for that symbol and all the symbols equivalenced with it. */
997 /* Translate a single common block. */
1000 translate_common (gfc_common_head *common, gfc_symbol *var_list)
1004 segment_info *common_segment;
1005 HOST_WIDE_INT offset;
1006 HOST_WIDE_INT current_offset;
1007 unsigned HOST_WIDE_INT align;
1008 unsigned HOST_WIDE_INT max_align;
1011 common_segment = NULL;
1016 /* Add symbols to the segment. */
1017 for (sym = var_list; sym; sym = sym->common_next)
1019 current_segment = common_segment;
1020 s = find_segment_info (sym);
1022 /* Symbol has already been added via an equivalence. Multiple
1023 use associations of the same common block result in equiv_built
1024 being set but no information about the symbol in the segment. */
1025 if (s && sym->equiv_built)
1027 /* Ensure the current location is properly aligned. */
1028 align = TYPE_ALIGN_UNIT (s->field);
1029 current_offset = (current_offset + align - 1) &~ (align - 1);
1031 /* Verify that it ended up where we expect it. */
1032 if (s->offset != current_offset)
1034 gfc_error ("Equivalence for '%s' does not match ordering of "
1035 "COMMON '%s' at %L", sym->name,
1036 common->name, &common->where);
1041 /* A symbol we haven't seen before. */
1042 s = current_segment = get_segment_info (sym, current_offset);
1044 /* Add all objects directly or indirectly equivalenced with this
1046 add_equivalences (&saw_equiv);
1048 if (current_segment->offset < 0)
1049 gfc_error ("The equivalence set for '%s' cause an invalid "
1050 "extension to COMMON '%s' at %L", sym->name,
1051 common->name, &common->where);
1053 offset = align_segment (&align);
1055 if (offset & (max_align - 1))
1057 /* The required offset conflicts with previous alignment
1058 requirements. Insert padding immediately before this
1060 gfc_warning ("Padding of %d bytes required before '%s' in "
1061 "COMMON '%s' at %L", (int)offset, s->sym->name,
1062 common->name, &common->where);
1066 /* Offset the whole common block. */
1067 apply_segment_offset (common_segment, offset);
1070 /* Apply the offset to the new segments. */
1071 apply_segment_offset (current_segment, offset);
1072 current_offset += offset;
1073 if (max_align < align)
1076 /* Add the new segments to the common block. */
1077 common_segment = add_segments (common_segment, current_segment);
1080 /* The offset of the next common variable. */
1081 current_offset += s->length;
1084 if (common_segment == NULL)
1086 gfc_error ("COMMON '%s' at %L does not exist",
1087 common->name, &common->where);
1091 if (common_segment->offset != 0)
1093 gfc_warning ("COMMON '%s' at %L requires %d bytes of padding at start",
1094 common->name, &common->where, (int)common_segment->offset);
1097 create_common (common, common_segment, saw_equiv);
1101 /* Create a new block for each merged equivalence list. */
1104 finish_equivalences (gfc_namespace *ns)
1108 gfc_common_head * c;
1109 HOST_WIDE_INT offset;
1110 unsigned HOST_WIDE_INT align;
1113 for (z = ns->equiv; z; z = z->next)
1114 for (y = z->eq; y; y = y->eq)
1118 sym = z->expr->symtree->n.sym;
1119 current_segment = get_segment_info (sym, 0);
1121 /* All objects directly or indirectly equivalenced with this
1123 add_equivalences (&dummy);
1125 /* Align the block. */
1126 offset = align_segment (&align);
1128 /* Ensure all offsets are positive. */
1129 offset -= current_segment->offset & ~(align - 1);
1131 apply_segment_offset (current_segment, offset);
1133 /* Create the decl. If this is a module equivalence, it has a
1134 unique name, pointed to by z->module. This is written to a
1135 gfc_common_header to push create_common into using
1136 build_common_decl, so that the equivalence appears as an
1137 external symbol. Otherwise, a local declaration is built using
1138 build_equiv_decl. */
1141 c = gfc_get_common_head ();
1142 /* We've lost the real location, so use the location of the
1143 enclosing procedure. */
1144 c->where = ns->proc_name->declared_at;
1145 strcpy (c->name, z->module);
1150 create_common (c, current_segment, true);
1156 /* Work function for translating a named common block. */
1159 named_common (gfc_symtree *st)
1161 translate_common (st->n.common, st->n.common->head);
1165 /* Translate the common blocks in a namespace. Unlike other variables,
1166 these have to be created before code, because the backend_decl depends
1167 on the rest of the common block. */
1170 gfc_trans_common (gfc_namespace *ns)
1174 /* Translate the blank common block. */
1175 if (ns->blank_common.head != NULL)
1177 c = gfc_get_common_head ();
1179 /* We've lost the real location, so use the location of the
1180 enclosing procedure. */
1181 if (ns->proc_name != NULL)
1182 c->where = ns->proc_name->declared_at;
1184 c->where = ns->blank_common.head->common_head->where;
1186 strcpy (c->name, BLANK_COMMON_NAME);
1187 translate_common (c, ns->blank_common.head);
1190 /* Translate all named common blocks. */
1191 gfc_traverse_symtree (ns->common_root, named_common);
1193 /* Translate local equivalence. */
1194 finish_equivalences (ns);
1196 /* Commit the newly created symbols for common blocks and module
1198 gfc_commit_symbols ();