1 /* Common block and equivalence list handling
2 Copyright (C) 2000-2015 Free Software Foundation, Inc.
3 Contributed by Canqun Yang <canqun@nudt.edu.cn>
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
21 /* The core algorithm is based on Andy Vaught's g95 tree. Also the
22 way to build UNION_TYPE is borrowed from Richard Henderson.
24 Transform common blocks. An integral part of this is processing
25 equivalence variables. Equivalenced variables that are not in a
26 common block end up in a private block of their own.
28 Each common block or local equivalence list is declared as a union.
29 Variables within the block are represented as a field within the
30 block with the proper offset.
32 So if two variables are equivalenced, they just point to a common
35 Mathematically, laying out an equivalence block is equivalent to
36 solving a linear system of equations. The matrix is usually a
37 sparse matrix in which each row contains all zero elements except
38 for a +1 and a -1, a sort of a generalized Vandermonde matrix. The
39 matrix is usually block diagonal. The system can be
40 overdetermined, underdetermined or have a unique solution. If the
41 system is inconsistent, the program is not standard conforming.
42 The solution vector is integral, since all of the pivots are +1 or -1.
44 How we lay out an equivalence block is a little less complicated.
45 In an equivalence list with n elements, there are n-1 conditions to
46 be satisfied. The conditions partition the variables into what we
47 will call segments. If A and B are equivalenced then A and B are
48 in the same segment. If B and C are equivalenced as well, then A,
49 B and C are in a segment and so on. Each segment is a block of
50 memory that has one or more variables equivalenced in some way. A
51 common block is made up of a series of segments that are joined one
52 after the other. In the linear system, a segment is a block
55 To lay out a segment we first start with some variable and
56 determine its length. The first variable is assumed to start at
57 offset one and extends to however long it is. We then traverse the
58 list of equivalences to find an unused condition that involves at
59 least one of the variables currently in the segment.
61 Each equivalence condition amounts to the condition B+b=C+c where B
62 and C are the offsets of the B and C variables, and b and c are
63 constants which are nonzero for array elements, substrings or
64 structure components. So for
66 EQUIVALENCE(B(2), C(3))
68 B + 2*size of B's elements = C + 3*size of C's elements.
70 If B and C are known we check to see if the condition already
71 holds. If B is known we can solve for C. Since we know the length
72 of C, we can see if the minimum and maximum extents of the segment
73 are affected. Eventually, we make a full pass through the
74 equivalence list without finding any new conditions and the segment
77 At this point, the segment is added to the current common block.
78 Since we know the minimum extent of the segment, everything in the
79 segment is translated to its position in the common block. The
80 usual case here is that there are no equivalence statements and the
81 common block is series of segments with one variable each, which is
82 a diagonal matrix in the matrix formulation.
84 Each segment is described by a chain of segment_info structures. Each
85 segment_info structure describes the extents of a single variable within
86 the segment. This list is maintained in the order the elements are
87 positioned within the segment. If two elements have the same starting
88 offset the smaller will come first. If they also have the same size their
89 ordering is undefined.
91 Once all common blocks have been created, the list of equivalences
92 is examined for still-unused equivalence conditions. We create a
93 block for each merged equivalence list. */
98 #include "coretypes.h"
103 #include "fold-const.h"
104 #include "stringpool.h"
105 #include "stor-layout.h"
107 #include "gfortran.h"
109 #include "trans-types.h"
110 #include "trans-const.h"
111 #include "target-memory.h"
114 /* Holds a single variable in an equivalence set. */
115 typedef struct segment_info
118 HOST_WIDE_INT offset
;
119 HOST_WIDE_INT length
;
120 /* This will contain the field type until the field is created. */
122 struct segment_info
*next
;
125 static segment_info
* current_segment
;
127 /* Store decl of all common blocks in this translation unit; the first
128 tree is the identifier. */
129 static std::map
<tree
, tree
> gfc_map_of_all_commons
;
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
.u
.cl
);
143 /* Create the segment_info and fill it in. */
144 s
= XCNEW (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
= XCNEW (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
= XCNEW (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
)
255 return get_identifier (com
->binding_label
);
257 if (strcmp (name
, BLANK_COMMON_NAME
) == 0)
258 return get_identifier (name
);
260 if (flag_underscoring
)
262 has_underscore
= strchr (name
, '_') != 0;
263 if (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 (h
->sym
->declared_at
.lb
->location
,
288 FIELD_DECL
, name
, h
->field
);
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 (gfc_charlen_type_node
, -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
);
327 /* If this field is volatile, mark it. */
328 if (h
->sym
->attr
.volatile_
)
331 TREE_THIS_VOLATILE (field
) = 1;
332 TREE_SIDE_EFFECTS (field
) = 1;
333 new_type
= build_qualified_type (TREE_TYPE (field
), TYPE_QUAL_VOLATILE
);
334 TREE_TYPE (field
) = new_type
;
341 /* Get storage for local equivalence. */
344 build_equiv_decl (tree union_type
, bool is_init
, bool is_saved
)
348 static int serial
= 0;
352 decl
= gfc_create_var (union_type
, "equiv");
353 TREE_STATIC (decl
) = 1;
354 GFC_DECL_COMMON_OR_EQUIV (decl
) = 1;
358 snprintf (name
, sizeof (name
), "equiv.%d", serial
++);
359 decl
= build_decl (input_location
,
360 VAR_DECL
, get_identifier (name
), union_type
);
361 DECL_ARTIFICIAL (decl
) = 1;
362 DECL_IGNORED_P (decl
) = 1;
364 if (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl
))
366 TREE_STATIC (decl
) = 1;
368 TREE_ADDRESSABLE (decl
) = 1;
369 TREE_USED (decl
) = 1;
370 GFC_DECL_COMMON_OR_EQUIV (decl
) = 1;
372 /* The source location has been lost, and doesn't really matter.
373 We need to set it to something though. */
374 gfc_set_decl_location (decl
, &gfc_current_locus
);
376 gfc_add_decl_to_function (decl
);
382 /* Get storage for common block. */
385 build_common_decl (gfc_common_head
*com
, tree union_type
, bool is_init
)
387 tree decl
, identifier
;
389 identifier
= gfc_sym_mangled_common_id (com
);
390 decl
= gfc_map_of_all_commons
.count(identifier
)
391 ? gfc_map_of_all_commons
[identifier
] : NULL_TREE
;
393 /* Update the size of this common block as needed. */
394 if (decl
!= NULL_TREE
)
396 tree size
= TYPE_SIZE_UNIT (union_type
);
398 /* Named common blocks of the same name shall be of the same size
399 in all scoping units of a program in which they appear, but
400 blank common blocks may be of different sizes. */
401 if (!tree_int_cst_equal (DECL_SIZE_UNIT (decl
), size
)
402 && strcmp (com
->name
, BLANK_COMMON_NAME
))
403 gfc_warning (0, "Named COMMON block %qs at %L shall be of the "
404 "same size as elsewhere (%lu vs %lu bytes)", com
->name
,
406 (unsigned long) TREE_INT_CST_LOW (size
),
407 (unsigned long) TREE_INT_CST_LOW (DECL_SIZE_UNIT (decl
)));
409 if (tree_int_cst_lt (DECL_SIZE_UNIT (decl
), size
))
411 DECL_SIZE (decl
) = TYPE_SIZE (union_type
);
412 DECL_SIZE_UNIT (decl
) = size
;
413 DECL_MODE (decl
) = TYPE_MODE (union_type
);
414 TREE_TYPE (decl
) = union_type
;
415 layout_decl (decl
, 0);
419 /* If this common block has been declared in a previous program unit,
420 and either it is already initialized or there is no new initialization
421 for it, just return. */
422 if ((decl
!= NULL_TREE
) && (!is_init
|| DECL_INITIAL (decl
)))
425 /* If there is no backend_decl for the common block, build it. */
426 if (decl
== NULL_TREE
)
428 if (com
->is_bind_c
== 1 && com
->binding_label
)
429 decl
= build_decl (input_location
, VAR_DECL
, identifier
, union_type
);
432 decl
= build_decl (input_location
, VAR_DECL
, get_identifier (com
->name
),
434 gfc_set_decl_assembler_name (decl
, identifier
);
437 TREE_PUBLIC (decl
) = 1;
438 TREE_STATIC (decl
) = 1;
439 DECL_IGNORED_P (decl
) = 1;
441 DECL_ALIGN (decl
) = BIGGEST_ALIGNMENT
;
444 /* Do not set the alignment for bind(c) common blocks to
445 BIGGEST_ALIGNMENT because that won't match what C does. Also,
446 for common blocks with one element, the alignment must be
447 that of the field within the common block in order to match
449 tree field
= NULL_TREE
;
450 field
= TYPE_FIELDS (TREE_TYPE (decl
));
451 if (DECL_CHAIN (field
) == NULL_TREE
)
452 DECL_ALIGN (decl
) = TYPE_ALIGN (TREE_TYPE (field
));
454 DECL_USER_ALIGN (decl
) = 0;
455 GFC_DECL_COMMON_OR_EQUIV (decl
) = 1;
457 gfc_set_decl_location (decl
, &com
->where
);
459 if (com
->threadprivate
)
460 set_decl_tls_model (decl
, decl_default_tls_model (decl
));
462 if (com
->omp_declare_target
)
463 DECL_ATTRIBUTES (decl
)
464 = tree_cons (get_identifier ("omp declare target"),
465 NULL_TREE
, DECL_ATTRIBUTES (decl
));
467 /* Place the back end declaration for this common block in
468 GLOBAL_BINDING_LEVEL. */
469 gfc_map_of_all_commons
[identifier
] = pushdecl_top_level (decl
);
472 /* Has no initial values. */
475 DECL_INITIAL (decl
) = NULL_TREE
;
476 DECL_COMMON (decl
) = 1;
477 DECL_DEFER_OUTPUT (decl
) = 1;
481 DECL_INITIAL (decl
) = error_mark_node
;
482 DECL_COMMON (decl
) = 0;
483 DECL_DEFER_OUTPUT (decl
) = 0;
489 /* Return a field that is the size of the union, if an equivalence has
490 overlapping initializers. Merge the initializers into a single
491 initializer for this new field, then free the old ones. */
494 get_init_field (segment_info
*head
, tree union_type
, tree
*field_init
,
495 record_layout_info rli
)
498 HOST_WIDE_INT length
= 0;
499 HOST_WIDE_INT offset
= 0;
500 unsigned HOST_WIDE_INT known_align
, desired_align
;
501 bool overlap
= false;
504 unsigned char *data
, *chk
;
505 vec
<constructor_elt
, va_gc
> *v
= NULL
;
507 tree type
= unsigned_char_type_node
;
510 /* Obtain the size of the union and check if there are any overlapping
512 for (s
= head
; s
; s
= s
->next
)
514 HOST_WIDE_INT slen
= s
->offset
+ s
->length
;
517 if (s
->offset
< offset
)
521 length
= length
< slen
? slen
: length
;
527 /* Now absorb all the initializer data into a single vector,
528 whilst checking for overlapping, unequal values. */
529 data
= XCNEWVEC (unsigned char, (size_t)length
);
530 chk
= XCNEWVEC (unsigned char, (size_t)length
);
532 /* TODO - change this when default initialization is implemented. */
533 memset (data
, '\0', (size_t)length
);
534 memset (chk
, '\0', (size_t)length
);
535 for (s
= head
; s
; s
= s
->next
)
537 gfc_merge_initializers (s
->sym
->ts
, s
->sym
->value
,
542 for (i
= 0; i
< length
; i
++)
543 CONSTRUCTOR_APPEND_ELT (v
, NULL
, build_int_cst (type
, data
[i
]));
548 /* Build a char[length] array to hold the initializers. Much of what
549 follows is borrowed from build_field, above. */
551 tmp
= build_int_cst (gfc_array_index_type
, length
- 1);
552 tmp
= build_range_type (gfc_array_index_type
,
553 gfc_index_zero_node
, tmp
);
554 tmp
= build_array_type (type
, tmp
);
555 field
= build_decl (gfc_current_locus
.lb
->location
,
556 FIELD_DECL
, NULL_TREE
, tmp
);
558 known_align
= BIGGEST_ALIGNMENT
;
560 desired_align
= update_alignment_for_field (rli
, field
, known_align
);
561 if (desired_align
> known_align
)
562 DECL_PACKED (field
) = 1;
564 DECL_FIELD_CONTEXT (field
) = union_type
;
565 DECL_FIELD_OFFSET (field
) = size_int (0);
566 DECL_FIELD_BIT_OFFSET (field
) = bitsize_zero_node
;
567 SET_DECL_OFFSET_ALIGN (field
, known_align
);
569 rli
->offset
= size_binop (MAX_EXPR
, rli
->offset
,
570 size_binop (PLUS_EXPR
,
571 DECL_FIELD_OFFSET (field
),
572 DECL_SIZE_UNIT (field
)));
574 init
= build_constructor (TREE_TYPE (field
), v
);
575 TREE_CONSTANT (init
) = 1;
579 for (s
= head
; s
; s
= s
->next
)
581 if (s
->sym
->value
== NULL
)
584 gfc_free_expr (s
->sym
->value
);
585 s
->sym
->value
= NULL
;
592 /* Declare memory for the common block or local equivalence, and create
593 backend declarations for all of the elements. */
596 create_common (gfc_common_head
*com
, segment_info
*head
, bool saw_equiv
)
598 segment_info
*s
, *next_s
;
602 tree field_init
= NULL_TREE
;
603 record_layout_info rli
;
605 bool is_init
= false;
606 bool is_saved
= false;
608 /* Declare the variables inside the common block.
609 If the current common block contains any equivalence object, then
610 make a UNION_TYPE node, otherwise RECORD_TYPE. This will let the
611 alias analyzer work well when there is no address overlapping for
612 common variables in the current common block. */
614 union_type
= make_node (UNION_TYPE
);
616 union_type
= make_node (RECORD_TYPE
);
618 rli
= start_record_layout (union_type
);
619 field_link
= &TYPE_FIELDS (union_type
);
621 /* Check for overlapping initializers and replace them with a single,
622 artificial field that contains all the data. */
624 field
= get_init_field (head
, union_type
, &field_init
, rli
);
628 if (field
!= NULL_TREE
)
632 field_link
= &DECL_CHAIN (field
);
635 for (s
= head
; s
; s
= s
->next
)
637 build_field (s
, union_type
, rli
);
639 /* Link the field into the type. */
640 *field_link
= s
->field
;
641 field_link
= &DECL_CHAIN (s
->field
);
643 /* Has initial value. */
647 /* Has SAVE attribute. */
648 if (s
->sym
->attr
.save
)
652 finish_record_layout (rli
, true);
655 decl
= build_common_decl (com
, union_type
, is_init
);
657 decl
= build_equiv_decl (union_type
, is_init
, is_saved
);
662 vec
<constructor_elt
, va_gc
> *v
= NULL
;
664 if (field
!= NULL_TREE
&& field_init
!= NULL_TREE
)
665 CONSTRUCTOR_APPEND_ELT (v
, field
, field_init
);
667 for (s
= head
; s
; s
= s
->next
)
671 /* Add the initializer for this field. */
672 tmp
= gfc_conv_initializer (s
->sym
->value
, &s
->sym
->ts
,
673 TREE_TYPE (s
->field
),
674 s
->sym
->attr
.dimension
,
676 || s
->sym
->attr
.allocatable
, false);
678 CONSTRUCTOR_APPEND_ELT (v
, s
->field
, tmp
);
682 gcc_assert (!v
->is_empty ());
683 ctor
= build_constructor (union_type
, v
);
684 TREE_CONSTANT (ctor
) = 1;
685 TREE_STATIC (ctor
) = 1;
686 DECL_INITIAL (decl
) = ctor
;
688 #ifdef ENABLE_CHECKING
691 unsigned HOST_WIDE_INT idx
;
692 FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor
), idx
, field
, value
)
693 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
698 /* Build component reference for each variable. */
699 for (s
= head
; s
; s
= next_s
)
703 var_decl
= build_decl (s
->sym
->declared_at
.lb
->location
,
704 VAR_DECL
, DECL_NAME (s
->field
),
705 TREE_TYPE (s
->field
));
706 TREE_STATIC (var_decl
) = TREE_STATIC (decl
);
707 /* Mark the variable as used in order to avoid warnings about
709 TREE_USED (var_decl
) = 1;
710 if (s
->sym
->attr
.use_assoc
)
711 DECL_IGNORED_P (var_decl
) = 1;
712 if (s
->sym
->attr
.target
)
713 TREE_ADDRESSABLE (var_decl
) = 1;
714 /* Fake variables are not visible from other translation units. */
715 TREE_PUBLIC (var_decl
) = 0;
716 gfc_finish_decl_attrs (var_decl
, &s
->sym
->attr
);
718 /* To preserve identifier names in COMMON, chain to procedure
719 scope unless at top level in a module definition. */
721 && s
->sym
->ns
->proc_name
722 && s
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
723 var_decl
= pushdecl_top_level (var_decl
);
725 gfc_add_decl_to_function (var_decl
);
727 SET_DECL_VALUE_EXPR (var_decl
,
728 fold_build3_loc (input_location
, COMPONENT_REF
,
729 TREE_TYPE (s
->field
),
730 decl
, s
->field
, NULL_TREE
));
731 DECL_HAS_VALUE_EXPR_P (var_decl
) = 1;
732 GFC_DECL_COMMON_OR_EQUIV (var_decl
) = 1;
734 if (s
->sym
->attr
.assign
)
736 gfc_allocate_lang_decl (var_decl
);
737 GFC_DECL_ASSIGN (var_decl
) = 1;
738 GFC_DECL_STRING_LEN (var_decl
) = GFC_DECL_STRING_LEN (s
->field
);
739 GFC_DECL_ASSIGN_ADDR (var_decl
) = GFC_DECL_ASSIGN_ADDR (s
->field
);
742 s
->sym
->backend_decl
= var_decl
;
750 /* Given a symbol, find it in the current segment list. Returns NULL if
753 static segment_info
*
754 find_segment_info (gfc_symbol
*symbol
)
758 for (n
= current_segment
; n
; n
= n
->next
)
760 if (n
->sym
== symbol
)
768 /* Given an expression node, make sure it is a constant integer and return
772 get_mpz (gfc_expr
*e
)
775 if (e
->expr_type
!= EXPR_CONSTANT
)
776 gfc_internal_error ("get_mpz(): Not an integer constant");
778 return &e
->value
.integer
;
782 /* Given an array specification and an array reference, figure out the
783 array element number (zero based). Bounds and elements are guaranteed
784 to be constants. If something goes wrong we generate an error and
788 element_number (gfc_array_ref
*ar
)
790 mpz_t multiplier
, offset
, extent
, n
;
792 HOST_WIDE_INT i
, rank
;
796 mpz_init_set_ui (multiplier
, 1);
797 mpz_init_set_ui (offset
, 0);
801 for (i
= 0; i
< rank
; i
++)
803 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
804 gfc_internal_error ("element_number(): Bad dimension type");
806 mpz_sub (n
, *get_mpz (ar
->start
[i
]), *get_mpz (as
->lower
[i
]));
808 mpz_mul (n
, n
, multiplier
);
809 mpz_add (offset
, offset
, n
);
811 mpz_sub (extent
, *get_mpz (as
->upper
[i
]), *get_mpz (as
->lower
[i
]));
812 mpz_add_ui (extent
, extent
, 1);
814 if (mpz_sgn (extent
) < 0)
815 mpz_set_ui (extent
, 0);
817 mpz_mul (multiplier
, multiplier
, extent
);
820 i
= mpz_get_ui (offset
);
822 mpz_clear (multiplier
);
831 /* Given a single element of an equivalence list, figure out the offset
832 from the base symbol. For simple variables or full arrays, this is
833 simply zero. For an array element we have to calculate the array
834 element number and multiply by the element size. For a substring we
835 have to calculate the further reference. */
838 calculate_offset (gfc_expr
*e
)
840 HOST_WIDE_INT n
, element_size
, offset
;
841 gfc_typespec
*element_type
;
845 element_type
= &e
->symtree
->n
.sym
->ts
;
847 for (reference
= e
->ref
; reference
; reference
= reference
->next
)
848 switch (reference
->type
)
851 switch (reference
->u
.ar
.type
)
857 n
= element_number (&reference
->u
.ar
);
858 if (element_type
->type
== BT_CHARACTER
)
859 gfc_conv_const_charlen (element_type
->u
.cl
);
861 int_size_in_bytes (gfc_typenode_for_spec (element_type
));
862 offset
+= n
* element_size
;
866 gfc_error ("Bad array reference at %L", &e
->where
);
870 if (reference
->u
.ss
.start
!= NULL
)
871 offset
+= mpz_get_ui (*get_mpz (reference
->u
.ss
.start
)) - 1;
874 gfc_error ("Illegal reference type at %L as EQUIVALENCE object",
881 /* Add a new segment_info structure to the current segment. eq1 is already
882 in the list, eq2 is not. */
885 new_condition (segment_info
*v
, gfc_equiv
*eq1
, gfc_equiv
*eq2
)
887 HOST_WIDE_INT offset1
, offset2
;
890 offset1
= calculate_offset (eq1
->expr
);
891 offset2
= calculate_offset (eq2
->expr
);
893 a
= get_segment_info (eq2
->expr
->symtree
->n
.sym
,
894 v
->offset
+ offset1
- offset2
);
896 current_segment
= add_segments (current_segment
, a
);
900 /* Given two equivalence structures that are both already in the list, make
901 sure that this new condition is not violated, generating an error if it
905 confirm_condition (segment_info
*s1
, gfc_equiv
*eq1
, segment_info
*s2
,
908 HOST_WIDE_INT offset1
, offset2
;
910 offset1
= calculate_offset (eq1
->expr
);
911 offset2
= calculate_offset (eq2
->expr
);
913 if (s1
->offset
+ offset1
!= s2
->offset
+ offset2
)
914 gfc_error ("Inconsistent equivalence rules involving %qs at %L and "
915 "%qs at %L", s1
->sym
->name
, &s1
->sym
->declared_at
,
916 s2
->sym
->name
, &s2
->sym
->declared_at
);
920 /* Process a new equivalence condition. eq1 is know to be in segment f.
921 If eq2 is also present then confirm that the condition holds.
922 Otherwise add a new variable to the segment list. */
925 add_condition (segment_info
*f
, gfc_equiv
*eq1
, gfc_equiv
*eq2
)
929 n
= find_segment_info (eq2
->expr
->symtree
->n
.sym
);
932 new_condition (f
, eq1
, eq2
);
934 confirm_condition (f
, eq1
, n
, eq2
);
938 /* Given a segment element, search through the equivalence lists for unused
939 conditions that involve the symbol. Add these rules to the segment. */
942 find_equivalence (segment_info
*n
)
944 gfc_equiv
*e1
, *e2
, *eq
;
949 for (e1
= n
->sym
->ns
->equiv
; e1
; e1
= e1
->next
)
953 /* Search the equivalence list, including the root (first) element
954 for the symbol that owns the segment. */
955 for (e2
= e1
; e2
; e2
= e2
->eq
)
957 if (!e2
->used
&& e2
->expr
->symtree
->n
.sym
== n
->sym
)
964 /* Go to the next root element. */
970 /* Now traverse the equivalence list matching the offsets. */
971 for (e2
= e1
; e2
; e2
= e2
->eq
)
973 if (!e2
->used
&& e2
!= eq
)
975 add_condition (n
, eq
, e2
);
985 /* Add all symbols equivalenced within a segment. We need to scan the
986 segment list multiple times to include indirect equivalences. Since
987 a new segment_info can inserted at the beginning of the segment list,
988 depending on its offset, we have to force a final pass through the
989 loop by demanding that completion sees a pass with no matches; i.e.,
990 all symbols with equiv_built set and no new equivalences found. */
993 add_equivalences (bool *saw_equiv
)
1003 for (f
= current_segment
; f
; f
= f
->next
)
1005 if (!f
->sym
->equiv_built
)
1007 f
->sym
->equiv_built
= 1;
1008 seen_one
= find_equivalence (f
);
1018 /* Add a copy of this segment list to the namespace. */
1019 copy_equiv_list_to_ns (current_segment
);
1023 /* Returns the offset necessary to properly align the current equivalence.
1024 Sets *palign to the required alignment. */
1026 static HOST_WIDE_INT
1027 align_segment (unsigned HOST_WIDE_INT
*palign
)
1030 unsigned HOST_WIDE_INT offset
;
1031 unsigned HOST_WIDE_INT max_align
;
1032 unsigned HOST_WIDE_INT this_align
;
1033 unsigned HOST_WIDE_INT this_offset
;
1037 for (s
= current_segment
; s
; s
= s
->next
)
1039 this_align
= TYPE_ALIGN_UNIT (s
->field
);
1040 if (s
->offset
& (this_align
- 1))
1042 /* Field is misaligned. */
1043 this_offset
= this_align
- ((s
->offset
+ offset
) & (this_align
- 1));
1044 if (this_offset
& (max_align
- 1))
1046 /* Aligning this field would misalign a previous field. */
1047 gfc_error ("The equivalence set for variable %qs "
1048 "declared at %L violates alignment requirements",
1049 s
->sym
->name
, &s
->sym
->declared_at
);
1051 offset
+= this_offset
;
1053 max_align
= this_align
;
1056 *palign
= max_align
;
1061 /* Adjust segment offsets by the given amount. */
1064 apply_segment_offset (segment_info
*s
, HOST_WIDE_INT offset
)
1066 for (; s
; s
= s
->next
)
1067 s
->offset
+= offset
;
1071 /* Lay out a symbol in a common block. If the symbol has already been seen
1072 then check the location is consistent. Otherwise create segments
1073 for that symbol and all the symbols equivalenced with it. */
1075 /* Translate a single common block. */
1078 translate_common (gfc_common_head
*common
, gfc_symbol
*var_list
)
1082 segment_info
*common_segment
;
1083 HOST_WIDE_INT offset
;
1084 HOST_WIDE_INT current_offset
;
1085 unsigned HOST_WIDE_INT align
;
1088 common_segment
= NULL
;
1094 /* Add symbols to the segment. */
1095 for (sym
= var_list
; sym
; sym
= sym
->common_next
)
1097 current_segment
= common_segment
;
1098 s
= find_segment_info (sym
);
1100 /* Symbol has already been added via an equivalence. Multiple
1101 use associations of the same common block result in equiv_built
1102 being set but no information about the symbol in the segment. */
1103 if (s
&& sym
->equiv_built
)
1105 /* Ensure the current location is properly aligned. */
1106 align
= TYPE_ALIGN_UNIT (s
->field
);
1107 current_offset
= (current_offset
+ align
- 1) &~ (align
- 1);
1109 /* Verify that it ended up where we expect it. */
1110 if (s
->offset
!= current_offset
)
1112 gfc_error ("Equivalence for %qs does not match ordering of "
1113 "COMMON %qs at %L", sym
->name
,
1114 common
->name
, &common
->where
);
1119 /* A symbol we haven't seen before. */
1120 s
= current_segment
= get_segment_info (sym
, current_offset
);
1122 /* Add all objects directly or indirectly equivalenced with this
1124 add_equivalences (&saw_equiv
);
1126 if (current_segment
->offset
< 0)
1127 gfc_error ("The equivalence set for %qs cause an invalid "
1128 "extension to COMMON %qs at %L", sym
->name
,
1129 common
->name
, &common
->where
);
1131 if (flag_align_commons
)
1132 offset
= align_segment (&align
);
1136 /* The required offset conflicts with previous alignment
1137 requirements. Insert padding immediately before this
1139 if (warn_align_commons
)
1141 if (strcmp (common
->name
, BLANK_COMMON_NAME
))
1143 "Padding of %d bytes required before %qs in "
1144 "COMMON %qs at %L; reorder elements or use "
1145 "-fno-align-commons", (int)offset
,
1146 s
->sym
->name
, common
->name
, &common
->where
);
1149 "Padding of %d bytes required before %qs in "
1150 "COMMON at %L; reorder elements or use "
1151 "-fno-align-commons", (int)offset
,
1152 s
->sym
->name
, &common
->where
);
1156 /* Apply the offset to the new segments. */
1157 apply_segment_offset (current_segment
, offset
);
1158 current_offset
+= offset
;
1160 /* Add the new segments to the common block. */
1161 common_segment
= add_segments (common_segment
, current_segment
);
1164 /* The offset of the next common variable. */
1165 current_offset
+= s
->length
;
1168 if (common_segment
== NULL
)
1170 gfc_error ("COMMON '%s' at %L does not exist",
1171 common
->name
, &common
->where
);
1175 if (common_segment
->offset
!= 0 && warn_align_commons
)
1177 if (strcmp (common
->name
, BLANK_COMMON_NAME
))
1178 gfc_warning (OPT_Walign_commons
,
1179 "COMMON %qs at %L requires %d bytes of padding; "
1180 "reorder elements or use %<-fno-align-commons%>",
1181 common
->name
, &common
->where
, (int)common_segment
->offset
);
1183 gfc_warning (OPT_Walign_commons
,
1184 "COMMON at %L requires %d bytes of padding; "
1185 "reorder elements or use %<-fno-align-commons%>",
1186 &common
->where
, (int)common_segment
->offset
);
1189 create_common (common
, common_segment
, saw_equiv
);
1193 /* Create a new block for each merged equivalence list. */
1196 finish_equivalences (gfc_namespace
*ns
)
1200 gfc_common_head
* c
;
1201 HOST_WIDE_INT offset
;
1202 unsigned HOST_WIDE_INT align
;
1205 for (z
= ns
->equiv
; z
; z
= z
->next
)
1206 for (y
= z
->eq
; y
; y
= y
->eq
)
1210 sym
= z
->expr
->symtree
->n
.sym
;
1211 current_segment
= get_segment_info (sym
, 0);
1213 /* All objects directly or indirectly equivalenced with this
1215 add_equivalences (&dummy
);
1217 /* Align the block. */
1218 offset
= align_segment (&align
);
1220 /* Ensure all offsets are positive. */
1221 offset
-= current_segment
->offset
& ~(align
- 1);
1223 apply_segment_offset (current_segment
, offset
);
1225 /* Create the decl. If this is a module equivalence, it has a
1226 unique name, pointed to by z->module. This is written to a
1227 gfc_common_header to push create_common into using
1228 build_common_decl, so that the equivalence appears as an
1229 external symbol. Otherwise, a local declaration is built using
1230 build_equiv_decl. */
1233 c
= gfc_get_common_head ();
1234 /* We've lost the real location, so use the location of the
1235 enclosing procedure. */
1236 c
->where
= ns
->proc_name
->declared_at
;
1237 strcpy (c
->name
, z
->module
);
1242 create_common (c
, current_segment
, true);
1248 /* Work function for translating a named common block. */
1251 named_common (gfc_symtree
*st
)
1253 translate_common (st
->n
.common
, st
->n
.common
->head
);
1257 /* Translate the common blocks in a namespace. Unlike other variables,
1258 these have to be created before code, because the backend_decl depends
1259 on the rest of the common block. */
1262 gfc_trans_common (gfc_namespace
*ns
)
1266 /* Translate the blank common block. */
1267 if (ns
->blank_common
.head
!= NULL
)
1269 c
= gfc_get_common_head ();
1270 c
->where
= ns
->blank_common
.head
->common_head
->where
;
1271 strcpy (c
->name
, BLANK_COMMON_NAME
);
1272 translate_common (c
, ns
->blank_common
.head
);
1275 /* Translate all named common blocks. */
1276 gfc_traverse_symtree (ns
->common_root
, named_common
);
1278 /* Translate local equivalence. */
1279 finish_equivalences (ns
);
1281 /* Commit the newly created symbols for common blocks and module
1283 gfc_commit_symbols ();