OSDN Git Service

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