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 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"
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
;
126 /* Make a segment_info based on a symbol. */
128 static segment_info
*
129 get_segment_info (gfc_symbol
* sym
, HOST_WIDE_INT offset
)
133 /* Make sure we've got the character length. */
134 if (sym
->ts
.type
== BT_CHARACTER
)
135 gfc_conv_const_charlen (sym
->ts
.cl
);
137 /* Create the segment_info and fill it in. */
138 s
= (segment_info
*) gfc_getmem (sizeof (segment_info
));
140 /* We will use this type when building the segment aggregate type. */
141 s
->field
= gfc_sym_type (sym
);
142 s
->length
= int_size_in_bytes (s
->field
);
149 /* Add a copy of a segment list to the namespace. This is specifically for
150 equivalence segments, so that dependency checking can be done on
151 equivalence group members. */
154 copy_equiv_list_to_ns (segment_info
*c
)
160 l
= (gfc_equiv_list
*) gfc_getmem (sizeof (gfc_equiv_list
));
162 l
->next
= c
->sym
->ns
->equiv_lists
;
163 c
->sym
->ns
->equiv_lists
= l
;
165 for (f
= c
; f
; f
= f
->next
)
167 s
= (gfc_equiv_info
*) gfc_getmem (sizeof (gfc_equiv_info
));
171 s
->offset
= f
->offset
;
172 s
->length
= f
->length
;
177 /* Add combine segment V and segment LIST. */
179 static segment_info
*
180 add_segments (segment_info
*list
, segment_info
*v
)
191 /* Find the location of the new element. */
194 if (v
->offset
< s
->offset
)
196 if (v
->offset
== s
->offset
197 && v
->length
<= s
->length
)
204 /* Insert the new element in between p and s. */
219 /* Construct mangled common block name from symbol name. */
222 gfc_sym_mangled_common_id (const char *name
)
225 char mangled_name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 1];
227 if (strcmp (name
, BLANK_COMMON_NAME
) == 0)
228 return get_identifier (name
);
230 if (gfc_option
.flag_underscoring
)
232 has_underscore
= strchr (name
, '_') != 0;
233 if (gfc_option
.flag_second_underscore
&& has_underscore
)
234 snprintf (mangled_name
, sizeof mangled_name
, "%s__", name
);
236 snprintf (mangled_name
, sizeof mangled_name
, "%s_", name
);
238 return get_identifier (mangled_name
);
241 return get_identifier (name
);
245 /* Build a field declaration for a common variable or a local equivalence
249 build_field (segment_info
*h
, tree union_type
, record_layout_info rli
)
253 HOST_WIDE_INT offset
= h
->offset
;
254 unsigned HOST_WIDE_INT desired_align
, known_align
;
256 name
= get_identifier (h
->sym
->name
);
257 field
= build_decl (FIELD_DECL
, name
, h
->field
);
258 gfc_set_decl_location (field
, &h
->sym
->declared_at
);
259 known_align
= (offset
& -offset
) * BITS_PER_UNIT
;
260 if (known_align
== 0 || known_align
> BIGGEST_ALIGNMENT
)
261 known_align
= BIGGEST_ALIGNMENT
;
263 desired_align
= update_alignment_for_field (rli
, field
, known_align
);
264 if (desired_align
> known_align
)
265 DECL_PACKED (field
) = 1;
267 DECL_FIELD_CONTEXT (field
) = union_type
;
268 DECL_FIELD_OFFSET (field
) = size_int (offset
);
269 DECL_FIELD_BIT_OFFSET (field
) = bitsize_zero_node
;
270 SET_DECL_OFFSET_ALIGN (field
, known_align
);
272 rli
->offset
= size_binop (MAX_EXPR
, rli
->offset
,
273 size_binop (PLUS_EXPR
,
274 DECL_FIELD_OFFSET (field
),
275 DECL_SIZE_UNIT (field
)));
276 /* If this field is assigned to a label, we create another two variables.
277 One will hold the address of target label or format label. The other will
278 hold the length of format label string. */
279 if (h
->sym
->attr
.assign
)
284 gfc_allocate_lang_decl (field
);
285 GFC_DECL_ASSIGN (field
) = 1;
286 len
= gfc_create_var_np (gfc_charlen_type_node
,h
->sym
->name
);
287 addr
= gfc_create_var_np (pvoid_type_node
, h
->sym
->name
);
288 TREE_STATIC (len
) = 1;
289 TREE_STATIC (addr
) = 1;
290 DECL_INITIAL (len
) = build_int_cst (NULL_TREE
, -2);
291 gfc_set_decl_location (len
, &h
->sym
->declared_at
);
292 gfc_set_decl_location (addr
, &h
->sym
->declared_at
);
293 GFC_DECL_STRING_LEN (field
) = pushdecl_top_level (len
);
294 GFC_DECL_ASSIGN_ADDR (field
) = pushdecl_top_level (addr
);
301 /* Get storage for local equivalence. */
304 build_equiv_decl (tree union_type
, bool is_init
, bool is_saved
)
308 static int serial
= 0;
312 decl
= gfc_create_var (union_type
, "equiv");
313 TREE_STATIC (decl
) = 1;
314 GFC_DECL_COMMON_OR_EQUIV (decl
) = 1;
318 snprintf (name
, sizeof (name
), "equiv.%d", serial
++);
319 decl
= build_decl (VAR_DECL
, get_identifier (name
), union_type
);
320 DECL_ARTIFICIAL (decl
) = 1;
321 DECL_IGNORED_P (decl
) = 1;
323 if (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl
))
325 TREE_STATIC (decl
) = 1;
327 TREE_ADDRESSABLE (decl
) = 1;
328 TREE_USED (decl
) = 1;
329 GFC_DECL_COMMON_OR_EQUIV (decl
) = 1;
331 /* The source location has been lost, and doesn't really matter.
332 We need to set it to something though. */
333 gfc_set_decl_location (decl
, &gfc_current_locus
);
335 gfc_add_decl_to_function (decl
);
341 /* Get storage for common block. */
344 build_common_decl (gfc_common_head
*com
, tree union_type
, bool is_init
)
346 gfc_symbol
*common_sym
;
349 /* Create a namespace to store symbols for common blocks. */
350 if (gfc_common_ns
== NULL
)
351 gfc_common_ns
= gfc_get_namespace (NULL
, 0);
353 gfc_get_symbol (com
->name
, gfc_common_ns
, &common_sym
);
354 decl
= common_sym
->backend_decl
;
356 /* Update the size of this common block as needed. */
357 if (decl
!= NULL_TREE
)
359 tree size
= TYPE_SIZE_UNIT (union_type
);
360 if (tree_int_cst_lt (DECL_SIZE_UNIT (decl
), size
))
362 /* Named common blocks of the same name shall be of the same size
363 in all scoping units of a program in which they appear, but
364 blank common blocks may be of different sizes. */
365 if (strcmp (com
->name
, BLANK_COMMON_NAME
))
366 gfc_warning ("Named COMMON block '%s' at %L shall be of the "
367 "same size", com
->name
, &com
->where
);
368 DECL_SIZE_UNIT (decl
) = size
;
372 /* If this common block has been declared in a previous program unit,
373 and either it is already initialized or there is no new initialization
374 for it, just return. */
375 if ((decl
!= NULL_TREE
) && (!is_init
|| DECL_INITIAL (decl
)))
378 /* If there is no backend_decl for the common block, build it. */
379 if (decl
== NULL_TREE
)
381 decl
= build_decl (VAR_DECL
, get_identifier (com
->name
), union_type
);
382 SET_DECL_ASSEMBLER_NAME (decl
, gfc_sym_mangled_common_id (com
->name
));
383 TREE_PUBLIC (decl
) = 1;
384 TREE_STATIC (decl
) = 1;
385 DECL_ALIGN (decl
) = BIGGEST_ALIGNMENT
;
386 DECL_USER_ALIGN (decl
) = 0;
387 GFC_DECL_COMMON_OR_EQUIV (decl
) = 1;
389 gfc_set_decl_location (decl
, &com
->where
);
391 if (com
->threadprivate
&& targetm
.have_tls
)
392 DECL_TLS_MODEL (decl
) = decl_default_tls_model (decl
);
394 /* Place the back end declaration for this common block in
395 GLOBAL_BINDING_LEVEL. */
396 common_sym
->backend_decl
= pushdecl_top_level (decl
);
399 /* Has no initial values. */
402 DECL_INITIAL (decl
) = NULL_TREE
;
403 DECL_COMMON (decl
) = 1;
404 DECL_DEFER_OUTPUT (decl
) = 1;
408 DECL_INITIAL (decl
) = error_mark_node
;
409 DECL_COMMON (decl
) = 0;
410 DECL_DEFER_OUTPUT (decl
) = 0;
416 /* Declare memory for the common block or local equivalence, and create
417 backend declarations for all of the elements. */
420 create_common (gfc_common_head
*com
, segment_info
* head
, bool saw_equiv
)
422 segment_info
*s
, *next_s
;
425 record_layout_info rli
;
427 bool is_init
= false;
428 bool is_saved
= false;
430 /* Declare the variables inside the common block.
431 If the current common block contains any equivalence object, then
432 make a UNION_TYPE node, otherwise RECORD_TYPE. This will let the
433 alias analyzer work well when there is no address overlapping for
434 common variables in the current common block. */
436 union_type
= make_node (UNION_TYPE
);
438 union_type
= make_node (RECORD_TYPE
);
440 rli
= start_record_layout (union_type
);
441 field_link
= &TYPE_FIELDS (union_type
);
443 for (s
= head
; s
; s
= s
->next
)
445 build_field (s
, union_type
, rli
);
447 /* Link the field into the type. */
448 *field_link
= s
->field
;
449 field_link
= &TREE_CHAIN (s
->field
);
451 /* Has initial value. */
455 /* Has SAVE attribute. */
456 if (s
->sym
->attr
.save
)
459 finish_record_layout (rli
, true);
462 decl
= build_common_decl (com
, union_type
, is_init
);
464 decl
= build_equiv_decl (union_type
, is_init
, is_saved
);
469 HOST_WIDE_INT offset
= 0;
470 VEC(constructor_elt
,gc
) *v
= NULL
;
472 for (s
= head
; s
; s
= s
->next
)
476 if (s
->offset
< offset
)
478 /* We have overlapping initializers. It could either be
479 partially initialized arrays (legal), or the user
480 specified multiple initial values (illegal).
481 We don't implement this yet, so bail out. */
482 gfc_todo_error ("Initialization of overlapping variables");
484 /* Add the initializer for this field. */
485 tmp
= gfc_conv_initializer (s
->sym
->value
, &s
->sym
->ts
,
486 TREE_TYPE (s
->field
), s
->sym
->attr
.dimension
,
487 s
->sym
->attr
.pointer
|| s
->sym
->attr
.allocatable
);
489 CONSTRUCTOR_APPEND_ELT (v
, s
->field
, tmp
);
490 offset
= s
->offset
+ s
->length
;
493 gcc_assert (!VEC_empty (constructor_elt
, v
));
494 ctor
= build_constructor (union_type
, v
);
495 TREE_CONSTANT (ctor
) = 1;
496 TREE_INVARIANT (ctor
) = 1;
497 TREE_STATIC (ctor
) = 1;
498 DECL_INITIAL (decl
) = ctor
;
500 #ifdef ENABLE_CHECKING
503 unsigned HOST_WIDE_INT idx
;
504 FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor
), idx
, field
, value
)
505 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
510 /* Build component reference for each variable. */
511 for (s
= head
; s
; s
= next_s
)
515 var_decl
= build_decl (VAR_DECL
, DECL_NAME (s
->field
),
516 TREE_TYPE (s
->field
));
517 gfc_set_decl_location (var_decl
, &s
->sym
->declared_at
);
518 TREE_PUBLIC (var_decl
) = TREE_PUBLIC (decl
);
519 TREE_STATIC (var_decl
) = TREE_STATIC (decl
);
520 TREE_USED (var_decl
) = TREE_USED (decl
);
521 if (s
->sym
->attr
.target
)
522 TREE_ADDRESSABLE (var_decl
) = 1;
523 /* This is a fake variable just for debugging purposes. */
524 TREE_ASM_WRITTEN (var_decl
) = 1;
527 var_decl
= pushdecl_top_level (var_decl
);
529 gfc_add_decl_to_function (var_decl
);
531 SET_DECL_VALUE_EXPR (var_decl
,
532 build3 (COMPONENT_REF
, TREE_TYPE (s
->field
),
533 decl
, s
->field
, NULL_TREE
));
534 DECL_HAS_VALUE_EXPR_P (var_decl
) = 1;
535 GFC_DECL_COMMON_OR_EQUIV (var_decl
) = 1;
537 if (s
->sym
->attr
.assign
)
539 gfc_allocate_lang_decl (var_decl
);
540 GFC_DECL_ASSIGN (var_decl
) = 1;
541 GFC_DECL_STRING_LEN (var_decl
) = GFC_DECL_STRING_LEN (s
->field
);
542 GFC_DECL_ASSIGN_ADDR (var_decl
) = GFC_DECL_ASSIGN_ADDR (s
->field
);
545 s
->sym
->backend_decl
= var_decl
;
553 /* Given a symbol, find it in the current segment list. Returns NULL if
556 static segment_info
*
557 find_segment_info (gfc_symbol
*symbol
)
561 for (n
= current_segment
; n
; n
= n
->next
)
563 if (n
->sym
== symbol
)
571 /* Given an expression node, make sure it is a constant integer and return
575 get_mpz (gfc_expr
*e
)
578 if (e
->expr_type
!= EXPR_CONSTANT
)
579 gfc_internal_error ("get_mpz(): Not an integer constant");
581 return &e
->value
.integer
;
585 /* Given an array specification and an array reference, figure out the
586 array element number (zero based). Bounds and elements are guaranteed
587 to be constants. If something goes wrong we generate an error and
591 element_number (gfc_array_ref
*ar
)
593 mpz_t multiplier
, offset
, extent
, n
;
595 HOST_WIDE_INT i
, rank
;
599 mpz_init_set_ui (multiplier
, 1);
600 mpz_init_set_ui (offset
, 0);
604 for (i
= 0; i
< rank
; i
++)
606 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
607 gfc_internal_error ("element_number(): Bad dimension type");
609 mpz_sub (n
, *get_mpz (ar
->start
[i
]), *get_mpz (as
->lower
[i
]));
611 mpz_mul (n
, n
, multiplier
);
612 mpz_add (offset
, offset
, n
);
614 mpz_sub (extent
, *get_mpz (as
->upper
[i
]), *get_mpz (as
->lower
[i
]));
615 mpz_add_ui (extent
, extent
, 1);
617 if (mpz_sgn (extent
) < 0)
618 mpz_set_ui (extent
, 0);
620 mpz_mul (multiplier
, multiplier
, extent
);
623 i
= mpz_get_ui (offset
);
625 mpz_clear (multiplier
);
634 /* Given a single element of an equivalence list, figure out the offset
635 from the base symbol. For simple variables or full arrays, this is
636 simply zero. For an array element we have to calculate the array
637 element number and multiply by the element size. For a substring we
638 have to calculate the further reference. */
641 calculate_offset (gfc_expr
*e
)
643 HOST_WIDE_INT n
, element_size
, offset
;
644 gfc_typespec
*element_type
;
648 element_type
= &e
->symtree
->n
.sym
->ts
;
650 for (reference
= e
->ref
; reference
; reference
= reference
->next
)
651 switch (reference
->type
)
654 switch (reference
->u
.ar
.type
)
660 n
= element_number (&reference
->u
.ar
);
661 if (element_type
->type
== BT_CHARACTER
)
662 gfc_conv_const_charlen (element_type
->cl
);
664 int_size_in_bytes (gfc_typenode_for_spec (element_type
));
665 offset
+= n
* element_size
;
669 gfc_error ("Bad array reference at %L", &e
->where
);
673 if (reference
->u
.ss
.start
!= NULL
)
674 offset
+= mpz_get_ui (*get_mpz (reference
->u
.ss
.start
)) - 1;
677 gfc_error ("Illegal reference type at %L as EQUIVALENCE object",
684 /* Add a new segment_info structure to the current segment. eq1 is already
685 in the list, eq2 is not. */
688 new_condition (segment_info
*v
, gfc_equiv
*eq1
, gfc_equiv
*eq2
)
690 HOST_WIDE_INT offset1
, offset2
;
693 offset1
= calculate_offset (eq1
->expr
);
694 offset2
= calculate_offset (eq2
->expr
);
696 a
= get_segment_info (eq2
->expr
->symtree
->n
.sym
,
697 v
->offset
+ offset1
- offset2
);
699 current_segment
= add_segments (current_segment
, a
);
703 /* Given two equivalence structures that are both already in the list, make
704 sure that this new condition is not violated, generating an error if it
708 confirm_condition (segment_info
*s1
, gfc_equiv
*eq1
, segment_info
*s2
,
711 HOST_WIDE_INT offset1
, offset2
;
713 offset1
= calculate_offset (eq1
->expr
);
714 offset2
= calculate_offset (eq2
->expr
);
716 if (s1
->offset
+ offset1
!= s2
->offset
+ offset2
)
717 gfc_error ("Inconsistent equivalence rules involving '%s' at %L and "
718 "'%s' at %L", s1
->sym
->name
, &s1
->sym
->declared_at
,
719 s2
->sym
->name
, &s2
->sym
->declared_at
);
723 /* Process a new equivalence condition. eq1 is know to be in segment f.
724 If eq2 is also present then confirm that the condition holds.
725 Otherwise add a new variable to the segment list. */
728 add_condition (segment_info
*f
, gfc_equiv
*eq1
, gfc_equiv
*eq2
)
732 n
= find_segment_info (eq2
->expr
->symtree
->n
.sym
);
735 new_condition (f
, eq1
, eq2
);
737 confirm_condition (f
, eq1
, n
, eq2
);
741 /* Given a segment element, search through the equivalence lists for unused
742 conditions that involve the symbol. Add these rules to the segment. */
745 find_equivalence (segment_info
*n
)
747 gfc_equiv
*e1
, *e2
, *eq
;
752 for (e1
= n
->sym
->ns
->equiv
; e1
; e1
= e1
->next
)
756 /* Search the equivalence list, including the root (first) element
757 for the symbol that owns the segment. */
758 for (e2
= e1
; e2
; e2
= e2
->eq
)
760 if (!e2
->used
&& e2
->expr
->symtree
->n
.sym
== n
->sym
)
767 /* Go to the next root element. */
773 /* Now traverse the equivalence list matching the offsets. */
774 for (e2
= e1
; e2
; e2
= e2
->eq
)
776 if (!e2
->used
&& e2
!= eq
)
778 add_condition (n
, eq
, e2
);
788 /* Add all symbols equivalenced within a segment. We need to scan the
789 segment list multiple times to include indirect equivalences. Since
790 a new segment_info can inserted at the beginning of the segment list,
791 depending on its offset, we have to force a final pass through the
792 loop by demanding that completion sees a pass with no matches; ie.
793 all symbols with equiv_built set and no new equivalences found. */
796 add_equivalences (bool *saw_equiv
)
806 for (f
= current_segment
; f
; f
= f
->next
)
808 if (!f
->sym
->equiv_built
)
810 f
->sym
->equiv_built
= 1;
811 seen_one
= find_equivalence (f
);
821 /* Add a copy of this segment list to the namespace. */
822 copy_equiv_list_to_ns (current_segment
);
826 /* Returns the offset necessary to properly align the current equivalence.
827 Sets *palign to the required alignment. */
830 align_segment (unsigned HOST_WIDE_INT
* palign
)
833 unsigned HOST_WIDE_INT offset
;
834 unsigned HOST_WIDE_INT max_align
;
835 unsigned HOST_WIDE_INT this_align
;
836 unsigned HOST_WIDE_INT this_offset
;
840 for (s
= current_segment
; s
; s
= s
->next
)
842 this_align
= TYPE_ALIGN_UNIT (s
->field
);
843 if (s
->offset
& (this_align
- 1))
845 /* Field is misaligned. */
846 this_offset
= this_align
- ((s
->offset
+ offset
) & (this_align
- 1));
847 if (this_offset
& (max_align
- 1))
849 /* Aligning this field would misalign a previous field. */
850 gfc_error ("The equivalence set for variable '%s' "
851 "declared at %L violates alignment requirements",
852 s
->sym
->name
, &s
->sym
->declared_at
);
854 offset
+= this_offset
;
856 max_align
= this_align
;
864 /* Adjust segment offsets by the given amount. */
867 apply_segment_offset (segment_info
* s
, HOST_WIDE_INT offset
)
869 for (; s
; s
= s
->next
)
874 /* Lay out a symbol in a common block. If the symbol has already been seen
875 then check the location is consistent. Otherwise create segments
876 for that symbol and all the symbols equivalenced with it. */
878 /* Translate a single common block. */
881 translate_common (gfc_common_head
*common
, gfc_symbol
*var_list
)
885 segment_info
*common_segment
;
886 HOST_WIDE_INT offset
;
887 HOST_WIDE_INT current_offset
;
888 unsigned HOST_WIDE_INT align
;
889 unsigned HOST_WIDE_INT max_align
;
892 common_segment
= NULL
;
897 /* Add symbols to the segment. */
898 for (sym
= var_list
; sym
; sym
= sym
->common_next
)
900 current_segment
= common_segment
;
901 s
= find_segment_info (sym
);
903 /* Symbol has already been added via an equivalence. Multiple
904 use associations of the same common block result in equiv_built
905 being set but no information about the symbol in the segment. */
906 if (s
&& sym
->equiv_built
)
908 /* Ensure the current location is properly aligned. */
909 align
= TYPE_ALIGN_UNIT (s
->field
);
910 current_offset
= (current_offset
+ align
- 1) &~ (align
- 1);
912 /* Verify that it ended up where we expect it. */
913 if (s
->offset
!= current_offset
)
915 gfc_error ("Equivalence for '%s' does not match ordering of "
916 "COMMON '%s' at %L", sym
->name
,
917 common
->name
, &common
->where
);
922 /* A symbol we haven't seen before. */
923 s
= current_segment
= get_segment_info (sym
, current_offset
);
925 /* Add all objects directly or indirectly equivalenced with this
927 add_equivalences (&saw_equiv
);
929 if (current_segment
->offset
< 0)
930 gfc_error ("The equivalence set for '%s' cause an invalid "
931 "extension to COMMON '%s' at %L", sym
->name
,
932 common
->name
, &common
->where
);
934 offset
= align_segment (&align
);
936 if (offset
& (max_align
- 1))
938 /* The required offset conflicts with previous alignment
939 requirements. Insert padding immediately before this
941 gfc_warning ("Padding of %d bytes required before '%s' in "
942 "COMMON '%s' at %L", (int)offset
, s
->sym
->name
,
943 common
->name
, &common
->where
);
947 /* Offset the whole common block. */
948 apply_segment_offset (common_segment
, offset
);
951 /* Apply the offset to the new segments. */
952 apply_segment_offset (current_segment
, offset
);
953 current_offset
+= offset
;
954 if (max_align
< align
)
957 /* Add the new segments to the common block. */
958 common_segment
= add_segments (common_segment
, current_segment
);
961 /* The offset of the next common variable. */
962 current_offset
+= s
->length
;
965 if (common_segment
== NULL
)
967 gfc_error ("COMMON '%s' at %L does not exist",
968 common
->name
, &common
->where
);
972 if (common_segment
->offset
!= 0)
974 gfc_warning ("COMMON '%s' at %L requires %d bytes of padding at start",
975 common
->name
, &common
->where
, (int)common_segment
->offset
);
978 create_common (common
, common_segment
, saw_equiv
);
982 /* Create a new block for each merged equivalence list. */
985 finish_equivalences (gfc_namespace
*ns
)
990 HOST_WIDE_INT offset
;
991 unsigned HOST_WIDE_INT align
;
994 for (z
= ns
->equiv
; z
; z
= z
->next
)
995 for (y
= z
->eq
; y
; y
= y
->eq
)
999 sym
= z
->expr
->symtree
->n
.sym
;
1000 current_segment
= get_segment_info (sym
, 0);
1002 /* All objects directly or indirectly equivalenced with this symbol. */
1003 add_equivalences (&dummy
);
1005 /* Align the block. */
1006 offset
= align_segment (&align
);
1008 /* Ensure all offsets are positive. */
1009 offset
-= current_segment
->offset
& ~(align
- 1);
1011 apply_segment_offset (current_segment
, offset
);
1013 /* Create the decl. If this is a module equivalence, it has a unique
1014 name, pointed to by z->module. This is written to a gfc_common_header
1015 to push create_common into using build_common_decl, so that the
1016 equivalence appears as an external symbol. Otherwise, a local
1017 declaration is built using build_equiv_decl.*/
1020 c
= gfc_get_common_head ();
1021 /* We've lost the real location, so use the location of the
1022 enclosing procedure. */
1023 c
->where
= ns
->proc_name
->declared_at
;
1024 strcpy (c
->name
, z
->module
);
1029 create_common (c
, current_segment
, true);
1035 /* Work function for translating a named common block. */
1038 named_common (gfc_symtree
*st
)
1040 translate_common (st
->n
.common
, st
->n
.common
->head
);
1044 /* Translate the common blocks in a namespace. Unlike other variables,
1045 these have to be created before code, because the backend_decl depends
1046 on the rest of the common block. */
1049 gfc_trans_common (gfc_namespace
*ns
)
1053 /* Translate the blank common block. */
1054 if (ns
->blank_common
.head
!= NULL
)
1056 c
= gfc_get_common_head ();
1058 /* We've lost the real location, so use the location of the
1059 enclosing procedure. */
1060 if (ns
->proc_name
!= NULL
)
1061 c
->where
= ns
->proc_name
->declared_at
;
1063 c
->where
= ns
->blank_common
.head
->common_head
->where
;
1065 strcpy (c
->name
, BLANK_COMMON_NAME
);
1066 translate_common (c
, ns
->blank_common
.head
);
1069 /* Translate all named common blocks. */
1070 gfc_traverse_symtree (ns
->common_root
, named_common
);
1072 /* Translate local equivalence. */
1073 finish_equivalences (ns
);
1075 /* Commit the newly created symbols for common blocks and module
1077 gfc_commit_symbols ();