1 /* Common block and equivalence list handling
2 Copyright (C) 2000, 2003, 2004, 2005, 2006
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 varible 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"
111 /* Holds a single variable in an equivalence set. */
112 typedef struct segment_info
115 HOST_WIDE_INT offset;
116 HOST_WIDE_INT length;
117 /* This will contain the field type until the field is created. */
119 struct segment_info *next;
122 static segment_info * current_segment;
123 static gfc_namespace *gfc_common_ns = NULL;
125 /* Make a segment_info based on a symbol. */
127 static segment_info *
128 get_segment_info (gfc_symbol * sym, HOST_WIDE_INT offset)
132 /* Make sure we've got the character length. */
133 if (sym->ts.type == BT_CHARACTER)
134 gfc_conv_const_charlen (sym->ts.cl);
136 /* Create the segment_info and fill it in. */
137 s = (segment_info *) gfc_getmem (sizeof (segment_info));
139 /* We will use this type when building the segment aggregate type. */
140 s->field = gfc_sym_type (sym);
141 s->length = int_size_in_bytes (s->field);
147 /* Add combine segment V and segment LIST. */
149 static segment_info *
150 add_segments (segment_info *list, segment_info *v)
161 /* Find the location of the new element. */
164 if (v->offset < s->offset)
166 if (v->offset == s->offset
167 && v->length <= s->length)
174 /* Insert the new element in between p and s. */
189 /* Construct mangled common block name from symbol name. */
192 gfc_sym_mangled_common_id (const char *name)
195 char mangled_name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
197 if (strcmp (name, BLANK_COMMON_NAME) == 0)
198 return get_identifier (name);
200 if (gfc_option.flag_underscoring)
202 has_underscore = strchr (name, '_') != 0;
203 if (gfc_option.flag_second_underscore && has_underscore)
204 snprintf (mangled_name, sizeof mangled_name, "%s__", name);
206 snprintf (mangled_name, sizeof mangled_name, "%s_", name);
208 return get_identifier (mangled_name);
211 return get_identifier (name);
215 /* Build a field declaration for a common variable or a local equivalence
219 build_field (segment_info *h, tree union_type, record_layout_info rli)
223 HOST_WIDE_INT offset = h->offset;
224 unsigned HOST_WIDE_INT desired_align, known_align;
226 name = get_identifier (h->sym->name);
227 field = build_decl (FIELD_DECL, name, h->field);
228 gfc_set_decl_location (field, &h->sym->declared_at);
229 known_align = (offset & -offset) * BITS_PER_UNIT;
230 if (known_align == 0 || known_align > BIGGEST_ALIGNMENT)
231 known_align = BIGGEST_ALIGNMENT;
233 desired_align = update_alignment_for_field (rli, field, known_align);
234 if (desired_align > known_align)
235 DECL_PACKED (field) = 1;
237 DECL_FIELD_CONTEXT (field) = union_type;
238 DECL_FIELD_OFFSET (field) = size_int (offset);
239 DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node;
240 SET_DECL_OFFSET_ALIGN (field, known_align);
242 rli->offset = size_binop (MAX_EXPR, rli->offset,
243 size_binop (PLUS_EXPR,
244 DECL_FIELD_OFFSET (field),
245 DECL_SIZE_UNIT (field)));
246 /* If this field is assigned to a label, we create another two variables.
247 One will hold the address of target label or format label. The other will
248 hold the length of format label string. */
249 if (h->sym->attr.assign)
254 gfc_allocate_lang_decl (field);
255 GFC_DECL_ASSIGN (field) = 1;
256 len = gfc_create_var_np (gfc_charlen_type_node,h->sym->name);
257 addr = gfc_create_var_np (pvoid_type_node, h->sym->name);
258 TREE_STATIC (len) = 1;
259 TREE_STATIC (addr) = 1;
260 DECL_INITIAL (len) = build_int_cst (NULL_TREE, -2);
261 gfc_set_decl_location (len, &h->sym->declared_at);
262 gfc_set_decl_location (addr, &h->sym->declared_at);
263 GFC_DECL_STRING_LEN (field) = pushdecl_top_level (len);
264 GFC_DECL_ASSIGN_ADDR (field) = pushdecl_top_level (addr);
271 /* Get storage for local equivalence. */
274 build_equiv_decl (tree union_type, bool is_init, bool is_saved)
278 static int serial = 0;
282 decl = gfc_create_var (union_type, "equiv");
283 TREE_STATIC (decl) = 1;
284 GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
288 snprintf (name, sizeof (name), "equiv.%d", serial++);
289 decl = build_decl (VAR_DECL, get_identifier (name), union_type);
290 DECL_ARTIFICIAL (decl) = 1;
291 DECL_IGNORED_P (decl) = 1;
293 if (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
295 TREE_STATIC (decl) = 1;
297 TREE_ADDRESSABLE (decl) = 1;
298 TREE_USED (decl) = 1;
299 GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
301 /* The source location has been lost, and doesn't really matter.
302 We need to set it to something though. */
303 gfc_set_decl_location (decl, &gfc_current_locus);
305 gfc_add_decl_to_function (decl);
311 /* Get storage for common block. */
314 build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
316 gfc_symbol *common_sym;
319 /* Create a namespace to store symbols for common blocks. */
320 if (gfc_common_ns == NULL)
321 gfc_common_ns = gfc_get_namespace (NULL, 0);
323 gfc_get_symbol (com->name, gfc_common_ns, &common_sym);
324 decl = common_sym->backend_decl;
326 /* Update the size of this common block as needed. */
327 if (decl != NULL_TREE)
329 tree size = TYPE_SIZE_UNIT (union_type);
330 if (tree_int_cst_lt (DECL_SIZE_UNIT (decl), size))
332 /* Named common blocks of the same name shall be of the same size
333 in all scoping units of a program in which they appear, but
334 blank common blocks may be of different sizes. */
335 if (strcmp (com->name, BLANK_COMMON_NAME))
336 gfc_warning ("Named COMMON block '%s' at %L shall be of the "
337 "same size", com->name, &com->where);
338 DECL_SIZE_UNIT (decl) = size;
342 /* If this common block has been declared in a previous program unit,
343 and either it is already initialized or there is no new initialization
344 for it, just return. */
345 if ((decl != NULL_TREE) && (!is_init || DECL_INITIAL (decl)))
348 /* If there is no backend_decl for the common block, build it. */
349 if (decl == NULL_TREE)
351 decl = build_decl (VAR_DECL, get_identifier (com->name), union_type);
352 SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_common_id (com->name));
353 TREE_PUBLIC (decl) = 1;
354 TREE_STATIC (decl) = 1;
355 DECL_ALIGN (decl) = BIGGEST_ALIGNMENT;
356 DECL_USER_ALIGN (decl) = 0;
357 GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
359 gfc_set_decl_location (decl, &com->where);
361 if (com->threadprivate && targetm.have_tls)
362 DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
364 /* Place the back end declaration for this common block in
365 GLOBAL_BINDING_LEVEL. */
366 common_sym->backend_decl = pushdecl_top_level (decl);
369 /* Has no initial values. */
372 DECL_INITIAL (decl) = NULL_TREE;
373 DECL_COMMON (decl) = 1;
374 DECL_DEFER_OUTPUT (decl) = 1;
378 DECL_INITIAL (decl) = error_mark_node;
379 DECL_COMMON (decl) = 0;
380 DECL_DEFER_OUTPUT (decl) = 0;
386 /* Declare memory for the common block or local equivalence, and create
387 backend declarations for all of the elements. */
390 create_common (gfc_common_head *com, segment_info * head, bool saw_equiv)
392 segment_info *s, *next_s;
395 record_layout_info rli;
397 bool is_init = false;
398 bool is_saved = false;
400 /* Declare the variables inside the common block.
401 If the current common block contains any equivalence object, then
402 make a UNION_TYPE node, otherwise RECORD_TYPE. This will let the
403 alias analyzer work well when there is no address overlapping for
404 common variables in the current common block. */
406 union_type = make_node (UNION_TYPE);
408 union_type = make_node (RECORD_TYPE);
410 rli = start_record_layout (union_type);
411 field_link = &TYPE_FIELDS (union_type);
413 for (s = head; s; s = s->next)
415 build_field (s, union_type, rli);
417 /* Link the field into the type. */
418 *field_link = s->field;
419 field_link = &TREE_CHAIN (s->field);
421 /* Has initial value. */
425 /* Has SAVE attribute. */
426 if (s->sym->attr.save)
429 finish_record_layout (rli, true);
432 decl = build_common_decl (com, union_type, is_init);
434 decl = build_equiv_decl (union_type, is_init, is_saved);
439 HOST_WIDE_INT offset = 0;
440 VEC(constructor_elt,gc) *v = NULL;
442 for (s = head; s; s = s->next)
446 if (s->offset < offset)
448 /* We have overlapping initializers. It could either be
449 partially initialized arrays (legal), or the user
450 specified multiple initial values (illegal).
451 We don't implement this yet, so bail out. */
452 gfc_todo_error ("Initialization of overlapping variables");
454 /* Add the initializer for this field. */
455 tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts,
456 TREE_TYPE (s->field), s->sym->attr.dimension,
457 s->sym->attr.pointer || s->sym->attr.allocatable);
459 CONSTRUCTOR_APPEND_ELT (v, s->field, tmp);
460 offset = s->offset + s->length;
463 gcc_assert (!VEC_empty (constructor_elt, v));
464 ctor = build_constructor (union_type, v);
465 TREE_CONSTANT (ctor) = 1;
466 TREE_INVARIANT (ctor) = 1;
467 TREE_STATIC (ctor) = 1;
468 DECL_INITIAL (decl) = ctor;
470 #ifdef ENABLE_CHECKING
473 unsigned HOST_WIDE_INT idx;
474 FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor), idx, field, value)
475 gcc_assert (TREE_CODE (field) == FIELD_DECL);
480 /* Build component reference for each variable. */
481 for (s = head; s; s = next_s)
485 var_decl = build_decl (VAR_DECL, DECL_NAME (s->field),
486 TREE_TYPE (s->field));
487 gfc_set_decl_location (var_decl, &s->sym->declared_at);
488 TREE_PUBLIC (var_decl) = TREE_PUBLIC (decl);
489 TREE_STATIC (var_decl) = TREE_STATIC (decl);
490 TREE_USED (var_decl) = TREE_USED (decl);
491 if (s->sym->attr.target)
492 TREE_ADDRESSABLE (var_decl) = 1;
493 /* This is a fake variable just for debugging purposes. */
494 TREE_ASM_WRITTEN (var_decl) = 1;
497 var_decl = pushdecl_top_level (var_decl);
499 gfc_add_decl_to_function (var_decl);
501 SET_DECL_VALUE_EXPR (var_decl,
502 build3 (COMPONENT_REF, TREE_TYPE (s->field),
503 decl, s->field, NULL_TREE));
504 DECL_HAS_VALUE_EXPR_P (var_decl) = 1;
505 GFC_DECL_COMMON_OR_EQUIV (var_decl) = 1;
507 if (s->sym->attr.assign)
509 gfc_allocate_lang_decl (var_decl);
510 GFC_DECL_ASSIGN (var_decl) = 1;
511 GFC_DECL_STRING_LEN (var_decl) = GFC_DECL_STRING_LEN (s->field);
512 GFC_DECL_ASSIGN_ADDR (var_decl) = GFC_DECL_ASSIGN_ADDR (s->field);
515 s->sym->backend_decl = var_decl;
523 /* Given a symbol, find it in the current segment list. Returns NULL if
526 static segment_info *
527 find_segment_info (gfc_symbol *symbol)
531 for (n = current_segment; n; n = n->next)
533 if (n->sym == symbol)
541 /* Given an expression node, make sure it is a constant integer and return
545 get_mpz (gfc_expr *e)
548 if (e->expr_type != EXPR_CONSTANT)
549 gfc_internal_error ("get_mpz(): Not an integer constant");
551 return &e->value.integer;
555 /* Given an array specification and an array reference, figure out the
556 array element number (zero based). Bounds and elements are guaranteed
557 to be constants. If something goes wrong we generate an error and
561 element_number (gfc_array_ref *ar)
563 mpz_t multiplier, offset, extent, n;
565 HOST_WIDE_INT i, rank;
569 mpz_init_set_ui (multiplier, 1);
570 mpz_init_set_ui (offset, 0);
574 for (i = 0; i < rank; i++)
576 if (ar->dimen_type[i] != DIMEN_ELEMENT)
577 gfc_internal_error ("element_number(): Bad dimension type");
579 mpz_sub (n, *get_mpz (ar->start[i]), *get_mpz (as->lower[i]));
581 mpz_mul (n, n, multiplier);
582 mpz_add (offset, offset, n);
584 mpz_sub (extent, *get_mpz (as->upper[i]), *get_mpz (as->lower[i]));
585 mpz_add_ui (extent, extent, 1);
587 if (mpz_sgn (extent) < 0)
588 mpz_set_ui (extent, 0);
590 mpz_mul (multiplier, multiplier, extent);
593 i = mpz_get_ui (offset);
595 mpz_clear (multiplier);
604 /* Given a single element of an equivalence list, figure out the offset
605 from the base symbol. For simple variables or full arrays, this is
606 simply zero. For an array element we have to calculate the array
607 element number and multiply by the element size. For a substring we
608 have to calculate the further reference. */
611 calculate_offset (gfc_expr *e)
613 HOST_WIDE_INT n, element_size, offset;
614 gfc_typespec *element_type;
618 element_type = &e->symtree->n.sym->ts;
620 for (reference = e->ref; reference; reference = reference->next)
621 switch (reference->type)
624 switch (reference->u.ar.type)
630 n = element_number (&reference->u.ar);
631 if (element_type->type == BT_CHARACTER)
632 gfc_conv_const_charlen (element_type->cl);
634 int_size_in_bytes (gfc_typenode_for_spec (element_type));
635 offset += n * element_size;
639 gfc_error ("Bad array reference at %L", &e->where);
643 if (reference->u.ss.start != NULL)
644 offset += mpz_get_ui (*get_mpz (reference->u.ss.start)) - 1;
647 gfc_error ("Illegal reference type at %L as EQUIVALENCE object",
654 /* Add a new segment_info structure to the current segment. eq1 is already
655 in the list, eq2 is not. */
658 new_condition (segment_info *v, gfc_equiv *eq1, gfc_equiv *eq2)
660 HOST_WIDE_INT offset1, offset2;
663 offset1 = calculate_offset (eq1->expr);
664 offset2 = calculate_offset (eq2->expr);
666 a = get_segment_info (eq2->expr->symtree->n.sym,
667 v->offset + offset1 - offset2);
669 current_segment = add_segments (current_segment, a);
673 /* Given two equivalence structures that are both already in the list, make
674 sure that this new condition is not violated, generating an error if it
678 confirm_condition (segment_info *s1, gfc_equiv *eq1, segment_info *s2,
681 HOST_WIDE_INT offset1, offset2;
683 offset1 = calculate_offset (eq1->expr);
684 offset2 = calculate_offset (eq2->expr);
686 if (s1->offset + offset1 != s2->offset + offset2)
687 gfc_error ("Inconsistent equivalence rules involving '%s' at %L and "
688 "'%s' at %L", s1->sym->name, &s1->sym->declared_at,
689 s2->sym->name, &s2->sym->declared_at);
693 /* Process a new equivalence condition. eq1 is know to be in segment f.
694 If eq2 is also present then confirm that the condition holds.
695 Otherwise add a new variable to the segment list. */
698 add_condition (segment_info *f, gfc_equiv *eq1, gfc_equiv *eq2)
702 n = find_segment_info (eq2->expr->symtree->n.sym);
705 new_condition (f, eq1, eq2);
707 confirm_condition (f, eq1, n, eq2);
711 /* Given a segment element, search through the equivalence lists for unused
712 conditions that involve the symbol. Add these rules to the segment. */
715 find_equivalence (segment_info *n)
717 gfc_equiv *e1, *e2, *eq;
722 for (e1 = n->sym->ns->equiv; e1; e1 = e1->next)
726 /* Search the equivalence list, including the root (first) element
727 for the symbol that owns the segment. */
728 for (e2 = e1; e2; e2 = e2->eq)
730 if (!e2->used && e2->expr->symtree->n.sym == n->sym)
737 /* Go to the next root element. */
743 /* Now traverse the equivalence list matching the offsets. */
744 for (e2 = e1; e2; e2 = e2->eq)
746 if (!e2->used && e2 != eq)
748 add_condition (n, eq, e2);
758 /* Add all symbols equivalenced within a segment. We need to scan the
759 segment list multiple times to include indirect equivalences. */
762 add_equivalences (bool *saw_equiv)
771 for (f = current_segment; f; f = f->next)
773 if (!f->sym->equiv_built)
775 f->sym->equiv_built = 1;
776 more = find_equivalence (f);
785 /* Returns the offset necessary to properly align the current equivalence.
786 Sets *palign to the required alignment. */
789 align_segment (unsigned HOST_WIDE_INT * palign)
792 unsigned HOST_WIDE_INT offset;
793 unsigned HOST_WIDE_INT max_align;
794 unsigned HOST_WIDE_INT this_align;
795 unsigned HOST_WIDE_INT this_offset;
799 for (s = current_segment; s; s = s->next)
801 this_align = TYPE_ALIGN_UNIT (s->field);
802 if (s->offset & (this_align - 1))
804 /* Field is misaligned. */
805 this_offset = this_align - ((s->offset + offset) & (this_align - 1));
806 if (this_offset & (max_align - 1))
808 /* Aligning this field would misalign a previous field. */
809 gfc_error ("The equivalence set for variable '%s' "
810 "declared at %L violates alignment requirents",
811 s->sym->name, &s->sym->declared_at);
813 offset += this_offset;
815 max_align = this_align;
823 /* Adjust segment offsets by the given amount. */
826 apply_segment_offset (segment_info * s, HOST_WIDE_INT offset)
828 for (; s; s = s->next)
833 /* Lay out a symbol in a common block. If the symbol has already been seen
834 then check the location is consistent. Otherwise create segments
835 for that symbol and all the symbols equivalenced with it. */
837 /* Translate a single common block. */
840 translate_common (gfc_common_head *common, gfc_symbol *var_list)
844 segment_info *common_segment;
845 HOST_WIDE_INT offset;
846 HOST_WIDE_INT current_offset;
847 unsigned HOST_WIDE_INT align;
848 unsigned HOST_WIDE_INT max_align;
851 common_segment = NULL;
856 /* Add symbols to the segment. */
857 for (sym = var_list; sym; sym = sym->common_next)
859 current_segment = common_segment;
860 s = find_segment_info (sym);
862 /* Symbol has already been added via an equivalence. Multiple
863 use associations of the same common block result in equiv_built
864 being set but no information about the symbol in the segment. */
865 if (s && sym->equiv_built)
867 /* Ensure the current location is properly aligned. */
868 align = TYPE_ALIGN_UNIT (s->field);
869 current_offset = (current_offset + align - 1) &~ (align - 1);
871 /* Verify that it ended up where we expect it. */
872 if (s->offset != current_offset)
874 gfc_error ("Equivalence for '%s' does not match ordering of "
875 "COMMON '%s' at %L", sym->name,
876 common->name, &common->where);
881 /* A symbol we haven't seen before. */
882 s = current_segment = get_segment_info (sym, current_offset);
884 /* Add all objects directly or indirectly equivalenced with this
886 add_equivalences (&saw_equiv);
888 if (current_segment->offset < 0)
889 gfc_error ("The equivalence set for '%s' cause an invalid "
890 "extension to COMMON '%s' at %L", sym->name,
891 common->name, &common->where);
893 offset = align_segment (&align);
895 if (offset & (max_align - 1))
897 /* The required offset conflicts with previous alignment
898 requirements. Insert padding immediately before this
900 gfc_warning ("Padding of %d bytes required before '%s' in "
901 "COMMON '%s' at %L", (int)offset, s->sym->name,
902 common->name, &common->where);
906 /* Offset the whole common block. */
907 apply_segment_offset (common_segment, offset);
910 /* Apply the offset to the new segments. */
911 apply_segment_offset (current_segment, offset);
912 current_offset += offset;
913 if (max_align < align)
916 /* Add the new segments to the common block. */
917 common_segment = add_segments (common_segment, current_segment);
920 /* The offset of the next common variable. */
921 current_offset += s->length;
924 if (common_segment->offset != 0)
926 gfc_warning ("COMMON '%s' at %L requires %d bytes of padding at start",
927 common->name, &common->where, (int)common_segment->offset);
930 create_common (common, common_segment, saw_equiv);
934 /* Create a new block for each merged equivalence list. */
937 finish_equivalences (gfc_namespace *ns)
942 HOST_WIDE_INT offset;
943 unsigned HOST_WIDE_INT align;
946 for (z = ns->equiv; z; z = z->next)
947 for (y = z->eq; y; y = y->eq)
951 sym = z->expr->symtree->n.sym;
952 current_segment = get_segment_info (sym, 0);
954 /* All objects directly or indirectly equivalenced with this symbol. */
955 add_equivalences (&dummy);
957 /* Align the block. */
958 offset = align_segment (&align);
960 /* Ensure all offsets are positive. */
961 offset -= current_segment->offset & ~(align - 1);
963 apply_segment_offset (current_segment, offset);
965 /* Create the decl. If this is a module equivalence, it has a unique
966 name, pointed to by z->module. This is written to a gfc_common_header
967 to push create_common into using build_common_decl, so that the
968 equivalence appears as an external symbol. Otherwise, a local
969 declaration is built using build_equiv_decl.*/
972 c = gfc_get_common_head ();
973 /* We've lost the real location, so use the location of the
974 enclosing procedure. */
975 c->where = ns->proc_name->declared_at;
976 strcpy (c->name, z->module);
981 create_common (c, current_segment, true);
987 /* Work function for translating a named common block. */
990 named_common (gfc_symtree *st)
992 translate_common (st->n.common, st->n.common->head);
996 /* Translate the common blocks in a namespace. Unlike other variables,
997 these have to be created before code, because the backend_decl depends
998 on the rest of the common block. */
1001 gfc_trans_common (gfc_namespace *ns)
1005 /* Translate the blank common block. */
1006 if (ns->blank_common.head != NULL)
1008 c = gfc_get_common_head ();
1009 /* We've lost the real location, so use the location of the
1010 enclosing procedure. */
1011 c->where = ns->proc_name->declared_at;
1012 strcpy (c->name, BLANK_COMMON_NAME);
1013 translate_common (c, ns->blank_common.head);
1016 /* Translate all named common blocks. */
1017 gfc_traverse_symtree (ns->common_root, named_common);
1019 /* Commit the newly created symbols for common blocks. */
1020 gfc_commit_symbols ();
1022 /* Translate local equivalence. */
1023 finish_equivalences (ns);