OSDN Git Service

0c36f544e6d30532b620c6a09f89096a66b0ebd3
[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 = MATCH_ERROR;
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_fatal_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_fatal_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.component = c->n.component;
1504       if (current_expand.expand_work_function (e) == FAILURE)
1505         return FAILURE;
1506     }
1507   return SUCCESS;
1508 }
1509
1510
1511 /* Given an array expression and an element number (starting at zero),
1512    return a pointer to the array element.  NULL is returned if the
1513    size of the array has been exceeded.  The expression node returned
1514    remains a part of the array and should not be freed.  Access is not
1515    efficient at all, but this is another place where things do not
1516    have to be particularly fast.  */
1517
1518 static gfc_expr *
1519 gfc_get_array_element (gfc_expr *array, int element)
1520 {
1521   expand_info expand_save;
1522   gfc_expr *e;
1523   gfc_try rc;
1524
1525   expand_save = current_expand;
1526   current_expand.extract_n = element;
1527   current_expand.expand_work_function = extract_element;
1528   current_expand.extracted = NULL;
1529   current_expand.extract_count = 0;
1530
1531   iter_stack = NULL;
1532
1533   rc = expand_constructor (array->value.constructor);
1534   e = current_expand.extracted;
1535   current_expand = expand_save;
1536
1537   if (rc == FAILURE)
1538     return NULL;
1539
1540   return e;
1541 }
1542
1543
1544 /* Top level subroutine for expanding constructors.  We only expand
1545    constructor if they are small enough.  */
1546
1547 gfc_try
1548 gfc_expand_constructor (gfc_expr *e, bool fatal)
1549 {
1550   expand_info expand_save;
1551   gfc_expr *f;
1552   gfc_try rc;
1553
1554   /* If we can successfully get an array element at the max array size then
1555      the array is too big to expand, so we just return.  */
1556   f = gfc_get_array_element (e, gfc_option.flag_max_array_constructor);
1557   if (f != NULL)
1558     {
1559       gfc_free_expr (f);
1560       if (fatal)
1561         {
1562           gfc_error ("The number of elements in the array constructor "
1563                      "at %L requires an increase of the allowed %d "
1564                      "upper limit.   See -fmax-array-constructor "
1565                      "option", &e->where,
1566                      gfc_option.flag_max_array_constructor);
1567           return FAILURE;
1568         }
1569       return SUCCESS;
1570     }
1571
1572   /* We now know the array is not too big so go ahead and try to expand it.  */
1573   expand_save = current_expand;
1574   current_expand.base = NULL;
1575
1576   iter_stack = NULL;
1577
1578   current_expand.expand_work_function = expand;
1579
1580   if (expand_constructor (e->value.constructor) == FAILURE)
1581     {
1582       gfc_constructor_free (current_expand.base);
1583       rc = FAILURE;
1584       goto done;
1585     }
1586
1587   gfc_constructor_free (e->value.constructor);
1588   e->value.constructor = current_expand.base;
1589
1590   rc = SUCCESS;
1591
1592 done:
1593   current_expand = expand_save;
1594
1595   return rc;
1596 }
1597
1598
1599 /* Work function for checking that an element of a constructor is a
1600    constant, after removal of any iteration variables.  We return
1601    FAILURE if not so.  */
1602
1603 static gfc_try
1604 is_constant_element (gfc_expr *e)
1605 {
1606   int rv;
1607
1608   rv = gfc_is_constant_expr (e);
1609   gfc_free_expr (e);
1610
1611   return rv ? SUCCESS : FAILURE;
1612 }
1613
1614
1615 /* Given an array constructor, determine if the constructor is
1616    constant or not by expanding it and making sure that all elements
1617    are constants.  This is a bit of a hack since something like (/ (i,
1618    i=1,100000000) /) will take a while as* opposed to a more clever
1619    function that traverses the expression tree. FIXME.  */
1620
1621 int
1622 gfc_constant_ac (gfc_expr *e)
1623 {
1624   expand_info expand_save;
1625   gfc_try rc;
1626
1627   iter_stack = NULL;
1628   expand_save = current_expand;
1629   current_expand.expand_work_function = is_constant_element;
1630
1631   rc = expand_constructor (e->value.constructor);
1632
1633   current_expand = expand_save;
1634   if (rc == FAILURE)
1635     return 0;
1636
1637   return 1;
1638 }
1639
1640
1641 /* Returns nonzero if an array constructor has been completely
1642    expanded (no iterators) and zero if iterators are present.  */
1643
1644 int
1645 gfc_expanded_ac (gfc_expr *e)
1646 {
1647   gfc_constructor *c;
1648
1649   if (e->expr_type == EXPR_ARRAY)
1650     for (c = gfc_constructor_first (e->value.constructor);
1651          c; c = gfc_constructor_next (c))
1652       if (c->iterator != NULL || !gfc_expanded_ac (c->expr))
1653         return 0;
1654
1655   return 1;
1656 }
1657
1658
1659 /*************** Type resolution of array constructors ***************/
1660
1661 /* Recursive array list resolution function.  All of the elements must
1662    be of the same type.  */
1663
1664 static gfc_try
1665 resolve_array_list (gfc_constructor_base base)
1666 {
1667   gfc_try t;
1668   gfc_constructor *c;
1669
1670   t = SUCCESS;
1671
1672   for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1673     {
1674       if (c->iterator != NULL
1675           && gfc_resolve_iterator (c->iterator, false) == FAILURE)
1676         t = FAILURE;
1677
1678       if (gfc_resolve_expr (c->expr) == FAILURE)
1679         t = FAILURE;
1680     }
1681
1682   return t;
1683 }
1684
1685 /* Resolve character array constructor. If it has a specified constant character
1686    length, pad/truncate the elements here; if the length is not specified and
1687    all elements are of compile-time known length, emit an error as this is
1688    invalid.  */
1689
1690 gfc_try
1691 gfc_resolve_character_array_constructor (gfc_expr *expr)
1692 {
1693   gfc_constructor *p;
1694   int found_length;
1695
1696   gcc_assert (expr->expr_type == EXPR_ARRAY);
1697   gcc_assert (expr->ts.type == BT_CHARACTER);
1698
1699   if (expr->ts.u.cl == NULL)
1700     {
1701       for (p = gfc_constructor_first (expr->value.constructor);
1702            p; p = gfc_constructor_next (p))
1703         if (p->expr->ts.u.cl != NULL)
1704           {
1705             /* Ensure that if there is a char_len around that it is
1706                used; otherwise the middle-end confuses them!  */
1707             expr->ts.u.cl = p->expr->ts.u.cl;
1708             goto got_charlen;
1709           }
1710
1711       expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1712     }
1713
1714 got_charlen:
1715
1716   found_length = -1;
1717
1718   if (expr->ts.u.cl->length == NULL)
1719     {
1720       /* Check that all constant string elements have the same length until
1721          we reach the end or find a variable-length one.  */
1722
1723       for (p = gfc_constructor_first (expr->value.constructor);
1724            p; p = gfc_constructor_next (p))
1725         {
1726           int current_length = -1;
1727           gfc_ref *ref;
1728           for (ref = p->expr->ref; ref; ref = ref->next)
1729             if (ref->type == REF_SUBSTRING
1730                 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1731                 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1732               break;
1733
1734           if (p->expr->expr_type == EXPR_CONSTANT)
1735             current_length = p->expr->value.character.length;
1736           else if (ref)
1737             {
1738               long j;
1739               j = mpz_get_ui (ref->u.ss.end->value.integer)
1740                 - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
1741               current_length = (int) j;
1742             }
1743           else if (p->expr->ts.u.cl && p->expr->ts.u.cl->length
1744                    && p->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1745             {
1746               long j;
1747               j = mpz_get_si (p->expr->ts.u.cl->length->value.integer);
1748               current_length = (int) j;
1749             }
1750           else
1751             return SUCCESS;
1752
1753           gcc_assert (current_length != -1);
1754
1755           if (found_length == -1)
1756             found_length = current_length;
1757           else if (found_length != current_length)
1758             {
1759               gfc_error ("Different CHARACTER lengths (%d/%d) in array"
1760                          " constructor at %L", found_length, current_length,
1761                          &p->expr->where);
1762               return FAILURE;
1763             }
1764
1765           gcc_assert (found_length == current_length);
1766         }
1767
1768       gcc_assert (found_length != -1);
1769
1770       /* Update the character length of the array constructor.  */
1771       expr->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
1772                                                 NULL, found_length);
1773     }
1774   else 
1775     {
1776       /* We've got a character length specified.  It should be an integer,
1777          otherwise an error is signalled elsewhere.  */
1778       gcc_assert (expr->ts.u.cl->length);
1779
1780       /* If we've got a constant character length, pad according to this.
1781          gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
1782          max_length only if they pass.  */
1783       gfc_extract_int (expr->ts.u.cl->length, &found_length);
1784
1785       /* Now pad/truncate the elements accordingly to the specified character
1786          length.  This is ok inside this conditional, as in the case above
1787          (without typespec) all elements are verified to have the same length
1788          anyway.  */
1789       if (found_length != -1)
1790         for (p = gfc_constructor_first (expr->value.constructor);
1791              p; p = gfc_constructor_next (p))
1792           if (p->expr->expr_type == EXPR_CONSTANT)
1793             {
1794               gfc_expr *cl = NULL;
1795               int current_length = -1;
1796               bool has_ts;
1797
1798               if (p->expr->ts.u.cl && p->expr->ts.u.cl->length)
1799               {
1800                 cl = p->expr->ts.u.cl->length;
1801                 gfc_extract_int (cl, &current_length);
1802               }
1803
1804               /* If gfc_extract_int above set current_length, we implicitly
1805                  know the type is BT_INTEGER and it's EXPR_CONSTANT.  */
1806
1807               has_ts = (expr->ts.u.cl && expr->ts.u.cl->length_from_typespec);
1808
1809               if (! cl
1810                   || (current_length != -1 && current_length < found_length))
1811                 gfc_set_constant_character_len (found_length, p->expr,
1812                                                 has_ts ? -1 : found_length);
1813             }
1814     }
1815
1816   return SUCCESS;
1817 }
1818
1819
1820 /* Resolve all of the expressions in an array list.  */
1821
1822 gfc_try
1823 gfc_resolve_array_constructor (gfc_expr *expr)
1824 {
1825   gfc_try t;
1826
1827   t = resolve_array_list (expr->value.constructor);
1828   if (t == SUCCESS)
1829     t = gfc_check_constructor_type (expr);
1830
1831   /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
1832      the call to this function, so we don't need to call it here; if it was
1833      called twice, an error message there would be duplicated.  */
1834
1835   return t;
1836 }
1837
1838
1839 /* Copy an iterator structure.  */
1840
1841 gfc_iterator *
1842 gfc_copy_iterator (gfc_iterator *src)
1843 {
1844   gfc_iterator *dest;
1845
1846   if (src == NULL)
1847     return NULL;
1848
1849   dest = gfc_get_iterator ();
1850
1851   dest->var = gfc_copy_expr (src->var);
1852   dest->start = gfc_copy_expr (src->start);
1853   dest->end = gfc_copy_expr (src->end);
1854   dest->step = gfc_copy_expr (src->step);
1855
1856   return dest;
1857 }
1858
1859
1860 /********* Subroutines for determining the size of an array *********/
1861
1862 /* These are needed just to accommodate RESHAPE().  There are no
1863    diagnostics here, we just return a negative number if something
1864    goes wrong.  */
1865
1866
1867 /* Get the size of single dimension of an array specification.  The
1868    array is guaranteed to be one dimensional.  */
1869
1870 gfc_try
1871 spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
1872 {
1873   if (as == NULL)
1874     return FAILURE;
1875
1876   if (dimen < 0 || dimen > as->rank - 1)
1877     gfc_internal_error ("spec_dimen_size(): Bad dimension");
1878
1879   if (as->type != AS_EXPLICIT
1880       || as->lower[dimen]->expr_type != EXPR_CONSTANT
1881       || as->upper[dimen]->expr_type != EXPR_CONSTANT
1882       || as->lower[dimen]->ts.type != BT_INTEGER
1883       || as->upper[dimen]->ts.type != BT_INTEGER)
1884     return FAILURE;
1885
1886   mpz_init (*result);
1887
1888   mpz_sub (*result, as->upper[dimen]->value.integer,
1889            as->lower[dimen]->value.integer);
1890
1891   mpz_add_ui (*result, *result, 1);
1892
1893   return SUCCESS;
1894 }
1895
1896
1897 gfc_try
1898 spec_size (gfc_array_spec *as, mpz_t *result)
1899 {
1900   mpz_t size;
1901   int d;
1902
1903   mpz_init_set_ui (*result, 1);
1904
1905   for (d = 0; d < as->rank; d++)
1906     {
1907       if (spec_dimen_size (as, d, &size) == FAILURE)
1908         {
1909           mpz_clear (*result);
1910           return FAILURE;
1911         }
1912
1913       mpz_mul (*result, *result, size);
1914       mpz_clear (size);
1915     }
1916
1917   return SUCCESS;
1918 }
1919
1920
1921 /* Get the number of elements in an array section.  */
1922
1923 gfc_try
1924 gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result)
1925 {
1926   mpz_t upper, lower, stride;
1927   gfc_try t;
1928
1929   if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
1930     gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
1931
1932   switch (ar->dimen_type[dimen])
1933     {
1934     case DIMEN_ELEMENT:
1935       mpz_init (*result);
1936       mpz_set_ui (*result, 1);
1937       t = SUCCESS;
1938       break;
1939
1940     case DIMEN_VECTOR:
1941       t = gfc_array_size (ar->start[dimen], result);    /* Recurse! */
1942       break;
1943
1944     case DIMEN_RANGE:
1945       mpz_init (upper);
1946       mpz_init (lower);
1947       mpz_init (stride);
1948       t = FAILURE;
1949
1950       if (ar->start[dimen] == NULL)
1951         {
1952           if (ar->as->lower[dimen] == NULL
1953               || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT)
1954             goto cleanup;
1955           mpz_set (lower, ar->as->lower[dimen]->value.integer);
1956         }
1957       else
1958         {
1959           if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
1960             goto cleanup;
1961           mpz_set (lower, ar->start[dimen]->value.integer);
1962         }
1963
1964       if (ar->end[dimen] == NULL)
1965         {
1966           if (ar->as->upper[dimen] == NULL
1967               || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT)
1968             goto cleanup;
1969           mpz_set (upper, ar->as->upper[dimen]->value.integer);
1970         }
1971       else
1972         {
1973           if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
1974             goto cleanup;
1975           mpz_set (upper, ar->end[dimen]->value.integer);
1976         }
1977
1978       if (ar->stride[dimen] == NULL)
1979         mpz_set_ui (stride, 1);
1980       else
1981         {
1982           if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
1983             goto cleanup;
1984           mpz_set (stride, ar->stride[dimen]->value.integer);
1985         }
1986
1987       mpz_init (*result);
1988       mpz_sub (*result, upper, lower);
1989       mpz_add (*result, *result, stride);
1990       mpz_div (*result, *result, stride);
1991
1992       /* Zero stride caught earlier.  */
1993       if (mpz_cmp_ui (*result, 0) < 0)
1994         mpz_set_ui (*result, 0);
1995       t = SUCCESS;
1996
1997     cleanup:
1998       mpz_clear (upper);
1999       mpz_clear (lower);
2000       mpz_clear (stride);
2001       return t;
2002
2003     default:
2004       gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
2005     }
2006
2007   return t;
2008 }
2009
2010
2011 static gfc_try
2012 ref_size (gfc_array_ref *ar, mpz_t *result)
2013 {
2014   mpz_t size;
2015   int d;
2016
2017   mpz_init_set_ui (*result, 1);
2018
2019   for (d = 0; d < ar->dimen; d++)
2020     {
2021       if (gfc_ref_dimen_size (ar, d, &size) == FAILURE)
2022         {
2023           mpz_clear (*result);
2024           return FAILURE;
2025         }
2026
2027       mpz_mul (*result, *result, size);
2028       mpz_clear (size);
2029     }
2030
2031   return SUCCESS;
2032 }
2033
2034
2035 /* Given an array expression and a dimension, figure out how many
2036    elements it has along that dimension.  Returns SUCCESS if we were
2037    able to return a result in the 'result' variable, FAILURE
2038    otherwise.  */
2039
2040 gfc_try
2041 gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
2042 {
2043   gfc_ref *ref;
2044   int i;
2045
2046   if (dimen < 0 || array == NULL || dimen > array->rank - 1)
2047     gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2048
2049   switch (array->expr_type)
2050     {
2051     case EXPR_VARIABLE:
2052     case EXPR_FUNCTION:
2053       for (ref = array->ref; ref; ref = ref->next)
2054         {
2055           if (ref->type != REF_ARRAY)
2056             continue;
2057
2058           if (ref->u.ar.type == AR_FULL)
2059             return spec_dimen_size (ref->u.ar.as, dimen, result);
2060
2061           if (ref->u.ar.type == AR_SECTION)
2062             {
2063               for (i = 0; dimen >= 0; i++)
2064                 if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2065                   dimen--;
2066
2067               return gfc_ref_dimen_size (&ref->u.ar, i - 1, result);
2068             }
2069         }
2070
2071       if (array->shape && array->shape[dimen])
2072         {
2073           mpz_init_set (*result, array->shape[dimen]);
2074           return SUCCESS;
2075         }
2076
2077       if (array->symtree->n.sym->attr.generic
2078           && array->value.function.esym != NULL)
2079         {
2080           if (spec_dimen_size (array->value.function.esym->as, dimen, result)
2081               == FAILURE)
2082             return FAILURE;
2083         }
2084       else if (spec_dimen_size (array->symtree->n.sym->as, dimen, result)
2085                == FAILURE)
2086         return FAILURE;
2087
2088       break;
2089
2090     case EXPR_ARRAY:
2091       if (array->shape == NULL) {
2092         /* Expressions with rank > 1 should have "shape" properly set */
2093         if ( array->rank != 1 )
2094           gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2095         return gfc_array_size(array, result);
2096       }
2097
2098       /* Fall through */
2099     default:
2100       if (array->shape == NULL)
2101         return FAILURE;
2102
2103       mpz_init_set (*result, array->shape[dimen]);
2104
2105       break;
2106     }
2107
2108   return SUCCESS;
2109 }
2110
2111
2112 /* Given an array expression, figure out how many elements are in the
2113    array.  Returns SUCCESS if this is possible, and sets the 'result'
2114    variable.  Otherwise returns FAILURE.  */
2115
2116 gfc_try
2117 gfc_array_size (gfc_expr *array, mpz_t *result)
2118 {
2119   expand_info expand_save;
2120   gfc_ref *ref;
2121   int i;
2122   gfc_try t;
2123
2124   switch (array->expr_type)
2125     {
2126     case EXPR_ARRAY:
2127       gfc_push_suppress_errors ();
2128
2129       expand_save = current_expand;
2130
2131       current_expand.count = result;
2132       mpz_init_set_ui (*result, 0);
2133
2134       current_expand.expand_work_function = count_elements;
2135       iter_stack = NULL;
2136
2137       t = expand_constructor (array->value.constructor);
2138
2139       gfc_pop_suppress_errors ();
2140
2141       if (t == FAILURE)
2142         mpz_clear (*result);
2143       current_expand = expand_save;
2144       return t;
2145
2146     case EXPR_VARIABLE:
2147       for (ref = array->ref; ref; ref = ref->next)
2148         {
2149           if (ref->type != REF_ARRAY)
2150             continue;
2151
2152           if (ref->u.ar.type == AR_FULL)
2153             return spec_size (ref->u.ar.as, result);
2154
2155           if (ref->u.ar.type == AR_SECTION)
2156             return ref_size (&ref->u.ar, result);
2157         }
2158
2159       return spec_size (array->symtree->n.sym->as, result);
2160
2161
2162     default:
2163       if (array->rank == 0 || array->shape == NULL)
2164         return FAILURE;
2165
2166       mpz_init_set_ui (*result, 1);
2167
2168       for (i = 0; i < array->rank; i++)
2169         mpz_mul (*result, *result, array->shape[i]);
2170
2171       break;
2172     }
2173
2174   return SUCCESS;
2175 }
2176
2177
2178 /* Given an array reference, return the shape of the reference in an
2179    array of mpz_t integers.  */
2180
2181 gfc_try
2182 gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
2183 {
2184   int d;
2185   int i;
2186
2187   d = 0;
2188
2189   switch (ar->type)
2190     {
2191     case AR_FULL:
2192       for (; d < ar->as->rank; d++)
2193         if (spec_dimen_size (ar->as, d, &shape[d]) == FAILURE)
2194           goto cleanup;
2195
2196       return SUCCESS;
2197
2198     case AR_SECTION:
2199       for (i = 0; i < ar->dimen; i++)
2200         {
2201           if (ar->dimen_type[i] != DIMEN_ELEMENT)
2202             {
2203               if (gfc_ref_dimen_size (ar, i, &shape[d]) == FAILURE)
2204                 goto cleanup;
2205               d++;
2206             }
2207         }
2208
2209       return SUCCESS;
2210
2211     default:
2212       break;
2213     }
2214
2215 cleanup:
2216   for (d--; d >= 0; d--)
2217     mpz_clear (shape[d]);
2218
2219   return FAILURE;
2220 }
2221
2222
2223 /* Given an array expression, find the array reference structure that
2224    characterizes the reference.  */
2225
2226 gfc_array_ref *
2227 gfc_find_array_ref (gfc_expr *e)
2228 {
2229   gfc_ref *ref;
2230
2231   for (ref = e->ref; ref; ref = ref->next)
2232     if (ref->type == REF_ARRAY
2233         && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION
2234             || (ref->u.ar.type == AR_ELEMENT && ref->u.ar.dimen == 0)))
2235       break;
2236
2237   if (ref == NULL)
2238     gfc_internal_error ("gfc_find_array_ref(): No ref found");
2239
2240   return &ref->u.ar;
2241 }
2242
2243
2244 /* Find out if an array shape is known at compile time.  */
2245
2246 int
2247 gfc_is_compile_time_shape (gfc_array_spec *as)
2248 {
2249   int i;
2250
2251   if (as->type != AS_EXPLICIT)
2252     return 0;
2253
2254   for (i = 0; i < as->rank; i++)
2255     if (!gfc_is_constant_expr (as->lower[i])
2256         || !gfc_is_constant_expr (as->upper[i]))
2257       return 0;
2258
2259   return 1;
2260 }