1 /* Common block and equivalence list handling
2 Copyright (C) 2000, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
4 Free Software Foundation, Inc.
5 Contributed by Canqun Yang <canqun@nudt.edu.cn>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* The core algorithm is based on Andy Vaught's g95 tree. Also the
24 way to build UNION_TYPE is borrowed from Richard Henderson.
26 Transform common blocks. An integral part of this is processing
27 equivalence variables. Equivalenced variables that are not in a
28 common block end up in a private block of their own.
30 Each common block or local equivalence list is declared as a union.
31 Variables within the block are represented as a field within the
32 block with the proper offset.
34 So if two variables are equivalenced, they just point to a common
37 Mathematically, laying out an equivalence block is equivalent to
38 solving a linear system of equations. The matrix is usually a
39 sparse matrix in which each row contains all zero elements except
40 for a +1 and a -1, a sort of a generalized Vandermonde matrix. The
41 matrix is usually block diagonal. The system can be
42 overdetermined, underdetermined or have a unique solution. If the
43 system is inconsistent, the program is not standard conforming.
44 The solution vector is integral, since all of the pivots are +1 or -1.
46 How we lay out an equivalence block is a little less complicated.
47 In an equivalence list with n elements, there are n-1 conditions to
48 be satisfied. The conditions partition the variables into what we
49 will call segments. If A and B are equivalenced then A and B are
50 in the same segment. If B and C are equivalenced as well, then A,
51 B and C are in a segment and so on. Each segment is a block of
52 memory that has one or more variables equivalenced in some way. A
53 common block is made up of a series of segments that are joined one
54 after the other. In the linear system, a segment is a block
57 To lay out a segment we first start with some variable and
58 determine its length. The first variable is assumed to start at
59 offset one and extends to however long it is. We then traverse the
60 list of equivalences to find an unused condition that involves at
61 least one of the variables currently in the segment.
63 Each equivalence condition amounts to the condition B+b=C+c where B
64 and C are the offsets of the B and C variables, and b and c are
65 constants which are nonzero for array elements, substrings or
66 structure components. So for
68 EQUIVALENCE(B(2), C(3))
70 B + 2*size of B's elements = C + 3*size of C's elements.
72 If B and C are known we check to see if the condition already
73 holds. If B is known we can solve for C. Since we know the length
74 of C, we can see if the minimum and maximum extents of the segment
75 are affected. Eventually, we make a full pass through the
76 equivalence list without finding any new conditions and the segment
79 At this point, the segment is added to the current common block.
80 Since we know the minimum extent of the segment, everything in the
81 segment is translated to its position in the common block. The
82 usual case here is that there are no equivalence statements and the
83 common block is series of segments with one variable each, which is
84 a diagonal matrix in the matrix formulation.
86 Each segment is described by a chain of segment_info structures. Each
87 segment_info structure describes the extents of a single variable within
88 the segment. This list is maintained in the order the elements are
89 positioned withing the segment. If two elements have the same starting
90 offset the smaller will come first. If they also have the same size their
91 ordering is undefined.
93 Once all common blocks have been created, the list of equivalences
94 is examined for still-unused equivalence conditions. We create a
95 block for each merged equivalence list. */
99 #include "coretypes.h"
102 #include "output.h" /* For decl_default_tls_model. */
103 #include "gfortran.h"
105 #include "trans-types.h"
106 #include "trans-const.h"
107 #include "target-memory.h"
110 /* Holds a single variable in an equivalence set. */
111 typedef struct segment_info
114 HOST_WIDE_INT offset
;
115 HOST_WIDE_INT length
;
116 /* This will contain the field type until the field is created. */
118 struct segment_info
*next
;
121 static segment_info
* current_segment
;
122 static gfc_namespace
*gfc_common_ns
= NULL
;
125 /* Make a segment_info based on a symbol. */
127 static segment_info
*
128 get_segment_info (gfc_symbol
* sym
, HOST_WIDE_INT offset
)
132 /* Make sure we've got the character length. */
133 if (sym
->ts
.type
== BT_CHARACTER
)
134 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
136 /* Create the segment_info and fill it in. */
137 s
= XCNEW (segment_info
);
139 /* We will use this type when building the segment aggregate type. */
140 s
->field
= gfc_sym_type (sym
);
141 s
->length
= int_size_in_bytes (s
->field
);
148 /* Add a copy of a segment list to the namespace. This is specifically for
149 equivalence segments, so that dependency checking can be done on
150 equivalence group members. */
153 copy_equiv_list_to_ns (segment_info
*c
)
159 l
= XCNEW (gfc_equiv_list
);
161 l
->next
= c
->sym
->ns
->equiv_lists
;
162 c
->sym
->ns
->equiv_lists
= l
;
164 for (f
= c
; f
; f
= f
->next
)
166 s
= XCNEW (gfc_equiv_info
);
170 s
->offset
= f
->offset
;
171 s
->length
= f
->length
;
176 /* Add combine segment V and segment LIST. */
178 static segment_info
*
179 add_segments (segment_info
*list
, segment_info
*v
)
190 /* Find the location of the new element. */
193 if (v
->offset
< s
->offset
)
195 if (v
->offset
== s
->offset
196 && v
->length
<= s
->length
)
203 /* Insert the new element in between p and s. */
219 /* Construct mangled common block name from symbol name. */
221 /* We need the bind(c) flag to tell us how/if we should mangle the symbol
222 name. There are few calls to this function, so few places that this
223 would need to be added. At the moment, there is only one call, in
224 build_common_decl(). We can't attempt to look up the common block
225 because we may be building it for the first time and therefore, it won't
226 be in the common_root. We also need the binding label, if it's bind(c).
227 Therefore, send in the pointer to the common block, so whatever info we
228 have so far can be used. All of the necessary info should be available
229 in the gfc_common_head by now, so it should be accurate to test the
230 isBindC flag and use the binding label given if it is bind(c).
232 We may NOT know yet if it's bind(c) or not, but we can try at least.
233 Will have to figure out what to do later if it's labeled bind(c)
234 after this is called. */
237 gfc_sym_mangled_common_id (gfc_common_head
*com
)
240 char mangled_name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 1];
241 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
243 /* Get the name out of the common block pointer. */
244 strcpy (name
, com
->name
);
246 /* If we're suppose to do a bind(c). */
247 if (com
->is_bind_c
== 1 && com
->binding_label
)
248 return get_identifier (com
->binding_label
);
250 if (strcmp (name
, BLANK_COMMON_NAME
) == 0)
251 return get_identifier (name
);
253 if (gfc_option
.flag_underscoring
)
255 has_underscore
= strchr (name
, '_') != 0;
256 if (gfc_option
.flag_second_underscore
&& has_underscore
)
257 snprintf (mangled_name
, sizeof mangled_name
, "%s__", name
);
259 snprintf (mangled_name
, sizeof mangled_name
, "%s_", name
);
261 return get_identifier (mangled_name
);
264 return get_identifier (name
);
268 /* Build a field declaration for a common variable or a local equivalence
272 build_field (segment_info
*h
, tree union_type
, record_layout_info rli
)
276 HOST_WIDE_INT offset
= h
->offset
;
277 unsigned HOST_WIDE_INT desired_align
, known_align
;
279 name
= get_identifier (h
->sym
->name
);
280 field
= build_decl (h
->sym
->declared_at
.lb
->location
,
281 FIELD_DECL
, name
, h
->field
);
282 known_align
= (offset
& -offset
) * BITS_PER_UNIT
;
283 if (known_align
== 0 || known_align
> BIGGEST_ALIGNMENT
)
284 known_align
= BIGGEST_ALIGNMENT
;
286 desired_align
= update_alignment_for_field (rli
, field
, known_align
);
287 if (desired_align
> known_align
)
288 DECL_PACKED (field
) = 1;
290 DECL_FIELD_CONTEXT (field
) = union_type
;
291 DECL_FIELD_OFFSET (field
) = size_int (offset
);
292 DECL_FIELD_BIT_OFFSET (field
) = bitsize_zero_node
;
293 SET_DECL_OFFSET_ALIGN (field
, known_align
);
295 rli
->offset
= size_binop (MAX_EXPR
, rli
->offset
,
296 size_binop (PLUS_EXPR
,
297 DECL_FIELD_OFFSET (field
),
298 DECL_SIZE_UNIT (field
)));
299 /* If this field is assigned to a label, we create another two variables.
300 One will hold the address of target label or format label. The other will
301 hold the length of format label string. */
302 if (h
->sym
->attr
.assign
)
307 gfc_allocate_lang_decl (field
);
308 GFC_DECL_ASSIGN (field
) = 1;
309 len
= gfc_create_var_np (gfc_charlen_type_node
,h
->sym
->name
);
310 addr
= gfc_create_var_np (pvoid_type_node
, h
->sym
->name
);
311 TREE_STATIC (len
) = 1;
312 TREE_STATIC (addr
) = 1;
313 DECL_INITIAL (len
) = build_int_cst (gfc_charlen_type_node
, -2);
314 gfc_set_decl_location (len
, &h
->sym
->declared_at
);
315 gfc_set_decl_location (addr
, &h
->sym
->declared_at
);
316 GFC_DECL_STRING_LEN (field
) = pushdecl_top_level (len
);
317 GFC_DECL_ASSIGN_ADDR (field
) = pushdecl_top_level (addr
);
320 /* If this field is volatile, mark it. */
321 if (h
->sym
->attr
.volatile_
)
324 TREE_THIS_VOLATILE (field
) = 1;
325 TREE_SIDE_EFFECTS (field
) = 1;
326 new_type
= build_qualified_type (TREE_TYPE (field
), TYPE_QUAL_VOLATILE
);
327 TREE_TYPE (field
) = new_type
;
334 /* Get storage for local equivalence. */
337 build_equiv_decl (tree union_type
, bool is_init
, bool is_saved
)
341 static int serial
= 0;
345 decl
= gfc_create_var (union_type
, "equiv");
346 TREE_STATIC (decl
) = 1;
347 GFC_DECL_COMMON_OR_EQUIV (decl
) = 1;
351 snprintf (name
, sizeof (name
), "equiv.%d", serial
++);
352 decl
= build_decl (input_location
,
353 VAR_DECL
, get_identifier (name
), union_type
);
354 DECL_ARTIFICIAL (decl
) = 1;
355 DECL_IGNORED_P (decl
) = 1;
357 if (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl
))
359 TREE_STATIC (decl
) = 1;
361 TREE_ADDRESSABLE (decl
) = 1;
362 TREE_USED (decl
) = 1;
363 GFC_DECL_COMMON_OR_EQUIV (decl
) = 1;
365 /* The source location has been lost, and doesn't really matter.
366 We need to set it to something though. */
367 gfc_set_decl_location (decl
, &gfc_current_locus
);
369 gfc_add_decl_to_function (decl
);
375 /* Get storage for common block. */
378 build_common_decl (gfc_common_head
*com
, tree union_type
, bool is_init
)
380 gfc_symbol
*common_sym
;
383 /* Create a namespace to store symbols for common blocks. */
384 if (gfc_common_ns
== NULL
)
385 gfc_common_ns
= gfc_get_namespace (NULL
, 0);
387 gfc_get_symbol (com
->name
, gfc_common_ns
, &common_sym
);
388 decl
= common_sym
->backend_decl
;
390 /* Update the size of this common block as needed. */
391 if (decl
!= NULL_TREE
)
393 tree size
= TYPE_SIZE_UNIT (union_type
);
395 /* Named common blocks of the same name shall be of the same size
396 in all scoping units of a program in which they appear, but
397 blank common blocks may be of different sizes. */
398 if (!tree_int_cst_equal (DECL_SIZE_UNIT (decl
), size
)
399 && strcmp (com
->name
, BLANK_COMMON_NAME
))
400 gfc_warning ("Named COMMON block '%s' at %L shall be of the "
401 "same size as elsewhere (%lu vs %lu bytes)", com
->name
,
403 (unsigned long) TREE_INT_CST_LOW (size
),
404 (unsigned long) TREE_INT_CST_LOW (DECL_SIZE_UNIT (decl
)));
406 if (tree_int_cst_lt (DECL_SIZE_UNIT (decl
), size
))
408 DECL_SIZE (decl
) = TYPE_SIZE (union_type
);
409 DECL_SIZE_UNIT (decl
) = size
;
410 DECL_MODE (decl
) = TYPE_MODE (union_type
);
411 TREE_TYPE (decl
) = union_type
;
412 layout_decl (decl
, 0);
416 /* If this common block has been declared in a previous program unit,
417 and either it is already initialized or there is no new initialization
418 for it, just return. */
419 if ((decl
!= NULL_TREE
) && (!is_init
|| DECL_INITIAL (decl
)))
422 /* If there is no backend_decl for the common block, build it. */
423 if (decl
== NULL_TREE
)
425 decl
= build_decl (input_location
,
426 VAR_DECL
, get_identifier (com
->name
), union_type
);
427 gfc_set_decl_assembler_name (decl
, gfc_sym_mangled_common_id (com
));
428 TREE_PUBLIC (decl
) = 1;
429 TREE_STATIC (decl
) = 1;
430 DECL_IGNORED_P (decl
) = 1;
432 DECL_ALIGN (decl
) = BIGGEST_ALIGNMENT
;
435 /* Do not set the alignment for bind(c) common blocks to
436 BIGGEST_ALIGNMENT because that won't match what C does. Also,
437 for common blocks with one element, the alignment must be
438 that of the field within the common block in order to match
440 tree field
= NULL_TREE
;
441 field
= TYPE_FIELDS (TREE_TYPE (decl
));
442 if (DECL_CHAIN (field
) == NULL_TREE
)
443 DECL_ALIGN (decl
) = TYPE_ALIGN (TREE_TYPE (field
));
445 DECL_USER_ALIGN (decl
) = 0;
446 GFC_DECL_COMMON_OR_EQUIV (decl
) = 1;
448 gfc_set_decl_location (decl
, &com
->where
);
450 if (com
->threadprivate
)
451 DECL_TLS_MODEL (decl
) = decl_default_tls_model (decl
);
453 /* Place the back end declaration for this common block in
454 GLOBAL_BINDING_LEVEL. */
455 common_sym
->backend_decl
= pushdecl_top_level (decl
);
458 /* Has no initial values. */
461 DECL_INITIAL (decl
) = NULL_TREE
;
462 DECL_COMMON (decl
) = 1;
463 DECL_DEFER_OUTPUT (decl
) = 1;
467 DECL_INITIAL (decl
) = error_mark_node
;
468 DECL_COMMON (decl
) = 0;
469 DECL_DEFER_OUTPUT (decl
) = 0;
475 /* Return a field that is the size of the union, if an equivalence has
476 overlapping initializers. Merge the initializers into a single
477 initializer for this new field, then free the old ones. */
480 get_init_field (segment_info
*head
, tree union_type
, tree
*field_init
,
481 record_layout_info rli
)
484 HOST_WIDE_INT length
= 0;
485 HOST_WIDE_INT offset
= 0;
486 unsigned HOST_WIDE_INT known_align
, desired_align
;
487 bool overlap
= false;
490 unsigned char *data
, *chk
;
491 VEC(constructor_elt
,gc
) *v
= NULL
;
493 tree type
= unsigned_char_type_node
;
496 /* Obtain the size of the union and check if there are any overlapping
498 for (s
= head
; s
; s
= s
->next
)
500 HOST_WIDE_INT slen
= s
->offset
+ s
->length
;
503 if (s
->offset
< offset
)
507 length
= length
< slen
? slen
: length
;
513 /* Now absorb all the initializer data into a single vector,
514 whilst checking for overlapping, unequal values. */
515 data
= XCNEWVEC (unsigned char, (size_t)length
);
516 chk
= XCNEWVEC (unsigned char, (size_t)length
);
518 /* TODO - change this when default initialization is implemented. */
519 memset (data
, '\0', (size_t)length
);
520 memset (chk
, '\0', (size_t)length
);
521 for (s
= head
; s
; s
= s
->next
)
523 gfc_merge_initializers (s
->sym
->ts
, s
->sym
->value
,
528 for (i
= 0; i
< length
; i
++)
529 CONSTRUCTOR_APPEND_ELT (v
, NULL
, build_int_cst (type
, data
[i
]));
534 /* Build a char[length] array to hold the initializers. Much of what
535 follows is borrowed from build_field, above. */
537 tmp
= build_int_cst (gfc_array_index_type
, length
- 1);
538 tmp
= build_range_type (gfc_array_index_type
,
539 gfc_index_zero_node
, tmp
);
540 tmp
= build_array_type (type
, tmp
);
541 field
= build_decl (gfc_current_locus
.lb
->location
,
542 FIELD_DECL
, NULL_TREE
, tmp
);
544 known_align
= BIGGEST_ALIGNMENT
;
546 desired_align
= update_alignment_for_field (rli
, field
, known_align
);
547 if (desired_align
> known_align
)
548 DECL_PACKED (field
) = 1;
550 DECL_FIELD_CONTEXT (field
) = union_type
;
551 DECL_FIELD_OFFSET (field
) = size_int (0);
552 DECL_FIELD_BIT_OFFSET (field
) = bitsize_zero_node
;
553 SET_DECL_OFFSET_ALIGN (field
, known_align
);
555 rli
->offset
= size_binop (MAX_EXPR
, rli
->offset
,
556 size_binop (PLUS_EXPR
,
557 DECL_FIELD_OFFSET (field
),
558 DECL_SIZE_UNIT (field
)));
560 init
= build_constructor (TREE_TYPE (field
), v
);
561 TREE_CONSTANT (init
) = 1;
565 for (s
= head
; s
; s
= s
->next
)
567 if (s
->sym
->value
== NULL
)
570 gfc_free_expr (s
->sym
->value
);
571 s
->sym
->value
= NULL
;
578 /* Declare memory for the common block or local equivalence, and create
579 backend declarations for all of the elements. */
582 create_common (gfc_common_head
*com
, segment_info
*head
, bool saw_equiv
)
584 segment_info
*s
, *next_s
;
588 tree field_init
= NULL_TREE
;
589 record_layout_info rli
;
591 bool is_init
= false;
592 bool is_saved
= false;
594 /* Declare the variables inside the common block.
595 If the current common block contains any equivalence object, then
596 make a UNION_TYPE node, otherwise RECORD_TYPE. This will let the
597 alias analyzer work well when there is no address overlapping for
598 common variables in the current common block. */
600 union_type
= make_node (UNION_TYPE
);
602 union_type
= make_node (RECORD_TYPE
);
604 rli
= start_record_layout (union_type
);
605 field_link
= &TYPE_FIELDS (union_type
);
607 /* Check for overlapping initializers and replace them with a single,
608 artificial field that contains all the data. */
610 field
= get_init_field (head
, union_type
, &field_init
, rli
);
614 if (field
!= NULL_TREE
)
618 field_link
= &DECL_CHAIN (field
);
621 for (s
= head
; s
; s
= s
->next
)
623 build_field (s
, union_type
, rli
);
625 /* Link the field into the type. */
626 *field_link
= s
->field
;
627 field_link
= &DECL_CHAIN (s
->field
);
629 /* Has initial value. */
633 /* Has SAVE attribute. */
634 if (s
->sym
->attr
.save
)
638 finish_record_layout (rli
, true);
641 decl
= build_common_decl (com
, union_type
, is_init
);
643 decl
= build_equiv_decl (union_type
, is_init
, is_saved
);
648 VEC(constructor_elt
,gc
) *v
= NULL
;
650 if (field
!= NULL_TREE
&& field_init
!= NULL_TREE
)
651 CONSTRUCTOR_APPEND_ELT (v
, field
, field_init
);
653 for (s
= head
; s
; s
= s
->next
)
657 /* Add the initializer for this field. */
658 tmp
= gfc_conv_initializer (s
->sym
->value
, &s
->sym
->ts
,
659 TREE_TYPE (s
->field
),
660 s
->sym
->attr
.dimension
,
662 || s
->sym
->attr
.allocatable
, false);
664 CONSTRUCTOR_APPEND_ELT (v
, s
->field
, tmp
);
668 gcc_assert (!VEC_empty (constructor_elt
, v
));
669 ctor
= build_constructor (union_type
, v
);
670 TREE_CONSTANT (ctor
) = 1;
671 TREE_STATIC (ctor
) = 1;
672 DECL_INITIAL (decl
) = ctor
;
674 #ifdef ENABLE_CHECKING
677 unsigned HOST_WIDE_INT idx
;
678 FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor
), idx
, field
, value
)
679 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
684 /* Build component reference for each variable. */
685 for (s
= head
; s
; s
= next_s
)
689 var_decl
= build_decl (s
->sym
->declared_at
.lb
->location
,
690 VAR_DECL
, DECL_NAME (s
->field
),
691 TREE_TYPE (s
->field
));
692 TREE_STATIC (var_decl
) = TREE_STATIC (decl
);
693 /* Mark the variable as used in order to avoid warnings about
695 TREE_USED (var_decl
) = 1;
696 if (s
->sym
->attr
.use_assoc
)
697 DECL_IGNORED_P (var_decl
) = 1;
698 if (s
->sym
->attr
.target
)
699 TREE_ADDRESSABLE (var_decl
) = 1;
700 /* Fake variables are not visible from other translation units. */
701 TREE_PUBLIC (var_decl
) = 0;
703 /* To preserve identifier names in COMMON, chain to procedure
704 scope unless at top level in a module definition. */
706 && s
->sym
->ns
->proc_name
707 && s
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
708 var_decl
= pushdecl_top_level (var_decl
);
710 gfc_add_decl_to_function (var_decl
);
712 SET_DECL_VALUE_EXPR (var_decl
,
713 fold_build3_loc (input_location
, COMPONENT_REF
,
714 TREE_TYPE (s
->field
),
715 decl
, s
->field
, NULL_TREE
));
716 DECL_HAS_VALUE_EXPR_P (var_decl
) = 1;
717 GFC_DECL_COMMON_OR_EQUIV (var_decl
) = 1;
719 if (s
->sym
->attr
.assign
)
721 gfc_allocate_lang_decl (var_decl
);
722 GFC_DECL_ASSIGN (var_decl
) = 1;
723 GFC_DECL_STRING_LEN (var_decl
) = GFC_DECL_STRING_LEN (s
->field
);
724 GFC_DECL_ASSIGN_ADDR (var_decl
) = GFC_DECL_ASSIGN_ADDR (s
->field
);
727 s
->sym
->backend_decl
= var_decl
;
735 /* Given a symbol, find it in the current segment list. Returns NULL if
738 static segment_info
*
739 find_segment_info (gfc_symbol
*symbol
)
743 for (n
= current_segment
; n
; n
= n
->next
)
745 if (n
->sym
== symbol
)
753 /* Given an expression node, make sure it is a constant integer and return
757 get_mpz (gfc_expr
*e
)
760 if (e
->expr_type
!= EXPR_CONSTANT
)
761 gfc_internal_error ("get_mpz(): Not an integer constant");
763 return &e
->value
.integer
;
767 /* Given an array specification and an array reference, figure out the
768 array element number (zero based). Bounds and elements are guaranteed
769 to be constants. If something goes wrong we generate an error and
773 element_number (gfc_array_ref
*ar
)
775 mpz_t multiplier
, offset
, extent
, n
;
777 HOST_WIDE_INT i
, rank
;
781 mpz_init_set_ui (multiplier
, 1);
782 mpz_init_set_ui (offset
, 0);
786 for (i
= 0; i
< rank
; i
++)
788 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
789 gfc_internal_error ("element_number(): Bad dimension type");
791 mpz_sub (n
, *get_mpz (ar
->start
[i
]), *get_mpz (as
->lower
[i
]));
793 mpz_mul (n
, n
, multiplier
);
794 mpz_add (offset
, offset
, n
);
796 mpz_sub (extent
, *get_mpz (as
->upper
[i
]), *get_mpz (as
->lower
[i
]));
797 mpz_add_ui (extent
, extent
, 1);
799 if (mpz_sgn (extent
) < 0)
800 mpz_set_ui (extent
, 0);
802 mpz_mul (multiplier
, multiplier
, extent
);
805 i
= mpz_get_ui (offset
);
807 mpz_clear (multiplier
);
816 /* Given a single element of an equivalence list, figure out the offset
817 from the base symbol. For simple variables or full arrays, this is
818 simply zero. For an array element we have to calculate the array
819 element number and multiply by the element size. For a substring we
820 have to calculate the further reference. */
823 calculate_offset (gfc_expr
*e
)
825 HOST_WIDE_INT n
, element_size
, offset
;
826 gfc_typespec
*element_type
;
830 element_type
= &e
->symtree
->n
.sym
->ts
;
832 for (reference
= e
->ref
; reference
; reference
= reference
->next
)
833 switch (reference
->type
)
836 switch (reference
->u
.ar
.type
)
842 n
= element_number (&reference
->u
.ar
);
843 if (element_type
->type
== BT_CHARACTER
)
844 gfc_conv_const_charlen (element_type
->u
.cl
);
846 int_size_in_bytes (gfc_typenode_for_spec (element_type
));
847 offset
+= n
* element_size
;
851 gfc_error ("Bad array reference at %L", &e
->where
);
855 if (reference
->u
.ss
.start
!= NULL
)
856 offset
+= mpz_get_ui (*get_mpz (reference
->u
.ss
.start
)) - 1;
859 gfc_error ("Illegal reference type at %L as EQUIVALENCE object",
866 /* Add a new segment_info structure to the current segment. eq1 is already
867 in the list, eq2 is not. */
870 new_condition (segment_info
*v
, gfc_equiv
*eq1
, gfc_equiv
*eq2
)
872 HOST_WIDE_INT offset1
, offset2
;
875 offset1
= calculate_offset (eq1
->expr
);
876 offset2
= calculate_offset (eq2
->expr
);
878 a
= get_segment_info (eq2
->expr
->symtree
->n
.sym
,
879 v
->offset
+ offset1
- offset2
);
881 current_segment
= add_segments (current_segment
, a
);
885 /* Given two equivalence structures that are both already in the list, make
886 sure that this new condition is not violated, generating an error if it
890 confirm_condition (segment_info
*s1
, gfc_equiv
*eq1
, segment_info
*s2
,
893 HOST_WIDE_INT offset1
, offset2
;
895 offset1
= calculate_offset (eq1
->expr
);
896 offset2
= calculate_offset (eq2
->expr
);
898 if (s1
->offset
+ offset1
!= s2
->offset
+ offset2
)
899 gfc_error ("Inconsistent equivalence rules involving '%s' at %L and "
900 "'%s' at %L", s1
->sym
->name
, &s1
->sym
->declared_at
,
901 s2
->sym
->name
, &s2
->sym
->declared_at
);
905 /* Process a new equivalence condition. eq1 is know to be in segment f.
906 If eq2 is also present then confirm that the condition holds.
907 Otherwise add a new variable to the segment list. */
910 add_condition (segment_info
*f
, gfc_equiv
*eq1
, gfc_equiv
*eq2
)
914 n
= find_segment_info (eq2
->expr
->symtree
->n
.sym
);
917 new_condition (f
, eq1
, eq2
);
919 confirm_condition (f
, eq1
, n
, eq2
);
923 /* Given a segment element, search through the equivalence lists for unused
924 conditions that involve the symbol. Add these rules to the segment. */
927 find_equivalence (segment_info
*n
)
929 gfc_equiv
*e1
, *e2
, *eq
;
934 for (e1
= n
->sym
->ns
->equiv
; e1
; e1
= e1
->next
)
938 /* Search the equivalence list, including the root (first) element
939 for the symbol that owns the segment. */
940 for (e2
= e1
; e2
; e2
= e2
->eq
)
942 if (!e2
->used
&& e2
->expr
->symtree
->n
.sym
== n
->sym
)
949 /* Go to the next root element. */
955 /* Now traverse the equivalence list matching the offsets. */
956 for (e2
= e1
; e2
; e2
= e2
->eq
)
958 if (!e2
->used
&& e2
!= eq
)
960 add_condition (n
, eq
, e2
);
970 /* Add all symbols equivalenced within a segment. We need to scan the
971 segment list multiple times to include indirect equivalences. Since
972 a new segment_info can inserted at the beginning of the segment list,
973 depending on its offset, we have to force a final pass through the
974 loop by demanding that completion sees a pass with no matches; i.e.,
975 all symbols with equiv_built set and no new equivalences found. */
978 add_equivalences (bool *saw_equiv
)
988 for (f
= current_segment
; f
; f
= f
->next
)
990 if (!f
->sym
->equiv_built
)
992 f
->sym
->equiv_built
= 1;
993 seen_one
= find_equivalence (f
);
1003 /* Add a copy of this segment list to the namespace. */
1004 copy_equiv_list_to_ns (current_segment
);
1008 /* Returns the offset necessary to properly align the current equivalence.
1009 Sets *palign to the required alignment. */
1011 static HOST_WIDE_INT
1012 align_segment (unsigned HOST_WIDE_INT
*palign
)
1015 unsigned HOST_WIDE_INT offset
;
1016 unsigned HOST_WIDE_INT max_align
;
1017 unsigned HOST_WIDE_INT this_align
;
1018 unsigned HOST_WIDE_INT this_offset
;
1022 for (s
= current_segment
; s
; s
= s
->next
)
1024 this_align
= TYPE_ALIGN_UNIT (s
->field
);
1025 if (s
->offset
& (this_align
- 1))
1027 /* Field is misaligned. */
1028 this_offset
= this_align
- ((s
->offset
+ offset
) & (this_align
- 1));
1029 if (this_offset
& (max_align
- 1))
1031 /* Aligning this field would misalign a previous field. */
1032 gfc_error ("The equivalence set for variable '%s' "
1033 "declared at %L violates alignment requirements",
1034 s
->sym
->name
, &s
->sym
->declared_at
);
1036 offset
+= this_offset
;
1038 max_align
= this_align
;
1041 *palign
= max_align
;
1046 /* Adjust segment offsets by the given amount. */
1049 apply_segment_offset (segment_info
*s
, HOST_WIDE_INT offset
)
1051 for (; s
; s
= s
->next
)
1052 s
->offset
+= offset
;
1056 /* Lay out a symbol in a common block. If the symbol has already been seen
1057 then check the location is consistent. Otherwise create segments
1058 for that symbol and all the symbols equivalenced with it. */
1060 /* Translate a single common block. */
1063 translate_common (gfc_common_head
*common
, gfc_symbol
*var_list
)
1067 segment_info
*common_segment
;
1068 HOST_WIDE_INT offset
;
1069 HOST_WIDE_INT current_offset
;
1070 unsigned HOST_WIDE_INT align
;
1073 common_segment
= NULL
;
1079 /* Add symbols to the segment. */
1080 for (sym
= var_list
; sym
; sym
= sym
->common_next
)
1082 current_segment
= common_segment
;
1083 s
= find_segment_info (sym
);
1085 /* Symbol has already been added via an equivalence. Multiple
1086 use associations of the same common block result in equiv_built
1087 being set but no information about the symbol in the segment. */
1088 if (s
&& sym
->equiv_built
)
1090 /* Ensure the current location is properly aligned. */
1091 align
= TYPE_ALIGN_UNIT (s
->field
);
1092 current_offset
= (current_offset
+ align
- 1) &~ (align
- 1);
1094 /* Verify that it ended up where we expect it. */
1095 if (s
->offset
!= current_offset
)
1097 gfc_error ("Equivalence for '%s' does not match ordering of "
1098 "COMMON '%s' at %L", sym
->name
,
1099 common
->name
, &common
->where
);
1104 /* A symbol we haven't seen before. */
1105 s
= current_segment
= get_segment_info (sym
, current_offset
);
1107 /* Add all objects directly or indirectly equivalenced with this
1109 add_equivalences (&saw_equiv
);
1111 if (current_segment
->offset
< 0)
1112 gfc_error ("The equivalence set for '%s' cause an invalid "
1113 "extension to COMMON '%s' at %L", sym
->name
,
1114 common
->name
, &common
->where
);
1116 if (gfc_option
.flag_align_commons
)
1117 offset
= align_segment (&align
);
1121 /* The required offset conflicts with previous alignment
1122 requirements. Insert padding immediately before this
1124 if (gfc_option
.warn_align_commons
)
1126 if (strcmp (common
->name
, BLANK_COMMON_NAME
))
1127 gfc_warning ("Padding of %d bytes required before '%s' in "
1128 "COMMON '%s' at %L; reorder elements or use "
1129 "-fno-align-commons", (int)offset
,
1130 s
->sym
->name
, common
->name
, &common
->where
);
1132 gfc_warning ("Padding of %d bytes required before '%s' in "
1133 "COMMON at %L; reorder elements or use "
1134 "-fno-align-commons", (int)offset
,
1135 s
->sym
->name
, &common
->where
);
1139 /* Apply the offset to the new segments. */
1140 apply_segment_offset (current_segment
, offset
);
1141 current_offset
+= offset
;
1143 /* Add the new segments to the common block. */
1144 common_segment
= add_segments (common_segment
, current_segment
);
1147 /* The offset of the next common variable. */
1148 current_offset
+= s
->length
;
1151 if (common_segment
== NULL
)
1153 gfc_error ("COMMON '%s' at %L does not exist",
1154 common
->name
, &common
->where
);
1158 if (common_segment
->offset
!= 0 && gfc_option
.warn_align_commons
)
1160 if (strcmp (common
->name
, BLANK_COMMON_NAME
))
1161 gfc_warning ("COMMON '%s' at %L requires %d bytes of padding; "
1162 "reorder elements or use -fno-align-commons",
1163 common
->name
, &common
->where
, (int)common_segment
->offset
);
1165 gfc_warning ("COMMON at %L requires %d bytes of padding; "
1166 "reorder elements or use -fno-align-commons",
1167 &common
->where
, (int)common_segment
->offset
);
1170 create_common (common
, common_segment
, saw_equiv
);
1174 /* Create a new block for each merged equivalence list. */
1177 finish_equivalences (gfc_namespace
*ns
)
1181 gfc_common_head
* c
;
1182 HOST_WIDE_INT offset
;
1183 unsigned HOST_WIDE_INT align
;
1186 for (z
= ns
->equiv
; z
; z
= z
->next
)
1187 for (y
= z
->eq
; y
; y
= y
->eq
)
1191 sym
= z
->expr
->symtree
->n
.sym
;
1192 current_segment
= get_segment_info (sym
, 0);
1194 /* All objects directly or indirectly equivalenced with this
1196 add_equivalences (&dummy
);
1198 /* Align the block. */
1199 offset
= align_segment (&align
);
1201 /* Ensure all offsets are positive. */
1202 offset
-= current_segment
->offset
& ~(align
- 1);
1204 apply_segment_offset (current_segment
, offset
);
1206 /* Create the decl. If this is a module equivalence, it has a
1207 unique name, pointed to by z->module. This is written to a
1208 gfc_common_header to push create_common into using
1209 build_common_decl, so that the equivalence appears as an
1210 external symbol. Otherwise, a local declaration is built using
1211 build_equiv_decl. */
1214 c
= gfc_get_common_head ();
1215 /* We've lost the real location, so use the location of the
1216 enclosing procedure. */
1217 c
->where
= ns
->proc_name
->declared_at
;
1218 strcpy (c
->name
, z
->module
);
1223 create_common (c
, current_segment
, true);
1229 /* Work function for translating a named common block. */
1232 named_common (gfc_symtree
*st
)
1234 translate_common (st
->n
.common
, st
->n
.common
->head
);
1238 /* Translate the common blocks in a namespace. Unlike other variables,
1239 these have to be created before code, because the backend_decl depends
1240 on the rest of the common block. */
1243 gfc_trans_common (gfc_namespace
*ns
)
1247 /* Translate the blank common block. */
1248 if (ns
->blank_common
.head
!= NULL
)
1250 c
= gfc_get_common_head ();
1251 c
->where
= ns
->blank_common
.head
->common_head
->where
;
1252 strcpy (c
->name
, BLANK_COMMON_NAME
);
1253 translate_common (c
, ns
->blank_common
.head
);
1256 /* Translate all named common blocks. */
1257 gfc_traverse_symtree (ns
->common_root
, named_common
);
1259 /* Translate local equivalence. */
1260 finish_equivalences (ns
);
1262 /* Commit the newly created symbols for common blocks and module
1264 gfc_commit_symbols ();