OSDN Git Service

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