OSDN Git Service

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