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. */
100 #include "coretypes.h"
105 #include "fold-const.h"
106 #include "stringpool.h"
107 #include "stor-layout.h"
109 #include "gfortran.h"
111 #include "trans-types.h"
112 #include "trans-const.h"
113 #include "target-memory.h"
116 /* Holds a single variable in an equivalence set. */
117 typedef struct segment_info
120 HOST_WIDE_INT offset
;
121 HOST_WIDE_INT length
;
122 /* This will contain the field type until the field is created. */
124 struct segment_info
*next
;
127 static segment_info
* current_segment
;
129 /* Store decl of all common blocks in this translation unit; the first
130 tree is the identifier. */
131 static std::map
<tree
, tree
> gfc_map_of_all_commons
;
134 /* Make a segment_info based on a symbol. */
136 static segment_info
*
137 get_segment_info (gfc_symbol
* sym
, HOST_WIDE_INT offset
)
141 /* Make sure we've got the character length. */
142 if (sym
->ts
.type
== BT_CHARACTER
)
143 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
145 /* Create the segment_info and fill it in. */
146 s
= XCNEW (segment_info
);
148 /* We will use this type when building the segment aggregate type. */
149 s
->field
= gfc_sym_type (sym
);
150 s
->length
= int_size_in_bytes (s
->field
);
157 /* Add a copy of a segment list to the namespace. This is specifically for
158 equivalence segments, so that dependency checking can be done on
159 equivalence group members. */
162 copy_equiv_list_to_ns (segment_info
*c
)
168 l
= XCNEW (gfc_equiv_list
);
170 l
->next
= c
->sym
->ns
->equiv_lists
;
171 c
->sym
->ns
->equiv_lists
= l
;
173 for (f
= c
; f
; f
= f
->next
)
175 s
= XCNEW (gfc_equiv_info
);
179 s
->offset
= f
->offset
;
180 s
->length
= f
->length
;
185 /* Add combine segment V and segment LIST. */
187 static segment_info
*
188 add_segments (segment_info
*list
, segment_info
*v
)
199 /* Find the location of the new element. */
202 if (v
->offset
< s
->offset
)
204 if (v
->offset
== s
->offset
205 && v
->length
<= s
->length
)
212 /* Insert the new element in between p and s. */
228 /* Construct mangled common block name from symbol name. */
230 /* We need the bind(c) flag to tell us how/if we should mangle the symbol
231 name. There are few calls to this function, so few places that this
232 would need to be added. At the moment, there is only one call, in
233 build_common_decl(). We can't attempt to look up the common block
234 because we may be building it for the first time and therefore, it won't
235 be in the common_root. We also need the binding label, if it's bind(c).
236 Therefore, send in the pointer to the common block, so whatever info we
237 have so far can be used. All of the necessary info should be available
238 in the gfc_common_head by now, so it should be accurate to test the
239 isBindC flag and use the binding label given if it is bind(c).
241 We may NOT know yet if it's bind(c) or not, but we can try at least.
242 Will have to figure out what to do later if it's labeled bind(c)
243 after this is called. */
246 gfc_sym_mangled_common_id (gfc_common_head
*com
)
249 char mangled_name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 1];
250 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
252 /* Get the name out of the common block pointer. */
253 strcpy (name
, com
->name
);
255 /* If we're suppose to do a bind(c). */
256 if (com
->is_bind_c
== 1 && com
->binding_label
)
257 return get_identifier (com
->binding_label
);
259 if (strcmp (name
, BLANK_COMMON_NAME
) == 0)
260 return get_identifier (name
);
262 if (flag_underscoring
)
264 has_underscore
= strchr (name
, '_') != 0;
265 if (flag_second_underscore
&& has_underscore
)
266 snprintf (mangled_name
, sizeof mangled_name
, "%s__", name
);
268 snprintf (mangled_name
, sizeof mangled_name
, "%s_", name
);
270 return get_identifier (mangled_name
);
273 return get_identifier (name
);
277 /* Build a field declaration for a common variable or a local equivalence
281 build_field (segment_info
*h
, tree union_type
, record_layout_info rli
)
285 HOST_WIDE_INT offset
= h
->offset
;
286 unsigned HOST_WIDE_INT desired_align
, known_align
;
288 name
= get_identifier (h
->sym
->name
);
289 field
= build_decl (h
->sym
->declared_at
.lb
->location
,
290 FIELD_DECL
, name
, h
->field
);
291 known_align
= (offset
& -offset
) * BITS_PER_UNIT
;
292 if (known_align
== 0 || known_align
> BIGGEST_ALIGNMENT
)
293 known_align
= BIGGEST_ALIGNMENT
;
295 desired_align
= update_alignment_for_field (rli
, field
, known_align
);
296 if (desired_align
> known_align
)
297 DECL_PACKED (field
) = 1;
299 DECL_FIELD_CONTEXT (field
) = union_type
;
300 DECL_FIELD_OFFSET (field
) = size_int (offset
);
301 DECL_FIELD_BIT_OFFSET (field
) = bitsize_zero_node
;
302 SET_DECL_OFFSET_ALIGN (field
, known_align
);
304 rli
->offset
= size_binop (MAX_EXPR
, rli
->offset
,
305 size_binop (PLUS_EXPR
,
306 DECL_FIELD_OFFSET (field
),
307 DECL_SIZE_UNIT (field
)));
308 /* If this field is assigned to a label, we create another two variables.
309 One will hold the address of target label or format label. The other will
310 hold the length of format label string. */
311 if (h
->sym
->attr
.assign
)
316 gfc_allocate_lang_decl (field
);
317 GFC_DECL_ASSIGN (field
) = 1;
318 len
= gfc_create_var_np (gfc_charlen_type_node
,h
->sym
->name
);
319 addr
= gfc_create_var_np (pvoid_type_node
, h
->sym
->name
);
320 TREE_STATIC (len
) = 1;
321 TREE_STATIC (addr
) = 1;
322 DECL_INITIAL (len
) = build_int_cst (gfc_charlen_type_node
, -2);
323 gfc_set_decl_location (len
, &h
->sym
->declared_at
);
324 gfc_set_decl_location (addr
, &h
->sym
->declared_at
);
325 GFC_DECL_STRING_LEN (field
) = pushdecl_top_level (len
);
326 GFC_DECL_ASSIGN_ADDR (field
) = pushdecl_top_level (addr
);
329 /* If this field is volatile, mark it. */
330 if (h
->sym
->attr
.volatile_
)
333 TREE_THIS_VOLATILE (field
) = 1;
334 TREE_SIDE_EFFECTS (field
) = 1;
335 new_type
= build_qualified_type (TREE_TYPE (field
), TYPE_QUAL_VOLATILE
);
336 TREE_TYPE (field
) = new_type
;
343 /* Get storage for local equivalence. */
346 build_equiv_decl (tree union_type
, bool is_init
, bool is_saved
)
350 static int serial
= 0;
354 decl
= gfc_create_var (union_type
, "equiv");
355 TREE_STATIC (decl
) = 1;
356 GFC_DECL_COMMON_OR_EQUIV (decl
) = 1;
360 snprintf (name
, sizeof (name
), "equiv.%d", serial
++);
361 decl
= build_decl (input_location
,
362 VAR_DECL
, get_identifier (name
), union_type
);
363 DECL_ARTIFICIAL (decl
) = 1;
364 DECL_IGNORED_P (decl
) = 1;
366 if (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl
))
368 TREE_STATIC (decl
) = 1;
370 TREE_ADDRESSABLE (decl
) = 1;
371 TREE_USED (decl
) = 1;
372 GFC_DECL_COMMON_OR_EQUIV (decl
) = 1;
374 /* The source location has been lost, and doesn't really matter.
375 We need to set it to something though. */
376 gfc_set_decl_location (decl
, &gfc_current_locus
);
378 gfc_add_decl_to_function (decl
);
384 /* Get storage for common block. */
387 build_common_decl (gfc_common_head
*com
, tree union_type
, bool is_init
)
389 tree decl
, identifier
;
391 identifier
= gfc_sym_mangled_common_id (com
);
392 decl
= gfc_map_of_all_commons
.count(identifier
)
393 ? gfc_map_of_all_commons
[identifier
] : NULL_TREE
;
395 /* Update the size of this common block as needed. */
396 if (decl
!= NULL_TREE
)
398 tree size
= TYPE_SIZE_UNIT (union_type
);
400 /* Named common blocks of the same name shall be of the same size
401 in all scoping units of a program in which they appear, but
402 blank common blocks may be of different sizes. */
403 if (!tree_int_cst_equal (DECL_SIZE_UNIT (decl
), size
)
404 && strcmp (com
->name
, BLANK_COMMON_NAME
))
405 gfc_warning (0, "Named COMMON block %qs at %L shall be of the "
406 "same size as elsewhere (%lu vs %lu bytes)", com
->name
,
408 (unsigned long) TREE_INT_CST_LOW (size
),
409 (unsigned long) TREE_INT_CST_LOW (DECL_SIZE_UNIT (decl
)));
411 if (tree_int_cst_lt (DECL_SIZE_UNIT (decl
), size
))
413 DECL_SIZE (decl
) = TYPE_SIZE (union_type
);
414 DECL_SIZE_UNIT (decl
) = size
;
415 DECL_MODE (decl
) = TYPE_MODE (union_type
);
416 TREE_TYPE (decl
) = union_type
;
417 layout_decl (decl
, 0);
421 /* If this common block has been declared in a previous program unit,
422 and either it is already initialized or there is no new initialization
423 for it, just return. */
424 if ((decl
!= NULL_TREE
) && (!is_init
|| DECL_INITIAL (decl
)))
427 /* If there is no backend_decl for the common block, build it. */
428 if (decl
== NULL_TREE
)
430 if (com
->is_bind_c
== 1 && com
->binding_label
)
431 decl
= build_decl (input_location
, VAR_DECL
, identifier
, union_type
);
434 decl
= build_decl (input_location
, VAR_DECL
, get_identifier (com
->name
),
436 gfc_set_decl_assembler_name (decl
, identifier
);
439 TREE_PUBLIC (decl
) = 1;
440 TREE_STATIC (decl
) = 1;
441 DECL_IGNORED_P (decl
) = 1;
443 DECL_ALIGN (decl
) = BIGGEST_ALIGNMENT
;
446 /* Do not set the alignment for bind(c) common blocks to
447 BIGGEST_ALIGNMENT because that won't match what C does. Also,
448 for common blocks with one element, the alignment must be
449 that of the field within the common block in order to match
451 tree field
= NULL_TREE
;
452 field
= TYPE_FIELDS (TREE_TYPE (decl
));
453 if (DECL_CHAIN (field
) == NULL_TREE
)
454 DECL_ALIGN (decl
) = TYPE_ALIGN (TREE_TYPE (field
));
456 DECL_USER_ALIGN (decl
) = 0;
457 GFC_DECL_COMMON_OR_EQUIV (decl
) = 1;
459 gfc_set_decl_location (decl
, &com
->where
);
461 if (com
->threadprivate
)
462 set_decl_tls_model (decl
, decl_default_tls_model (decl
));
464 if (com
->omp_declare_target
)
465 DECL_ATTRIBUTES (decl
)
466 = tree_cons (get_identifier ("omp declare target"),
467 NULL_TREE
, DECL_ATTRIBUTES (decl
));
469 /* Place the back end declaration for this common block in
470 GLOBAL_BINDING_LEVEL. */
471 gfc_map_of_all_commons
[identifier
] = pushdecl_top_level (decl
);
474 /* Has no initial values. */
477 DECL_INITIAL (decl
) = NULL_TREE
;
478 DECL_COMMON (decl
) = 1;
479 DECL_DEFER_OUTPUT (decl
) = 1;
483 DECL_INITIAL (decl
) = error_mark_node
;
484 DECL_COMMON (decl
) = 0;
485 DECL_DEFER_OUTPUT (decl
) = 0;
491 /* Return a field that is the size of the union, if an equivalence has
492 overlapping initializers. Merge the initializers into a single
493 initializer for this new field, then free the old ones. */
496 get_init_field (segment_info
*head
, tree union_type
, tree
*field_init
,
497 record_layout_info rli
)
500 HOST_WIDE_INT length
= 0;
501 HOST_WIDE_INT offset
= 0;
502 unsigned HOST_WIDE_INT known_align
, desired_align
;
503 bool overlap
= false;
506 unsigned char *data
, *chk
;
507 vec
<constructor_elt
, va_gc
> *v
= NULL
;
509 tree type
= unsigned_char_type_node
;
512 /* Obtain the size of the union and check if there are any overlapping
514 for (s
= head
; s
; s
= s
->next
)
516 HOST_WIDE_INT slen
= s
->offset
+ s
->length
;
519 if (s
->offset
< offset
)
523 length
= length
< slen
? slen
: length
;
529 /* Now absorb all the initializer data into a single vector,
530 whilst checking for overlapping, unequal values. */
531 data
= XCNEWVEC (unsigned char, (size_t)length
);
532 chk
= XCNEWVEC (unsigned char, (size_t)length
);
534 /* TODO - change this when default initialization is implemented. */
535 memset (data
, '\0', (size_t)length
);
536 memset (chk
, '\0', (size_t)length
);
537 for (s
= head
; s
; s
= s
->next
)
539 gfc_merge_initializers (s
->sym
->ts
, s
->sym
->value
,
544 for (i
= 0; i
< length
; i
++)
545 CONSTRUCTOR_APPEND_ELT (v
, NULL
, build_int_cst (type
, data
[i
]));
550 /* Build a char[length] array to hold the initializers. Much of what
551 follows is borrowed from build_field, above. */
553 tmp
= build_int_cst (gfc_array_index_type
, length
- 1);
554 tmp
= build_range_type (gfc_array_index_type
,
555 gfc_index_zero_node
, tmp
);
556 tmp
= build_array_type (type
, tmp
);
557 field
= build_decl (gfc_current_locus
.lb
->location
,
558 FIELD_DECL
, NULL_TREE
, tmp
);
560 known_align
= BIGGEST_ALIGNMENT
;
562 desired_align
= update_alignment_for_field (rli
, field
, known_align
);
563 if (desired_align
> known_align
)
564 DECL_PACKED (field
) = 1;
566 DECL_FIELD_CONTEXT (field
) = union_type
;
567 DECL_FIELD_OFFSET (field
) = size_int (0);
568 DECL_FIELD_BIT_OFFSET (field
) = bitsize_zero_node
;
569 SET_DECL_OFFSET_ALIGN (field
, known_align
);
571 rli
->offset
= size_binop (MAX_EXPR
, rli
->offset
,
572 size_binop (PLUS_EXPR
,
573 DECL_FIELD_OFFSET (field
),
574 DECL_SIZE_UNIT (field
)));
576 init
= build_constructor (TREE_TYPE (field
), v
);
577 TREE_CONSTANT (init
) = 1;
581 for (s
= head
; s
; s
= s
->next
)
583 if (s
->sym
->value
== NULL
)
586 gfc_free_expr (s
->sym
->value
);
587 s
->sym
->value
= NULL
;
594 /* Declare memory for the common block or local equivalence, and create
595 backend declarations for all of the elements. */
598 create_common (gfc_common_head
*com
, segment_info
*head
, bool saw_equiv
)
600 segment_info
*s
, *next_s
;
604 tree field_init
= NULL_TREE
;
605 record_layout_info rli
;
607 bool is_init
= false;
608 bool is_saved
= false;
610 /* Declare the variables inside the common block.
611 If the current common block contains any equivalence object, then
612 make a UNION_TYPE node, otherwise RECORD_TYPE. This will let the
613 alias analyzer work well when there is no address overlapping for
614 common variables in the current common block. */
616 union_type
= make_node (UNION_TYPE
);
618 union_type
= make_node (RECORD_TYPE
);
620 rli
= start_record_layout (union_type
);
621 field_link
= &TYPE_FIELDS (union_type
);
623 /* Check for overlapping initializers and replace them with a single,
624 artificial field that contains all the data. */
626 field
= get_init_field (head
, union_type
, &field_init
, rli
);
630 if (field
!= NULL_TREE
)
634 field_link
= &DECL_CHAIN (field
);
637 for (s
= head
; s
; s
= s
->next
)
639 build_field (s
, union_type
, rli
);
641 /* Link the field into the type. */
642 *field_link
= s
->field
;
643 field_link
= &DECL_CHAIN (s
->field
);
645 /* Has initial value. */
649 /* Has SAVE attribute. */
650 if (s
->sym
->attr
.save
)
654 finish_record_layout (rli
, true);
657 decl
= build_common_decl (com
, union_type
, is_init
);
659 decl
= build_equiv_decl (union_type
, is_init
, is_saved
);
664 vec
<constructor_elt
, va_gc
> *v
= NULL
;
666 if (field
!= NULL_TREE
&& field_init
!= NULL_TREE
)
667 CONSTRUCTOR_APPEND_ELT (v
, field
, field_init
);
669 for (s
= head
; s
; s
= s
->next
)
673 /* Add the initializer for this field. */
674 tmp
= gfc_conv_initializer (s
->sym
->value
, &s
->sym
->ts
,
675 TREE_TYPE (s
->field
),
676 s
->sym
->attr
.dimension
,
678 || s
->sym
->attr
.allocatable
, false);
680 CONSTRUCTOR_APPEND_ELT (v
, s
->field
, tmp
);
684 gcc_assert (!v
->is_empty ());
685 ctor
= build_constructor (union_type
, v
);
686 TREE_CONSTANT (ctor
) = 1;
687 TREE_STATIC (ctor
) = 1;
688 DECL_INITIAL (decl
) = ctor
;
690 #ifdef ENABLE_CHECKING
693 unsigned HOST_WIDE_INT idx
;
694 FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor
), idx
, field
, value
)
695 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
700 /* Build component reference for each variable. */
701 for (s
= head
; s
; s
= next_s
)
705 var_decl
= build_decl (s
->sym
->declared_at
.lb
->location
,
706 VAR_DECL
, DECL_NAME (s
->field
),
707 TREE_TYPE (s
->field
));
708 TREE_STATIC (var_decl
) = TREE_STATIC (decl
);
709 /* Mark the variable as used in order to avoid warnings about
711 TREE_USED (var_decl
) = 1;
712 if (s
->sym
->attr
.use_assoc
)
713 DECL_IGNORED_P (var_decl
) = 1;
714 if (s
->sym
->attr
.target
)
715 TREE_ADDRESSABLE (var_decl
) = 1;
716 /* Fake variables are not visible from other translation units. */
717 TREE_PUBLIC (var_decl
) = 0;
718 gfc_finish_decl_attrs (var_decl
, &s
->sym
->attr
);
720 /* To preserve identifier names in COMMON, chain to procedure
721 scope unless at top level in a module definition. */
723 && s
->sym
->ns
->proc_name
724 && s
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
725 var_decl
= pushdecl_top_level (var_decl
);
727 gfc_add_decl_to_function (var_decl
);
729 SET_DECL_VALUE_EXPR (var_decl
,
730 fold_build3_loc (input_location
, COMPONENT_REF
,
731 TREE_TYPE (s
->field
),
732 decl
, s
->field
, NULL_TREE
));
733 DECL_HAS_VALUE_EXPR_P (var_decl
) = 1;
734 GFC_DECL_COMMON_OR_EQUIV (var_decl
) = 1;
736 if (s
->sym
->attr
.assign
)
738 gfc_allocate_lang_decl (var_decl
);
739 GFC_DECL_ASSIGN (var_decl
) = 1;
740 GFC_DECL_STRING_LEN (var_decl
) = GFC_DECL_STRING_LEN (s
->field
);
741 GFC_DECL_ASSIGN_ADDR (var_decl
) = GFC_DECL_ASSIGN_ADDR (s
->field
);
744 s
->sym
->backend_decl
= var_decl
;
752 /* Given a symbol, find it in the current segment list. Returns NULL if
755 static segment_info
*
756 find_segment_info (gfc_symbol
*symbol
)
760 for (n
= current_segment
; n
; n
= n
->next
)
762 if (n
->sym
== symbol
)
770 /* Given an expression node, make sure it is a constant integer and return
774 get_mpz (gfc_expr
*e
)
777 if (e
->expr_type
!= EXPR_CONSTANT
)
778 gfc_internal_error ("get_mpz(): Not an integer constant");
780 return &e
->value
.integer
;
784 /* Given an array specification and an array reference, figure out the
785 array element number (zero based). Bounds and elements are guaranteed
786 to be constants. If something goes wrong we generate an error and
790 element_number (gfc_array_ref
*ar
)
792 mpz_t multiplier
, offset
, extent
, n
;
794 HOST_WIDE_INT i
, rank
;
798 mpz_init_set_ui (multiplier
, 1);
799 mpz_init_set_ui (offset
, 0);
803 for (i
= 0; i
< rank
; i
++)
805 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
806 gfc_internal_error ("element_number(): Bad dimension type");
808 mpz_sub (n
, *get_mpz (ar
->start
[i
]), *get_mpz (as
->lower
[i
]));
810 mpz_mul (n
, n
, multiplier
);
811 mpz_add (offset
, offset
, n
);
813 mpz_sub (extent
, *get_mpz (as
->upper
[i
]), *get_mpz (as
->lower
[i
]));
814 mpz_add_ui (extent
, extent
, 1);
816 if (mpz_sgn (extent
) < 0)
817 mpz_set_ui (extent
, 0);
819 mpz_mul (multiplier
, multiplier
, extent
);
822 i
= mpz_get_ui (offset
);
824 mpz_clear (multiplier
);
833 /* Given a single element of an equivalence list, figure out the offset
834 from the base symbol. For simple variables or full arrays, this is
835 simply zero. For an array element we have to calculate the array
836 element number and multiply by the element size. For a substring we
837 have to calculate the further reference. */
840 calculate_offset (gfc_expr
*e
)
842 HOST_WIDE_INT n
, element_size
, offset
;
843 gfc_typespec
*element_type
;
847 element_type
= &e
->symtree
->n
.sym
->ts
;
849 for (reference
= e
->ref
; reference
; reference
= reference
->next
)
850 switch (reference
->type
)
853 switch (reference
->u
.ar
.type
)
859 n
= element_number (&reference
->u
.ar
);
860 if (element_type
->type
== BT_CHARACTER
)
861 gfc_conv_const_charlen (element_type
->u
.cl
);
863 int_size_in_bytes (gfc_typenode_for_spec (element_type
));
864 offset
+= n
* element_size
;
868 gfc_error ("Bad array reference at %L", &e
->where
);
872 if (reference
->u
.ss
.start
!= NULL
)
873 offset
+= mpz_get_ui (*get_mpz (reference
->u
.ss
.start
)) - 1;
876 gfc_error ("Illegal reference type at %L as EQUIVALENCE object",
883 /* Add a new segment_info structure to the current segment. eq1 is already
884 in the list, eq2 is not. */
887 new_condition (segment_info
*v
, gfc_equiv
*eq1
, gfc_equiv
*eq2
)
889 HOST_WIDE_INT offset1
, offset2
;
892 offset1
= calculate_offset (eq1
->expr
);
893 offset2
= calculate_offset (eq2
->expr
);
895 a
= get_segment_info (eq2
->expr
->symtree
->n
.sym
,
896 v
->offset
+ offset1
- offset2
);
898 current_segment
= add_segments (current_segment
, a
);
902 /* Given two equivalence structures that are both already in the list, make
903 sure that this new condition is not violated, generating an error if it
907 confirm_condition (segment_info
*s1
, gfc_equiv
*eq1
, segment_info
*s2
,
910 HOST_WIDE_INT offset1
, offset2
;
912 offset1
= calculate_offset (eq1
->expr
);
913 offset2
= calculate_offset (eq2
->expr
);
915 if (s1
->offset
+ offset1
!= s2
->offset
+ offset2
)
916 gfc_error ("Inconsistent equivalence rules involving %qs at %L and "
917 "%qs at %L", s1
->sym
->name
, &s1
->sym
->declared_at
,
918 s2
->sym
->name
, &s2
->sym
->declared_at
);
922 /* Process a new equivalence condition. eq1 is know to be in segment f.
923 If eq2 is also present then confirm that the condition holds.
924 Otherwise add a new variable to the segment list. */
927 add_condition (segment_info
*f
, gfc_equiv
*eq1
, gfc_equiv
*eq2
)
931 n
= find_segment_info (eq2
->expr
->symtree
->n
.sym
);
934 new_condition (f
, eq1
, eq2
);
936 confirm_condition (f
, eq1
, n
, eq2
);
940 /* Given a segment element, search through the equivalence lists for unused
941 conditions that involve the symbol. Add these rules to the segment. */
944 find_equivalence (segment_info
*n
)
946 gfc_equiv
*e1
, *e2
, *eq
;
951 for (e1
= n
->sym
->ns
->equiv
; e1
; e1
= e1
->next
)
955 /* Search the equivalence list, including the root (first) element
956 for the symbol that owns the segment. */
957 for (e2
= e1
; e2
; e2
= e2
->eq
)
959 if (!e2
->used
&& e2
->expr
->symtree
->n
.sym
== n
->sym
)
966 /* Go to the next root element. */
972 /* Now traverse the equivalence list matching the offsets. */
973 for (e2
= e1
; e2
; e2
= e2
->eq
)
975 if (!e2
->used
&& e2
!= eq
)
977 add_condition (n
, eq
, e2
);
987 /* Add all symbols equivalenced within a segment. We need to scan the
988 segment list multiple times to include indirect equivalences. Since
989 a new segment_info can inserted at the beginning of the segment list,
990 depending on its offset, we have to force a final pass through the
991 loop by demanding that completion sees a pass with no matches; i.e.,
992 all symbols with equiv_built set and no new equivalences found. */
995 add_equivalences (bool *saw_equiv
)
1005 for (f
= current_segment
; f
; f
= f
->next
)
1007 if (!f
->sym
->equiv_built
)
1009 f
->sym
->equiv_built
= 1;
1010 seen_one
= find_equivalence (f
);
1020 /* Add a copy of this segment list to the namespace. */
1021 copy_equiv_list_to_ns (current_segment
);
1025 /* Returns the offset necessary to properly align the current equivalence.
1026 Sets *palign to the required alignment. */
1028 static HOST_WIDE_INT
1029 align_segment (unsigned HOST_WIDE_INT
*palign
)
1032 unsigned HOST_WIDE_INT offset
;
1033 unsigned HOST_WIDE_INT max_align
;
1034 unsigned HOST_WIDE_INT this_align
;
1035 unsigned HOST_WIDE_INT this_offset
;
1039 for (s
= current_segment
; s
; s
= s
->next
)
1041 this_align
= TYPE_ALIGN_UNIT (s
->field
);
1042 if (s
->offset
& (this_align
- 1))
1044 /* Field is misaligned. */
1045 this_offset
= this_align
- ((s
->offset
+ offset
) & (this_align
- 1));
1046 if (this_offset
& (max_align
- 1))
1048 /* Aligning this field would misalign a previous field. */
1049 gfc_error ("The equivalence set for variable %qs "
1050 "declared at %L violates alignment requirements",
1051 s
->sym
->name
, &s
->sym
->declared_at
);
1053 offset
+= this_offset
;
1055 max_align
= this_align
;
1058 *palign
= max_align
;
1063 /* Adjust segment offsets by the given amount. */
1066 apply_segment_offset (segment_info
*s
, HOST_WIDE_INT offset
)
1068 for (; s
; s
= s
->next
)
1069 s
->offset
+= offset
;
1073 /* Lay out a symbol in a common block. If the symbol has already been seen
1074 then check the location is consistent. Otherwise create segments
1075 for that symbol and all the symbols equivalenced with it. */
1077 /* Translate a single common block. */
1080 translate_common (gfc_common_head
*common
, gfc_symbol
*var_list
)
1084 segment_info
*common_segment
;
1085 HOST_WIDE_INT offset
;
1086 HOST_WIDE_INT current_offset
;
1087 unsigned HOST_WIDE_INT align
;
1090 common_segment
= NULL
;
1096 /* Add symbols to the segment. */
1097 for (sym
= var_list
; sym
; sym
= sym
->common_next
)
1099 current_segment
= common_segment
;
1100 s
= find_segment_info (sym
);
1102 /* Symbol has already been added via an equivalence. Multiple
1103 use associations of the same common block result in equiv_built
1104 being set but no information about the symbol in the segment. */
1105 if (s
&& sym
->equiv_built
)
1107 /* Ensure the current location is properly aligned. */
1108 align
= TYPE_ALIGN_UNIT (s
->field
);
1109 current_offset
= (current_offset
+ align
- 1) &~ (align
- 1);
1111 /* Verify that it ended up where we expect it. */
1112 if (s
->offset
!= current_offset
)
1114 gfc_error ("Equivalence for %qs does not match ordering of "
1115 "COMMON %qs at %L", sym
->name
,
1116 common
->name
, &common
->where
);
1121 /* A symbol we haven't seen before. */
1122 s
= current_segment
= get_segment_info (sym
, current_offset
);
1124 /* Add all objects directly or indirectly equivalenced with this
1126 add_equivalences (&saw_equiv
);
1128 if (current_segment
->offset
< 0)
1129 gfc_error ("The equivalence set for %qs cause an invalid "
1130 "extension to COMMON %qs at %L", sym
->name
,
1131 common
->name
, &common
->where
);
1133 if (flag_align_commons
)
1134 offset
= align_segment (&align
);
1138 /* The required offset conflicts with previous alignment
1139 requirements. Insert padding immediately before this
1141 if (warn_align_commons
)
1143 if (strcmp (common
->name
, BLANK_COMMON_NAME
))
1145 "Padding of %d bytes required before %qs in "
1146 "COMMON %qs at %L; reorder elements or use "
1147 "-fno-align-commons", (int)offset
,
1148 s
->sym
->name
, common
->name
, &common
->where
);
1151 "Padding of %d bytes required before %qs in "
1152 "COMMON at %L; reorder elements or use "
1153 "-fno-align-commons", (int)offset
,
1154 s
->sym
->name
, &common
->where
);
1158 /* Apply the offset to the new segments. */
1159 apply_segment_offset (current_segment
, offset
);
1160 current_offset
+= offset
;
1162 /* Add the new segments to the common block. */
1163 common_segment
= add_segments (common_segment
, current_segment
);
1166 /* The offset of the next common variable. */
1167 current_offset
+= s
->length
;
1170 if (common_segment
== NULL
)
1172 gfc_error ("COMMON '%s' at %L does not exist",
1173 common
->name
, &common
->where
);
1177 if (common_segment
->offset
!= 0 && warn_align_commons
)
1179 if (strcmp (common
->name
, BLANK_COMMON_NAME
))
1180 gfc_warning (OPT_Walign_commons
,
1181 "COMMON %qs at %L requires %d bytes of padding; "
1182 "reorder elements or use %<-fno-align-commons%>",
1183 common
->name
, &common
->where
, (int)common_segment
->offset
);
1185 gfc_warning (OPT_Walign_commons
,
1186 "COMMON at %L requires %d bytes of padding; "
1187 "reorder elements or use %<-fno-align-commons%>",
1188 &common
->where
, (int)common_segment
->offset
);
1191 create_common (common
, common_segment
, saw_equiv
);
1195 /* Create a new block for each merged equivalence list. */
1198 finish_equivalences (gfc_namespace
*ns
)
1202 gfc_common_head
* c
;
1203 HOST_WIDE_INT offset
;
1204 unsigned HOST_WIDE_INT align
;
1207 for (z
= ns
->equiv
; z
; z
= z
->next
)
1208 for (y
= z
->eq
; y
; y
= y
->eq
)
1212 sym
= z
->expr
->symtree
->n
.sym
;
1213 current_segment
= get_segment_info (sym
, 0);
1215 /* All objects directly or indirectly equivalenced with this
1217 add_equivalences (&dummy
);
1219 /* Align the block. */
1220 offset
= align_segment (&align
);
1222 /* Ensure all offsets are positive. */
1223 offset
-= current_segment
->offset
& ~(align
- 1);
1225 apply_segment_offset (current_segment
, offset
);
1227 /* Create the decl. If this is a module equivalence, it has a
1228 unique name, pointed to by z->module. This is written to a
1229 gfc_common_header to push create_common into using
1230 build_common_decl, so that the equivalence appears as an
1231 external symbol. Otherwise, a local declaration is built using
1232 build_equiv_decl. */
1235 c
= gfc_get_common_head ();
1236 /* We've lost the real location, so use the location of the
1237 enclosing procedure. */
1238 c
->where
= ns
->proc_name
->declared_at
;
1239 strcpy (c
->name
, z
->module
);
1244 create_common (c
, current_segment
, true);
1250 /* Work function for translating a named common block. */
1253 named_common (gfc_symtree
*st
)
1255 translate_common (st
->n
.common
, st
->n
.common
->head
);
1259 /* Translate the common blocks in a namespace. Unlike other variables,
1260 these have to be created before code, because the backend_decl depends
1261 on the rest of the common block. */
1264 gfc_trans_common (gfc_namespace
*ns
)
1268 /* Translate the blank common block. */
1269 if (ns
->blank_common
.head
!= NULL
)
1271 c
= gfc_get_common_head ();
1272 c
->where
= ns
->blank_common
.head
->common_head
->where
;
1273 strcpy (c
->name
, BLANK_COMMON_NAME
);
1274 translate_common (c
, ns
->blank_common
.head
);
1277 /* Translate all named common blocks. */
1278 gfc_traverse_symtree (ns
->common_root
, named_common
);
1280 /* Translate local equivalence. */
1281 finish_equivalences (ns
);
1283 /* Commit the newly created symbols for common blocks and module
1285 gfc_commit_symbols ();