1 /* Common block and equivalence list handling
2 Copyright (C) 2000, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Canqun Yang <canqun@nudt.edu.cn>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* The core algorithm is based on Andy Vaught's g95 tree. Also the
23 way to build UNION_TYPE is borrowed from Richard Henderson.
25 Transform common blocks. An integral part of this is processing
26 equivalence variables. Equivalenced variables that are not in a
27 common block end up in a private block of their own.
29 Each common block or local equivalence list is declared as a union.
30 Variables within the block are represented as a field within the
31 block with the proper offset.
33 So if two variables are equivalenced, they just point to a common
36 Mathematically, laying out an equivalence block is equivalent to
37 solving a linear system of equations. The matrix is usually a
38 sparse matrix in which each row contains all zero elements except
39 for a +1 and a -1, a sort of a generalized Vandermonde matrix. The
40 matrix is usually block diagonal. The system can be
41 overdetermined, underdetermined or have a unique solution. If the
42 system is inconsistent, the program is not standard conforming.
43 The solution vector is integral, since all of the pivots are +1 or -1.
45 How we lay out an equivalence block is a little less complicated.
46 In an equivalence list with n elements, there are n-1 conditions to
47 be satisfied. The conditions partition the variables into what we
48 will call segments. If A and B are equivalenced then A and B are
49 in the same segment. If B and C are equivalenced as well, then A,
50 B and C are in a segment and so on. Each segment is a block of
51 memory that has one or more variables equivalenced in some way. A
52 common block is made up of a series of segments that are joined one
53 after the other. In the linear system, a segment is a block
56 To lay out a segment we first start with some variable and
57 determine its length. The first variable is assumed to start at
58 offset one and extends to however long it is. We then traverse the
59 list of equivalences to find an unused condition that involves at
60 least one of the variables currently in the segment.
62 Each equivalence condition amounts to the condition B+b=C+c where B
63 and C are the offsets of the B and C variables, and b and c are
64 constants which are nonzero for array elements, substrings or
65 structure components. So for
67 EQUIVALENCE(B(2), C(3))
69 B + 2*size of B's elements = C + 3*size of C's elements.
71 If B and C are known we check to see if the condition already
72 holds. If B is known we can solve for C. Since we know the length
73 of C, we can see if the minimum and maximum extents of the segment
74 are affected. Eventually, we make a full pass through the
75 equivalence list without finding any new conditions and the segment
78 At this point, the segment is added to the current common block.
79 Since we know the minimum extent of the segment, everything in the
80 segment is translated to its position in the common block. The
81 usual case here is that there are no equivalence statements and the
82 common block is series of segments with one variable each, which is
83 a diagonal matrix in the matrix formulation.
85 Each segment is described by a chain of segment_info structures. Each
86 segment_info structure describes the extents of a single variable within
87 the segment. This list is maintained in the order the elements are
88 positioned withing the segment. If two elements have the same starting
89 offset the smaller will come first. If they also have the same size their
90 ordering is undefined.
92 Once all common blocks have been created, the list of equivalences
93 is examined for still-unused equivalence conditions. We create a
94 block for each merged equivalence list. */
98 #include "coretypes.h"
101 #include "output.h" /* For decl_default_tls_model. */
102 #include "gfortran.h"
104 #include "trans-types.h"
105 #include "trans-const.h"
106 #include "target-memory.h"
109 /* Holds a single variable in an equivalence set. */
110 typedef struct segment_info
113 HOST_WIDE_INT offset
;
114 HOST_WIDE_INT length
;
115 /* This will contain the field type until the field is created. */
117 struct segment_info
*next
;
120 static segment_info
* current_segment
;
121 static gfc_namespace
*gfc_common_ns
= NULL
;
124 /* Make a segment_info based on a symbol. */
126 static segment_info
*
127 get_segment_info (gfc_symbol
* sym
, HOST_WIDE_INT offset
)
131 /* Make sure we've got the character length. */
132 if (sym
->ts
.type
== BT_CHARACTER
)
133 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
135 /* Create the segment_info and fill it in. */
136 s
= XCNEW (segment_info
);
138 /* We will use this type when building the segment aggregate type. */
139 s
->field
= gfc_sym_type (sym
);
140 s
->length
= int_size_in_bytes (s
->field
);
147 /* Add a copy of a segment list to the namespace. This is specifically for
148 equivalence segments, so that dependency checking can be done on
149 equivalence group members. */
152 copy_equiv_list_to_ns (segment_info
*c
)
158 l
= XCNEW (gfc_equiv_list
);
160 l
->next
= c
->sym
->ns
->equiv_lists
;
161 c
->sym
->ns
->equiv_lists
= l
;
163 for (f
= c
; f
; f
= f
->next
)
165 s
= XCNEW (gfc_equiv_info
);
169 s
->offset
= f
->offset
;
170 s
->length
= f
->length
;
175 /* Add combine segment V and segment LIST. */
177 static segment_info
*
178 add_segments (segment_info
*list
, segment_info
*v
)
189 /* Find the location of the new element. */
192 if (v
->offset
< s
->offset
)
194 if (v
->offset
== s
->offset
195 && v
->length
<= s
->length
)
202 /* Insert the new element in between p and s. */
218 /* Construct mangled common block name from symbol name. */
220 /* We need the bind(c) flag to tell us how/if we should mangle the symbol
221 name. There are few calls to this function, so few places that this
222 would need to be added. At the moment, there is only one call, in
223 build_common_decl(). We can't attempt to look up the common block
224 because we may be building it for the first time and therefore, it won't
225 be in the common_root. We also need the binding label, if it's bind(c).
226 Therefore, send in the pointer to the common block, so whatever info we
227 have so far can be used. All of the necessary info should be available
228 in the gfc_common_head by now, so it should be accurate to test the
229 isBindC flag and use the binding label given if it is bind(c).
231 We may NOT know yet if it's bind(c) or not, but we can try at least.
232 Will have to figure out what to do later if it's labeled bind(c)
233 after this is called. */
236 gfc_sym_mangled_common_id (gfc_common_head
*com
)
239 char mangled_name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 1];
240 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
242 /* Get the name out of the common block pointer. */
243 strcpy (name
, com
->name
);
245 /* If we're suppose to do a bind(c). */
246 if (com
->is_bind_c
== 1 && com
->binding_label
[0] != '\0')
247 return get_identifier (com
->binding_label
);
249 if (strcmp (name
, BLANK_COMMON_NAME
) == 0)
250 return get_identifier (name
);
252 if (gfc_option
.flag_underscoring
)
254 has_underscore
= strchr (name
, '_') != 0;
255 if (gfc_option
.flag_second_underscore
&& has_underscore
)
256 snprintf (mangled_name
, sizeof mangled_name
, "%s__", name
);
258 snprintf (mangled_name
, sizeof mangled_name
, "%s_", name
);
260 return get_identifier (mangled_name
);
263 return get_identifier (name
);
267 /* Build a field declaration for a common variable or a local equivalence
271 build_field (segment_info
*h
, tree union_type
, record_layout_info rli
)
275 HOST_WIDE_INT offset
= h
->offset
;
276 unsigned HOST_WIDE_INT desired_align
, known_align
;
278 name
= get_identifier (h
->sym
->name
);
279 field
= build_decl (h
->sym
->declared_at
.lb
->location
,
280 FIELD_DECL
, name
, h
->field
);
281 known_align
= (offset
& -offset
) * BITS_PER_UNIT
;
282 if (known_align
== 0 || known_align
> BIGGEST_ALIGNMENT
)
283 known_align
= BIGGEST_ALIGNMENT
;
285 desired_align
= update_alignment_for_field (rli
, field
, known_align
);
286 if (desired_align
> known_align
)
287 DECL_PACKED (field
) = 1;
289 DECL_FIELD_CONTEXT (field
) = union_type
;
290 DECL_FIELD_OFFSET (field
) = size_int (offset
);
291 DECL_FIELD_BIT_OFFSET (field
) = bitsize_zero_node
;
292 SET_DECL_OFFSET_ALIGN (field
, known_align
);
294 rli
->offset
= size_binop (MAX_EXPR
, rli
->offset
,
295 size_binop (PLUS_EXPR
,
296 DECL_FIELD_OFFSET (field
),
297 DECL_SIZE_UNIT (field
)));
298 /* If this field is assigned to a label, we create another two variables.
299 One will hold the address of target label or format label. The other will
300 hold the length of format label string. */
301 if (h
->sym
->attr
.assign
)
306 gfc_allocate_lang_decl (field
);
307 GFC_DECL_ASSIGN (field
) = 1;
308 len
= gfc_create_var_np (gfc_charlen_type_node
,h
->sym
->name
);
309 addr
= gfc_create_var_np (pvoid_type_node
, h
->sym
->name
);
310 TREE_STATIC (len
) = 1;
311 TREE_STATIC (addr
) = 1;
312 DECL_INITIAL (len
) = build_int_cst (gfc_charlen_type_node
, -2);
313 gfc_set_decl_location (len
, &h
->sym
->declared_at
);
314 gfc_set_decl_location (addr
, &h
->sym
->declared_at
);
315 GFC_DECL_STRING_LEN (field
) = pushdecl_top_level (len
);
316 GFC_DECL_ASSIGN_ADDR (field
) = pushdecl_top_level (addr
);
319 /* If this field is volatile, mark it. */
320 if (h
->sym
->attr
.volatile_
)
323 TREE_THIS_VOLATILE (field
) = 1;
324 TREE_SIDE_EFFECTS (field
) = 1;
325 new_type
= build_qualified_type (TREE_TYPE (field
), TYPE_QUAL_VOLATILE
);
326 TREE_TYPE (field
) = new_type
;
333 /* Get storage for local equivalence. */
336 build_equiv_decl (tree union_type
, bool is_init
, bool is_saved
)
340 static int serial
= 0;
344 decl
= gfc_create_var (union_type
, "equiv");
345 TREE_STATIC (decl
) = 1;
346 GFC_DECL_COMMON_OR_EQUIV (decl
) = 1;
350 snprintf (name
, sizeof (name
), "equiv.%d", serial
++);
351 decl
= build_decl (input_location
,
352 VAR_DECL
, get_identifier (name
), union_type
);
353 DECL_ARTIFICIAL (decl
) = 1;
354 DECL_IGNORED_P (decl
) = 1;
356 if (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl
))
358 TREE_STATIC (decl
) = 1;
360 TREE_ADDRESSABLE (decl
) = 1;
361 TREE_USED (decl
) = 1;
362 GFC_DECL_COMMON_OR_EQUIV (decl
) = 1;
364 /* The source location has been lost, and doesn't really matter.
365 We need to set it to something though. */
366 gfc_set_decl_location (decl
, &gfc_current_locus
);
368 gfc_add_decl_to_function (decl
);
374 /* Get storage for common block. */
377 build_common_decl (gfc_common_head
*com
, tree union_type
, bool is_init
)
379 gfc_symbol
*common_sym
;
382 /* Create a namespace to store symbols for common blocks. */
383 if (gfc_common_ns
== NULL
)
384 gfc_common_ns
= gfc_get_namespace (NULL
, 0);
386 gfc_get_symbol (com
->name
, gfc_common_ns
, &common_sym
);
387 decl
= common_sym
->backend_decl
;
389 /* Update the size of this common block as needed. */
390 if (decl
!= NULL_TREE
)
392 tree size
= TYPE_SIZE_UNIT (union_type
);
394 /* Named common blocks of the same name shall be of the same size
395 in all scoping units of a program in which they appear, but
396 blank common blocks may be of different sizes. */
397 if (!tree_int_cst_equal (DECL_SIZE_UNIT (decl
), size
)
398 && strcmp (com
->name
, BLANK_COMMON_NAME
))
399 gfc_warning ("Named COMMON block '%s' at %L shall be of the "
400 "same size as elsewhere (%lu vs %lu bytes)", com
->name
,
402 (unsigned long) TREE_INT_CST_LOW (size
),
403 (unsigned long) TREE_INT_CST_LOW (DECL_SIZE_UNIT (decl
)));
405 if (tree_int_cst_lt (DECL_SIZE_UNIT (decl
), size
))
407 DECL_SIZE (decl
) = TYPE_SIZE (union_type
);
408 DECL_SIZE_UNIT (decl
) = size
;
409 DECL_MODE (decl
) = TYPE_MODE (union_type
);
410 TREE_TYPE (decl
) = union_type
;
411 layout_decl (decl
, 0);
415 /* If this common block has been declared in a previous program unit,
416 and either it is already initialized or there is no new initialization
417 for it, just return. */
418 if ((decl
!= NULL_TREE
) && (!is_init
|| DECL_INITIAL (decl
)))
421 /* If there is no backend_decl for the common block, build it. */
422 if (decl
== NULL_TREE
)
424 decl
= build_decl (input_location
,
425 VAR_DECL
, get_identifier (com
->name
), union_type
);
426 gfc_set_decl_assembler_name (decl
, gfc_sym_mangled_common_id (com
));
427 TREE_PUBLIC (decl
) = 1;
428 TREE_STATIC (decl
) = 1;
429 DECL_IGNORED_P (decl
) = 1;
431 DECL_ALIGN (decl
) = BIGGEST_ALIGNMENT
;
434 /* Do not set the alignment for bind(c) common blocks to
435 BIGGEST_ALIGNMENT because that won't match what C does. Also,
436 for common blocks with one element, the alignment must be
437 that of the field within the common block in order to match
439 tree field
= NULL_TREE
;
440 field
= TYPE_FIELDS (TREE_TYPE (decl
));
441 if (DECL_CHAIN (field
) == NULL_TREE
)
442 DECL_ALIGN (decl
) = TYPE_ALIGN (TREE_TYPE (field
));
444 DECL_USER_ALIGN (decl
) = 0;
445 GFC_DECL_COMMON_OR_EQUIV (decl
) = 1;
447 gfc_set_decl_location (decl
, &com
->where
);
449 if (com
->threadprivate
)
450 DECL_TLS_MODEL (decl
) = decl_default_tls_model (decl
);
452 /* Place the back end declaration for this common block in
453 GLOBAL_BINDING_LEVEL. */
454 common_sym
->backend_decl
= pushdecl_top_level (decl
);
457 /* Has no initial values. */
460 DECL_INITIAL (decl
) = NULL_TREE
;
461 DECL_COMMON (decl
) = 1;
462 DECL_DEFER_OUTPUT (decl
) = 1;
466 DECL_INITIAL (decl
) = error_mark_node
;
467 DECL_COMMON (decl
) = 0;
468 DECL_DEFER_OUTPUT (decl
) = 0;
474 /* Return a field that is the size of the union, if an equivalence has
475 overlapping initializers. Merge the initializers into a single
476 initializer for this new field, then free the old ones. */
479 get_init_field (segment_info
*head
, tree union_type
, tree
*field_init
,
480 record_layout_info rli
)
483 HOST_WIDE_INT length
= 0;
484 HOST_WIDE_INT offset
= 0;
485 unsigned HOST_WIDE_INT known_align
, desired_align
;
486 bool overlap
= false;
489 unsigned char *data
, *chk
;
490 VEC(constructor_elt
,gc
) *v
= NULL
;
492 tree type
= unsigned_char_type_node
;
495 /* Obtain the size of the union and check if there are any overlapping
497 for (s
= head
; s
; s
= s
->next
)
499 HOST_WIDE_INT slen
= s
->offset
+ s
->length
;
502 if (s
->offset
< offset
)
506 length
= length
< slen
? slen
: length
;
512 /* Now absorb all the initializer data into a single vector,
513 whilst checking for overlapping, unequal values. */
514 data
= XCNEWVEC (unsigned char, (size_t)length
);
515 chk
= XCNEWVEC (unsigned char, (size_t)length
);
517 /* TODO - change this when default initialization is implemented. */
518 memset (data
, '\0', (size_t)length
);
519 memset (chk
, '\0', (size_t)length
);
520 for (s
= head
; s
; s
= s
->next
)
522 gfc_merge_initializers (s
->sym
->ts
, s
->sym
->value
,
527 for (i
= 0; i
< length
; i
++)
528 CONSTRUCTOR_APPEND_ELT (v
, NULL
, build_int_cst (type
, data
[i
]));
533 /* Build a char[length] array to hold the initializers. Much of what
534 follows is borrowed from build_field, above. */
536 tmp
= build_int_cst (gfc_array_index_type
, length
- 1);
537 tmp
= build_range_type (gfc_array_index_type
,
538 gfc_index_zero_node
, tmp
);
539 tmp
= build_array_type (type
, tmp
);
540 field
= build_decl (gfc_current_locus
.lb
->location
,
541 FIELD_DECL
, NULL_TREE
, tmp
);
543 known_align
= BIGGEST_ALIGNMENT
;
545 desired_align
= update_alignment_for_field (rli
, field
, known_align
);
546 if (desired_align
> known_align
)
547 DECL_PACKED (field
) = 1;
549 DECL_FIELD_CONTEXT (field
) = union_type
;
550 DECL_FIELD_OFFSET (field
) = size_int (0);
551 DECL_FIELD_BIT_OFFSET (field
) = bitsize_zero_node
;
552 SET_DECL_OFFSET_ALIGN (field
, known_align
);
554 rli
->offset
= size_binop (MAX_EXPR
, rli
->offset
,
555 size_binop (PLUS_EXPR
,
556 DECL_FIELD_OFFSET (field
),
557 DECL_SIZE_UNIT (field
)));
559 init
= build_constructor (TREE_TYPE (field
), v
);
560 TREE_CONSTANT (init
) = 1;
564 for (s
= head
; s
; s
= s
->next
)
566 if (s
->sym
->value
== NULL
)
569 gfc_free_expr (s
->sym
->value
);
570 s
->sym
->value
= NULL
;
577 /* Declare memory for the common block or local equivalence, and create
578 backend declarations for all of the elements. */
581 create_common (gfc_common_head
*com
, segment_info
*head
, bool saw_equiv
)
583 segment_info
*s
, *next_s
;
587 tree field_init
= NULL_TREE
;
588 record_layout_info rli
;
590 bool is_init
= false;
591 bool is_saved
= false;
593 /* Declare the variables inside the common block.
594 If the current common block contains any equivalence object, then
595 make a UNION_TYPE node, otherwise RECORD_TYPE. This will let the
596 alias analyzer work well when there is no address overlapping for
597 common variables in the current common block. */
599 union_type
= make_node (UNION_TYPE
);
601 union_type
= make_node (RECORD_TYPE
);
603 rli
= start_record_layout (union_type
);
604 field_link
= &TYPE_FIELDS (union_type
);
606 /* Check for overlapping initializers and replace them with a single,
607 artificial field that contains all the data. */
609 field
= get_init_field (head
, union_type
, &field_init
, rli
);
613 if (field
!= NULL_TREE
)
617 field_link
= &DECL_CHAIN (field
);
620 for (s
= head
; s
; s
= s
->next
)
622 build_field (s
, union_type
, rli
);
624 /* Link the field into the type. */
625 *field_link
= s
->field
;
626 field_link
= &DECL_CHAIN (s
->field
);
628 /* Has initial value. */
632 /* Has SAVE attribute. */
633 if (s
->sym
->attr
.save
)
637 finish_record_layout (rli
, true);
640 decl
= build_common_decl (com
, union_type
, is_init
);
642 decl
= build_equiv_decl (union_type
, is_init
, is_saved
);
647 VEC(constructor_elt
,gc
) *v
= NULL
;
649 if (field
!= NULL_TREE
&& field_init
!= NULL_TREE
)
650 CONSTRUCTOR_APPEND_ELT (v
, field
, field_init
);
652 for (s
= head
; s
; s
= s
->next
)
656 /* Add the initializer for this field. */
657 tmp
= gfc_conv_initializer (s
->sym
->value
, &s
->sym
->ts
,
658 TREE_TYPE (s
->field
),
659 s
->sym
->attr
.dimension
,
661 || s
->sym
->attr
.allocatable
, false);
663 CONSTRUCTOR_APPEND_ELT (v
, s
->field
, tmp
);
667 gcc_assert (!VEC_empty (constructor_elt
, v
));
668 ctor
= build_constructor (union_type
, v
);
669 TREE_CONSTANT (ctor
) = 1;
670 TREE_STATIC (ctor
) = 1;
671 DECL_INITIAL (decl
) = ctor
;
673 #ifdef ENABLE_CHECKING
676 unsigned HOST_WIDE_INT idx
;
677 FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor
), idx
, field
, value
)
678 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
683 /* Build component reference for each variable. */
684 for (s
= head
; s
; s
= next_s
)
688 var_decl
= build_decl (s
->sym
->declared_at
.lb
->location
,
689 VAR_DECL
, DECL_NAME (s
->field
),
690 TREE_TYPE (s
->field
));
691 TREE_STATIC (var_decl
) = TREE_STATIC (decl
);
692 TREE_USED (var_decl
) = TREE_USED (decl
);
693 if (s
->sym
->attr
.use_assoc
)
694 DECL_IGNORED_P (var_decl
) = 1;
695 if (s
->sym
->attr
.target
)
696 TREE_ADDRESSABLE (var_decl
) = 1;
697 /* This is a fake variable just for debugging purposes. */
698 TREE_ASM_WRITTEN (var_decl
) = 1;
699 /* Fake variables are not visible from other translation units. */
700 TREE_PUBLIC (var_decl
) = 0;
702 /* To preserve identifier names in COMMON, chain to procedure
703 scope unless at top level in a module definition. */
705 && s
->sym
->ns
->proc_name
706 && s
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
707 var_decl
= pushdecl_top_level (var_decl
);
709 gfc_add_decl_to_function (var_decl
);
711 SET_DECL_VALUE_EXPR (var_decl
,
712 fold_build3_loc (input_location
, COMPONENT_REF
,
713 TREE_TYPE (s
->field
),
714 decl
, s
->field
, NULL_TREE
));
715 DECL_HAS_VALUE_EXPR_P (var_decl
) = 1;
716 GFC_DECL_COMMON_OR_EQUIV (var_decl
) = 1;
718 if (s
->sym
->attr
.assign
)
720 gfc_allocate_lang_decl (var_decl
);
721 GFC_DECL_ASSIGN (var_decl
) = 1;
722 GFC_DECL_STRING_LEN (var_decl
) = GFC_DECL_STRING_LEN (s
->field
);
723 GFC_DECL_ASSIGN_ADDR (var_decl
) = GFC_DECL_ASSIGN_ADDR (s
->field
);
726 s
->sym
->backend_decl
= var_decl
;
734 /* Given a symbol, find it in the current segment list. Returns NULL if
737 static segment_info
*
738 find_segment_info (gfc_symbol
*symbol
)
742 for (n
= current_segment
; n
; n
= n
->next
)
744 if (n
->sym
== symbol
)
752 /* Given an expression node, make sure it is a constant integer and return
756 get_mpz (gfc_expr
*e
)
759 if (e
->expr_type
!= EXPR_CONSTANT
)
760 gfc_internal_error ("get_mpz(): Not an integer constant");
762 return &e
->value
.integer
;
766 /* Given an array specification and an array reference, figure out the
767 array element number (zero based). Bounds and elements are guaranteed
768 to be constants. If something goes wrong we generate an error and
772 element_number (gfc_array_ref
*ar
)
774 mpz_t multiplier
, offset
, extent
, n
;
776 HOST_WIDE_INT i
, rank
;
780 mpz_init_set_ui (multiplier
, 1);
781 mpz_init_set_ui (offset
, 0);
785 for (i
= 0; i
< rank
; i
++)
787 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
788 gfc_internal_error ("element_number(): Bad dimension type");
790 mpz_sub (n
, *get_mpz (ar
->start
[i
]), *get_mpz (as
->lower
[i
]));
792 mpz_mul (n
, n
, multiplier
);
793 mpz_add (offset
, offset
, n
);
795 mpz_sub (extent
, *get_mpz (as
->upper
[i
]), *get_mpz (as
->lower
[i
]));
796 mpz_add_ui (extent
, extent
, 1);
798 if (mpz_sgn (extent
) < 0)
799 mpz_set_ui (extent
, 0);
801 mpz_mul (multiplier
, multiplier
, extent
);
804 i
= mpz_get_ui (offset
);
806 mpz_clear (multiplier
);
815 /* Given a single element of an equivalence list, figure out the offset
816 from the base symbol. For simple variables or full arrays, this is
817 simply zero. For an array element we have to calculate the array
818 element number and multiply by the element size. For a substring we
819 have to calculate the further reference. */
822 calculate_offset (gfc_expr
*e
)
824 HOST_WIDE_INT n
, element_size
, offset
;
825 gfc_typespec
*element_type
;
829 element_type
= &e
->symtree
->n
.sym
->ts
;
831 for (reference
= e
->ref
; reference
; reference
= reference
->next
)
832 switch (reference
->type
)
835 switch (reference
->u
.ar
.type
)
841 n
= element_number (&reference
->u
.ar
);
842 if (element_type
->type
== BT_CHARACTER
)
843 gfc_conv_const_charlen (element_type
->u
.cl
);
845 int_size_in_bytes (gfc_typenode_for_spec (element_type
));
846 offset
+= n
* element_size
;
850 gfc_error ("Bad array reference at %L", &e
->where
);
854 if (reference
->u
.ss
.start
!= NULL
)
855 offset
+= mpz_get_ui (*get_mpz (reference
->u
.ss
.start
)) - 1;
858 gfc_error ("Illegal reference type at %L as EQUIVALENCE object",
865 /* Add a new segment_info structure to the current segment. eq1 is already
866 in the list, eq2 is not. */
869 new_condition (segment_info
*v
, gfc_equiv
*eq1
, gfc_equiv
*eq2
)
871 HOST_WIDE_INT offset1
, offset2
;
874 offset1
= calculate_offset (eq1
->expr
);
875 offset2
= calculate_offset (eq2
->expr
);
877 a
= get_segment_info (eq2
->expr
->symtree
->n
.sym
,
878 v
->offset
+ offset1
- offset2
);
880 current_segment
= add_segments (current_segment
, a
);
884 /* Given two equivalence structures that are both already in the list, make
885 sure that this new condition is not violated, generating an error if it
889 confirm_condition (segment_info
*s1
, gfc_equiv
*eq1
, segment_info
*s2
,
892 HOST_WIDE_INT offset1
, offset2
;
894 offset1
= calculate_offset (eq1
->expr
);
895 offset2
= calculate_offset (eq2
->expr
);
897 if (s1
->offset
+ offset1
!= s2
->offset
+ offset2
)
898 gfc_error ("Inconsistent equivalence rules involving '%s' at %L and "
899 "'%s' at %L", s1
->sym
->name
, &s1
->sym
->declared_at
,
900 s2
->sym
->name
, &s2
->sym
->declared_at
);
904 /* Process a new equivalence condition. eq1 is know to be in segment f.
905 If eq2 is also present then confirm that the condition holds.
906 Otherwise add a new variable to the segment list. */
909 add_condition (segment_info
*f
, gfc_equiv
*eq1
, gfc_equiv
*eq2
)
913 n
= find_segment_info (eq2
->expr
->symtree
->n
.sym
);
916 new_condition (f
, eq1
, eq2
);
918 confirm_condition (f
, eq1
, n
, eq2
);
922 /* Given a segment element, search through the equivalence lists for unused
923 conditions that involve the symbol. Add these rules to the segment. */
926 find_equivalence (segment_info
*n
)
928 gfc_equiv
*e1
, *e2
, *eq
;
933 for (e1
= n
->sym
->ns
->equiv
; e1
; e1
= e1
->next
)
937 /* Search the equivalence list, including the root (first) element
938 for the symbol that owns the segment. */
939 for (e2
= e1
; e2
; e2
= e2
->eq
)
941 if (!e2
->used
&& e2
->expr
->symtree
->n
.sym
== n
->sym
)
948 /* Go to the next root element. */
954 /* Now traverse the equivalence list matching the offsets. */
955 for (e2
= e1
; e2
; e2
= e2
->eq
)
957 if (!e2
->used
&& e2
!= eq
)
959 add_condition (n
, eq
, e2
);
969 /* Add all symbols equivalenced within a segment. We need to scan the
970 segment list multiple times to include indirect equivalences. Since
971 a new segment_info can inserted at the beginning of the segment list,
972 depending on its offset, we have to force a final pass through the
973 loop by demanding that completion sees a pass with no matches; i.e.,
974 all symbols with equiv_built set and no new equivalences found. */
977 add_equivalences (bool *saw_equiv
)
987 for (f
= current_segment
; f
; f
= f
->next
)
989 if (!f
->sym
->equiv_built
)
991 f
->sym
->equiv_built
= 1;
992 seen_one
= find_equivalence (f
);
1002 /* Add a copy of this segment list to the namespace. */
1003 copy_equiv_list_to_ns (current_segment
);
1007 /* Returns the offset necessary to properly align the current equivalence.
1008 Sets *palign to the required alignment. */
1010 static HOST_WIDE_INT
1011 align_segment (unsigned HOST_WIDE_INT
*palign
)
1014 unsigned HOST_WIDE_INT offset
;
1015 unsigned HOST_WIDE_INT max_align
;
1016 unsigned HOST_WIDE_INT this_align
;
1017 unsigned HOST_WIDE_INT this_offset
;
1021 for (s
= current_segment
; s
; s
= s
->next
)
1023 this_align
= TYPE_ALIGN_UNIT (s
->field
);
1024 if (s
->offset
& (this_align
- 1))
1026 /* Field is misaligned. */
1027 this_offset
= this_align
- ((s
->offset
+ offset
) & (this_align
- 1));
1028 if (this_offset
& (max_align
- 1))
1030 /* Aligning this field would misalign a previous field. */
1031 gfc_error ("The equivalence set for variable '%s' "
1032 "declared at %L violates alignment requirements",
1033 s
->sym
->name
, &s
->sym
->declared_at
);
1035 offset
+= this_offset
;
1037 max_align
= this_align
;
1040 *palign
= max_align
;
1045 /* Adjust segment offsets by the given amount. */
1048 apply_segment_offset (segment_info
*s
, HOST_WIDE_INT offset
)
1050 for (; s
; s
= s
->next
)
1051 s
->offset
+= offset
;
1055 /* Lay out a symbol in a common block. If the symbol has already been seen
1056 then check the location is consistent. Otherwise create segments
1057 for that symbol and all the symbols equivalenced with it. */
1059 /* Translate a single common block. */
1062 translate_common (gfc_common_head
*common
, gfc_symbol
*var_list
)
1066 segment_info
*common_segment
;
1067 HOST_WIDE_INT offset
;
1068 HOST_WIDE_INT current_offset
;
1069 unsigned HOST_WIDE_INT align
;
1072 common_segment
= NULL
;
1078 /* Add symbols to the segment. */
1079 for (sym
= var_list
; sym
; sym
= sym
->common_next
)
1081 current_segment
= common_segment
;
1082 s
= find_segment_info (sym
);
1084 /* Symbol has already been added via an equivalence. Multiple
1085 use associations of the same common block result in equiv_built
1086 being set but no information about the symbol in the segment. */
1087 if (s
&& sym
->equiv_built
)
1089 /* Ensure the current location is properly aligned. */
1090 align
= TYPE_ALIGN_UNIT (s
->field
);
1091 current_offset
= (current_offset
+ align
- 1) &~ (align
- 1);
1093 /* Verify that it ended up where we expect it. */
1094 if (s
->offset
!= current_offset
)
1096 gfc_error ("Equivalence for '%s' does not match ordering of "
1097 "COMMON '%s' at %L", sym
->name
,
1098 common
->name
, &common
->where
);
1103 /* A symbol we haven't seen before. */
1104 s
= current_segment
= get_segment_info (sym
, current_offset
);
1106 /* Add all objects directly or indirectly equivalenced with this
1108 add_equivalences (&saw_equiv
);
1110 if (current_segment
->offset
< 0)
1111 gfc_error ("The equivalence set for '%s' cause an invalid "
1112 "extension to COMMON '%s' at %L", sym
->name
,
1113 common
->name
, &common
->where
);
1115 if (gfc_option
.flag_align_commons
)
1116 offset
= align_segment (&align
);
1120 /* The required offset conflicts with previous alignment
1121 requirements. Insert padding immediately before this
1123 if (gfc_option
.warn_align_commons
)
1125 if (strcmp (common
->name
, BLANK_COMMON_NAME
))
1126 gfc_warning ("Padding of %d bytes required before '%s' in "
1127 "COMMON '%s' at %L; reorder elements or use "
1128 "-fno-align-commons", (int)offset
,
1129 s
->sym
->name
, common
->name
, &common
->where
);
1131 gfc_warning ("Padding of %d bytes required before '%s' in "
1132 "COMMON at %L; reorder elements or use "
1133 "-fno-align-commons", (int)offset
,
1134 s
->sym
->name
, &common
->where
);
1138 /* Apply the offset to the new segments. */
1139 apply_segment_offset (current_segment
, offset
);
1140 current_offset
+= offset
;
1142 /* Add the new segments to the common block. */
1143 common_segment
= add_segments (common_segment
, current_segment
);
1146 /* The offset of the next common variable. */
1147 current_offset
+= s
->length
;
1150 if (common_segment
== NULL
)
1152 gfc_error ("COMMON '%s' at %L does not exist",
1153 common
->name
, &common
->where
);
1157 if (common_segment
->offset
!= 0 && gfc_option
.warn_align_commons
)
1159 if (strcmp (common
->name
, BLANK_COMMON_NAME
))
1160 gfc_warning ("COMMON '%s' at %L requires %d bytes of padding; "
1161 "reorder elements or use -fno-align-commons",
1162 common
->name
, &common
->where
, (int)common_segment
->offset
);
1164 gfc_warning ("COMMON at %L requires %d bytes of padding; "
1165 "reorder elements or use -fno-align-commons",
1166 &common
->where
, (int)common_segment
->offset
);
1169 create_common (common
, common_segment
, saw_equiv
);
1173 /* Create a new block for each merged equivalence list. */
1176 finish_equivalences (gfc_namespace
*ns
)
1180 gfc_common_head
* c
;
1181 HOST_WIDE_INT offset
;
1182 unsigned HOST_WIDE_INT align
;
1185 for (z
= ns
->equiv
; z
; z
= z
->next
)
1186 for (y
= z
->eq
; y
; y
= y
->eq
)
1190 sym
= z
->expr
->symtree
->n
.sym
;
1191 current_segment
= get_segment_info (sym
, 0);
1193 /* All objects directly or indirectly equivalenced with this
1195 add_equivalences (&dummy
);
1197 /* Align the block. */
1198 offset
= align_segment (&align
);
1200 /* Ensure all offsets are positive. */
1201 offset
-= current_segment
->offset
& ~(align
- 1);
1203 apply_segment_offset (current_segment
, offset
);
1205 /* Create the decl. If this is a module equivalence, it has a
1206 unique name, pointed to by z->module. This is written to a
1207 gfc_common_header to push create_common into using
1208 build_common_decl, so that the equivalence appears as an
1209 external symbol. Otherwise, a local declaration is built using
1210 build_equiv_decl. */
1213 c
= gfc_get_common_head ();
1214 /* We've lost the real location, so use the location of the
1215 enclosing procedure. */
1216 c
->where
= ns
->proc_name
->declared_at
;
1217 strcpy (c
->name
, z
->module
);
1222 create_common (c
, current_segment
, true);
1228 /* Work function for translating a named common block. */
1231 named_common (gfc_symtree
*st
)
1233 translate_common (st
->n
.common
, st
->n
.common
->head
);
1237 /* Translate the common blocks in a namespace. Unlike other variables,
1238 these have to be created before code, because the backend_decl depends
1239 on the rest of the common block. */
1242 gfc_trans_common (gfc_namespace
*ns
)
1246 /* Translate the blank common block. */
1247 if (ns
->blank_common
.head
!= NULL
)
1249 c
= gfc_get_common_head ();
1250 c
->where
= ns
->blank_common
.head
->common_head
->where
;
1251 strcpy (c
->name
, BLANK_COMMON_NAME
);
1252 translate_common (c
, ns
->blank_common
.head
);
1255 /* Translate all named common blocks. */
1256 gfc_traverse_symtree (ns
->common_root
, named_common
);
1258 /* Translate local equivalence. */
1259 finish_equivalences (ns
);
1261 /* Commit the newly created symbols for common blocks and module
1263 gfc_commit_symbols ();