1 /* Common block and equivalence list handling
2 Copyright (C) 2000, 2003, 2004, 2005, 2006, 2007, 2008
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"
104 #include "gfortran.h"
106 #include "trans-types.h"
107 #include "trans-const.h"
108 #include "target-memory.h"
111 /* Holds a single variable in an equivalence set. */
112 typedef struct segment_info
115 HOST_WIDE_INT offset
;
116 HOST_WIDE_INT length
;
117 /* This will contain the field type until the field is created. */
119 struct segment_info
*next
;
122 static segment_info
* current_segment
;
123 static gfc_namespace
*gfc_common_ns
= NULL
;
126 /* Make a segment_info based on a symbol. */
128 static segment_info
*
129 get_segment_info (gfc_symbol
* sym
, HOST_WIDE_INT offset
)
133 /* Make sure we've got the character length. */
134 if (sym
->ts
.type
== BT_CHARACTER
)
135 gfc_conv_const_charlen (sym
->ts
.cl
);
137 /* Create the segment_info and fill it in. */
138 s
= (segment_info
*) gfc_getmem (sizeof (segment_info
));
140 /* We will use this type when building the segment aggregate type. */
141 s
->field
= gfc_sym_type (sym
);
142 s
->length
= int_size_in_bytes (s
->field
);
149 /* Add a copy of a segment list to the namespace. This is specifically for
150 equivalence segments, so that dependency checking can be done on
151 equivalence group members. */
154 copy_equiv_list_to_ns (segment_info
*c
)
160 l
= (gfc_equiv_list
*) gfc_getmem (sizeof (gfc_equiv_list
));
162 l
->next
= c
->sym
->ns
->equiv_lists
;
163 c
->sym
->ns
->equiv_lists
= l
;
165 for (f
= c
; f
; f
= f
->next
)
167 s
= (gfc_equiv_info
*) gfc_getmem (sizeof (gfc_equiv_info
));
171 s
->offset
= f
->offset
;
172 s
->length
= f
->length
;
177 /* Add combine segment V and segment LIST. */
179 static segment_info
*
180 add_segments (segment_info
*list
, segment_info
*v
)
191 /* Find the location of the new element. */
194 if (v
->offset
< s
->offset
)
196 if (v
->offset
== s
->offset
197 && v
->length
<= s
->length
)
204 /* Insert the new element in between p and s. */
220 /* Construct mangled common block name from symbol name. */
222 /* We need the bind(c) flag to tell us how/if we should mangle the symbol
223 name. There are few calls to this function, so few places that this
224 would need to be added. At the moment, there is only one call, in
225 build_common_decl(). We can't attempt to look up the common block
226 because we may be building it for the first time and therefore, it won't
227 be in the common_root. We also need the binding label, if it's bind(c).
228 Therefore, send in the pointer to the common block, so whatever info we
229 have so far can be used. All of the necessary info should be available
230 in the gfc_common_head by now, so it should be accurate to test the
231 isBindC flag and use the binding label given if it is bind(c).
233 We may NOT know yet if it's bind(c) or not, but we can try at least.
234 Will have to figure out what to do later if it's labeled bind(c)
235 after this is called. */
238 gfc_sym_mangled_common_id (gfc_common_head
*com
)
241 char mangled_name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 1];
242 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
244 /* Get the name out of the common block pointer. */
245 strcpy (name
, com
->name
);
247 /* If we're suppose to do a bind(c). */
248 if (com
->is_bind_c
== 1 && com
->binding_label
[0] != '\0')
249 return get_identifier (com
->binding_label
);
251 if (strcmp (name
, BLANK_COMMON_NAME
) == 0)
252 return get_identifier (name
);
254 if (gfc_option
.flag_underscoring
)
256 has_underscore
= strchr (name
, '_') != 0;
257 if (gfc_option
.flag_second_underscore
&& has_underscore
)
258 snprintf (mangled_name
, sizeof mangled_name
, "%s__", name
);
260 snprintf (mangled_name
, sizeof mangled_name
, "%s_", name
);
262 return get_identifier (mangled_name
);
265 return get_identifier (name
);
269 /* Build a field declaration for a common variable or a local equivalence
273 build_field (segment_info
*h
, tree union_type
, record_layout_info rli
)
277 HOST_WIDE_INT offset
= h
->offset
;
278 unsigned HOST_WIDE_INT desired_align
, known_align
;
280 name
= get_identifier (h
->sym
->name
);
281 field
= build_decl (FIELD_DECL
, name
, h
->field
);
282 gfc_set_decl_location (field
, &h
->sym
->declared_at
);
283 known_align
= (offset
& -offset
) * BITS_PER_UNIT
;
284 if (known_align
== 0 || known_align
> BIGGEST_ALIGNMENT
)
285 known_align
= BIGGEST_ALIGNMENT
;
287 desired_align
= update_alignment_for_field (rli
, field
, known_align
);
288 if (desired_align
> known_align
)
289 DECL_PACKED (field
) = 1;
291 DECL_FIELD_CONTEXT (field
) = union_type
;
292 DECL_FIELD_OFFSET (field
) = size_int (offset
);
293 DECL_FIELD_BIT_OFFSET (field
) = bitsize_zero_node
;
294 SET_DECL_OFFSET_ALIGN (field
, known_align
);
296 rli
->offset
= size_binop (MAX_EXPR
, rli
->offset
,
297 size_binop (PLUS_EXPR
,
298 DECL_FIELD_OFFSET (field
),
299 DECL_SIZE_UNIT (field
)));
300 /* If this field is assigned to a label, we create another two variables.
301 One will hold the address of target label or format label. The other will
302 hold the length of format label string. */
303 if (h
->sym
->attr
.assign
)
308 gfc_allocate_lang_decl (field
);
309 GFC_DECL_ASSIGN (field
) = 1;
310 len
= gfc_create_var_np (gfc_charlen_type_node
,h
->sym
->name
);
311 addr
= gfc_create_var_np (pvoid_type_node
, h
->sym
->name
);
312 TREE_STATIC (len
) = 1;
313 TREE_STATIC (addr
) = 1;
314 DECL_INITIAL (len
) = build_int_cst (NULL_TREE
, -2);
315 gfc_set_decl_location (len
, &h
->sym
->declared_at
);
316 gfc_set_decl_location (addr
, &h
->sym
->declared_at
);
317 GFC_DECL_STRING_LEN (field
) = pushdecl_top_level (len
);
318 GFC_DECL_ASSIGN_ADDR (field
) = pushdecl_top_level (addr
);
321 /* If this field is volatile, mark it. */
322 if (h
->sym
->attr
.volatile_
)
325 TREE_THIS_VOLATILE (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 (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
);
393 if (tree_int_cst_lt (DECL_SIZE_UNIT (decl
), size
))
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 (strcmp (com
->name
, BLANK_COMMON_NAME
))
399 gfc_warning ("Named COMMON block '%s' at %L shall be of the "
400 "same size", com
->name
, &com
->where
);
401 DECL_SIZE_UNIT (decl
) = size
;
402 TREE_TYPE (decl
) = union_type
;
406 /* If this common block has been declared in a previous program unit,
407 and either it is already initialized or there is no new initialization
408 for it, just return. */
409 if ((decl
!= NULL_TREE
) && (!is_init
|| DECL_INITIAL (decl
)))
412 /* If there is no backend_decl for the common block, build it. */
413 if (decl
== NULL_TREE
)
415 decl
= build_decl (VAR_DECL
, get_identifier (com
->name
), union_type
);
416 SET_DECL_ASSEMBLER_NAME (decl
, gfc_sym_mangled_common_id (com
));
417 TREE_PUBLIC (decl
) = 1;
418 TREE_STATIC (decl
) = 1;
419 DECL_IGNORED_P (decl
) = 1;
421 DECL_ALIGN (decl
) = BIGGEST_ALIGNMENT
;
424 /* Do not set the alignment for bind(c) common blocks to
425 BIGGEST_ALIGNMENT because that won't match what C does. Also,
426 for common blocks with one element, the alignment must be
427 that of the field within the common block in order to match
429 tree field
= NULL_TREE
;
430 field
= TYPE_FIELDS (TREE_TYPE (decl
));
431 if (TREE_CHAIN (field
) == NULL_TREE
)
432 DECL_ALIGN (decl
) = TYPE_ALIGN (TREE_TYPE (field
));
434 DECL_USER_ALIGN (decl
) = 0;
435 GFC_DECL_COMMON_OR_EQUIV (decl
) = 1;
437 gfc_set_decl_location (decl
, &com
->where
);
439 if (com
->threadprivate
)
440 DECL_TLS_MODEL (decl
) = decl_default_tls_model (decl
);
442 /* Place the back end declaration for this common block in
443 GLOBAL_BINDING_LEVEL. */
444 common_sym
->backend_decl
= pushdecl_top_level (decl
);
447 /* Has no initial values. */
450 DECL_INITIAL (decl
) = NULL_TREE
;
451 DECL_COMMON (decl
) = 1;
452 DECL_DEFER_OUTPUT (decl
) = 1;
456 DECL_INITIAL (decl
) = error_mark_node
;
457 DECL_COMMON (decl
) = 0;
458 DECL_DEFER_OUTPUT (decl
) = 0;
464 /* Return a field that is the size of the union, if an equivalence has
465 overlapping initializers. Merge the initializers into a single
466 initializer for this new field, then free the old ones. */
469 get_init_field (segment_info
*head
, tree union_type
, tree
*field_init
,
470 record_layout_info rli
)
473 HOST_WIDE_INT length
= 0;
474 HOST_WIDE_INT offset
= 0;
475 unsigned HOST_WIDE_INT known_align
, desired_align
;
476 bool overlap
= false;
479 unsigned char *data
, *chk
;
480 VEC(constructor_elt
,gc
) *v
= NULL
;
482 tree type
= unsigned_char_type_node
;
485 /* Obtain the size of the union and check if there are any overlapping
487 for (s
= head
; s
; s
= s
->next
)
489 HOST_WIDE_INT slen
= s
->offset
+ s
->length
;
492 if (s
->offset
< offset
)
496 length
= length
< slen
? slen
: length
;
502 /* Now absorb all the initializer data into a single vector,
503 whilst checking for overlapping, unequal values. */
504 data
= (unsigned char*)gfc_getmem ((size_t)length
);
505 chk
= (unsigned char*)gfc_getmem ((size_t)length
);
507 /* TODO - change this when default initialization is implemented. */
508 memset (data
, '\0', (size_t)length
);
509 memset (chk
, '\0', (size_t)length
);
510 for (s
= head
; s
; s
= s
->next
)
512 gfc_merge_initializers (s
->sym
->ts
, s
->sym
->value
,
517 for (i
= 0; i
< length
; i
++)
518 CONSTRUCTOR_APPEND_ELT (v
, NULL
, build_int_cst (type
, data
[i
]));
523 /* Build a char[length] array to hold the initializers. Much of what
524 follows is borrowed from build_field, above. */
526 tmp
= build_int_cst (gfc_array_index_type
, length
- 1);
527 tmp
= build_range_type (gfc_array_index_type
,
528 gfc_index_zero_node
, tmp
);
529 tmp
= build_array_type (type
, tmp
);
530 field
= build_decl (FIELD_DECL
, NULL_TREE
, tmp
);
531 gfc_set_decl_location (field
, &gfc_current_locus
);
533 known_align
= BIGGEST_ALIGNMENT
;
535 desired_align
= update_alignment_for_field (rli
, field
, known_align
);
536 if (desired_align
> known_align
)
537 DECL_PACKED (field
) = 1;
539 DECL_FIELD_CONTEXT (field
) = union_type
;
540 DECL_FIELD_OFFSET (field
) = size_int (0);
541 DECL_FIELD_BIT_OFFSET (field
) = bitsize_zero_node
;
542 SET_DECL_OFFSET_ALIGN (field
, known_align
);
544 rli
->offset
= size_binop (MAX_EXPR
, rli
->offset
,
545 size_binop (PLUS_EXPR
,
546 DECL_FIELD_OFFSET (field
),
547 DECL_SIZE_UNIT (field
)));
549 init
= build_constructor (TREE_TYPE (field
), v
);
550 TREE_CONSTANT (init
) = 1;
554 for (s
= head
; s
; s
= s
->next
)
556 if (s
->sym
->value
== NULL
)
559 gfc_free_expr (s
->sym
->value
);
560 s
->sym
->value
= NULL
;
567 /* Declare memory for the common block or local equivalence, and create
568 backend declarations for all of the elements. */
571 create_common (gfc_common_head
*com
, segment_info
*head
, bool saw_equiv
)
573 segment_info
*s
, *next_s
;
577 tree field_init
= NULL_TREE
;
578 record_layout_info rli
;
580 bool is_init
= false;
581 bool is_saved
= false;
583 /* Declare the variables inside the common block.
584 If the current common block contains any equivalence object, then
585 make a UNION_TYPE node, otherwise RECORD_TYPE. This will let the
586 alias analyzer work well when there is no address overlapping for
587 common variables in the current common block. */
589 union_type
= make_node (UNION_TYPE
);
591 union_type
= make_node (RECORD_TYPE
);
593 rli
= start_record_layout (union_type
);
594 field_link
= &TYPE_FIELDS (union_type
);
596 /* Check for overlapping initializers and replace them with a single,
597 artificial field that contains all the data. */
599 field
= get_init_field (head
, union_type
, &field_init
, rli
);
603 if (field
!= NULL_TREE
)
607 field_link
= &TREE_CHAIN (field
);
610 for (s
= head
; s
; s
= s
->next
)
612 build_field (s
, union_type
, rli
);
614 /* Link the field into the type. */
615 *field_link
= s
->field
;
616 field_link
= &TREE_CHAIN (s
->field
);
618 /* Has initial value. */
622 /* Has SAVE attribute. */
623 if (s
->sym
->attr
.save
)
627 finish_record_layout (rli
, true);
630 decl
= build_common_decl (com
, union_type
, is_init
);
632 decl
= build_equiv_decl (union_type
, is_init
, is_saved
);
637 HOST_WIDE_INT offset
= 0;
638 VEC(constructor_elt
,gc
) *v
= NULL
;
640 if (field
!= NULL_TREE
&& field_init
!= NULL_TREE
)
641 CONSTRUCTOR_APPEND_ELT (v
, field
, field_init
);
643 for (s
= head
; s
; s
= s
->next
)
647 /* Add the initializer for this field. */
648 tmp
= gfc_conv_initializer (s
->sym
->value
, &s
->sym
->ts
,
649 TREE_TYPE (s
->field
), s
->sym
->attr
.dimension
,
650 s
->sym
->attr
.pointer
|| s
->sym
->attr
.allocatable
);
652 CONSTRUCTOR_APPEND_ELT (v
, s
->field
, tmp
);
653 offset
= s
->offset
+ s
->length
;
657 gcc_assert (!VEC_empty (constructor_elt
, v
));
658 ctor
= build_constructor (union_type
, v
);
659 TREE_CONSTANT (ctor
) = 1;
660 TREE_STATIC (ctor
) = 1;
661 DECL_INITIAL (decl
) = ctor
;
663 #ifdef ENABLE_CHECKING
666 unsigned HOST_WIDE_INT idx
;
667 FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor
), idx
, field
, value
)
668 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
673 /* Build component reference for each variable. */
674 for (s
= head
; s
; s
= next_s
)
678 var_decl
= build_decl (VAR_DECL
, DECL_NAME (s
->field
),
679 TREE_TYPE (s
->field
));
680 gfc_set_decl_location (var_decl
, &s
->sym
->declared_at
);
681 TREE_PUBLIC (var_decl
) = TREE_PUBLIC (decl
);
682 TREE_STATIC (var_decl
) = TREE_STATIC (decl
);
683 TREE_USED (var_decl
) = TREE_USED (decl
);
684 if (s
->sym
->attr
.use_assoc
)
685 DECL_IGNORED_P (var_decl
) = 1;
686 if (s
->sym
->attr
.target
)
687 TREE_ADDRESSABLE (var_decl
) = 1;
688 /* This is a fake variable just for debugging purposes. */
689 TREE_ASM_WRITTEN (var_decl
) = 1;
691 /* To preserve identifier names in COMMON, chain to procedure
692 scope unless at top level in a module definition. */
694 && s
->sym
->ns
->proc_name
695 && s
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
696 var_decl
= pushdecl_top_level (var_decl
);
698 gfc_add_decl_to_function (var_decl
);
700 SET_DECL_VALUE_EXPR (var_decl
,
701 fold_build3 (COMPONENT_REF
, TREE_TYPE (s
->field
),
702 decl
, s
->field
, NULL_TREE
));
703 DECL_HAS_VALUE_EXPR_P (var_decl
) = 1;
704 GFC_DECL_COMMON_OR_EQUIV (var_decl
) = 1;
706 if (s
->sym
->attr
.assign
)
708 gfc_allocate_lang_decl (var_decl
);
709 GFC_DECL_ASSIGN (var_decl
) = 1;
710 GFC_DECL_STRING_LEN (var_decl
) = GFC_DECL_STRING_LEN (s
->field
);
711 GFC_DECL_ASSIGN_ADDR (var_decl
) = GFC_DECL_ASSIGN_ADDR (s
->field
);
714 s
->sym
->backend_decl
= var_decl
;
722 /* Given a symbol, find it in the current segment list. Returns NULL if
725 static segment_info
*
726 find_segment_info (gfc_symbol
*symbol
)
730 for (n
= current_segment
; n
; n
= n
->next
)
732 if (n
->sym
== symbol
)
740 /* Given an expression node, make sure it is a constant integer and return
744 get_mpz (gfc_expr
*e
)
747 if (e
->expr_type
!= EXPR_CONSTANT
)
748 gfc_internal_error ("get_mpz(): Not an integer constant");
750 return &e
->value
.integer
;
754 /* Given an array specification and an array reference, figure out the
755 array element number (zero based). Bounds and elements are guaranteed
756 to be constants. If something goes wrong we generate an error and
760 element_number (gfc_array_ref
*ar
)
762 mpz_t multiplier
, offset
, extent
, n
;
764 HOST_WIDE_INT i
, rank
;
768 mpz_init_set_ui (multiplier
, 1);
769 mpz_init_set_ui (offset
, 0);
773 for (i
= 0; i
< rank
; i
++)
775 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
776 gfc_internal_error ("element_number(): Bad dimension type");
778 mpz_sub (n
, *get_mpz (ar
->start
[i
]), *get_mpz (as
->lower
[i
]));
780 mpz_mul (n
, n
, multiplier
);
781 mpz_add (offset
, offset
, n
);
783 mpz_sub (extent
, *get_mpz (as
->upper
[i
]), *get_mpz (as
->lower
[i
]));
784 mpz_add_ui (extent
, extent
, 1);
786 if (mpz_sgn (extent
) < 0)
787 mpz_set_ui (extent
, 0);
789 mpz_mul (multiplier
, multiplier
, extent
);
792 i
= mpz_get_ui (offset
);
794 mpz_clear (multiplier
);
803 /* Given a single element of an equivalence list, figure out the offset
804 from the base symbol. For simple variables or full arrays, this is
805 simply zero. For an array element we have to calculate the array
806 element number and multiply by the element size. For a substring we
807 have to calculate the further reference. */
810 calculate_offset (gfc_expr
*e
)
812 HOST_WIDE_INT n
, element_size
, offset
;
813 gfc_typespec
*element_type
;
817 element_type
= &e
->symtree
->n
.sym
->ts
;
819 for (reference
= e
->ref
; reference
; reference
= reference
->next
)
820 switch (reference
->type
)
823 switch (reference
->u
.ar
.type
)
829 n
= element_number (&reference
->u
.ar
);
830 if (element_type
->type
== BT_CHARACTER
)
831 gfc_conv_const_charlen (element_type
->cl
);
833 int_size_in_bytes (gfc_typenode_for_spec (element_type
));
834 offset
+= n
* element_size
;
838 gfc_error ("Bad array reference at %L", &e
->where
);
842 if (reference
->u
.ss
.start
!= NULL
)
843 offset
+= mpz_get_ui (*get_mpz (reference
->u
.ss
.start
)) - 1;
846 gfc_error ("Illegal reference type at %L as EQUIVALENCE object",
853 /* Add a new segment_info structure to the current segment. eq1 is already
854 in the list, eq2 is not. */
857 new_condition (segment_info
*v
, gfc_equiv
*eq1
, gfc_equiv
*eq2
)
859 HOST_WIDE_INT offset1
, offset2
;
862 offset1
= calculate_offset (eq1
->expr
);
863 offset2
= calculate_offset (eq2
->expr
);
865 a
= get_segment_info (eq2
->expr
->symtree
->n
.sym
,
866 v
->offset
+ offset1
- offset2
);
868 current_segment
= add_segments (current_segment
, a
);
872 /* Given two equivalence structures that are both already in the list, make
873 sure that this new condition is not violated, generating an error if it
877 confirm_condition (segment_info
*s1
, gfc_equiv
*eq1
, segment_info
*s2
,
880 HOST_WIDE_INT offset1
, offset2
;
882 offset1
= calculate_offset (eq1
->expr
);
883 offset2
= calculate_offset (eq2
->expr
);
885 if (s1
->offset
+ offset1
!= s2
->offset
+ offset2
)
886 gfc_error ("Inconsistent equivalence rules involving '%s' at %L and "
887 "'%s' at %L", s1
->sym
->name
, &s1
->sym
->declared_at
,
888 s2
->sym
->name
, &s2
->sym
->declared_at
);
892 /* Process a new equivalence condition. eq1 is know to be in segment f.
893 If eq2 is also present then confirm that the condition holds.
894 Otherwise add a new variable to the segment list. */
897 add_condition (segment_info
*f
, gfc_equiv
*eq1
, gfc_equiv
*eq2
)
901 n
= find_segment_info (eq2
->expr
->symtree
->n
.sym
);
904 new_condition (f
, eq1
, eq2
);
906 confirm_condition (f
, eq1
, n
, eq2
);
910 /* Given a segment element, search through the equivalence lists for unused
911 conditions that involve the symbol. Add these rules to the segment. */
914 find_equivalence (segment_info
*n
)
916 gfc_equiv
*e1
, *e2
, *eq
;
921 for (e1
= n
->sym
->ns
->equiv
; e1
; e1
= e1
->next
)
925 /* Search the equivalence list, including the root (first) element
926 for the symbol that owns the segment. */
927 for (e2
= e1
; e2
; e2
= e2
->eq
)
929 if (!e2
->used
&& e2
->expr
->symtree
->n
.sym
== n
->sym
)
936 /* Go to the next root element. */
942 /* Now traverse the equivalence list matching the offsets. */
943 for (e2
= e1
; e2
; e2
= e2
->eq
)
945 if (!e2
->used
&& e2
!= eq
)
947 add_condition (n
, eq
, e2
);
957 /* Add all symbols equivalenced within a segment. We need to scan the
958 segment list multiple times to include indirect equivalences. Since
959 a new segment_info can inserted at the beginning of the segment list,
960 depending on its offset, we have to force a final pass through the
961 loop by demanding that completion sees a pass with no matches; i.e.,
962 all symbols with equiv_built set and no new equivalences found. */
965 add_equivalences (bool *saw_equiv
)
975 for (f
= current_segment
; f
; f
= f
->next
)
977 if (!f
->sym
->equiv_built
)
979 f
->sym
->equiv_built
= 1;
980 seen_one
= find_equivalence (f
);
990 /* Add a copy of this segment list to the namespace. */
991 copy_equiv_list_to_ns (current_segment
);
995 /* Returns the offset necessary to properly align the current equivalence.
996 Sets *palign to the required alignment. */
999 align_segment (unsigned HOST_WIDE_INT
*palign
)
1002 unsigned HOST_WIDE_INT offset
;
1003 unsigned HOST_WIDE_INT max_align
;
1004 unsigned HOST_WIDE_INT this_align
;
1005 unsigned HOST_WIDE_INT this_offset
;
1009 for (s
= current_segment
; s
; s
= s
->next
)
1011 this_align
= TYPE_ALIGN_UNIT (s
->field
);
1012 if (s
->offset
& (this_align
- 1))
1014 /* Field is misaligned. */
1015 this_offset
= this_align
- ((s
->offset
+ offset
) & (this_align
- 1));
1016 if (this_offset
& (max_align
- 1))
1018 /* Aligning this field would misalign a previous field. */
1019 gfc_error ("The equivalence set for variable '%s' "
1020 "declared at %L violates alignment requirements",
1021 s
->sym
->name
, &s
->sym
->declared_at
);
1023 offset
+= this_offset
;
1025 max_align
= this_align
;
1028 *palign
= max_align
;
1033 /* Adjust segment offsets by the given amount. */
1036 apply_segment_offset (segment_info
*s
, HOST_WIDE_INT offset
)
1038 for (; s
; s
= s
->next
)
1039 s
->offset
+= offset
;
1043 /* Lay out a symbol in a common block. If the symbol has already been seen
1044 then check the location is consistent. Otherwise create segments
1045 for that symbol and all the symbols equivalenced with it. */
1047 /* Translate a single common block. */
1050 translate_common (gfc_common_head
*common
, gfc_symbol
*var_list
)
1054 segment_info
*common_segment
;
1055 HOST_WIDE_INT offset
;
1056 HOST_WIDE_INT current_offset
;
1057 unsigned HOST_WIDE_INT align
;
1058 unsigned HOST_WIDE_INT max_align
;
1061 common_segment
= NULL
;
1068 /* Add symbols to the segment. */
1069 for (sym
= var_list
; sym
; sym
= sym
->common_next
)
1071 current_segment
= common_segment
;
1072 s
= find_segment_info (sym
);
1074 /* Symbol has already been added via an equivalence. Multiple
1075 use associations of the same common block result in equiv_built
1076 being set but no information about the symbol in the segment. */
1077 if (s
&& sym
->equiv_built
)
1079 /* Ensure the current location is properly aligned. */
1080 align
= TYPE_ALIGN_UNIT (s
->field
);
1081 current_offset
= (current_offset
+ align
- 1) &~ (align
- 1);
1083 /* Verify that it ended up where we expect it. */
1084 if (s
->offset
!= current_offset
)
1086 gfc_error ("Equivalence for '%s' does not match ordering of "
1087 "COMMON '%s' at %L", sym
->name
,
1088 common
->name
, &common
->where
);
1093 /* A symbol we haven't seen before. */
1094 s
= current_segment
= get_segment_info (sym
, current_offset
);
1096 /* Add all objects directly or indirectly equivalenced with this
1098 add_equivalences (&saw_equiv
);
1100 if (current_segment
->offset
< 0)
1101 gfc_error ("The equivalence set for '%s' cause an invalid "
1102 "extension to COMMON '%s' at %L", sym
->name
,
1103 common
->name
, &common
->where
);
1105 if (gfc_option
.flag_align_commons
)
1106 offset
= align_segment (&align
);
1108 if (offset
& (max_align
- 1))
1110 /* The required offset conflicts with previous alignment
1111 requirements. Insert padding immediately before this
1113 if (gfc_option
.warn_align_commons
)
1115 if (strcmp (common
->name
, BLANK_COMMON_NAME
))
1116 gfc_warning ("Padding of %d bytes required before '%s' in "
1117 "COMMON '%s' at %L; reorder elements or use "
1118 "-fno-align-commons", (int)offset
,
1119 s
->sym
->name
, common
->name
, &common
->where
);
1121 gfc_warning ("Padding of %d bytes required before '%s' in "
1122 "COMMON at %L; reorder elements or use "
1123 "-fno-align-commons", (int)offset
,
1124 s
->sym
->name
, &common
->where
);
1129 /* Offset the whole common block. */
1130 apply_segment_offset (common_segment
, offset
);
1133 /* Apply the offset to the new segments. */
1134 apply_segment_offset (current_segment
, offset
);
1135 current_offset
+= offset
;
1136 if (max_align
< align
)
1139 /* Add the new segments to the common block. */
1140 common_segment
= add_segments (common_segment
, current_segment
);
1143 /* The offset of the next common variable. */
1144 current_offset
+= s
->length
;
1147 if (common_segment
== NULL
)
1149 gfc_error ("COMMON '%s' at %L does not exist",
1150 common
->name
, &common
->where
);
1154 if (common_segment
->offset
!= 0 && gfc_option
.warn_align_commons
)
1156 if (strcmp (common
->name
, BLANK_COMMON_NAME
))
1157 gfc_warning ("COMMON '%s' at %L requires %d bytes of padding at start; "
1158 "reorder elements or use -fno-align-commons",
1159 common
->name
, &common
->where
, (int)common_segment
->offset
);
1161 gfc_warning ("COMMON at %L requires %d bytes of padding at start; "
1162 "reorder elements or use -fno-align-commons",
1163 &common
->where
, (int)common_segment
->offset
);
1166 create_common (common
, common_segment
, saw_equiv
);
1170 /* Create a new block for each merged equivalence list. */
1173 finish_equivalences (gfc_namespace
*ns
)
1177 gfc_common_head
* c
;
1178 HOST_WIDE_INT offset
;
1179 unsigned HOST_WIDE_INT align
;
1182 for (z
= ns
->equiv
; z
; z
= z
->next
)
1183 for (y
= z
->eq
; y
; y
= y
->eq
)
1187 sym
= z
->expr
->symtree
->n
.sym
;
1188 current_segment
= get_segment_info (sym
, 0);
1190 /* All objects directly or indirectly equivalenced with this
1192 add_equivalences (&dummy
);
1194 /* Align the block. */
1195 offset
= align_segment (&align
);
1197 /* Ensure all offsets are positive. */
1198 offset
-= current_segment
->offset
& ~(align
- 1);
1200 apply_segment_offset (current_segment
, offset
);
1202 /* Create the decl. If this is a module equivalence, it has a
1203 unique name, pointed to by z->module. This is written to a
1204 gfc_common_header to push create_common into using
1205 build_common_decl, so that the equivalence appears as an
1206 external symbol. Otherwise, a local declaration is built using
1207 build_equiv_decl. */
1210 c
= gfc_get_common_head ();
1211 /* We've lost the real location, so use the location of the
1212 enclosing procedure. */
1213 c
->where
= ns
->proc_name
->declared_at
;
1214 strcpy (c
->name
, z
->module
);
1219 create_common (c
, current_segment
, true);
1225 /* Work function for translating a named common block. */
1228 named_common (gfc_symtree
*st
)
1230 translate_common (st
->n
.common
, st
->n
.common
->head
);
1234 /* Translate the common blocks in a namespace. Unlike other variables,
1235 these have to be created before code, because the backend_decl depends
1236 on the rest of the common block. */
1239 gfc_trans_common (gfc_namespace
*ns
)
1243 /* Translate the blank common block. */
1244 if (ns
->blank_common
.head
!= NULL
)
1246 c
= gfc_get_common_head ();
1247 c
->where
= ns
->blank_common
.head
->common_head
->where
;
1248 strcpy (c
->name
, BLANK_COMMON_NAME
);
1249 translate_common (c
, ns
->blank_common
.head
);
1252 /* Translate all named common blocks. */
1253 gfc_traverse_symtree (ns
->common_root
, named_common
);
1255 /* Translate local equivalence. */
1256 finish_equivalences (ns
);
1258 /* Commit the newly created symbols for common blocks and module
1260 gfc_commit_symbols ();