OSDN Git Service

4a110bba0d528b88e770d48fe59fa9f1dc043ad9
[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   for (;;)
533     {
534       as->corank++;
535       current_type = match_array_element_spec (as);
536
537       if (current_type == AS_UNKNOWN)
538         goto cleanup;
539
540       if (as->corank == 1)
541         as->cotype = current_type;
542       else
543         switch (as->cotype)
544           { /* See how current spec meshes with the existing.  */
545             case AS_UNKNOWN:
546               goto cleanup;
547
548             case AS_EXPLICIT:
549               if (current_type == AS_ASSUMED_SIZE)
550                 {
551                   as->cotype = AS_ASSUMED_SIZE;
552                   break;
553                 }
554
555               if (current_type == AS_EXPLICIT)
556                 break;
557
558               gfc_error ("Bad array specification for an explicitly "
559                          "shaped array at %C");
560
561               goto cleanup;
562
563             case AS_ASSUMED_SHAPE:
564               if ((current_type == AS_ASSUMED_SHAPE)
565                   || (current_type == AS_DEFERRED))
566                 break;
567
568               gfc_error ("Bad array specification for assumed shape "
569                          "array at %C");
570               goto cleanup;
571
572             case AS_DEFERRED:
573               if (current_type == AS_DEFERRED)
574                 break;
575
576               if (current_type == AS_ASSUMED_SHAPE)
577                 {
578                   as->cotype = AS_ASSUMED_SHAPE;
579                   break;
580                 }
581
582               gfc_error ("Bad specification for deferred shape array at %C");
583               goto cleanup;
584
585             case AS_ASSUMED_SIZE:
586               gfc_error ("Bad specification for assumed size array at %C");
587               goto cleanup;
588           }
589
590       if (gfc_match_char (']') == MATCH_YES)
591         break;
592
593       if (gfc_match_char (',') != MATCH_YES)
594         {
595           gfc_error ("Expected another dimension in array declaration at %C");
596           goto cleanup;
597         }
598
599       if (as->corank >= GFC_MAX_DIMENSIONS)
600         {
601           gfc_error ("Array specification at %C has more than %d "
602                      "dimensions", GFC_MAX_DIMENSIONS);
603           goto cleanup;
604         }
605     }
606
607   if (current_type == AS_EXPLICIT)
608     {
609       gfc_error ("Upper bound of last coarray dimension must be '*' at %C");
610       goto cleanup;
611     }
612
613   if (as->cotype == AS_ASSUMED_SIZE)
614     as->cotype = AS_EXPLICIT;
615
616   if (as->rank == 0)
617     as->type = as->cotype;
618
619 done:
620   if (as->rank == 0 && as->corank == 0)
621     {
622       *asp = NULL;
623       gfc_free_array_spec (as);
624       return MATCH_NO;
625     }
626
627   /* If a lower bounds of an assumed shape array is blank, put in one.  */
628   if (as->type == AS_ASSUMED_SHAPE)
629     {
630       for (i = 0; i < as->rank + as->corank; i++)
631         {
632           if (as->lower[i] == NULL)
633             as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
634         }
635     }
636
637   *asp = as;
638
639   return MATCH_YES;
640
641 cleanup:
642   /* Something went wrong.  */
643   gfc_free_array_spec (as);
644   return MATCH_ERROR;
645 }
646
647
648 /* Given a symbol and an array specification, modify the symbol to
649    have that array specification.  The error locus is needed in case
650    something goes wrong.  On failure, the caller must free the spec.  */
651
652 gfc_try
653 gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
654 {
655   int i;
656
657   if (as == NULL)
658     return SUCCESS;
659
660   if (as->rank
661       && gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE)
662     return FAILURE;
663
664   if (as->corank
665       && gfc_add_codimension (&sym->attr, sym->name, error_loc) == FAILURE)
666     return FAILURE;
667
668   if (sym->as == NULL)
669     {
670       sym->as = as;
671       return SUCCESS;
672     }
673
674   if (as->corank)
675     {
676       /* The "sym" has no corank (checked via gfc_add_codimension). Thus
677          the codimension is simply added.  */
678       gcc_assert (as->rank == 0 && sym->as->corank == 0);
679
680       sym->as->cotype = as->cotype;
681       sym->as->corank = as->corank;
682       for (i = 0; i < as->corank; i++)
683         {
684           sym->as->lower[sym->as->rank + i] = as->lower[i];
685           sym->as->upper[sym->as->rank + i] = as->upper[i];
686         }
687     }
688   else
689     {
690       /* The "sym" has no rank (checked via gfc_add_dimension). Thus
691          the dimension is added - but first the codimensions (if existing
692          need to be shifted to make space for the dimension.  */
693       gcc_assert (as->corank == 0 && sym->as->rank == 0);
694
695       sym->as->rank = as->rank;
696       sym->as->type = as->type;
697       sym->as->cray_pointee = as->cray_pointee;
698       sym->as->cp_was_assumed = as->cp_was_assumed;
699
700       for (i = 0; i < sym->as->corank; i++)
701         {
702           sym->as->lower[as->rank + i] = sym->as->lower[i];
703           sym->as->upper[as->rank + i] = sym->as->upper[i];
704         }
705       for (i = 0; i < as->rank; i++)
706         {
707           sym->as->lower[i] = as->lower[i];
708           sym->as->upper[i] = as->upper[i];
709         }
710     }
711
712   gfc_free (as);
713   return SUCCESS;
714 }
715
716
717 /* Copy an array specification.  */
718
719 gfc_array_spec *
720 gfc_copy_array_spec (gfc_array_spec *src)
721 {
722   gfc_array_spec *dest;
723   int i;
724
725   if (src == NULL)
726     return NULL;
727
728   dest = gfc_get_array_spec ();
729
730   *dest = *src;
731
732   for (i = 0; i < dest->rank + dest->corank; i++)
733     {
734       dest->lower[i] = gfc_copy_expr (dest->lower[i]);
735       dest->upper[i] = gfc_copy_expr (dest->upper[i]);
736     }
737
738   return dest;
739 }
740
741
742 /* Returns nonzero if the two expressions are equal.  Only handles integer
743    constants.  */
744
745 static int
746 compare_bounds (gfc_expr *bound1, gfc_expr *bound2)
747 {
748   if (bound1 == NULL || bound2 == NULL
749       || bound1->expr_type != EXPR_CONSTANT
750       || bound2->expr_type != EXPR_CONSTANT
751       || bound1->ts.type != BT_INTEGER
752       || bound2->ts.type != BT_INTEGER)
753     gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
754
755   if (mpz_cmp (bound1->value.integer, bound2->value.integer) == 0)
756     return 1;
757   else
758     return 0;
759 }
760
761
762 /* Compares two array specifications.  They must be constant or deferred
763    shape.  */
764
765 int
766 gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2)
767 {
768   int i;
769
770   if (as1 == NULL && as2 == NULL)
771     return 1;
772
773   if (as1 == NULL || as2 == NULL)
774     return 0;
775
776   if (as1->rank != as2->rank)
777     return 0;
778
779   if (as1->corank != as2->corank)
780     return 0;
781
782   if (as1->rank == 0)
783     return 1;
784
785   if (as1->type != as2->type)
786     return 0;
787
788   if (as1->type == AS_EXPLICIT)
789     for (i = 0; i < as1->rank + as1->corank; i++)
790       {
791         if (compare_bounds (as1->lower[i], as2->lower[i]) == 0)
792           return 0;
793
794         if (compare_bounds (as1->upper[i], as2->upper[i]) == 0)
795           return 0;
796       }
797
798   return 1;
799 }
800
801
802 /****************** Array constructor functions ******************/
803
804
805 /* Given an expression node that might be an array constructor and a
806    symbol, make sure that no iterators in this or child constructors
807    use the symbol as an implied-DO iterator.  Returns nonzero if a
808    duplicate was found.  */
809
810 static int
811 check_duplicate_iterator (gfc_constructor_base base, gfc_symbol *master)
812 {
813   gfc_constructor *c;
814   gfc_expr *e;
815
816   for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
817     {
818       e = c->expr;
819
820       if (e->expr_type == EXPR_ARRAY
821           && check_duplicate_iterator (e->value.constructor, master))
822         return 1;
823
824       if (c->iterator == NULL)
825         continue;
826
827       if (c->iterator->var->symtree->n.sym == master)
828         {
829           gfc_error ("DO-iterator '%s' at %L is inside iterator of the "
830                      "same name", master->name, &c->where);
831
832           return 1;
833         }
834     }
835
836   return 0;
837 }
838
839
840 /* Forward declaration because these functions are mutually recursive.  */
841 static match match_array_cons_element (gfc_constructor_base *);
842
843 /* Match a list of array elements.  */
844
845 static match
846 match_array_list (gfc_constructor_base *result)
847 {
848   gfc_constructor_base head;
849   gfc_constructor *p;
850   gfc_iterator iter;
851   locus old_loc;
852   gfc_expr *e;
853   match m;
854   int n;
855
856   old_loc = gfc_current_locus;
857
858   if (gfc_match_char ('(') == MATCH_NO)
859     return MATCH_NO;
860
861   memset (&iter, '\0', sizeof (gfc_iterator));
862   head = NULL;
863
864   m = match_array_cons_element (&head);
865   if (m != MATCH_YES)
866     goto cleanup;
867
868   if (gfc_match_char (',') != MATCH_YES)
869     {
870       m = MATCH_NO;
871       goto cleanup;
872     }
873
874   for (n = 1;; n++)
875     {
876       m = gfc_match_iterator (&iter, 0);
877       if (m == MATCH_YES)
878         break;
879       if (m == MATCH_ERROR)
880         goto cleanup;
881
882       m = match_array_cons_element (&head);
883       if (m == MATCH_ERROR)
884         goto cleanup;
885       if (m == MATCH_NO)
886         {
887           if (n > 2)
888             goto syntax;
889           m = MATCH_NO;
890           goto cleanup;         /* Could be a complex constant */
891         }
892
893       if (gfc_match_char (',') != MATCH_YES)
894         {
895           if (n > 2)
896             goto syntax;
897           m = MATCH_NO;
898           goto cleanup;
899         }
900     }
901
902   if (gfc_match_char (')') != MATCH_YES)
903     goto syntax;
904
905   if (check_duplicate_iterator (head, iter.var->symtree->n.sym))
906     {
907       m = MATCH_ERROR;
908       goto cleanup;
909     }
910
911   e = gfc_get_array_expr (BT_UNKNOWN, 0, &old_loc);
912   e->value.constructor = head;
913
914   p = gfc_constructor_append_expr (result, e, &gfc_current_locus);
915   p->iterator = gfc_get_iterator ();
916   *p->iterator = iter;
917
918   return MATCH_YES;
919
920 syntax:
921   gfc_error ("Syntax error in array constructor at %C");
922   m = MATCH_ERROR;
923
924 cleanup:
925   gfc_constructor_free (head);
926   gfc_free_iterator (&iter, 0);
927   gfc_current_locus = old_loc;
928   return m;
929 }
930
931
932 /* Match a single element of an array constructor, which can be a
933    single expression or a list of elements.  */
934
935 static match
936 match_array_cons_element (gfc_constructor_base *result)
937 {
938   gfc_expr *expr;
939   match m;
940
941   m = match_array_list (result);
942   if (m != MATCH_NO)
943     return m;
944
945   m = gfc_match_expr (&expr);
946   if (m != MATCH_YES)
947     return m;
948
949   gfc_constructor_append_expr (result, expr, &gfc_current_locus);
950   return MATCH_YES;
951 }
952
953
954 /* Match an array constructor.  */
955
956 match
957 gfc_match_array_constructor (gfc_expr **result)
958 {
959   gfc_constructor_base head, new_cons;
960   gfc_expr *expr;
961   gfc_typespec ts;
962   locus where;
963   match m;
964   const char *end_delim;
965   bool seen_ts;
966
967   if (gfc_match (" (/") == MATCH_NO)
968     {
969       if (gfc_match (" [") == MATCH_NO)
970         return MATCH_NO;
971       else
972         {
973           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: [...] "
974                               "style array constructors at %C") == FAILURE)
975             return MATCH_ERROR;
976           end_delim = " ]";
977         }
978     }
979   else
980     end_delim = " /)";
981
982   where = gfc_current_locus;
983   head = new_cons = NULL;
984   seen_ts = false;
985
986   /* Try to match an optional "type-spec ::"  */
987   if (gfc_match_decl_type_spec (&ts, 0) == MATCH_YES)
988     {
989       seen_ts = (gfc_match (" ::") == MATCH_YES);
990
991       if (seen_ts)
992         {
993           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Array constructor "
994                               "including type specification at %C") == FAILURE)
995             goto cleanup;
996         }
997     }
998
999   if (! seen_ts)
1000     gfc_current_locus = where;
1001
1002   if (gfc_match (end_delim) == MATCH_YES)
1003     {
1004       if (seen_ts)
1005         goto done;
1006       else
1007         {
1008           gfc_error ("Empty array constructor at %C is not allowed");
1009           goto cleanup;
1010         }
1011     }
1012
1013   for (;;)
1014     {
1015       m = match_array_cons_element (&head);
1016       if (m == MATCH_ERROR)
1017         goto cleanup;
1018       if (m == MATCH_NO)
1019         goto syntax;
1020
1021       if (gfc_match_char (',') == MATCH_NO)
1022         break;
1023     }
1024
1025   if (gfc_match (end_delim) == MATCH_NO)
1026     goto syntax;
1027
1028 done:
1029   /* Size must be calculated at resolution time.  */
1030   if (seen_ts)
1031     {
1032       expr = gfc_get_array_expr (ts.type, ts.kind, &where);
1033       expr->ts = ts;
1034     }
1035   else
1036     expr = gfc_get_array_expr (BT_UNKNOWN, 0, &where);
1037
1038   expr->value.constructor = head;
1039   if (expr->ts.u.cl)
1040     expr->ts.u.cl->length_from_typespec = seen_ts;
1041
1042   *result = expr;
1043   return MATCH_YES;
1044
1045 syntax:
1046   gfc_error ("Syntax error in array constructor at %C");
1047
1048 cleanup:
1049   gfc_constructor_free (head);
1050   return MATCH_ERROR;
1051 }
1052
1053
1054
1055 /************** Check array constructors for correctness **************/
1056
1057 /* Given an expression, compare it's type with the type of the current
1058    constructor.  Returns nonzero if an error was issued.  The
1059    cons_state variable keeps track of whether the type of the
1060    constructor being read or resolved is known to be good, bad or just
1061    starting out.  */
1062
1063 static gfc_typespec constructor_ts;
1064 static enum
1065 { CONS_START, CONS_GOOD, CONS_BAD }
1066 cons_state;
1067
1068 static int
1069 check_element_type (gfc_expr *expr, bool convert)
1070 {
1071   if (cons_state == CONS_BAD)
1072     return 0;                   /* Suppress further errors */
1073
1074   if (cons_state == CONS_START)
1075     {
1076       if (expr->ts.type == BT_UNKNOWN)
1077         cons_state = CONS_BAD;
1078       else
1079         {
1080           cons_state = CONS_GOOD;
1081           constructor_ts = expr->ts;
1082         }
1083
1084       return 0;
1085     }
1086
1087   if (gfc_compare_types (&constructor_ts, &expr->ts))
1088     return 0;
1089
1090   if (convert)
1091     return gfc_convert_type (expr, &constructor_ts, 1) == SUCCESS ? 0 : 1;
1092
1093   gfc_error ("Element in %s array constructor at %L is %s",
1094              gfc_typename (&constructor_ts), &expr->where,
1095              gfc_typename (&expr->ts));
1096
1097   cons_state = CONS_BAD;
1098   return 1;
1099 }
1100
1101
1102 /* Recursive work function for gfc_check_constructor_type().  */
1103
1104 static gfc_try
1105 check_constructor_type (gfc_constructor_base base, bool convert)
1106 {
1107   gfc_constructor *c;
1108   gfc_expr *e;
1109
1110   for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1111     {
1112       e = c->expr;
1113
1114       if (e->expr_type == EXPR_ARRAY)
1115         {
1116           if (check_constructor_type (e->value.constructor, convert) == FAILURE)
1117             return FAILURE;
1118
1119           continue;
1120         }
1121
1122       if (check_element_type (e, convert))
1123         return FAILURE;
1124     }
1125
1126   return SUCCESS;
1127 }
1128
1129
1130 /* Check that all elements of an array constructor are the same type.
1131    On FAILURE, an error has been generated.  */
1132
1133 gfc_try
1134 gfc_check_constructor_type (gfc_expr *e)
1135 {
1136   gfc_try t;
1137
1138   if (e->ts.type != BT_UNKNOWN)
1139     {
1140       cons_state = CONS_GOOD;
1141       constructor_ts = e->ts;
1142     }
1143   else
1144     {
1145       cons_state = CONS_START;
1146       gfc_clear_ts (&constructor_ts);
1147     }
1148
1149   /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1150      typespec, and we will now convert the values on the fly.  */
1151   t = check_constructor_type (e->value.constructor, e->ts.type != BT_UNKNOWN);
1152   if (t == SUCCESS && e->ts.type == BT_UNKNOWN)
1153     e->ts = constructor_ts;
1154
1155   return t;
1156 }
1157
1158
1159
1160 typedef struct cons_stack
1161 {
1162   gfc_iterator *iterator;
1163   struct cons_stack *previous;
1164 }
1165 cons_stack;
1166
1167 static cons_stack *base;
1168
1169 static gfc_try check_constructor (gfc_constructor_base, gfc_try (*) (gfc_expr *));
1170
1171 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1172    that that variable is an iteration variables.  */
1173
1174 gfc_try
1175 gfc_check_iter_variable (gfc_expr *expr)
1176 {
1177   gfc_symbol *sym;
1178   cons_stack *c;
1179
1180   sym = expr->symtree->n.sym;
1181
1182   for (c = base; c; c = c->previous)
1183     if (sym == c->iterator->var->symtree->n.sym)
1184       return SUCCESS;
1185
1186   return FAILURE;
1187 }
1188
1189
1190 /* Recursive work function for gfc_check_constructor().  This amounts
1191    to calling the check function for each expression in the
1192    constructor, giving variables with the names of iterators a pass.  */
1193
1194 static gfc_try
1195 check_constructor (gfc_constructor_base ctor, gfc_try (*check_function) (gfc_expr *))
1196 {
1197   cons_stack element;
1198   gfc_expr *e;
1199   gfc_try t;
1200   gfc_constructor *c;
1201
1202   for (c = gfc_constructor_first (ctor); c; c = gfc_constructor_next (c))
1203     {
1204       e = c->expr;
1205
1206       if (e->expr_type != EXPR_ARRAY)
1207         {
1208           if ((*check_function) (e) == FAILURE)
1209             return FAILURE;
1210           continue;
1211         }
1212
1213       element.previous = base;
1214       element.iterator = c->iterator;
1215
1216       base = &element;
1217       t = check_constructor (e->value.constructor, check_function);
1218       base = element.previous;
1219
1220       if (t == FAILURE)
1221         return FAILURE;
1222     }
1223
1224   /* Nothing went wrong, so all OK.  */
1225   return SUCCESS;
1226 }
1227
1228
1229 /* Checks a constructor to see if it is a particular kind of
1230    expression -- specification, restricted, or initialization as
1231    determined by the check_function.  */
1232
1233 gfc_try
1234 gfc_check_constructor (gfc_expr *expr, gfc_try (*check_function) (gfc_expr *))
1235 {
1236   cons_stack *base_save;
1237   gfc_try t;
1238
1239   base_save = base;
1240   base = NULL;
1241
1242   t = check_constructor (expr->value.constructor, check_function);
1243   base = base_save;
1244
1245   return t;
1246 }
1247
1248
1249
1250 /**************** Simplification of array constructors ****************/
1251
1252 iterator_stack *iter_stack;
1253
1254 typedef struct
1255 {
1256   gfc_constructor_base base;
1257   int extract_count, extract_n;
1258   gfc_expr *extracted;
1259   mpz_t *count;
1260
1261   mpz_t *offset;
1262   gfc_component *component;
1263
1264   gfc_try (*expand_work_function) (gfc_expr *);
1265 }
1266 expand_info;
1267
1268 static expand_info current_expand;
1269
1270 static gfc_try expand_constructor (gfc_constructor_base);
1271
1272
1273 /* Work function that counts the number of elements present in a
1274    constructor.  */
1275
1276 static gfc_try
1277 count_elements (gfc_expr *e)
1278 {
1279   mpz_t result;
1280
1281   if (e->rank == 0)
1282     mpz_add_ui (*current_expand.count, *current_expand.count, 1);
1283   else
1284     {
1285       if (gfc_array_size (e, &result) == FAILURE)
1286         {
1287           gfc_free_expr (e);
1288           return FAILURE;
1289         }
1290
1291       mpz_add (*current_expand.count, *current_expand.count, result);
1292       mpz_clear (result);
1293     }
1294
1295   gfc_free_expr (e);
1296   return SUCCESS;
1297 }
1298
1299
1300 /* Work function that extracts a particular element from an array
1301    constructor, freeing the rest.  */
1302
1303 static gfc_try
1304 extract_element (gfc_expr *e)
1305 {
1306   if (e->rank != 0)
1307     {                           /* Something unextractable */
1308       gfc_free_expr (e);
1309       return FAILURE;
1310     }
1311
1312   if (current_expand.extract_count == current_expand.extract_n)
1313     current_expand.extracted = e;
1314   else
1315     gfc_free_expr (e);
1316
1317   current_expand.extract_count++;
1318   
1319   return SUCCESS;
1320 }
1321
1322
1323 /* Work function that constructs a new constructor out of the old one,
1324    stringing new elements together.  */
1325
1326 static gfc_try
1327 expand (gfc_expr *e)
1328 {
1329   gfc_constructor *c = gfc_constructor_append_expr (&current_expand.base,
1330                                                     e, &e->where);
1331
1332   c->n.component = current_expand.component;
1333   return SUCCESS;
1334 }
1335
1336
1337 /* Given an initialization expression that is a variable reference,
1338    substitute the current value of the iteration variable.  */
1339
1340 void
1341 gfc_simplify_iterator_var (gfc_expr *e)
1342 {
1343   iterator_stack *p;
1344
1345   for (p = iter_stack; p; p = p->prev)
1346     if (e->symtree == p->variable)
1347       break;
1348
1349   if (p == NULL)
1350     return;             /* Variable not found */
1351
1352   gfc_replace_expr (e, gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
1353
1354   mpz_set (e->value.integer, p->value);
1355
1356   return;
1357 }
1358
1359
1360 /* Expand an expression with that is inside of a constructor,
1361    recursing into other constructors if present.  */
1362
1363 static gfc_try
1364 expand_expr (gfc_expr *e)
1365 {
1366   if (e->expr_type == EXPR_ARRAY)
1367     return expand_constructor (e->value.constructor);
1368
1369   e = gfc_copy_expr (e);
1370
1371   if (gfc_simplify_expr (e, 1) == FAILURE)
1372     {
1373       gfc_free_expr (e);
1374       return FAILURE;
1375     }
1376
1377   return current_expand.expand_work_function (e);
1378 }
1379
1380
1381 static gfc_try
1382 expand_iterator (gfc_constructor *c)
1383 {
1384   gfc_expr *start, *end, *step;
1385   iterator_stack frame;
1386   mpz_t trip;
1387   gfc_try t;
1388
1389   end = step = NULL;
1390
1391   t = FAILURE;
1392
1393   mpz_init (trip);
1394   mpz_init (frame.value);
1395   frame.prev = NULL;
1396
1397   start = gfc_copy_expr (c->iterator->start);
1398   if (gfc_simplify_expr (start, 1) == FAILURE)
1399     goto cleanup;
1400
1401   if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER)
1402     goto cleanup;
1403
1404   end = gfc_copy_expr (c->iterator->end);
1405   if (gfc_simplify_expr (end, 1) == FAILURE)
1406     goto cleanup;
1407
1408   if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER)
1409     goto cleanup;
1410
1411   step = gfc_copy_expr (c->iterator->step);
1412   if (gfc_simplify_expr (step, 1) == FAILURE)
1413     goto cleanup;
1414
1415   if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER)
1416     goto cleanup;
1417
1418   if (mpz_sgn (step->value.integer) == 0)
1419     {
1420       gfc_error ("Iterator step at %L cannot be zero", &step->where);
1421       goto cleanup;
1422     }
1423
1424   /* Calculate the trip count of the loop.  */
1425   mpz_sub (trip, end->value.integer, start->value.integer);
1426   mpz_add (trip, trip, step->value.integer);
1427   mpz_tdiv_q (trip, trip, step->value.integer);
1428
1429   mpz_set (frame.value, start->value.integer);
1430
1431   frame.prev = iter_stack;
1432   frame.variable = c->iterator->var->symtree;
1433   iter_stack = &frame;
1434
1435   while (mpz_sgn (trip) > 0)
1436     {
1437       if (expand_expr (c->expr) == FAILURE)
1438         goto cleanup;
1439
1440       mpz_add (frame.value, frame.value, step->value.integer);
1441       mpz_sub_ui (trip, trip, 1);
1442     }
1443
1444   t = SUCCESS;
1445
1446 cleanup:
1447   gfc_free_expr (start);
1448   gfc_free_expr (end);
1449   gfc_free_expr (step);
1450
1451   mpz_clear (trip);
1452   mpz_clear (frame.value);
1453
1454   iter_stack = frame.prev;
1455
1456   return t;
1457 }
1458
1459
1460 /* Expand a constructor into constant constructors without any
1461    iterators, calling the work function for each of the expanded
1462    expressions.  The work function needs to either save or free the
1463    passed expression.  */
1464
1465 static gfc_try
1466 expand_constructor (gfc_constructor_base base)
1467 {
1468   gfc_constructor *c;
1469   gfc_expr *e;
1470
1471   for (c = gfc_constructor_first (base); c; c = gfc_constructor_next(c))
1472     {
1473       if (c->iterator != NULL)
1474         {
1475           if (expand_iterator (c) == FAILURE)
1476             return FAILURE;
1477           continue;
1478         }
1479
1480       e = c->expr;
1481
1482       if (e->expr_type == EXPR_ARRAY)
1483         {
1484           if (expand_constructor (e->value.constructor) == FAILURE)
1485             return FAILURE;
1486
1487           continue;
1488         }
1489
1490       e = gfc_copy_expr (e);
1491       if (gfc_simplify_expr (e, 1) == FAILURE)
1492         {
1493           gfc_free_expr (e);
1494           return FAILURE;
1495         }
1496       current_expand.offset = &c->offset;
1497       current_expand.component = c->n.component;
1498       if (current_expand.expand_work_function (e) == FAILURE)
1499         return FAILURE;
1500     }
1501   return SUCCESS;
1502 }
1503
1504
1505 /* Given an array expression and an element number (starting at zero),
1506    return a pointer to the array element.  NULL is returned if the
1507    size of the array has been exceeded.  The expression node returned
1508    remains a part of the array and should not be freed.  Access is not
1509    efficient at all, but this is another place where things do not
1510    have to be particularly fast.  */
1511
1512 static gfc_expr *
1513 gfc_get_array_element (gfc_expr *array, int element)
1514 {
1515   expand_info expand_save;
1516   gfc_expr *e;
1517   gfc_try rc;
1518
1519   expand_save = current_expand;
1520   current_expand.extract_n = element;
1521   current_expand.expand_work_function = extract_element;
1522   current_expand.extracted = NULL;
1523   current_expand.extract_count = 0;
1524
1525   iter_stack = NULL;
1526
1527   rc = expand_constructor (array->value.constructor);
1528   e = current_expand.extracted;
1529   current_expand = expand_save;
1530
1531   if (rc == FAILURE)
1532     return NULL;
1533
1534   return e;
1535 }
1536
1537
1538 /* Top level subroutine for expanding constructors.  We only expand
1539    constructor if they are small enough.  */
1540
1541 gfc_try
1542 gfc_expand_constructor (gfc_expr *e)
1543 {
1544   expand_info expand_save;
1545   gfc_expr *f;
1546   gfc_try rc;
1547
1548   /* If we can successfully get an array element at the max array size then
1549      the array is too big to expand, so we just return.  */
1550   f = gfc_get_array_element (e, gfc_option.flag_max_array_constructor);
1551   if (f != NULL)
1552     {
1553       gfc_free_expr (f);
1554       return SUCCESS;
1555     }
1556
1557   /* We now know the array is not too big so go ahead and try to expand it.  */
1558   expand_save = current_expand;
1559   current_expand.base = NULL;
1560
1561   iter_stack = NULL;
1562
1563   current_expand.expand_work_function = expand;
1564
1565   if (expand_constructor (e->value.constructor) == FAILURE)
1566     {
1567       gfc_constructor_free (current_expand.base);
1568       rc = FAILURE;
1569       goto done;
1570     }
1571
1572   gfc_constructor_free (e->value.constructor);
1573   e->value.constructor = current_expand.base;
1574
1575   rc = SUCCESS;
1576
1577 done:
1578   current_expand = expand_save;
1579
1580   return rc;
1581 }
1582
1583
1584 /* Work function for checking that an element of a constructor is a
1585    constant, after removal of any iteration variables.  We return
1586    FAILURE if not so.  */
1587
1588 static gfc_try
1589 is_constant_element (gfc_expr *e)
1590 {
1591   int rv;
1592
1593   rv = gfc_is_constant_expr (e);
1594   gfc_free_expr (e);
1595
1596   return rv ? SUCCESS : FAILURE;
1597 }
1598
1599
1600 /* Given an array constructor, determine if the constructor is
1601    constant or not by expanding it and making sure that all elements
1602    are constants.  This is a bit of a hack since something like (/ (i,
1603    i=1,100000000) /) will take a while as* opposed to a more clever
1604    function that traverses the expression tree. FIXME.  */
1605
1606 int
1607 gfc_constant_ac (gfc_expr *e)
1608 {
1609   expand_info expand_save;
1610   gfc_try rc;
1611
1612   iter_stack = NULL;
1613   expand_save = current_expand;
1614   current_expand.expand_work_function = is_constant_element;
1615
1616   rc = expand_constructor (e->value.constructor);
1617
1618   current_expand = expand_save;
1619   if (rc == FAILURE)
1620     return 0;
1621
1622   return 1;
1623 }
1624
1625
1626 /* Returns nonzero if an array constructor has been completely
1627    expanded (no iterators) and zero if iterators are present.  */
1628
1629 int
1630 gfc_expanded_ac (gfc_expr *e)
1631 {
1632   gfc_constructor *c;
1633
1634   if (e->expr_type == EXPR_ARRAY)
1635     for (c = gfc_constructor_first (e->value.constructor);
1636          c; c = gfc_constructor_next (c))
1637       if (c->iterator != NULL || !gfc_expanded_ac (c->expr))
1638         return 0;
1639
1640   return 1;
1641 }
1642
1643
1644 /*************** Type resolution of array constructors ***************/
1645
1646 /* Recursive array list resolution function.  All of the elements must
1647    be of the same type.  */
1648
1649 static gfc_try
1650 resolve_array_list (gfc_constructor_base base)
1651 {
1652   gfc_try t;
1653   gfc_constructor *c;
1654
1655   t = SUCCESS;
1656
1657   for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1658     {
1659       if (c->iterator != NULL
1660           && gfc_resolve_iterator (c->iterator, false) == FAILURE)
1661         t = FAILURE;
1662
1663       if (gfc_resolve_expr (c->expr) == FAILURE)
1664         t = FAILURE;
1665     }
1666
1667   return t;
1668 }
1669
1670 /* Resolve character array constructor. If it has a specified constant character
1671    length, pad/truncate the elements here; if the length is not specified and
1672    all elements are of compile-time known length, emit an error as this is
1673    invalid.  */
1674
1675 gfc_try
1676 gfc_resolve_character_array_constructor (gfc_expr *expr)
1677 {
1678   gfc_constructor *p;
1679   int found_length;
1680
1681   gcc_assert (expr->expr_type == EXPR_ARRAY);
1682   gcc_assert (expr->ts.type == BT_CHARACTER);
1683
1684   if (expr->ts.u.cl == NULL)
1685     {
1686       for (p = gfc_constructor_first (expr->value.constructor);
1687            p; p = gfc_constructor_next (p))
1688         if (p->expr->ts.u.cl != NULL)
1689           {
1690             /* Ensure that if there is a char_len around that it is
1691                used; otherwise the middle-end confuses them!  */
1692             expr->ts.u.cl = p->expr->ts.u.cl;
1693             goto got_charlen;
1694           }
1695
1696       expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1697     }
1698
1699 got_charlen:
1700
1701   found_length = -1;
1702
1703   if (expr->ts.u.cl->length == NULL)
1704     {
1705       /* Check that all constant string elements have the same length until
1706          we reach the end or find a variable-length one.  */
1707
1708       for (p = gfc_constructor_first (expr->value.constructor);
1709            p; p = gfc_constructor_next (p))
1710         {
1711           int current_length = -1;
1712           gfc_ref *ref;
1713           for (ref = p->expr->ref; ref; ref = ref->next)
1714             if (ref->type == REF_SUBSTRING
1715                 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1716                 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1717               break;
1718
1719           if (p->expr->expr_type == EXPR_CONSTANT)
1720             current_length = p->expr->value.character.length;
1721           else if (ref)
1722             {
1723               long j;
1724               j = mpz_get_ui (ref->u.ss.end->value.integer)
1725                 - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
1726               current_length = (int) j;
1727             }
1728           else if (p->expr->ts.u.cl && p->expr->ts.u.cl->length
1729                    && p->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1730             {
1731               long j;
1732               j = mpz_get_si (p->expr->ts.u.cl->length->value.integer);
1733               current_length = (int) j;
1734             }
1735           else
1736             return SUCCESS;
1737
1738           gcc_assert (current_length != -1);
1739
1740           if (found_length == -1)
1741             found_length = current_length;
1742           else if (found_length != current_length)
1743             {
1744               gfc_error ("Different CHARACTER lengths (%d/%d) in array"
1745                          " constructor at %L", found_length, current_length,
1746                          &p->expr->where);
1747               return FAILURE;
1748             }
1749
1750           gcc_assert (found_length == current_length);
1751         }
1752
1753       gcc_assert (found_length != -1);
1754
1755       /* Update the character length of the array constructor.  */
1756       expr->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
1757                                                 NULL, found_length);
1758     }
1759   else 
1760     {
1761       /* We've got a character length specified.  It should be an integer,
1762          otherwise an error is signalled elsewhere.  */
1763       gcc_assert (expr->ts.u.cl->length);
1764
1765       /* If we've got a constant character length, pad according to this.
1766          gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
1767          max_length only if they pass.  */
1768       gfc_extract_int (expr->ts.u.cl->length, &found_length);
1769
1770       /* Now pad/truncate the elements accordingly to the specified character
1771          length.  This is ok inside this conditional, as in the case above
1772          (without typespec) all elements are verified to have the same length
1773          anyway.  */
1774       if (found_length != -1)
1775         for (p = gfc_constructor_first (expr->value.constructor);
1776              p; p = gfc_constructor_next (p))
1777           if (p->expr->expr_type == EXPR_CONSTANT)
1778             {
1779               gfc_expr *cl = NULL;
1780               int current_length = -1;
1781               bool has_ts;
1782
1783               if (p->expr->ts.u.cl && p->expr->ts.u.cl->length)
1784               {
1785                 cl = p->expr->ts.u.cl->length;
1786                 gfc_extract_int (cl, &current_length);
1787               }
1788
1789               /* If gfc_extract_int above set current_length, we implicitly
1790                  know the type is BT_INTEGER and it's EXPR_CONSTANT.  */
1791
1792               has_ts = (expr->ts.u.cl && expr->ts.u.cl->length_from_typespec);
1793
1794               if (! cl
1795                   || (current_length != -1 && current_length < found_length))
1796                 gfc_set_constant_character_len (found_length, p->expr,
1797                                                 has_ts ? -1 : found_length);
1798             }
1799     }
1800
1801   return SUCCESS;
1802 }
1803
1804
1805 /* Resolve all of the expressions in an array list.  */
1806
1807 gfc_try
1808 gfc_resolve_array_constructor (gfc_expr *expr)
1809 {
1810   gfc_try t;
1811
1812   t = resolve_array_list (expr->value.constructor);
1813   if (t == SUCCESS)
1814     t = gfc_check_constructor_type (expr);
1815
1816   /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
1817      the call to this function, so we don't need to call it here; if it was
1818      called twice, an error message there would be duplicated.  */
1819
1820   return t;
1821 }
1822
1823
1824 /* Copy an iterator structure.  */
1825
1826 gfc_iterator *
1827 gfc_copy_iterator (gfc_iterator *src)
1828 {
1829   gfc_iterator *dest;
1830
1831   if (src == NULL)
1832     return NULL;
1833
1834   dest = gfc_get_iterator ();
1835
1836   dest->var = gfc_copy_expr (src->var);
1837   dest->start = gfc_copy_expr (src->start);
1838   dest->end = gfc_copy_expr (src->end);
1839   dest->step = gfc_copy_expr (src->step);
1840
1841   return dest;
1842 }
1843
1844
1845 /********* Subroutines for determining the size of an array *********/
1846
1847 /* These are needed just to accommodate RESHAPE().  There are no
1848    diagnostics here, we just return a negative number if something
1849    goes wrong.  */
1850
1851
1852 /* Get the size of single dimension of an array specification.  The
1853    array is guaranteed to be one dimensional.  */
1854
1855 gfc_try
1856 spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
1857 {
1858   if (as == NULL)
1859     return FAILURE;
1860
1861   if (dimen < 0 || dimen > as->rank - 1)
1862     gfc_internal_error ("spec_dimen_size(): Bad dimension");
1863
1864   if (as->type != AS_EXPLICIT
1865       || as->lower[dimen]->expr_type != EXPR_CONSTANT
1866       || as->upper[dimen]->expr_type != EXPR_CONSTANT
1867       || as->lower[dimen]->ts.type != BT_INTEGER
1868       || as->upper[dimen]->ts.type != BT_INTEGER)
1869     return FAILURE;
1870
1871   mpz_init (*result);
1872
1873   mpz_sub (*result, as->upper[dimen]->value.integer,
1874            as->lower[dimen]->value.integer);
1875
1876   mpz_add_ui (*result, *result, 1);
1877
1878   return SUCCESS;
1879 }
1880
1881
1882 gfc_try
1883 spec_size (gfc_array_spec *as, mpz_t *result)
1884 {
1885   mpz_t size;
1886   int d;
1887
1888   mpz_init_set_ui (*result, 1);
1889
1890   for (d = 0; d < as->rank; d++)
1891     {
1892       if (spec_dimen_size (as, d, &size) == FAILURE)
1893         {
1894           mpz_clear (*result);
1895           return FAILURE;
1896         }
1897
1898       mpz_mul (*result, *result, size);
1899       mpz_clear (size);
1900     }
1901
1902   return SUCCESS;
1903 }
1904
1905
1906 /* Get the number of elements in an array section.  */
1907
1908 gfc_try
1909 gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result)
1910 {
1911   mpz_t upper, lower, stride;
1912   gfc_try t;
1913
1914   if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
1915     gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
1916
1917   switch (ar->dimen_type[dimen])
1918     {
1919     case DIMEN_ELEMENT:
1920       mpz_init (*result);
1921       mpz_set_ui (*result, 1);
1922       t = SUCCESS;
1923       break;
1924
1925     case DIMEN_VECTOR:
1926       t = gfc_array_size (ar->start[dimen], result);    /* Recurse! */
1927       break;
1928
1929     case DIMEN_RANGE:
1930       mpz_init (upper);
1931       mpz_init (lower);
1932       mpz_init (stride);
1933       t = FAILURE;
1934
1935       if (ar->start[dimen] == NULL)
1936         {
1937           if (ar->as->lower[dimen] == NULL
1938               || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT)
1939             goto cleanup;
1940           mpz_set (lower, ar->as->lower[dimen]->value.integer);
1941         }
1942       else
1943         {
1944           if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
1945             goto cleanup;
1946           mpz_set (lower, ar->start[dimen]->value.integer);
1947         }
1948
1949       if (ar->end[dimen] == NULL)
1950         {
1951           if (ar->as->upper[dimen] == NULL
1952               || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT)
1953             goto cleanup;
1954           mpz_set (upper, ar->as->upper[dimen]->value.integer);
1955         }
1956       else
1957         {
1958           if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
1959             goto cleanup;
1960           mpz_set (upper, ar->end[dimen]->value.integer);
1961         }
1962
1963       if (ar->stride[dimen] == NULL)
1964         mpz_set_ui (stride, 1);
1965       else
1966         {
1967           if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
1968             goto cleanup;
1969           mpz_set (stride, ar->stride[dimen]->value.integer);
1970         }
1971
1972       mpz_init (*result);
1973       mpz_sub (*result, upper, lower);
1974       mpz_add (*result, *result, stride);
1975       mpz_div (*result, *result, stride);
1976
1977       /* Zero stride caught earlier.  */
1978       if (mpz_cmp_ui (*result, 0) < 0)
1979         mpz_set_ui (*result, 0);
1980       t = SUCCESS;
1981
1982     cleanup:
1983       mpz_clear (upper);
1984       mpz_clear (lower);
1985       mpz_clear (stride);
1986       return t;
1987
1988     default:
1989       gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
1990     }
1991
1992   return t;
1993 }
1994
1995
1996 static gfc_try
1997 ref_size (gfc_array_ref *ar, mpz_t *result)
1998 {
1999   mpz_t size;
2000   int d;
2001
2002   mpz_init_set_ui (*result, 1);
2003
2004   for (d = 0; d < ar->dimen; d++)
2005     {
2006       if (gfc_ref_dimen_size (ar, d, &size) == FAILURE)
2007         {
2008           mpz_clear (*result);
2009           return FAILURE;
2010         }
2011
2012       mpz_mul (*result, *result, size);
2013       mpz_clear (size);
2014     }
2015
2016   return SUCCESS;
2017 }
2018
2019
2020 /* Given an array expression and a dimension, figure out how many
2021    elements it has along that dimension.  Returns SUCCESS if we were
2022    able to return a result in the 'result' variable, FAILURE
2023    otherwise.  */
2024
2025 gfc_try
2026 gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
2027 {
2028   gfc_ref *ref;
2029   int i;
2030
2031   if (dimen < 0 || array == NULL || dimen > array->rank - 1)
2032     gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2033
2034   switch (array->expr_type)
2035     {
2036     case EXPR_VARIABLE:
2037     case EXPR_FUNCTION:
2038       for (ref = array->ref; ref; ref = ref->next)
2039         {
2040           if (ref->type != REF_ARRAY)
2041             continue;
2042
2043           if (ref->u.ar.type == AR_FULL)
2044             return spec_dimen_size (ref->u.ar.as, dimen, result);
2045
2046           if (ref->u.ar.type == AR_SECTION)
2047             {
2048               for (i = 0; dimen >= 0; i++)
2049                 if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2050                   dimen--;
2051
2052               return gfc_ref_dimen_size (&ref->u.ar, i - 1, result);
2053             }
2054         }
2055
2056       if (array->shape && array->shape[dimen])
2057         {
2058           mpz_init_set (*result, array->shape[dimen]);
2059           return SUCCESS;
2060         }
2061
2062       if (array->symtree->n.sym->attr.generic
2063           && array->value.function.esym != NULL)
2064         {
2065           if (spec_dimen_size (array->value.function.esym->as, dimen, result)
2066               == FAILURE)
2067             return FAILURE;
2068         }
2069       else if (spec_dimen_size (array->symtree->n.sym->as, dimen, result)
2070                == FAILURE)
2071         return FAILURE;
2072
2073       break;
2074
2075     case EXPR_ARRAY:
2076       if (array->shape == NULL) {
2077         /* Expressions with rank > 1 should have "shape" properly set */
2078         if ( array->rank != 1 )
2079           gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2080         return gfc_array_size(array, result);
2081       }
2082
2083       /* Fall through */
2084     default:
2085       if (array->shape == NULL)
2086         return FAILURE;
2087
2088       mpz_init_set (*result, array->shape[dimen]);
2089
2090       break;
2091     }
2092
2093   return SUCCESS;
2094 }
2095
2096
2097 /* Given an array expression, figure out how many elements are in the
2098    array.  Returns SUCCESS if this is possible, and sets the 'result'
2099    variable.  Otherwise returns FAILURE.  */
2100
2101 gfc_try
2102 gfc_array_size (gfc_expr *array, mpz_t *result)
2103 {
2104   expand_info expand_save;
2105   gfc_ref *ref;
2106   int i;
2107   gfc_try t;
2108
2109   switch (array->expr_type)
2110     {
2111     case EXPR_ARRAY:
2112       gfc_push_suppress_errors ();
2113
2114       expand_save = current_expand;
2115
2116       current_expand.count = result;
2117       mpz_init_set_ui (*result, 0);
2118
2119       current_expand.expand_work_function = count_elements;
2120       iter_stack = NULL;
2121
2122       t = expand_constructor (array->value.constructor);
2123
2124       gfc_pop_suppress_errors ();
2125
2126       if (t == FAILURE)
2127         mpz_clear (*result);
2128       current_expand = expand_save;
2129       return t;
2130
2131     case EXPR_VARIABLE:
2132       for (ref = array->ref; ref; ref = ref->next)
2133         {
2134           if (ref->type != REF_ARRAY)
2135             continue;
2136
2137           if (ref->u.ar.type == AR_FULL)
2138             return spec_size (ref->u.ar.as, result);
2139
2140           if (ref->u.ar.type == AR_SECTION)
2141             return ref_size (&ref->u.ar, result);
2142         }
2143
2144       return spec_size (array->symtree->n.sym->as, result);
2145
2146
2147     default:
2148       if (array->rank == 0 || array->shape == NULL)
2149         return FAILURE;
2150
2151       mpz_init_set_ui (*result, 1);
2152
2153       for (i = 0; i < array->rank; i++)
2154         mpz_mul (*result, *result, array->shape[i]);
2155
2156       break;
2157     }
2158
2159   return SUCCESS;
2160 }
2161
2162
2163 /* Given an array reference, return the shape of the reference in an
2164    array of mpz_t integers.  */
2165
2166 gfc_try
2167 gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
2168 {
2169   int d;
2170   int i;
2171
2172   d = 0;
2173
2174   switch (ar->type)
2175     {
2176     case AR_FULL:
2177       for (; d < ar->as->rank; d++)
2178         if (spec_dimen_size (ar->as, d, &shape[d]) == FAILURE)
2179           goto cleanup;
2180
2181       return SUCCESS;
2182
2183     case AR_SECTION:
2184       for (i = 0; i < ar->dimen; i++)
2185         {
2186           if (ar->dimen_type[i] != DIMEN_ELEMENT)
2187             {
2188               if (gfc_ref_dimen_size (ar, i, &shape[d]) == FAILURE)
2189                 goto cleanup;
2190               d++;
2191             }
2192         }
2193
2194       return SUCCESS;
2195
2196     default:
2197       break;
2198     }
2199
2200 cleanup:
2201   for (d--; d >= 0; d--)
2202     mpz_clear (shape[d]);
2203
2204   return FAILURE;
2205 }
2206
2207
2208 /* Given an array expression, find the array reference structure that
2209    characterizes the reference.  */
2210
2211 gfc_array_ref *
2212 gfc_find_array_ref (gfc_expr *e)
2213 {
2214   gfc_ref *ref;
2215
2216   for (ref = e->ref; ref; ref = ref->next)
2217     if (ref->type == REF_ARRAY
2218         && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION
2219             || (ref->u.ar.type == AR_ELEMENT && ref->u.ar.dimen == 0)))
2220       break;
2221
2222   if (ref == NULL)
2223     gfc_internal_error ("gfc_find_array_ref(): No ref found");
2224
2225   return &ref->u.ar;
2226 }
2227
2228
2229 /* Find out if an array shape is known at compile time.  */
2230
2231 int
2232 gfc_is_compile_time_shape (gfc_array_spec *as)
2233 {
2234   int i;
2235
2236   if (as->type != AS_EXPLICIT)
2237     return 0;
2238
2239   for (i = 0; i < as->rank; i++)
2240     if (!gfc_is_constant_expr (as->lower[i])
2241         || !gfc_is_constant_expr (as->upper[i]))
2242       return 0;
2243
2244   return 1;
2245 }