1 /* Common block and equivalence list handling
2 Copyright (C) 2000-2016 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"
101 #include "gfortran.h"
103 #include "stringpool.h"
104 #include "fold-const.h"
105 #include "stor-layout.h"
107 #include "trans-types.h"
108 #include "trans-const.h"
109 #include "target-memory.h"
112 /* Holds a single variable in an equivalence set. */
113 typedef struct segment_info
116 HOST_WIDE_INT offset
;
117 HOST_WIDE_INT length
;
118 /* This will contain the field type until the field is created. */
120 struct segment_info
*next
;
123 static segment_info
* current_segment
;
125 /* Store decl of all common blocks in this translation unit; the first
126 tree is the identifier. */
127 static std::map
<tree
, tree
> gfc_map_of_all_commons
;
130 /* Make a segment_info based on a symbol. */
132 static segment_info
*
133 get_segment_info (gfc_symbol
* sym
, HOST_WIDE_INT offset
)
137 /* Make sure we've got the character length. */
138 if (sym
->ts
.type
== BT_CHARACTER
)
139 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
141 /* Create the segment_info and fill it in. */
142 s
= XCNEW (segment_info
);
144 /* We will use this type when building the segment aggregate type. */
145 s
->field
= gfc_sym_type (sym
);
146 s
->length
= int_size_in_bytes (s
->field
);
153 /* Add a copy of a segment list to the namespace. This is specifically for
154 equivalence segments, so that dependency checking can be done on
155 equivalence group members. */
158 copy_equiv_list_to_ns (segment_info
*c
)
164 l
= XCNEW (gfc_equiv_list
);
166 l
->next
= c
->sym
->ns
->equiv_lists
;
167 c
->sym
->ns
->equiv_lists
= l
;
169 for (f
= c
; f
; f
= f
->next
)
171 s
= XCNEW (gfc_equiv_info
);
175 s
->offset
= f
->offset
;
176 s
->length
= f
->length
;
181 /* Add combine segment V and segment LIST. */
183 static segment_info
*
184 add_segments (segment_info
*list
, segment_info
*v
)
195 /* Find the location of the new element. */
198 if (v
->offset
< s
->offset
)
200 if (v
->offset
== s
->offset
201 && v
->length
<= s
->length
)
208 /* Insert the new element in between p and s. */
224 /* Construct mangled common block name from symbol name. */
226 /* We need the bind(c) flag to tell us how/if we should mangle the symbol
227 name. There are few calls to this function, so few places that this
228 would need to be added. At the moment, there is only one call, in
229 build_common_decl(). We can't attempt to look up the common block
230 because we may be building it for the first time and therefore, it won't
231 be in the common_root. We also need the binding label, if it's bind(c).
232 Therefore, send in the pointer to the common block, so whatever info we
233 have so far can be used. All of the necessary info should be available
234 in the gfc_common_head by now, so it should be accurate to test the
235 isBindC flag and use the binding label given if it is bind(c).
237 We may NOT know yet if it's bind(c) or not, but we can try at least.
238 Will have to figure out what to do later if it's labeled bind(c)
239 after this is called. */
242 gfc_sym_mangled_common_id (gfc_common_head
*com
)
245 char mangled_name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 1];
246 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
248 /* Get the name out of the common block pointer. */
249 strcpy (name
, com
->name
);
251 /* If we're suppose to do a bind(c). */
252 if (com
->is_bind_c
== 1 && com
->binding_label
)
253 return get_identifier (com
->binding_label
);
255 if (strcmp (name
, BLANK_COMMON_NAME
) == 0)
256 return get_identifier (name
);
258 if (flag_underscoring
)
260 has_underscore
= strchr (name
, '_') != 0;
261 if (flag_second_underscore
&& has_underscore
)
262 snprintf (mangled_name
, sizeof mangled_name
, "%s__", name
);
264 snprintf (mangled_name
, sizeof mangled_name
, "%s_", name
);
266 return get_identifier (mangled_name
);
269 return get_identifier (name
);
273 /* Build a field declaration for a common variable or a local equivalence
277 build_field (segment_info
*h
, tree union_type
, record_layout_info rli
)
281 HOST_WIDE_INT offset
= h
->offset
;
282 unsigned HOST_WIDE_INT desired_align
, known_align
;
284 name
= get_identifier (h
->sym
->name
);
285 field
= build_decl (h
->sym
->declared_at
.lb
->location
,
286 FIELD_DECL
, name
, h
->field
);
287 known_align
= (offset
& -offset
) * BITS_PER_UNIT
;
288 if (known_align
== 0 || known_align
> BIGGEST_ALIGNMENT
)
289 known_align
= BIGGEST_ALIGNMENT
;
291 desired_align
= update_alignment_for_field (rli
, field
, known_align
);
292 if (desired_align
> known_align
)
293 DECL_PACKED (field
) = 1;
295 DECL_FIELD_CONTEXT (field
) = union_type
;
296 DECL_FIELD_OFFSET (field
) = size_int (offset
);
297 DECL_FIELD_BIT_OFFSET (field
) = bitsize_zero_node
;
298 SET_DECL_OFFSET_ALIGN (field
, known_align
);
300 rli
->offset
= size_binop (MAX_EXPR
, rli
->offset
,
301 size_binop (PLUS_EXPR
,
302 DECL_FIELD_OFFSET (field
),
303 DECL_SIZE_UNIT (field
)));
304 /* If this field is assigned to a label, we create another two variables.
305 One will hold the address of target label or format label. The other will
306 hold the length of format label string. */
307 if (h
->sym
->attr
.assign
)
312 gfc_allocate_lang_decl (field
);
313 GFC_DECL_ASSIGN (field
) = 1;
314 len
= gfc_create_var_np (gfc_charlen_type_node
,h
->sym
->name
);
315 addr
= gfc_create_var_np (pvoid_type_node
, h
->sym
->name
);
316 TREE_STATIC (len
) = 1;
317 TREE_STATIC (addr
) = 1;
318 DECL_INITIAL (len
) = build_int_cst (gfc_charlen_type_node
, -2);
319 gfc_set_decl_location (len
, &h
->sym
->declared_at
);
320 gfc_set_decl_location (addr
, &h
->sym
->declared_at
);
321 GFC_DECL_STRING_LEN (field
) = pushdecl_top_level (len
);
322 GFC_DECL_ASSIGN_ADDR (field
) = pushdecl_top_level (addr
);
325 /* If this field is volatile, mark it. */
326 if (h
->sym
->attr
.volatile_
)
329 TREE_THIS_VOLATILE (field
) = 1;
330 TREE_SIDE_EFFECTS (field
) = 1;
331 new_type
= build_qualified_type (TREE_TYPE (field
), TYPE_QUAL_VOLATILE
);
332 TREE_TYPE (field
) = new_type
;
339 /* Get storage for local equivalence. */
342 build_equiv_decl (tree union_type
, bool is_init
, bool is_saved
)
346 static int serial
= 0;
350 decl
= gfc_create_var (union_type
, "equiv");
351 TREE_STATIC (decl
) = 1;
352 GFC_DECL_COMMON_OR_EQUIV (decl
) = 1;
356 snprintf (name
, sizeof (name
), "equiv.%d", serial
++);
357 decl
= build_decl (input_location
,
358 VAR_DECL
, get_identifier (name
), union_type
);
359 DECL_ARTIFICIAL (decl
) = 1;
360 DECL_IGNORED_P (decl
) = 1;
362 if (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl
))
364 TREE_STATIC (decl
) = 1;
366 TREE_ADDRESSABLE (decl
) = 1;
367 TREE_USED (decl
) = 1;
368 GFC_DECL_COMMON_OR_EQUIV (decl
) = 1;
370 /* The source location has been lost, and doesn't really matter.
371 We need to set it to something though. */
372 gfc_set_decl_location (decl
, &gfc_current_locus
);
374 gfc_add_decl_to_function (decl
);
380 /* Get storage for common block. */
383 build_common_decl (gfc_common_head
*com
, tree union_type
, bool is_init
)
385 tree decl
, identifier
;
387 identifier
= gfc_sym_mangled_common_id (com
);
388 decl
= gfc_map_of_all_commons
.count(identifier
)
389 ? gfc_map_of_all_commons
[identifier
] : NULL_TREE
;
391 /* Update the size of this common block as needed. */
392 if (decl
!= NULL_TREE
)
394 tree size
= TYPE_SIZE_UNIT (union_type
);
396 /* Named common blocks of the same name shall be of the same size
397 in all scoping units of a program in which they appear, but
398 blank common blocks may be of different sizes. */
399 if (!tree_int_cst_equal (DECL_SIZE_UNIT (decl
), size
)
400 && strcmp (com
->name
, BLANK_COMMON_NAME
))
401 gfc_warning (0, "Named COMMON block %qs at %L shall be of the "
402 "same size as elsewhere (%lu vs %lu bytes)", com
->name
,
404 (unsigned long) TREE_INT_CST_LOW (size
),
405 (unsigned long) TREE_INT_CST_LOW (DECL_SIZE_UNIT (decl
)));
407 if (tree_int_cst_lt (DECL_SIZE_UNIT (decl
), size
))
409 DECL_SIZE (decl
) = TYPE_SIZE (union_type
);
410 DECL_SIZE_UNIT (decl
) = size
;
411 DECL_MODE (decl
) = TYPE_MODE (union_type
);
412 TREE_TYPE (decl
) = union_type
;
413 layout_decl (decl
, 0);
417 /* If this common block has been declared in a previous program unit,
418 and either it is already initialized or there is no new initialization
419 for it, just return. */
420 if ((decl
!= NULL_TREE
) && (!is_init
|| DECL_INITIAL (decl
)))
423 /* If there is no backend_decl for the common block, build it. */
424 if (decl
== NULL_TREE
)
426 if (com
->is_bind_c
== 1 && com
->binding_label
)
427 decl
= build_decl (input_location
, VAR_DECL
, identifier
, union_type
);
430 decl
= build_decl (input_location
, VAR_DECL
, get_identifier (com
->name
),
432 gfc_set_decl_assembler_name (decl
, identifier
);
435 TREE_PUBLIC (decl
) = 1;
436 TREE_STATIC (decl
) = 1;
437 DECL_IGNORED_P (decl
) = 1;
439 SET_DECL_ALIGN (decl
, BIGGEST_ALIGNMENT
);
442 /* Do not set the alignment for bind(c) common blocks to
443 BIGGEST_ALIGNMENT because that won't match what C does. Also,
444 for common blocks with one element, the alignment must be
445 that of the field within the common block in order to match
447 tree field
= NULL_TREE
;
448 field
= TYPE_FIELDS (TREE_TYPE (decl
));
449 if (DECL_CHAIN (field
) == NULL_TREE
)
450 SET_DECL_ALIGN (decl
, TYPE_ALIGN (TREE_TYPE (field
)));
452 DECL_USER_ALIGN (decl
) = 0;
453 GFC_DECL_COMMON_OR_EQUIV (decl
) = 1;
455 gfc_set_decl_location (decl
, &com
->where
);
457 if (com
->threadprivate
)
458 set_decl_tls_model (decl
, decl_default_tls_model (decl
));
460 if (com
->omp_declare_target
)
461 DECL_ATTRIBUTES (decl
)
462 = tree_cons (get_identifier ("omp declare target"),
463 NULL_TREE
, DECL_ATTRIBUTES (decl
));
465 /* Place the back end declaration for this common block in
466 GLOBAL_BINDING_LEVEL. */
467 gfc_map_of_all_commons
[identifier
] = pushdecl_top_level (decl
);
470 /* Has no initial values. */
473 DECL_INITIAL (decl
) = NULL_TREE
;
474 DECL_COMMON (decl
) = 1;
475 DECL_DEFER_OUTPUT (decl
) = 1;
479 DECL_INITIAL (decl
) = error_mark_node
;
480 DECL_COMMON (decl
) = 0;
481 DECL_DEFER_OUTPUT (decl
) = 0;
487 /* Return a field that is the size of the union, if an equivalence has
488 overlapping initializers. Merge the initializers into a single
489 initializer for this new field, then free the old ones. */
492 get_init_field (segment_info
*head
, tree union_type
, tree
*field_init
,
493 record_layout_info rli
)
496 HOST_WIDE_INT length
= 0;
497 HOST_WIDE_INT offset
= 0;
498 unsigned HOST_WIDE_INT known_align
, desired_align
;
499 bool overlap
= false;
502 unsigned char *data
, *chk
;
503 vec
<constructor_elt
, va_gc
> *v
= NULL
;
505 tree type
= unsigned_char_type_node
;
508 /* Obtain the size of the union and check if there are any overlapping
510 for (s
= head
; s
; s
= s
->next
)
512 HOST_WIDE_INT slen
= s
->offset
+ s
->length
;
515 if (s
->offset
< offset
)
519 length
= length
< slen
? slen
: length
;
525 /* Now absorb all the initializer data into a single vector,
526 whilst checking for overlapping, unequal values. */
527 data
= XCNEWVEC (unsigned char, (size_t)length
);
528 chk
= XCNEWVEC (unsigned char, (size_t)length
);
530 /* TODO - change this when default initialization is implemented. */
531 memset (data
, '\0', (size_t)length
);
532 memset (chk
, '\0', (size_t)length
);
533 for (s
= head
; s
; s
= s
->next
)
535 gfc_merge_initializers (s
->sym
->ts
, s
->sym
->value
,
540 for (i
= 0; i
< length
; i
++)
541 CONSTRUCTOR_APPEND_ELT (v
, NULL
, build_int_cst (type
, data
[i
]));
546 /* Build a char[length] array to hold the initializers. Much of what
547 follows is borrowed from build_field, above. */
549 tmp
= build_int_cst (gfc_array_index_type
, length
- 1);
550 tmp
= build_range_type (gfc_array_index_type
,
551 gfc_index_zero_node
, tmp
);
552 tmp
= build_array_type (type
, tmp
);
553 field
= build_decl (gfc_current_locus
.lb
->location
,
554 FIELD_DECL
, NULL_TREE
, tmp
);
556 known_align
= BIGGEST_ALIGNMENT
;
558 desired_align
= update_alignment_for_field (rli
, field
, known_align
);
559 if (desired_align
> known_align
)
560 DECL_PACKED (field
) = 1;
562 DECL_FIELD_CONTEXT (field
) = union_type
;
563 DECL_FIELD_OFFSET (field
) = size_int (0);
564 DECL_FIELD_BIT_OFFSET (field
) = bitsize_zero_node
;
565 SET_DECL_OFFSET_ALIGN (field
, known_align
);
567 rli
->offset
= size_binop (MAX_EXPR
, rli
->offset
,
568 size_binop (PLUS_EXPR
,
569 DECL_FIELD_OFFSET (field
),
570 DECL_SIZE_UNIT (field
)));
572 init
= build_constructor (TREE_TYPE (field
), v
);
573 TREE_CONSTANT (init
) = 1;
577 for (s
= head
; s
; s
= s
->next
)
579 if (s
->sym
->value
== NULL
)
582 gfc_free_expr (s
->sym
->value
);
583 s
->sym
->value
= NULL
;
590 /* Declare memory for the common block or local equivalence, and create
591 backend declarations for all of the elements. */
594 create_common (gfc_common_head
*com
, segment_info
*head
, bool saw_equiv
)
596 segment_info
*s
, *next_s
;
600 tree field_init
= NULL_TREE
;
601 record_layout_info rli
;
603 bool is_init
= false;
604 bool is_saved
= false;
606 /* Declare the variables inside the common block.
607 If the current common block contains any equivalence object, then
608 make a UNION_TYPE node, otherwise RECORD_TYPE. This will let the
609 alias analyzer work well when there is no address overlapping for
610 common variables in the current common block. */
612 union_type
= make_node (UNION_TYPE
);
614 union_type
= make_node (RECORD_TYPE
);
616 rli
= start_record_layout (union_type
);
617 field_link
= &TYPE_FIELDS (union_type
);
619 /* Check for overlapping initializers and replace them with a single,
620 artificial field that contains all the data. */
622 field
= get_init_field (head
, union_type
, &field_init
, rli
);
626 if (field
!= NULL_TREE
)
630 field_link
= &DECL_CHAIN (field
);
633 for (s
= head
; s
; s
= s
->next
)
635 build_field (s
, union_type
, rli
);
637 /* Link the field into the type. */
638 *field_link
= s
->field
;
639 field_link
= &DECL_CHAIN (s
->field
);
641 /* Has initial value. */
645 /* Has SAVE attribute. */
646 if (s
->sym
->attr
.save
)
650 finish_record_layout (rli
, true);
653 decl
= build_common_decl (com
, union_type
, is_init
);
655 decl
= build_equiv_decl (union_type
, is_init
, is_saved
);
660 vec
<constructor_elt
, va_gc
> *v
= NULL
;
662 if (field
!= NULL_TREE
&& field_init
!= NULL_TREE
)
663 CONSTRUCTOR_APPEND_ELT (v
, field
, field_init
);
665 for (s
= head
; s
; s
= s
->next
)
669 /* Add the initializer for this field. */
670 tmp
= gfc_conv_initializer (s
->sym
->value
, &s
->sym
->ts
,
671 TREE_TYPE (s
->field
),
672 s
->sym
->attr
.dimension
,
674 || s
->sym
->attr
.allocatable
, false);
676 CONSTRUCTOR_APPEND_ELT (v
, s
->field
, tmp
);
680 gcc_assert (!v
->is_empty ());
681 ctor
= build_constructor (union_type
, v
);
682 TREE_CONSTANT (ctor
) = 1;
683 TREE_STATIC (ctor
) = 1;
684 DECL_INITIAL (decl
) = ctor
;
689 unsigned HOST_WIDE_INT idx
;
690 FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor
), idx
, field
, value
)
691 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
695 /* Build component reference for each variable. */
696 for (s
= head
; s
; s
= next_s
)
700 var_decl
= build_decl (s
->sym
->declared_at
.lb
->location
,
701 VAR_DECL
, DECL_NAME (s
->field
),
702 TREE_TYPE (s
->field
));
703 TREE_STATIC (var_decl
) = TREE_STATIC (decl
);
704 /* Mark the variable as used in order to avoid warnings about
706 TREE_USED (var_decl
) = 1;
707 if (s
->sym
->attr
.use_assoc
)
708 DECL_IGNORED_P (var_decl
) = 1;
709 if (s
->sym
->attr
.target
)
710 TREE_ADDRESSABLE (var_decl
) = 1;
711 /* Fake variables are not visible from other translation units. */
712 TREE_PUBLIC (var_decl
) = 0;
713 gfc_finish_decl_attrs (var_decl
, &s
->sym
->attr
);
715 /* To preserve identifier names in COMMON, chain to procedure
716 scope unless at top level in a module definition. */
718 && s
->sym
->ns
->proc_name
719 && s
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
720 var_decl
= pushdecl_top_level (var_decl
);
722 gfc_add_decl_to_function (var_decl
);
724 SET_DECL_VALUE_EXPR (var_decl
,
725 fold_build3_loc (input_location
, COMPONENT_REF
,
726 TREE_TYPE (s
->field
),
727 decl
, s
->field
, NULL_TREE
));
728 DECL_HAS_VALUE_EXPR_P (var_decl
) = 1;
729 GFC_DECL_COMMON_OR_EQUIV (var_decl
) = 1;
731 if (s
->sym
->attr
.assign
)
733 gfc_allocate_lang_decl (var_decl
);
734 GFC_DECL_ASSIGN (var_decl
) = 1;
735 GFC_DECL_STRING_LEN (var_decl
) = GFC_DECL_STRING_LEN (s
->field
);
736 GFC_DECL_ASSIGN_ADDR (var_decl
) = GFC_DECL_ASSIGN_ADDR (s
->field
);
739 s
->sym
->backend_decl
= var_decl
;
747 /* Given a symbol, find it in the current segment list. Returns NULL if
750 static segment_info
*
751 find_segment_info (gfc_symbol
*symbol
)
755 for (n
= current_segment
; n
; n
= n
->next
)
757 if (n
->sym
== symbol
)
765 /* Given an expression node, make sure it is a constant integer and return
769 get_mpz (gfc_expr
*e
)
772 if (e
->expr_type
!= EXPR_CONSTANT
)
773 gfc_internal_error ("get_mpz(): Not an integer constant");
775 return &e
->value
.integer
;
779 /* Given an array specification and an array reference, figure out the
780 array element number (zero based). Bounds and elements are guaranteed
781 to be constants. If something goes wrong we generate an error and
785 element_number (gfc_array_ref
*ar
)
787 mpz_t multiplier
, offset
, extent
, n
;
789 HOST_WIDE_INT i
, rank
;
793 mpz_init_set_ui (multiplier
, 1);
794 mpz_init_set_ui (offset
, 0);
798 for (i
= 0; i
< rank
; i
++)
800 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
801 gfc_internal_error ("element_number(): Bad dimension type");
803 mpz_sub (n
, *get_mpz (ar
->start
[i
]), *get_mpz (as
->lower
[i
]));
805 mpz_mul (n
, n
, multiplier
);
806 mpz_add (offset
, offset
, n
);
808 mpz_sub (extent
, *get_mpz (as
->upper
[i
]), *get_mpz (as
->lower
[i
]));
809 mpz_add_ui (extent
, extent
, 1);
811 if (mpz_sgn (extent
) < 0)
812 mpz_set_ui (extent
, 0);
814 mpz_mul (multiplier
, multiplier
, extent
);
817 i
= mpz_get_ui (offset
);
819 mpz_clear (multiplier
);
828 /* Given a single element of an equivalence list, figure out the offset
829 from the base symbol. For simple variables or full arrays, this is
830 simply zero. For an array element we have to calculate the array
831 element number and multiply by the element size. For a substring we
832 have to calculate the further reference. */
835 calculate_offset (gfc_expr
*e
)
837 HOST_WIDE_INT n
, element_size
, offset
;
838 gfc_typespec
*element_type
;
842 element_type
= &e
->symtree
->n
.sym
->ts
;
844 for (reference
= e
->ref
; reference
; reference
= reference
->next
)
845 switch (reference
->type
)
848 switch (reference
->u
.ar
.type
)
854 n
= element_number (&reference
->u
.ar
);
855 if (element_type
->type
== BT_CHARACTER
)
856 gfc_conv_const_charlen (element_type
->u
.cl
);
858 int_size_in_bytes (gfc_typenode_for_spec (element_type
));
859 offset
+= n
* element_size
;
863 gfc_error ("Bad array reference at %L", &e
->where
);
867 if (reference
->u
.ss
.start
!= NULL
)
868 offset
+= mpz_get_ui (*get_mpz (reference
->u
.ss
.start
)) - 1;
871 gfc_error ("Illegal reference type at %L as EQUIVALENCE object",
878 /* Add a new segment_info structure to the current segment. eq1 is already
879 in the list, eq2 is not. */
882 new_condition (segment_info
*v
, gfc_equiv
*eq1
, gfc_equiv
*eq2
)
884 HOST_WIDE_INT offset1
, offset2
;
887 offset1
= calculate_offset (eq1
->expr
);
888 offset2
= calculate_offset (eq2
->expr
);
890 a
= get_segment_info (eq2
->expr
->symtree
->n
.sym
,
891 v
->offset
+ offset1
- offset2
);
893 current_segment
= add_segments (current_segment
, a
);
897 /* Given two equivalence structures that are both already in the list, make
898 sure that this new condition is not violated, generating an error if it
902 confirm_condition (segment_info
*s1
, gfc_equiv
*eq1
, segment_info
*s2
,
905 HOST_WIDE_INT offset1
, offset2
;
907 offset1
= calculate_offset (eq1
->expr
);
908 offset2
= calculate_offset (eq2
->expr
);
910 if (s1
->offset
+ offset1
!= s2
->offset
+ offset2
)
911 gfc_error ("Inconsistent equivalence rules involving %qs at %L and "
912 "%qs at %L", s1
->sym
->name
, &s1
->sym
->declared_at
,
913 s2
->sym
->name
, &s2
->sym
->declared_at
);
917 /* Process a new equivalence condition. eq1 is know to be in segment f.
918 If eq2 is also present then confirm that the condition holds.
919 Otherwise add a new variable to the segment list. */
922 add_condition (segment_info
*f
, gfc_equiv
*eq1
, gfc_equiv
*eq2
)
926 n
= find_segment_info (eq2
->expr
->symtree
->n
.sym
);
929 new_condition (f
, eq1
, eq2
);
931 confirm_condition (f
, eq1
, n
, eq2
);
935 /* Given a segment element, search through the equivalence lists for unused
936 conditions that involve the symbol. Add these rules to the segment. */
939 find_equivalence (segment_info
*n
)
941 gfc_equiv
*e1
, *e2
, *eq
;
946 for (e1
= n
->sym
->ns
->equiv
; e1
; e1
= e1
->next
)
950 /* Search the equivalence list, including the root (first) element
951 for the symbol that owns the segment. */
952 for (e2
= e1
; e2
; e2
= e2
->eq
)
954 if (!e2
->used
&& e2
->expr
->symtree
->n
.sym
== n
->sym
)
961 /* Go to the next root element. */
967 /* Now traverse the equivalence list matching the offsets. */
968 for (e2
= e1
; e2
; e2
= e2
->eq
)
970 if (!e2
->used
&& e2
!= eq
)
972 add_condition (n
, eq
, e2
);
982 /* Add all symbols equivalenced within a segment. We need to scan the
983 segment list multiple times to include indirect equivalences. Since
984 a new segment_info can inserted at the beginning of the segment list,
985 depending on its offset, we have to force a final pass through the
986 loop by demanding that completion sees a pass with no matches; i.e.,
987 all symbols with equiv_built set and no new equivalences found. */
990 add_equivalences (bool *saw_equiv
)
1000 for (f
= current_segment
; f
; f
= f
->next
)
1002 if (!f
->sym
->equiv_built
)
1004 f
->sym
->equiv_built
= 1;
1005 seen_one
= find_equivalence (f
);
1015 /* Add a copy of this segment list to the namespace. */
1016 copy_equiv_list_to_ns (current_segment
);
1020 /* Returns the offset necessary to properly align the current equivalence.
1021 Sets *palign to the required alignment. */
1023 static HOST_WIDE_INT
1024 align_segment (unsigned HOST_WIDE_INT
*palign
)
1027 unsigned HOST_WIDE_INT offset
;
1028 unsigned HOST_WIDE_INT max_align
;
1029 unsigned HOST_WIDE_INT this_align
;
1030 unsigned HOST_WIDE_INT this_offset
;
1034 for (s
= current_segment
; s
; s
= s
->next
)
1036 this_align
= TYPE_ALIGN_UNIT (s
->field
);
1037 if (s
->offset
& (this_align
- 1))
1039 /* Field is misaligned. */
1040 this_offset
= this_align
- ((s
->offset
+ offset
) & (this_align
- 1));
1041 if (this_offset
& (max_align
- 1))
1043 /* Aligning this field would misalign a previous field. */
1044 gfc_error ("The equivalence set for variable %qs "
1045 "declared at %L violates alignment requirements",
1046 s
->sym
->name
, &s
->sym
->declared_at
);
1048 offset
+= this_offset
;
1050 max_align
= this_align
;
1053 *palign
= max_align
;
1058 /* Adjust segment offsets by the given amount. */
1061 apply_segment_offset (segment_info
*s
, HOST_WIDE_INT offset
)
1063 for (; s
; s
= s
->next
)
1064 s
->offset
+= offset
;
1068 /* Lay out a symbol in a common block. If the symbol has already been seen
1069 then check the location is consistent. Otherwise create segments
1070 for that symbol and all the symbols equivalenced with it. */
1072 /* Translate a single common block. */
1075 translate_common (gfc_common_head
*common
, gfc_symbol
*var_list
)
1079 segment_info
*common_segment
;
1080 HOST_WIDE_INT offset
;
1081 HOST_WIDE_INT current_offset
;
1082 unsigned HOST_WIDE_INT align
;
1085 common_segment
= NULL
;
1091 /* Add symbols to the segment. */
1092 for (sym
= var_list
; sym
; sym
= sym
->common_next
)
1094 current_segment
= common_segment
;
1095 s
= find_segment_info (sym
);
1097 /* Symbol has already been added via an equivalence. Multiple
1098 use associations of the same common block result in equiv_built
1099 being set but no information about the symbol in the segment. */
1100 if (s
&& sym
->equiv_built
)
1102 /* Ensure the current location is properly aligned. */
1103 align
= TYPE_ALIGN_UNIT (s
->field
);
1104 current_offset
= (current_offset
+ align
- 1) &~ (align
- 1);
1106 /* Verify that it ended up where we expect it. */
1107 if (s
->offset
!= current_offset
)
1109 gfc_error ("Equivalence for %qs does not match ordering of "
1110 "COMMON %qs at %L", sym
->name
,
1111 common
->name
, &common
->where
);
1116 /* A symbol we haven't seen before. */
1117 s
= current_segment
= get_segment_info (sym
, current_offset
);
1119 /* Add all objects directly or indirectly equivalenced with this
1121 add_equivalences (&saw_equiv
);
1123 if (current_segment
->offset
< 0)
1124 gfc_error ("The equivalence set for %qs cause an invalid "
1125 "extension to COMMON %qs at %L", sym
->name
,
1126 common
->name
, &common
->where
);
1128 if (flag_align_commons
)
1129 offset
= align_segment (&align
);
1133 /* The required offset conflicts with previous alignment
1134 requirements. Insert padding immediately before this
1136 if (warn_align_commons
)
1138 if (strcmp (common
->name
, BLANK_COMMON_NAME
))
1140 "Padding of %d bytes required before %qs in "
1141 "COMMON %qs at %L; reorder elements or use "
1142 "-fno-align-commons", (int)offset
,
1143 s
->sym
->name
, common
->name
, &common
->where
);
1146 "Padding of %d bytes required before %qs in "
1147 "COMMON at %L; reorder elements or use "
1148 "-fno-align-commons", (int)offset
,
1149 s
->sym
->name
, &common
->where
);
1153 /* Apply the offset to the new segments. */
1154 apply_segment_offset (current_segment
, offset
);
1155 current_offset
+= offset
;
1157 /* Add the new segments to the common block. */
1158 common_segment
= add_segments (common_segment
, current_segment
);
1161 /* The offset of the next common variable. */
1162 current_offset
+= s
->length
;
1165 if (common_segment
== NULL
)
1167 gfc_error ("COMMON %qs at %L does not exist",
1168 common
->name
, &common
->where
);
1172 if (common_segment
->offset
!= 0 && warn_align_commons
)
1174 if (strcmp (common
->name
, BLANK_COMMON_NAME
))
1175 gfc_warning (OPT_Walign_commons
,
1176 "COMMON %qs at %L requires %d bytes of padding; "
1177 "reorder elements or use %<-fno-align-commons%>",
1178 common
->name
, &common
->where
, (int)common_segment
->offset
);
1180 gfc_warning (OPT_Walign_commons
,
1181 "COMMON at %L requires %d bytes of padding; "
1182 "reorder elements or use %<-fno-align-commons%>",
1183 &common
->where
, (int)common_segment
->offset
);
1186 create_common (common
, common_segment
, saw_equiv
);
1190 /* Create a new block for each merged equivalence list. */
1193 finish_equivalences (gfc_namespace
*ns
)
1197 gfc_common_head
* c
;
1198 HOST_WIDE_INT offset
;
1199 unsigned HOST_WIDE_INT align
;
1202 for (z
= ns
->equiv
; z
; z
= z
->next
)
1203 for (y
= z
->eq
; y
; y
= y
->eq
)
1207 sym
= z
->expr
->symtree
->n
.sym
;
1208 current_segment
= get_segment_info (sym
, 0);
1210 /* All objects directly or indirectly equivalenced with this
1212 add_equivalences (&dummy
);
1214 /* Align the block. */
1215 offset
= align_segment (&align
);
1217 /* Ensure all offsets are positive. */
1218 offset
-= current_segment
->offset
& ~(align
- 1);
1220 apply_segment_offset (current_segment
, offset
);
1222 /* Create the decl. If this is a module equivalence, it has a
1223 unique name, pointed to by z->module. This is written to a
1224 gfc_common_header to push create_common into using
1225 build_common_decl, so that the equivalence appears as an
1226 external symbol. Otherwise, a local declaration is built using
1227 build_equiv_decl. */
1230 c
= gfc_get_common_head ();
1231 /* We've lost the real location, so use the location of the
1232 enclosing procedure. */
1233 c
->where
= ns
->proc_name
->declared_at
;
1234 strcpy (c
->name
, z
->module
);
1239 create_common (c
, current_segment
, true);
1245 /* Work function for translating a named common block. */
1248 named_common (gfc_symtree
*st
)
1250 translate_common (st
->n
.common
, st
->n
.common
->head
);
1254 /* Translate the common blocks in a namespace. Unlike other variables,
1255 these have to be created before code, because the backend_decl depends
1256 on the rest of the common block. */
1259 gfc_trans_common (gfc_namespace
*ns
)
1263 /* Translate the blank common block. */
1264 if (ns
->blank_common
.head
!= NULL
)
1266 c
= gfc_get_common_head ();
1267 c
->where
= ns
->blank_common
.head
->common_head
->where
;
1268 strcpy (c
->name
, BLANK_COMMON_NAME
);
1269 translate_common (c
, ns
->blank_common
.head
);
1272 /* Translate all named common blocks. */
1273 gfc_traverse_symtree (ns
->common_root
, named_common
);
1275 /* Translate local equivalence. */
1276 finish_equivalences (ns
);
1278 /* Commit the newly created symbols for common blocks and module
1280 gfc_commit_symbols ();