]>
Commit | Line | Data |
---|---|---|
6de9cd9a | 1 | /* Common block and equivalence list handling |
6c7a4dfd JJ |
2 | Copyright (C) 2000, 2003, 2004, 2005, 2006 |
3 | Free Software Foundation, Inc. | |
6de9cd9a DN |
4 | Contributed by Canqun Yang <canqun@nudt.edu.cn> |
5 | ||
9fc4d79b | 6 | This file is part of GCC. |
6de9cd9a | 7 | |
9fc4d79b TS |
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 2, or (at your option) any later | |
11 | version. | |
6de9cd9a | 12 | |
9fc4d79b TS |
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 | |
16 | for more details. | |
6de9cd9a DN |
17 | |
18 | You should have received a copy of the GNU General Public License | |
9fc4d79b | 19 | along with GCC; see the file COPYING. If not, write to the Free |
ab57747b KC |
20 | Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA |
21 | 02110-1301, USA. */ | |
6de9cd9a DN |
22 | |
23 | /* The core algorithm is based on Andy Vaught's g95 tree. Also the | |
24 | way to build UNION_TYPE is borrowed from Richard Henderson. | |
25 | ||
26 | Transform common blocks. An integral part of this is processing | |
1f2959f0 | 27 | equivalence variables. Equivalenced variables that are not in a |
6de9cd9a DN |
28 | common block end up in a private block of their own. |
29 | ||
30 | Each common block or local equivalence list is declared as a union. | |
31 | Variables within the block are represented as a field within the | |
32 | block with the proper offset. | |
33 | ||
34 | So if two variables are equivalenced, they just point to a common | |
35 | area in memory. | |
36 | ||
37 | Mathematically, laying out an equivalence block is equivalent to | |
38 | solving a linear system of equations. The matrix is usually a | |
39 | sparse matrix in which each row contains all zero elements except | |
40 | for a +1 and a -1, a sort of a generalized Vandermonde matrix. The | |
41 | matrix is usually block diagonal. The system can be | |
42 | overdetermined, underdetermined or have a unique solution. If the | |
43 | system is inconsistent, the program is not standard conforming. | |
44 | The solution vector is integral, since all of the pivots are +1 or -1. | |
45 | ||
46 | How we lay out an equivalence block is a little less complicated. | |
47 | In an equivalence list with n elements, there are n-1 conditions to | |
48 | be satisfied. The conditions partition the variables into what we | |
49 | will call segments. If A and B are equivalenced then A and B are | |
50 | in the same segment. If B and C are equivalenced as well, then A, | |
51 | B and C are in a segment and so on. Each segment is a block of | |
52 | memory that has one or more variables equivalenced in some way. A | |
53 | common block is made up of a series of segments that are joined one | |
54 | after the other. In the linear system, a segment is a block | |
55 | diagonal. | |
56 | ||
57 | To lay out a segment we first start with some variable and | |
58 | determine its length. The first variable is assumed to start at | |
59 | offset one and extends to however long it is. We then traverse the | |
60 | list of equivalences to find an unused condition that involves at | |
61 | least one of the variables currently in the segment. | |
62 | ||
63 | Each equivalence condition amounts to the condition B+b=C+c where B | |
64 | and C are the offsets of the B and C variables, and b and c are | |
65 | constants which are nonzero for array elements, substrings or | |
66 | structure components. So for | |
67 | ||
68 | EQUIVALENCE(B(2), C(3)) | |
69 | we have | |
70 | B + 2*size of B's elements = C + 3*size of C's elements. | |
71 | ||
72 | If B and C are known we check to see if the condition already | |
73 | holds. If B is known we can solve for C. Since we know the length | |
74 | of C, we can see if the minimum and maximum extents of the segment | |
75 | are affected. Eventually, we make a full pass through the | |
76 | equivalence list without finding any new conditions and the segment | |
77 | is fully specified. | |
78 | ||
79 | At this point, the segment is added to the current common block. | |
80 | Since we know the minimum extent of the segment, everything in the | |
81 | segment is translated to its position in the common block. The | |
82 | usual case here is that there are no equivalence statements and the | |
83 | common block is series of segments with one variable each, which is | |
84 | a diagonal matrix in the matrix formulation. | |
85 | ||
5291e69a PB |
86 | Each segment is described by a chain of segment_info structures. Each |
87 | segment_info structure describes the extents of a single varible within | |
88 | the segment. This list is maintained in the order the elements are | |
89 | positioned withing the segment. If two elements have the same starting | |
90 | offset the smaller will come first. If they also have the same size their | |
91 | ordering is undefined. | |
92 | ||
6de9cd9a DN |
93 | Once all common blocks have been created, the list of equivalences |
94 | is examined for still-unused equivalence conditions. We create a | |
95 | block for each merged equivalence list. */ | |
96 | ||
97 | #include "config.h" | |
98 | #include "system.h" | |
99 | #include "coretypes.h" | |
6c7a4dfd | 100 | #include "target.h" |
6de9cd9a DN |
101 | #include "tree.h" |
102 | #include "toplev.h" | |
103 | #include "tm.h" | |
25f2dfd3 | 104 | #include "rtl.h" |
6de9cd9a DN |
105 | #include "gfortran.h" |
106 | #include "trans.h" | |
107 | #include "trans-types.h" | |
108 | #include "trans-const.h" | |
109 | ||
110 | ||
49de9e73 | 111 | /* Holds a single variable in an equivalence set. */ |
6de9cd9a DN |
112 | typedef struct segment_info |
113 | { | |
114 | gfc_symbol *sym; | |
5291e69a PB |
115 | HOST_WIDE_INT offset; |
116 | HOST_WIDE_INT length; | |
ad6e2a18 | 117 | /* This will contain the field type until the field is created. */ |
a8a6b603 | 118 | tree field; |
6de9cd9a DN |
119 | struct segment_info *next; |
120 | } segment_info; | |
121 | ||
832ef1ce | 122 | static segment_info * current_segment; |
6de9cd9a DN |
123 | static gfc_namespace *gfc_common_ns = NULL; |
124 | ||
61321991 | 125 | |
ad6e2a18 TS |
126 | /* Make a segment_info based on a symbol. */ |
127 | ||
128 | static segment_info * | |
129 | get_segment_info (gfc_symbol * sym, HOST_WIDE_INT offset) | |
130 | { | |
131 | segment_info *s; | |
132 | ||
133 | /* Make sure we've got the character length. */ | |
134 | if (sym->ts.type == BT_CHARACTER) | |
135 | gfc_conv_const_charlen (sym->ts.cl); | |
136 | ||
137 | /* Create the segment_info and fill it in. */ | |
138 | s = (segment_info *) gfc_getmem (sizeof (segment_info)); | |
139 | s->sym = sym; | |
13795658 | 140 | /* We will use this type when building the segment aggregate type. */ |
ad6e2a18 TS |
141 | s->field = gfc_sym_type (sym); |
142 | s->length = int_size_in_bytes (s->field); | |
143 | s->offset = offset; | |
144 | ||
145 | return s; | |
146 | } | |
147 | ||
61321991 PT |
148 | |
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. */ | |
152 | ||
153 | static void | |
154 | copy_equiv_list_to_ns (segment_info *c) | |
155 | { | |
156 | segment_info *f; | |
157 | gfc_equiv_info *s; | |
158 | gfc_equiv_list *l; | |
159 | ||
160 | l = (gfc_equiv_list *) gfc_getmem (sizeof (gfc_equiv_list)); | |
161 | ||
162 | l->next = c->sym->ns->equiv_lists; | |
163 | c->sym->ns->equiv_lists = l; | |
164 | ||
165 | for (f = c; f; f = f->next) | |
166 | { | |
167 | s = (gfc_equiv_info *) gfc_getmem (sizeof (gfc_equiv_info)); | |
168 | s->next = l->equiv; | |
169 | l->equiv = s; | |
170 | s->sym = f->sym; | |
171 | s->offset = f->offset; | |
172 | } | |
173 | } | |
174 | ||
175 | ||
a8a6b603 | 176 | /* Add combine segment V and segment LIST. */ |
5291e69a PB |
177 | |
178 | static segment_info * | |
179 | add_segments (segment_info *list, segment_info *v) | |
180 | { | |
181 | segment_info *s; | |
182 | segment_info *p; | |
183 | segment_info *next; | |
a8a6b603 | 184 | |
5291e69a PB |
185 | p = NULL; |
186 | s = list; | |
187 | ||
188 | while (v) | |
189 | { | |
190 | /* Find the location of the new element. */ | |
191 | while (s) | |
192 | { | |
193 | if (v->offset < s->offset) | |
194 | break; | |
195 | if (v->offset == s->offset | |
196 | && v->length <= s->length) | |
197 | break; | |
198 | ||
199 | p = s; | |
200 | s = s->next; | |
201 | } | |
202 | ||
203 | /* Insert the new element in between p and s. */ | |
204 | next = v->next; | |
205 | v->next = s; | |
206 | if (p == NULL) | |
207 | list = v; | |
208 | else | |
209 | p->next = v; | |
210 | ||
211 | p = v; | |
212 | v = next; | |
213 | } | |
a8a6b603 | 214 | |
5291e69a PB |
215 | return list; |
216 | } | |
217 | ||
6de9cd9a DN |
218 | /* Construct mangled common block name from symbol name. */ |
219 | ||
220 | static tree | |
9056bd70 | 221 | gfc_sym_mangled_common_id (const char *name) |
6de9cd9a DN |
222 | { |
223 | int has_underscore; | |
9056bd70 | 224 | char mangled_name[GFC_MAX_MANGLED_SYMBOL_LEN + 1]; |
6de9cd9a | 225 | |
9056bd70 TS |
226 | if (strcmp (name, BLANK_COMMON_NAME) == 0) |
227 | return get_identifier (name); | |
a8a6b603 | 228 | |
6de9cd9a DN |
229 | if (gfc_option.flag_underscoring) |
230 | { | |
9056bd70 | 231 | has_underscore = strchr (name, '_') != 0; |
6de9cd9a | 232 | if (gfc_option.flag_second_underscore && has_underscore) |
9056bd70 | 233 | snprintf (mangled_name, sizeof mangled_name, "%s__", name); |
6de9cd9a | 234 | else |
9056bd70 | 235 | snprintf (mangled_name, sizeof mangled_name, "%s_", name); |
a8a6b603 | 236 | |
9056bd70 | 237 | return get_identifier (mangled_name); |
6de9cd9a DN |
238 | } |
239 | else | |
9056bd70 | 240 | return get_identifier (name); |
6de9cd9a DN |
241 | } |
242 | ||
243 | ||
ad6e2a18 | 244 | /* Build a field declaration for a common variable or a local equivalence |
6de9cd9a DN |
245 | object. */ |
246 | ||
ad6e2a18 | 247 | static void |
6de9cd9a DN |
248 | build_field (segment_info *h, tree union_type, record_layout_info rli) |
249 | { | |
ad6e2a18 TS |
250 | tree field; |
251 | tree name; | |
6de9cd9a | 252 | HOST_WIDE_INT offset = h->offset; |
5291e69a | 253 | unsigned HOST_WIDE_INT desired_align, known_align; |
6de9cd9a | 254 | |
ad6e2a18 TS |
255 | name = get_identifier (h->sym->name); |
256 | field = build_decl (FIELD_DECL, name, h->field); | |
c8cc8542 | 257 | gfc_set_decl_location (field, &h->sym->declared_at); |
6de9cd9a DN |
258 | known_align = (offset & -offset) * BITS_PER_UNIT; |
259 | if (known_align == 0 || known_align > BIGGEST_ALIGNMENT) | |
260 | known_align = BIGGEST_ALIGNMENT; | |
261 | ||
262 | desired_align = update_alignment_for_field (rli, field, known_align); | |
263 | if (desired_align > known_align) | |
264 | DECL_PACKED (field) = 1; | |
265 | ||
266 | DECL_FIELD_CONTEXT (field) = union_type; | |
267 | DECL_FIELD_OFFSET (field) = size_int (offset); | |
268 | DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node; | |
269 | SET_DECL_OFFSET_ALIGN (field, known_align); | |
270 | ||
271 | rli->offset = size_binop (MAX_EXPR, rli->offset, | |
272 | size_binop (PLUS_EXPR, | |
273 | DECL_FIELD_OFFSET (field), | |
274 | DECL_SIZE_UNIT (field))); | |
ce2df7c6 | 275 | /* If this field is assigned to a label, we create another two variables. |
81871c2a | 276 | One will hold the address of target label or format label. The other will |
ce2df7c6 FW |
277 | hold the length of format label string. */ |
278 | if (h->sym->attr.assign) | |
279 | { | |
280 | tree len; | |
281 | tree addr; | |
282 | ||
283 | gfc_allocate_lang_decl (field); | |
284 | GFC_DECL_ASSIGN (field) = 1; | |
285 | len = gfc_create_var_np (gfc_charlen_type_node,h->sym->name); | |
286 | addr = gfc_create_var_np (pvoid_type_node, h->sym->name); | |
287 | TREE_STATIC (len) = 1; | |
288 | TREE_STATIC (addr) = 1; | |
289 | DECL_INITIAL (len) = build_int_cst (NULL_TREE, -2); | |
290 | gfc_set_decl_location (len, &h->sym->declared_at); | |
291 | gfc_set_decl_location (addr, &h->sym->declared_at); | |
292 | GFC_DECL_STRING_LEN (field) = pushdecl_top_level (len); | |
293 | GFC_DECL_ASSIGN_ADDR (field) = pushdecl_top_level (addr); | |
294 | } | |
295 | ||
ad6e2a18 | 296 | h->field = field; |
6de9cd9a DN |
297 | } |
298 | ||
299 | ||
300 | /* Get storage for local equivalence. */ | |
301 | ||
302 | static tree | |
57f0d086 | 303 | build_equiv_decl (tree union_type, bool is_init, bool is_saved) |
6de9cd9a DN |
304 | { |
305 | tree decl; | |
bae88af6 TS |
306 | char name[15]; |
307 | static int serial = 0; | |
5291e69a PB |
308 | |
309 | if (is_init) | |
310 | { | |
311 | decl = gfc_create_var (union_type, "equiv"); | |
312 | TREE_STATIC (decl) = 1; | |
6c7a4dfd | 313 | GFC_DECL_COMMON_OR_EQUIV (decl) = 1; |
5291e69a PB |
314 | return decl; |
315 | } | |
316 | ||
bae88af6 TS |
317 | snprintf (name, sizeof (name), "equiv.%d", serial++); |
318 | decl = build_decl (VAR_DECL, get_identifier (name), union_type); | |
6de9cd9a | 319 | DECL_ARTIFICIAL (decl) = 1; |
bae88af6 | 320 | DECL_IGNORED_P (decl) = 1; |
6de9cd9a | 321 | |
57f0d086 JJ |
322 | if (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)) |
323 | || is_saved) | |
bae88af6 | 324 | TREE_STATIC (decl) = 1; |
6de9cd9a DN |
325 | |
326 | TREE_ADDRESSABLE (decl) = 1; | |
327 | TREE_USED (decl) = 1; | |
6c7a4dfd | 328 | GFC_DECL_COMMON_OR_EQUIV (decl) = 1; |
c8cc8542 PB |
329 | |
330 | /* The source location has been lost, and doesn't really matter. | |
331 | We need to set it to something though. */ | |
332 | gfc_set_decl_location (decl, &gfc_current_locus); | |
333 | ||
6de9cd9a DN |
334 | gfc_add_decl_to_function (decl); |
335 | ||
336 | return decl; | |
337 | } | |
338 | ||
339 | ||
340 | /* Get storage for common block. */ | |
341 | ||
342 | static tree | |
53814b8f | 343 | build_common_decl (gfc_common_head *com, tree union_type, bool is_init) |
6de9cd9a DN |
344 | { |
345 | gfc_symbol *common_sym; | |
346 | tree decl; | |
347 | ||
348 | /* Create a namespace to store symbols for common blocks. */ | |
349 | if (gfc_common_ns == NULL) | |
0366dfe9 | 350 | gfc_common_ns = gfc_get_namespace (NULL, 0); |
6de9cd9a | 351 | |
53814b8f | 352 | gfc_get_symbol (com->name, gfc_common_ns, &common_sym); |
6de9cd9a DN |
353 | decl = common_sym->backend_decl; |
354 | ||
355 | /* Update the size of this common block as needed. */ | |
356 | if (decl != NULL_TREE) | |
357 | { | |
5291e69a | 358 | tree size = TYPE_SIZE_UNIT (union_type); |
6de9cd9a DN |
359 | if (tree_int_cst_lt (DECL_SIZE_UNIT (decl), size)) |
360 | { | |
361 | /* Named common blocks of the same name shall be of the same size | |
362 | in all scoping units of a program in which they appear, but | |
363 | blank common blocks may be of different sizes. */ | |
53814b8f | 364 | if (strcmp (com->name, BLANK_COMMON_NAME)) |
a8a6b603 | 365 | gfc_warning ("Named COMMON block '%s' at %L shall be of the " |
53814b8f | 366 | "same size", com->name, &com->where); |
6de9cd9a DN |
367 | DECL_SIZE_UNIT (decl) = size; |
368 | } | |
369 | } | |
370 | ||
371 | /* If this common block has been declared in a previous program unit, | |
372 | and either it is already initialized or there is no new initialization | |
373 | for it, just return. */ | |
374 | if ((decl != NULL_TREE) && (!is_init || DECL_INITIAL (decl))) | |
375 | return decl; | |
376 | ||
377 | /* If there is no backend_decl for the common block, build it. */ | |
378 | if (decl == NULL_TREE) | |
379 | { | |
53814b8f TS |
380 | decl = build_decl (VAR_DECL, get_identifier (com->name), union_type); |
381 | SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_common_id (com->name)); | |
6de9cd9a DN |
382 | TREE_PUBLIC (decl) = 1; |
383 | TREE_STATIC (decl) = 1; | |
384 | DECL_ALIGN (decl) = BIGGEST_ALIGNMENT; | |
385 | DECL_USER_ALIGN (decl) = 0; | |
6c7a4dfd | 386 | GFC_DECL_COMMON_OR_EQUIV (decl) = 1; |
5291e69a | 387 | |
c8cc8542 PB |
388 | gfc_set_decl_location (decl, &com->where); |
389 | ||
6c7a4dfd JJ |
390 | if (com->threadprivate && targetm.have_tls) |
391 | DECL_TLS_MODEL (decl) = decl_default_tls_model (decl); | |
392 | ||
5291e69a PB |
393 | /* Place the back end declaration for this common block in |
394 | GLOBAL_BINDING_LEVEL. */ | |
395 | common_sym->backend_decl = pushdecl_top_level (decl); | |
6de9cd9a DN |
396 | } |
397 | ||
398 | /* Has no initial values. */ | |
399 | if (!is_init) | |
400 | { | |
401 | DECL_INITIAL (decl) = NULL_TREE; | |
402 | DECL_COMMON (decl) = 1; | |
403 | DECL_DEFER_OUTPUT (decl) = 1; | |
6de9cd9a DN |
404 | } |
405 | else | |
406 | { | |
407 | DECL_INITIAL (decl) = error_mark_node; | |
408 | DECL_COMMON (decl) = 0; | |
409 | DECL_DEFER_OUTPUT (decl) = 0; | |
6de9cd9a DN |
410 | } |
411 | return decl; | |
412 | } | |
413 | ||
414 | ||
415 | /* Declare memory for the common block or local equivalence, and create | |
416 | backend declarations for all of the elements. */ | |
417 | ||
418 | static void | |
a3122424 | 419 | create_common (gfc_common_head *com, segment_info * head, bool saw_equiv) |
a8a6b603 TS |
420 | { |
421 | segment_info *s, *next_s; | |
6de9cd9a DN |
422 | tree union_type; |
423 | tree *field_link; | |
424 | record_layout_info rli; | |
425 | tree decl; | |
426 | bool is_init = false; | |
57f0d086 | 427 | bool is_saved = false; |
6de9cd9a | 428 | |
a3122424 CY |
429 | /* Declare the variables inside the common block. |
430 | If the current common block contains any equivalence object, then | |
431 | make a UNION_TYPE node, otherwise RECORD_TYPE. This will let the | |
432 | alias analyzer work well when there is no address overlapping for | |
433 | common variables in the current common block. */ | |
434 | if (saw_equiv) | |
435 | union_type = make_node (UNION_TYPE); | |
436 | else | |
437 | union_type = make_node (RECORD_TYPE); | |
438 | ||
6de9cd9a DN |
439 | rli = start_record_layout (union_type); |
440 | field_link = &TYPE_FIELDS (union_type); | |
441 | ||
832ef1ce | 442 | for (s = head; s; s = s->next) |
6de9cd9a | 443 | { |
a8a6b603 | 444 | build_field (s, union_type, rli); |
6de9cd9a DN |
445 | |
446 | /* Link the field into the type. */ | |
a8a6b603 TS |
447 | *field_link = s->field; |
448 | field_link = &TREE_CHAIN (s->field); | |
ad6e2a18 | 449 | |
a8a6b603 TS |
450 | /* Has initial value. */ |
451 | if (s->sym->value) | |
6de9cd9a | 452 | is_init = true; |
57f0d086 JJ |
453 | |
454 | /* Has SAVE attribute. */ | |
455 | if (s->sym->attr.save) | |
456 | is_saved = true; | |
6de9cd9a DN |
457 | } |
458 | finish_record_layout (rli, true); | |
459 | ||
9056bd70 | 460 | if (com) |
53814b8f | 461 | decl = build_common_decl (com, union_type, is_init); |
6de9cd9a | 462 | else |
57f0d086 | 463 | decl = build_equiv_decl (union_type, is_init, is_saved); |
6de9cd9a | 464 | |
5291e69a PB |
465 | if (is_init) |
466 | { | |
4038c495 | 467 | tree ctor, tmp; |
5291e69a | 468 | HOST_WIDE_INT offset = 0; |
4038c495 | 469 | VEC(constructor_elt,gc) *v = NULL; |
5291e69a | 470 | |
832ef1ce | 471 | for (s = head; s; s = s->next) |
5291e69a | 472 | { |
a8a6b603 | 473 | if (s->sym->value) |
5291e69a | 474 | { |
a8a6b603 | 475 | if (s->offset < offset) |
5291e69a PB |
476 | { |
477 | /* We have overlapping initializers. It could either be | |
1f2959f0 | 478 | partially initialized arrays (legal), or the user |
5291e69a PB |
479 | specified multiple initial values (illegal). |
480 | We don't implement this yet, so bail out. */ | |
481 | gfc_todo_error ("Initialization of overlapping variables"); | |
482 | } | |
597073ac PB |
483 | /* Add the initializer for this field. */ |
484 | tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts, | |
485 | TREE_TYPE (s->field), s->sym->attr.dimension, | |
486 | s->sym->attr.pointer || s->sym->attr.allocatable); | |
4038c495 GB |
487 | |
488 | CONSTRUCTOR_APPEND_ELT (v, s->field, tmp); | |
a8a6b603 | 489 | offset = s->offset + s->length; |
5291e69a PB |
490 | } |
491 | } | |
4038c495 GB |
492 | gcc_assert (!VEC_empty (constructor_elt, v)); |
493 | ctor = build_constructor (union_type, v); | |
5291e69a PB |
494 | TREE_CONSTANT (ctor) = 1; |
495 | TREE_INVARIANT (ctor) = 1; | |
496 | TREE_STATIC (ctor) = 1; | |
497 | DECL_INITIAL (decl) = ctor; | |
498 | ||
499 | #ifdef ENABLE_CHECKING | |
4038c495 GB |
500 | { |
501 | tree field, value; | |
502 | unsigned HOST_WIDE_INT idx; | |
503 | FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor), idx, field, value) | |
504 | gcc_assert (TREE_CODE (field) == FIELD_DECL); | |
505 | } | |
5291e69a PB |
506 | #endif |
507 | } | |
508 | ||
6de9cd9a | 509 | /* Build component reference for each variable. */ |
832ef1ce | 510 | for (s = head; s; s = next_s) |
6de9cd9a | 511 | { |
81871c2a JJ |
512 | tree var_decl; |
513 | ||
514 | var_decl = build_decl (VAR_DECL, DECL_NAME (s->field), | |
515 | TREE_TYPE (s->field)); | |
516 | gfc_set_decl_location (var_decl, &s->sym->declared_at); | |
517 | TREE_PUBLIC (var_decl) = TREE_PUBLIC (decl); | |
518 | TREE_STATIC (var_decl) = TREE_STATIC (decl); | |
519 | TREE_USED (var_decl) = TREE_USED (decl); | |
520 | if (s->sym->attr.target) | |
521 | TREE_ADDRESSABLE (var_decl) = 1; | |
522 | /* This is a fake variable just for debugging purposes. */ | |
523 | TREE_ASM_WRITTEN (var_decl) = 1; | |
524 | ||
525 | if (com) | |
526 | var_decl = pushdecl_top_level (var_decl); | |
527 | else | |
528 | gfc_add_decl_to_function (var_decl); | |
529 | ||
530 | SET_DECL_VALUE_EXPR (var_decl, | |
531 | build3 (COMPONENT_REF, TREE_TYPE (s->field), | |
532 | decl, s->field, NULL_TREE)); | |
533 | DECL_HAS_VALUE_EXPR_P (var_decl) = 1; | |
6c7a4dfd | 534 | GFC_DECL_COMMON_OR_EQUIV (var_decl) = 1; |
81871c2a JJ |
535 | |
536 | if (s->sym->attr.assign) | |
537 | { | |
538 | gfc_allocate_lang_decl (var_decl); | |
539 | GFC_DECL_ASSIGN (var_decl) = 1; | |
540 | GFC_DECL_STRING_LEN (var_decl) = GFC_DECL_STRING_LEN (s->field); | |
541 | GFC_DECL_ASSIGN_ADDR (var_decl) = GFC_DECL_ASSIGN_ADDR (s->field); | |
542 | } | |
543 | ||
544 | s->sym->backend_decl = var_decl; | |
6de9cd9a | 545 | |
a8a6b603 TS |
546 | next_s = s->next; |
547 | gfc_free (s); | |
6de9cd9a | 548 | } |
a8a6b603 | 549 | } |
6de9cd9a DN |
550 | |
551 | ||
552 | /* Given a symbol, find it in the current segment list. Returns NULL if | |
a8a6b603 | 553 | not found. */ |
6de9cd9a | 554 | |
a8a6b603 | 555 | static segment_info * |
6de9cd9a | 556 | find_segment_info (gfc_symbol *symbol) |
a8a6b603 | 557 | { |
6de9cd9a DN |
558 | segment_info *n; |
559 | ||
560 | for (n = current_segment; n; n = n->next) | |
5291e69a PB |
561 | { |
562 | if (n->sym == symbol) | |
563 | return n; | |
564 | } | |
6de9cd9a | 565 | |
a8a6b603 TS |
566 | return NULL; |
567 | } | |
6de9cd9a DN |
568 | |
569 | ||
6de9cd9a | 570 | /* Given an expression node, make sure it is a constant integer and return |
a8a6b603 | 571 | the mpz_t value. */ |
6de9cd9a | 572 | |
a8a6b603 TS |
573 | static mpz_t * |
574 | get_mpz (gfc_expr *e) | |
6de9cd9a | 575 | { |
a8a6b603 TS |
576 | |
577 | if (e->expr_type != EXPR_CONSTANT) | |
6de9cd9a DN |
578 | gfc_internal_error ("get_mpz(): Not an integer constant"); |
579 | ||
a8a6b603 TS |
580 | return &e->value.integer; |
581 | } | |
6de9cd9a DN |
582 | |
583 | ||
584 | /* Given an array specification and an array reference, figure out the | |
585 | array element number (zero based). Bounds and elements are guaranteed | |
586 | to be constants. If something goes wrong we generate an error and | |
a8a6b603 | 587 | return zero. */ |
6de9cd9a | 588 | |
5291e69a | 589 | static HOST_WIDE_INT |
6de9cd9a | 590 | element_number (gfc_array_ref *ar) |
a8a6b603 TS |
591 | { |
592 | mpz_t multiplier, offset, extent, n; | |
6de9cd9a | 593 | gfc_array_spec *as; |
a8a6b603 | 594 | HOST_WIDE_INT i, rank; |
6de9cd9a DN |
595 | |
596 | as = ar->as; | |
597 | rank = as->rank; | |
598 | mpz_init_set_ui (multiplier, 1); | |
599 | mpz_init_set_ui (offset, 0); | |
600 | mpz_init (extent); | |
a8a6b603 | 601 | mpz_init (n); |
6de9cd9a | 602 | |
a8a6b603 | 603 | for (i = 0; i < rank; i++) |
6de9cd9a | 604 | { |
a8a6b603 | 605 | if (ar->dimen_type[i] != DIMEN_ELEMENT) |
6de9cd9a DN |
606 | gfc_internal_error ("element_number(): Bad dimension type"); |
607 | ||
a8a6b603 | 608 | mpz_sub (n, *get_mpz (ar->start[i]), *get_mpz (as->lower[i])); |
6de9cd9a | 609 | |
a8a6b603 TS |
610 | mpz_mul (n, n, multiplier); |
611 | mpz_add (offset, offset, n); | |
6de9cd9a | 612 | |
a8a6b603 | 613 | mpz_sub (extent, *get_mpz (as->upper[i]), *get_mpz (as->lower[i])); |
6de9cd9a DN |
614 | mpz_add_ui (extent, extent, 1); |
615 | ||
616 | if (mpz_sgn (extent) < 0) | |
617 | mpz_set_ui (extent, 0); | |
618 | ||
619 | mpz_mul (multiplier, multiplier, extent); | |
620 | } | |
621 | ||
a8a6b603 | 622 | i = mpz_get_ui (offset); |
6de9cd9a DN |
623 | |
624 | mpz_clear (multiplier); | |
625 | mpz_clear (offset); | |
626 | mpz_clear (extent); | |
a8a6b603 | 627 | mpz_clear (n); |
6de9cd9a | 628 | |
a8a6b603 | 629 | return i; |
6de9cd9a DN |
630 | } |
631 | ||
632 | ||
633 | /* Given a single element of an equivalence list, figure out the offset | |
634 | from the base symbol. For simple variables or full arrays, this is | |
635 | simply zero. For an array element we have to calculate the array | |
636 | element number and multiply by the element size. For a substring we | |
637 | have to calculate the further reference. */ | |
638 | ||
5291e69a | 639 | static HOST_WIDE_INT |
a8a6b603 | 640 | calculate_offset (gfc_expr *e) |
6de9cd9a | 641 | { |
a8a6b603 | 642 | HOST_WIDE_INT n, element_size, offset; |
6de9cd9a DN |
643 | gfc_typespec *element_type; |
644 | gfc_ref *reference; | |
645 | ||
646 | offset = 0; | |
a8a6b603 | 647 | element_type = &e->symtree->n.sym->ts; |
6de9cd9a | 648 | |
a8a6b603 | 649 | for (reference = e->ref; reference; reference = reference->next) |
6de9cd9a DN |
650 | switch (reference->type) |
651 | { | |
652 | case REF_ARRAY: | |
653 | switch (reference->u.ar.type) | |
654 | { | |
655 | case AR_FULL: | |
656 | break; | |
657 | ||
658 | case AR_ELEMENT: | |
a8a6b603 | 659 | n = element_number (&reference->u.ar); |
6de9cd9a DN |
660 | if (element_type->type == BT_CHARACTER) |
661 | gfc_conv_const_charlen (element_type->cl); | |
662 | element_size = | |
663 | int_size_in_bytes (gfc_typenode_for_spec (element_type)); | |
a8a6b603 | 664 | offset += n * element_size; |
6de9cd9a DN |
665 | break; |
666 | ||
667 | default: | |
a8a6b603 | 668 | gfc_error ("Bad array reference at %L", &e->where); |
6de9cd9a DN |
669 | } |
670 | break; | |
671 | case REF_SUBSTRING: | |
672 | if (reference->u.ss.start != NULL) | |
673 | offset += mpz_get_ui (*get_mpz (reference->u.ss.start)) - 1; | |
674 | break; | |
675 | default: | |
5291e69a | 676 | gfc_error ("Illegal reference type at %L as EQUIVALENCE object", |
a8a6b603 TS |
677 | &e->where); |
678 | } | |
6de9cd9a DN |
679 | return offset; |
680 | } | |
681 | ||
a8a6b603 | 682 | |
5291e69a PB |
683 | /* Add a new segment_info structure to the current segment. eq1 is already |
684 | in the list, eq2 is not. */ | |
6de9cd9a DN |
685 | |
686 | static void | |
687 | new_condition (segment_info *v, gfc_equiv *eq1, gfc_equiv *eq2) | |
688 | { | |
5291e69a | 689 | HOST_WIDE_INT offset1, offset2; |
6de9cd9a | 690 | segment_info *a; |
a8a6b603 | 691 | |
6de9cd9a DN |
692 | offset1 = calculate_offset (eq1->expr); |
693 | offset2 = calculate_offset (eq2->expr); | |
694 | ||
ad6e2a18 TS |
695 | a = get_segment_info (eq2->expr->symtree->n.sym, |
696 | v->offset + offset1 - offset2); | |
6de9cd9a | 697 | |
5291e69a | 698 | current_segment = add_segments (current_segment, a); |
6de9cd9a DN |
699 | } |
700 | ||
701 | ||
702 | /* Given two equivalence structures that are both already in the list, make | |
703 | sure that this new condition is not violated, generating an error if it | |
704 | is. */ | |
705 | ||
706 | static void | |
a8a6b603 | 707 | confirm_condition (segment_info *s1, gfc_equiv *eq1, segment_info *s2, |
6de9cd9a DN |
708 | gfc_equiv *eq2) |
709 | { | |
5291e69a | 710 | HOST_WIDE_INT offset1, offset2; |
6de9cd9a DN |
711 | |
712 | offset1 = calculate_offset (eq1->expr); | |
713 | offset2 = calculate_offset (eq2->expr); | |
a8a6b603 TS |
714 | |
715 | if (s1->offset + offset1 != s2->offset + offset2) | |
5291e69a | 716 | gfc_error ("Inconsistent equivalence rules involving '%s' at %L and " |
a8a6b603 TS |
717 | "'%s' at %L", s1->sym->name, &s1->sym->declared_at, |
718 | s2->sym->name, &s2->sym->declared_at); | |
719 | } | |
720 | ||
6de9cd9a | 721 | |
5291e69a PB |
722 | /* Process a new equivalence condition. eq1 is know to be in segment f. |
723 | If eq2 is also present then confirm that the condition holds. | |
724 | Otherwise add a new variable to the segment list. */ | |
6de9cd9a DN |
725 | |
726 | static void | |
5291e69a | 727 | add_condition (segment_info *f, gfc_equiv *eq1, gfc_equiv *eq2) |
6de9cd9a | 728 | { |
5291e69a | 729 | segment_info *n; |
6de9cd9a | 730 | |
5291e69a | 731 | n = find_segment_info (eq2->expr->symtree->n.sym); |
6de9cd9a | 732 | |
5291e69a PB |
733 | if (n == NULL) |
734 | new_condition (f, eq1, eq2); | |
735 | else | |
736 | confirm_condition (f, eq1, n, eq2); | |
6de9cd9a DN |
737 | } |
738 | ||
739 | ||
5291e69a | 740 | /* Given a segment element, search through the equivalence lists for unused |
30aabb86 PT |
741 | conditions that involve the symbol. Add these rules to the segment. */ |
742 | ||
5291e69a | 743 | static bool |
a8a6b603 | 744 | find_equivalence (segment_info *n) |
6de9cd9a | 745 | { |
30aabb86 | 746 | gfc_equiv *e1, *e2, *eq; |
5291e69a | 747 | bool found; |
30aabb86 | 748 | |
5291e69a | 749 | found = FALSE; |
30aabb86 | 750 | |
a8a6b603 | 751 | for (e1 = n->sym->ns->equiv; e1; e1 = e1->next) |
5291e69a | 752 | { |
30aabb86 | 753 | eq = NULL; |
5291e69a | 754 | |
30aabb86 PT |
755 | /* Search the equivalence list, including the root (first) element |
756 | for the symbol that owns the segment. */ | |
757 | for (e2 = e1; e2; e2 = e2->eq) | |
758 | { | |
759 | if (!e2->used && e2->expr->symtree->n.sym == n->sym) | |
5291e69a | 760 | { |
a8a6b603 | 761 | eq = e2; |
30aabb86 | 762 | break; |
5291e69a | 763 | } |
30aabb86 PT |
764 | } |
765 | ||
766 | /* Go to the next root element. */ | |
767 | if (eq == NULL) | |
768 | continue; | |
769 | ||
770 | eq->used = 1; | |
771 | ||
772 | /* Now traverse the equivalence list matching the offsets. */ | |
773 | for (e2 = e1; e2; e2 = e2->eq) | |
774 | { | |
775 | if (!e2->used && e2 != eq) | |
5291e69a | 776 | { |
30aabb86 PT |
777 | add_condition (n, eq, e2); |
778 | e2->used = 1; | |
5291e69a | 779 | found = TRUE; |
5291e69a PB |
780 | } |
781 | } | |
782 | } | |
783 | return found; | |
6de9cd9a DN |
784 | } |
785 | ||
a8a6b603 | 786 | |
8a0b57b3 PT |
787 | /* Add all symbols equivalenced within a segment. We need to scan the |
788 | segment list multiple times to include indirect equivalences. Since | |
789 | a new segment_info can inserted at the beginning of the segment list, | |
790 | depending on its offset, we have to force a final pass through the | |
791 | loop by demanding that completion sees a pass with no matches; ie. | |
792 | all symbols with equiv_built set and no new equivalences found. */ | |
6de9cd9a | 793 | |
5291e69a | 794 | static void |
a3122424 | 795 | add_equivalences (bool *saw_equiv) |
6de9cd9a | 796 | { |
6de9cd9a | 797 | segment_info *f; |
8a0b57b3 | 798 | bool seen_one, more; |
6de9cd9a | 799 | |
8a0b57b3 | 800 | seen_one = false; |
5291e69a PB |
801 | more = TRUE; |
802 | while (more) | |
6de9cd9a | 803 | { |
5291e69a PB |
804 | more = FALSE; |
805 | for (f = current_segment; f; f = f->next) | |
806 | { | |
807 | if (!f->sym->equiv_built) | |
808 | { | |
809 | f->sym->equiv_built = 1; | |
8a0b57b3 PT |
810 | seen_one = find_equivalence (f); |
811 | if (seen_one) | |
812 | { | |
813 | *saw_equiv = true; | |
814 | more = true; | |
815 | } | |
5291e69a PB |
816 | } |
817 | } | |
6de9cd9a | 818 | } |
61321991 PT |
819 | |
820 | /* Add a copy of this segment list to the namespace. */ | |
821 | copy_equiv_list_to_ns (current_segment); | |
6de9cd9a | 822 | } |
a8a6b603 TS |
823 | |
824 | ||
43a5ef69 | 825 | /* Returns the offset necessary to properly align the current equivalence. |
832ef1ce PB |
826 | Sets *palign to the required alignment. */ |
827 | ||
828 | static HOST_WIDE_INT | |
829 | align_segment (unsigned HOST_WIDE_INT * palign) | |
830 | { | |
831 | segment_info *s; | |
832 | unsigned HOST_WIDE_INT offset; | |
833 | unsigned HOST_WIDE_INT max_align; | |
834 | unsigned HOST_WIDE_INT this_align; | |
835 | unsigned HOST_WIDE_INT this_offset; | |
836 | ||
837 | max_align = 1; | |
838 | offset = 0; | |
839 | for (s = current_segment; s; s = s->next) | |
840 | { | |
841 | this_align = TYPE_ALIGN_UNIT (s->field); | |
842 | if (s->offset & (this_align - 1)) | |
843 | { | |
844 | /* Field is misaligned. */ | |
845 | this_offset = this_align - ((s->offset + offset) & (this_align - 1)); | |
846 | if (this_offset & (max_align - 1)) | |
847 | { | |
848 | /* Aligning this field would misalign a previous field. */ | |
849 | gfc_error ("The equivalence set for variable '%s' " | |
850 | "declared at %L violates alignment requirents", | |
851 | s->sym->name, &s->sym->declared_at); | |
852 | } | |
853 | offset += this_offset; | |
854 | } | |
855 | max_align = this_align; | |
856 | } | |
857 | if (palign) | |
858 | *palign = max_align; | |
859 | return offset; | |
860 | } | |
861 | ||
862 | ||
863 | /* Adjust segment offsets by the given amount. */ | |
a8a6b603 | 864 | |
6de9cd9a | 865 | static void |
832ef1ce | 866 | apply_segment_offset (segment_info * s, HOST_WIDE_INT offset) |
6de9cd9a | 867 | { |
832ef1ce PB |
868 | for (; s; s = s->next) |
869 | s->offset += offset; | |
870 | } | |
871 | ||
872 | ||
873 | /* Lay out a symbol in a common block. If the symbol has already been seen | |
874 | then check the location is consistent. Otherwise create segments | |
875 | for that symbol and all the symbols equivalenced with it. */ | |
876 | ||
877 | /* Translate a single common block. */ | |
878 | ||
879 | static void | |
880 | translate_common (gfc_common_head *common, gfc_symbol *var_list) | |
881 | { | |
882 | gfc_symbol *sym; | |
883 | segment_info *s; | |
884 | segment_info *common_segment; | |
885 | HOST_WIDE_INT offset; | |
886 | HOST_WIDE_INT current_offset; | |
887 | unsigned HOST_WIDE_INT align; | |
888 | unsigned HOST_WIDE_INT max_align; | |
a3122424 | 889 | bool saw_equiv; |
832ef1ce PB |
890 | |
891 | common_segment = NULL; | |
892 | current_offset = 0; | |
893 | max_align = 1; | |
a3122424 | 894 | saw_equiv = false; |
832ef1ce PB |
895 | |
896 | /* Add symbols to the segment. */ | |
897 | for (sym = var_list; sym; sym = sym->common_next) | |
898 | { | |
30aabb86 PT |
899 | current_segment = common_segment; |
900 | s = find_segment_info (sym); | |
832ef1ce | 901 | |
30aabb86 PT |
902 | /* Symbol has already been added via an equivalence. Multiple |
903 | use associations of the same common block result in equiv_built | |
904 | being set but no information about the symbol in the segment. */ | |
905 | if (s && sym->equiv_built) | |
906 | { | |
832ef1ce PB |
907 | /* Ensure the current location is properly aligned. */ |
908 | align = TYPE_ALIGN_UNIT (s->field); | |
909 | current_offset = (current_offset + align - 1) &~ (align - 1); | |
910 | ||
911 | /* Verify that it ended up where we expect it. */ | |
912 | if (s->offset != current_offset) | |
913 | { | |
914 | gfc_error ("Equivalence for '%s' does not match ordering of " | |
915 | "COMMON '%s' at %L", sym->name, | |
916 | common->name, &common->where); | |
917 | } | |
918 | } | |
919 | else | |
920 | { | |
921 | /* A symbol we haven't seen before. */ | |
922 | s = current_segment = get_segment_info (sym, current_offset); | |
a8a6b603 | 923 | |
832ef1ce PB |
924 | /* Add all objects directly or indirectly equivalenced with this |
925 | symbol. */ | |
a3122424 | 926 | add_equivalences (&saw_equiv); |
ad6e2a18 | 927 | |
832ef1ce PB |
928 | if (current_segment->offset < 0) |
929 | gfc_error ("The equivalence set for '%s' cause an invalid " | |
930 | "extension to COMMON '%s' at %L", sym->name, | |
931 | common->name, &common->where); | |
6de9cd9a | 932 | |
832ef1ce | 933 | offset = align_segment (&align); |
6de9cd9a | 934 | |
832ef1ce PB |
935 | if (offset & (max_align - 1)) |
936 | { | |
937 | /* The required offset conflicts with previous alignment | |
938 | requirements. Insert padding immediately before this | |
939 | segment. */ | |
940 | gfc_warning ("Padding of %d bytes required before '%s' in " | |
eb83e811 | 941 | "COMMON '%s' at %L", (int)offset, s->sym->name, |
832ef1ce PB |
942 | common->name, &common->where); |
943 | } | |
944 | else | |
945 | { | |
946 | /* Offset the whole common block. */ | |
947 | apply_segment_offset (common_segment, offset); | |
948 | } | |
6de9cd9a | 949 | |
832ef1ce PB |
950 | /* Apply the offset to the new segments. */ |
951 | apply_segment_offset (current_segment, offset); | |
952 | current_offset += offset; | |
953 | if (max_align < align) | |
954 | max_align = align; | |
955 | ||
956 | /* Add the new segments to the common block. */ | |
957 | common_segment = add_segments (common_segment, current_segment); | |
958 | } | |
959 | ||
960 | /* The offset of the next common variable. */ | |
961 | current_offset += s->length; | |
962 | } | |
963 | ||
964 | if (common_segment->offset != 0) | |
965 | { | |
966 | gfc_warning ("COMMON '%s' at %L requires %d bytes of padding at start", | |
eb83e811 | 967 | common->name, &common->where, (int)common_segment->offset); |
832ef1ce PB |
968 | } |
969 | ||
a3122424 | 970 | create_common (common, common_segment, saw_equiv); |
6de9cd9a DN |
971 | } |
972 | ||
973 | ||
974 | /* Create a new block for each merged equivalence list. */ | |
975 | ||
976 | static void | |
977 | finish_equivalences (gfc_namespace *ns) | |
978 | { | |
979 | gfc_equiv *z, *y; | |
980 | gfc_symbol *sym; | |
30aabb86 | 981 | gfc_common_head * c; |
36c028f6 PB |
982 | HOST_WIDE_INT offset; |
983 | unsigned HOST_WIDE_INT align; | |
a3122424 | 984 | bool dummy; |
6de9cd9a DN |
985 | |
986 | for (z = ns->equiv; z; z = z->next) | |
a8a6b603 | 987 | for (y = z->eq; y; y = y->eq) |
6de9cd9a | 988 | { |
a8a6b603 TS |
989 | if (y->used) |
990 | continue; | |
6de9cd9a | 991 | sym = z->expr->symtree->n.sym; |
ad6e2a18 | 992 | current_segment = get_segment_info (sym, 0); |
6de9cd9a | 993 | |
1f2959f0 | 994 | /* All objects directly or indirectly equivalenced with this symbol. */ |
a3122424 | 995 | add_equivalences (&dummy); |
6de9cd9a | 996 | |
36c028f6 PB |
997 | /* Align the block. */ |
998 | offset = align_segment (&align); | |
832ef1ce | 999 | |
36c028f6 PB |
1000 | /* Ensure all offsets are positive. */ |
1001 | offset -= current_segment->offset & ~(align - 1); | |
6de9cd9a | 1002 | |
36c028f6 | 1003 | apply_segment_offset (current_segment, offset); |
6de9cd9a | 1004 | |
30aabb86 PT |
1005 | /* Create the decl. If this is a module equivalence, it has a unique |
1006 | name, pointed to by z->module. This is written to a gfc_common_header | |
1007 | to push create_common into using build_common_decl, so that the | |
1008 | equivalence appears as an external symbol. Otherwise, a local | |
1009 | declaration is built using build_equiv_decl.*/ | |
1010 | if (z->module) | |
1011 | { | |
1012 | c = gfc_get_common_head (); | |
1013 | /* We've lost the real location, so use the location of the | |
1014 | enclosing procedure. */ | |
1015 | c->where = ns->proc_name->declared_at; | |
1016 | strcpy (c->name, z->module); | |
1017 | } | |
1018 | else | |
1019 | c = NULL; | |
1020 | ||
1021 | create_common (c, current_segment, true); | |
6de9cd9a DN |
1022 | break; |
1023 | } | |
1024 | } | |
1025 | ||
1026 | ||
6de9cd9a DN |
1027 | /* Work function for translating a named common block. */ |
1028 | ||
1029 | static void | |
9056bd70 | 1030 | named_common (gfc_symtree *st) |
6de9cd9a | 1031 | { |
53814b8f | 1032 | translate_common (st->n.common, st->n.common->head); |
6de9cd9a DN |
1033 | } |
1034 | ||
1035 | ||
1036 | /* Translate the common blocks in a namespace. Unlike other variables, | |
1037 | these have to be created before code, because the backend_decl depends | |
1038 | on the rest of the common block. */ | |
a8a6b603 TS |
1039 | |
1040 | void | |
6de9cd9a DN |
1041 | gfc_trans_common (gfc_namespace *ns) |
1042 | { | |
9056bd70 | 1043 | gfc_common_head *c; |
6de9cd9a DN |
1044 | |
1045 | /* Translate the blank common block. */ | |
9056bd70 | 1046 | if (ns->blank_common.head != NULL) |
6de9cd9a | 1047 | { |
9056bd70 | 1048 | c = gfc_get_common_head (); |
c8cc8542 PB |
1049 | /* We've lost the real location, so use the location of the |
1050 | enclosing procedure. */ | |
1051 | c->where = ns->proc_name->declared_at; | |
53814b8f TS |
1052 | strcpy (c->name, BLANK_COMMON_NAME); |
1053 | translate_common (c, ns->blank_common.head); | |
6de9cd9a DN |
1054 | } |
1055 | ||
1056 | /* Translate all named common blocks. */ | |
a8a6b603 | 1057 | gfc_traverse_symtree (ns->common_root, named_common); |
6de9cd9a DN |
1058 | |
1059 | /* Commit the newly created symbols for common blocks. */ | |
1060 | gfc_commit_symbols (); | |
1061 | ||
1062 | /* Translate local equivalence. */ | |
1063 | finish_equivalences (ns); | |
1064 | } |