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