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