OSDN Git Service

1c213245626802737f5d17b651a5c27b12a66ba8
[pf3gnuchains/gcc-fork.git] / gcc / fortran / array.c
1 /* Array things
2    Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3    Free Software Foundation, Inc.
4    Contributed by Andy Vaught
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 #include "config.h"
23 #include "system.h"
24 #include "gfortran.h"
25 #include "match.h"
26 #include "constructor.h"
27
28 /**************** Array reference matching subroutines *****************/
29
30 /* Copy an array reference structure.  */
31
32 gfc_array_ref *
33 gfc_copy_array_ref (gfc_array_ref *src)
34 {
35   gfc_array_ref *dest;
36   int i;
37
38   if (src == NULL)
39     return NULL;
40
41   dest = gfc_get_array_ref ();
42
43   *dest = *src;
44
45   for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
46     {
47       dest->start[i] = gfc_copy_expr (src->start[i]);
48       dest->end[i] = gfc_copy_expr (src->end[i]);
49       dest->stride[i] = gfc_copy_expr (src->stride[i]);
50     }
51
52   dest->offset = gfc_copy_expr (src->offset);
53
54   return dest;
55 }
56
57
58 /* Match a single dimension of an array reference.  This can be a
59    single element or an array section.  Any modifications we've made
60    to the ar structure are cleaned up by the caller.  If the init
61    is set, we require the subscript to be a valid initialization
62    expression.  */
63
64 static match
65 match_subscript (gfc_array_ref *ar, int init, bool match_star)
66 {
67   match m;
68   bool star = false;
69   int i;
70
71   i = ar->dimen + ar->codimen;
72
73   ar->c_where[i] = gfc_current_locus;
74   ar->start[i] = ar->end[i] = ar->stride[i] = NULL;
75
76   /* We can't be sure of the difference between DIMEN_ELEMENT and
77      DIMEN_VECTOR until we know the type of the element itself at
78      resolution time.  */
79
80   ar->dimen_type[i] = DIMEN_UNKNOWN;
81
82   if (gfc_match_char (':') == MATCH_YES)
83     goto end_element;
84
85   /* Get start element.  */
86   if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
87     star = true;
88
89   if (!star && init)
90     m = gfc_match_init_expr (&ar->start[i]);
91   else if (!star)
92     m = gfc_match_expr (&ar->start[i]);
93
94   if (m == MATCH_NO)
95     gfc_error ("Expected array subscript at %C");
96   if (m != MATCH_YES)
97     return MATCH_ERROR;
98
99   if (gfc_match_char (':') == MATCH_NO)
100     goto matched;
101
102   if (star)
103     {
104       gfc_error ("Unexpected '*' in coarray subscript at %C");
105       return MATCH_ERROR;
106     }
107
108   /* Get an optional end element.  Because we've seen the colon, we
109      definitely have a range along this dimension.  */
110 end_element:
111   ar->dimen_type[i] = DIMEN_RANGE;
112
113   if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
114     star = true;
115   else if (init)
116     m = gfc_match_init_expr (&ar->end[i]);
117   else
118     m = gfc_match_expr (&ar->end[i]);
119
120   if (m == MATCH_ERROR)
121     return MATCH_ERROR;
122
123   /* See if we have an optional stride.  */
124   if (gfc_match_char (':') == MATCH_YES)
125     {
126       if (star)
127         {
128           gfc_error ("Strides not allowed in coarray subscript at %C");
129           return MATCH_ERROR;
130         }
131
132       m = init ? gfc_match_init_expr (&ar->stride[i])
133                : gfc_match_expr (&ar->stride[i]);
134
135       if (m == MATCH_NO)
136         gfc_error ("Expected array subscript stride at %C");
137       if (m != MATCH_YES)
138         return MATCH_ERROR;
139     }
140
141 matched:
142   if (star)
143     ar->dimen_type[i] = DIMEN_STAR;
144
145   return MATCH_YES;
146 }
147
148
149 /* Match an array reference, whether it is the whole array or a
150    particular elements or a section. If init is set, the reference has
151    to consist of init expressions.  */
152
153 match
154 gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init,
155                      int corank)
156 {
157   match m;
158   bool matched_bracket = false;
159
160   memset (ar, '\0', sizeof (ar));
161
162   ar->where = gfc_current_locus;
163   ar->as = as;
164   ar->type = AR_UNKNOWN;
165
166   if (gfc_match_char ('[') == MATCH_YES)
167     {
168        matched_bracket = true;
169        goto coarray;
170     }
171
172   if (gfc_match_char ('(') != MATCH_YES)
173     {
174       ar->type = AR_FULL;
175       ar->dimen = 0;
176       return MATCH_YES;
177     }
178
179   for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++)
180     {
181       m = match_subscript (ar, init, false);
182       if (m == MATCH_ERROR)
183         return MATCH_ERROR;
184
185       if (gfc_match_char (')') == MATCH_YES)
186         {
187           ar->dimen++;
188           goto coarray;
189         }
190
191       if (gfc_match_char (',') != MATCH_YES)
192         {
193           gfc_error ("Invalid form of array reference at %C");
194           return MATCH_ERROR;
195         }
196     }
197
198   gfc_error ("Array reference at %C cannot have more than %d dimensions",
199              GFC_MAX_DIMENSIONS);
200   return MATCH_ERROR;
201
202 coarray:
203   if (!matched_bracket && gfc_match_char ('[') != MATCH_YES)
204     {
205       if (ar->dimen > 0)
206         return MATCH_YES;
207       else
208         return MATCH_ERROR;
209     }
210
211   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
212     {
213       gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable");
214       return MATCH_ERROR;
215     }
216
217   if (corank == 0)
218     {
219         gfc_error ("Unexpected coarray designator at %C");
220         return MATCH_ERROR;
221     }
222
223   for (ar->codimen = 0; ar->codimen + ar->dimen < GFC_MAX_DIMENSIONS; ar->codimen++)
224     {
225       m = match_subscript (ar, init, ar->codimen == (corank - 1));
226       if (m == MATCH_ERROR)
227         return MATCH_ERROR;
228
229       if (gfc_match_char (']') == MATCH_YES)
230         {
231           ar->codimen++;
232           return MATCH_YES;
233         }
234
235       if (gfc_match_char (',') != MATCH_YES)
236         {
237           gfc_error ("Invalid form of coarray reference at %C");
238           return MATCH_ERROR;
239         }
240     }
241
242   gfc_error ("Array reference at %C cannot have more than %d dimensions",
243              GFC_MAX_DIMENSIONS);
244   return MATCH_ERROR;
245
246 }
247
248
249 /************** Array specification matching subroutines ***************/
250
251 /* Free all of the expressions associated with array bounds
252    specifications.  */
253
254 void
255 gfc_free_array_spec (gfc_array_spec *as)
256 {
257   int i;
258
259   if (as == NULL)
260     return;
261
262   for (i = 0; i < as->rank + as->corank; i++)
263     {
264       gfc_free_expr (as->lower[i]);
265       gfc_free_expr (as->upper[i]);
266     }
267
268   gfc_free (as);
269 }
270
271
272 /* Take an array bound, resolves the expression, that make up the
273    shape and check associated constraints.  */
274
275 static gfc_try
276 resolve_array_bound (gfc_expr *e, int check_constant)
277 {
278   if (e == NULL)
279     return SUCCESS;
280
281   if (gfc_resolve_expr (e) == FAILURE
282       || gfc_specification_expr (e) == FAILURE)
283     return FAILURE;
284
285   if (check_constant && gfc_is_constant_expr (e) == 0)
286     {
287       gfc_error ("Variable '%s' at %L in this context must be constant",
288                  e->symtree->n.sym->name, &e->where);
289       return FAILURE;
290     }
291
292   return SUCCESS;
293 }
294
295
296 /* Takes an array specification, resolves the expressions that make up
297    the shape and make sure everything is integral.  */
298
299 gfc_try
300 gfc_resolve_array_spec (gfc_array_spec *as, int check_constant)
301 {
302   gfc_expr *e;
303   int i;
304
305   if (as == NULL)
306     return SUCCESS;
307
308   for (i = 0; i < as->rank + as->corank; i++)
309     {
310       e = as->lower[i];
311       if (resolve_array_bound (e, check_constant) == FAILURE)
312         return FAILURE;
313
314       e = as->upper[i];
315       if (resolve_array_bound (e, check_constant) == FAILURE)
316         return FAILURE;
317
318       if ((as->lower[i] == NULL) || (as->upper[i] == NULL))
319         continue;
320
321       /* If the size is negative in this dimension, set it to zero.  */
322       if (as->lower[i]->expr_type == EXPR_CONSTANT
323             && as->upper[i]->expr_type == EXPR_CONSTANT
324             && mpz_cmp (as->upper[i]->value.integer,
325                         as->lower[i]->value.integer) < 0)
326         {
327           gfc_free_expr (as->upper[i]);
328           as->upper[i] = gfc_copy_expr (as->lower[i]);
329           mpz_sub_ui (as->upper[i]->value.integer,
330                       as->upper[i]->value.integer, 1);
331         }
332     }
333
334   return SUCCESS;
335 }
336
337
338 /* Match a single array element specification.  The return values as
339    well as the upper and lower bounds of the array spec are filled
340    in according to what we see on the input.  The caller makes sure
341    individual specifications make sense as a whole.
342
343
344         Parsed       Lower   Upper  Returned
345         ------------------------------------
346           :           NULL    NULL   AS_DEFERRED (*)
347           x            1       x     AS_EXPLICIT
348           x:           x      NULL   AS_ASSUMED_SHAPE
349           x:y          x       y     AS_EXPLICIT
350           x:*          x      NULL   AS_ASSUMED_SIZE
351           *            1      NULL   AS_ASSUMED_SIZE
352
353   (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE.  This
354   is fixed during the resolution of formal interfaces.
355
356    Anything else AS_UNKNOWN.  */
357
358 static array_type
359 match_array_element_spec (gfc_array_spec *as)
360 {
361   gfc_expr **upper, **lower;
362   match m;
363
364   lower = &as->lower[as->rank + as->corank - 1];
365   upper = &as->upper[as->rank + as->corank - 1];
366
367   if (gfc_match_char ('*') == MATCH_YES)
368     {
369       *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
370       return AS_ASSUMED_SIZE;
371     }
372
373   if (gfc_match_char (':') == MATCH_YES)
374     return AS_DEFERRED;
375
376   m = gfc_match_expr (upper);
377   if (m == MATCH_NO)
378     gfc_error ("Expected expression in array specification at %C");
379   if (m != MATCH_YES)
380     return AS_UNKNOWN;
381   if (gfc_expr_check_typed (*upper, gfc_current_ns, false) == FAILURE)
382     return AS_UNKNOWN;
383
384   if (gfc_match_char (':') == MATCH_NO)
385     {
386       *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
387       return AS_EXPLICIT;
388     }
389
390   *lower = *upper;
391   *upper = NULL;
392
393   if (gfc_match_char ('*') == MATCH_YES)
394     return AS_ASSUMED_SIZE;
395
396   m = gfc_match_expr (upper);
397   if (m == MATCH_ERROR)
398     return AS_UNKNOWN;
399   if (m == MATCH_NO)
400     return AS_ASSUMED_SHAPE;
401   if (gfc_expr_check_typed (*upper, gfc_current_ns, false) == FAILURE)
402     return AS_UNKNOWN;
403
404   return AS_EXPLICIT;
405 }
406
407
408 /* Matches an array specification, incidentally figuring out what sort
409    it is. Match either a normal array specification, or a coarray spec
410    or both. Optionally allow [:] for coarrays.  */
411
412 match
413 gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
414 {
415   array_type current_type;
416   gfc_array_spec *as;
417   int i;
418  
419   as = gfc_get_array_spec ();
420   as->corank = 0;
421   as->rank = 0;
422
423   for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
424     {
425       as->lower[i] = NULL;
426       as->upper[i] = NULL;
427     }
428
429   if (!match_dim)
430     goto coarray;
431
432   if (gfc_match_char ('(') != MATCH_YES)
433     {
434       if (!match_codim)
435         goto done;
436       goto coarray;
437     }
438
439   for (;;)
440     {
441       as->rank++;
442       current_type = match_array_element_spec (as);
443
444       if (as->rank == 1)
445         {
446           if (current_type == AS_UNKNOWN)
447             goto cleanup;
448           as->type = current_type;
449         }
450       else
451         switch (as->type)
452           {             /* See how current spec meshes with the existing.  */
453           case AS_UNKNOWN:
454             goto cleanup;
455
456           case AS_EXPLICIT:
457             if (current_type == AS_ASSUMED_SIZE)
458               {
459                 as->type = AS_ASSUMED_SIZE;
460                 break;
461               }
462
463             if (current_type == AS_EXPLICIT)
464               break;
465
466             gfc_error ("Bad array specification for an explicitly shaped "
467                        "array at %C");
468
469             goto cleanup;
470
471           case AS_ASSUMED_SHAPE:
472             if ((current_type == AS_ASSUMED_SHAPE)
473                 || (current_type == AS_DEFERRED))
474               break;
475
476             gfc_error ("Bad array specification for assumed shape "
477                        "array at %C");
478             goto cleanup;
479
480           case AS_DEFERRED:
481             if (current_type == AS_DEFERRED)
482               break;
483
484             if (current_type == AS_ASSUMED_SHAPE)
485               {
486                 as->type = AS_ASSUMED_SHAPE;
487                 break;
488               }
489
490             gfc_error ("Bad specification for deferred shape array at %C");
491             goto cleanup;
492
493           case AS_ASSUMED_SIZE:
494             gfc_error ("Bad specification for assumed size array at %C");
495             goto cleanup;
496           }
497
498       if (gfc_match_char (')') == MATCH_YES)
499         break;
500
501       if (gfc_match_char (',') != MATCH_YES)
502         {
503           gfc_error ("Expected another dimension in array declaration at %C");
504           goto cleanup;
505         }
506
507       if (as->rank + as->corank >= GFC_MAX_DIMENSIONS)
508         {
509           gfc_error ("Array specification at %C has more than %d dimensions",
510                      GFC_MAX_DIMENSIONS);
511           goto cleanup;
512         }
513
514       if (as->corank + as->rank >= 7
515           && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Array "
516                              "specification at %C with more than 7 dimensions")
517              == FAILURE)
518         goto cleanup;
519     }
520
521   if (!match_codim)
522     goto done;
523
524 coarray:
525   if (gfc_match_char ('[')  != MATCH_YES)
526     goto done;
527
528   if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Coarray declaration at %C")
529       == FAILURE)
530     goto cleanup;
531
532   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
533     {
534       gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable");
535       goto cleanup;
536     }
537
538   for (;;)
539     {
540       as->corank++;
541       current_type = match_array_element_spec (as);
542
543       if (current_type == AS_UNKNOWN)
544         goto cleanup;
545
546       if (as->corank == 1)
547         as->cotype = current_type;
548       else
549         switch (as->cotype)
550           { /* See how current spec meshes with the existing.  */
551             case AS_UNKNOWN:
552               goto cleanup;
553
554             case AS_EXPLICIT:
555               if (current_type == AS_ASSUMED_SIZE)
556                 {
557                   as->cotype = AS_ASSUMED_SIZE;
558                   break;
559                 }
560
561               if (current_type == AS_EXPLICIT)
562                 break;
563
564               gfc_error ("Bad array specification for an explicitly "
565                          "shaped array at %C");
566
567               goto cleanup;
568
569             case AS_ASSUMED_SHAPE:
570               if ((current_type == AS_ASSUMED_SHAPE)
571                   || (current_type == AS_DEFERRED))
572                 break;
573
574               gfc_error ("Bad array specification for assumed shape "
575                          "array at %C");
576               goto cleanup;
577
578             case AS_DEFERRED:
579               if (current_type == AS_DEFERRED)
580                 break;
581
582               if (current_type == AS_ASSUMED_SHAPE)
583                 {
584                   as->cotype = AS_ASSUMED_SHAPE;
585                   break;
586                 }
587
588               gfc_error ("Bad specification for deferred shape array at %C");
589               goto cleanup;
590
591             case AS_ASSUMED_SIZE:
592               gfc_error ("Bad specification for assumed size array at %C");
593               goto cleanup;
594           }
595
596       if (gfc_match_char (']') == MATCH_YES)
597         break;
598
599       if (gfc_match_char (',') != MATCH_YES)
600         {
601           gfc_error ("Expected another dimension in array declaration at %C");
602           goto cleanup;
603         }
604
605       if (as->corank >= GFC_MAX_DIMENSIONS)
606         {
607           gfc_error ("Array specification at %C has more than %d "
608                      "dimensions", GFC_MAX_DIMENSIONS);
609           goto cleanup;
610         }
611     }
612
613   if (current_type == AS_EXPLICIT)
614     {
615       gfc_error ("Upper bound of last coarray dimension must be '*' at %C");
616       goto cleanup;
617     }
618
619   if (as->cotype == AS_ASSUMED_SIZE)
620     as->cotype = AS_EXPLICIT;
621
622   if (as->rank == 0)
623     as->type = as->cotype;
624
625 done:
626   if (as->rank == 0 && as->corank == 0)
627     {
628       *asp = NULL;
629       gfc_free_array_spec (as);
630       return MATCH_NO;
631     }
632
633   /* If a lower bounds of an assumed shape array is blank, put in one.  */
634   if (as->type == AS_ASSUMED_SHAPE)
635     {
636       for (i = 0; i < as->rank + as->corank; i++)
637         {
638           if (as->lower[i] == NULL)
639             as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
640         }
641     }
642
643   *asp = as;
644
645   return MATCH_YES;
646
647 cleanup:
648   /* Something went wrong.  */
649   gfc_free_array_spec (as);
650   return MATCH_ERROR;
651 }
652
653
654 /* Given a symbol and an array specification, modify the symbol to
655    have that array specification.  The error locus is needed in case
656    something goes wrong.  On failure, the caller must free the spec.  */
657
658 gfc_try
659 gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
660 {
661   int i;
662
663   if (as == NULL)
664     return SUCCESS;
665
666   if (as->rank
667       && gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE)
668     return FAILURE;
669
670   if (as->corank
671       && gfc_add_codimension (&sym->attr, sym->name, error_loc) == FAILURE)
672     return FAILURE;
673
674   if (sym->as == NULL)
675     {
676       sym->as = as;
677       return SUCCESS;
678     }
679
680   if (as->corank)
681     {
682       /* The "sym" has no corank (checked via gfc_add_codimension). Thus
683          the codimension is simply added.  */
684       gcc_assert (as->rank == 0 && sym->as->corank == 0);
685
686       sym->as->cotype = as->cotype;
687       sym->as->corank = as->corank;
688       for (i = 0; i < as->corank; i++)
689         {
690           sym->as->lower[sym->as->rank + i] = as->lower[i];
691           sym->as->upper[sym->as->rank + i] = as->upper[i];
692         }
693     }
694   else
695     {
696       /* The "sym" has no rank (checked via gfc_add_dimension). Thus
697          the dimension is added - but first the codimensions (if existing
698          need to be shifted to make space for the dimension.  */
699       gcc_assert (as->corank == 0 && sym->as->rank == 0);
700
701       sym->as->rank = as->rank;
702       sym->as->type = as->type;
703       sym->as->cray_pointee = as->cray_pointee;
704       sym->as->cp_was_assumed = as->cp_was_assumed;
705
706       for (i = 0; i < sym->as->corank; i++)
707         {
708           sym->as->lower[as->rank + i] = sym->as->lower[i];
709           sym->as->upper[as->rank + i] = sym->as->upper[i];
710         }
711       for (i = 0; i < as->rank; i++)
712         {
713           sym->as->lower[i] = as->lower[i];
714           sym->as->upper[i] = as->upper[i];
715         }
716     }
717
718   gfc_free (as);
719   return SUCCESS;
720 }
721
722
723 /* Copy an array specification.  */
724
725 gfc_array_spec *
726 gfc_copy_array_spec (gfc_array_spec *src)
727 {
728   gfc_array_spec *dest;
729   int i;
730
731   if (src == NULL)
732     return NULL;
733
734   dest = gfc_get_array_spec ();
735
736   *dest = *src;
737
738   for (i = 0; i < dest->rank + dest->corank; i++)
739     {
740       dest->lower[i] = gfc_copy_expr (dest->lower[i]);
741       dest->upper[i] = gfc_copy_expr (dest->upper[i]);
742     }
743
744   return dest;
745 }
746
747
748 /* Returns nonzero if the two expressions are equal.  Only handles integer
749    constants.  */
750
751 static int
752 compare_bounds (gfc_expr *bound1, gfc_expr *bound2)
753 {
754   if (bound1 == NULL || bound2 == NULL
755       || bound1->expr_type != EXPR_CONSTANT
756       || bound2->expr_type != EXPR_CONSTANT
757       || bound1->ts.type != BT_INTEGER
758       || bound2->ts.type != BT_INTEGER)
759     gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
760
761   if (mpz_cmp (bound1->value.integer, bound2->value.integer) == 0)
762     return 1;
763   else
764     return 0;
765 }
766
767
768 /* Compares two array specifications.  They must be constant or deferred
769    shape.  */
770
771 int
772 gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2)
773 {
774   int i;
775
776   if (as1 == NULL && as2 == NULL)
777     return 1;
778
779   if (as1 == NULL || as2 == NULL)
780     return 0;
781
782   if (as1->rank != as2->rank)
783     return 0;
784
785   if (as1->corank != as2->corank)
786     return 0;
787
788   if (as1->rank == 0)
789     return 1;
790
791   if (as1->type != as2->type)
792     return 0;
793
794   if (as1->type == AS_EXPLICIT)
795     for (i = 0; i < as1->rank + as1->corank; i++)
796       {
797         if (compare_bounds (as1->lower[i], as2->lower[i]) == 0)
798           return 0;
799
800         if (compare_bounds (as1->upper[i], as2->upper[i]) == 0)
801           return 0;
802       }
803
804   return 1;
805 }
806
807
808 /****************** Array constructor functions ******************/
809
810
811 /* Given an expression node that might be an array constructor and a
812    symbol, make sure that no iterators in this or child constructors
813    use the symbol as an implied-DO iterator.  Returns nonzero if a
814    duplicate was found.  */
815
816 static int
817 check_duplicate_iterator (gfc_constructor_base base, gfc_symbol *master)
818 {
819   gfc_constructor *c;
820   gfc_expr *e;
821
822   for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
823     {
824       e = c->expr;
825
826       if (e->expr_type == EXPR_ARRAY
827           && check_duplicate_iterator (e->value.constructor, master))
828         return 1;
829
830       if (c->iterator == NULL)
831         continue;
832
833       if (c->iterator->var->symtree->n.sym == master)
834         {
835           gfc_error ("DO-iterator '%s' at %L is inside iterator of the "
836                      "same name", master->name, &c->where);
837
838           return 1;
839         }
840     }
841
842   return 0;
843 }
844
845
846 /* Forward declaration because these functions are mutually recursive.  */
847 static match match_array_cons_element (gfc_constructor_base *);
848
849 /* Match a list of array elements.  */
850
851 static match
852 match_array_list (gfc_constructor_base *result)
853 {
854   gfc_constructor_base head;
855   gfc_constructor *p;
856   gfc_iterator iter;
857   locus old_loc;
858   gfc_expr *e;
859   match m;
860   int n;
861
862   old_loc = gfc_current_locus;
863
864   if (gfc_match_char ('(') == MATCH_NO)
865     return MATCH_NO;
866
867   memset (&iter, '\0', sizeof (gfc_iterator));
868   head = NULL;
869
870   m = match_array_cons_element (&head);
871   if (m != MATCH_YES)
872     goto cleanup;
873
874   if (gfc_match_char (',') != MATCH_YES)
875     {
876       m = MATCH_NO;
877       goto cleanup;
878     }
879
880   for (n = 1;; n++)
881     {
882       m = gfc_match_iterator (&iter, 0);
883       if (m == MATCH_YES)
884         break;
885       if (m == MATCH_ERROR)
886         goto cleanup;
887
888       m = match_array_cons_element (&head);
889       if (m == MATCH_ERROR)
890         goto cleanup;
891       if (m == MATCH_NO)
892         {
893           if (n > 2)
894             goto syntax;
895           m = MATCH_NO;
896           goto cleanup;         /* Could be a complex constant */
897         }
898
899       if (gfc_match_char (',') != MATCH_YES)
900         {
901           if (n > 2)
902             goto syntax;
903           m = MATCH_NO;
904           goto cleanup;
905         }
906     }
907
908   if (gfc_match_char (')') != MATCH_YES)
909     goto syntax;
910
911   if (check_duplicate_iterator (head, iter.var->symtree->n.sym))
912     {
913       m = MATCH_ERROR;
914       goto cleanup;
915     }
916
917   e = gfc_get_array_expr (BT_UNKNOWN, 0, &old_loc);
918   e->value.constructor = head;
919
920   p = gfc_constructor_append_expr (result, e, &gfc_current_locus);
921   p->iterator = gfc_get_iterator ();
922   *p->iterator = iter;
923
924   return MATCH_YES;
925
926 syntax:
927   gfc_error ("Syntax error in array constructor at %C");
928   m = MATCH_ERROR;
929
930 cleanup:
931   gfc_constructor_free (head);
932   gfc_free_iterator (&iter, 0);
933   gfc_current_locus = old_loc;
934   return m;
935 }
936
937
938 /* Match a single element of an array constructor, which can be a
939    single expression or a list of elements.  */
940
941 static match
942 match_array_cons_element (gfc_constructor_base *result)
943 {
944   gfc_expr *expr;
945   match m;
946
947   m = match_array_list (result);
948   if (m != MATCH_NO)
949     return m;
950
951   m = gfc_match_expr (&expr);
952   if (m != MATCH_YES)
953     return m;
954
955   gfc_constructor_append_expr (result, expr, &gfc_current_locus);
956   return MATCH_YES;
957 }
958
959
960 /* Match an array constructor.  */
961
962 match
963 gfc_match_array_constructor (gfc_expr **result)
964 {
965   gfc_constructor_base head, new_cons;
966   gfc_expr *expr;
967   gfc_typespec ts;
968   locus where;
969   match m;
970   const char *end_delim;
971   bool seen_ts;
972
973   if (gfc_match (" (/") == MATCH_NO)
974     {
975       if (gfc_match (" [") == MATCH_NO)
976         return MATCH_NO;
977       else
978         {
979           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: [...] "
980                               "style array constructors at %C") == FAILURE)
981             return MATCH_ERROR;
982           end_delim = " ]";
983         }
984     }
985   else
986     end_delim = " /)";
987
988   where = gfc_current_locus;
989   head = new_cons = NULL;
990   seen_ts = false;
991
992   /* Try to match an optional "type-spec ::"  */
993   if (gfc_match_decl_type_spec (&ts, 0) == MATCH_YES)
994     {
995       seen_ts = (gfc_match (" ::") == MATCH_YES);
996
997       if (seen_ts)
998         {
999           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Array constructor "
1000                               "including type specification at %C") == FAILURE)
1001             goto cleanup;
1002         }
1003     }
1004
1005   if (! seen_ts)
1006     gfc_current_locus = where;
1007
1008   if (gfc_match (end_delim) == MATCH_YES)
1009     {
1010       if (seen_ts)
1011         goto done;
1012       else
1013         {
1014           gfc_error ("Empty array constructor at %C is not allowed");
1015           goto cleanup;
1016         }
1017     }
1018
1019   for (;;)
1020     {
1021       m = match_array_cons_element (&head);
1022       if (m == MATCH_ERROR)
1023         goto cleanup;
1024       if (m == MATCH_NO)
1025         goto syntax;
1026
1027       if (gfc_match_char (',') == MATCH_NO)
1028         break;
1029     }
1030
1031   if (gfc_match (end_delim) == MATCH_NO)
1032     goto syntax;
1033
1034 done:
1035   /* Size must be calculated at resolution time.  */
1036   if (seen_ts)
1037     {
1038       expr = gfc_get_array_expr (ts.type, ts.kind, &where);
1039       expr->ts = ts;
1040     }
1041   else
1042     expr = gfc_get_array_expr (BT_UNKNOWN, 0, &where);
1043
1044   expr->value.constructor = head;
1045   if (expr->ts.u.cl)
1046     expr->ts.u.cl->length_from_typespec = seen_ts;
1047
1048   *result = expr;
1049   return MATCH_YES;
1050
1051 syntax:
1052   gfc_error ("Syntax error in array constructor at %C");
1053
1054 cleanup:
1055   gfc_constructor_free (head);
1056   return MATCH_ERROR;
1057 }
1058
1059
1060
1061 /************** Check array constructors for correctness **************/
1062
1063 /* Given an expression, compare it's type with the type of the current
1064    constructor.  Returns nonzero if an error was issued.  The
1065    cons_state variable keeps track of whether the type of the
1066    constructor being read or resolved is known to be good, bad or just
1067    starting out.  */
1068
1069 static gfc_typespec constructor_ts;
1070 static enum
1071 { CONS_START, CONS_GOOD, CONS_BAD }
1072 cons_state;
1073
1074 static int
1075 check_element_type (gfc_expr *expr, bool convert)
1076 {
1077   if (cons_state == CONS_BAD)
1078     return 0;                   /* Suppress further errors */
1079
1080   if (cons_state == CONS_START)
1081     {
1082       if (expr->ts.type == BT_UNKNOWN)
1083         cons_state = CONS_BAD;
1084       else
1085         {
1086           cons_state = CONS_GOOD;
1087           constructor_ts = expr->ts;
1088         }
1089
1090       return 0;
1091     }
1092
1093   if (gfc_compare_types (&constructor_ts, &expr->ts))
1094     return 0;
1095
1096   if (convert)
1097     return gfc_convert_type (expr, &constructor_ts, 1) == SUCCESS ? 0 : 1;
1098
1099   gfc_error ("Element in %s array constructor at %L is %s",
1100              gfc_typename (&constructor_ts), &expr->where,
1101              gfc_typename (&expr->ts));
1102
1103   cons_state = CONS_BAD;
1104   return 1;
1105 }
1106
1107
1108 /* Recursive work function for gfc_check_constructor_type().  */
1109
1110 static gfc_try
1111 check_constructor_type (gfc_constructor_base base, bool convert)
1112 {
1113   gfc_constructor *c;
1114   gfc_expr *e;
1115
1116   for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1117     {
1118       e = c->expr;
1119
1120       if (e->expr_type == EXPR_ARRAY)
1121         {
1122           if (check_constructor_type (e->value.constructor, convert) == FAILURE)
1123             return FAILURE;
1124
1125           continue;
1126         }
1127
1128       if (check_element_type (e, convert))
1129         return FAILURE;
1130     }
1131
1132   return SUCCESS;
1133 }
1134
1135
1136 /* Check that all elements of an array constructor are the same type.
1137    On FAILURE, an error has been generated.  */
1138
1139 gfc_try
1140 gfc_check_constructor_type (gfc_expr *e)
1141 {
1142   gfc_try t;
1143
1144   if (e->ts.type != BT_UNKNOWN)
1145     {
1146       cons_state = CONS_GOOD;
1147       constructor_ts = e->ts;
1148     }
1149   else
1150     {
1151       cons_state = CONS_START;
1152       gfc_clear_ts (&constructor_ts);
1153     }
1154
1155   /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1156      typespec, and we will now convert the values on the fly.  */
1157   t = check_constructor_type (e->value.constructor, e->ts.type != BT_UNKNOWN);
1158   if (t == SUCCESS && e->ts.type == BT_UNKNOWN)
1159     e->ts = constructor_ts;
1160
1161   return t;
1162 }
1163
1164
1165
1166 typedef struct cons_stack
1167 {
1168   gfc_iterator *iterator;
1169   struct cons_stack *previous;
1170 }
1171 cons_stack;
1172
1173 static cons_stack *base;
1174
1175 static gfc_try check_constructor (gfc_constructor_base, gfc_try (*) (gfc_expr *));
1176
1177 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1178    that that variable is an iteration variables.  */
1179
1180 gfc_try
1181 gfc_check_iter_variable (gfc_expr *expr)
1182 {
1183   gfc_symbol *sym;
1184   cons_stack *c;
1185
1186   sym = expr->symtree->n.sym;
1187
1188   for (c = base; c; c = c->previous)
1189     if (sym == c->iterator->var->symtree->n.sym)
1190       return SUCCESS;
1191
1192   return FAILURE;
1193 }
1194
1195
1196 /* Recursive work function for gfc_check_constructor().  This amounts
1197    to calling the check function for each expression in the
1198    constructor, giving variables with the names of iterators a pass.  */
1199
1200 static gfc_try
1201 check_constructor (gfc_constructor_base ctor, gfc_try (*check_function) (gfc_expr *))
1202 {
1203   cons_stack element;
1204   gfc_expr *e;
1205   gfc_try t;
1206   gfc_constructor *c;
1207
1208   for (c = gfc_constructor_first (ctor); c; c = gfc_constructor_next (c))
1209     {
1210       e = c->expr;
1211
1212       if (e->expr_type != EXPR_ARRAY)
1213         {
1214           if ((*check_function) (e) == FAILURE)
1215             return FAILURE;
1216           continue;
1217         }
1218
1219       element.previous = base;
1220       element.iterator = c->iterator;
1221
1222       base = &element;
1223       t = check_constructor (e->value.constructor, check_function);
1224       base = element.previous;
1225
1226       if (t == FAILURE)
1227         return FAILURE;
1228     }
1229
1230   /* Nothing went wrong, so all OK.  */
1231   return SUCCESS;
1232 }
1233
1234
1235 /* Checks a constructor to see if it is a particular kind of
1236    expression -- specification, restricted, or initialization as
1237    determined by the check_function.  */
1238
1239 gfc_try
1240 gfc_check_constructor (gfc_expr *expr, gfc_try (*check_function) (gfc_expr *))
1241 {
1242   cons_stack *base_save;
1243   gfc_try t;
1244
1245   base_save = base;
1246   base = NULL;
1247
1248   t = check_constructor (expr->value.constructor, check_function);
1249   base = base_save;
1250
1251   return t;
1252 }
1253
1254
1255
1256 /**************** Simplification of array constructors ****************/
1257
1258 iterator_stack *iter_stack;
1259
1260 typedef struct
1261 {
1262   gfc_constructor_base base;
1263   int extract_count, extract_n;
1264   gfc_expr *extracted;
1265   mpz_t *count;
1266
1267   mpz_t *offset;
1268   gfc_component *component;
1269
1270   gfc_try (*expand_work_function) (gfc_expr *);
1271 }
1272 expand_info;
1273
1274 static expand_info current_expand;
1275
1276 static gfc_try expand_constructor (gfc_constructor_base);
1277
1278
1279 /* Work function that counts the number of elements present in a
1280    constructor.  */
1281
1282 static gfc_try
1283 count_elements (gfc_expr *e)
1284 {
1285   mpz_t result;
1286
1287   if (e->rank == 0)
1288     mpz_add_ui (*current_expand.count, *current_expand.count, 1);
1289   else
1290     {
1291       if (gfc_array_size (e, &result) == FAILURE)
1292         {
1293           gfc_free_expr (e);
1294           return FAILURE;
1295         }
1296
1297       mpz_add (*current_expand.count, *current_expand.count, result);
1298       mpz_clear (result);
1299     }
1300
1301   gfc_free_expr (e);
1302   return SUCCESS;
1303 }
1304
1305
1306 /* Work function that extracts a particular element from an array
1307    constructor, freeing the rest.  */
1308
1309 static gfc_try
1310 extract_element (gfc_expr *e)
1311 {
1312   if (e->rank != 0)
1313     {                           /* Something unextractable */
1314       gfc_free_expr (e);
1315       return FAILURE;
1316     }
1317
1318   if (current_expand.extract_count == current_expand.extract_n)
1319     current_expand.extracted = e;
1320   else
1321     gfc_free_expr (e);
1322
1323   current_expand.extract_count++;
1324   
1325   return SUCCESS;
1326 }
1327
1328
1329 /* Work function that constructs a new constructor out of the old one,
1330    stringing new elements together.  */
1331
1332 static gfc_try
1333 expand (gfc_expr *e)
1334 {
1335   gfc_constructor *c = gfc_constructor_append_expr (&current_expand.base,
1336                                                     e, &e->where);
1337
1338   c->n.component = current_expand.component;
1339   return SUCCESS;
1340 }
1341
1342
1343 /* Given an initialization expression that is a variable reference,
1344    substitute the current value of the iteration variable.  */
1345
1346 void
1347 gfc_simplify_iterator_var (gfc_expr *e)
1348 {
1349   iterator_stack *p;
1350
1351   for (p = iter_stack; p; p = p->prev)
1352     if (e->symtree == p->variable)
1353       break;
1354
1355   if (p == NULL)
1356     return;             /* Variable not found */
1357
1358   gfc_replace_expr (e, gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
1359
1360   mpz_set (e->value.integer, p->value);
1361
1362   return;
1363 }
1364
1365
1366 /* Expand an expression with that is inside of a constructor,
1367    recursing into other constructors if present.  */
1368
1369 static gfc_try
1370 expand_expr (gfc_expr *e)
1371 {
1372   if (e->expr_type == EXPR_ARRAY)
1373     return expand_constructor (e->value.constructor);
1374
1375   e = gfc_copy_expr (e);
1376
1377   if (gfc_simplify_expr (e, 1) == FAILURE)
1378     {
1379       gfc_free_expr (e);
1380       return FAILURE;
1381     }
1382
1383   return current_expand.expand_work_function (e);
1384 }
1385
1386
1387 static gfc_try
1388 expand_iterator (gfc_constructor *c)
1389 {
1390   gfc_expr *start, *end, *step;
1391   iterator_stack frame;
1392   mpz_t trip;
1393   gfc_try t;
1394
1395   end = step = NULL;
1396
1397   t = FAILURE;
1398
1399   mpz_init (trip);
1400   mpz_init (frame.value);
1401   frame.prev = NULL;
1402
1403   start = gfc_copy_expr (c->iterator->start);
1404   if (gfc_simplify_expr (start, 1) == FAILURE)
1405     goto cleanup;
1406
1407   if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER)
1408     goto cleanup;
1409
1410   end = gfc_copy_expr (c->iterator->end);
1411   if (gfc_simplify_expr (end, 1) == FAILURE)
1412     goto cleanup;
1413
1414   if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER)
1415     goto cleanup;
1416
1417   step = gfc_copy_expr (c->iterator->step);
1418   if (gfc_simplify_expr (step, 1) == FAILURE)
1419     goto cleanup;
1420
1421   if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER)
1422     goto cleanup;
1423
1424   if (mpz_sgn (step->value.integer) == 0)
1425     {
1426       gfc_error ("Iterator step at %L cannot be zero", &step->where);
1427       goto cleanup;
1428     }
1429
1430   /* Calculate the trip count of the loop.  */
1431   mpz_sub (trip, end->value.integer, start->value.integer);
1432   mpz_add (trip, trip, step->value.integer);
1433   mpz_tdiv_q (trip, trip, step->value.integer);
1434
1435   mpz_set (frame.value, start->value.integer);
1436
1437   frame.prev = iter_stack;
1438   frame.variable = c->iterator->var->symtree;
1439   iter_stack = &frame;
1440
1441   while (mpz_sgn (trip) > 0)
1442     {
1443       if (expand_expr (c->expr) == FAILURE)
1444         goto cleanup;
1445
1446       mpz_add (frame.value, frame.value, step->value.integer);
1447       mpz_sub_ui (trip, trip, 1);
1448     }
1449
1450   t = SUCCESS;
1451
1452 cleanup:
1453   gfc_free_expr (start);
1454   gfc_free_expr (end);
1455   gfc_free_expr (step);
1456
1457   mpz_clear (trip);
1458   mpz_clear (frame.value);
1459
1460   iter_stack = frame.prev;
1461
1462   return t;
1463 }
1464
1465
1466 /* Expand a constructor into constant constructors without any
1467    iterators, calling the work function for each of the expanded
1468    expressions.  The work function needs to either save or free the
1469    passed expression.  */
1470
1471 static gfc_try
1472 expand_constructor (gfc_constructor_base base)
1473 {
1474   gfc_constructor *c;
1475   gfc_expr *e;
1476
1477   for (c = gfc_constructor_first (base); c; c = gfc_constructor_next(c))
1478     {
1479       if (c->iterator != NULL)
1480         {
1481           if (expand_iterator (c) == FAILURE)
1482             return FAILURE;
1483           continue;
1484         }
1485
1486       e = c->expr;
1487
1488       if (e->expr_type == EXPR_ARRAY)
1489         {
1490           if (expand_constructor (e->value.constructor) == FAILURE)
1491             return FAILURE;
1492
1493           continue;
1494         }
1495
1496       e = gfc_copy_expr (e);
1497       if (gfc_simplify_expr (e, 1) == FAILURE)
1498         {
1499           gfc_free_expr (e);
1500           return FAILURE;
1501         }
1502       current_expand.offset = &c->offset;
1503       current_expand.repeat = &c->repeat;
1504       current_expand.component = c->n.component;
1505       if (current_expand.expand_work_function (e) == FAILURE)
1506         return FAILURE;
1507     }
1508   return SUCCESS;
1509 }
1510
1511
1512 /* Given an array expression and an element number (starting at zero),
1513    return a pointer to the array element.  NULL is returned if the
1514    size of the array has been exceeded.  The expression node returned
1515    remains a part of the array and should not be freed.  Access is not
1516    efficient at all, but this is another place where things do not
1517    have to be particularly fast.  */
1518
1519 static gfc_expr *
1520 gfc_get_array_element (gfc_expr *array, int element)
1521 {
1522   expand_info expand_save;
1523   gfc_expr *e;
1524   gfc_try rc;
1525
1526   expand_save = current_expand;
1527   current_expand.extract_n = element;
1528   current_expand.expand_work_function = extract_element;
1529   current_expand.extracted = NULL;
1530   current_expand.extract_count = 0;
1531
1532   iter_stack = NULL;
1533
1534   rc = expand_constructor (array->value.constructor);
1535   e = current_expand.extracted;
1536   current_expand = expand_save;
1537
1538   if (rc == FAILURE)
1539     return NULL;
1540
1541   return e;
1542 }
1543
1544
1545 /* Top level subroutine for expanding constructors.  We only expand
1546    constructor if they are small enough.  */
1547
1548 gfc_try
1549 gfc_expand_constructor (gfc_expr *e)
1550 {
1551   expand_info expand_save;
1552   gfc_expr *f;
1553   gfc_try rc;
1554
1555   /* If we can successfully get an array element at the max array size then
1556      the array is too big to expand, so we just return.  */
1557   f = gfc_get_array_element (e, gfc_option.flag_max_array_constructor);
1558   if (f != NULL)
1559     {
1560       gfc_free_expr (f);
1561       return SUCCESS;
1562     }
1563
1564   /* We now know the array is not too big so go ahead and try to expand it.  */
1565   expand_save = current_expand;
1566   current_expand.base = NULL;
1567
1568   iter_stack = NULL;
1569
1570   current_expand.expand_work_function = expand;
1571
1572   if (expand_constructor (e->value.constructor) == FAILURE)
1573     {
1574       gfc_constructor_free (current_expand.base);
1575       rc = FAILURE;
1576       goto done;
1577     }
1578
1579   gfc_constructor_free (e->value.constructor);
1580   e->value.constructor = current_expand.base;
1581
1582   rc = SUCCESS;
1583
1584 done:
1585   current_expand = expand_save;
1586
1587   return rc;
1588 }
1589
1590
1591 /* Work function for checking that an element of a constructor is a
1592    constant, after removal of any iteration variables.  We return
1593    FAILURE if not so.  */
1594
1595 static gfc_try
1596 is_constant_element (gfc_expr *e)
1597 {
1598   int rv;
1599
1600   rv = gfc_is_constant_expr (e);
1601   gfc_free_expr (e);
1602
1603   return rv ? SUCCESS : FAILURE;
1604 }
1605
1606
1607 /* Given an array constructor, determine if the constructor is
1608    constant or not by expanding it and making sure that all elements
1609    are constants.  This is a bit of a hack since something like (/ (i,
1610    i=1,100000000) /) will take a while as* opposed to a more clever
1611    function that traverses the expression tree. FIXME.  */
1612
1613 int
1614 gfc_constant_ac (gfc_expr *e)
1615 {
1616   expand_info expand_save;
1617   gfc_try rc;
1618
1619   iter_stack = NULL;
1620   expand_save = current_expand;
1621   current_expand.expand_work_function = is_constant_element;
1622
1623   rc = expand_constructor (e->value.constructor);
1624
1625   current_expand = expand_save;
1626   if (rc == FAILURE)
1627     return 0;
1628
1629   return 1;
1630 }
1631
1632
1633 /* Returns nonzero if an array constructor has been completely
1634    expanded (no iterators) and zero if iterators are present.  */
1635
1636 int
1637 gfc_expanded_ac (gfc_expr *e)
1638 {
1639   gfc_constructor *c;
1640
1641   if (e->expr_type == EXPR_ARRAY)
1642     for (c = gfc_constructor_first (e->value.constructor);
1643          c; c = gfc_constructor_next (c))
1644       if (c->iterator != NULL || !gfc_expanded_ac (c->expr))
1645         return 0;
1646
1647   return 1;
1648 }
1649
1650
1651 /*************** Type resolution of array constructors ***************/
1652
1653 /* Recursive array list resolution function.  All of the elements must
1654    be of the same type.  */
1655
1656 static gfc_try
1657 resolve_array_list (gfc_constructor_base base)
1658 {
1659   gfc_try t;
1660   gfc_constructor *c;
1661
1662   t = SUCCESS;
1663
1664   for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1665     {
1666       if (c->iterator != NULL
1667           && gfc_resolve_iterator (c->iterator, false) == FAILURE)
1668         t = FAILURE;
1669
1670       if (gfc_resolve_expr (c->expr) == FAILURE)
1671         t = FAILURE;
1672     }
1673
1674   return t;
1675 }
1676
1677 /* Resolve character array constructor. If it has a specified constant character
1678    length, pad/truncate the elements here; if the length is not specified and
1679    all elements are of compile-time known length, emit an error as this is
1680    invalid.  */
1681
1682 gfc_try
1683 gfc_resolve_character_array_constructor (gfc_expr *expr)
1684 {
1685   gfc_constructor *p;
1686   int found_length;
1687
1688   gcc_assert (expr->expr_type == EXPR_ARRAY);
1689   gcc_assert (expr->ts.type == BT_CHARACTER);
1690
1691   if (expr->ts.u.cl == NULL)
1692     {
1693       for (p = gfc_constructor_first (expr->value.constructor);
1694            p; p = gfc_constructor_next (p))
1695         if (p->expr->ts.u.cl != NULL)
1696           {
1697             /* Ensure that if there is a char_len around that it is
1698                used; otherwise the middle-end confuses them!  */
1699             expr->ts.u.cl = p->expr->ts.u.cl;
1700             goto got_charlen;
1701           }
1702
1703       expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1704     }
1705
1706 got_charlen:
1707
1708   found_length = -1;
1709
1710   if (expr->ts.u.cl->length == NULL)
1711     {
1712       /* Check that all constant string elements have the same length until
1713          we reach the end or find a variable-length one.  */
1714
1715       for (p = gfc_constructor_first (expr->value.constructor);
1716            p; p = gfc_constructor_next (p))
1717         {
1718           int current_length = -1;
1719           gfc_ref *ref;
1720           for (ref = p->expr->ref; ref; ref = ref->next)
1721             if (ref->type == REF_SUBSTRING
1722                 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1723                 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1724               break;
1725
1726           if (p->expr->expr_type == EXPR_CONSTANT)
1727             current_length = p->expr->value.character.length;
1728           else if (ref)
1729             {
1730               long j;
1731               j = mpz_get_ui (ref->u.ss.end->value.integer)
1732                 - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
1733               current_length = (int) j;
1734             }
1735           else if (p->expr->ts.u.cl && p->expr->ts.u.cl->length
1736                    && p->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1737             {
1738               long j;
1739               j = mpz_get_si (p->expr->ts.u.cl->length->value.integer);
1740               current_length = (int) j;
1741             }
1742           else
1743             return SUCCESS;
1744
1745           gcc_assert (current_length != -1);
1746
1747           if (found_length == -1)
1748             found_length = current_length;
1749           else if (found_length != current_length)
1750             {
1751               gfc_error ("Different CHARACTER lengths (%d/%d) in array"
1752                          " constructor at %L", found_length, current_length,
1753                          &p->expr->where);
1754               return FAILURE;
1755             }
1756
1757           gcc_assert (found_length == current_length);
1758         }
1759
1760       gcc_assert (found_length != -1);
1761
1762       /* Update the character length of the array constructor.  */
1763       expr->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
1764                                                 NULL, found_length);
1765     }
1766   else 
1767     {
1768       /* We've got a character length specified.  It should be an integer,
1769          otherwise an error is signalled elsewhere.  */
1770       gcc_assert (expr->ts.u.cl->length);
1771
1772       /* If we've got a constant character length, pad according to this.
1773          gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
1774          max_length only if they pass.  */
1775       gfc_extract_int (expr->ts.u.cl->length, &found_length);
1776
1777       /* Now pad/truncate the elements accordingly to the specified character
1778          length.  This is ok inside this conditional, as in the case above
1779          (without typespec) all elements are verified to have the same length
1780          anyway.  */
1781       if (found_length != -1)
1782         for (p = gfc_constructor_first (expr->value.constructor);
1783              p; p = gfc_constructor_next (p))
1784           if (p->expr->expr_type == EXPR_CONSTANT)
1785             {
1786               gfc_expr *cl = NULL;
1787               int current_length = -1;
1788               bool has_ts;
1789
1790               if (p->expr->ts.u.cl && p->expr->ts.u.cl->length)
1791               {
1792                 cl = p->expr->ts.u.cl->length;
1793                 gfc_extract_int (cl, &current_length);
1794               }
1795
1796               /* If gfc_extract_int above set current_length, we implicitly
1797                  know the type is BT_INTEGER and it's EXPR_CONSTANT.  */
1798
1799               has_ts = (expr->ts.u.cl && expr->ts.u.cl->length_from_typespec);
1800
1801               if (! cl
1802                   || (current_length != -1 && current_length < found_length))
1803                 gfc_set_constant_character_len (found_length, p->expr,
1804                                                 has_ts ? -1 : found_length);
1805             }
1806     }
1807
1808   return SUCCESS;
1809 }
1810
1811
1812 /* Resolve all of the expressions in an array list.  */
1813
1814 gfc_try
1815 gfc_resolve_array_constructor (gfc_expr *expr)
1816 {
1817   gfc_try t;
1818
1819   t = resolve_array_list (expr->value.constructor);
1820   if (t == SUCCESS)
1821     t = gfc_check_constructor_type (expr);
1822
1823   /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
1824      the call to this function, so we don't need to call it here; if it was
1825      called twice, an error message there would be duplicated.  */
1826
1827   return t;
1828 }
1829
1830
1831 /* Copy an iterator structure.  */
1832
1833 gfc_iterator *
1834 gfc_copy_iterator (gfc_iterator *src)
1835 {
1836   gfc_iterator *dest;
1837
1838   if (src == NULL)
1839     return NULL;
1840
1841   dest = gfc_get_iterator ();
1842
1843   dest->var = gfc_copy_expr (src->var);
1844   dest->start = gfc_copy_expr (src->start);
1845   dest->end = gfc_copy_expr (src->end);
1846   dest->step = gfc_copy_expr (src->step);
1847
1848   return dest;
1849 }
1850
1851
1852 /********* Subroutines for determining the size of an array *********/
1853
1854 /* These are needed just to accommodate RESHAPE().  There are no
1855    diagnostics here, we just return a negative number if something
1856    goes wrong.  */
1857
1858
1859 /* Get the size of single dimension of an array specification.  The
1860    array is guaranteed to be one dimensional.  */
1861
1862 gfc_try
1863 spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
1864 {
1865   if (as == NULL)
1866     return FAILURE;
1867
1868   if (dimen < 0 || dimen > as->rank - 1)
1869     gfc_internal_error ("spec_dimen_size(): Bad dimension");
1870
1871   if (as->type != AS_EXPLICIT
1872       || as->lower[dimen]->expr_type != EXPR_CONSTANT
1873       || as->upper[dimen]->expr_type != EXPR_CONSTANT
1874       || as->lower[dimen]->ts.type != BT_INTEGER
1875       || as->upper[dimen]->ts.type != BT_INTEGER)
1876     return FAILURE;
1877
1878   mpz_init (*result);
1879
1880   mpz_sub (*result, as->upper[dimen]->value.integer,
1881            as->lower[dimen]->value.integer);
1882
1883   mpz_add_ui (*result, *result, 1);
1884
1885   return SUCCESS;
1886 }
1887
1888
1889 gfc_try
1890 spec_size (gfc_array_spec *as, mpz_t *result)
1891 {
1892   mpz_t size;
1893   int d;
1894
1895   mpz_init_set_ui (*result, 1);
1896
1897   for (d = 0; d < as->rank; d++)
1898     {
1899       if (spec_dimen_size (as, d, &size) == FAILURE)
1900         {
1901           mpz_clear (*result);
1902           return FAILURE;
1903         }
1904
1905       mpz_mul (*result, *result, size);
1906       mpz_clear (size);
1907     }
1908
1909   return SUCCESS;
1910 }
1911
1912
1913 /* Get the number of elements in an array section.  */
1914
1915 gfc_try
1916 gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result)
1917 {
1918   mpz_t upper, lower, stride;
1919   gfc_try t;
1920
1921   if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
1922     gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
1923
1924   switch (ar->dimen_type[dimen])
1925     {
1926     case DIMEN_ELEMENT:
1927       mpz_init (*result);
1928       mpz_set_ui (*result, 1);
1929       t = SUCCESS;
1930       break;
1931
1932     case DIMEN_VECTOR:
1933       t = gfc_array_size (ar->start[dimen], result);    /* Recurse! */
1934       break;
1935
1936     case DIMEN_RANGE:
1937       mpz_init (upper);
1938       mpz_init (lower);
1939       mpz_init (stride);
1940       t = FAILURE;
1941
1942       if (ar->start[dimen] == NULL)
1943         {
1944           if (ar->as->lower[dimen] == NULL
1945               || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT)
1946             goto cleanup;
1947           mpz_set (lower, ar->as->lower[dimen]->value.integer);
1948         }
1949       else
1950         {
1951           if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
1952             goto cleanup;
1953           mpz_set (lower, ar->start[dimen]->value.integer);
1954         }
1955
1956       if (ar->end[dimen] == NULL)
1957         {
1958           if (ar->as->upper[dimen] == NULL
1959               || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT)
1960             goto cleanup;
1961           mpz_set (upper, ar->as->upper[dimen]->value.integer);
1962         }
1963       else
1964         {
1965           if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
1966             goto cleanup;
1967           mpz_set (upper, ar->end[dimen]->value.integer);
1968         }
1969
1970       if (ar->stride[dimen] == NULL)
1971         mpz_set_ui (stride, 1);
1972       else
1973         {
1974           if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
1975             goto cleanup;
1976           mpz_set (stride, ar->stride[dimen]->value.integer);
1977         }
1978
1979       mpz_init (*result);
1980       mpz_sub (*result, upper, lower);
1981       mpz_add (*result, *result, stride);
1982       mpz_div (*result, *result, stride);
1983
1984       /* Zero stride caught earlier.  */
1985       if (mpz_cmp_ui (*result, 0) < 0)
1986         mpz_set_ui (*result, 0);
1987       t = SUCCESS;
1988
1989     cleanup:
1990       mpz_clear (upper);
1991       mpz_clear (lower);
1992       mpz_clear (stride);
1993       return t;
1994
1995     default:
1996       gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
1997     }
1998
1999   return t;
2000 }
2001
2002
2003 static gfc_try
2004 ref_size (gfc_array_ref *ar, mpz_t *result)
2005 {
2006   mpz_t size;
2007   int d;
2008
2009   mpz_init_set_ui (*result, 1);
2010
2011   for (d = 0; d < ar->dimen; d++)
2012     {
2013       if (gfc_ref_dimen_size (ar, d, &size) == FAILURE)
2014         {
2015           mpz_clear (*result);
2016           return FAILURE;
2017         }
2018
2019       mpz_mul (*result, *result, size);
2020       mpz_clear (size);
2021     }
2022
2023   return SUCCESS;
2024 }
2025
2026
2027 /* Given an array expression and a dimension, figure out how many
2028    elements it has along that dimension.  Returns SUCCESS if we were
2029    able to return a result in the 'result' variable, FAILURE
2030    otherwise.  */
2031
2032 gfc_try
2033 gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
2034 {
2035   gfc_ref *ref;
2036   int i;
2037
2038   if (dimen < 0 || array == NULL || dimen > array->rank - 1)
2039     gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2040
2041   switch (array->expr_type)
2042     {
2043     case EXPR_VARIABLE:
2044     case EXPR_FUNCTION:
2045       for (ref = array->ref; ref; ref = ref->next)
2046         {
2047           if (ref->type != REF_ARRAY)
2048             continue;
2049
2050           if (ref->u.ar.type == AR_FULL)
2051             return spec_dimen_size (ref->u.ar.as, dimen, result);
2052
2053           if (ref->u.ar.type == AR_SECTION)
2054             {
2055               for (i = 0; dimen >= 0; i++)
2056                 if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2057                   dimen--;
2058
2059               return gfc_ref_dimen_size (&ref->u.ar, i - 1, result);
2060             }
2061         }
2062
2063       if (array->shape && array->shape[dimen])
2064         {
2065           mpz_init_set (*result, array->shape[dimen]);
2066           return SUCCESS;
2067         }
2068
2069       if (array->symtree->n.sym->attr.generic
2070           && array->value.function.esym != NULL)
2071         {
2072           if (spec_dimen_size (array->value.function.esym->as, dimen, result)
2073               == FAILURE)
2074             return FAILURE;
2075         }
2076       else if (spec_dimen_size (array->symtree->n.sym->as, dimen, result)
2077                == FAILURE)
2078         return FAILURE;
2079
2080       break;
2081
2082     case EXPR_ARRAY:
2083       if (array->shape == NULL) {
2084         /* Expressions with rank > 1 should have "shape" properly set */
2085         if ( array->rank != 1 )
2086           gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2087         return gfc_array_size(array, result);
2088       }
2089
2090       /* Fall through */
2091     default:
2092       if (array->shape == NULL)
2093         return FAILURE;
2094
2095       mpz_init_set (*result, array->shape[dimen]);
2096
2097       break;
2098     }
2099
2100   return SUCCESS;
2101 }
2102
2103
2104 /* Given an array expression, figure out how many elements are in the
2105    array.  Returns SUCCESS if this is possible, and sets the 'result'
2106    variable.  Otherwise returns FAILURE.  */
2107
2108 gfc_try
2109 gfc_array_size (gfc_expr *array, mpz_t *result)
2110 {
2111   expand_info expand_save;
2112   gfc_ref *ref;
2113   int i;
2114   gfc_try t;
2115
2116   switch (array->expr_type)
2117     {
2118     case EXPR_ARRAY:
2119       gfc_push_suppress_errors ();
2120
2121       expand_save = current_expand;
2122
2123       current_expand.count = result;
2124       mpz_init_set_ui (*result, 0);
2125
2126       current_expand.expand_work_function = count_elements;
2127       iter_stack = NULL;
2128
2129       t = expand_constructor (array->value.constructor);
2130
2131       gfc_pop_suppress_errors ();
2132
2133       if (t == FAILURE)
2134         mpz_clear (*result);
2135       current_expand = expand_save;
2136       return t;
2137
2138     case EXPR_VARIABLE:
2139       for (ref = array->ref; ref; ref = ref->next)
2140         {
2141           if (ref->type != REF_ARRAY)
2142             continue;
2143
2144           if (ref->u.ar.type == AR_FULL)
2145             return spec_size (ref->u.ar.as, result);
2146
2147           if (ref->u.ar.type == AR_SECTION)
2148             return ref_size (&ref->u.ar, result);
2149         }
2150
2151       return spec_size (array->symtree->n.sym->as, result);
2152
2153
2154     default:
2155       if (array->rank == 0 || array->shape == NULL)
2156         return FAILURE;
2157
2158       mpz_init_set_ui (*result, 1);
2159
2160       for (i = 0; i < array->rank; i++)
2161         mpz_mul (*result, *result, array->shape[i]);
2162
2163       break;
2164     }
2165
2166   return SUCCESS;
2167 }
2168
2169
2170 /* Given an array reference, return the shape of the reference in an
2171    array of mpz_t integers.  */
2172
2173 gfc_try
2174 gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
2175 {
2176   int d;
2177   int i;
2178
2179   d = 0;
2180
2181   switch (ar->type)
2182     {
2183     case AR_FULL:
2184       for (; d < ar->as->rank; d++)
2185         if (spec_dimen_size (ar->as, d, &shape[d]) == FAILURE)
2186           goto cleanup;
2187
2188       return SUCCESS;
2189
2190     case AR_SECTION:
2191       for (i = 0; i < ar->dimen; i++)
2192         {
2193           if (ar->dimen_type[i] != DIMEN_ELEMENT)
2194             {
2195               if (gfc_ref_dimen_size (ar, i, &shape[d]) == FAILURE)
2196                 goto cleanup;
2197               d++;
2198             }
2199         }
2200
2201       return SUCCESS;
2202
2203     default:
2204       break;
2205     }
2206
2207 cleanup:
2208   for (d--; d >= 0; d--)
2209     mpz_clear (shape[d]);
2210
2211   return FAILURE;
2212 }
2213
2214
2215 /* Given an array expression, find the array reference structure that
2216    characterizes the reference.  */
2217
2218 gfc_array_ref *
2219 gfc_find_array_ref (gfc_expr *e)
2220 {
2221   gfc_ref *ref;
2222
2223   for (ref = e->ref; ref; ref = ref->next)
2224     if (ref->type == REF_ARRAY
2225         && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION
2226             || (ref->u.ar.type == AR_ELEMENT && ref->u.ar.dimen == 0)))
2227       break;
2228
2229   if (ref == NULL)
2230     gfc_internal_error ("gfc_find_array_ref(): No ref found");
2231
2232   return &ref->u.ar;
2233 }
2234
2235
2236 /* Find out if an array shape is known at compile time.  */
2237
2238 int
2239 gfc_is_compile_time_shape (gfc_array_spec *as)
2240 {
2241   int i;
2242
2243   if (as->type != AS_EXPLICIT)
2244     return 0;
2245
2246   for (i = 0; i < as->rank; i++)
2247     if (!gfc_is_constant_expr (as->lower[i])
2248         || !gfc_is_constant_expr (as->upper[i]))
2249       return 0;
2250
2251   return 1;
2252 }