OSDN Git Service

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