OSDN Git Service

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