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