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 /* TODO: This is defined in match.h, and probably shouldn't be here also,
113 but we need it for now at least and don't want to include the whole
115 gfc_common_head *gfc_get_common (const char *, int);
118 /* Holds a single variable in an equivalence set. */
119 typedef struct segment_info
122 HOST_WIDE_INT offset;
123 HOST_WIDE_INT length;
124 /* This will contain the field type until the field is created. */
126 struct segment_info *next;
129 static segment_info * current_segment;
130 static gfc_namespace *gfc_common_ns = NULL;
133 /* Make a segment_info based on a symbol. */
135 static segment_info *
136 get_segment_info (gfc_symbol * sym, HOST_WIDE_INT offset)
140 /* Make sure we've got the character length. */
141 if (sym->ts.type == BT_CHARACTER)
142 gfc_conv_const_charlen (sym->ts.cl);
144 /* Create the segment_info and fill it in. */
145 s = (segment_info *) gfc_getmem (sizeof (segment_info));
147 /* We will use this type when building the segment aggregate type. */
148 s->field = gfc_sym_type (sym);
149 s->length = int_size_in_bytes (s->field);
156 /* Add a copy of a segment list to the namespace. This is specifically for
157 equivalence segments, so that dependency checking can be done on
158 equivalence group members. */
161 copy_equiv_list_to_ns (segment_info *c)
167 l = (gfc_equiv_list *) gfc_getmem (sizeof (gfc_equiv_list));
169 l->next = c->sym->ns->equiv_lists;
170 c->sym->ns->equiv_lists = l;
172 for (f = c; f; f = f->next)
174 s = (gfc_equiv_info *) gfc_getmem (sizeof (gfc_equiv_info));
178 s->offset = f->offset;
179 s->length = f->length;
184 /* Add combine segment V and segment LIST. */
186 static segment_info *
187 add_segments (segment_info *list, segment_info *v)
198 /* Find the location of the new element. */
201 if (v->offset < s->offset)
203 if (v->offset == s->offset
204 && v->length <= s->length)
211 /* Insert the new element in between p and s. */
227 /* Construct mangled common block name from symbol name. */
229 /* We need the bind(c) flag to tell us how/if we should mangle the symbol
230 name. There are few calls to this function, so few places that this
231 would need to be added. At the moment, there is only one call, in
232 build_common_decl(). We can't attempt to look up the common block
233 because we may be building it for the first time and therefore, it won't
234 be in the common_root. We also need the binding label, if it's bind(c).
235 Therefore, send in the pointer to the common block, so whatever info we
236 have so far can be used. All of the necessary info should be available
237 in the gfc_common_head by now, so it should be accurate to test the
238 isBindC flag and use the binding label given if it is bind(c).
240 We may NOT know yet if it's bind(c) or not, but we can try at least.
241 Will have to figure out what to do later if it's labeled bind(c)
242 after this is called. */
245 gfc_sym_mangled_common_id (gfc_common_head *com)
248 char mangled_name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
249 char name[GFC_MAX_SYMBOL_LEN + 1];
251 /* Get the name out of the common block pointer. */
252 strcpy (name, com->name);
254 /* If we're suppose to do a bind(c). */
255 if (com->is_bind_c == 1 && com->binding_label[0] != '\0')
256 return get_identifier (com->binding_label);
258 if (strcmp (name, BLANK_COMMON_NAME) == 0)
259 return get_identifier (name);
261 if (gfc_option.flag_underscoring)
263 has_underscore = strchr (name, '_') != 0;
264 if (gfc_option.flag_second_underscore && has_underscore)
265 snprintf (mangled_name, sizeof mangled_name, "%s__", name);
267 snprintf (mangled_name, sizeof mangled_name, "%s_", name);
269 return get_identifier (mangled_name);
272 return get_identifier (name);
276 /* Build a field declaration for a common variable or a local equivalence
280 build_field (segment_info *h, tree union_type, record_layout_info rli)
284 HOST_WIDE_INT offset = h->offset;
285 unsigned HOST_WIDE_INT desired_align, known_align;
287 name = get_identifier (h->sym->name);
288 field = build_decl (FIELD_DECL, name, h->field);
289 gfc_set_decl_location (field, &h->sym->declared_at);
290 known_align = (offset & -offset) * BITS_PER_UNIT;
291 if (known_align == 0 || known_align > BIGGEST_ALIGNMENT)
292 known_align = BIGGEST_ALIGNMENT;
294 desired_align = update_alignment_for_field (rli, field, known_align);
295 if (desired_align > known_align)
296 DECL_PACKED (field) = 1;
298 DECL_FIELD_CONTEXT (field) = union_type;
299 DECL_FIELD_OFFSET (field) = size_int (offset);
300 DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node;
301 SET_DECL_OFFSET_ALIGN (field, known_align);
303 rli->offset = size_binop (MAX_EXPR, rli->offset,
304 size_binop (PLUS_EXPR,
305 DECL_FIELD_OFFSET (field),
306 DECL_SIZE_UNIT (field)));
307 /* If this field is assigned to a label, we create another two variables.
308 One will hold the address of target label or format label. The other will
309 hold the length of format label string. */
310 if (h->sym->attr.assign)
315 gfc_allocate_lang_decl (field);
316 GFC_DECL_ASSIGN (field) = 1;
317 len = gfc_create_var_np (gfc_charlen_type_node,h->sym->name);
318 addr = gfc_create_var_np (pvoid_type_node, h->sym->name);
319 TREE_STATIC (len) = 1;
320 TREE_STATIC (addr) = 1;
321 DECL_INITIAL (len) = build_int_cst (NULL_TREE, -2);
322 gfc_set_decl_location (len, &h->sym->declared_at);
323 gfc_set_decl_location (addr, &h->sym->declared_at);
324 GFC_DECL_STRING_LEN (field) = pushdecl_top_level (len);
325 GFC_DECL_ASSIGN_ADDR (field) = pushdecl_top_level (addr);
332 /* Get storage for local equivalence. */
335 build_equiv_decl (tree union_type, bool is_init, bool is_saved)
339 static int serial = 0;
343 decl = gfc_create_var (union_type, "equiv");
344 TREE_STATIC (decl) = 1;
345 GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
349 snprintf (name, sizeof (name), "equiv.%d", serial++);
350 decl = build_decl (VAR_DECL, get_identifier (name), union_type);
351 DECL_ARTIFICIAL (decl) = 1;
352 DECL_IGNORED_P (decl) = 1;
354 if (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
356 TREE_STATIC (decl) = 1;
358 TREE_ADDRESSABLE (decl) = 1;
359 TREE_USED (decl) = 1;
360 GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
362 /* The source location has been lost, and doesn't really matter.
363 We need to set it to something though. */
364 gfc_set_decl_location (decl, &gfc_current_locus);
366 gfc_add_decl_to_function (decl);
372 /* Get storage for common block. */
375 build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
377 gfc_symbol *common_sym;
380 /* Create a namespace to store symbols for common blocks. */
381 if (gfc_common_ns == NULL)
382 gfc_common_ns = gfc_get_namespace (NULL, 0);
384 gfc_get_symbol (com->name, gfc_common_ns, &common_sym);
385 decl = common_sym->backend_decl;
387 /* Update the size of this common block as needed. */
388 if (decl != NULL_TREE)
390 tree size = TYPE_SIZE_UNIT (union_type);
391 if (tree_int_cst_lt (DECL_SIZE_UNIT (decl), size))
393 /* Named common blocks of the same name shall be of the same size
394 in all scoping units of a program in which they appear, but
395 blank common blocks may be of different sizes. */
396 if (strcmp (com->name, BLANK_COMMON_NAME))
397 gfc_warning ("Named COMMON block '%s' at %L shall be of the "
398 "same size", com->name, &com->where);
399 DECL_SIZE_UNIT (decl) = size;
400 TREE_TYPE (decl) = union_type;
404 /* If this common block has been declared in a previous program unit,
405 and either it is already initialized or there is no new initialization
406 for it, just return. */
407 if ((decl != NULL_TREE) && (!is_init || DECL_INITIAL (decl)))
410 /* If there is no backend_decl for the common block, build it. */
411 if (decl == NULL_TREE)
413 decl = build_decl (VAR_DECL, get_identifier (com->name), union_type);
414 SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_common_id (com));
415 TREE_PUBLIC (decl) = 1;
416 TREE_STATIC (decl) = 1;
417 DECL_ALIGN (decl) = BIGGEST_ALIGNMENT;
418 DECL_USER_ALIGN (decl) = 0;
419 GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
421 gfc_set_decl_location (decl, &com->where);
423 if (com->threadprivate)
424 DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
426 /* Place the back end declaration for this common block in
427 GLOBAL_BINDING_LEVEL. */
428 common_sym->backend_decl = pushdecl_top_level (decl);
431 /* Has no initial values. */
434 DECL_INITIAL (decl) = NULL_TREE;
435 DECL_COMMON (decl) = 1;
436 DECL_DEFER_OUTPUT (decl) = 1;
440 DECL_INITIAL (decl) = error_mark_node;
441 DECL_COMMON (decl) = 0;
442 DECL_DEFER_OUTPUT (decl) = 0;
448 /* Return a field that is the size of the union, if an equivalence has
449 overlapping initializers. Merge the initializers into a single
450 initializer for this new field, then free the old ones. */
453 get_init_field (segment_info *head, tree union_type, tree *field_init,
454 record_layout_info rli)
457 HOST_WIDE_INT length = 0;
458 HOST_WIDE_INT offset = 0;
459 unsigned HOST_WIDE_INT known_align, desired_align;
460 bool overlap = false;
463 unsigned char *data, *chk;
464 VEC(constructor_elt,gc) *v = NULL;
466 tree type = unsigned_char_type_node;
469 /* Obtain the size of the union and check if there are any overlapping
471 for (s = head; s; s = s->next)
473 HOST_WIDE_INT slen = s->offset + s->length;
476 if (s->offset < offset)
480 length = length < slen ? slen : length;
486 /* Now absorb all the initializer data into a single vector,
487 whilst checking for overlapping, unequal values. */
488 data = (unsigned char*)gfc_getmem ((size_t)length);
489 chk = (unsigned char*)gfc_getmem ((size_t)length);
491 /* TODO - change this when default initialization is implemented. */
492 memset (data, '\0', (size_t)length);
493 memset (chk, '\0', (size_t)length);
494 for (s = head; s; s = s->next)
496 gfc_merge_initializers (s->sym->ts, s->sym->value,
501 for (i = 0; i < length; i++)
502 CONSTRUCTOR_APPEND_ELT (v, NULL, build_int_cst (type, data[i]));
507 /* Build a char[length] array to hold the initializers. Much of what
508 follows is borrowed from build_field, above. */
510 tmp = build_int_cst (gfc_array_index_type, length - 1);
511 tmp = build_range_type (gfc_array_index_type,
512 gfc_index_zero_node, tmp);
513 tmp = build_array_type (type, tmp);
514 field = build_decl (FIELD_DECL, NULL_TREE, tmp);
515 gfc_set_decl_location (field, &gfc_current_locus);
517 known_align = BIGGEST_ALIGNMENT;
519 desired_align = update_alignment_for_field (rli, field, known_align);
520 if (desired_align > known_align)
521 DECL_PACKED (field) = 1;
523 DECL_FIELD_CONTEXT (field) = union_type;
524 DECL_FIELD_OFFSET (field) = size_int (0);
525 DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node;
526 SET_DECL_OFFSET_ALIGN (field, known_align);
528 rli->offset = size_binop (MAX_EXPR, rli->offset,
529 size_binop (PLUS_EXPR,
530 DECL_FIELD_OFFSET (field),
531 DECL_SIZE_UNIT (field)));
533 init = build_constructor (TREE_TYPE (field), v);
534 TREE_CONSTANT (init) = 1;
535 TREE_INVARIANT (init) = 1;
539 for (s = head; s; s = s->next)
541 if (s->sym->value == NULL)
544 gfc_free_expr (s->sym->value);
545 s->sym->value = NULL;
552 /* Declare memory for the common block or local equivalence, and create
553 backend declarations for all of the elements. */
556 create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)
558 segment_info *s, *next_s;
562 tree field_init = NULL_TREE;
563 record_layout_info rli;
565 bool is_init = false;
566 bool is_saved = false;
568 /* Declare the variables inside the common block.
569 If the current common block contains any equivalence object, then
570 make a UNION_TYPE node, otherwise RECORD_TYPE. This will let the
571 alias analyzer work well when there is no address overlapping for
572 common variables in the current common block. */
574 union_type = make_node (UNION_TYPE);
576 union_type = make_node (RECORD_TYPE);
578 rli = start_record_layout (union_type);
579 field_link = &TYPE_FIELDS (union_type);
581 /* Check for overlapping initializers and replace them with a single,
582 artificial field that contains all the data. */
584 field = get_init_field (head, union_type, &field_init, rli);
588 if (field != NULL_TREE)
592 field_link = &TREE_CHAIN (field);
595 for (s = head; s; s = s->next)
597 build_field (s, union_type, rli);
599 /* Link the field into the type. */
600 *field_link = s->field;
601 field_link = &TREE_CHAIN (s->field);
603 /* Has initial value. */
607 /* Has SAVE attribute. */
608 if (s->sym->attr.save)
612 finish_record_layout (rli, true);
615 decl = build_common_decl (com, union_type, is_init);
617 decl = build_equiv_decl (union_type, is_init, is_saved);
622 HOST_WIDE_INT offset = 0;
623 VEC(constructor_elt,gc) *v = NULL;
625 if (field != NULL_TREE && field_init != NULL_TREE)
626 CONSTRUCTOR_APPEND_ELT (v, field, field_init);
628 for (s = head; s; s = s->next)
632 /* Add the initializer for this field. */
633 tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts,
634 TREE_TYPE (s->field), s->sym->attr.dimension,
635 s->sym->attr.pointer || s->sym->attr.allocatable);
637 CONSTRUCTOR_APPEND_ELT (v, s->field, tmp);
638 offset = s->offset + s->length;
642 gcc_assert (!VEC_empty (constructor_elt, v));
643 ctor = build_constructor (union_type, v);
644 TREE_CONSTANT (ctor) = 1;
645 TREE_INVARIANT (ctor) = 1;
646 TREE_STATIC (ctor) = 1;
647 DECL_INITIAL (decl) = ctor;
649 #ifdef ENABLE_CHECKING
652 unsigned HOST_WIDE_INT idx;
653 FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor), idx, field, value)
654 gcc_assert (TREE_CODE (field) == FIELD_DECL);
659 /* Build component reference for each variable. */
660 for (s = head; s; s = next_s)
664 var_decl = build_decl (VAR_DECL, DECL_NAME (s->field),
665 TREE_TYPE (s->field));
666 gfc_set_decl_location (var_decl, &s->sym->declared_at);
667 TREE_PUBLIC (var_decl) = TREE_PUBLIC (decl);
668 TREE_STATIC (var_decl) = TREE_STATIC (decl);
669 TREE_USED (var_decl) = TREE_USED (decl);
670 if (s->sym->attr.target)
671 TREE_ADDRESSABLE (var_decl) = 1;
672 /* This is a fake variable just for debugging purposes. */
673 TREE_ASM_WRITTEN (var_decl) = 1;
676 var_decl = pushdecl_top_level (var_decl);
678 gfc_add_decl_to_function (var_decl);
680 SET_DECL_VALUE_EXPR (var_decl,
681 build3 (COMPONENT_REF, TREE_TYPE (s->field),
682 decl, s->field, NULL_TREE));
683 DECL_HAS_VALUE_EXPR_P (var_decl) = 1;
684 GFC_DECL_COMMON_OR_EQUIV (var_decl) = 1;
686 if (s->sym->attr.assign)
688 gfc_allocate_lang_decl (var_decl);
689 GFC_DECL_ASSIGN (var_decl) = 1;
690 GFC_DECL_STRING_LEN (var_decl) = GFC_DECL_STRING_LEN (s->field);
691 GFC_DECL_ASSIGN_ADDR (var_decl) = GFC_DECL_ASSIGN_ADDR (s->field);
694 s->sym->backend_decl = var_decl;
702 /* Given a symbol, find it in the current segment list. Returns NULL if
705 static segment_info *
706 find_segment_info (gfc_symbol *symbol)
710 for (n = current_segment; n; n = n->next)
712 if (n->sym == symbol)
720 /* Given an expression node, make sure it is a constant integer and return
724 get_mpz (gfc_expr *e)
727 if (e->expr_type != EXPR_CONSTANT)
728 gfc_internal_error ("get_mpz(): Not an integer constant");
730 return &e->value.integer;
734 /* Given an array specification and an array reference, figure out the
735 array element number (zero based). Bounds and elements are guaranteed
736 to be constants. If something goes wrong we generate an error and
740 element_number (gfc_array_ref *ar)
742 mpz_t multiplier, offset, extent, n;
744 HOST_WIDE_INT i, rank;
748 mpz_init_set_ui (multiplier, 1);
749 mpz_init_set_ui (offset, 0);
753 for (i = 0; i < rank; i++)
755 if (ar->dimen_type[i] != DIMEN_ELEMENT)
756 gfc_internal_error ("element_number(): Bad dimension type");
758 mpz_sub (n, *get_mpz (ar->start[i]), *get_mpz (as->lower[i]));
760 mpz_mul (n, n, multiplier);
761 mpz_add (offset, offset, n);
763 mpz_sub (extent, *get_mpz (as->upper[i]), *get_mpz (as->lower[i]));
764 mpz_add_ui (extent, extent, 1);
766 if (mpz_sgn (extent) < 0)
767 mpz_set_ui (extent, 0);
769 mpz_mul (multiplier, multiplier, extent);
772 i = mpz_get_ui (offset);
774 mpz_clear (multiplier);
783 /* Given a single element of an equivalence list, figure out the offset
784 from the base symbol. For simple variables or full arrays, this is
785 simply zero. For an array element we have to calculate the array
786 element number and multiply by the element size. For a substring we
787 have to calculate the further reference. */
790 calculate_offset (gfc_expr *e)
792 HOST_WIDE_INT n, element_size, offset;
793 gfc_typespec *element_type;
797 element_type = &e->symtree->n.sym->ts;
799 for (reference = e->ref; reference; reference = reference->next)
800 switch (reference->type)
803 switch (reference->u.ar.type)
809 n = element_number (&reference->u.ar);
810 if (element_type->type == BT_CHARACTER)
811 gfc_conv_const_charlen (element_type->cl);
813 int_size_in_bytes (gfc_typenode_for_spec (element_type));
814 offset += n * element_size;
818 gfc_error ("Bad array reference at %L", &e->where);
822 if (reference->u.ss.start != NULL)
823 offset += mpz_get_ui (*get_mpz (reference->u.ss.start)) - 1;
826 gfc_error ("Illegal reference type at %L as EQUIVALENCE object",
833 /* Add a new segment_info structure to the current segment. eq1 is already
834 in the list, eq2 is not. */
837 new_condition (segment_info *v, gfc_equiv *eq1, gfc_equiv *eq2)
839 HOST_WIDE_INT offset1, offset2;
842 offset1 = calculate_offset (eq1->expr);
843 offset2 = calculate_offset (eq2->expr);
845 a = get_segment_info (eq2->expr->symtree->n.sym,
846 v->offset + offset1 - offset2);
848 current_segment = add_segments (current_segment, a);
852 /* Given two equivalence structures that are both already in the list, make
853 sure that this new condition is not violated, generating an error if it
857 confirm_condition (segment_info *s1, gfc_equiv *eq1, segment_info *s2,
860 HOST_WIDE_INT offset1, offset2;
862 offset1 = calculate_offset (eq1->expr);
863 offset2 = calculate_offset (eq2->expr);
865 if (s1->offset + offset1 != s2->offset + offset2)
866 gfc_error ("Inconsistent equivalence rules involving '%s' at %L and "
867 "'%s' at %L", s1->sym->name, &s1->sym->declared_at,
868 s2->sym->name, &s2->sym->declared_at);
872 /* Process a new equivalence condition. eq1 is know to be in segment f.
873 If eq2 is also present then confirm that the condition holds.
874 Otherwise add a new variable to the segment list. */
877 add_condition (segment_info *f, gfc_equiv *eq1, gfc_equiv *eq2)
881 n = find_segment_info (eq2->expr->symtree->n.sym);
884 new_condition (f, eq1, eq2);
886 confirm_condition (f, eq1, n, eq2);
890 /* Given a segment element, search through the equivalence lists for unused
891 conditions that involve the symbol. Add these rules to the segment. */
894 find_equivalence (segment_info *n)
896 gfc_equiv *e1, *e2, *eq;
901 for (e1 = n->sym->ns->equiv; e1; e1 = e1->next)
905 /* Search the equivalence list, including the root (first) element
906 for the symbol that owns the segment. */
907 for (e2 = e1; e2; e2 = e2->eq)
909 if (!e2->used && e2->expr->symtree->n.sym == n->sym)
916 /* Go to the next root element. */
922 /* Now traverse the equivalence list matching the offsets. */
923 for (e2 = e1; e2; e2 = e2->eq)
925 if (!e2->used && e2 != eq)
927 add_condition (n, eq, e2);
937 /* Add all symbols equivalenced within a segment. We need to scan the
938 segment list multiple times to include indirect equivalences. Since
939 a new segment_info can inserted at the beginning of the segment list,
940 depending on its offset, we have to force a final pass through the
941 loop by demanding that completion sees a pass with no matches; ie.
942 all symbols with equiv_built set and no new equivalences found. */
945 add_equivalences (bool *saw_equiv)
955 for (f = current_segment; f; f = f->next)
957 if (!f->sym->equiv_built)
959 f->sym->equiv_built = 1;
960 seen_one = find_equivalence (f);
970 /* Add a copy of this segment list to the namespace. */
971 copy_equiv_list_to_ns (current_segment);
975 /* Returns the offset necessary to properly align the current equivalence.
976 Sets *palign to the required alignment. */
979 align_segment (unsigned HOST_WIDE_INT *palign)
982 unsigned HOST_WIDE_INT offset;
983 unsigned HOST_WIDE_INT max_align;
984 unsigned HOST_WIDE_INT this_align;
985 unsigned HOST_WIDE_INT this_offset;
989 for (s = current_segment; s; s = s->next)
991 this_align = TYPE_ALIGN_UNIT (s->field);
992 if (s->offset & (this_align - 1))
994 /* Field is misaligned. */
995 this_offset = this_align - ((s->offset + offset) & (this_align - 1));
996 if (this_offset & (max_align - 1))
998 /* Aligning this field would misalign a previous field. */
999 gfc_error ("The equivalence set for variable '%s' "
1000 "declared at %L violates alignment requirements",
1001 s->sym->name, &s->sym->declared_at);
1003 offset += this_offset;
1005 max_align = this_align;
1008 *palign = max_align;
1013 /* Adjust segment offsets by the given amount. */
1016 apply_segment_offset (segment_info *s, HOST_WIDE_INT offset)
1018 for (; s; s = s->next)
1019 s->offset += offset;
1023 /* Lay out a symbol in a common block. If the symbol has already been seen
1024 then check the location is consistent. Otherwise create segments
1025 for that symbol and all the symbols equivalenced with it. */
1027 /* Translate a single common block. */
1030 translate_common (gfc_common_head *common, gfc_symbol *var_list)
1034 segment_info *common_segment;
1035 HOST_WIDE_INT offset;
1036 HOST_WIDE_INT current_offset;
1037 unsigned HOST_WIDE_INT align;
1038 unsigned HOST_WIDE_INT max_align;
1041 common_segment = NULL;
1046 /* Add symbols to the segment. */
1047 for (sym = var_list; sym; sym = sym->common_next)
1049 current_segment = common_segment;
1050 s = find_segment_info (sym);
1052 /* Symbol has already been added via an equivalence. Multiple
1053 use associations of the same common block result in equiv_built
1054 being set but no information about the symbol in the segment. */
1055 if (s && sym->equiv_built)
1057 /* Ensure the current location is properly aligned. */
1058 align = TYPE_ALIGN_UNIT (s->field);
1059 current_offset = (current_offset + align - 1) &~ (align - 1);
1061 /* Verify that it ended up where we expect it. */
1062 if (s->offset != current_offset)
1064 gfc_error ("Equivalence for '%s' does not match ordering of "
1065 "COMMON '%s' at %L", sym->name,
1066 common->name, &common->where);
1071 /* A symbol we haven't seen before. */
1072 s = current_segment = get_segment_info (sym, current_offset);
1074 /* Add all objects directly or indirectly equivalenced with this
1076 add_equivalences (&saw_equiv);
1078 if (current_segment->offset < 0)
1079 gfc_error ("The equivalence set for '%s' cause an invalid "
1080 "extension to COMMON '%s' at %L", sym->name,
1081 common->name, &common->where);
1083 offset = align_segment (&align);
1085 if (offset & (max_align - 1))
1087 /* The required offset conflicts with previous alignment
1088 requirements. Insert padding immediately before this
1090 gfc_warning ("Padding of %d bytes required before '%s' in "
1091 "COMMON '%s' at %L", (int)offset, s->sym->name,
1092 common->name, &common->where);
1096 /* Offset the whole common block. */
1097 apply_segment_offset (common_segment, offset);
1100 /* Apply the offset to the new segments. */
1101 apply_segment_offset (current_segment, offset);
1102 current_offset += offset;
1103 if (max_align < align)
1106 /* Add the new segments to the common block. */
1107 common_segment = add_segments (common_segment, current_segment);
1110 /* The offset of the next common variable. */
1111 current_offset += s->length;
1114 if (common_segment == NULL)
1116 gfc_error ("COMMON '%s' at %L does not exist",
1117 common->name, &common->where);
1121 if (common_segment->offset != 0)
1123 gfc_warning ("COMMON '%s' at %L requires %d bytes of padding at start",
1124 common->name, &common->where, (int)common_segment->offset);
1127 create_common (common, common_segment, saw_equiv);
1131 /* Create a new block for each merged equivalence list. */
1134 finish_equivalences (gfc_namespace *ns)
1138 gfc_common_head * c;
1139 HOST_WIDE_INT offset;
1140 unsigned HOST_WIDE_INT align;
1143 for (z = ns->equiv; z; z = z->next)
1144 for (y = z->eq; y; y = y->eq)
1148 sym = z->expr->symtree->n.sym;
1149 current_segment = get_segment_info (sym, 0);
1151 /* All objects directly or indirectly equivalenced with this
1153 add_equivalences (&dummy);
1155 /* Align the block. */
1156 offset = align_segment (&align);
1158 /* Ensure all offsets are positive. */
1159 offset -= current_segment->offset & ~(align - 1);
1161 apply_segment_offset (current_segment, offset);
1163 /* Create the decl. If this is a module equivalence, it has a
1164 unique name, pointed to by z->module. This is written to a
1165 gfc_common_header to push create_common into using
1166 build_common_decl, so that the equivalence appears as an
1167 external symbol. Otherwise, a local declaration is built using
1168 build_equiv_decl. */
1171 c = gfc_get_common_head ();
1172 /* We've lost the real location, so use the location of the
1173 enclosing procedure. */
1174 c->where = ns->proc_name->declared_at;
1175 strcpy (c->name, z->module);
1180 create_common (c, current_segment, true);
1186 /* Work function for translating a named common block. */
1189 named_common (gfc_symtree *st)
1191 translate_common (st->n.common, st->n.common->head);
1195 /* Translate the common blocks in a namespace. Unlike other variables,
1196 these have to be created before code, because the backend_decl depends
1197 on the rest of the common block. */
1200 gfc_trans_common (gfc_namespace *ns)
1204 /* Translate the blank common block. */
1205 if (ns->blank_common.head != NULL)
1207 c = gfc_get_common_head ();
1209 /* We've lost the real location, so use the location of the
1210 enclosing procedure. */
1211 if (ns->proc_name != NULL)
1212 c->where = ns->proc_name->declared_at;
1214 c->where = ns->blank_common.head->common_head->where;
1216 strcpy (c->name, BLANK_COMMON_NAME);
1217 translate_common (c, ns->blank_common.head);
1220 /* Translate all named common blocks. */
1221 gfc_traverse_symtree (ns->common_root, named_common);
1223 /* Translate local equivalence. */
1224 finish_equivalences (ns);
1226 /* Commit the newly created symbols for common blocks and module
1228 gfc_commit_symbols ();