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 3, 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 COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* The core algorithm is based on Andy Vaught's g95 tree. Also the
23 way to build UNION_TYPE is borrowed from Richard Henderson.
25 Transform common blocks. An integral part of this is processing
26 equivalence variables. Equivalenced variables that are not in a
27 common block end up in a private block of their own.
29 Each common block or local equivalence list is declared as a union.
30 Variables within the block are represented as a field within the
31 block with the proper offset.
33 So if two variables are equivalenced, they just point to a common
36 Mathematically, laying out an equivalence block is equivalent to
37 solving a linear system of equations. The matrix is usually a
38 sparse matrix in which each row contains all zero elements except
39 for a +1 and a -1, a sort of a generalized Vandermonde matrix. The
40 matrix is usually block diagonal. The system can be
41 overdetermined, underdetermined or have a unique solution. If the
42 system is inconsistent, the program is not standard conforming.
43 The solution vector is integral, since all of the pivots are +1 or -1.
45 How we lay out an equivalence block is a little less complicated.
46 In an equivalence list with n elements, there are n-1 conditions to
47 be satisfied. The conditions partition the variables into what we
48 will call segments. If A and B are equivalenced then A and B are
49 in the same segment. If B and C are equivalenced as well, then A,
50 B and C are in a segment and so on. Each segment is a block of
51 memory that has one or more variables equivalenced in some way. A
52 common block is made up of a series of segments that are joined one
53 after the other. In the linear system, a segment is a block
56 To lay out a segment we first start with some variable and
57 determine its length. The first variable is assumed to start at
58 offset one and extends to however long it is. We then traverse the
59 list of equivalences to find an unused condition that involves at
60 least one of the variables currently in the segment.
62 Each equivalence condition amounts to the condition B+b=C+c where B
63 and C are the offsets of the B and C variables, and b and c are
64 constants which are nonzero for array elements, substrings or
65 structure components. So for
67 EQUIVALENCE(B(2), C(3))
69 B + 2*size of B's elements = C + 3*size of C's elements.
71 If B and C are known we check to see if the condition already
72 holds. If B is known we can solve for C. Since we know the length
73 of C, we can see if the minimum and maximum extents of the segment
74 are affected. Eventually, we make a full pass through the
75 equivalence list without finding any new conditions and the segment
78 At this point, the segment is added to the current common block.
79 Since we know the minimum extent of the segment, everything in the
80 segment is translated to its position in the common block. The
81 usual case here is that there are no equivalence statements and the
82 common block is series of segments with one variable each, which is
83 a diagonal matrix in the matrix formulation.
85 Each segment is described by a chain of segment_info structures. Each
86 segment_info structure describes the extents of a single variable within
87 the segment. This list is maintained in the order the elements are
88 positioned withing the segment. If two elements have the same starting
89 offset the smaller will come first. If they also have the same size their
90 ordering is undefined.
92 Once all common blocks have been created, the list of equivalences
93 is examined for still-unused equivalence conditions. We create a
94 block for each merged equivalence list. */
98 #include "coretypes.h"
104 #include "gfortran.h"
106 #include "trans-types.h"
107 #include "trans-const.h"
108 #include "target-memory.h"
111 /* TODO: This is defined in match.h, and probably shouldn't be here also,
112 but we need it for now at least and don't want to include the whole
114 gfc_common_head *gfc_get_common (const char *, int);
117 /* Holds a single variable in an equivalence set. */
118 typedef struct segment_info
121 HOST_WIDE_INT offset;
122 HOST_WIDE_INT length;
123 /* This will contain the field type until the field is created. */
125 struct segment_info *next;
128 static segment_info * current_segment;
129 static gfc_namespace *gfc_common_ns = NULL;
132 /* Make a segment_info based on a symbol. */
134 static segment_info *
135 get_segment_info (gfc_symbol * sym, HOST_WIDE_INT offset)
139 /* Make sure we've got the character length. */
140 if (sym->ts.type == BT_CHARACTER)
141 gfc_conv_const_charlen (sym->ts.cl);
143 /* Create the segment_info and fill it in. */
144 s = (segment_info *) gfc_getmem (sizeof (segment_info));
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);
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. */
160 copy_equiv_list_to_ns (segment_info *c)
166 l = (gfc_equiv_list *) gfc_getmem (sizeof (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 = (gfc_equiv_info *) gfc_getmem (sizeof (gfc_equiv_info));
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)
197 /* Find the location of the new element. */
200 if (v->offset < s->offset)
202 if (v->offset == s->offset
203 && v->length <= s->length)
210 /* Insert the new element in between p and s. */
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. */
244 gfc_sym_mangled_common_id (gfc_common_head *com)
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[0] != '\0')
255 return get_identifier (com->binding_label);
257 if (strcmp (name, BLANK_COMMON_NAME) == 0)
258 return get_identifier (name);
260 if (gfc_option.flag_underscoring)
262 has_underscore = strchr (name, '_') != 0;
263 if (gfc_option.flag_second_underscore && has_underscore)
264 snprintf (mangled_name, sizeof mangled_name, "%s__", name);
266 snprintf (mangled_name, sizeof mangled_name, "%s_", name);
268 return get_identifier (mangled_name);
271 return get_identifier (name);
275 /* Build a field declaration for a common variable or a local equivalence
279 build_field (segment_info *h, tree union_type, record_layout_info rli)
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 (FIELD_DECL, name, h->field);
288 gfc_set_decl_location (field, &h->sym->declared_at);
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)
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 (NULL_TREE, -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);
331 /* Get storage for local equivalence. */
334 build_equiv_decl (tree union_type, bool is_init, bool is_saved)
338 static int serial = 0;
342 decl = gfc_create_var (union_type, "equiv");
343 TREE_STATIC (decl) = 1;
344 GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
348 snprintf (name, sizeof (name), "equiv.%d", serial++);
349 decl = build_decl (VAR_DECL, get_identifier (name), union_type);
350 DECL_ARTIFICIAL (decl) = 1;
351 DECL_IGNORED_P (decl) = 1;
353 if (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
355 TREE_STATIC (decl) = 1;
357 TREE_ADDRESSABLE (decl) = 1;
358 TREE_USED (decl) = 1;
359 GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
361 /* The source location has been lost, and doesn't really matter.
362 We need to set it to something though. */
363 gfc_set_decl_location (decl, &gfc_current_locus);
365 gfc_add_decl_to_function (decl);
371 /* Get storage for common block. */
374 build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
376 gfc_symbol *common_sym;
379 /* Create a namespace to store symbols for common blocks. */
380 if (gfc_common_ns == NULL)
381 gfc_common_ns = gfc_get_namespace (NULL, 0);
383 gfc_get_symbol (com->name, gfc_common_ns, &common_sym);
384 decl = common_sym->backend_decl;
386 /* Update the size of this common block as needed. */
387 if (decl != NULL_TREE)
389 tree size = TYPE_SIZE_UNIT (union_type);
390 if (tree_int_cst_lt (DECL_SIZE_UNIT (decl), size))
392 /* Named common blocks of the same name shall be of the same size
393 in all scoping units of a program in which they appear, but
394 blank common blocks may be of different sizes. */
395 if (strcmp (com->name, BLANK_COMMON_NAME))
396 gfc_warning ("Named COMMON block '%s' at %L shall be of the "
397 "same size", com->name, &com->where);
398 DECL_SIZE_UNIT (decl) = size;
399 TREE_TYPE (decl) = union_type;
403 /* If this common block has been declared in a previous program unit,
404 and either it is already initialized or there is no new initialization
405 for it, just return. */
406 if ((decl != NULL_TREE) && (!is_init || DECL_INITIAL (decl)))
409 /* If there is no backend_decl for the common block, build it. */
410 if (decl == NULL_TREE)
412 decl = build_decl (VAR_DECL, get_identifier (com->name), union_type);
413 SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_common_id (com));
414 TREE_PUBLIC (decl) = 1;
415 TREE_STATIC (decl) = 1;
416 DECL_ALIGN (decl) = BIGGEST_ALIGNMENT;
417 DECL_USER_ALIGN (decl) = 0;
418 GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
420 gfc_set_decl_location (decl, &com->where);
422 if (com->threadprivate)
423 DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
425 /* Place the back end declaration for this common block in
426 GLOBAL_BINDING_LEVEL. */
427 common_sym->backend_decl = pushdecl_top_level (decl);
430 /* Has no initial values. */
433 DECL_INITIAL (decl) = NULL_TREE;
434 DECL_COMMON (decl) = 1;
435 DECL_DEFER_OUTPUT (decl) = 1;
439 DECL_INITIAL (decl) = error_mark_node;
440 DECL_COMMON (decl) = 0;
441 DECL_DEFER_OUTPUT (decl) = 0;
447 /* Return a field that is the size of the union, if an equivalence has
448 overlapping initializers. Merge the initializers into a single
449 initializer for this new field, then free the old ones. */
452 get_init_field (segment_info *head, tree union_type, tree *field_init,
453 record_layout_info rli)
456 HOST_WIDE_INT length = 0;
457 HOST_WIDE_INT offset = 0;
458 unsigned HOST_WIDE_INT known_align, desired_align;
459 bool overlap = false;
462 unsigned char *data, *chk;
463 VEC(constructor_elt,gc) *v = NULL;
465 tree type = unsigned_char_type_node;
468 /* Obtain the size of the union and check if there are any overlapping
470 for (s = head; s; s = s->next)
472 HOST_WIDE_INT slen = s->offset + s->length;
475 if (s->offset < offset)
479 length = length < slen ? slen : length;
485 /* Now absorb all the initializer data into a single vector,
486 whilst checking for overlapping, unequal values. */
487 data = (unsigned char*)gfc_getmem ((size_t)length);
488 chk = (unsigned char*)gfc_getmem ((size_t)length);
490 /* TODO - change this when default initialization is implemented. */
491 memset (data, '\0', (size_t)length);
492 memset (chk, '\0', (size_t)length);
493 for (s = head; s; s = s->next)
495 gfc_merge_initializers (s->sym->ts, s->sym->value,
500 for (i = 0; i < length; i++)
501 CONSTRUCTOR_APPEND_ELT (v, NULL, build_int_cst (type, data[i]));
506 /* Build a char[length] array to hold the initializers. Much of what
507 follows is borrowed from build_field, above. */
509 tmp = build_int_cst (gfc_array_index_type, length - 1);
510 tmp = build_range_type (gfc_array_index_type,
511 gfc_index_zero_node, tmp);
512 tmp = build_array_type (type, tmp);
513 field = build_decl (FIELD_DECL, NULL_TREE, tmp);
514 gfc_set_decl_location (field, &gfc_current_locus);
516 known_align = BIGGEST_ALIGNMENT;
518 desired_align = update_alignment_for_field (rli, field, known_align);
519 if (desired_align > known_align)
520 DECL_PACKED (field) = 1;
522 DECL_FIELD_CONTEXT (field) = union_type;
523 DECL_FIELD_OFFSET (field) = size_int (0);
524 DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node;
525 SET_DECL_OFFSET_ALIGN (field, known_align);
527 rli->offset = size_binop (MAX_EXPR, rli->offset,
528 size_binop (PLUS_EXPR,
529 DECL_FIELD_OFFSET (field),
530 DECL_SIZE_UNIT (field)));
532 init = build_constructor (TREE_TYPE (field), v);
533 TREE_CONSTANT (init) = 1;
534 TREE_INVARIANT (init) = 1;
538 for (s = head; s; s = s->next)
540 if (s->sym->value == NULL)
543 gfc_free_expr (s->sym->value);
544 s->sym->value = NULL;
551 /* Declare memory for the common block or local equivalence, and create
552 backend declarations for all of the elements. */
555 create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)
557 segment_info *s, *next_s;
561 tree field_init = NULL_TREE;
562 record_layout_info rli;
564 bool is_init = false;
565 bool is_saved = false;
567 /* Declare the variables inside the common block.
568 If the current common block contains any equivalence object, then
569 make a UNION_TYPE node, otherwise RECORD_TYPE. This will let the
570 alias analyzer work well when there is no address overlapping for
571 common variables in the current common block. */
573 union_type = make_node (UNION_TYPE);
575 union_type = make_node (RECORD_TYPE);
577 rli = start_record_layout (union_type);
578 field_link = &TYPE_FIELDS (union_type);
580 /* Check for overlapping initializers and replace them with a single,
581 artificial field that contains all the data. */
583 field = get_init_field (head, union_type, &field_init, rli);
587 if (field != NULL_TREE)
591 field_link = &TREE_CHAIN (field);
594 for (s = head; s; s = s->next)
596 build_field (s, union_type, rli);
598 /* Link the field into the type. */
599 *field_link = s->field;
600 field_link = &TREE_CHAIN (s->field);
602 /* Has initial value. */
606 /* Has SAVE attribute. */
607 if (s->sym->attr.save)
611 finish_record_layout (rli, true);
614 decl = build_common_decl (com, union_type, is_init);
616 decl = build_equiv_decl (union_type, is_init, is_saved);
621 HOST_WIDE_INT offset = 0;
622 VEC(constructor_elt,gc) *v = NULL;
624 if (field != NULL_TREE && field_init != NULL_TREE)
625 CONSTRUCTOR_APPEND_ELT (v, field, field_init);
627 for (s = head; s; s = s->next)
631 /* Add the initializer for this field. */
632 tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts,
633 TREE_TYPE (s->field), s->sym->attr.dimension,
634 s->sym->attr.pointer || s->sym->attr.allocatable);
636 CONSTRUCTOR_APPEND_ELT (v, s->field, tmp);
637 offset = s->offset + s->length;
641 gcc_assert (!VEC_empty (constructor_elt, v));
642 ctor = build_constructor (union_type, v);
643 TREE_CONSTANT (ctor) = 1;
644 TREE_INVARIANT (ctor) = 1;
645 TREE_STATIC (ctor) = 1;
646 DECL_INITIAL (decl) = ctor;
648 #ifdef ENABLE_CHECKING
651 unsigned HOST_WIDE_INT idx;
652 FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor), idx, field, value)
653 gcc_assert (TREE_CODE (field) == FIELD_DECL);
658 /* Build component reference for each variable. */
659 for (s = head; s; s = next_s)
663 var_decl = build_decl (VAR_DECL, DECL_NAME (s->field),
664 TREE_TYPE (s->field));
665 gfc_set_decl_location (var_decl, &s->sym->declared_at);
666 TREE_PUBLIC (var_decl) = TREE_PUBLIC (decl);
667 TREE_STATIC (var_decl) = TREE_STATIC (decl);
668 TREE_USED (var_decl) = TREE_USED (decl);
669 if (s->sym->attr.target)
670 TREE_ADDRESSABLE (var_decl) = 1;
671 /* This is a fake variable just for debugging purposes. */
672 TREE_ASM_WRITTEN (var_decl) = 1;
675 var_decl = pushdecl_top_level (var_decl);
677 gfc_add_decl_to_function (var_decl);
679 SET_DECL_VALUE_EXPR (var_decl,
680 build3 (COMPONENT_REF, TREE_TYPE (s->field),
681 decl, s->field, NULL_TREE));
682 DECL_HAS_VALUE_EXPR_P (var_decl) = 1;
683 GFC_DECL_COMMON_OR_EQUIV (var_decl) = 1;
685 if (s->sym->attr.assign)
687 gfc_allocate_lang_decl (var_decl);
688 GFC_DECL_ASSIGN (var_decl) = 1;
689 GFC_DECL_STRING_LEN (var_decl) = GFC_DECL_STRING_LEN (s->field);
690 GFC_DECL_ASSIGN_ADDR (var_decl) = GFC_DECL_ASSIGN_ADDR (s->field);
693 s->sym->backend_decl = var_decl;
701 /* Given a symbol, find it in the current segment list. Returns NULL if
704 static segment_info *
705 find_segment_info (gfc_symbol *symbol)
709 for (n = current_segment; n; n = n->next)
711 if (n->sym == symbol)
719 /* Given an expression node, make sure it is a constant integer and return
723 get_mpz (gfc_expr *e)
726 if (e->expr_type != EXPR_CONSTANT)
727 gfc_internal_error ("get_mpz(): Not an integer constant");
729 return &e->value.integer;
733 /* Given an array specification and an array reference, figure out the
734 array element number (zero based). Bounds and elements are guaranteed
735 to be constants. If something goes wrong we generate an error and
739 element_number (gfc_array_ref *ar)
741 mpz_t multiplier, offset, extent, n;
743 HOST_WIDE_INT i, rank;
747 mpz_init_set_ui (multiplier, 1);
748 mpz_init_set_ui (offset, 0);
752 for (i = 0; i < rank; i++)
754 if (ar->dimen_type[i] != DIMEN_ELEMENT)
755 gfc_internal_error ("element_number(): Bad dimension type");
757 mpz_sub (n, *get_mpz (ar->start[i]), *get_mpz (as->lower[i]));
759 mpz_mul (n, n, multiplier);
760 mpz_add (offset, offset, n);
762 mpz_sub (extent, *get_mpz (as->upper[i]), *get_mpz (as->lower[i]));
763 mpz_add_ui (extent, extent, 1);
765 if (mpz_sgn (extent) < 0)
766 mpz_set_ui (extent, 0);
768 mpz_mul (multiplier, multiplier, extent);
771 i = mpz_get_ui (offset);
773 mpz_clear (multiplier);
782 /* Given a single element of an equivalence list, figure out the offset
783 from the base symbol. For simple variables or full arrays, this is
784 simply zero. For an array element we have to calculate the array
785 element number and multiply by the element size. For a substring we
786 have to calculate the further reference. */
789 calculate_offset (gfc_expr *e)
791 HOST_WIDE_INT n, element_size, offset;
792 gfc_typespec *element_type;
796 element_type = &e->symtree->n.sym->ts;
798 for (reference = e->ref; reference; reference = reference->next)
799 switch (reference->type)
802 switch (reference->u.ar.type)
808 n = element_number (&reference->u.ar);
809 if (element_type->type == BT_CHARACTER)
810 gfc_conv_const_charlen (element_type->cl);
812 int_size_in_bytes (gfc_typenode_for_spec (element_type));
813 offset += n * element_size;
817 gfc_error ("Bad array reference at %L", &e->where);
821 if (reference->u.ss.start != NULL)
822 offset += mpz_get_ui (*get_mpz (reference->u.ss.start)) - 1;
825 gfc_error ("Illegal reference type at %L as EQUIVALENCE object",
832 /* Add a new segment_info structure to the current segment. eq1 is already
833 in the list, eq2 is not. */
836 new_condition (segment_info *v, gfc_equiv *eq1, gfc_equiv *eq2)
838 HOST_WIDE_INT offset1, offset2;
841 offset1 = calculate_offset (eq1->expr);
842 offset2 = calculate_offset (eq2->expr);
844 a = get_segment_info (eq2->expr->symtree->n.sym,
845 v->offset + offset1 - offset2);
847 current_segment = add_segments (current_segment, a);
851 /* Given two equivalence structures that are both already in the list, make
852 sure that this new condition is not violated, generating an error if it
856 confirm_condition (segment_info *s1, gfc_equiv *eq1, segment_info *s2,
859 HOST_WIDE_INT offset1, offset2;
861 offset1 = calculate_offset (eq1->expr);
862 offset2 = calculate_offset (eq2->expr);
864 if (s1->offset + offset1 != s2->offset + offset2)
865 gfc_error ("Inconsistent equivalence rules involving '%s' at %L and "
866 "'%s' at %L", s1->sym->name, &s1->sym->declared_at,
867 s2->sym->name, &s2->sym->declared_at);
871 /* Process a new equivalence condition. eq1 is know to be in segment f.
872 If eq2 is also present then confirm that the condition holds.
873 Otherwise add a new variable to the segment list. */
876 add_condition (segment_info *f, gfc_equiv *eq1, gfc_equiv *eq2)
880 n = find_segment_info (eq2->expr->symtree->n.sym);
883 new_condition (f, eq1, eq2);
885 confirm_condition (f, eq1, n, eq2);
889 /* Given a segment element, search through the equivalence lists for unused
890 conditions that involve the symbol. Add these rules to the segment. */
893 find_equivalence (segment_info *n)
895 gfc_equiv *e1, *e2, *eq;
900 for (e1 = n->sym->ns->equiv; e1; e1 = e1->next)
904 /* Search the equivalence list, including the root (first) element
905 for the symbol that owns the segment. */
906 for (e2 = e1; e2; e2 = e2->eq)
908 if (!e2->used && e2->expr->symtree->n.sym == n->sym)
915 /* Go to the next root element. */
921 /* Now traverse the equivalence list matching the offsets. */
922 for (e2 = e1; e2; e2 = e2->eq)
924 if (!e2->used && e2 != eq)
926 add_condition (n, eq, e2);
936 /* Add all symbols equivalenced within a segment. We need to scan the
937 segment list multiple times to include indirect equivalences. Since
938 a new segment_info can inserted at the beginning of the segment list,
939 depending on its offset, we have to force a final pass through the
940 loop by demanding that completion sees a pass with no matches; ie.
941 all symbols with equiv_built set and no new equivalences found. */
944 add_equivalences (bool *saw_equiv)
954 for (f = current_segment; f; f = f->next)
956 if (!f->sym->equiv_built)
958 f->sym->equiv_built = 1;
959 seen_one = find_equivalence (f);
969 /* Add a copy of this segment list to the namespace. */
970 copy_equiv_list_to_ns (current_segment);
974 /* Returns the offset necessary to properly align the current equivalence.
975 Sets *palign to the required alignment. */
978 align_segment (unsigned HOST_WIDE_INT *palign)
981 unsigned HOST_WIDE_INT offset;
982 unsigned HOST_WIDE_INT max_align;
983 unsigned HOST_WIDE_INT this_align;
984 unsigned HOST_WIDE_INT this_offset;
988 for (s = current_segment; s; s = s->next)
990 this_align = TYPE_ALIGN_UNIT (s->field);
991 if (s->offset & (this_align - 1))
993 /* Field is misaligned. */
994 this_offset = this_align - ((s->offset + offset) & (this_align - 1));
995 if (this_offset & (max_align - 1))
997 /* Aligning this field would misalign a previous field. */
998 gfc_error ("The equivalence set for variable '%s' "
999 "declared at %L violates alignment requirements",
1000 s->sym->name, &s->sym->declared_at);
1002 offset += this_offset;
1004 max_align = this_align;
1007 *palign = max_align;
1012 /* Adjust segment offsets by the given amount. */
1015 apply_segment_offset (segment_info *s, HOST_WIDE_INT offset)
1017 for (; s; s = s->next)
1018 s->offset += offset;
1022 /* Lay out a symbol in a common block. If the symbol has already been seen
1023 then check the location is consistent. Otherwise create segments
1024 for that symbol and all the symbols equivalenced with it. */
1026 /* Translate a single common block. */
1029 translate_common (gfc_common_head *common, gfc_symbol *var_list)
1033 segment_info *common_segment;
1034 HOST_WIDE_INT offset;
1035 HOST_WIDE_INT current_offset;
1036 unsigned HOST_WIDE_INT align;
1037 unsigned HOST_WIDE_INT max_align;
1040 common_segment = NULL;
1045 /* Add symbols to the segment. */
1046 for (sym = var_list; sym; sym = sym->common_next)
1048 current_segment = common_segment;
1049 s = find_segment_info (sym);
1051 /* Symbol has already been added via an equivalence. Multiple
1052 use associations of the same common block result in equiv_built
1053 being set but no information about the symbol in the segment. */
1054 if (s && sym->equiv_built)
1056 /* Ensure the current location is properly aligned. */
1057 align = TYPE_ALIGN_UNIT (s->field);
1058 current_offset = (current_offset + align - 1) &~ (align - 1);
1060 /* Verify that it ended up where we expect it. */
1061 if (s->offset != current_offset)
1063 gfc_error ("Equivalence for '%s' does not match ordering of "
1064 "COMMON '%s' at %L", sym->name,
1065 common->name, &common->where);
1070 /* A symbol we haven't seen before. */
1071 s = current_segment = get_segment_info (sym, current_offset);
1073 /* Add all objects directly or indirectly equivalenced with this
1075 add_equivalences (&saw_equiv);
1077 if (current_segment->offset < 0)
1078 gfc_error ("The equivalence set for '%s' cause an invalid "
1079 "extension to COMMON '%s' at %L", sym->name,
1080 common->name, &common->where);
1082 offset = align_segment (&align);
1084 if (offset & (max_align - 1))
1086 /* The required offset conflicts with previous alignment
1087 requirements. Insert padding immediately before this
1089 gfc_warning ("Padding of %d bytes required before '%s' in "
1090 "COMMON '%s' at %L", (int)offset, s->sym->name,
1091 common->name, &common->where);
1095 /* Offset the whole common block. */
1096 apply_segment_offset (common_segment, offset);
1099 /* Apply the offset to the new segments. */
1100 apply_segment_offset (current_segment, offset);
1101 current_offset += offset;
1102 if (max_align < align)
1105 /* Add the new segments to the common block. */
1106 common_segment = add_segments (common_segment, current_segment);
1109 /* The offset of the next common variable. */
1110 current_offset += s->length;
1113 if (common_segment == NULL)
1115 gfc_error ("COMMON '%s' at %L does not exist",
1116 common->name, &common->where);
1120 if (common_segment->offset != 0)
1122 gfc_warning ("COMMON '%s' at %L requires %d bytes of padding at start",
1123 common->name, &common->where, (int)common_segment->offset);
1126 create_common (common, common_segment, saw_equiv);
1130 /* Create a new block for each merged equivalence list. */
1133 finish_equivalences (gfc_namespace *ns)
1137 gfc_common_head * c;
1138 HOST_WIDE_INT offset;
1139 unsigned HOST_WIDE_INT align;
1142 for (z = ns->equiv; z; z = z->next)
1143 for (y = z->eq; y; y = y->eq)
1147 sym = z->expr->symtree->n.sym;
1148 current_segment = get_segment_info (sym, 0);
1150 /* All objects directly or indirectly equivalenced with this
1152 add_equivalences (&dummy);
1154 /* Align the block. */
1155 offset = align_segment (&align);
1157 /* Ensure all offsets are positive. */
1158 offset -= current_segment->offset & ~(align - 1);
1160 apply_segment_offset (current_segment, offset);
1162 /* Create the decl. If this is a module equivalence, it has a
1163 unique name, pointed to by z->module. This is written to a
1164 gfc_common_header to push create_common into using
1165 build_common_decl, so that the equivalence appears as an
1166 external symbol. Otherwise, a local declaration is built using
1167 build_equiv_decl. */
1170 c = gfc_get_common_head ();
1171 /* We've lost the real location, so use the location of the
1172 enclosing procedure. */
1173 c->where = ns->proc_name->declared_at;
1174 strcpy (c->name, z->module);
1179 create_common (c, current_segment, true);
1185 /* Work function for translating a named common block. */
1188 named_common (gfc_symtree *st)
1190 translate_common (st->n.common, st->n.common->head);
1194 /* Translate the common blocks in a namespace. Unlike other variables,
1195 these have to be created before code, because the backend_decl depends
1196 on the rest of the common block. */
1199 gfc_trans_common (gfc_namespace *ns)
1203 /* Translate the blank common block. */
1204 if (ns->blank_common.head != NULL)
1206 c = gfc_get_common_head ();
1208 /* We've lost the real location, so use the location of the
1209 enclosing procedure. */
1210 if (ns->proc_name != NULL)
1211 c->where = ns->proc_name->declared_at;
1213 c->where = ns->blank_common.head->common_head->where;
1215 strcpy (c->name, BLANK_COMMON_NAME);
1216 translate_common (c, ns->blank_common.head);
1219 /* Translate all named common blocks. */
1220 gfc_traverse_symtree (ns->common_root, named_common);
1222 /* Translate local equivalence. */
1223 finish_equivalences (ns);
1225 /* Commit the newly created symbols for common blocks and module
1227 gfc_commit_symbols ();