|
111
|
1 /* Common block and equivalence list handling
|
|
131
|
2 Copyright (C) 2000-2018 Free Software Foundation, Inc.
|
|
111
|
3 Contributed by Canqun Yang <canqun@nudt.edu.cn>
|
|
|
4
|
|
|
5 This file is part of GCC.
|
|
|
6
|
|
|
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
|
|
|
10 version.
|
|
|
11
|
|
|
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
|
|
|
15 for more details.
|
|
|
16
|
|
|
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/>. */
|
|
|
20
|
|
|
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.
|
|
|
23
|
|
|
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.
|
|
|
27
|
|
|
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.
|
|
|
31
|
|
|
32 So if two variables are equivalenced, they just point to a common
|
|
|
33 area in memory.
|
|
|
34
|
|
|
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.
|
|
|
43
|
|
|
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
|
|
|
53 diagonal.
|
|
|
54
|
|
|
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.
|
|
|
60
|
|
|
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
|
|
|
65
|
|
|
66 EQUIVALENCE(B(2), C(3))
|
|
|
67 we have
|
|
|
68 B + 2*size of B's elements = C + 3*size of C's elements.
|
|
|
69
|
|
|
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
|
|
|
75 is fully specified.
|
|
|
76
|
|
|
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.
|
|
|
83
|
|
|
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.
|
|
|
90
|
|
|
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. */
|
|
|
94
|
|
|
95 #include "config.h"
|
|
|
96 #define INCLUDE_MAP
|
|
|
97 #include "system.h"
|
|
|
98 #include "coretypes.h"
|
|
|
99 #include "tm.h"
|
|
|
100 #include "tree.h"
|
|
|
101 #include "gfortran.h"
|
|
|
102 #include "trans.h"
|
|
|
103 #include "stringpool.h"
|
|
|
104 #include "fold-const.h"
|
|
|
105 #include "stor-layout.h"
|
|
|
106 #include "varasm.h"
|
|
|
107 #include "trans-types.h"
|
|
|
108 #include "trans-const.h"
|
|
|
109 #include "target-memory.h"
|
|
|
110
|
|
|
111
|
|
|
112 /* Holds a single variable in an equivalence set. */
|
|
|
113 typedef struct segment_info
|
|
|
114 {
|
|
|
115 gfc_symbol *sym;
|
|
|
116 HOST_WIDE_INT offset;
|
|
|
117 HOST_WIDE_INT length;
|
|
|
118 /* This will contain the field type until the field is created. */
|
|
|
119 tree field;
|
|
|
120 struct segment_info *next;
|
|
|
121 } segment_info;
|
|
|
122
|
|
|
123 static segment_info * current_segment;
|
|
|
124
|
|
|
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;
|
|
|
128
|
|
|
129
|
|
|
130 /* Make a segment_info based on a symbol. */
|
|
|
131
|
|
|
132 static segment_info *
|
|
|
133 get_segment_info (gfc_symbol * sym, HOST_WIDE_INT offset)
|
|
|
134 {
|
|
|
135 segment_info *s;
|
|
|
136
|
|
|
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);
|
|
|
140
|
|
|
141 /* Create the segment_info and fill it in. */
|
|
|
142 s = XCNEW (segment_info);
|
|
|
143 s->sym = sym;
|
|
|
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);
|
|
|
147 s->offset = offset;
|
|
|
148
|
|
|
149 return s;
|
|
|
150 }
|
|
|
151
|
|
|
152
|
|
|
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. */
|
|
|
156
|
|
|
157 static void
|
|
|
158 copy_equiv_list_to_ns (segment_info *c)
|
|
|
159 {
|
|
|
160 segment_info *f;
|
|
|
161 gfc_equiv_info *s;
|
|
|
162 gfc_equiv_list *l;
|
|
|
163
|
|
|
164 l = XCNEW (gfc_equiv_list);
|
|
|
165
|
|
|
166 l->next = c->sym->ns->equiv_lists;
|
|
|
167 c->sym->ns->equiv_lists = l;
|
|
|
168
|
|
|
169 for (f = c; f; f = f->next)
|
|
|
170 {
|
|
|
171 s = XCNEW (gfc_equiv_info);
|
|
|
172 s->next = l->equiv;
|
|
|
173 l->equiv = s;
|
|
|
174 s->sym = f->sym;
|
|
|
175 s->offset = f->offset;
|
|
|
176 s->length = f->length;
|
|
|
177 }
|
|
|
178 }
|
|
|
179
|
|
|
180
|
|
|
181 /* Add combine segment V and segment LIST. */
|
|
|
182
|
|
|
183 static segment_info *
|
|
|
184 add_segments (segment_info *list, segment_info *v)
|
|
|
185 {
|
|
|
186 segment_info *s;
|
|
|
187 segment_info *p;
|
|
|
188 segment_info *next;
|
|
|
189
|
|
|
190 p = NULL;
|
|
|
191 s = list;
|
|
|
192
|
|
|
193 while (v)
|
|
|
194 {
|
|
|
195 /* Find the location of the new element. */
|
|
|
196 while (s)
|
|
|
197 {
|
|
|
198 if (v->offset < s->offset)
|
|
|
199 break;
|
|
|
200 if (v->offset == s->offset
|
|
|
201 && v->length <= s->length)
|
|
|
202 break;
|
|
|
203
|
|
|
204 p = s;
|
|
|
205 s = s->next;
|
|
|
206 }
|
|
|
207
|
|
|
208 /* Insert the new element in between p and s. */
|
|
|
209 next = v->next;
|
|
|
210 v->next = s;
|
|
|
211 if (p == NULL)
|
|
|
212 list = v;
|
|
|
213 else
|
|
|
214 p->next = v;
|
|
|
215
|
|
|
216 p = v;
|
|
|
217 v = next;
|
|
|
218 }
|
|
|
219
|
|
|
220 return list;
|
|
|
221 }
|
|
|
222
|
|
|
223
|
|
|
224 /* Construct mangled common block name from symbol name. */
|
|
|
225
|
|
|
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).
|
|
|
236
|
|
|
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. */
|
|
|
240
|
|
|
241 static tree
|
|
|
242 gfc_sym_mangled_common_id (gfc_common_head *com)
|
|
|
243 {
|
|
|
244 int has_underscore;
|
|
|
245 char mangled_name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
|
|
|
246 char name[GFC_MAX_SYMBOL_LEN + 1];
|
|
|
247
|
|
|
248 /* Get the name out of the common block pointer. */
|
|
|
249 strcpy (name, com->name);
|
|
|
250
|
|
|
251 /* If we're suppose to do a bind(c). */
|
|
|
252 if (com->is_bind_c == 1 && com->binding_label)
|
|
|
253 return get_identifier (com->binding_label);
|
|
|
254
|
|
|
255 if (strcmp (name, BLANK_COMMON_NAME) == 0)
|
|
|
256 return get_identifier (name);
|
|
|
257
|
|
|
258 if (flag_underscoring)
|
|
|
259 {
|
|
|
260 has_underscore = strchr (name, '_') != 0;
|
|
|
261 if (flag_second_underscore && has_underscore)
|
|
|
262 snprintf (mangled_name, sizeof mangled_name, "%s__", name);
|
|
|
263 else
|
|
|
264 snprintf (mangled_name, sizeof mangled_name, "%s_", name);
|
|
|
265
|
|
|
266 return get_identifier (mangled_name);
|
|
|
267 }
|
|
|
268 else
|
|
|
269 return get_identifier (name);
|
|
|
270 }
|
|
|
271
|
|
|
272
|
|
|
273 /* Build a field declaration for a common variable or a local equivalence
|
|
|
274 object. */
|
|
|
275
|
|
|
276 static void
|
|
|
277 build_field (segment_info *h, tree union_type, record_layout_info rli)
|
|
|
278 {
|
|
|
279 tree field;
|
|
|
280 tree name;
|
|
|
281 HOST_WIDE_INT offset = h->offset;
|
|
|
282 unsigned HOST_WIDE_INT desired_align, known_align;
|
|
|
283
|
|
|
284 name = get_identifier (h->sym->name);
|
|
|
285 field = build_decl (h->sym->declared_at.lb->location,
|
|
|
286 FIELD_DECL, name, h->field);
|
|
|
287 known_align = (offset & -offset) * BITS_PER_UNIT;
|
|
|
288 if (known_align == 0 || known_align > BIGGEST_ALIGNMENT)
|
|
|
289 known_align = BIGGEST_ALIGNMENT;
|
|
|
290
|
|
|
291 desired_align = update_alignment_for_field (rli, field, known_align);
|
|
|
292 if (desired_align > known_align)
|
|
|
293 DECL_PACKED (field) = 1;
|
|
|
294
|
|
|
295 DECL_FIELD_CONTEXT (field) = union_type;
|
|
|
296 DECL_FIELD_OFFSET (field) = size_int (offset);
|
|
|
297 DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node;
|
|
|
298 SET_DECL_OFFSET_ALIGN (field, known_align);
|
|
|
299
|
|
|
300 rli->offset = size_binop (MAX_EXPR, rli->offset,
|
|
|
301 size_binop (PLUS_EXPR,
|
|
|
302 DECL_FIELD_OFFSET (field),
|
|
|
303 DECL_SIZE_UNIT (field)));
|
|
|
304 /* If this field is assigned to a label, we create another two variables.
|
|
|
305 One will hold the address of target label or format label. The other will
|
|
|
306 hold the length of format label string. */
|
|
|
307 if (h->sym->attr.assign)
|
|
|
308 {
|
|
|
309 tree len;
|
|
|
310 tree addr;
|
|
|
311
|
|
|
312 gfc_allocate_lang_decl (field);
|
|
|
313 GFC_DECL_ASSIGN (field) = 1;
|
|
|
314 len = gfc_create_var_np (gfc_charlen_type_node,h->sym->name);
|
|
|
315 addr = gfc_create_var_np (pvoid_type_node, h->sym->name);
|
|
|
316 TREE_STATIC (len) = 1;
|
|
|
317 TREE_STATIC (addr) = 1;
|
|
|
318 DECL_INITIAL (len) = build_int_cst (gfc_charlen_type_node, -2);
|
|
|
319 gfc_set_decl_location (len, &h->sym->declared_at);
|
|
|
320 gfc_set_decl_location (addr, &h->sym->declared_at);
|
|
|
321 GFC_DECL_STRING_LEN (field) = pushdecl_top_level (len);
|
|
|
322 GFC_DECL_ASSIGN_ADDR (field) = pushdecl_top_level (addr);
|
|
|
323 }
|
|
|
324
|
|
|
325 /* If this field is volatile, mark it. */
|
|
|
326 if (h->sym->attr.volatile_)
|
|
|
327 {
|
|
|
328 tree new_type;
|
|
|
329 TREE_THIS_VOLATILE (field) = 1;
|
|
|
330 TREE_SIDE_EFFECTS (field) = 1;
|
|
|
331 new_type = build_qualified_type (TREE_TYPE (field), TYPE_QUAL_VOLATILE);
|
|
|
332 TREE_TYPE (field) = new_type;
|
|
|
333 }
|
|
|
334
|
|
|
335 h->field = field;
|
|
|
336 }
|
|
|
337
|
|
|
338
|
|
|
339 /* Get storage for local equivalence. */
|
|
|
340
|
|
|
341 static tree
|
|
|
342 build_equiv_decl (tree union_type, bool is_init, bool is_saved)
|
|
|
343 {
|
|
|
344 tree decl;
|
|
|
345 char name[18];
|
|
|
346 static int serial = 0;
|
|
|
347
|
|
|
348 if (is_init)
|
|
|
349 {
|
|
|
350 decl = gfc_create_var (union_type, "equiv");
|
|
|
351 TREE_STATIC (decl) = 1;
|
|
|
352 GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
|
|
|
353 return decl;
|
|
|
354 }
|
|
|
355
|
|
|
356 snprintf (name, sizeof (name), "equiv.%d", serial++);
|
|
|
357 decl = build_decl (input_location,
|
|
|
358 VAR_DECL, get_identifier (name), union_type);
|
|
|
359 DECL_ARTIFICIAL (decl) = 1;
|
|
|
360 DECL_IGNORED_P (decl) = 1;
|
|
|
361
|
|
|
362 if (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
|
|
|
363 || is_saved)
|
|
|
364 TREE_STATIC (decl) = 1;
|
|
|
365
|
|
|
366 TREE_ADDRESSABLE (decl) = 1;
|
|
|
367 TREE_USED (decl) = 1;
|
|
|
368 GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
|
|
|
369
|
|
|
370 /* The source location has been lost, and doesn't really matter.
|
|
|
371 We need to set it to something though. */
|
|
|
372 gfc_set_decl_location (decl, &gfc_current_locus);
|
|
|
373
|
|
|
374 gfc_add_decl_to_function (decl);
|
|
|
375
|
|
|
376 return decl;
|
|
|
377 }
|
|
|
378
|
|
|
379
|
|
|
380 /* Get storage for common block. */
|
|
|
381
|
|
|
382 static tree
|
|
|
383 build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
|
|
|
384 {
|
|
|
385 tree decl, identifier;
|
|
|
386
|
|
|
387 identifier = gfc_sym_mangled_common_id (com);
|
|
|
388 decl = gfc_map_of_all_commons.count(identifier)
|
|
|
389 ? gfc_map_of_all_commons[identifier] : NULL_TREE;
|
|
|
390
|
|
|
391 /* Update the size of this common block as needed. */
|
|
|
392 if (decl != NULL_TREE)
|
|
|
393 {
|
|
|
394 tree size = TYPE_SIZE_UNIT (union_type);
|
|
|
395
|
|
|
396 /* Named common blocks of the same name shall be of the same size
|
|
|
397 in all scoping units of a program in which they appear, but
|
|
|
398 blank common blocks may be of different sizes. */
|
|
|
399 if (!tree_int_cst_equal (DECL_SIZE_UNIT (decl), size)
|
|
|
400 && strcmp (com->name, BLANK_COMMON_NAME))
|
|
|
401 gfc_warning (0, "Named COMMON block %qs at %L shall be of the "
|
|
|
402 "same size as elsewhere (%lu vs %lu bytes)", com->name,
|
|
|
403 &com->where,
|
|
|
404 (unsigned long) TREE_INT_CST_LOW (size),
|
|
|
405 (unsigned long) TREE_INT_CST_LOW (DECL_SIZE_UNIT (decl)));
|
|
|
406
|
|
|
407 if (tree_int_cst_lt (DECL_SIZE_UNIT (decl), size))
|
|
|
408 {
|
|
|
409 DECL_SIZE (decl) = TYPE_SIZE (union_type);
|
|
|
410 DECL_SIZE_UNIT (decl) = size;
|
|
|
411 SET_DECL_MODE (decl, TYPE_MODE (union_type));
|
|
|
412 TREE_TYPE (decl) = union_type;
|
|
|
413 layout_decl (decl, 0);
|
|
|
414 }
|
|
|
415 }
|
|
|
416
|
|
|
417 /* If this common block has been declared in a previous program unit,
|
|
|
418 and either it is already initialized or there is no new initialization
|
|
|
419 for it, just return. */
|
|
|
420 if ((decl != NULL_TREE) && (!is_init || DECL_INITIAL (decl)))
|
|
|
421 return decl;
|
|
|
422
|
|
|
423 /* If there is no backend_decl for the common block, build it. */
|
|
|
424 if (decl == NULL_TREE)
|
|
|
425 {
|
|
|
426 if (com->is_bind_c == 1 && com->binding_label)
|
|
|
427 decl = build_decl (input_location, VAR_DECL, identifier, union_type);
|
|
|
428 else
|
|
|
429 {
|
|
|
430 decl = build_decl (input_location, VAR_DECL, get_identifier (com->name),
|
|
|
431 union_type);
|
|
|
432 gfc_set_decl_assembler_name (decl, identifier);
|
|
|
433 }
|
|
|
434
|
|
|
435 TREE_PUBLIC (decl) = 1;
|
|
|
436 TREE_STATIC (decl) = 1;
|
|
|
437 DECL_IGNORED_P (decl) = 1;
|
|
|
438 if (!com->is_bind_c)
|
|
|
439 SET_DECL_ALIGN (decl, BIGGEST_ALIGNMENT);
|
|
|
440 else
|
|
|
441 {
|
|
|
442 /* Do not set the alignment for bind(c) common blocks to
|
|
|
443 BIGGEST_ALIGNMENT because that won't match what C does. Also,
|
|
|
444 for common blocks with one element, the alignment must be
|
|
|
445 that of the field within the common block in order to match
|
|
|
446 what C will do. */
|
|
|
447 tree field = NULL_TREE;
|
|
|
448 field = TYPE_FIELDS (TREE_TYPE (decl));
|
|
|
449 if (DECL_CHAIN (field) == NULL_TREE)
|
|
|
450 SET_DECL_ALIGN (decl, TYPE_ALIGN (TREE_TYPE (field)));
|
|
|
451 }
|
|
|
452 DECL_USER_ALIGN (decl) = 0;
|
|
|
453 GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
|
|
|
454
|
|
|
455 gfc_set_decl_location (decl, &com->where);
|
|
|
456
|
|
|
457 if (com->threadprivate)
|
|
|
458 set_decl_tls_model (decl, decl_default_tls_model (decl));
|
|
|
459
|
|
|
460 if (com->omp_declare_target_link)
|
|
|
461 DECL_ATTRIBUTES (decl)
|
|
|
462 = tree_cons (get_identifier ("omp declare target link"),
|
|
|
463 NULL_TREE, DECL_ATTRIBUTES (decl));
|
|
|
464 else if (com->omp_declare_target)
|
|
|
465 DECL_ATTRIBUTES (decl)
|
|
|
466 = tree_cons (get_identifier ("omp declare target"),
|
|
|
467 NULL_TREE, DECL_ATTRIBUTES (decl));
|
|
|
468
|
|
|
469 /* Place the back end declaration for this common block in
|
|
|
470 GLOBAL_BINDING_LEVEL. */
|
|
|
471 gfc_map_of_all_commons[identifier] = pushdecl_top_level (decl);
|
|
|
472 }
|
|
|
473
|
|
|
474 /* Has no initial values. */
|
|
|
475 if (!is_init)
|
|
|
476 {
|
|
|
477 DECL_INITIAL (decl) = NULL_TREE;
|
|
|
478 DECL_COMMON (decl) = 1;
|
|
|
479 DECL_DEFER_OUTPUT (decl) = 1;
|
|
|
480 }
|
|
|
481 else
|
|
|
482 {
|
|
|
483 DECL_INITIAL (decl) = error_mark_node;
|
|
|
484 DECL_COMMON (decl) = 0;
|
|
|
485 DECL_DEFER_OUTPUT (decl) = 0;
|
|
|
486 }
|
|
|
487 return decl;
|
|
|
488 }
|
|
|
489
|
|
|
490
|
|
|
491 /* Return a field that is the size of the union, if an equivalence has
|
|
|
492 overlapping initializers. Merge the initializers into a single
|
|
|
493 initializer for this new field, then free the old ones. */
|
|
|
494
|
|
|
495 static tree
|
|
|
496 get_init_field (segment_info *head, tree union_type, tree *field_init,
|
|
|
497 record_layout_info rli)
|
|
|
498 {
|
|
|
499 segment_info *s;
|
|
|
500 HOST_WIDE_INT length = 0;
|
|
|
501 HOST_WIDE_INT offset = 0;
|
|
|
502 unsigned HOST_WIDE_INT known_align, desired_align;
|
|
|
503 bool overlap = false;
|
|
|
504 tree tmp, field;
|
|
|
505 tree init;
|
|
|
506 unsigned char *data, *chk;
|
|
|
507 vec<constructor_elt, va_gc> *v = NULL;
|
|
|
508
|
|
|
509 tree type = unsigned_char_type_node;
|
|
|
510 int i;
|
|
|
511
|
|
|
512 /* Obtain the size of the union and check if there are any overlapping
|
|
|
513 initializers. */
|
|
|
514 for (s = head; s; s = s->next)
|
|
|
515 {
|
|
|
516 HOST_WIDE_INT slen = s->offset + s->length;
|
|
|
517 if (s->sym->value)
|
|
|
518 {
|
|
|
519 if (s->offset < offset)
|
|
|
520 overlap = true;
|
|
|
521 offset = slen;
|
|
|
522 }
|
|
|
523 length = length < slen ? slen : length;
|
|
|
524 }
|
|
|
525
|
|
|
526 if (!overlap)
|
|
|
527 return NULL_TREE;
|
|
|
528
|
|
|
529 /* Now absorb all the initializer data into a single vector,
|
|
|
530 whilst checking for overlapping, unequal values. */
|
|
|
531 data = XCNEWVEC (unsigned char, (size_t)length);
|
|
|
532 chk = XCNEWVEC (unsigned char, (size_t)length);
|
|
|
533
|
|
|
534 /* TODO - change this when default initialization is implemented. */
|
|
|
535 memset (data, '\0', (size_t)length);
|
|
|
536 memset (chk, '\0', (size_t)length);
|
|
|
537 for (s = head; s; s = s->next)
|
|
|
538 if (s->sym->value)
|
|
|
539 {
|
|
|
540 locus *loc = NULL;
|
|
|
541 if (s->sym->ns->equiv && s->sym->ns->equiv->eq)
|
|
|
542 loc = &s->sym->ns->equiv->eq->expr->where;
|
|
|
543 gfc_merge_initializers (s->sym->ts, s->sym->value, loc,
|
|
|
544 &data[s->offset],
|
|
|
545 &chk[s->offset],
|
|
|
546 (size_t)s->length);
|
|
|
547 }
|
|
|
548
|
|
|
549 for (i = 0; i < length; i++)
|
|
|
550 CONSTRUCTOR_APPEND_ELT (v, NULL, build_int_cst (type, data[i]));
|
|
|
551
|
|
|
552 free (data);
|
|
|
553 free (chk);
|
|
|
554
|
|
|
555 /* Build a char[length] array to hold the initializers. Much of what
|
|
|
556 follows is borrowed from build_field, above. */
|
|
|
557
|
|
|
558 tmp = build_int_cst (gfc_array_index_type, length - 1);
|
|
|
559 tmp = build_range_type (gfc_array_index_type,
|
|
|
560 gfc_index_zero_node, tmp);
|
|
|
561 tmp = build_array_type (type, tmp);
|
|
|
562 field = build_decl (gfc_current_locus.lb->location,
|
|
|
563 FIELD_DECL, NULL_TREE, tmp);
|
|
|
564
|
|
|
565 known_align = BIGGEST_ALIGNMENT;
|
|
|
566
|
|
|
567 desired_align = update_alignment_for_field (rli, field, known_align);
|
|
|
568 if (desired_align > known_align)
|
|
|
569 DECL_PACKED (field) = 1;
|
|
|
570
|
|
|
571 DECL_FIELD_CONTEXT (field) = union_type;
|
|
|
572 DECL_FIELD_OFFSET (field) = size_int (0);
|
|
|
573 DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node;
|
|
|
574 SET_DECL_OFFSET_ALIGN (field, known_align);
|
|
|
575
|
|
|
576 rli->offset = size_binop (MAX_EXPR, rli->offset,
|
|
|
577 size_binop (PLUS_EXPR,
|
|
|
578 DECL_FIELD_OFFSET (field),
|
|
|
579 DECL_SIZE_UNIT (field)));
|
|
|
580
|
|
|
581 init = build_constructor (TREE_TYPE (field), v);
|
|
|
582 TREE_CONSTANT (init) = 1;
|
|
|
583
|
|
|
584 *field_init = init;
|
|
|
585
|
|
|
586 for (s = head; s; s = s->next)
|
|
|
587 {
|
|
|
588 if (s->sym->value == NULL)
|
|
|
589 continue;
|
|
|
590
|
|
|
591 gfc_free_expr (s->sym->value);
|
|
|
592 s->sym->value = NULL;
|
|
|
593 }
|
|
|
594
|
|
|
595 return field;
|
|
|
596 }
|
|
|
597
|
|
|
598
|
|
|
599 /* Declare memory for the common block or local equivalence, and create
|
|
|
600 backend declarations for all of the elements. */
|
|
|
601
|
|
|
602 static void
|
|
|
603 create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)
|
|
|
604 {
|
|
|
605 segment_info *s, *next_s;
|
|
|
606 tree union_type;
|
|
|
607 tree *field_link;
|
|
|
608 tree field;
|
|
|
609 tree field_init = NULL_TREE;
|
|
|
610 record_layout_info rli;
|
|
|
611 tree decl;
|
|
|
612 bool is_init = false;
|
|
|
613 bool is_saved = false;
|
|
|
614
|
|
|
615 /* Declare the variables inside the common block.
|
|
|
616 If the current common block contains any equivalence object, then
|
|
|
617 make a UNION_TYPE node, otherwise RECORD_TYPE. This will let the
|
|
|
618 alias analyzer work well when there is no address overlapping for
|
|
|
619 common variables in the current common block. */
|
|
|
620 if (saw_equiv)
|
|
|
621 union_type = make_node (UNION_TYPE);
|
|
|
622 else
|
|
|
623 union_type = make_node (RECORD_TYPE);
|
|
|
624
|
|
|
625 rli = start_record_layout (union_type);
|
|
|
626 field_link = &TYPE_FIELDS (union_type);
|
|
|
627
|
|
|
628 /* Check for overlapping initializers and replace them with a single,
|
|
|
629 artificial field that contains all the data. */
|
|
|
630 if (saw_equiv)
|
|
|
631 field = get_init_field (head, union_type, &field_init, rli);
|
|
|
632 else
|
|
|
633 field = NULL_TREE;
|
|
|
634
|
|
|
635 if (field != NULL_TREE)
|
|
|
636 {
|
|
|
637 is_init = true;
|
|
|
638 *field_link = field;
|
|
|
639 field_link = &DECL_CHAIN (field);
|
|
|
640 }
|
|
|
641
|
|
|
642 for (s = head; s; s = s->next)
|
|
|
643 {
|
|
|
644 build_field (s, union_type, rli);
|
|
|
645
|
|
|
646 /* Link the field into the type. */
|
|
|
647 *field_link = s->field;
|
|
|
648 field_link = &DECL_CHAIN (s->field);
|
|
|
649
|
|
|
650 /* Has initial value. */
|
|
|
651 if (s->sym->value)
|
|
|
652 is_init = true;
|
|
|
653
|
|
|
654 /* Has SAVE attribute. */
|
|
|
655 if (s->sym->attr.save)
|
|
|
656 is_saved = true;
|
|
|
657 }
|
|
|
658
|
|
|
659 finish_record_layout (rli, true);
|
|
|
660
|
|
|
661 if (com)
|
|
|
662 decl = build_common_decl (com, union_type, is_init);
|
|
|
663 else
|
|
|
664 decl = build_equiv_decl (union_type, is_init, is_saved);
|
|
|
665
|
|
|
666 if (is_init)
|
|
|
667 {
|
|
|
668 tree ctor, tmp;
|
|
|
669 vec<constructor_elt, va_gc> *v = NULL;
|
|
|
670
|
|
|
671 if (field != NULL_TREE && field_init != NULL_TREE)
|
|
|
672 CONSTRUCTOR_APPEND_ELT (v, field, field_init);
|
|
|
673 else
|
|
|
674 for (s = head; s; s = s->next)
|
|
|
675 {
|
|
|
676 if (s->sym->value)
|
|
|
677 {
|
|
|
678 /* Add the initializer for this field. */
|
|
|
679 tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts,
|
|
|
680 TREE_TYPE (s->field),
|
|
|
681 s->sym->attr.dimension,
|
|
|
682 s->sym->attr.pointer
|
|
|
683 || s->sym->attr.allocatable, false);
|
|
|
684
|
|
|
685 CONSTRUCTOR_APPEND_ELT (v, s->field, tmp);
|
|
|
686 }
|
|
|
687 }
|
|
|
688
|
|
|
689 gcc_assert (!v->is_empty ());
|
|
|
690 ctor = build_constructor (union_type, v);
|
|
|
691 TREE_CONSTANT (ctor) = 1;
|
|
|
692 TREE_STATIC (ctor) = 1;
|
|
|
693 DECL_INITIAL (decl) = ctor;
|
|
|
694
|
|
|
695 if (flag_checking)
|
|
|
696 {
|
|
|
697 tree field, value;
|
|
|
698 unsigned HOST_WIDE_INT idx;
|
|
|
699 FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor), idx, field, value)
|
|
|
700 gcc_assert (TREE_CODE (field) == FIELD_DECL);
|
|
|
701 }
|
|
|
702 }
|
|
|
703
|
|
|
704 /* Build component reference for each variable. */
|
|
|
705 for (s = head; s; s = next_s)
|
|
|
706 {
|
|
|
707 tree var_decl;
|
|
|
708
|
|
|
709 var_decl = build_decl (s->sym->declared_at.lb->location,
|
|
|
710 VAR_DECL, DECL_NAME (s->field),
|
|
|
711 TREE_TYPE (s->field));
|
|
|
712 TREE_STATIC (var_decl) = TREE_STATIC (decl);
|
|
|
713 /* Mark the variable as used in order to avoid warnings about
|
|
|
714 unused variables. */
|
|
|
715 TREE_USED (var_decl) = 1;
|
|
|
716 if (s->sym->attr.use_assoc)
|
|
|
717 DECL_IGNORED_P (var_decl) = 1;
|
|
|
718 if (s->sym->attr.target)
|
|
|
719 TREE_ADDRESSABLE (var_decl) = 1;
|
|
|
720 /* Fake variables are not visible from other translation units. */
|
|
|
721 TREE_PUBLIC (var_decl) = 0;
|
|
|
722 gfc_finish_decl_attrs (var_decl, &s->sym->attr);
|
|
|
723
|
|
|
724 /* To preserve identifier names in COMMON, chain to procedure
|
|
|
725 scope unless at top level in a module definition. */
|
|
|
726 if (com
|
|
|
727 && s->sym->ns->proc_name
|
|
|
728 && s->sym->ns->proc_name->attr.flavor == FL_MODULE)
|
|
|
729 var_decl = pushdecl_top_level (var_decl);
|
|
|
730 else
|
|
|
731 gfc_add_decl_to_function (var_decl);
|
|
|
732
|
|
|
733 SET_DECL_VALUE_EXPR (var_decl,
|
|
|
734 fold_build3_loc (input_location, COMPONENT_REF,
|
|
|
735 TREE_TYPE (s->field),
|
|
|
736 decl, s->field, NULL_TREE));
|
|
|
737 DECL_HAS_VALUE_EXPR_P (var_decl) = 1;
|
|
|
738 GFC_DECL_COMMON_OR_EQUIV (var_decl) = 1;
|
|
|
739
|
|
|
740 if (s->sym->attr.assign)
|
|
|
741 {
|
|
|
742 gfc_allocate_lang_decl (var_decl);
|
|
|
743 GFC_DECL_ASSIGN (var_decl) = 1;
|
|
|
744 GFC_DECL_STRING_LEN (var_decl) = GFC_DECL_STRING_LEN (s->field);
|
|
|
745 GFC_DECL_ASSIGN_ADDR (var_decl) = GFC_DECL_ASSIGN_ADDR (s->field);
|
|
|
746 }
|
|
|
747
|
|
|
748 s->sym->backend_decl = var_decl;
|
|
|
749
|
|
|
750 next_s = s->next;
|
|
|
751 free (s);
|
|
|
752 }
|
|
|
753 }
|
|
|
754
|
|
|
755
|
|
|
756 /* Given a symbol, find it in the current segment list. Returns NULL if
|
|
|
757 not found. */
|
|
|
758
|
|
|
759 static segment_info *
|
|
|
760 find_segment_info (gfc_symbol *symbol)
|
|
|
761 {
|
|
|
762 segment_info *n;
|
|
|
763
|
|
|
764 for (n = current_segment; n; n = n->next)
|
|
|
765 {
|
|
|
766 if (n->sym == symbol)
|
|
|
767 return n;
|
|
|
768 }
|
|
|
769
|
|
|
770 return NULL;
|
|
|
771 }
|
|
|
772
|
|
|
773
|
|
|
774 /* Given an expression node, make sure it is a constant integer and return
|
|
|
775 the mpz_t value. */
|
|
|
776
|
|
|
777 static mpz_t *
|
|
|
778 get_mpz (gfc_expr *e)
|
|
|
779 {
|
|
|
780
|
|
|
781 if (e->expr_type != EXPR_CONSTANT)
|
|
|
782 gfc_internal_error ("get_mpz(): Not an integer constant");
|
|
|
783
|
|
|
784 return &e->value.integer;
|
|
|
785 }
|
|
|
786
|
|
|
787
|
|
|
788 /* Given an array specification and an array reference, figure out the
|
|
|
789 array element number (zero based). Bounds and elements are guaranteed
|
|
|
790 to be constants. If something goes wrong we generate an error and
|
|
|
791 return zero. */
|
|
|
792
|
|
|
793 static HOST_WIDE_INT
|
|
|
794 element_number (gfc_array_ref *ar)
|
|
|
795 {
|
|
|
796 mpz_t multiplier, offset, extent, n;
|
|
|
797 gfc_array_spec *as;
|
|
|
798 HOST_WIDE_INT i, rank;
|
|
|
799
|
|
|
800 as = ar->as;
|
|
|
801 rank = as->rank;
|
|
|
802 mpz_init_set_ui (multiplier, 1);
|
|
|
803 mpz_init_set_ui (offset, 0);
|
|
|
804 mpz_init (extent);
|
|
|
805 mpz_init (n);
|
|
|
806
|
|
|
807 for (i = 0; i < rank; i++)
|
|
|
808 {
|
|
|
809 if (ar->dimen_type[i] != DIMEN_ELEMENT)
|
|
|
810 gfc_internal_error ("element_number(): Bad dimension type");
|
|
|
811
|
|
|
812 if (as && as->lower[i])
|
|
|
813 mpz_sub (n, *get_mpz (ar->start[i]), *get_mpz (as->lower[i]));
|
|
|
814 else
|
|
|
815 mpz_sub_ui (n, *get_mpz (ar->start[i]), 1);
|
|
|
816
|
|
|
817 mpz_mul (n, n, multiplier);
|
|
|
818 mpz_add (offset, offset, n);
|
|
|
819
|
|
|
820 if (as && as->upper[i] && as->lower[i])
|
|
|
821 {
|
|
|
822 mpz_sub (extent, *get_mpz (as->upper[i]), *get_mpz (as->lower[i]));
|
|
|
823 mpz_add_ui (extent, extent, 1);
|
|
|
824 }
|
|
|
825 else
|
|
|
826 mpz_set_ui (extent, 0);
|
|
|
827
|
|
|
828 if (mpz_sgn (extent) < 0)
|
|
|
829 mpz_set_ui (extent, 0);
|
|
|
830
|
|
|
831 mpz_mul (multiplier, multiplier, extent);
|
|
|
832 }
|
|
|
833
|
|
|
834 i = mpz_get_ui (offset);
|
|
|
835
|
|
|
836 mpz_clear (multiplier);
|
|
|
837 mpz_clear (offset);
|
|
|
838 mpz_clear (extent);
|
|
|
839 mpz_clear (n);
|
|
|
840
|
|
|
841 return i;
|
|
|
842 }
|
|
|
843
|
|
|
844
|
|
|
845 /* Given a single element of an equivalence list, figure out the offset
|
|
|
846 from the base symbol. For simple variables or full arrays, this is
|
|
|
847 simply zero. For an array element we have to calculate the array
|
|
|
848 element number and multiply by the element size. For a substring we
|
|
|
849 have to calculate the further reference. */
|
|
|
850
|
|
|
851 static HOST_WIDE_INT
|
|
|
852 calculate_offset (gfc_expr *e)
|
|
|
853 {
|
|
|
854 HOST_WIDE_INT n, element_size, offset;
|
|
|
855 gfc_typespec *element_type;
|
|
|
856 gfc_ref *reference;
|
|
|
857
|
|
|
858 offset = 0;
|
|
|
859 element_type = &e->symtree->n.sym->ts;
|
|
|
860
|
|
|
861 for (reference = e->ref; reference; reference = reference->next)
|
|
|
862 switch (reference->type)
|
|
|
863 {
|
|
|
864 case REF_ARRAY:
|
|
|
865 switch (reference->u.ar.type)
|
|
|
866 {
|
|
|
867 case AR_FULL:
|
|
|
868 break;
|
|
|
869
|
|
|
870 case AR_ELEMENT:
|
|
|
871 n = element_number (&reference->u.ar);
|
|
|
872 if (element_type->type == BT_CHARACTER)
|
|
|
873 gfc_conv_const_charlen (element_type->u.cl);
|
|
|
874 element_size =
|
|
|
875 int_size_in_bytes (gfc_typenode_for_spec (element_type));
|
|
|
876 offset += n * element_size;
|
|
|
877 break;
|
|
|
878
|
|
|
879 default:
|
|
|
880 gfc_error ("Bad array reference at %L", &e->where);
|
|
|
881 }
|
|
|
882 break;
|
|
|
883 case REF_SUBSTRING:
|
|
|
884 if (reference->u.ss.start != NULL)
|
|
|
885 offset += mpz_get_ui (*get_mpz (reference->u.ss.start)) - 1;
|
|
|
886 break;
|
|
|
887 default:
|
|
|
888 gfc_error ("Illegal reference type at %L as EQUIVALENCE object",
|
|
|
889 &e->where);
|
|
|
890 }
|
|
|
891 return offset;
|
|
|
892 }
|
|
|
893
|
|
|
894
|
|
|
895 /* Add a new segment_info structure to the current segment. eq1 is already
|
|
|
896 in the list, eq2 is not. */
|
|
|
897
|
|
|
898 static void
|
|
|
899 new_condition (segment_info *v, gfc_equiv *eq1, gfc_equiv *eq2)
|
|
|
900 {
|
|
|
901 HOST_WIDE_INT offset1, offset2;
|
|
|
902 segment_info *a;
|
|
|
903
|
|
|
904 offset1 = calculate_offset (eq1->expr);
|
|
|
905 offset2 = calculate_offset (eq2->expr);
|
|
|
906
|
|
|
907 a = get_segment_info (eq2->expr->symtree->n.sym,
|
|
|
908 v->offset + offset1 - offset2);
|
|
|
909
|
|
|
910 current_segment = add_segments (current_segment, a);
|
|
|
911 }
|
|
|
912
|
|
|
913
|
|
|
914 /* Given two equivalence structures that are both already in the list, make
|
|
|
915 sure that this new condition is not violated, generating an error if it
|
|
|
916 is. */
|
|
|
917
|
|
|
918 static void
|
|
|
919 confirm_condition (segment_info *s1, gfc_equiv *eq1, segment_info *s2,
|
|
|
920 gfc_equiv *eq2)
|
|
|
921 {
|
|
|
922 HOST_WIDE_INT offset1, offset2;
|
|
|
923
|
|
|
924 offset1 = calculate_offset (eq1->expr);
|
|
|
925 offset2 = calculate_offset (eq2->expr);
|
|
|
926
|
|
|
927 if (s1->offset + offset1 != s2->offset + offset2)
|
|
|
928 gfc_error ("Inconsistent equivalence rules involving %qs at %L and "
|
|
|
929 "%qs at %L", s1->sym->name, &s1->sym->declared_at,
|
|
|
930 s2->sym->name, &s2->sym->declared_at);
|
|
|
931 }
|
|
|
932
|
|
|
933
|
|
|
934 /* Process a new equivalence condition. eq1 is know to be in segment f.
|
|
|
935 If eq2 is also present then confirm that the condition holds.
|
|
|
936 Otherwise add a new variable to the segment list. */
|
|
|
937
|
|
|
938 static void
|
|
|
939 add_condition (segment_info *f, gfc_equiv *eq1, gfc_equiv *eq2)
|
|
|
940 {
|
|
|
941 segment_info *n;
|
|
|
942
|
|
|
943 n = find_segment_info (eq2->expr->symtree->n.sym);
|
|
|
944
|
|
|
945 if (n == NULL)
|
|
|
946 new_condition (f, eq1, eq2);
|
|
|
947 else
|
|
|
948 confirm_condition (f, eq1, n, eq2);
|
|
|
949 }
|
|
|
950
|
|
|
951
|
|
|
952 /* Given a segment element, search through the equivalence lists for unused
|
|
|
953 conditions that involve the symbol. Add these rules to the segment. */
|
|
|
954
|
|
|
955 static bool
|
|
|
956 find_equivalence (segment_info *n)
|
|
|
957 {
|
|
|
958 gfc_equiv *e1, *e2, *eq;
|
|
|
959 bool found;
|
|
|
960
|
|
|
961 found = FALSE;
|
|
|
962
|
|
|
963 for (e1 = n->sym->ns->equiv; e1; e1 = e1->next)
|
|
|
964 {
|
|
|
965 eq = NULL;
|
|
|
966
|
|
|
967 /* Search the equivalence list, including the root (first) element
|
|
|
968 for the symbol that owns the segment. */
|
|
|
969 for (e2 = e1; e2; e2 = e2->eq)
|
|
|
970 {
|
|
|
971 if (!e2->used && e2->expr->symtree->n.sym == n->sym)
|
|
|
972 {
|
|
|
973 eq = e2;
|
|
|
974 break;
|
|
|
975 }
|
|
|
976 }
|
|
|
977
|
|
|
978 /* Go to the next root element. */
|
|
|
979 if (eq == NULL)
|
|
|
980 continue;
|
|
|
981
|
|
|
982 eq->used = 1;
|
|
|
983
|
|
|
984 /* Now traverse the equivalence list matching the offsets. */
|
|
|
985 for (e2 = e1; e2; e2 = e2->eq)
|
|
|
986 {
|
|
|
987 if (!e2->used && e2 != eq)
|
|
|
988 {
|
|
|
989 add_condition (n, eq, e2);
|
|
|
990 e2->used = 1;
|
|
|
991 found = TRUE;
|
|
|
992 }
|
|
|
993 }
|
|
|
994 }
|
|
|
995 return found;
|
|
|
996 }
|
|
|
997
|
|
|
998
|
|
|
999 /* Add all symbols equivalenced within a segment. We need to scan the
|
|
|
1000 segment list multiple times to include indirect equivalences. Since
|
|
|
1001 a new segment_info can inserted at the beginning of the segment list,
|
|
|
1002 depending on its offset, we have to force a final pass through the
|
|
|
1003 loop by demanding that completion sees a pass with no matches; i.e.,
|
|
|
1004 all symbols with equiv_built set and no new equivalences found. */
|
|
|
1005
|
|
|
1006 static void
|
|
|
1007 add_equivalences (bool *saw_equiv)
|
|
|
1008 {
|
|
|
1009 segment_info *f;
|
|
|
1010 bool seen_one, more;
|
|
|
1011
|
|
|
1012 seen_one = false;
|
|
|
1013 more = TRUE;
|
|
|
1014 while (more)
|
|
|
1015 {
|
|
|
1016 more = FALSE;
|
|
|
1017 for (f = current_segment; f; f = f->next)
|
|
|
1018 {
|
|
|
1019 if (!f->sym->equiv_built)
|
|
|
1020 {
|
|
|
1021 f->sym->equiv_built = 1;
|
|
|
1022 seen_one = find_equivalence (f);
|
|
|
1023 if (seen_one)
|
|
|
1024 {
|
|
|
1025 *saw_equiv = true;
|
|
|
1026 more = true;
|
|
|
1027 }
|
|
|
1028 }
|
|
|
1029 }
|
|
|
1030 }
|
|
|
1031
|
|
|
1032 /* Add a copy of this segment list to the namespace. */
|
|
|
1033 copy_equiv_list_to_ns (current_segment);
|
|
|
1034 }
|
|
|
1035
|
|
|
1036
|
|
|
1037 /* Returns the offset necessary to properly align the current equivalence.
|
|
|
1038 Sets *palign to the required alignment. */
|
|
|
1039
|
|
|
1040 static HOST_WIDE_INT
|
|
|
1041 align_segment (unsigned HOST_WIDE_INT *palign)
|
|
|
1042 {
|
|
|
1043 segment_info *s;
|
|
|
1044 unsigned HOST_WIDE_INT offset;
|
|
|
1045 unsigned HOST_WIDE_INT max_align;
|
|
|
1046 unsigned HOST_WIDE_INT this_align;
|
|
|
1047 unsigned HOST_WIDE_INT this_offset;
|
|
|
1048
|
|
|
1049 max_align = 1;
|
|
|
1050 offset = 0;
|
|
|
1051 for (s = current_segment; s; s = s->next)
|
|
|
1052 {
|
|
|
1053 this_align = TYPE_ALIGN_UNIT (s->field);
|
|
|
1054 if (s->offset & (this_align - 1))
|
|
|
1055 {
|
|
|
1056 /* Field is misaligned. */
|
|
|
1057 this_offset = this_align - ((s->offset + offset) & (this_align - 1));
|
|
|
1058 if (this_offset & (max_align - 1))
|
|
|
1059 {
|
|
|
1060 /* Aligning this field would misalign a previous field. */
|
|
|
1061 gfc_error ("The equivalence set for variable %qs "
|
|
|
1062 "declared at %L violates alignment requirements",
|
|
|
1063 s->sym->name, &s->sym->declared_at);
|
|
|
1064 }
|
|
|
1065 offset += this_offset;
|
|
|
1066 }
|
|
|
1067 max_align = this_align;
|
|
|
1068 }
|
|
|
1069 if (palign)
|
|
|
1070 *palign = max_align;
|
|
|
1071 return offset;
|
|
|
1072 }
|
|
|
1073
|
|
|
1074
|
|
|
1075 /* Adjust segment offsets by the given amount. */
|
|
|
1076
|
|
|
1077 static void
|
|
|
1078 apply_segment_offset (segment_info *s, HOST_WIDE_INT offset)
|
|
|
1079 {
|
|
|
1080 for (; s; s = s->next)
|
|
|
1081 s->offset += offset;
|
|
|
1082 }
|
|
|
1083
|
|
|
1084
|
|
|
1085 /* Lay out a symbol in a common block. If the symbol has already been seen
|
|
|
1086 then check the location is consistent. Otherwise create segments
|
|
|
1087 for that symbol and all the symbols equivalenced with it. */
|
|
|
1088
|
|
|
1089 /* Translate a single common block. */
|
|
|
1090
|
|
|
1091 static void
|
|
|
1092 translate_common (gfc_common_head *common, gfc_symbol *var_list)
|
|
|
1093 {
|
|
|
1094 gfc_symbol *sym;
|
|
|
1095 segment_info *s;
|
|
|
1096 segment_info *common_segment;
|
|
|
1097 HOST_WIDE_INT offset;
|
|
|
1098 HOST_WIDE_INT current_offset;
|
|
|
1099 unsigned HOST_WIDE_INT align;
|
|
|
1100 bool saw_equiv;
|
|
|
1101
|
|
|
1102 common_segment = NULL;
|
|
|
1103 offset = 0;
|
|
|
1104 current_offset = 0;
|
|
|
1105 align = 1;
|
|
|
1106 saw_equiv = false;
|
|
|
1107
|
|
|
1108 /* Add symbols to the segment. */
|
|
|
1109 for (sym = var_list; sym; sym = sym->common_next)
|
|
|
1110 {
|
|
|
1111 current_segment = common_segment;
|
|
|
1112 s = find_segment_info (sym);
|
|
|
1113
|
|
|
1114 /* Symbol has already been added via an equivalence. Multiple
|
|
|
1115 use associations of the same common block result in equiv_built
|
|
|
1116 being set but no information about the symbol in the segment. */
|
|
|
1117 if (s && sym->equiv_built)
|
|
|
1118 {
|
|
|
1119 /* Ensure the current location is properly aligned. */
|
|
|
1120 align = TYPE_ALIGN_UNIT (s->field);
|
|
|
1121 current_offset = (current_offset + align - 1) &~ (align - 1);
|
|
|
1122
|
|
|
1123 /* Verify that it ended up where we expect it. */
|
|
|
1124 if (s->offset != current_offset)
|
|
|
1125 {
|
|
|
1126 gfc_error ("Equivalence for %qs does not match ordering of "
|
|
|
1127 "COMMON %qs at %L", sym->name,
|
|
|
1128 common->name, &common->where);
|
|
|
1129 }
|
|
|
1130 }
|
|
|
1131 else
|
|
|
1132 {
|
|
|
1133 /* A symbol we haven't seen before. */
|
|
|
1134 s = current_segment = get_segment_info (sym, current_offset);
|
|
|
1135
|
|
|
1136 /* Add all objects directly or indirectly equivalenced with this
|
|
|
1137 symbol. */
|
|
|
1138 add_equivalences (&saw_equiv);
|
|
|
1139
|
|
|
1140 if (current_segment->offset < 0)
|
|
|
1141 gfc_error ("The equivalence set for %qs cause an invalid "
|
|
|
1142 "extension to COMMON %qs at %L", sym->name,
|
|
|
1143 common->name, &common->where);
|
|
|
1144
|
|
|
1145 if (flag_align_commons)
|
|
|
1146 offset = align_segment (&align);
|
|
|
1147
|
|
|
1148 if (offset)
|
|
|
1149 {
|
|
|
1150 /* The required offset conflicts with previous alignment
|
|
|
1151 requirements. Insert padding immediately before this
|
|
|
1152 segment. */
|
|
|
1153 if (warn_align_commons)
|
|
|
1154 {
|
|
|
1155 if (strcmp (common->name, BLANK_COMMON_NAME))
|
|
|
1156 gfc_warning (OPT_Walign_commons,
|
|
|
1157 "Padding of %d bytes required before %qs in "
|
|
|
1158 "COMMON %qs at %L; reorder elements or use "
|
|
|
1159 "-fno-align-commons", (int)offset,
|
|
|
1160 s->sym->name, common->name, &common->where);
|
|
|
1161 else
|
|
|
1162 gfc_warning (OPT_Walign_commons,
|
|
|
1163 "Padding of %d bytes required before %qs in "
|
|
|
1164 "COMMON at %L; reorder elements or use "
|
|
|
1165 "-fno-align-commons", (int)offset,
|
|
|
1166 s->sym->name, &common->where);
|
|
|
1167 }
|
|
|
1168 }
|
|
|
1169
|
|
|
1170 /* Apply the offset to the new segments. */
|
|
|
1171 apply_segment_offset (current_segment, offset);
|
|
|
1172 current_offset += offset;
|
|
|
1173
|
|
|
1174 /* Add the new segments to the common block. */
|
|
|
1175 common_segment = add_segments (common_segment, current_segment);
|
|
|
1176 }
|
|
|
1177
|
|
|
1178 /* The offset of the next common variable. */
|
|
|
1179 current_offset += s->length;
|
|
|
1180 }
|
|
|
1181
|
|
|
1182 if (common_segment == NULL)
|
|
|
1183 {
|
|
|
1184 gfc_error ("COMMON %qs at %L does not exist",
|
|
|
1185 common->name, &common->where);
|
|
|
1186 return;
|
|
|
1187 }
|
|
|
1188
|
|
|
1189 if (common_segment->offset != 0 && warn_align_commons)
|
|
|
1190 {
|
|
|
1191 if (strcmp (common->name, BLANK_COMMON_NAME))
|
|
|
1192 gfc_warning (OPT_Walign_commons,
|
|
|
1193 "COMMON %qs at %L requires %d bytes of padding; "
|
|
|
1194 "reorder elements or use %<-fno-align-commons%>",
|
|
|
1195 common->name, &common->where, (int)common_segment->offset);
|
|
|
1196 else
|
|
|
1197 gfc_warning (OPT_Walign_commons,
|
|
|
1198 "COMMON at %L requires %d bytes of padding; "
|
|
|
1199 "reorder elements or use %<-fno-align-commons%>",
|
|
|
1200 &common->where, (int)common_segment->offset);
|
|
|
1201 }
|
|
|
1202
|
|
|
1203 create_common (common, common_segment, saw_equiv);
|
|
|
1204 }
|
|
|
1205
|
|
|
1206
|
|
|
1207 /* Create a new block for each merged equivalence list. */
|
|
|
1208
|
|
|
1209 static void
|
|
|
1210 finish_equivalences (gfc_namespace *ns)
|
|
|
1211 {
|
|
|
1212 gfc_equiv *z, *y;
|
|
|
1213 gfc_symbol *sym;
|
|
|
1214 gfc_common_head * c;
|
|
|
1215 HOST_WIDE_INT offset;
|
|
|
1216 unsigned HOST_WIDE_INT align;
|
|
|
1217 bool dummy;
|
|
|
1218
|
|
|
1219 for (z = ns->equiv; z; z = z->next)
|
|
|
1220 for (y = z->eq; y; y = y->eq)
|
|
|
1221 {
|
|
|
1222 if (y->used)
|
|
|
1223 continue;
|
|
|
1224 sym = z->expr->symtree->n.sym;
|
|
|
1225 current_segment = get_segment_info (sym, 0);
|
|
|
1226
|
|
|
1227 /* All objects directly or indirectly equivalenced with this
|
|
|
1228 symbol. */
|
|
|
1229 add_equivalences (&dummy);
|
|
|
1230
|
|
|
1231 /* Align the block. */
|
|
|
1232 offset = align_segment (&align);
|
|
|
1233
|
|
|
1234 /* Ensure all offsets are positive. */
|
|
|
1235 offset -= current_segment->offset & ~(align - 1);
|
|
|
1236
|
|
|
1237 apply_segment_offset (current_segment, offset);
|
|
|
1238
|
|
|
1239 /* Create the decl. If this is a module equivalence, it has a
|
|
|
1240 unique name, pointed to by z->module. This is written to a
|
|
|
1241 gfc_common_header to push create_common into using
|
|
|
1242 build_common_decl, so that the equivalence appears as an
|
|
|
1243 external symbol. Otherwise, a local declaration is built using
|
|
|
1244 build_equiv_decl. */
|
|
|
1245 if (z->module)
|
|
|
1246 {
|
|
|
1247 c = gfc_get_common_head ();
|
|
|
1248 /* We've lost the real location, so use the location of the
|
|
|
1249 enclosing procedure. If we're in a BLOCK DATA block, then
|
|
|
1250 use the location in the sym_root. */
|
|
|
1251 if (ns->proc_name)
|
|
|
1252 c->where = ns->proc_name->declared_at;
|
|
|
1253 else if (ns->is_block_data)
|
|
|
1254 c->where = ns->sym_root->n.sym->declared_at;
|
|
|
1255 strcpy (c->name, z->module);
|
|
|
1256 }
|
|
|
1257 else
|
|
|
1258 c = NULL;
|
|
|
1259
|
|
|
1260 create_common (c, current_segment, true);
|
|
|
1261 break;
|
|
|
1262 }
|
|
|
1263 }
|
|
|
1264
|
|
|
1265
|
|
|
1266 /* Work function for translating a named common block. */
|
|
|
1267
|
|
|
1268 static void
|
|
|
1269 named_common (gfc_symtree *st)
|
|
|
1270 {
|
|
|
1271 translate_common (st->n.common, st->n.common->head);
|
|
|
1272 }
|
|
|
1273
|
|
|
1274
|
|
|
1275 /* Translate the common blocks in a namespace. Unlike other variables,
|
|
|
1276 these have to be created before code, because the backend_decl depends
|
|
|
1277 on the rest of the common block. */
|
|
|
1278
|
|
|
1279 void
|
|
|
1280 gfc_trans_common (gfc_namespace *ns)
|
|
|
1281 {
|
|
|
1282 gfc_common_head *c;
|
|
|
1283
|
|
|
1284 /* Translate the blank common block. */
|
|
|
1285 if (ns->blank_common.head != NULL)
|
|
|
1286 {
|
|
|
1287 c = gfc_get_common_head ();
|
|
|
1288 c->where = ns->blank_common.head->common_head->where;
|
|
|
1289 strcpy (c->name, BLANK_COMMON_NAME);
|
|
|
1290 translate_common (c, ns->blank_common.head);
|
|
|
1291 }
|
|
|
1292
|
|
|
1293 /* Translate all named common blocks. */
|
|
|
1294 gfc_traverse_symtree (ns->common_root, named_common);
|
|
|
1295
|
|
|
1296 /* Translate local equivalence. */
|
|
|
1297 finish_equivalences (ns);
|
|
|
1298
|
|
|
1299 /* Commit the newly created symbols for common blocks and module
|
|
|
1300 equivalences. */
|
|
|
1301 gfc_commit_symbols ();
|
|
|
1302 }
|
