OSDN Git Service

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