1 /* Common block and equivalence list handling
2 Copyright (C) 2000-2021 Free Software Foundation, Inc.
3 Contributed by Canqun Yang <canqun@nudt.edu.cn>
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
21 /* The core algorithm is based on Andy Vaught's g95 tree. Also the
22 way to build UNION_TYPE is borrowed from Richard Henderson.
24 Transform common blocks. An integral part of this is processing
25 equivalence variables. Equivalenced variables that are not in a
26 common block end up in a private block of their own.
28 Each common block or local equivalence list is declared as a union.
29 Variables within the block are represented as a field within the
30 block with the proper offset.
32 So if two variables are equivalenced, they just point to a common
35 Mathematically, laying out an equivalence block is equivalent to
36 solving a linear system of equations. The matrix is usually a
37 sparse matrix in which each row contains all zero elements except
38 for a +1 and a -1, a sort of a generalized Vandermonde matrix. The
39 matrix is usually block diagonal. The system can be
40 overdetermined, underdetermined or have a unique solution. If the
41 system is inconsistent, the program is not standard conforming.
42 The solution vector is integral, since all of the pivots are +1 or -1.
44 How we lay out an equivalence block is a little less complicated.
45 In an equivalence list with n elements, there are n-1 conditions to
46 be satisfied. The conditions partition the variables into what we
47 will call segments. If A and B are equivalenced then A and B are
48 in the same segment. If B and C are equivalenced as well, then A,
49 B and C are in a segment and so on. Each segment is a block of
50 memory that has one or more variables equivalenced in some way. A
51 common block is made up of a series of segments that are joined one
52 after the other. In the linear system, a segment is a block
55 To lay out a segment we first start with some variable and
56 determine its length. The first variable is assumed to start at
57 offset one and extends to however long it is. We then traverse the
58 list of equivalences to find an unused condition that involves at
59 least one of the variables currently in the segment.
61 Each equivalence condition amounts to the condition B+b=C+c where B
62 and C are the offsets of the B and C variables, and b and c are
63 constants which are nonzero for array elements, substrings or
64 structure components. So for
66 EQUIVALENCE(B(2), C(3))
68 B + 2*size of B's elements = C + 3*size of C's elements.
70 If B and C are known we check to see if the condition already
71 holds. If B is known we can solve for C. Since we know the length
72 of C, we can see if the minimum and maximum extents of the segment
73 are affected. Eventually, we make a full pass through the
74 equivalence list without finding any new conditions and the segment
77 At this point, the segment is added to the current common block.
78 Since we know the minimum extent of the segment, everything in the
79 segment is translated to its position in the common block. The
80 usual case here is that there are no equivalence statements and the
81 common block is series of segments with one variable each, which is
82 a diagonal matrix in the matrix formulation.
84 Each segment is described by a chain of segment_info structures. Each
85 segment_info structure describes the extents of a single variable within
86 the segment. This list is maintained in the order the elements are
87 positioned within the segment. If two elements have the same starting
88 offset the smaller will come first. If they also have the same size their
89 ordering is undefined.
91 Once all common blocks have been created, the list of equivalences
92 is examined for still-unused equivalence conditions. We create a
93 block for each merged equivalence list. */
98 #include "coretypes.h"
101 #include "gfortran.h"
103 #include "stringpool.h"
104 #include "fold-const.h"
105 #include "stor-layout.h"
107 #include "trans-types.h"
108 #include "trans-const.h"
109 #include "target-memory.h"
112 /* Holds a single variable in an equivalence set. */
113 typedef struct segment_info
116 HOST_WIDE_INT offset
;
117 HOST_WIDE_INT length
;
118 /* This will contain the field type until the field is created. */
120 struct segment_info
*next
;
123 static segment_info
* current_segment
;
125 /* Store decl of all common blocks in this translation unit; the first
126 tree is the identifier. */
127 static std::map
<tree
, tree
> gfc_map_of_all_commons
;
130 /* Make a segment_info based on a symbol. */
132 static segment_info
*
133 get_segment_info (gfc_symbol
* sym
, HOST_WIDE_INT offset
)
137 /* Make sure we've got the character length. */
138 if (sym
->ts
.type
== BT_CHARACTER
)
139 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
141 /* Create the segment_info and fill it in. */
142 s
= XCNEW (segment_info
);
144 /* We will use this type when building the segment aggregate type. */
145 s
->field
= gfc_sym_type (sym
);
146 s
->length
= int_size_in_bytes (s
->field
);
153 /* Add a copy of a segment list to the namespace. This is specifically for
154 equivalence segments, so that dependency checking can be done on
155 equivalence group members. */
158 copy_equiv_list_to_ns (segment_info
*c
)
164 l
= XCNEW (gfc_equiv_list
);
166 l
->next
= c
->sym
->ns
->equiv_lists
;
167 c
->sym
->ns
->equiv_lists
= l
;
169 for (f
= c
; f
; f
= f
->next
)
171 s
= XCNEW (gfc_equiv_info
);
175 s
->offset
= f
->offset
;
176 s
->length
= f
->length
;
181 /* Add combine segment V and segment LIST. */
183 static segment_info
*
184 add_segments (segment_info
*list
, segment_info
*v
)
195 /* Find the location of the new element. */
198 if (v
->offset
< s
->offset
)
200 if (v
->offset
== s
->offset
201 && v
->length
<= s
->length
)
208 /* Insert the new element in between p and s. */
224 /* Construct mangled common block name from symbol name. */
226 /* We need the bind(c) flag to tell us how/if we should mangle the symbol
227 name. There are few calls to this function, so few places that this
228 would need to be added. At the moment, there is only one call, in
229 build_common_decl(). We can't attempt to look up the common block
230 because we may be building it for the first time and therefore, it won't
231 be in the common_root. We also need the binding label, if it's bind(c).
232 Therefore, send in the pointer to the common block, so whatever info we
233 have so far can be used. All of the necessary info should be available
234 in the gfc_common_head by now, so it should be accurate to test the
235 isBindC flag and use the binding label given if it is bind(c).
237 We may NOT know yet if it's bind(c) or not, but we can try at least.
238 Will have to figure out what to do later if it's labeled bind(c)
239 after this is called. */
242 gfc_sym_mangled_common_id (gfc_common_head
*com
)
245 /* Provide sufficient space to hold "symbol.symbol.eq.1234567890__". */
246 char mangled_name
[2*GFC_MAX_MANGLED_SYMBOL_LEN
+ 1 + 16 + 1];
247 char name
[sizeof (mangled_name
) - 2];
249 /* Get the name out of the common block pointer. */
250 size_t len
= strlen (com
->name
);
251 gcc_assert (len
< sizeof (name
));
252 strcpy (name
, com
->name
);
254 /* If we're suppose to do a bind(c). */
255 if (com
->is_bind_c
== 1 && com
->binding_label
)
256 return get_identifier (com
->binding_label
);
258 if (strcmp (name
, BLANK_COMMON_NAME
) == 0)
259 return get_identifier (name
);
261 if (flag_underscoring
)
263 has_underscore
= strchr (name
, '_') != 0;
264 if (flag_second_underscore
&& has_underscore
)
265 snprintf (mangled_name
, sizeof mangled_name
, "%s__", name
);
267 snprintf (mangled_name
, sizeof mangled_name
, "%s_", name
);
269 return get_identifier (mangled_name
);
272 return get_identifier (name
);
276 /* Build a field declaration for a common variable or a local equivalence
280 build_field (segment_info
*h
, tree union_type
, record_layout_info rli
)
284 HOST_WIDE_INT offset
= h
->offset
;
285 unsigned HOST_WIDE_INT desired_align
, known_align
;
287 name
= get_identifier (h
->sym
->name
);
288 field
= build_decl (gfc_get_location (&h
->sym
->declared_at
),
289 FIELD_DECL
, name
, h
->field
);
290 known_align
= (offset
& -offset
) * BITS_PER_UNIT
;
291 if (known_align
== 0 || known_align
> BIGGEST_ALIGNMENT
)
292 known_align
= BIGGEST_ALIGNMENT
;
294 desired_align
= update_alignment_for_field (rli
, field
, known_align
);
295 if (desired_align
> known_align
)
296 DECL_PACKED (field
) = 1;
298 DECL_FIELD_CONTEXT (field
) = union_type
;
299 DECL_FIELD_OFFSET (field
) = size_int (offset
);
300 DECL_FIELD_BIT_OFFSET (field
) = bitsize_zero_node
;
301 SET_DECL_OFFSET_ALIGN (field
, known_align
);
303 rli
->offset
= size_binop (MAX_EXPR
, rli
->offset
,
304 size_binop (PLUS_EXPR
,
305 DECL_FIELD_OFFSET (field
),
306 DECL_SIZE_UNIT (field
)));
307 /* If this field is assigned to a label, we create another two variables.
308 One will hold the address of target label or format label. The other will
309 hold the length of format label string. */
310 if (h
->sym
->attr
.assign
)
315 gfc_allocate_lang_decl (field
);
316 GFC_DECL_ASSIGN (field
) = 1;
317 len
= gfc_create_var_np (gfc_charlen_type_node
,h
->sym
->name
);
318 addr
= gfc_create_var_np (pvoid_type_node
, h
->sym
->name
);
319 TREE_STATIC (len
) = 1;
320 TREE_STATIC (addr
) = 1;
321 DECL_INITIAL (len
) = build_int_cst (gfc_charlen_type_node
, -2);
322 gfc_set_decl_location (len
, &h
->sym
->declared_at
);
323 gfc_set_decl_location (addr
, &h
->sym
->declared_at
);
324 GFC_DECL_STRING_LEN (field
) = pushdecl_top_level (len
);
325 GFC_DECL_ASSIGN_ADDR (field
) = pushdecl_top_level (addr
);
328 /* If this field is volatile, mark it. */
329 if (h
->sym
->attr
.volatile_
)
332 TREE_THIS_VOLATILE (field
) = 1;
333 TREE_SIDE_EFFECTS (field
) = 1;
334 new_type
= build_qualified_type (TREE_TYPE (field
), TYPE_QUAL_VOLATILE
);
335 TREE_TYPE (field
) = new_type
;
342 /* Get storage for local equivalence. */
345 build_equiv_decl (tree union_type
, bool is_init
, bool is_saved
, bool is_auto
)
349 static int serial
= 0;
353 decl
= gfc_create_var (union_type
, "equiv");
354 TREE_STATIC (decl
) = 1;
355 GFC_DECL_COMMON_OR_EQUIV (decl
) = 1;
359 snprintf (name
, sizeof (name
), "equiv.%d", serial
++);
360 decl
= build_decl (input_location
,
361 VAR_DECL
, get_identifier (name
), union_type
);
362 DECL_ARTIFICIAL (decl
) = 1;
363 DECL_IGNORED_P (decl
) = 1;
365 if (!is_auto
&& (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl
))
367 TREE_STATIC (decl
) = 1;
369 TREE_ADDRESSABLE (decl
) = 1;
370 TREE_USED (decl
) = 1;
371 GFC_DECL_COMMON_OR_EQUIV (decl
) = 1;
373 /* The source location has been lost, and doesn't really matter.
374 We need to set it to something though. */
375 gfc_set_decl_location (decl
, &gfc_current_locus
);
377 gfc_add_decl_to_function (decl
);
383 /* Get storage for common block. */
386 build_common_decl (gfc_common_head
*com
, tree union_type
, bool is_init
)
388 tree decl
, identifier
;
390 identifier
= gfc_sym_mangled_common_id (com
);
391 decl
= gfc_map_of_all_commons
.count(identifier
)
392 ? gfc_map_of_all_commons
[identifier
] : NULL_TREE
;
394 /* Update the size of this common block as needed. */
395 if (decl
!= NULL_TREE
)
397 tree size
= TYPE_SIZE_UNIT (union_type
);
399 /* Named common blocks of the same name shall be of the same size
400 in all scoping units of a program in which they appear, but
401 blank common blocks may be of different sizes. */
402 if (!tree_int_cst_equal (DECL_SIZE_UNIT (decl
), size
)
403 && strcmp (com
->name
, BLANK_COMMON_NAME
))
404 gfc_warning (0, "Named COMMON block %qs at %L shall be of the "
405 "same size as elsewhere (%lu vs %lu bytes)", com
->name
,
407 (unsigned long) TREE_INT_CST_LOW (size
),
408 (unsigned long) TREE_INT_CST_LOW (DECL_SIZE_UNIT (decl
)));
410 if (tree_int_cst_lt (DECL_SIZE_UNIT (decl
), size
))
412 DECL_SIZE (decl
) = TYPE_SIZE (union_type
);
413 DECL_SIZE_UNIT (decl
) = size
;
414 SET_DECL_MODE (decl
, TYPE_MODE (union_type
));
415 TREE_TYPE (decl
) = union_type
;
416 layout_decl (decl
, 0);
420 /* If this common block has been declared in a previous program unit,
421 and either it is already initialized or there is no new initialization
422 for it, just return. */
423 if ((decl
!= NULL_TREE
) && (!is_init
|| DECL_INITIAL (decl
)))
426 /* If there is no backend_decl for the common block, build it. */
427 if (decl
== NULL_TREE
)
429 tree omp_clauses
= NULL_TREE
;
431 if (com
->is_bind_c
== 1 && com
->binding_label
)
432 decl
= build_decl (input_location
, VAR_DECL
, identifier
, union_type
);
435 decl
= build_decl (input_location
, VAR_DECL
, get_identifier (com
->name
),
437 gfc_set_decl_assembler_name (decl
, identifier
);
440 TREE_PUBLIC (decl
) = 1;
441 TREE_STATIC (decl
) = 1;
442 DECL_IGNORED_P (decl
) = 1;
444 SET_DECL_ALIGN (decl
, BIGGEST_ALIGNMENT
);
447 /* Do not set the alignment for bind(c) common blocks to
448 BIGGEST_ALIGNMENT because that won't match what C does. Also,
449 for common blocks with one element, the alignment must be
450 that of the field within the common block in order to match
452 tree field
= NULL_TREE
;
453 field
= TYPE_FIELDS (TREE_TYPE (decl
));
454 if (DECL_CHAIN (field
) == NULL_TREE
)
455 SET_DECL_ALIGN (decl
, TYPE_ALIGN (TREE_TYPE (field
)));
457 DECL_USER_ALIGN (decl
) = 0;
458 GFC_DECL_COMMON_OR_EQUIV (decl
) = 1;
460 gfc_set_decl_location (decl
, &com
->where
);
462 if (com
->threadprivate
)
463 set_decl_tls_model (decl
, decl_default_tls_model (decl
));
465 if (com
->omp_device_type
!= OMP_DEVICE_TYPE_UNSET
)
467 tree c
= build_omp_clause (UNKNOWN_LOCATION
, OMP_CLAUSE_DEVICE_TYPE
);
468 switch (com
->omp_device_type
)
470 case OMP_DEVICE_TYPE_HOST
:
471 OMP_CLAUSE_DEVICE_TYPE_KIND (c
) = OMP_CLAUSE_DEVICE_TYPE_HOST
;
473 case OMP_DEVICE_TYPE_NOHOST
:
474 OMP_CLAUSE_DEVICE_TYPE_KIND (c
) = OMP_CLAUSE_DEVICE_TYPE_NOHOST
;
476 case OMP_DEVICE_TYPE_ANY
:
477 OMP_CLAUSE_DEVICE_TYPE_KIND (c
) = OMP_CLAUSE_DEVICE_TYPE_ANY
;
484 if (com
->omp_declare_target_link
)
485 DECL_ATTRIBUTES (decl
)
486 = tree_cons (get_identifier ("omp declare target link"),
487 omp_clauses
, DECL_ATTRIBUTES (decl
));
488 else if (com
->omp_declare_target
)
489 DECL_ATTRIBUTES (decl
)
490 = tree_cons (get_identifier ("omp declare target"),
491 omp_clauses
, DECL_ATTRIBUTES (decl
));
493 /* Place the back end declaration for this common block in
494 GLOBAL_BINDING_LEVEL. */
495 gfc_map_of_all_commons
[identifier
] = pushdecl_top_level (decl
);
498 /* Has no initial values. */
501 DECL_INITIAL (decl
) = NULL_TREE
;
502 DECL_COMMON (decl
) = 1;
503 DECL_DEFER_OUTPUT (decl
) = 1;
507 DECL_INITIAL (decl
) = error_mark_node
;
508 DECL_COMMON (decl
) = 0;
509 DECL_DEFER_OUTPUT (decl
) = 0;
515 /* Return a field that is the size of the union, if an equivalence has
516 overlapping initializers. Merge the initializers into a single
517 initializer for this new field, then free the old ones. */
520 get_init_field (segment_info
*head
, tree union_type
, tree
*field_init
,
521 record_layout_info rli
)
524 HOST_WIDE_INT length
= 0;
525 HOST_WIDE_INT offset
= 0;
526 unsigned HOST_WIDE_INT known_align
, desired_align
;
527 bool overlap
= false;
530 unsigned char *data
, *chk
;
531 vec
<constructor_elt
, va_gc
> *v
= NULL
;
533 tree type
= unsigned_char_type_node
;
536 /* Obtain the size of the union and check if there are any overlapping
538 for (s
= head
; s
; s
= s
->next
)
540 HOST_WIDE_INT slen
= s
->offset
+ s
->length
;
543 if (s
->offset
< offset
)
547 length
= length
< slen
? slen
: length
;
553 /* Now absorb all the initializer data into a single vector,
554 whilst checking for overlapping, unequal values. */
555 data
= XCNEWVEC (unsigned char, (size_t)length
);
556 chk
= XCNEWVEC (unsigned char, (size_t)length
);
558 /* TODO - change this when default initialization is implemented. */
559 memset (data
, '\0', (size_t)length
);
560 memset (chk
, '\0', (size_t)length
);
561 for (s
= head
; s
; s
= s
->next
)
565 if (s
->sym
->ns
->equiv
&& s
->sym
->ns
->equiv
->eq
)
566 loc
= &s
->sym
->ns
->equiv
->eq
->expr
->where
;
567 gfc_merge_initializers (s
->sym
->ts
, s
->sym
->value
, loc
,
573 for (i
= 0; i
< length
; i
++)
574 CONSTRUCTOR_APPEND_ELT (v
, NULL
, build_int_cst (type
, data
[i
]));
579 /* Build a char[length] array to hold the initializers. Much of what
580 follows is borrowed from build_field, above. */
582 tmp
= build_int_cst (gfc_array_index_type
, length
- 1);
583 tmp
= build_range_type (gfc_array_index_type
,
584 gfc_index_zero_node
, tmp
);
585 tmp
= build_array_type (type
, tmp
);
586 field
= build_decl (gfc_get_location (&gfc_current_locus
),
587 FIELD_DECL
, NULL_TREE
, tmp
);
589 known_align
= BIGGEST_ALIGNMENT
;
591 desired_align
= update_alignment_for_field (rli
, field
, known_align
);
592 if (desired_align
> known_align
)
593 DECL_PACKED (field
) = 1;
595 DECL_FIELD_CONTEXT (field
) = union_type
;
596 DECL_FIELD_OFFSET (field
) = size_int (0);
597 DECL_FIELD_BIT_OFFSET (field
) = bitsize_zero_node
;
598 SET_DECL_OFFSET_ALIGN (field
, known_align
);
600 rli
->offset
= size_binop (MAX_EXPR
, rli
->offset
,
601 size_binop (PLUS_EXPR
,
602 DECL_FIELD_OFFSET (field
),
603 DECL_SIZE_UNIT (field
)));
605 init
= build_constructor (TREE_TYPE (field
), v
);
606 TREE_CONSTANT (init
) = 1;
610 for (s
= head
; s
; s
= s
->next
)
612 if (s
->sym
->value
== NULL
)
615 gfc_free_expr (s
->sym
->value
);
616 s
->sym
->value
= NULL
;
623 /* Declare memory for the common block or local equivalence, and create
624 backend declarations for all of the elements. */
627 create_common (gfc_common_head
*com
, segment_info
*head
, bool saw_equiv
)
629 segment_info
*s
, *next_s
;
633 tree field_init
= NULL_TREE
;
634 record_layout_info rli
;
636 bool is_init
= false;
637 bool is_saved
= false;
638 bool is_auto
= false;
640 /* Declare the variables inside the common block.
641 If the current common block contains any equivalence object, then
642 make a UNION_TYPE node, otherwise RECORD_TYPE. This will let the
643 alias analyzer work well when there is no address overlapping for
644 common variables in the current common block. */
646 union_type
= make_node (UNION_TYPE
);
648 union_type
= make_node (RECORD_TYPE
);
650 rli
= start_record_layout (union_type
);
651 field_link
= &TYPE_FIELDS (union_type
);
653 /* Check for overlapping initializers and replace them with a single,
654 artificial field that contains all the data. */
656 field
= get_init_field (head
, union_type
, &field_init
, rli
);
660 if (field
!= NULL_TREE
)
664 field_link
= &DECL_CHAIN (field
);
667 for (s
= head
; s
; s
= s
->next
)
669 build_field (s
, union_type
, rli
);
671 /* Link the field into the type. */
672 *field_link
= s
->field
;
673 field_link
= &DECL_CHAIN (s
->field
);
675 /* Has initial value. */
679 /* Has SAVE attribute. */
680 if (s
->sym
->attr
.save
)
683 /* Has AUTOMATIC attribute. */
684 if (s
->sym
->attr
.automatic
)
688 finish_record_layout (rli
, true);
691 decl
= build_common_decl (com
, union_type
, is_init
);
693 decl
= build_equiv_decl (union_type
, is_init
, is_saved
, is_auto
);
698 vec
<constructor_elt
, va_gc
> *v
= NULL
;
700 if (field
!= NULL_TREE
&& field_init
!= NULL_TREE
)
701 CONSTRUCTOR_APPEND_ELT (v
, field
, field_init
);
703 for (s
= head
; s
; s
= s
->next
)
707 /* Add the initializer for this field. */
708 tmp
= gfc_conv_initializer (s
->sym
->value
, &s
->sym
->ts
,
709 TREE_TYPE (s
->field
),
710 s
->sym
->attr
.dimension
,
712 || s
->sym
->attr
.allocatable
, false);
714 CONSTRUCTOR_APPEND_ELT (v
, s
->field
, tmp
);
718 gcc_assert (!v
->is_empty ());
719 ctor
= build_constructor (union_type
, v
);
720 TREE_CONSTANT (ctor
) = 1;
721 TREE_STATIC (ctor
) = 1;
722 DECL_INITIAL (decl
) = ctor
;
727 unsigned HOST_WIDE_INT idx
;
728 FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor
), idx
, field
, value
)
729 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
733 /* Build component reference for each variable. */
734 for (s
= head
; s
; s
= next_s
)
738 var_decl
= build_decl (gfc_get_location (&s
->sym
->declared_at
),
739 VAR_DECL
, DECL_NAME (s
->field
),
740 TREE_TYPE (s
->field
));
741 TREE_STATIC (var_decl
) = TREE_STATIC (decl
);
742 /* Mark the variable as used in order to avoid warnings about
744 TREE_USED (var_decl
) = 1;
745 if (s
->sym
->attr
.use_assoc
)
746 DECL_IGNORED_P (var_decl
) = 1;
747 if (s
->sym
->attr
.target
)
748 TREE_ADDRESSABLE (var_decl
) = 1;
749 /* Fake variables are not visible from other translation units. */
750 TREE_PUBLIC (var_decl
) = 0;
751 gfc_finish_decl_attrs (var_decl
, &s
->sym
->attr
);
753 /* To preserve identifier names in COMMON, chain to procedure
754 scope unless at top level in a module definition. */
756 && s
->sym
->ns
->proc_name
757 && s
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
758 var_decl
= pushdecl_top_level (var_decl
);
760 gfc_add_decl_to_function (var_decl
);
762 tree comp
= build3_loc (input_location
, COMPONENT_REF
,
763 TREE_TYPE (s
->field
), decl
, s
->field
, NULL_TREE
);
764 if (TREE_THIS_VOLATILE (s
->field
))
765 TREE_THIS_VOLATILE (comp
) = 1;
766 SET_DECL_VALUE_EXPR (var_decl
, comp
);
767 DECL_HAS_VALUE_EXPR_P (var_decl
) = 1;
768 GFC_DECL_COMMON_OR_EQUIV (var_decl
) = 1;
770 if (s
->sym
->attr
.assign
)
772 gfc_allocate_lang_decl (var_decl
);
773 GFC_DECL_ASSIGN (var_decl
) = 1;
774 GFC_DECL_STRING_LEN (var_decl
) = GFC_DECL_STRING_LEN (s
->field
);
775 GFC_DECL_ASSIGN_ADDR (var_decl
) = GFC_DECL_ASSIGN_ADDR (s
->field
);
778 s
->sym
->backend_decl
= var_decl
;
786 /* Given a symbol, find it in the current segment list. Returns NULL if
789 static segment_info
*
790 find_segment_info (gfc_symbol
*symbol
)
794 for (n
= current_segment
; n
; n
= n
->next
)
796 if (n
->sym
== symbol
)
804 /* Given an expression node, make sure it is a constant integer and return
808 get_mpz (gfc_expr
*e
)
811 if (e
->expr_type
!= EXPR_CONSTANT
)
812 gfc_internal_error ("get_mpz(): Not an integer constant");
814 return &e
->value
.integer
;
818 /* Given an array specification and an array reference, figure out the
819 array element number (zero based). Bounds and elements are guaranteed
820 to be constants. If something goes wrong we generate an error and
824 element_number (gfc_array_ref
*ar
)
826 mpz_t multiplier
, offset
, extent
, n
;
828 HOST_WIDE_INT i
, rank
;
832 mpz_init_set_ui (multiplier
, 1);
833 mpz_init_set_ui (offset
, 0);
837 for (i
= 0; i
< rank
; i
++)
839 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
840 gfc_internal_error ("element_number(): Bad dimension type");
842 if (as
&& as
->lower
[i
])
843 mpz_sub (n
, *get_mpz (ar
->start
[i
]), *get_mpz (as
->lower
[i
]));
845 mpz_sub_ui (n
, *get_mpz (ar
->start
[i
]), 1);
847 mpz_mul (n
, n
, multiplier
);
848 mpz_add (offset
, offset
, n
);
850 if (as
&& as
->upper
[i
] && as
->lower
[i
])
852 mpz_sub (extent
, *get_mpz (as
->upper
[i
]), *get_mpz (as
->lower
[i
]));
853 mpz_add_ui (extent
, extent
, 1);
856 mpz_set_ui (extent
, 0);
858 if (mpz_sgn (extent
) < 0)
859 mpz_set_ui (extent
, 0);
861 mpz_mul (multiplier
, multiplier
, extent
);
864 i
= mpz_get_ui (offset
);
866 mpz_clear (multiplier
);
875 /* Given a single element of an equivalence list, figure out the offset
876 from the base symbol. For simple variables or full arrays, this is
877 simply zero. For an array element we have to calculate the array
878 element number and multiply by the element size. For a substring we
879 have to calculate the further reference. */
882 calculate_offset (gfc_expr
*e
)
884 HOST_WIDE_INT n
, element_size
, offset
;
885 gfc_typespec
*element_type
;
889 element_type
= &e
->symtree
->n
.sym
->ts
;
891 for (reference
= e
->ref
; reference
; reference
= reference
->next
)
892 switch (reference
->type
)
895 switch (reference
->u
.ar
.type
)
901 n
= element_number (&reference
->u
.ar
);
902 if (element_type
->type
== BT_CHARACTER
)
903 gfc_conv_const_charlen (element_type
->u
.cl
);
905 int_size_in_bytes (gfc_typenode_for_spec (element_type
));
906 offset
+= n
* element_size
;
910 gfc_error ("Bad array reference at %L", &e
->where
);
914 if (reference
->u
.ss
.start
!= NULL
)
915 offset
+= mpz_get_ui (*get_mpz (reference
->u
.ss
.start
)) - 1;
918 gfc_error ("Illegal reference type at %L as EQUIVALENCE object",
925 /* Add a new segment_info structure to the current segment. eq1 is already
926 in the list, eq2 is not. */
929 new_condition (segment_info
*v
, gfc_equiv
*eq1
, gfc_equiv
*eq2
)
931 HOST_WIDE_INT offset1
, offset2
;
934 offset1
= calculate_offset (eq1
->expr
);
935 offset2
= calculate_offset (eq2
->expr
);
937 a
= get_segment_info (eq2
->expr
->symtree
->n
.sym
,
938 v
->offset
+ offset1
- offset2
);
940 current_segment
= add_segments (current_segment
, a
);
944 /* Given two equivalence structures that are both already in the list, make
945 sure that this new condition is not violated, generating an error if it
949 confirm_condition (segment_info
*s1
, gfc_equiv
*eq1
, segment_info
*s2
,
952 HOST_WIDE_INT offset1
, offset2
;
954 offset1
= calculate_offset (eq1
->expr
);
955 offset2
= calculate_offset (eq2
->expr
);
957 if (s1
->offset
+ offset1
!= s2
->offset
+ offset2
)
958 gfc_error ("Inconsistent equivalence rules involving %qs at %L and "
959 "%qs at %L", s1
->sym
->name
, &s1
->sym
->declared_at
,
960 s2
->sym
->name
, &s2
->sym
->declared_at
);
964 /* Process a new equivalence condition. eq1 is know to be in segment f.
965 If eq2 is also present then confirm that the condition holds.
966 Otherwise add a new variable to the segment list. */
969 add_condition (segment_info
*f
, gfc_equiv
*eq1
, gfc_equiv
*eq2
)
973 n
= find_segment_info (eq2
->expr
->symtree
->n
.sym
);
976 new_condition (f
, eq1
, eq2
);
978 confirm_condition (f
, eq1
, n
, eq2
);
982 accumulate_equivalence_attributes (symbol_attribute
*dummy_symbol
, gfc_equiv
*e
)
984 symbol_attribute attr
= e
->expr
->symtree
->n
.sym
->attr
;
986 dummy_symbol
->dummy
|= attr
.dummy
;
987 dummy_symbol
->pointer
|= attr
.pointer
;
988 dummy_symbol
->target
|= attr
.target
;
989 dummy_symbol
->external
|= attr
.external
;
990 dummy_symbol
->intrinsic
|= attr
.intrinsic
;
991 dummy_symbol
->allocatable
|= attr
.allocatable
;
992 dummy_symbol
->elemental
|= attr
.elemental
;
993 dummy_symbol
->recursive
|= attr
.recursive
;
994 dummy_symbol
->in_common
|= attr
.in_common
;
995 dummy_symbol
->result
|= attr
.result
;
996 dummy_symbol
->in_namelist
|= attr
.in_namelist
;
997 dummy_symbol
->optional
|= attr
.optional
;
998 dummy_symbol
->entry
|= attr
.entry
;
999 dummy_symbol
->function
|= attr
.function
;
1000 dummy_symbol
->subroutine
|= attr
.subroutine
;
1001 dummy_symbol
->dimension
|= attr
.dimension
;
1002 dummy_symbol
->in_equivalence
|= attr
.in_equivalence
;
1003 dummy_symbol
->use_assoc
|= attr
.use_assoc
;
1004 dummy_symbol
->cray_pointer
|= attr
.cray_pointer
;
1005 dummy_symbol
->cray_pointee
|= attr
.cray_pointee
;
1006 dummy_symbol
->data
|= attr
.data
;
1007 dummy_symbol
->value
|= attr
.value
;
1008 dummy_symbol
->volatile_
|= attr
.volatile_
;
1009 dummy_symbol
->is_protected
|= attr
.is_protected
;
1010 dummy_symbol
->is_bind_c
|= attr
.is_bind_c
;
1011 dummy_symbol
->procedure
|= attr
.procedure
;
1012 dummy_symbol
->proc_pointer
|= attr
.proc_pointer
;
1013 dummy_symbol
->abstract
|= attr
.abstract
;
1014 dummy_symbol
->asynchronous
|= attr
.asynchronous
;
1015 dummy_symbol
->codimension
|= attr
.codimension
;
1016 dummy_symbol
->contiguous
|= attr
.contiguous
;
1017 dummy_symbol
->generic
|= attr
.generic
;
1018 dummy_symbol
->automatic
|= attr
.automatic
;
1019 dummy_symbol
->threadprivate
|= attr
.threadprivate
;
1020 dummy_symbol
->omp_declare_target
|= attr
.omp_declare_target
;
1021 dummy_symbol
->omp_declare_target_link
|= attr
.omp_declare_target_link
;
1022 dummy_symbol
->oacc_declare_copyin
|= attr
.oacc_declare_copyin
;
1023 dummy_symbol
->oacc_declare_create
|= attr
.oacc_declare_create
;
1024 dummy_symbol
->oacc_declare_deviceptr
|= attr
.oacc_declare_deviceptr
;
1025 dummy_symbol
->oacc_declare_device_resident
1026 |= attr
.oacc_declare_device_resident
;
1028 /* Not strictly correct, but probably close enough. */
1029 if (attr
.save
> dummy_symbol
->save
)
1030 dummy_symbol
->save
= attr
.save
;
1031 if (attr
.access
> dummy_symbol
->access
)
1032 dummy_symbol
->access
= attr
.access
;
1035 /* Given a segment element, search through the equivalence lists for unused
1036 conditions that involve the symbol. Add these rules to the segment. */
1039 find_equivalence (segment_info
*n
)
1041 gfc_equiv
*e1
, *e2
, *eq
;
1046 for (e1
= n
->sym
->ns
->equiv
; e1
; e1
= e1
->next
)
1050 /* Search the equivalence list, including the root (first) element
1051 for the symbol that owns the segment. */
1052 symbol_attribute dummy_symbol
;
1053 memset (&dummy_symbol
, 0, sizeof (dummy_symbol
));
1054 for (e2
= e1
; e2
; e2
= e2
->eq
)
1056 accumulate_equivalence_attributes (&dummy_symbol
, e2
);
1057 if (!e2
->used
&& e2
->expr
->symtree
->n
.sym
== n
->sym
)
1064 gfc_check_conflict (&dummy_symbol
, e1
->expr
->symtree
->name
, &e1
->expr
->where
);
1066 /* Go to the next root element. */
1072 /* Now traverse the equivalence list matching the offsets. */
1073 for (e2
= e1
; e2
; e2
= e2
->eq
)
1075 if (!e2
->used
&& e2
!= eq
)
1077 add_condition (n
, eq
, e2
);
1087 /* Add all symbols equivalenced within a segment. We need to scan the
1088 segment list multiple times to include indirect equivalences. Since
1089 a new segment_info can inserted at the beginning of the segment list,
1090 depending on its offset, we have to force a final pass through the
1091 loop by demanding that completion sees a pass with no matches; i.e.,
1092 all symbols with equiv_built set and no new equivalences found. */
1095 add_equivalences (bool *saw_equiv
)
1103 for (f
= current_segment
; f
; f
= f
->next
)
1105 if (!f
->sym
->equiv_built
)
1107 f
->sym
->equiv_built
= 1;
1108 bool seen_one
= find_equivalence (f
);
1118 /* Add a copy of this segment list to the namespace. */
1119 copy_equiv_list_to_ns (current_segment
);
1123 /* Returns the offset necessary to properly align the current equivalence.
1124 Sets *palign to the required alignment. */
1126 static HOST_WIDE_INT
1127 align_segment (unsigned HOST_WIDE_INT
*palign
)
1130 unsigned HOST_WIDE_INT offset
;
1131 unsigned HOST_WIDE_INT max_align
;
1132 unsigned HOST_WIDE_INT this_align
;
1133 unsigned HOST_WIDE_INT this_offset
;
1137 for (s
= current_segment
; s
; s
= s
->next
)
1139 this_align
= TYPE_ALIGN_UNIT (s
->field
);
1140 if (s
->offset
& (this_align
- 1))
1142 /* Field is misaligned. */
1143 this_offset
= this_align
- ((s
->offset
+ offset
) & (this_align
- 1));
1144 if (this_offset
& (max_align
- 1))
1146 /* Aligning this field would misalign a previous field. */
1147 gfc_error ("The equivalence set for variable %qs "
1148 "declared at %L violates alignment requirements",
1149 s
->sym
->name
, &s
->sym
->declared_at
);
1151 offset
+= this_offset
;
1153 max_align
= this_align
;
1156 *palign
= max_align
;
1161 /* Adjust segment offsets by the given amount. */
1164 apply_segment_offset (segment_info
*s
, HOST_WIDE_INT offset
)
1166 for (; s
; s
= s
->next
)
1167 s
->offset
+= offset
;
1171 /* Lay out a symbol in a common block. If the symbol has already been seen
1172 then check the location is consistent. Otherwise create segments
1173 for that symbol and all the symbols equivalenced with it. */
1175 /* Translate a single common block. */
1178 translate_common (gfc_common_head
*common
, gfc_symbol
*var_list
)
1182 segment_info
*common_segment
;
1183 HOST_WIDE_INT offset
;
1184 HOST_WIDE_INT current_offset
;
1185 unsigned HOST_WIDE_INT align
;
1188 common_segment
= NULL
;
1194 /* Add symbols to the segment. */
1195 for (sym
= var_list
; sym
; sym
= sym
->common_next
)
1197 current_segment
= common_segment
;
1198 s
= find_segment_info (sym
);
1200 /* Symbol has already been added via an equivalence. Multiple
1201 use associations of the same common block result in equiv_built
1202 being set but no information about the symbol in the segment. */
1203 if (s
&& sym
->equiv_built
)
1205 /* Ensure the current location is properly aligned. */
1206 align
= TYPE_ALIGN_UNIT (s
->field
);
1207 current_offset
= (current_offset
+ align
- 1) &~ (align
- 1);
1209 /* Verify that it ended up where we expect it. */
1210 if (s
->offset
!= current_offset
)
1212 gfc_error ("Equivalence for %qs does not match ordering of "
1213 "COMMON %qs at %L", sym
->name
,
1214 common
->name
, &common
->where
);
1219 /* A symbol we haven't seen before. */
1220 s
= current_segment
= get_segment_info (sym
, current_offset
);
1222 /* Add all objects directly or indirectly equivalenced with this
1224 add_equivalences (&saw_equiv
);
1226 if (current_segment
->offset
< 0)
1227 gfc_error ("The equivalence set for %qs cause an invalid "
1228 "extension to COMMON %qs at %L", sym
->name
,
1229 common
->name
, &common
->where
);
1231 if (flag_align_commons
)
1232 offset
= align_segment (&align
);
1236 /* The required offset conflicts with previous alignment
1237 requirements. Insert padding immediately before this
1239 if (warn_align_commons
)
1241 if (strcmp (common
->name
, BLANK_COMMON_NAME
))
1242 gfc_warning (OPT_Walign_commons
,
1243 "Padding of %d bytes required before %qs in "
1244 "COMMON %qs at %L; reorder elements or use "
1245 "%<-fno-align-commons%>", (int)offset
,
1246 s
->sym
->name
, common
->name
, &common
->where
);
1248 gfc_warning (OPT_Walign_commons
,
1249 "Padding of %d bytes required before %qs in "
1250 "COMMON at %L; reorder elements or use "
1251 "%<-fno-align-commons%>", (int)offset
,
1252 s
->sym
->name
, &common
->where
);
1256 /* Apply the offset to the new segments. */
1257 apply_segment_offset (current_segment
, offset
);
1258 current_offset
+= offset
;
1260 /* Add the new segments to the common block. */
1261 common_segment
= add_segments (common_segment
, current_segment
);
1264 /* The offset of the next common variable. */
1265 current_offset
+= s
->length
;
1268 if (common_segment
== NULL
)
1270 gfc_error ("COMMON %qs at %L does not exist",
1271 common
->name
, &common
->where
);
1275 if (common_segment
->offset
!= 0 && warn_align_commons
)
1277 if (strcmp (common
->name
, BLANK_COMMON_NAME
))
1278 gfc_warning (OPT_Walign_commons
,
1279 "COMMON %qs at %L requires %d bytes of padding; "
1280 "reorder elements or use %<-fno-align-commons%>",
1281 common
->name
, &common
->where
, (int)common_segment
->offset
);
1283 gfc_warning (OPT_Walign_commons
,
1284 "COMMON at %L requires %d bytes of padding; "
1285 "reorder elements or use %<-fno-align-commons%>",
1286 &common
->where
, (int)common_segment
->offset
);
1289 create_common (common
, common_segment
, saw_equiv
);
1293 /* Create a new block for each merged equivalence list. */
1296 finish_equivalences (gfc_namespace
*ns
)
1300 gfc_common_head
* c
;
1301 HOST_WIDE_INT offset
;
1302 unsigned HOST_WIDE_INT align
;
1305 for (z
= ns
->equiv
; z
; z
= z
->next
)
1306 for (y
= z
->eq
; y
; y
= y
->eq
)
1310 sym
= z
->expr
->symtree
->n
.sym
;
1311 current_segment
= get_segment_info (sym
, 0);
1313 /* All objects directly or indirectly equivalenced with this
1315 add_equivalences (&dummy
);
1317 /* Align the block. */
1318 offset
= align_segment (&align
);
1320 /* Ensure all offsets are positive. */
1321 offset
-= current_segment
->offset
& ~(align
- 1);
1323 apply_segment_offset (current_segment
, offset
);
1325 /* Create the decl. If this is a module equivalence, it has a
1326 unique name, pointed to by z->module. This is written to a
1327 gfc_common_header to push create_common into using
1328 build_common_decl, so that the equivalence appears as an
1329 external symbol. Otherwise, a local declaration is built using
1330 build_equiv_decl. */
1333 c
= gfc_get_common_head ();
1334 /* We've lost the real location, so use the location of the
1335 enclosing procedure. If we're in a BLOCK DATA block, then
1336 use the location in the sym_root. */
1338 c
->where
= ns
->proc_name
->declared_at
;
1339 else if (ns
->is_block_data
)
1340 c
->where
= ns
->sym_root
->n
.sym
->declared_at
;
1342 size_t len
= strlen (z
->module
);
1343 gcc_assert (len
< sizeof (c
->name
));
1344 memcpy (c
->name
, z
->module
, len
);
1345 c
->name
[len
] = '\0';
1350 create_common (c
, current_segment
, true);
1356 /* Work function for translating a named common block. */
1359 named_common (gfc_symtree
*st
)
1361 translate_common (st
->n
.common
, st
->n
.common
->head
);
1365 /* Translate the common blocks in a namespace. Unlike other variables,
1366 these have to be created before code, because the backend_decl depends
1367 on the rest of the common block. */
1370 gfc_trans_common (gfc_namespace
*ns
)
1374 /* Translate the blank common block. */
1375 if (ns
->blank_common
.head
!= NULL
)
1377 c
= gfc_get_common_head ();
1378 c
->where
= ns
->blank_common
.head
->common_head
->where
;
1379 strcpy (c
->name
, BLANK_COMMON_NAME
);
1380 translate_common (c
, ns
->blank_common
.head
);
1383 /* Translate all named common blocks. */
1384 gfc_traverse_symtree (ns
->common_root
, named_common
);
1386 /* Translate local equivalence. */
1387 finish_equivalences (ns
);
1389 /* Commit the newly created symbols for common blocks and module
1391 gfc_commit_symbols ();