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"
100 #include "hash-set.h"
107 #include "fold-const.h"
108 #include "stringpool.h"
109 #include "stor-layout.h"
111 #include "gfortran.h"
113 #include "trans-types.h"
114 #include "trans-const.h"
115 #include "target-memory.h"
118 /* Holds a single variable in an equivalence set. */
119 typedef struct segment_info
122 HOST_WIDE_INT offset
;
123 HOST_WIDE_INT length
;
124 /* This will contain the field type until the field is created. */
126 struct segment_info
*next
;
129 static segment_info
* current_segment
;
131 /* Store decl of all common blocks in this translation unit; the first
132 tree is the identifier. */
133 static std::map
<tree
, tree
> gfc_map_of_all_commons
;
136 /* Make a segment_info based on a symbol. */
138 static segment_info
*
139 get_segment_info (gfc_symbol
* sym
, HOST_WIDE_INT offset
)
143 /* Make sure we've got the character length. */
144 if (sym
->ts
.type
== BT_CHARACTER
)
145 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
147 /* Create the segment_info and fill it in. */
148 s
= XCNEW (segment_info
);
150 /* We will use this type when building the segment aggregate type. */
151 s
->field
= gfc_sym_type (sym
);
152 s
->length
= int_size_in_bytes (s
->field
);
159 /* Add a copy of a segment list to the namespace. This is specifically for
160 equivalence segments, so that dependency checking can be done on
161 equivalence group members. */
164 copy_equiv_list_to_ns (segment_info
*c
)
170 l
= XCNEW (gfc_equiv_list
);
172 l
->next
= c
->sym
->ns
->equiv_lists
;
173 c
->sym
->ns
->equiv_lists
= l
;
175 for (f
= c
; f
; f
= f
->next
)
177 s
= XCNEW (gfc_equiv_info
);
181 s
->offset
= f
->offset
;
182 s
->length
= f
->length
;
187 /* Add combine segment V and segment LIST. */
189 static segment_info
*
190 add_segments (segment_info
*list
, segment_info
*v
)
201 /* Find the location of the new element. */
204 if (v
->offset
< s
->offset
)
206 if (v
->offset
== s
->offset
207 && v
->length
<= s
->length
)
214 /* Insert the new element in between p and s. */
230 /* Construct mangled common block name from symbol name. */
232 /* We need the bind(c) flag to tell us how/if we should mangle the symbol
233 name. There are few calls to this function, so few places that this
234 would need to be added. At the moment, there is only one call, in
235 build_common_decl(). We can't attempt to look up the common block
236 because we may be building it for the first time and therefore, it won't
237 be in the common_root. We also need the binding label, if it's bind(c).
238 Therefore, send in the pointer to the common block, so whatever info we
239 have so far can be used. All of the necessary info should be available
240 in the gfc_common_head by now, so it should be accurate to test the
241 isBindC flag and use the binding label given if it is bind(c).
243 We may NOT know yet if it's bind(c) or not, but we can try at least.
244 Will have to figure out what to do later if it's labeled bind(c)
245 after this is called. */
248 gfc_sym_mangled_common_id (gfc_common_head
*com
)
251 char mangled_name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 1];
252 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
254 /* Get the name out of the common block pointer. */
255 strcpy (name
, com
->name
);
257 /* If we're suppose to do a bind(c). */
258 if (com
->is_bind_c
== 1 && com
->binding_label
)
259 return get_identifier (com
->binding_label
);
261 if (strcmp (name
, BLANK_COMMON_NAME
) == 0)
262 return get_identifier (name
);
264 if (flag_underscoring
)
266 has_underscore
= strchr (name
, '_') != 0;
267 if (flag_second_underscore
&& has_underscore
)
268 snprintf (mangled_name
, sizeof mangled_name
, "%s__", name
);
270 snprintf (mangled_name
, sizeof mangled_name
, "%s_", name
);
272 return get_identifier (mangled_name
);
275 return get_identifier (name
);
279 /* Build a field declaration for a common variable or a local equivalence
283 build_field (segment_info
*h
, tree union_type
, record_layout_info rli
)
287 HOST_WIDE_INT offset
= h
->offset
;
288 unsigned HOST_WIDE_INT desired_align
, known_align
;
290 name
= get_identifier (h
->sym
->name
);
291 field
= build_decl (h
->sym
->declared_at
.lb
->location
,
292 FIELD_DECL
, name
, h
->field
);
293 known_align
= (offset
& -offset
) * BITS_PER_UNIT
;
294 if (known_align
== 0 || known_align
> BIGGEST_ALIGNMENT
)
295 known_align
= BIGGEST_ALIGNMENT
;
297 desired_align
= update_alignment_for_field (rli
, field
, known_align
);
298 if (desired_align
> known_align
)
299 DECL_PACKED (field
) = 1;
301 DECL_FIELD_CONTEXT (field
) = union_type
;
302 DECL_FIELD_OFFSET (field
) = size_int (offset
);
303 DECL_FIELD_BIT_OFFSET (field
) = bitsize_zero_node
;
304 SET_DECL_OFFSET_ALIGN (field
, known_align
);
306 rli
->offset
= size_binop (MAX_EXPR
, rli
->offset
,
307 size_binop (PLUS_EXPR
,
308 DECL_FIELD_OFFSET (field
),
309 DECL_SIZE_UNIT (field
)));
310 /* If this field is assigned to a label, we create another two variables.
311 One will hold the address of target label or format label. The other will
312 hold the length of format label string. */
313 if (h
->sym
->attr
.assign
)
318 gfc_allocate_lang_decl (field
);
319 GFC_DECL_ASSIGN (field
) = 1;
320 len
= gfc_create_var_np (gfc_charlen_type_node
,h
->sym
->name
);
321 addr
= gfc_create_var_np (pvoid_type_node
, h
->sym
->name
);
322 TREE_STATIC (len
) = 1;
323 TREE_STATIC (addr
) = 1;
324 DECL_INITIAL (len
) = build_int_cst (gfc_charlen_type_node
, -2);
325 gfc_set_decl_location (len
, &h
->sym
->declared_at
);
326 gfc_set_decl_location (addr
, &h
->sym
->declared_at
);
327 GFC_DECL_STRING_LEN (field
) = pushdecl_top_level (len
);
328 GFC_DECL_ASSIGN_ADDR (field
) = pushdecl_top_level (addr
);
331 /* If this field is volatile, mark it. */
332 if (h
->sym
->attr
.volatile_
)
335 TREE_THIS_VOLATILE (field
) = 1;
336 TREE_SIDE_EFFECTS (field
) = 1;
337 new_type
= build_qualified_type (TREE_TYPE (field
), TYPE_QUAL_VOLATILE
);
338 TREE_TYPE (field
) = new_type
;
345 /* Get storage for local equivalence. */
348 build_equiv_decl (tree union_type
, bool is_init
, bool is_saved
)
352 static int serial
= 0;
356 decl
= gfc_create_var (union_type
, "equiv");
357 TREE_STATIC (decl
) = 1;
358 GFC_DECL_COMMON_OR_EQUIV (decl
) = 1;
362 snprintf (name
, sizeof (name
), "equiv.%d", serial
++);
363 decl
= build_decl (input_location
,
364 VAR_DECL
, get_identifier (name
), union_type
);
365 DECL_ARTIFICIAL (decl
) = 1;
366 DECL_IGNORED_P (decl
) = 1;
368 if (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl
))
370 TREE_STATIC (decl
) = 1;
372 TREE_ADDRESSABLE (decl
) = 1;
373 TREE_USED (decl
) = 1;
374 GFC_DECL_COMMON_OR_EQUIV (decl
) = 1;
376 /* The source location has been lost, and doesn't really matter.
377 We need to set it to something though. */
378 gfc_set_decl_location (decl
, &gfc_current_locus
);
380 gfc_add_decl_to_function (decl
);
386 /* Get storage for common block. */
389 build_common_decl (gfc_common_head
*com
, tree union_type
, bool is_init
)
391 tree decl
, identifier
;
393 identifier
= gfc_sym_mangled_common_id (com
);
394 decl
= gfc_map_of_all_commons
.count(identifier
)
395 ? gfc_map_of_all_commons
[identifier
] : NULL_TREE
;
397 /* Update the size of this common block as needed. */
398 if (decl
!= NULL_TREE
)
400 tree size
= TYPE_SIZE_UNIT (union_type
);
402 /* Named common blocks of the same name shall be of the same size
403 in all scoping units of a program in which they appear, but
404 blank common blocks may be of different sizes. */
405 if (!tree_int_cst_equal (DECL_SIZE_UNIT (decl
), size
)
406 && strcmp (com
->name
, BLANK_COMMON_NAME
))
407 gfc_warning (0, "Named COMMON block %qs at %L shall be of the "
408 "same size as elsewhere (%lu vs %lu bytes)", com
->name
,
410 (unsigned long) TREE_INT_CST_LOW (size
),
411 (unsigned long) TREE_INT_CST_LOW (DECL_SIZE_UNIT (decl
)));
413 if (tree_int_cst_lt (DECL_SIZE_UNIT (decl
), size
))
415 DECL_SIZE (decl
) = TYPE_SIZE (union_type
);
416 DECL_SIZE_UNIT (decl
) = size
;
417 DECL_MODE (decl
) = TYPE_MODE (union_type
);
418 TREE_TYPE (decl
) = union_type
;
419 layout_decl (decl
, 0);
423 /* If this common block has been declared in a previous program unit,
424 and either it is already initialized or there is no new initialization
425 for it, just return. */
426 if ((decl
!= NULL_TREE
) && (!is_init
|| DECL_INITIAL (decl
)))
429 /* If there is no backend_decl for the common block, build it. */
430 if (decl
== NULL_TREE
)
432 if (com
->is_bind_c
== 1 && com
->binding_label
)
433 decl
= build_decl (input_location
, VAR_DECL
, identifier
, union_type
);
436 decl
= build_decl (input_location
, VAR_DECL
, get_identifier (com
->name
),
438 gfc_set_decl_assembler_name (decl
, identifier
);
441 TREE_PUBLIC (decl
) = 1;
442 TREE_STATIC (decl
) = 1;
443 DECL_IGNORED_P (decl
) = 1;
445 DECL_ALIGN (decl
) = BIGGEST_ALIGNMENT
;
448 /* Do not set the alignment for bind(c) common blocks to
449 BIGGEST_ALIGNMENT because that won't match what C does. Also,
450 for common blocks with one element, the alignment must be
451 that of the field within the common block in order to match
453 tree field
= NULL_TREE
;
454 field
= TYPE_FIELDS (TREE_TYPE (decl
));
455 if (DECL_CHAIN (field
) == NULL_TREE
)
456 DECL_ALIGN (decl
) = TYPE_ALIGN (TREE_TYPE (field
));
458 DECL_USER_ALIGN (decl
) = 0;
459 GFC_DECL_COMMON_OR_EQUIV (decl
) = 1;
461 gfc_set_decl_location (decl
, &com
->where
);
463 if (com
->threadprivate
)
464 set_decl_tls_model (decl
, decl_default_tls_model (decl
));
466 if (com
->omp_declare_target
)
467 DECL_ATTRIBUTES (decl
)
468 = tree_cons (get_identifier ("omp declare target"),
469 NULL_TREE
, DECL_ATTRIBUTES (decl
));
471 /* Place the back end declaration for this common block in
472 GLOBAL_BINDING_LEVEL. */
473 gfc_map_of_all_commons
[identifier
] = pushdecl_top_level (decl
);
476 /* Has no initial values. */
479 DECL_INITIAL (decl
) = NULL_TREE
;
480 DECL_COMMON (decl
) = 1;
481 DECL_DEFER_OUTPUT (decl
) = 1;
485 DECL_INITIAL (decl
) = error_mark_node
;
486 DECL_COMMON (decl
) = 0;
487 DECL_DEFER_OUTPUT (decl
) = 0;
493 /* Return a field that is the size of the union, if an equivalence has
494 overlapping initializers. Merge the initializers into a single
495 initializer for this new field, then free the old ones. */
498 get_init_field (segment_info
*head
, tree union_type
, tree
*field_init
,
499 record_layout_info rli
)
502 HOST_WIDE_INT length
= 0;
503 HOST_WIDE_INT offset
= 0;
504 unsigned HOST_WIDE_INT known_align
, desired_align
;
505 bool overlap
= false;
508 unsigned char *data
, *chk
;
509 vec
<constructor_elt
, va_gc
> *v
= NULL
;
511 tree type
= unsigned_char_type_node
;
514 /* Obtain the size of the union and check if there are any overlapping
516 for (s
= head
; s
; s
= s
->next
)
518 HOST_WIDE_INT slen
= s
->offset
+ s
->length
;
521 if (s
->offset
< offset
)
525 length
= length
< slen
? slen
: length
;
531 /* Now absorb all the initializer data into a single vector,
532 whilst checking for overlapping, unequal values. */
533 data
= XCNEWVEC (unsigned char, (size_t)length
);
534 chk
= XCNEWVEC (unsigned char, (size_t)length
);
536 /* TODO - change this when default initialization is implemented. */
537 memset (data
, '\0', (size_t)length
);
538 memset (chk
, '\0', (size_t)length
);
539 for (s
= head
; s
; s
= s
->next
)
541 gfc_merge_initializers (s
->sym
->ts
, s
->sym
->value
,
546 for (i
= 0; i
< length
; i
++)
547 CONSTRUCTOR_APPEND_ELT (v
, NULL
, build_int_cst (type
, data
[i
]));
552 /* Build a char[length] array to hold the initializers. Much of what
553 follows is borrowed from build_field, above. */
555 tmp
= build_int_cst (gfc_array_index_type
, length
- 1);
556 tmp
= build_range_type (gfc_array_index_type
,
557 gfc_index_zero_node
, tmp
);
558 tmp
= build_array_type (type
, tmp
);
559 field
= build_decl (gfc_current_locus
.lb
->location
,
560 FIELD_DECL
, NULL_TREE
, tmp
);
562 known_align
= BIGGEST_ALIGNMENT
;
564 desired_align
= update_alignment_for_field (rli
, field
, known_align
);
565 if (desired_align
> known_align
)
566 DECL_PACKED (field
) = 1;
568 DECL_FIELD_CONTEXT (field
) = union_type
;
569 DECL_FIELD_OFFSET (field
) = size_int (0);
570 DECL_FIELD_BIT_OFFSET (field
) = bitsize_zero_node
;
571 SET_DECL_OFFSET_ALIGN (field
, known_align
);
573 rli
->offset
= size_binop (MAX_EXPR
, rli
->offset
,
574 size_binop (PLUS_EXPR
,
575 DECL_FIELD_OFFSET (field
),
576 DECL_SIZE_UNIT (field
)));
578 init
= build_constructor (TREE_TYPE (field
), v
);
579 TREE_CONSTANT (init
) = 1;
583 for (s
= head
; s
; s
= s
->next
)
585 if (s
->sym
->value
== NULL
)
588 gfc_free_expr (s
->sym
->value
);
589 s
->sym
->value
= NULL
;
596 /* Declare memory for the common block or local equivalence, and create
597 backend declarations for all of the elements. */
600 create_common (gfc_common_head
*com
, segment_info
*head
, bool saw_equiv
)
602 segment_info
*s
, *next_s
;
606 tree field_init
= NULL_TREE
;
607 record_layout_info rli
;
609 bool is_init
= false;
610 bool is_saved
= false;
612 /* Declare the variables inside the common block.
613 If the current common block contains any equivalence object, then
614 make a UNION_TYPE node, otherwise RECORD_TYPE. This will let the
615 alias analyzer work well when there is no address overlapping for
616 common variables in the current common block. */
618 union_type
= make_node (UNION_TYPE
);
620 union_type
= make_node (RECORD_TYPE
);
622 rli
= start_record_layout (union_type
);
623 field_link
= &TYPE_FIELDS (union_type
);
625 /* Check for overlapping initializers and replace them with a single,
626 artificial field that contains all the data. */
628 field
= get_init_field (head
, union_type
, &field_init
, rli
);
632 if (field
!= NULL_TREE
)
636 field_link
= &DECL_CHAIN (field
);
639 for (s
= head
; s
; s
= s
->next
)
641 build_field (s
, union_type
, rli
);
643 /* Link the field into the type. */
644 *field_link
= s
->field
;
645 field_link
= &DECL_CHAIN (s
->field
);
647 /* Has initial value. */
651 /* Has SAVE attribute. */
652 if (s
->sym
->attr
.save
)
656 finish_record_layout (rli
, true);
659 decl
= build_common_decl (com
, union_type
, is_init
);
661 decl
= build_equiv_decl (union_type
, is_init
, is_saved
);
666 vec
<constructor_elt
, va_gc
> *v
= NULL
;
668 if (field
!= NULL_TREE
&& field_init
!= NULL_TREE
)
669 CONSTRUCTOR_APPEND_ELT (v
, field
, field_init
);
671 for (s
= head
; s
; s
= s
->next
)
675 /* Add the initializer for this field. */
676 tmp
= gfc_conv_initializer (s
->sym
->value
, &s
->sym
->ts
,
677 TREE_TYPE (s
->field
),
678 s
->sym
->attr
.dimension
,
680 || s
->sym
->attr
.allocatable
, false);
682 CONSTRUCTOR_APPEND_ELT (v
, s
->field
, tmp
);
686 gcc_assert (!v
->is_empty ());
687 ctor
= build_constructor (union_type
, v
);
688 TREE_CONSTANT (ctor
) = 1;
689 TREE_STATIC (ctor
) = 1;
690 DECL_INITIAL (decl
) = ctor
;
692 #ifdef ENABLE_CHECKING
695 unsigned HOST_WIDE_INT idx
;
696 FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor
), idx
, field
, value
)
697 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
702 /* Build component reference for each variable. */
703 for (s
= head
; s
; s
= next_s
)
707 var_decl
= build_decl (s
->sym
->declared_at
.lb
->location
,
708 VAR_DECL
, DECL_NAME (s
->field
),
709 TREE_TYPE (s
->field
));
710 TREE_STATIC (var_decl
) = TREE_STATIC (decl
);
711 /* Mark the variable as used in order to avoid warnings about
713 TREE_USED (var_decl
) = 1;
714 if (s
->sym
->attr
.use_assoc
)
715 DECL_IGNORED_P (var_decl
) = 1;
716 if (s
->sym
->attr
.target
)
717 TREE_ADDRESSABLE (var_decl
) = 1;
718 /* Fake variables are not visible from other translation units. */
719 TREE_PUBLIC (var_decl
) = 0;
720 gfc_finish_decl_attrs (var_decl
, &s
->sym
->attr
);
722 /* To preserve identifier names in COMMON, chain to procedure
723 scope unless at top level in a module definition. */
725 && s
->sym
->ns
->proc_name
726 && s
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
727 var_decl
= pushdecl_top_level (var_decl
);
729 gfc_add_decl_to_function (var_decl
);
731 SET_DECL_VALUE_EXPR (var_decl
,
732 fold_build3_loc (input_location
, COMPONENT_REF
,
733 TREE_TYPE (s
->field
),
734 decl
, s
->field
, NULL_TREE
));
735 DECL_HAS_VALUE_EXPR_P (var_decl
) = 1;
736 GFC_DECL_COMMON_OR_EQUIV (var_decl
) = 1;
738 if (s
->sym
->attr
.assign
)
740 gfc_allocate_lang_decl (var_decl
);
741 GFC_DECL_ASSIGN (var_decl
) = 1;
742 GFC_DECL_STRING_LEN (var_decl
) = GFC_DECL_STRING_LEN (s
->field
);
743 GFC_DECL_ASSIGN_ADDR (var_decl
) = GFC_DECL_ASSIGN_ADDR (s
->field
);
746 s
->sym
->backend_decl
= var_decl
;
754 /* Given a symbol, find it in the current segment list. Returns NULL if
757 static segment_info
*
758 find_segment_info (gfc_symbol
*symbol
)
762 for (n
= current_segment
; n
; n
= n
->next
)
764 if (n
->sym
== symbol
)
772 /* Given an expression node, make sure it is a constant integer and return
776 get_mpz (gfc_expr
*e
)
779 if (e
->expr_type
!= EXPR_CONSTANT
)
780 gfc_internal_error ("get_mpz(): Not an integer constant");
782 return &e
->value
.integer
;
786 /* Given an array specification and an array reference, figure out the
787 array element number (zero based). Bounds and elements are guaranteed
788 to be constants. If something goes wrong we generate an error and
792 element_number (gfc_array_ref
*ar
)
794 mpz_t multiplier
, offset
, extent
, n
;
796 HOST_WIDE_INT i
, rank
;
800 mpz_init_set_ui (multiplier
, 1);
801 mpz_init_set_ui (offset
, 0);
805 for (i
= 0; i
< rank
; i
++)
807 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
808 gfc_internal_error ("element_number(): Bad dimension type");
810 mpz_sub (n
, *get_mpz (ar
->start
[i
]), *get_mpz (as
->lower
[i
]));
812 mpz_mul (n
, n
, multiplier
);
813 mpz_add (offset
, offset
, n
);
815 mpz_sub (extent
, *get_mpz (as
->upper
[i
]), *get_mpz (as
->lower
[i
]));
816 mpz_add_ui (extent
, extent
, 1);
818 if (mpz_sgn (extent
) < 0)
819 mpz_set_ui (extent
, 0);
821 mpz_mul (multiplier
, multiplier
, extent
);
824 i
= mpz_get_ui (offset
);
826 mpz_clear (multiplier
);
835 /* Given a single element of an equivalence list, figure out the offset
836 from the base symbol. For simple variables or full arrays, this is
837 simply zero. For an array element we have to calculate the array
838 element number and multiply by the element size. For a substring we
839 have to calculate the further reference. */
842 calculate_offset (gfc_expr
*e
)
844 HOST_WIDE_INT n
, element_size
, offset
;
845 gfc_typespec
*element_type
;
849 element_type
= &e
->symtree
->n
.sym
->ts
;
851 for (reference
= e
->ref
; reference
; reference
= reference
->next
)
852 switch (reference
->type
)
855 switch (reference
->u
.ar
.type
)
861 n
= element_number (&reference
->u
.ar
);
862 if (element_type
->type
== BT_CHARACTER
)
863 gfc_conv_const_charlen (element_type
->u
.cl
);
865 int_size_in_bytes (gfc_typenode_for_spec (element_type
));
866 offset
+= n
* element_size
;
870 gfc_error ("Bad array reference at %L", &e
->where
);
874 if (reference
->u
.ss
.start
!= NULL
)
875 offset
+= mpz_get_ui (*get_mpz (reference
->u
.ss
.start
)) - 1;
878 gfc_error ("Illegal reference type at %L as EQUIVALENCE object",
885 /* Add a new segment_info structure to the current segment. eq1 is already
886 in the list, eq2 is not. */
889 new_condition (segment_info
*v
, gfc_equiv
*eq1
, gfc_equiv
*eq2
)
891 HOST_WIDE_INT offset1
, offset2
;
894 offset1
= calculate_offset (eq1
->expr
);
895 offset2
= calculate_offset (eq2
->expr
);
897 a
= get_segment_info (eq2
->expr
->symtree
->n
.sym
,
898 v
->offset
+ offset1
- offset2
);
900 current_segment
= add_segments (current_segment
, a
);
904 /* Given two equivalence structures that are both already in the list, make
905 sure that this new condition is not violated, generating an error if it
909 confirm_condition (segment_info
*s1
, gfc_equiv
*eq1
, segment_info
*s2
,
912 HOST_WIDE_INT offset1
, offset2
;
914 offset1
= calculate_offset (eq1
->expr
);
915 offset2
= calculate_offset (eq2
->expr
);
917 if (s1
->offset
+ offset1
!= s2
->offset
+ offset2
)
918 gfc_error ("Inconsistent equivalence rules involving %qs at %L and "
919 "%qs at %L", s1
->sym
->name
, &s1
->sym
->declared_at
,
920 s2
->sym
->name
, &s2
->sym
->declared_at
);
924 /* Process a new equivalence condition. eq1 is know to be in segment f.
925 If eq2 is also present then confirm that the condition holds.
926 Otherwise add a new variable to the segment list. */
929 add_condition (segment_info
*f
, gfc_equiv
*eq1
, gfc_equiv
*eq2
)
933 n
= find_segment_info (eq2
->expr
->symtree
->n
.sym
);
936 new_condition (f
, eq1
, eq2
);
938 confirm_condition (f
, eq1
, n
, eq2
);
942 /* Given a segment element, search through the equivalence lists for unused
943 conditions that involve the symbol. Add these rules to the segment. */
946 find_equivalence (segment_info
*n
)
948 gfc_equiv
*e1
, *e2
, *eq
;
953 for (e1
= n
->sym
->ns
->equiv
; e1
; e1
= e1
->next
)
957 /* Search the equivalence list, including the root (first) element
958 for the symbol that owns the segment. */
959 for (e2
= e1
; e2
; e2
= e2
->eq
)
961 if (!e2
->used
&& e2
->expr
->symtree
->n
.sym
== n
->sym
)
968 /* Go to the next root element. */
974 /* Now traverse the equivalence list matching the offsets. */
975 for (e2
= e1
; e2
; e2
= e2
->eq
)
977 if (!e2
->used
&& e2
!= eq
)
979 add_condition (n
, eq
, e2
);
989 /* Add all symbols equivalenced within a segment. We need to scan the
990 segment list multiple times to include indirect equivalences. Since
991 a new segment_info can inserted at the beginning of the segment list,
992 depending on its offset, we have to force a final pass through the
993 loop by demanding that completion sees a pass with no matches; i.e.,
994 all symbols with equiv_built set and no new equivalences found. */
997 add_equivalences (bool *saw_equiv
)
1000 bool seen_one
, more
;
1007 for (f
= current_segment
; f
; f
= f
->next
)
1009 if (!f
->sym
->equiv_built
)
1011 f
->sym
->equiv_built
= 1;
1012 seen_one
= find_equivalence (f
);
1022 /* Add a copy of this segment list to the namespace. */
1023 copy_equiv_list_to_ns (current_segment
);
1027 /* Returns the offset necessary to properly align the current equivalence.
1028 Sets *palign to the required alignment. */
1030 static HOST_WIDE_INT
1031 align_segment (unsigned HOST_WIDE_INT
*palign
)
1034 unsigned HOST_WIDE_INT offset
;
1035 unsigned HOST_WIDE_INT max_align
;
1036 unsigned HOST_WIDE_INT this_align
;
1037 unsigned HOST_WIDE_INT this_offset
;
1041 for (s
= current_segment
; s
; s
= s
->next
)
1043 this_align
= TYPE_ALIGN_UNIT (s
->field
);
1044 if (s
->offset
& (this_align
- 1))
1046 /* Field is misaligned. */
1047 this_offset
= this_align
- ((s
->offset
+ offset
) & (this_align
- 1));
1048 if (this_offset
& (max_align
- 1))
1050 /* Aligning this field would misalign a previous field. */
1051 gfc_error ("The equivalence set for variable %qs "
1052 "declared at %L violates alignment requirements",
1053 s
->sym
->name
, &s
->sym
->declared_at
);
1055 offset
+= this_offset
;
1057 max_align
= this_align
;
1060 *palign
= max_align
;
1065 /* Adjust segment offsets by the given amount. */
1068 apply_segment_offset (segment_info
*s
, HOST_WIDE_INT offset
)
1070 for (; s
; s
= s
->next
)
1071 s
->offset
+= offset
;
1075 /* Lay out a symbol in a common block. If the symbol has already been seen
1076 then check the location is consistent. Otherwise create segments
1077 for that symbol and all the symbols equivalenced with it. */
1079 /* Translate a single common block. */
1082 translate_common (gfc_common_head
*common
, gfc_symbol
*var_list
)
1086 segment_info
*common_segment
;
1087 HOST_WIDE_INT offset
;
1088 HOST_WIDE_INT current_offset
;
1089 unsigned HOST_WIDE_INT align
;
1092 common_segment
= NULL
;
1098 /* Add symbols to the segment. */
1099 for (sym
= var_list
; sym
; sym
= sym
->common_next
)
1101 current_segment
= common_segment
;
1102 s
= find_segment_info (sym
);
1104 /* Symbol has already been added via an equivalence. Multiple
1105 use associations of the same common block result in equiv_built
1106 being set but no information about the symbol in the segment. */
1107 if (s
&& sym
->equiv_built
)
1109 /* Ensure the current location is properly aligned. */
1110 align
= TYPE_ALIGN_UNIT (s
->field
);
1111 current_offset
= (current_offset
+ align
- 1) &~ (align
- 1);
1113 /* Verify that it ended up where we expect it. */
1114 if (s
->offset
!= current_offset
)
1116 gfc_error ("Equivalence for %qs does not match ordering of "
1117 "COMMON %qs at %L", sym
->name
,
1118 common
->name
, &common
->where
);
1123 /* A symbol we haven't seen before. */
1124 s
= current_segment
= get_segment_info (sym
, current_offset
);
1126 /* Add all objects directly or indirectly equivalenced with this
1128 add_equivalences (&saw_equiv
);
1130 if (current_segment
->offset
< 0)
1131 gfc_error ("The equivalence set for %qs cause an invalid "
1132 "extension to COMMON %qs at %L", sym
->name
,
1133 common
->name
, &common
->where
);
1135 if (flag_align_commons
)
1136 offset
= align_segment (&align
);
1140 /* The required offset conflicts with previous alignment
1141 requirements. Insert padding immediately before this
1143 if (warn_align_commons
)
1145 if (strcmp (common
->name
, BLANK_COMMON_NAME
))
1147 "Padding of %d bytes required before %qs in "
1148 "COMMON %qs at %L; reorder elements or use "
1149 "-fno-align-commons", (int)offset
,
1150 s
->sym
->name
, common
->name
, &common
->where
);
1153 "Padding of %d bytes required before %qs in "
1154 "COMMON at %L; reorder elements or use "
1155 "-fno-align-commons", (int)offset
,
1156 s
->sym
->name
, &common
->where
);
1160 /* Apply the offset to the new segments. */
1161 apply_segment_offset (current_segment
, offset
);
1162 current_offset
+= offset
;
1164 /* Add the new segments to the common block. */
1165 common_segment
= add_segments (common_segment
, current_segment
);
1168 /* The offset of the next common variable. */
1169 current_offset
+= s
->length
;
1172 if (common_segment
== NULL
)
1174 gfc_error ("COMMON '%s' at %L does not exist",
1175 common
->name
, &common
->where
);
1179 if (common_segment
->offset
!= 0 && warn_align_commons
)
1181 if (strcmp (common
->name
, BLANK_COMMON_NAME
))
1182 gfc_warning (OPT_Walign_commons
,
1183 "COMMON %qs at %L requires %d bytes of padding; "
1184 "reorder elements or use %<-fno-align-commons%>",
1185 common
->name
, &common
->where
, (int)common_segment
->offset
);
1187 gfc_warning (OPT_Walign_commons
,
1188 "COMMON at %L requires %d bytes of padding; "
1189 "reorder elements or use %<-fno-align-commons%>",
1190 &common
->where
, (int)common_segment
->offset
);
1193 create_common (common
, common_segment
, saw_equiv
);
1197 /* Create a new block for each merged equivalence list. */
1200 finish_equivalences (gfc_namespace
*ns
)
1204 gfc_common_head
* c
;
1205 HOST_WIDE_INT offset
;
1206 unsigned HOST_WIDE_INT align
;
1209 for (z
= ns
->equiv
; z
; z
= z
->next
)
1210 for (y
= z
->eq
; y
; y
= y
->eq
)
1214 sym
= z
->expr
->symtree
->n
.sym
;
1215 current_segment
= get_segment_info (sym
, 0);
1217 /* All objects directly or indirectly equivalenced with this
1219 add_equivalences (&dummy
);
1221 /* Align the block. */
1222 offset
= align_segment (&align
);
1224 /* Ensure all offsets are positive. */
1225 offset
-= current_segment
->offset
& ~(align
- 1);
1227 apply_segment_offset (current_segment
, offset
);
1229 /* Create the decl. If this is a module equivalence, it has a
1230 unique name, pointed to by z->module. This is written to a
1231 gfc_common_header to push create_common into using
1232 build_common_decl, so that the equivalence appears as an
1233 external symbol. Otherwise, a local declaration is built using
1234 build_equiv_decl. */
1237 c
= gfc_get_common_head ();
1238 /* We've lost the real location, so use the location of the
1239 enclosing procedure. */
1240 c
->where
= ns
->proc_name
->declared_at
;
1241 strcpy (c
->name
, z
->module
);
1246 create_common (c
, current_segment
, true);
1252 /* Work function for translating a named common block. */
1255 named_common (gfc_symtree
*st
)
1257 translate_common (st
->n
.common
, st
->n
.common
->head
);
1261 /* Translate the common blocks in a namespace. Unlike other variables,
1262 these have to be created before code, because the backend_decl depends
1263 on the rest of the common block. */
1266 gfc_trans_common (gfc_namespace
*ns
)
1270 /* Translate the blank common block. */
1271 if (ns
->blank_common
.head
!= NULL
)
1273 c
= gfc_get_common_head ();
1274 c
->where
= ns
->blank_common
.head
->common_head
->where
;
1275 strcpy (c
->name
, BLANK_COMMON_NAME
);
1276 translate_common (c
, ns
->blank_common
.head
);
1279 /* Translate all named common blocks. */
1280 gfc_traverse_symtree (ns
->common_root
, named_common
);
1282 /* Translate local equivalence. */
1283 finish_equivalences (ns
);
1285 /* Commit the newly created symbols for common blocks and module
1287 gfc_commit_symbols ();