1	/* Check functions
2	Copyright (C) 2002-2023 Free Software Foundation, Inc.
3	Contributed by Andy Vaught & Katherine Holcomb
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
22	/* These functions check to see if an argument list is compatible with
23	a particular intrinsic function or subroutine. Presence of
24	required arguments has already been established, the argument list
25	has been sorted into the right order and has NULL arguments in the
26	correct places for missing optional arguments. */
27
28	#include "config.h"
29	#include "system.h"
30	#include "coretypes.h"
31	#include "options.h"
32	#include "gfortran.h"
33	#include "intrinsic.h"
34	#include "constructor.h"
35	#include "target-memory.h"
36
37
38	/* Reset a BOZ to a zero value. This is used to prevent run-on errors
39	from resolve.cc(resolve_function). */
40
41	static void
42	reset_boz (gfc_expr *x)
43	{
44	/* Clear boz info. */
45	x->boz.rdx = 0;
46	x->boz.len = 0;
47	free (ptr: x->boz.str);
48
49	x->ts.type = BT_INTEGER;
50	x->ts.kind = gfc_default_integer_kind;
51	mpz_init (x->value.integer);
52	mpz_set_ui (x->value.integer, 0);
53	}
54
55	/* A BOZ literal constant can appear in a limited number of contexts.
56	gfc_invalid_boz() is a helper function to simplify error/warning
57	generation. gfortran accepts the nonstandard 'X' for 'Z', and gfortran
58	allows the BOZ indicator to appear as a suffix. If -fallow-invalid-boz
59	is used, then issue a warning; otherwise issue an error. */
60
61	bool
62	gfc_invalid_boz (const char *msg, locus *loc)
63	{
64	if (flag_allow_invalid_boz)
65	{
66	gfc_warning (opt: 0, msg, loc);
67	return false;
68	}
69
70	const char *hint = _(" [see %<-fno-allow-invalid-boz%>]");
71	size_t len = strlen (s: msg) + strlen (s: hint) + 1;
72	char *msg2 = (char *) alloca (len);
73	strcpy (dest: msg2, src: msg);
74	strcat (dest: msg2, src: hint);
75	gfc_error (msg2, loc);
76	return true;
77	}
78
79
80	/* Issue an error for an illegal BOZ argument. */
81
82	static bool
83	illegal_boz_arg (gfc_expr *x)
84	{
85	if (x->ts.type == BT_BOZ)
86	{
87	gfc_error ("BOZ literal constant at %L cannot be an actual argument "
88	"to %qs", &x->where, gfc_current_intrinsic);
89	reset_boz (x);
90	return true;
91	}
92
93	return false;
94	}
95
96	/* Some procedures take two arguments such that both cannot be BOZ. */
97
98	static bool
99	boz_args_check(gfc_expr *i, gfc_expr *j)
100	{
101	if (i->ts.type == BT_BOZ && j->ts.type == BT_BOZ)
102	{
103	gfc_error ("Arguments of %qs at %L and %L cannot both be BOZ "
104	"literal constants", gfc_current_intrinsic, &i->where,
105	&j->where);
106	reset_boz (x: i);
107	reset_boz (x: j);
108	return false;
109
110	}
111
112	return true;
113	}
114
115
116	/* Check that a BOZ is a constant. */
117
118	static bool
119	is_boz_constant (gfc_expr *a)
120	{
121	if (a->expr_type != EXPR_CONSTANT)
122	{
123	gfc_error ("Invalid use of BOZ literal constant at %L", &a->where);
124	return false;
125	}
126
127	return true;
128	}
129
130
131	/* Convert a octal string into a binary string. This is used in the
132	fallback conversion of an octal string to a REAL. */
133
134	static char *
135	oct2bin(int nbits, char *oct)
136	{
137	const char bits[8][5] = {
138	"000", "001", "010", "011", "100", "101", "110", "111"};
139
140	char *buf, *bufp;
141	int i, j, n;
142
143	j = nbits + 1;
144	if (nbits == 64) j++;
145
146	bufp = buf = XCNEWVEC (char, j + 1);
147	memset (s: bufp, c: 0, n: j + 1);
148
149	n = strlen (s: oct);
150	for (i = 0; i < n; i++, oct++)
151	{
152	j = *oct - 48;
153	strcpy (dest: bufp, src: &bits[j][0]);
154	bufp += 3;
155	}
156
157	bufp = XCNEWVEC (char, nbits + 1);
158	if (nbits == 64)
159	strcpy (dest: bufp, src: buf + 2);
160	else
161	strcpy (dest: bufp, src: buf + 1);
162
163	free (ptr: buf);
164
165	return bufp;
166	}
167
168
169	/* Convert a hexidecimal string into a binary string. This is used in the
170	fallback conversion of a hexidecimal string to a REAL. */
171
172	static char *
173	hex2bin(int nbits, char *hex)
174	{
175	const char bits[16][5] = {
176	"0000", "0001", "0010", "0011", "0100", "0101", "0110", "0111",
177	"1000", "1001", "1010", "1011", "1100", "1101", "1110", "1111"};
178
179	char *buf, *bufp;
180	int i, j, n;
181
182	bufp = buf = XCNEWVEC (char, nbits + 1);
183	memset (s: bufp, c: 0, n: nbits + 1);
184
185	n = strlen (s: hex);
186	for (i = 0; i < n; i++, hex++)
187	{
188	j = *hex;
189	if (j > 47 && j < 58)
190	j -= 48;
191	else if (j > 64 && j < 71)
192	j -= 55;
193	else if (j > 96 && j < 103)
194	j -= 87;
195	else
196	gcc_unreachable ();
197
198	strcpy (dest: bufp, src: &bits[j][0]);
199	bufp += 4;
200	}
201
202	return buf;
203	}
204
205
206	/* Fallback conversion of a BOZ string to REAL. */
207
208	static void
209	bin2real (gfc_expr *x, int kind)
210	{
211	char buf[114], *sp;
212	int b, i, ie, t, w;
213	bool sgn;
214	mpz_t em;
215
216	i = gfc_validate_kind (BT_REAL, kind, false);
217	t = gfc_real_kinds[i].digits - 1;
218
219	/* Number of bits in the exponent. */
220	if (gfc_real_kinds[i].max_exponent == 16384)
221	w = 15;
222	else if (gfc_real_kinds[i].max_exponent == 1024)
223	w = 11;
224	else
225	w = 8;
226
227	if (x->boz.rdx == 16)
228	sp = hex2bin (nbits: gfc_real_kinds[i].mode_precision, hex: x->boz.str);
229	else if (x->boz.rdx == 8)
230	sp = oct2bin (nbits: gfc_real_kinds[i].mode_precision, oct: x->boz.str);
231	else
232	sp = x->boz.str;
233
234	/* Extract sign bit. */
235	sgn = *sp != '0';
236
237	/* Extract biased exponent. */
238	memset (s: buf, c: 0, n: 114);
239	strncpy (dest: buf, src: ++sp, n: w);
240	mpz_init (em);
241	mpz_set_str (em, buf, 2);
242	ie = mpz_get_si (em);
243
244	mpfr_init2 (x->value.real, t + 1);
245	x->ts.type = BT_REAL;
246	x->ts.kind = kind;
247
248	sp += w; /* Set to first digit in significand. */
249	b = (1 << w) - 1;
250	if ((i == 0 && ie == b) || (i == 1 && ie == b)
251	|| ((i == 2 || i == 3) && ie == b))
252	{
253	bool zeros = true;
254	if (i == 2) sp++;
255	for (; *sp; sp++)
256	{
257	if (*sp != '0')
258	{
259	zeros = false;
260	break;
261	}
262	}
263
264	if (zeros)
265	mpfr_set_inf (x->value.real, 1);
266	else
267	mpfr_set_nan (x->value.real);
268	}
269	else
270	{
271	if (i == 2)
272	strncpy (dest: buf, src: sp, n: t + 1);
273	else
274	{
275	/* Significand with hidden bit. */
276	buf[0] = '1';
277	strncpy (dest: &buf[1], src: sp, n: t);
278	}
279
280	/* Convert to significand to integer. */
281	mpz_set_str (em, buf, 2);
282	ie -= ((1 << (w - 1)) - 1); /* Unbiased exponent. */
283	mpfr_set_z_2exp (x->value.real, em, ie - t, GFC_RND_MODE);
284	}
285
286	if (sgn) mpfr_neg (x->value.real, x->value.real, GFC_RND_MODE);
287
288	mpz_clear (em);
289	}
290
291
292	/* Fortran 2018 treats a BOZ as simply a string of bits. gfc_boz2real ()
293	converts the string into a REAL of the appropriate kind. The treatment
294	of the sign bit is processor dependent. */
295
296	bool
297	gfc_boz2real (gfc_expr *x, int kind)
298	{
299	extern int gfc_max_integer_kind;
300	gfc_typespec ts;
301	int len;
302	char *buf, *str;
303
304	if (!is_boz_constant (a: x))
305	return false;
306
307	/* Determine the length of the required string. */
308	len = 8 * kind;
309	if (x->boz.rdx == 16) len /= 4;
310	if (x->boz.rdx == 8) len = len / 3 + 1;
311	buf = (char *) alloca (len + 1); /* +1 for NULL terminator. */
312
313	if (x->boz.len >= len) /* Truncate if necessary. */
314	{
315	str = x->boz.str + (x->boz.len - len);
316	strcpy(dest: buf, src: str);
317	}
318	else /* Copy and pad. */
319	{
320	memset (s: buf, c: 48, n: len);
321	str = buf + (len - x->boz.len);
322	strcpy (dest: str, src: x->boz.str);
323	}
324
325	/* Need to adjust leading bits in an octal string. */
326	if (x->boz.rdx == 8)
327	{
328	/* Clear first bit. */
329	if (kind == 4 || kind == 10 || kind == 16)
330	{
331	if (buf[0] == '4')
332	buf[0] = '0';
333	else if (buf[0] == '5')
334	buf[0] = '1';
335	else if (buf[0] == '6')
336	buf[0] = '2';
337	else if (buf[0] == '7')
338	buf[0] = '3';
339	}
340	/* Clear first two bits. */
341	else
342	{
343	if (buf[0] == '2' || buf[0] == '4' || buf[0] == '6')
344	buf[0] = '0';
345	else if (buf[0] == '3' || buf[0] == '5' || buf[0] == '7')
346	buf[0] = '1';
347	}
348	}
349
350	/* Reset BOZ string to the truncated or padded version. */
351	free (ptr: x->boz.str);
352	x->boz.len = len;
353	x->boz.str = XCNEWVEC (char, len + 1);
354	strncpy (dest: x->boz.str, src: buf, n: len);
355
356	/* For some targets, the largest INTEGER in terms of bits is smaller than
357	the bits needed to hold the REAL. Fortunately, the kind type parameter
358	indicates the number of bytes required to an INTEGER and a REAL. */
359	if (gfc_max_integer_kind < kind)
360	{
361	bin2real (x, kind);
362	}
363	else
364	{
365	/* Convert to widest possible integer. */
366	gfc_boz2int (x, gfc_max_integer_kind);
367	ts.type = BT_REAL;
368	ts.kind = kind;
369	if (!gfc_convert_boz (x, &ts))
370	{
371	gfc_error ("Failure in conversion of BOZ to REAL at %L", &x->where);
372	return false;
373	}
374	}
375
376	return true;
377	}
378
379
380	/* Fortran 2018 treats a BOZ as simply a string of bits. gfc_boz2int ()
381	converts the string into an INTEGER of the appropriate kind. The
382	treatment of the sign bit is processor dependent. If the converted
383	value exceeds the range of the type, then wrap-around semantics are
384	applied. */
385
386	bool
387	gfc_boz2int (gfc_expr *x, int kind)
388	{
389	int i, len;
390	char *buf, *str;
391	mpz_t tmp1;
392
393	if (!is_boz_constant (a: x))
394	return false;
395
396	i = gfc_validate_kind (BT_INTEGER, kind, false);
397	len = gfc_integer_kinds[i].bit_size;
398	if (x->boz.rdx == 16) len /= 4;
399	if (x->boz.rdx == 8) len = len / 3 + 1;
400	buf = (char *) alloca (len + 1); /* +1 for NULL terminator. */
401
402	if (x->boz.len >= len) /* Truncate if necessary. */
403	{
404	str = x->boz.str + (x->boz.len - len);
405	strcpy(dest: buf, src: str);
406	}
407	else /* Copy and pad. */
408	{
409	memset (s: buf, c: 48, n: len);
410	str = buf + (len - x->boz.len);
411	strcpy (dest: str, src: x->boz.str);
412	}
413
414	/* Need to adjust leading bits in an octal string. */
415	if (x->boz.rdx == 8)
416	{
417	/* Clear first bit. */
418	if (kind == 1 || kind == 4 || kind == 16)
419	{
420	if (buf[0] == '4')
421	buf[0] = '0';
422	else if (buf[0] == '5')
423	buf[0] = '1';
424	else if (buf[0] == '6')
425	buf[0] = '2';
426	else if (buf[0] == '7')
427	buf[0] = '3';
428	}
429	/* Clear first two bits. */
430	else
431	{
432	if (buf[0] == '2' || buf[0] == '4' || buf[0] == '6')
433	buf[0] = '0';
434	else if (buf[0] == '3' || buf[0] == '5' || buf[0] == '7')
435	buf[0] = '1';
436	}
437	}
438
439	/* Convert as-if unsigned integer. */
440	mpz_init (tmp1);
441	mpz_set_str (tmp1, buf, x->boz.rdx);
442
443	/* Check for wrap-around. */
444	if (mpz_cmp (tmp1, gfc_integer_kinds[i].huge) > 0)
445	{
446	mpz_t tmp2;
447	mpz_init (tmp2);
448	mpz_add_ui (tmp2, gfc_integer_kinds[i].huge, 1);
449	mpz_mod (tmp1, tmp1, tmp2);
450	mpz_sub (tmp1, tmp1, tmp2);
451	mpz_clear (tmp2);
452	}
453
454	/* Clear boz info. */
455	x->boz.rdx = 0;
456	x->boz.len = 0;
457	free (ptr: x->boz.str);
458
459	mpz_init (x->value.integer);
460	mpz_set (x->value.integer, tmp1);
461	x->ts.type = BT_INTEGER;
462	x->ts.kind = kind;
463	mpz_clear (tmp1);
464
465	return true;
466	}
467
468
469	/* Make sure an expression is a scalar. */
470
471	static bool
472	scalar_check (gfc_expr *e, int n)
473	{
474	if (e->rank == 0)
475	return true;
476
477	gfc_error ("%qs argument of %qs intrinsic at %L must be a scalar",
478	gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
479	&e->where);
480
481	return false;
482	}
483
484
485	/* Check the type of an expression. */
486
487	static bool
488	type_check (gfc_expr *e, int n, bt type)
489	{
490	if (e->ts.type == type)
491	return true;
492
493	gfc_error ("%qs argument of %qs intrinsic at %L must be %s",
494	gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
495	&e->where, gfc_basic_typename (type));
496
497	return false;
498	}
499
500
501	/* Check that the expression is a numeric type. */
502
503	static bool
504	numeric_check (gfc_expr *e, int n)
505	{
506	/* Users sometime use a subroutine designator as an actual argument to
507	an intrinsic subprogram that expects an argument with a numeric type. */
508	if (e->symtree && e->symtree->n.sym->attr.subroutine)
509	goto error;
510
511	if (gfc_numeric_ts (&e->ts))
512	return true;
513
514	/* If the expression has not got a type, check if its namespace can
515	offer a default type. */
516	if ((e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
517	&& e->symtree->n.sym->ts.type == BT_UNKNOWN
518	&& gfc_set_default_type (e->symtree->n.sym, 0, e->symtree->n.sym->ns)
519	&& gfc_numeric_ts (&e->symtree->n.sym->ts))
520	{
521	e->ts = e->symtree->n.sym->ts;
522	return true;
523	}
524
525	error:
526
527	gfc_error ("%qs argument of %qs intrinsic at %L must have a numeric type",
528	gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
529	&e->where);
530
531	return false;
532	}
533
534
535	/* Check that an expression is integer or real. */
536
537	static bool
538	int_or_real_check (gfc_expr *e, int n)
539	{
540	if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
541	{
542	gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
543	"or REAL", gfc_current_intrinsic_arg[n]->name,
544	gfc_current_intrinsic, &e->where);
545	return false;
546	}
547
548	return true;
549	}
550
551	/* Check that an expression is integer or real; allow character for
552	F2003 or later. */
553
554	static bool
555	int_or_real_or_char_check_f2003 (gfc_expr *e, int n)
556	{
557	if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
558	{
559	if (e->ts.type == BT_CHARACTER)
560	return gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Character for "
561	"%qs argument of %qs intrinsic at %L",
562	gfc_current_intrinsic_arg[n]->name,
563	gfc_current_intrinsic, &e->where);
564	else
565	{
566	if (gfc_option.allow_std & GFC_STD_F2003)
567	gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
568	"or REAL or CHARACTER",
569	gfc_current_intrinsic_arg[n]->name,
570	gfc_current_intrinsic, &e->where);
571	else
572	gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
573	"or REAL", gfc_current_intrinsic_arg[n]->name,
574	gfc_current_intrinsic, &e->where);
575	}
576	return false;
577	}
578
579	return true;
580	}
581
582	/* Check that an expression is an intrinsic type. */
583	static bool
584	intrinsic_type_check (gfc_expr *e, int n)
585	{
586	if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL
587	&& e->ts.type != BT_COMPLEX && e->ts.type != BT_CHARACTER
588	&& e->ts.type != BT_LOGICAL)
589	{
590	gfc_error ("%qs argument of %qs intrinsic at %L must be of intrinsic type",
591	gfc_current_intrinsic_arg[n]->name,
592	gfc_current_intrinsic, &e->where);
593	return false;
594	}
595	return true;
596	}
597
598	/* Check that an expression is real or complex. */
599
600	static bool
601	real_or_complex_check (gfc_expr *e, int n)
602	{
603	if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX)
604	{
605	gfc_error ("%qs argument of %qs intrinsic at %L must be REAL "
606	"or COMPLEX", gfc_current_intrinsic_arg[n]->name,
607	gfc_current_intrinsic, &e->where);
608	return false;
609	}
610
611	return true;
612	}
613
614
615	/* Check that an expression is INTEGER or PROCEDURE. */
616
617	static bool
618	int_or_proc_check (gfc_expr *e, int n)
619	{
620	if (e->ts.type != BT_INTEGER && e->ts.type != BT_PROCEDURE)
621	{
622	gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
623	"or PROCEDURE", gfc_current_intrinsic_arg[n]->name,
624	gfc_current_intrinsic, &e->where);
625	return false;
626	}
627
628	return true;
629	}
630
631
632	/* Check that the expression is an optional constant integer
633	and that it specifies a valid kind for that type. */
634
635	static bool
636	kind_check (gfc_expr *k, int n, bt type)
637	{
638	int kind;
639
640	if (k == NULL)
641	return true;
642
643	if (!type_check (e: k, n, type: BT_INTEGER))
644	return false;
645
646	if (!scalar_check (e: k, n))
647	return false;
648
649	if (!gfc_check_init_expr (k))
650	{
651	gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
652	gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
653	&k->where);
654	return false;
655	}
656
657	if (gfc_extract_int (k, &kind)
658	|| gfc_validate_kind (type, kind, true) < 0)
659	{
660	gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type),
661	&k->where);
662	return false;
663	}
664
665	return true;
666	}
667
668
669	/* Make sure the expression is a double precision real. */
670
671	static bool
672	double_check (gfc_expr *d, int n)
673	{
674	if (!type_check (e: d, n, type: BT_REAL))
675	return false;
676
677	if (d->ts.kind != gfc_default_double_kind)
678	{
679	gfc_error ("%qs argument of %qs intrinsic at %L must be double "
680	"precision", gfc_current_intrinsic_arg[n]->name,
681	gfc_current_intrinsic, &d->where);
682	return false;
683	}
684
685	return true;
686	}
687
688
689	static bool
690	coarray_check (gfc_expr *e, int n)
691	{
692	if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok
693	&& CLASS_DATA (e)->attr.codimension
694	&& CLASS_DATA (e)->as->corank)
695	{
696	gfc_add_class_array_ref (e);
697	return true;
698	}
699
700	if (!gfc_is_coarray (e))
701	{
702	gfc_error ("Expected coarray variable as %qs argument to the %s "
703	"intrinsic at %L", gfc_current_intrinsic_arg[n]->name,
704	gfc_current_intrinsic, &e->where);
705	return false;
706	}
707
708	return true;
709	}
710
711
712	/* Make sure the expression is a logical array. */
713
714	static bool
715	logical_array_check (gfc_expr *array, int n)
716	{
717	if (array->ts.type != BT_LOGICAL || array->rank == 0)
718	{
719	gfc_error ("%qs argument of %qs intrinsic at %L must be a logical "
720	"array", gfc_current_intrinsic_arg[n]->name,
721	gfc_current_intrinsic, &array->where);
722	return false;
723	}
724
725	return true;
726	}
727
728
729	/* Make sure an expression is an array. */
730
731	static bool
732	array_check (gfc_expr *e, int n)
733	{
734	if (e->rank != 0 && e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok
735	&& CLASS_DATA (e)->attr.dimension
736	&& CLASS_DATA (e)->as->rank)
737	{
738	gfc_add_class_array_ref (e);
739	}
740
741	if (e->rank != 0 && e->ts.type != BT_PROCEDURE)
742	return true;
743
744	gfc_error ("%qs argument of %qs intrinsic at %L must be an array",
745	gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
746	&e->where);
747
748	return false;
749	}
750
751
752	/* If expr is a constant, then check to ensure that it is greater than
753	of equal to zero. */
754
755	static bool
756	nonnegative_check (const char *arg, gfc_expr *expr)
757	{
758	int i;
759
760	if (expr->expr_type == EXPR_CONSTANT)
761	{
762	gfc_extract_int (expr, &i);
763	if (i < 0)
764	{
765	gfc_error ("%qs at %L must be nonnegative", arg, &expr->where);
766	return false;
767	}
768	}
769
770	return true;
771	}
772
773
774	/* If expr is a constant, then check to ensure that it is greater than zero. */
775
776	static bool
777	positive_check (int n, gfc_expr *expr)
778	{
779	int i;
780
781	if (expr->expr_type == EXPR_CONSTANT)
782	{
783	gfc_extract_int (expr, &i);
784	if (i <= 0)
785	{
786	gfc_error ("%qs argument of %qs intrinsic at %L must be positive",
787	gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
788	&expr->where);
789	return false;
790	}
791	}
792
793	return true;
794	}
795
796
797	/* If expr2 is constant, then check that the value is less than
798	(less than or equal to, if 'or_equal' is true) bit_size(expr1). */
799
800	static bool
801	less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2,
802	gfc_expr *expr2, bool or_equal)
803	{
804	int i2, i3;
805
806	if (expr2->expr_type == EXPR_CONSTANT)
807	{
808	gfc_extract_int (expr2, &i2);
809	i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
810
811	/* For ISHFT[C], check that |shift| <= bit_size(i). */
812	if (arg2 == NULL)
813	{
814	if (i2 < 0)
815	i2 = -i2;
816
817	if (i2 > gfc_integer_kinds[i3].bit_size)
818	{
819	gfc_error ("The absolute value of SHIFT at %L must be less "
820	"than or equal to BIT_SIZE(%qs)",
821	&expr2->where, arg1);
822	return false;
823	}
824	}
825
826	if (or_equal)
827	{
828	if (i2 > gfc_integer_kinds[i3].bit_size)
829	{
830	gfc_error ("%qs at %L must be less than "
831	"or equal to BIT_SIZE(%qs)",
832	arg2, &expr2->where, arg1);
833	return false;
834	}
835	}
836	else
837	{
838	if (i2 >= gfc_integer_kinds[i3].bit_size)
839	{
840	gfc_error ("%qs at %L must be less than BIT_SIZE(%qs)",
841	arg2, &expr2->where, arg1);
842	return false;
843	}
844	}
845	}
846
847	return true;
848	}
849
850
851	/* If expr is constant, then check that the value is less than or equal
852	to the bit_size of the kind k. */
853
854	static bool
855	less_than_bitsizekind (const char *arg, gfc_expr *expr, int k)
856	{
857	int i, val;
858
859	if (expr->expr_type != EXPR_CONSTANT)
860	return true;
861
862	i = gfc_validate_kind (BT_INTEGER, k, false);
863	gfc_extract_int (expr, &val);
864
865	if (val > gfc_integer_kinds[i].bit_size)
866	{
867	gfc_error ("%qs at %L must be less than or equal to the BIT_SIZE of "
868	"INTEGER(KIND=%d)", arg, &expr->where, k);
869	return false;
870	}
871
872	return true;
873	}
874
875
876	/* If expr2 and expr3 are constants, then check that the value is less than
877	or equal to bit_size(expr1). */
878
879	static bool
880	less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2,
881	gfc_expr *expr2, const char *arg3, gfc_expr *expr3)
882	{
883	int i2, i3;
884
885	if (expr2->expr_type == EXPR_CONSTANT && expr3->expr_type == EXPR_CONSTANT)
886	{
887	gfc_extract_int (expr2, &i2);
888	gfc_extract_int (expr3, &i3);
889	i2 += i3;
890	i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
891	if (i2 > gfc_integer_kinds[i3].bit_size)
892	{
893	gfc_error ("%<%s + %s%> at %L must be less than or equal "
894	"to BIT_SIZE(%qs)",
895	arg2, arg3, &expr2->where, arg1);
896	return false;
897	}
898	}
899
900	return true;
901	}
902
903	/* Make sure two expressions have the same type. */
904
905	static bool
906	same_type_check (gfc_expr *e, int n, gfc_expr *f, int m, bool assoc = false)
907	{
908	gfc_typespec *ets = &e->ts;
909	gfc_typespec *fts = &f->ts;
910
911	if (assoc)
912	{
913	/* Procedure pointer component expressions have the type of the interface
914	procedure. If they are being tested for association with a procedure
915	pointer (ie. not a component), the type of the procedure must be
916	determined. */
917	if (e->ts.type == BT_PROCEDURE && e->symtree->n.sym)
918	ets = &e->symtree->n.sym->ts;
919	if (f->ts.type == BT_PROCEDURE && f->symtree->n.sym)
920	fts = &f->symtree->n.sym->ts;
921	}
922
923	if (gfc_compare_types (ets, fts))
924	return true;
925
926	gfc_error ("%qs argument of %qs intrinsic at %L must be the same type "
927	"and kind as %qs", gfc_current_intrinsic_arg[m]->name,
928	gfc_current_intrinsic, &f->where,
929	gfc_current_intrinsic_arg[n]->name);
930
931	return false;
932	}
933
934
935	/* Make sure that an expression has a certain (nonzero) rank. */
936
937	static bool
938	rank_check (gfc_expr *e, int n, int rank)
939	{
940	if (e->rank == rank)
941	return true;
942
943	gfc_error ("%qs argument of %qs intrinsic at %L must be of rank %d",
944	gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
945	&e->where, rank);
946
947	return false;
948	}
949
950
951	/* Make sure a variable expression is not an optional dummy argument. */
952
953	static bool
954	nonoptional_check (gfc_expr *e, int n)
955	{
956	if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
957	{
958	gfc_error ("%qs argument of %qs intrinsic at %L must not be OPTIONAL",
959	gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
960	&e->where);
961	}
962
963	/* TODO: Recursive check on nonoptional variables? */
964
965	return true;
966	}
967
968
969	/* Check for ALLOCATABLE attribute. */
970
971	static bool
972	allocatable_check (gfc_expr *e, int n)
973	{
974	symbol_attribute attr;
975
976	attr = gfc_variable_attr (e, NULL);
977	if (!attr.allocatable
978	|| (attr.associate_var && !attr.select_rank_temporary))
979	{
980	gfc_error ("%qs argument of %qs intrinsic at %L must be ALLOCATABLE",
981	gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
982	&e->where);
983	return false;
984	}
985
986	return true;
987	}
988
989
990	/* Check that an expression has a particular kind. */
991
992	static bool
993	kind_value_check (gfc_expr *e, int n, int k)
994	{
995	if (e->ts.kind == k)
996	return true;
997
998	gfc_error ("%qs argument of %qs intrinsic at %L must be of kind %d",
999	gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
1000	&e->where, k);
1001
1002	return false;
1003	}
1004
1005
1006	/* Make sure an expression is a variable. */
1007
1008	static bool
1009	variable_check (gfc_expr *e, int n, bool allow_proc)
1010	{
1011	if (e->expr_type == EXPR_VARIABLE
1012	&& e->symtree->n.sym->attr.intent == INTENT_IN
1013	&& (gfc_current_intrinsic_arg[n]->intent == INTENT_OUT
1014	|| gfc_current_intrinsic_arg[n]->intent == INTENT_INOUT)
1015	&& !gfc_check_vardef_context (e, false, true, false, NULL))
1016	{
1017	gfc_error ("%qs argument of %qs intrinsic at %L cannot be INTENT(IN)",
1018	gfc_current_intrinsic_arg[n]->name,
1019	gfc_current_intrinsic, &e->where);
1020	return false;
1021	}
1022
1023	if (e->expr_type == EXPR_VARIABLE
1024	&& e->symtree->n.sym->attr.flavor != FL_PARAMETER
1025	&& (allow_proc || !e->symtree->n.sym->attr.function))
1026	return true;
1027
1028	if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.function
1029	&& e->symtree->n.sym == e->symtree->n.sym->result)
1030	{
1031	gfc_namespace *ns;
1032	for (ns = gfc_current_ns; ns; ns = ns->parent)
1033	if (ns->proc_name == e->symtree->n.sym)
1034	return true;
1035	}
1036
1037	/* F2018:R902: function reference having a data pointer result. */
1038	if (e->expr_type == EXPR_FUNCTION
1039	&& e->symtree->n.sym->attr.flavor == FL_PROCEDURE
1040	&& e->symtree->n.sym->attr.function
1041	&& e->symtree->n.sym->attr.pointer)
1042	return true;
1043
1044	gfc_error ("%qs argument of %qs intrinsic at %L must be a variable",
1045	gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where);
1046
1047	return false;
1048	}
1049
1050
1051	/* Check the common DIM parameter for correctness. */
1052
1053	static bool
1054	dim_check (gfc_expr *dim, int n, bool optional)
1055	{
1056	if (dim == NULL)
1057	return true;
1058
1059	if (!type_check (e: dim, n, type: BT_INTEGER))
1060	return false;
1061
1062	if (!scalar_check (e: dim, n))
1063	return false;
1064
1065	if (!optional && !nonoptional_check (e: dim, n))
1066	return false;
1067
1068	return true;
1069	}
1070
1071
1072	/* If a coarray DIM parameter is a constant, make sure that it is greater than
1073	zero and less than or equal to the corank of the given array. */
1074
1075	static bool
1076	dim_corank_check (gfc_expr *dim, gfc_expr *array)
1077	{
1078	int corank;
1079
1080	gcc_assert (array->expr_type == EXPR_VARIABLE);
1081
1082	if (dim->expr_type != EXPR_CONSTANT)
1083	return true;
1084
1085	if (array->ts.type == BT_CLASS)
1086	return true;
1087
1088	corank = gfc_get_corank (array);
1089
1090	if (mpz_cmp_ui (dim->value.integer, 1) < 0
1091	|| mpz_cmp_ui (dim->value.integer, corank) > 0)
1092	{
1093	gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
1094	"codimension index", gfc_current_intrinsic, &dim->where);
1095
1096	return false;
1097	}
1098
1099	return true;
1100	}
1101
1102
1103	/* If a DIM parameter is a constant, make sure that it is greater than
1104	zero and less than or equal to the rank of the given array. If
1105	allow_assumed is zero then dim must be less than the rank of the array
1106	for assumed size arrays. */
1107
1108	static bool
1109	dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
1110	{
1111	gfc_array_ref *ar;
1112	int rank;
1113
1114	if (dim == NULL)
1115	return true;
1116
1117	if (dim->expr_type != EXPR_CONSTANT)
1118	return true;
1119
1120	if (array->expr_type == EXPR_FUNCTION && array->value.function.isym
1121	&& array->value.function.isym->id == GFC_ISYM_SPREAD)
1122	rank = array->rank + 1;
1123	else
1124	rank = array->rank;
1125
1126	/* Assumed-rank array. */
1127	if (rank == -1)
1128	rank = GFC_MAX_DIMENSIONS;
1129
1130	if (array->expr_type == EXPR_VARIABLE)
1131	{
1132	ar = gfc_find_array_ref (array, a: true);
1133	if (!ar)
1134	return false;
1135	if (ar->as->type == AS_ASSUMED_SIZE
1136	&& !allow_assumed
1137	&& ar->type != AR_ELEMENT
1138	&& ar->type != AR_SECTION)
1139	rank--;
1140	}
1141
1142	if (mpz_cmp_ui (dim->value.integer, 1) < 0
1143	|| mpz_cmp_ui (dim->value.integer, rank) > 0)
1144	{
1145	gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
1146	"dimension index", gfc_current_intrinsic, &dim->where);
1147
1148	return false;
1149	}
1150
1151	return true;
1152	}
1153
1154
1155	/* Compare the size of a along dimension ai with the size of b along
1156	dimension bi, returning 0 if they are known not to be identical,
1157	and 1 if they are identical, or if this cannot be determined. */
1158
1159	static bool
1160	identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
1161	{
1162	mpz_t a_size, b_size;
1163	bool ret;
1164
1165	gcc_assert (a->rank > ai);
1166	gcc_assert (b->rank > bi);
1167
1168	ret = true;
1169
1170	if (gfc_array_dimen_size (a, ai, &a_size))
1171	{
1172	if (gfc_array_dimen_size (b, bi, &b_size))
1173	{
1174	if (mpz_cmp (a_size, b_size) != 0)
1175	ret = false;
1176
1177	mpz_clear (b_size);
1178	}
1179	mpz_clear (a_size);
1180	}
1181	return ret;
1182	}
1183
1184	/* Calculate the length of a character variable, including substrings.
1185	Strip away parentheses if necessary. Return -1 if no length could
1186	be determined. */
1187
1188	static long
1189	gfc_var_strlen (const gfc_expr *a)
1190	{
1191	gfc_ref *ra;
1192
1193	while (a->expr_type == EXPR_OP && a->value.op.op == INTRINSIC_PARENTHESES)
1194	a = a->value.op.op1;
1195
1196	for (ra = a->ref; ra != NULL && ra->type != REF_SUBSTRING; ra = ra->next)
1197	;
1198
1199	if (ra)
1200	{
1201	long start_a, end_a;
1202
1203	if (!ra->u.ss.end)
1204	return -1;
1205
1206	if ((!ra->u.ss.start || ra->u.ss.start->expr_type == EXPR_CONSTANT)
1207	&& ra->u.ss.end->expr_type == EXPR_CONSTANT)
1208	{
1209	start_a = ra->u.ss.start ? mpz_get_si (ra->u.ss.start->value.integer)
1210	: 1;
1211	end_a = mpz_get_si (ra->u.ss.end->value.integer);
1212	return (end_a < start_a) ? 0 : end_a - start_a + 1;
1213	}
1214	else if (ra->u.ss.start
1215	&& gfc_dep_compare_expr (ra->u.ss.start, ra->u.ss.end) == 0)
1216	return 1;
1217	else
1218	return -1;
1219	}
1220
1221	if (a->ts.u.cl && a->ts.u.cl->length
1222	&& a->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1223	return mpz_get_si (a->ts.u.cl->length->value.integer);
1224	else if (a->expr_type == EXPR_CONSTANT
1225	&& (a->ts.u.cl == NULL || a->ts.u.cl->length == NULL))
1226	return a->value.character.length;
1227	else
1228	return -1;
1229
1230	}
1231
1232	/* Check whether two character expressions have the same length;
1233	returns true if they have or if the length cannot be determined,
1234	otherwise return false and raise a gfc_error. */
1235
1236	bool
1237	gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
1238	{
1239	long len_a, len_b;
1240
1241	len_a = gfc_var_strlen(a);
1242	len_b = gfc_var_strlen(a: b);
1243
1244	if (len_a == -1 || len_b == -1 || len_a == len_b)
1245	return true;
1246	else
1247	{
1248	gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
1249	len_a, len_b, name, &a->where);
1250	return false;
1251	}
1252	}
1253
1254
1255	/***** Check functions *****/
1256
1257	/* Check subroutine suitable for intrinsics taking a real argument and
1258	a kind argument for the result. */
1259
1260	static bool
1261	check_a_kind (gfc_expr *a, gfc_expr *kind, bt type)
1262	{
1263	if (!type_check (e: a, n: 0, type: BT_REAL))
1264	return false;
1265	if (!kind_check (k: kind, n: 1, type))
1266	return false;
1267
1268	return true;
1269	}
1270
1271
1272	/* Check subroutine suitable for ceiling, floor and nint. */
1273
1274	bool
1275	gfc_check_a_ikind (gfc_expr *a, gfc_expr *kind)
1276	{
1277	return check_a_kind (a, kind, type: BT_INTEGER);
1278	}
1279
1280
1281	/* Check subroutine suitable for aint, anint. */
1282
1283	bool
1284	gfc_check_a_xkind (gfc_expr *a, gfc_expr *kind)
1285	{
1286	return check_a_kind (a, kind, type: BT_REAL);
1287	}
1288
1289
1290	bool
1291	gfc_check_abs (gfc_expr *a)
1292	{
1293	if (!numeric_check (e: a, n: 0))
1294	return false;
1295
1296	return true;
1297	}
1298
1299
1300	bool
1301	gfc_check_achar (gfc_expr *a, gfc_expr *kind)
1302	{
1303	if (a->ts.type == BT_BOZ)
1304	{
1305	if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in "
1306	"ACHAR intrinsic subprogram"), loc: &a->where))
1307	return false;
1308
1309	if (!gfc_boz2int (x: a, kind: gfc_default_integer_kind))
1310	return false;
1311	}
1312
1313	if (!type_check (e: a, n: 0, type: BT_INTEGER))
1314	return false;
1315
1316	if (!kind_check (k: kind, n: 1, type: BT_CHARACTER))
1317	return false;
1318
1319	return true;
1320	}
1321
1322
1323	bool
1324	gfc_check_access_func (gfc_expr *name, gfc_expr *mode)
1325	{
1326	if (!type_check (e: name, n: 0, type: BT_CHARACTER)
1327	|| !scalar_check (e: name, n: 0))
1328	return false;
1329	if (!kind_value_check (e: name, n: 0, k: gfc_default_character_kind))
1330	return false;
1331
1332	if (!type_check (e: mode, n: 1, type: BT_CHARACTER)
1333	|| !scalar_check (e: mode, n: 1))
1334	return false;
1335	if (!kind_value_check (e: mode, n: 1, k: gfc_default_character_kind))
1336	return false;
1337
1338	return true;
1339	}
1340
1341
1342	bool
1343	gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
1344	{
1345	if (!logical_array_check (array: mask, n: 0))
1346	return false;
1347
1348	if (!dim_check (dim, n: 1, optional: false))
1349	return false;
1350
1351	if (!dim_rank_check (dim, array: mask, allow_assumed: 0))
1352	return false;
1353
1354	return true;
1355	}
1356
1357
1358	/* Limited checking for ALLOCATED intrinsic. Additional checking
1359	is performed in intrinsic.cc(sort_actual), because ALLOCATED
1360	has two mutually exclusive non-optional arguments. */
1361
1362	bool
1363	gfc_check_allocated (gfc_expr *array)
1364	{
1365	/* Tests on allocated components of coarrays need to detour the check to
1366	argument of the _caf_get. */
1367	if (flag_coarray == GFC_FCOARRAY_LIB && array->expr_type == EXPR_FUNCTION
1368	&& array->value.function.isym
1369	&& array->value.function.isym->id == GFC_ISYM_CAF_GET)
1370	{
1371	array = array->value.function.actual->expr;
1372	if (!array->ref)
1373	return false;
1374	}
1375
1376	if (!variable_check (e: array, n: 0, allow_proc: false))
1377	return false;
1378	if (!allocatable_check (e: array, n: 0))
1379	return false;
1380
1381	return true;
1382	}
1383
1384
1385	/* Common check function where the first argument must be real or
1386	integer and the second argument must be the same as the first. */
1387
1388	bool
1389	gfc_check_a_p (gfc_expr *a, gfc_expr *p)
1390	{
1391	if (!int_or_real_check (e: a, n: 0))
1392	return false;
1393
1394	if (a->ts.type != p->ts.type)
1395	{
1396	gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
1397	"have the same type", gfc_current_intrinsic_arg[0]->name,
1398	gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1399	&p->where);
1400	return false;
1401	}
1402
1403	if (a->ts.kind != p->ts.kind)
1404	{
1405	if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
1406	&p->where))
1407	return false;
1408	}
1409
1410	return true;
1411	}
1412
1413
1414	bool
1415	gfc_check_x_yd (gfc_expr *x, gfc_expr *y)
1416	{
1417	if (!double_check (d: x, n: 0) || !double_check (d: y, n: 1))
1418	return false;
1419
1420	return true;
1421	}
1422
1423	bool
1424	gfc_invalid_null_arg (gfc_expr *x)
1425	{
1426	if (x->expr_type == EXPR_NULL)
1427	{
1428	gfc_error ("NULL at %L is not permitted as actual argument "
1429	"to %qs intrinsic function", &x->where,
1430	gfc_current_intrinsic);
1431	return true;
1432	}
1433	return false;
1434	}
1435
1436	bool
1437	gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
1438	{
1439	symbol_attribute attr1, attr2;
1440	int i;
1441	bool t;
1442
1443	if (gfc_invalid_null_arg (x: pointer))
1444	return false;
1445
1446	attr1 = gfc_expr_attr (pointer);
1447
1448	if (!attr1.pointer && !attr1.proc_pointer)
1449	{
1450	gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER",
1451	gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
1452	&pointer->where);
1453	return false;
1454	}
1455
1456	/* F2008, C1242. */
1457	if (attr1.pointer && gfc_is_coindexed (pointer))
1458	{
1459	gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
1460	"coindexed", gfc_current_intrinsic_arg[0]->name,
1461	gfc_current_intrinsic, &pointer->where);
1462	return false;
1463	}
1464
1465	/* Target argument is optional. */
1466	if (target == NULL)
1467	return true;
1468
1469	if (gfc_invalid_null_arg (x: target))
1470	return false;
1471
1472	if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION)
1473	attr2 = gfc_expr_attr (target);
1474	else
1475	{
1476	gfc_error ("%qs argument of %qs intrinsic at %L must be a pointer "
1477	"or target VARIABLE or FUNCTION",
1478	gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1479	&target->where);
1480	return false;
1481	}
1482
1483	if (attr1.pointer && !attr2.pointer && !attr2.target)
1484	{
1485	gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER "
1486	"or a TARGET", gfc_current_intrinsic_arg[1]->name,
1487	gfc_current_intrinsic, &target->where);
1488	return false;
1489	}
1490
1491	/* F2008, C1242. */
1492	if (attr1.pointer && gfc_is_coindexed (target))
1493	{
1494	gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
1495	"coindexed", gfc_current_intrinsic_arg[1]->name,
1496	gfc_current_intrinsic, &target->where);
1497	return false;
1498	}
1499
1500	t = true;
1501	if (!same_type_check (e: pointer, n: 0, f: target, m: 1, assoc: true))
1502	t = false;
1503	/* F2018 C838 explicitly allows an assumed-rank variable as the first
1504	argument of intrinsic inquiry functions. */
1505	if (pointer->rank != -1 && !rank_check (e: target, n: 0, rank: pointer->rank))
1506	t = false;
1507	if (target->rank > 0 && target->ref)
1508	{
1509	for (i = 0; i < target->rank; i++)
1510	if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
1511	{
1512	gfc_error ("Array section with a vector subscript at %L shall not "
1513	"be the target of a pointer",
1514	&target->where);
1515	t = false;
1516	break;
1517	}
1518	}
1519	return t;
1520	}
1521
1522
1523	bool
1524	gfc_check_atan_2 (gfc_expr *y, gfc_expr *x)
1525	{
1526	/* gfc_notify_std would be a waste of time as the return value
1527	is seemingly used only for the generic resolution. The error
1528	will be: Too many arguments. */
1529	if ((gfc_option.allow_std & GFC_STD_F2008) == 0)
1530	return false;
1531
1532	return gfc_check_atan2 (y, x);
1533	}
1534
1535
1536	bool
1537	gfc_check_atan2 (gfc_expr *y, gfc_expr *x)
1538	{
1539	if (!type_check (e: y, n: 0, type: BT_REAL))
1540	return false;
1541	if (!same_type_check (e: y, n: 0, f: x, m: 1))
1542	return false;
1543
1544	return true;
1545	}
1546
1547
1548	static bool
1549	gfc_check_atomic (gfc_expr *atom, int atom_no, gfc_expr *value, int val_no,
1550	gfc_expr *stat, int stat_no)
1551	{
1552	if (!scalar_check (e: atom, n: atom_no) || !scalar_check (e: value, n: val_no))
1553	return false;
1554
1555	if (!(atom->ts.type == BT_INTEGER && atom->ts.kind == gfc_atomic_int_kind)
1556	&& !(atom->ts.type == BT_LOGICAL
1557	&& atom->ts.kind == gfc_atomic_logical_kind))
1558	{
1559	gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1560	"integer of ATOMIC_INT_KIND or a logical of "
1561	"ATOMIC_LOGICAL_KIND", &atom->where, gfc_current_intrinsic);
1562	return false;
1563	}
1564
1565	if (!gfc_is_coarray (atom) && !gfc_is_coindexed (atom))
1566	{
1567	gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a "
1568	"coarray or coindexed", &atom->where, gfc_current_intrinsic);
1569	return false;
1570	}
1571
1572	if (atom->ts.type != value->ts.type)
1573	{
1574	gfc_error ("%qs argument of %qs intrinsic at %L shall have the same "
1575	"type as %qs at %L", gfc_current_intrinsic_arg[val_no]->name,
1576	gfc_current_intrinsic, &value->where,
1577	gfc_current_intrinsic_arg[atom_no]->name, &atom->where);
1578	return false;
1579	}
1580
1581	if (stat != NULL)
1582	{
1583	if (!type_check (e: stat, n: stat_no, type: BT_INTEGER))
1584	return false;
1585	if (!scalar_check (e: stat, n: stat_no))
1586	return false;
1587	if (!variable_check (e: stat, n: stat_no, allow_proc: false))
1588	return false;
1589	if (!kind_value_check (e: stat, n: stat_no, k: gfc_default_integer_kind))
1590	return false;
1591
1592	if (!gfc_notify_std (GFC_STD_F2018, "STAT= argument to %s at %L",
1593	gfc_current_intrinsic, &stat->where))
1594	return false;
1595	}
1596
1597	return true;
1598	}
1599
1600
1601	bool
1602	gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value, gfc_expr *stat)
1603	{
1604	if (atom->expr_type == EXPR_FUNCTION
1605	&& atom->value.function.isym
1606	&& atom->value.function.isym->id == GFC_ISYM_CAF_GET)
1607	atom = atom->value.function.actual->expr;
1608
1609	if (!gfc_check_vardef_context (atom, false, false, false, NULL))
1610	{
1611	gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1612	"definable", gfc_current_intrinsic, &atom->where);
1613	return false;
1614	}
1615
1616	return gfc_check_atomic (atom, atom_no: 0, value, val_no: 1, stat, stat_no: 2);
1617	}
1618
1619
1620	bool
1621	gfc_check_atomic_op (gfc_expr *atom, gfc_expr *value, gfc_expr *stat)
1622	{
1623	if (atom->ts.type != BT_INTEGER || atom->ts.kind != gfc_atomic_int_kind)
1624	{
1625	gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1626	"integer of ATOMIC_INT_KIND", &atom->where,
1627	gfc_current_intrinsic);
1628	return false;
1629	}
1630
1631	return gfc_check_atomic_def (atom, value, stat);
1632	}
1633
1634
1635	bool
1636	gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom, gfc_expr *stat)
1637	{
1638	if (atom->expr_type == EXPR_FUNCTION
1639	&& atom->value.function.isym
1640	&& atom->value.function.isym->id == GFC_ISYM_CAF_GET)
1641	atom = atom->value.function.actual->expr;
1642
1643	if (!gfc_check_vardef_context (value, false, false, false, NULL))
1644	{
1645	gfc_error ("VALUE argument of the %s intrinsic function at %L shall be "
1646	"definable", gfc_current_intrinsic, &value->where);
1647	return false;
1648	}
1649
1650	return gfc_check_atomic (atom, atom_no: 1, value, val_no: 0, stat, stat_no: 2);
1651	}
1652
1653
1654	bool
1655	gfc_check_image_status (gfc_expr *image, gfc_expr *team)
1656	{
1657	/* IMAGE has to be a positive, scalar integer. */
1658	if (!type_check (e: image, n: 0, type: BT_INTEGER) || !scalar_check (e: image, n: 0)
1659	|| !positive_check (n: 0, expr: image))
1660	return false;
1661
1662	if (team)
1663	{
1664	gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
1665	gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1666	&team->where);
1667	return false;
1668	}
1669	return true;
1670	}
1671
1672
1673	bool
1674	gfc_check_failed_or_stopped_images (gfc_expr *team, gfc_expr *kind)
1675	{
1676	if (team)
1677	{
1678	gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
1679	gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
1680	&team->where);
1681	return false;
1682	}
1683
1684	if (kind)
1685	{
1686	int k;
1687
1688	if (!type_check (e: kind, n: 1, type: BT_INTEGER) || !scalar_check (e: kind, n: 1)
1689	|| !positive_check (n: 1, expr: kind))
1690	return false;
1691
1692	/* Get the kind, reporting error on non-constant or overflow. */
1693	gfc_current_locus = kind->where;
1694	if (gfc_extract_int (kind, &k, 1))
1695	return false;
1696	if (gfc_validate_kind (BT_INTEGER, k, true) == -1)
1697	{
1698	gfc_error ("%qs argument of %qs intrinsic at %L shall specify a "
1699	"valid integer kind", gfc_current_intrinsic_arg[1]->name,
1700	gfc_current_intrinsic, &kind->where);
1701	return false;
1702	}
1703	}
1704	return true;
1705	}
1706
1707
1708	bool
1709	gfc_check_get_team (gfc_expr *level)
1710	{
1711	if (level)
1712	{
1713	gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
1714	gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
1715	&level->where);
1716	return false;
1717	}
1718	return true;
1719	}
1720
1721
1722	bool
1723	gfc_check_atomic_cas (gfc_expr *atom, gfc_expr *old, gfc_expr *compare,
1724	gfc_expr *new_val, gfc_expr *stat)
1725	{
1726	if (atom->expr_type == EXPR_FUNCTION
1727	&& atom->value.function.isym
1728	&& atom->value.function.isym->id == GFC_ISYM_CAF_GET)
1729	atom = atom->value.function.actual->expr;
1730
1731	if (!gfc_check_atomic (atom, atom_no: 0, value: new_val, val_no: 3, stat, stat_no: 4))
1732	return false;
1733
1734	if (!scalar_check (e: old, n: 1) || !scalar_check (e: compare, n: 2))
1735	return false;
1736
1737	if (!same_type_check (e: atom, n: 0, f: old, m: 1))
1738	return false;
1739
1740	if (!same_type_check (e: atom, n: 0, f: compare, m: 2))
1741	return false;
1742
1743	if (!gfc_check_vardef_context (atom, false, false, false, NULL))
1744	{
1745	gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1746	"definable", gfc_current_intrinsic, &atom->where);
1747	return false;
1748	}
1749
1750	if (!gfc_check_vardef_context (old, false, false, false, NULL))
1751	{
1752	gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
1753	"definable", gfc_current_intrinsic, &old->where);
1754	return false;
1755	}
1756
1757	return true;
1758	}
1759
1760	bool
1761	gfc_check_event_query (gfc_expr *event, gfc_expr *count, gfc_expr *stat)
1762	{
1763	if (event->ts.type != BT_DERIVED
1764	|| event->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
1765	|| event->ts.u.derived->intmod_sym_id != ISOFORTRAN_EVENT_TYPE)
1766	{
1767	gfc_error ("EVENT argument at %L to the intrinsic EVENT_QUERY "
1768	"shall be of type EVENT_TYPE", &event->where);
1769	return false;
1770	}
1771
1772	if (!scalar_check (e: event, n: 0))
1773	return false;
1774
1775	if (!gfc_check_vardef_context (count, false, false, false, NULL))
1776	{
1777	gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
1778	"shall be definable", &count->where);
1779	return false;
1780	}
1781
1782	if (!type_check (e: count, n: 1, type: BT_INTEGER))
1783	return false;
1784
1785	int i = gfc_validate_kind (BT_INTEGER, count->ts.kind, false);
1786	int j = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false);
1787
1788	if (gfc_integer_kinds[i].range < gfc_integer_kinds[j].range)
1789	{
1790	gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
1791	"shall have at least the range of the default integer",
1792	&count->where);
1793	return false;
1794	}
1795
1796	if (stat != NULL)
1797	{
1798	if (!type_check (e: stat, n: 2, type: BT_INTEGER))
1799	return false;
1800	if (!scalar_check (e: stat, n: 2))
1801	return false;
1802	if (!variable_check (e: stat, n: 2, allow_proc: false))
1803	return false;
1804
1805	if (!gfc_notify_std (GFC_STD_F2018, "STAT= argument to %s at %L",
1806	gfc_current_intrinsic, &stat->where))
1807	return false;
1808	}
1809
1810	return true;
1811	}
1812
1813
1814	bool
1815	gfc_check_atomic_fetch_op (gfc_expr *atom, gfc_expr *value, gfc_expr *old,
1816	gfc_expr *stat)
1817	{
1818	if (atom->expr_type == EXPR_FUNCTION
1819	&& atom->value.function.isym
1820	&& atom->value.function.isym->id == GFC_ISYM_CAF_GET)
1821	atom = atom->value.function.actual->expr;
1822
1823	if (atom->ts.type != BT_INTEGER || atom->ts.kind != gfc_atomic_int_kind)
1824	{
1825	gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1826	"integer of ATOMIC_INT_KIND", &atom->where,
1827	gfc_current_intrinsic);
1828	return false;
1829	}
1830
1831	if (!gfc_check_atomic (atom, atom_no: 0, value, val_no: 1, stat, stat_no: 3))
1832	return false;
1833
1834	if (!scalar_check (e: old, n: 2))
1835	return false;
1836
1837	if (!same_type_check (e: atom, n: 0, f: old, m: 2))
1838	return false;
1839
1840	if (!gfc_check_vardef_context (atom, false, false, false, NULL))
1841	{
1842	gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1843	"definable", gfc_current_intrinsic, &atom->where);
1844	return false;
1845	}
1846
1847	if (!gfc_check_vardef_context (old, false, false, false, NULL))
1848	{
1849	gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
1850	"definable", gfc_current_intrinsic, &old->where);
1851	return false;
1852	}
1853
1854	return true;
1855	}
1856
1857
1858	/* BESJN and BESYN functions. */
1859
1860	bool
1861	gfc_check_besn (gfc_expr *n, gfc_expr *x)
1862	{
1863	if (!type_check (e: n, n: 0, type: BT_INTEGER))
1864	return false;
1865	if (n->expr_type == EXPR_CONSTANT)
1866	{
1867	int i;
1868	gfc_extract_int (n, &i);
1869	if (i < 0 && !gfc_notify_std (GFC_STD_GNU, "Negative argument "
1870	"N at %L", &n->where))
1871	return false;
1872	}
1873
1874	if (!type_check (e: x, n: 1, type: BT_REAL))
1875	return false;
1876
1877	return true;
1878	}
1879
1880
1881	/* Transformational version of the Bessel JN and YN functions. */
1882
1883	bool
1884	gfc_check_bessel_n2 (gfc_expr *n1, gfc_expr *n2, gfc_expr *x)
1885	{
1886	if (!type_check (e: n1, n: 0, type: BT_INTEGER))
1887	return false;
1888	if (!scalar_check (e: n1, n: 0))
1889	return false;
1890	if (!nonnegative_check (arg: "N1", expr: n1))
1891	return false;
1892
1893	if (!type_check (e: n2, n: 1, type: BT_INTEGER))
1894	return false;
1895	if (!scalar_check (e: n2, n: 1))
1896	return false;
1897	if (!nonnegative_check (arg: "N2", expr: n2))
1898	return false;
1899
1900	if (!type_check (e: x, n: 2, type: BT_REAL))
1901	return false;
1902	if (!scalar_check (e: x, n: 2))
1903	return false;
1904
1905	return true;
1906	}
1907
1908
1909	bool
1910	gfc_check_bge_bgt_ble_blt (gfc_expr *i, gfc_expr *j)
1911	{
1912	extern int gfc_max_integer_kind;
1913
1914	/* If i and j are both BOZ, convert to widest INTEGER. */
1915	if (i->ts.type == BT_BOZ && j->ts.type == BT_BOZ)
1916	{
1917	if (!gfc_boz2int (x: i, kind: gfc_max_integer_kind))
1918	return false;
1919	if (!gfc_boz2int (x: j, kind: gfc_max_integer_kind))
1920	return false;
1921	}
1922
1923	/* If i is BOZ and j is integer, convert i to type of j. */
1924	if (i->ts.type == BT_BOZ && j->ts.type == BT_INTEGER
1925	&& !gfc_boz2int (x: i, kind: j->ts.kind))
1926	return false;
1927
1928	/* If j is BOZ and i is integer, convert j to type of i. */
1929	if (j->ts.type == BT_BOZ && i->ts.type == BT_INTEGER
1930	&& !gfc_boz2int (x: j, kind: i->ts.kind))
1931	return false;
1932
1933	if (!type_check (e: i, n: 0, type: BT_INTEGER))
1934	return false;
1935
1936	if (!type_check (e: j, n: 1, type: BT_INTEGER))
1937	return false;
1938
1939	return true;
1940	}
1941
1942
1943	bool
1944	gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos)
1945	{
1946	if (!type_check (e: i, n: 0, type: BT_INTEGER))
1947	return false;
1948
1949	if (!type_check (e: pos, n: 1, type: BT_INTEGER))
1950	return false;
1951
1952	if (!nonnegative_check (arg: "pos", expr: pos))
1953	return false;
1954
1955	if (!less_than_bitsize1 (arg1: "i", expr1: i, arg2: "pos", expr2: pos, or_equal: false))
1956	return false;
1957
1958	return true;
1959	}
1960
1961
1962	bool
1963	gfc_check_char (gfc_expr *i, gfc_expr *kind)
1964	{
1965	if (i->ts.type == BT_BOZ)
1966	{
1967	if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in "
1968	"CHAR intrinsic subprogram"), loc: &i->where))
1969	return false;
1970
1971	if (!gfc_boz2int (x: i, kind: gfc_default_integer_kind))
1972	return false;
1973	}
1974
1975	if (!type_check (e: i, n: 0, type: BT_INTEGER))
1976	return false;
1977
1978	if (!kind_check (k: kind, n: 1, type: BT_CHARACTER))
1979	return false;
1980
1981	return true;
1982	}
1983
1984
1985	bool
1986	gfc_check_chdir (gfc_expr *dir)
1987	{
1988	if (!type_check (e: dir, n: 0, type: BT_CHARACTER))
1989	return false;
1990	if (!kind_value_check (e: dir, n: 0, k: gfc_default_character_kind))
1991	return false;
1992
1993	return true;
1994	}
1995
1996
1997	bool
1998	gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status)
1999	{
2000	if (!type_check (e: dir, n: 0, type: BT_CHARACTER))
2001	return false;
2002	if (!kind_value_check (e: dir, n: 0, k: gfc_default_character_kind))
2003	return false;
2004
2005	if (status == NULL)
2006	return true;
2007
2008	if (!type_check (e: status, n: 1, type: BT_INTEGER))
2009	return false;
2010	if (!scalar_check (e: status, n: 1))
2011	return false;
2012
2013	return true;
2014	}
2015
2016
2017	bool
2018	gfc_check_chmod (gfc_expr *name, gfc_expr *mode)
2019	{
2020	if (!type_check (e: name, n: 0, type: BT_CHARACTER))
2021	return false;
2022	if (!kind_value_check (e: name, n: 0, k: gfc_default_character_kind))
2023	return false;
2024
2025	if (!type_check (e: mode, n: 1, type: BT_CHARACTER))
2026	return false;
2027	if (!kind_value_check (e: mode, n: 1, k: gfc_default_character_kind))
2028	return false;
2029
2030	return true;
2031	}
2032
2033
2034	bool
2035	gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status)
2036	{
2037	if (!type_check (e: name, n: 0, type: BT_CHARACTER))
2038	return false;
2039	if (!kind_value_check (e: name, n: 0, k: gfc_default_character_kind))
2040	return false;
2041
2042	if (!type_check (e: mode, n: 1, type: BT_CHARACTER))
2043	return false;
2044	if (!kind_value_check (e: mode, n: 1, k: gfc_default_character_kind))
2045	return false;
2046
2047	if (status == NULL)
2048	return true;
2049
2050	if (!type_check (e: status, n: 2, type: BT_INTEGER))
2051	return false;
2052
2053	if (!scalar_check (e: status, n: 2))
2054	return false;
2055
2056	return true;
2057	}
2058
2059
2060	bool
2061	gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
2062	{
2063	int k;
2064
2065	/* Check kind first, because it may be needed in conversion of a BOZ. */
2066	if (kind)
2067	{
2068	if (!kind_check (k: kind, n: 2, type: BT_COMPLEX))
2069	return false;
2070	gfc_extract_int (kind, &k);
2071	}
2072	else
2073	k = gfc_default_complex_kind;
2074
2075	if (x->ts.type == BT_BOZ && !gfc_boz2real (x, kind: k))
2076	return false;
2077
2078	if (!numeric_check (e: x, n: 0))
2079	return false;
2080
2081	if (y != NULL)
2082	{
2083	if (y->ts.type == BT_BOZ && !gfc_boz2real (x: y, kind: k))
2084	return false;
2085
2086	if (!numeric_check (e: y, n: 1))
2087	return false;
2088
2089	if (x->ts.type == BT_COMPLEX)
2090	{
2091	gfc_error ("%qs argument of %qs intrinsic at %L must not be "
2092	"present if %<x%> is COMPLEX",
2093	gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
2094	&y->where);
2095	return false;
2096	}
2097
2098	if (y->ts.type == BT_COMPLEX)
2099	{
2100	gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
2101	"of either REAL or INTEGER",
2102	gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
2103	&y->where);
2104	return false;
2105	}
2106	}
2107
2108	if (!kind && warn_conversion
2109	&& x->ts.type == BT_REAL && x->ts.kind > gfc_default_real_kind)
2110	gfc_warning_now (opt: OPT_Wconversion, "Conversion from %s to default-kind "
2111	"COMPLEX(%d) at %L might lose precision, consider using "
2112	"the KIND argument", gfc_typename (&x->ts),
2113	gfc_default_real_kind, &x->where);
2114	else if (y && !kind && warn_conversion
2115	&& y->ts.type == BT_REAL && y->ts.kind > gfc_default_real_kind)
2116	gfc_warning_now (opt: OPT_Wconversion, "Conversion from %s to default-kind "
2117	"COMPLEX(%d) at %L might lose precision, consider using "
2118	"the KIND argument", gfc_typename (&y->ts),
2119	gfc_default_real_kind, &y->where);
2120	return true;
2121	}
2122
2123
2124	static bool
2125	check_co_collective (gfc_expr *a, gfc_expr *image_idx, gfc_expr *stat,
2126	gfc_expr *errmsg, bool co_reduce)
2127	{
2128	if (!variable_check (e: a, n: 0, allow_proc: false))
2129	return false;
2130
2131	if (!gfc_check_vardef_context (a, false, false, false, "argument 'A' with "
2132	"INTENT(INOUT)"))
2133	return false;
2134
2135	/* Fortran 2008, 12.5.2.4, paragraph 18. */
2136	if (gfc_has_vector_subscript (a))
2137	{
2138	gfc_error ("Argument %<A%> with INTENT(INOUT) at %L of the intrinsic "
2139	"subroutine %s shall not have a vector subscript",
2140	&a->where, gfc_current_intrinsic);
2141	return false;
2142	}
2143
2144	if (gfc_is_coindexed (a))
2145	{
2146	gfc_error ("The A argument at %L to the intrinsic %s shall not be "
2147	"coindexed", &a->where, gfc_current_intrinsic);
2148	return false;
2149	}
2150
2151	if (image_idx != NULL)
2152	{
2153	if (!type_check (e: image_idx, n: co_reduce ? 2 : 1, type: BT_INTEGER))
2154	return false;
2155	if (!scalar_check (e: image_idx, n: co_reduce ? 2 : 1))
2156	return false;
2157	}
2158
2159	if (stat != NULL)
2160	{
2161	if (!type_check (e: stat, n: co_reduce ? 3 : 2, type: BT_INTEGER))
2162	return false;
2163	if (!scalar_check (e: stat, n: co_reduce ? 3 : 2))
2164	return false;
2165	if (!variable_check (e: stat, n: co_reduce ? 3 : 2, allow_proc: false))
2166	return false;
2167	if (stat->ts.kind != 4)
2168	{
2169	gfc_error ("The stat= argument at %L must be a kind=4 integer "
2170	"variable", &stat->where);
2171	return false;
2172	}
2173	}
2174
2175	if (errmsg != NULL)
2176	{
2177	if (!type_check (e: errmsg, n: co_reduce ? 4 : 3, type: BT_CHARACTER))
2178	return false;
2179	if (!scalar_check (e: errmsg, n: co_reduce ? 4 : 3))
2180	return false;
2181	if (!variable_check (e: errmsg, n: co_reduce ? 4 : 3, allow_proc: false))
2182	return false;
2183	if (errmsg->ts.kind != 1)
2184	{
2185	gfc_error ("The errmsg= argument at %L must be a default-kind "
2186	"character variable", &errmsg->where);
2187	return false;
2188	}
2189	}
2190
2191	if (flag_coarray == GFC_FCOARRAY_NONE)
2192	{
2193	gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable",
2194	&a->where);
2195	return false;
2196	}
2197
2198	return true;
2199	}
2200
2201
2202	bool
2203	gfc_check_co_broadcast (gfc_expr *a, gfc_expr *source_image, gfc_expr *stat,
2204	gfc_expr *errmsg)
2205	{
2206	if (a->ts.type == BT_CLASS || gfc_expr_attr (a).alloc_comp)
2207	{
2208	gfc_error ("Support for the A argument at %L which is polymorphic A "
2209	"argument or has allocatable components is not yet "
2210	"implemented", &a->where);
2211	return false;
2212	}
2213	return check_co_collective (a, image_idx: source_image, stat, errmsg, co_reduce: false);
2214	}
2215
2216
2217	bool
2218	gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image,
2219	gfc_expr *stat, gfc_expr *errmsg)
2220	{
2221	symbol_attribute attr;
2222	gfc_formal_arglist *formal;
2223	gfc_symbol *sym;
2224
2225	if (a->ts.type == BT_CLASS)
2226	{
2227	gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic",
2228	&a->where);
2229	return false;
2230	}
2231
2232	if (gfc_expr_attr (a).alloc_comp)
2233	{
2234	gfc_error ("Support for the A argument at %L with allocatable components"
2235	" is not yet implemented", &a->where);
2236	return false;
2237	}
2238
2239	if (!check_co_collective (a, image_idx: result_image, stat, errmsg, co_reduce: true))
2240	return false;
2241
2242	if (!gfc_resolve_expr (op))
2243	return false;
2244
2245	attr = gfc_expr_attr (op);
2246	if (!attr.pure || !attr.function)
2247	{
2248	gfc_error ("OPERATION argument at %L must be a PURE function",
2249	&op->where);
2250	return false;
2251	}
2252
2253	if (attr.intrinsic)
2254	{
2255	/* None of the intrinsics fulfills the criteria of taking two arguments,
2256	returning the same type and kind as the arguments and being permitted
2257	as actual argument. */
2258	gfc_error ("Intrinsic function %s at %L is not permitted for CO_REDUCE",
2259	op->symtree->n.sym->name, &op->where);
2260	return false;
2261	}
2262
2263	if (gfc_is_proc_ptr_comp (op))
2264	{
2265	gfc_component *comp = gfc_get_proc_ptr_comp (op);
2266	sym = comp->ts.interface;
2267	}
2268	else
2269	sym = op->symtree->n.sym;
2270
2271	formal = sym->formal;
2272
2273	if (!formal || !formal->next || formal->next->next)
2274	{
2275	gfc_error ("The function passed as OPERATION at %L shall have two "
2276	"arguments", &op->where);
2277	return false;
2278	}
2279
2280	if (sym->result->ts.type == BT_UNKNOWN)
2281	gfc_set_default_type (sym->result, 0, NULL);
2282
2283	if (!gfc_compare_types (&a->ts, &sym->result->ts))
2284	{
2285	gfc_error ("The A argument at %L has type %s but the function passed as "
2286	"OPERATION at %L returns %s",
2287	&a->where, gfc_typename (a), &op->where,
2288	gfc_typename (&sym->result->ts));
2289	return false;
2290	}
2291	if (!gfc_compare_types (&a->ts, &formal->sym->ts)
2292	|| !gfc_compare_types (&a->ts, &formal->next->sym->ts))
2293	{
2294	gfc_error ("The function passed as OPERATION at %L has arguments of type "
2295	"%s and %s but shall have type %s", &op->where,
2296	gfc_typename (&formal->sym->ts),
2297	gfc_typename (&formal->next->sym->ts), gfc_typename (a));
2298	return false;
2299	}
2300	if (op->rank || attr.allocatable || attr.pointer || formal->sym->as
2301	|| formal->next->sym->as || formal->sym->attr.allocatable
2302	|| formal->next->sym->attr.allocatable || formal->sym->attr.pointer
2303	|| formal->next->sym->attr.pointer)
2304	{
2305	gfc_error ("The function passed as OPERATION at %L shall have scalar "
2306	"nonallocatable nonpointer arguments and return a "
2307	"nonallocatable nonpointer scalar", &op->where);
2308	return false;
2309	}
2310
2311	if (formal->sym->attr.value != formal->next->sym->attr.value)
2312	{
2313	gfc_error ("The function passed as OPERATION at %L shall have the VALUE "
2314	"attribute either for none or both arguments", &op->where);
2315	return false;
2316	}
2317
2318	if (formal->sym->attr.target != formal->next->sym->attr.target)
2319	{
2320	gfc_error ("The function passed as OPERATION at %L shall have the TARGET "
2321	"attribute either for none or both arguments", &op->where);
2322	return false;
2323	}
2324
2325	if (formal->sym->attr.asynchronous != formal->next->sym->attr.asynchronous)
2326	{
2327	gfc_error ("The function passed as OPERATION at %L shall have the "
2328	"ASYNCHRONOUS attribute either for none or both arguments",
2329	&op->where);
2330	return false;
2331	}
2332
2333	if (formal->sym->attr.optional || formal->next->sym->attr.optional)
2334	{
2335	gfc_error ("The function passed as OPERATION at %L shall not have the "
2336	"OPTIONAL attribute for either of the arguments", &op->where);
2337	return false;
2338	}
2339
2340	if (a->ts.type == BT_CHARACTER)
2341	{
2342	gfc_charlen *cl;
2343	unsigned long actual_size, formal_size1, formal_size2, result_size;
2344
2345	cl = a->ts.u.cl;
2346	actual_size = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT
2347	? mpz_get_ui (gmp_z: cl->length->value.integer) : 0;
2348
2349	cl = formal->sym->ts.u.cl;
2350	formal_size1 = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT
2351	? mpz_get_ui (gmp_z: cl->length->value.integer) : 0;
2352
2353	cl = formal->next->sym->ts.u.cl;
2354	formal_size2 = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT
2355	? mpz_get_ui (gmp_z: cl->length->value.integer) : 0;
2356
2357	cl = sym->ts.u.cl;
2358	result_size = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT
2359	? mpz_get_ui (gmp_z: cl->length->value.integer) : 0;
2360
2361	if (actual_size
2362	&& ((formal_size1 && actual_size != formal_size1)
2363	|| (formal_size2 && actual_size != formal_size2)))
2364	{
2365	gfc_error ("The character length of the A argument at %L and of the "
2366	"arguments of the OPERATION at %L shall be the same",
2367	&a->where, &op->where);
2368	return false;
2369	}
2370	if (actual_size && result_size && actual_size != result_size)
2371	{
2372	gfc_error ("The character length of the A argument at %L and of the "
2373	"function result of the OPERATION at %L shall be the same",
2374	&a->where, &op->where);
2375	return false;
2376	}
2377	}
2378
2379	return true;
2380	}
2381
2382
2383	bool
2384	gfc_check_co_minmax (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat,
2385	gfc_expr *errmsg)
2386	{
2387	if (a->ts.type != BT_INTEGER && a->ts.type != BT_REAL
2388	&& a->ts.type != BT_CHARACTER)
2389	{
2390	gfc_error ("%qs argument of %qs intrinsic at %L shall be of type "
2391	"integer, real or character",
2392	gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
2393	&a->where);
2394	return false;
2395	}
2396	return check_co_collective (a, image_idx: result_image, stat, errmsg, co_reduce: false);
2397	}
2398
2399
2400	bool
2401	gfc_check_co_sum (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat,
2402	gfc_expr *errmsg)
2403	{
2404	if (!numeric_check (e: a, n: 0))
2405	return false;
2406	return check_co_collective (a, image_idx: result_image, stat, errmsg, co_reduce: false);
2407	}
2408
2409
2410	bool
2411	gfc_check_complex (gfc_expr *x, gfc_expr *y)
2412	{
2413	if (!boz_args_check (i: x, j: y))
2414	return false;
2415
2416	if (x->ts.type == BT_BOZ)
2417	{
2418	if (gfc_invalid_boz (G_("BOZ constant at %L cannot appear in the COMPLEX"
2419	" intrinsic subprogram"), loc: &x->where))
2420	{
2421	reset_boz (x);
2422	return false;
2423	}
2424	if (y->ts.type == BT_INTEGER && !gfc_boz2int (x, kind: y->ts.kind))
2425	return false;
2426	if (y->ts.type == BT_REAL && !gfc_boz2real (x, kind: y->ts.kind))
2427	return false;
2428	}
2429
2430	if (y->ts.type == BT_BOZ)
2431	{
2432	if (gfc_invalid_boz (G_("BOZ constant at %L cannot appear in the COMPLEX"
2433	" intrinsic subprogram"), loc: &y->where))
2434	{
2435	reset_boz (x: y);
2436	return false;
2437	}
2438	if (x->ts.type == BT_INTEGER && !gfc_boz2int (x: y, kind: x->ts.kind))
2439	return false;
2440	if (x->ts.type == BT_REAL && !gfc_boz2real (x: y, kind: x->ts.kind))
2441	return false;
2442	}
2443
2444	if (!int_or_real_check (e: x, n: 0))
2445	return false;
2446	if (!scalar_check (e: x, n: 0))
2447	return false;
2448
2449	if (!int_or_real_check (e: y, n: 1))
2450	return false;
2451	if (!scalar_check (e: y, n: 1))
2452	return false;
2453
2454	return true;
2455	}
2456
2457
2458	bool
2459	gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
2460	{
2461	if (!logical_array_check (array: mask, n: 0))
2462	return false;
2463	if (!dim_check (dim, n: 1, optional: false))
2464	return false;
2465	if (!dim_rank_check (dim, array: mask, allow_assumed: 0))
2466	return false;
2467	if (!kind_check (k: kind, n: 2, type: BT_INTEGER))
2468	return false;
2469	if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
2470	"with KIND argument at %L",
2471	gfc_current_intrinsic, &kind->where))
2472	return false;
2473
2474	return true;
2475	}
2476
2477
2478	bool
2479	gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
2480	{
2481	if (!array_check (e: array, n: 0))
2482	return false;
2483
2484	if (!type_check (e: shift, n: 1, type: BT_INTEGER))
2485	return false;
2486
2487	if (!dim_check (dim, n: 2, optional: true))
2488	return false;
2489
2490	if (!dim_rank_check (dim, array, allow_assumed: false))
2491	return false;
2492
2493	if (array->rank == 1 || shift->rank == 0)
2494	{
2495	if (!scalar_check (e: shift, n: 1))
2496	return false;
2497	}
2498	else if (shift->rank == array->rank - 1)
2499	{
2500	int d;
2501	if (!dim)
2502	d = 1;
2503	else if (dim->expr_type == EXPR_CONSTANT)
2504	gfc_extract_int (dim, &d);
2505	else
2506	d = -1;
2507
2508	if (d > 0)
2509	{
2510	int i, j;
2511	for (i = 0, j = 0; i < array->rank; i++)
2512	if (i != d - 1)
2513	{
2514	if (!identical_dimen_shape (a: array, ai: i, b: shift, bi: j))
2515	{
2516	gfc_error ("%qs argument of %qs intrinsic at %L has "
2517	"invalid shape in dimension %d (%ld/%ld)",
2518	gfc_current_intrinsic_arg[1]->name,
2519	gfc_current_intrinsic, &shift->where, i + 1,
2520	mpz_get_si (array->shape[i]),
2521	mpz_get_si (shift->shape[j]));
2522	return false;
2523	}
2524
2525	j += 1;
2526	}
2527	}
2528	}
2529	else
2530	{
2531	gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
2532	"%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
2533	gfc_current_intrinsic, &shift->where, array->rank - 1);
2534	return false;
2535	}
2536
2537	return true;
2538	}
2539
2540
2541	bool
2542	gfc_check_ctime (gfc_expr *time)
2543	{
2544	if (!scalar_check (e: time, n: 0))
2545	return false;
2546
2547	if (!type_check (e: time, n: 0, type: BT_INTEGER))
2548	return false;
2549
2550	return true;
2551	}
2552
2553
2554	bool gfc_check_datan2 (gfc_expr *y, gfc_expr *x)
2555	{
2556	if (!double_check (d: y, n: 0) || !double_check (d: x, n: 1))
2557	return false;
2558
2559	return true;
2560	}
2561
2562	bool
2563	gfc_check_dcmplx (gfc_expr *x, gfc_expr *y)
2564	{
2565	if (x->ts.type == BT_BOZ && !gfc_boz2real (x, kind: gfc_default_double_kind))
2566	return false;
2567
2568	if (!numeric_check (e: x, n: 0))
2569	return false;
2570
2571	if (y != NULL)
2572	{
2573	if (y->ts.type == BT_BOZ && !gfc_boz2real (x: y, kind: gfc_default_double_kind))
2574	return false;
2575
2576	if (!numeric_check (e: y, n: 1))
2577	return false;
2578
2579	if (x->ts.type == BT_COMPLEX)
2580	{
2581	gfc_error ("%qs argument of %qs intrinsic at %L must not be "
2582	"present if %<x%> is COMPLEX",
2583	gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
2584	&y->where);
2585	return false;
2586	}
2587
2588	if (y->ts.type == BT_COMPLEX)
2589	{
2590	gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
2591	"of either REAL or INTEGER",
2592	gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
2593	&y->where);
2594	return false;
2595	}
2596	}
2597
2598	return true;
2599	}
2600
2601
2602	bool
2603	gfc_check_dble (gfc_expr *x)
2604	{
2605	if (x->ts.type == BT_BOZ && !gfc_boz2real (x, kind: gfc_default_double_kind))
2606	return false;
2607
2608	if (!numeric_check (e: x, n: 0))
2609	return false;
2610
2611	return true;
2612	}
2613
2614
2615	bool
2616	gfc_check_digits (gfc_expr *x)
2617	{
2618	if (!int_or_real_check (e: x, n: 0))
2619	return false;
2620
2621	return true;
2622	}
2623
2624
2625	bool
2626	gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
2627	{
2628	switch (vector_a->ts.type)
2629	{
2630	case BT_LOGICAL:
2631	if (!type_check (e: vector_b, n: 1, type: BT_LOGICAL))
2632	return false;
2633	break;
2634
2635	case BT_INTEGER:
2636	case BT_REAL:
2637	case BT_COMPLEX:
2638	if (!numeric_check (e: vector_b, n: 1))
2639	return false;
2640	break;
2641
2642	default:
2643	gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
2644	"or LOGICAL", gfc_current_intrinsic_arg[0]->name,
2645	gfc_current_intrinsic, &vector_a->where);
2646	return false;
2647	}
2648
2649	if (!rank_check (e: vector_a, n: 0, rank: 1))
2650	return false;
2651
2652	if (!rank_check (e: vector_b, n: 1, rank: 1))
2653	return false;
2654
2655	if (! identical_dimen_shape (a: vector_a, ai: 0, b: vector_b, bi: 0))
2656	{
2657	gfc_error ("Different shape for arguments %qs and %qs at %L for "
2658	"intrinsic %<dot_product%>",
2659	gfc_current_intrinsic_arg[0]->name,
2660	gfc_current_intrinsic_arg[1]->name, &vector_a->where);
2661	return false;
2662	}
2663
2664	return true;
2665	}
2666
2667
2668	bool
2669	gfc_check_dprod (gfc_expr *x, gfc_expr *y)
2670	{
2671	if (!type_check (e: x, n: 0, type: BT_REAL)
2672	|| !type_check (e: y, n: 1, type: BT_REAL))
2673	return false;
2674
2675	if (x->ts.kind != gfc_default_real_kind)
2676	{
2677	gfc_error ("%qs argument of %qs intrinsic at %L must be default "
2678	"real", gfc_current_intrinsic_arg[0]->name,
2679	gfc_current_intrinsic, &x->where);
2680	return false;
2681	}
2682
2683	if (y->ts.kind != gfc_default_real_kind)
2684	{
2685	gfc_error ("%qs argument of %qs intrinsic at %L must be default "
2686	"real", gfc_current_intrinsic_arg[1]->name,
2687	gfc_current_intrinsic, &y->where);
2688	return false;
2689	}
2690
2691	return true;
2692	}
2693
2694	bool
2695	gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift)
2696	{
2697	/* i and j cannot both be BOZ literal constants. */
2698	if (!boz_args_check (i, j))
2699	return false;
2700
2701	/* If i is BOZ and j is integer, convert i to type of j. If j is not
2702	an integer, clear the BOZ; otherwise, check that i is an integer. */
2703	if (i->ts.type == BT_BOZ)
2704	{
2705	if (j->ts.type != BT_INTEGER)
2706	reset_boz (x: i);
2707	else if (!gfc_boz2int (x: i, kind: j->ts.kind))
2708	return false;
2709	}
2710	else if (!type_check (e: i, n: 0, type: BT_INTEGER))
2711	{
2712	if (j->ts.type == BT_BOZ)
2713	reset_boz (x: j);
2714	return false;
2715	}
2716
2717	/* If j is BOZ and i is integer, convert j to type of i. If i is not
2718	an integer, clear the BOZ; otherwise, check that i is an integer. */
2719	if (j->ts.type == BT_BOZ)
2720	{
2721	if (i->ts.type != BT_INTEGER)
2722	reset_boz (x: j);
2723	else if (!gfc_boz2int (x: j, kind: i->ts.kind))
2724	return false;
2725	}
2726	else if (!type_check (e: j, n: 1, type: BT_INTEGER))
2727	return false;
2728
2729	if (!same_type_check (e: i, n: 0, f: j, m: 1))
2730	return false;
2731
2732	if (!type_check (e: shift, n: 2, type: BT_INTEGER))
2733	return false;
2734
2735	if (!nonnegative_check (arg: "SHIFT", expr: shift))
2736	return false;
2737
2738	if (!less_than_bitsize1 (arg1: "I", expr1: i, arg2: "SHIFT", expr2: shift, or_equal: true))
2739	return false;
2740
2741	return true;
2742	}
2743
2744
2745	bool
2746	gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
2747	gfc_expr *dim)
2748	{
2749	int d;
2750
2751	if (!array_check (e: array, n: 0))
2752	return false;
2753
2754	if (!type_check (e: shift, n: 1, type: BT_INTEGER))
2755	return false;
2756
2757	if (!dim_check (dim, n: 3, optional: true))
2758	return false;
2759
2760	if (!dim_rank_check (dim, array, allow_assumed: false))
2761	return false;
2762
2763	if (!dim)
2764	d = 1;
2765	else if (dim->expr_type == EXPR_CONSTANT)
2766	gfc_extract_int (dim, &d);
2767	else
2768	d = -1;
2769
2770	if (array->rank == 1 || shift->rank == 0)
2771	{
2772	if (!scalar_check (e: shift, n: 1))
2773	return false;
2774	}
2775	else if (shift->rank == array->rank - 1)
2776	{
2777	if (d > 0)
2778	{
2779	int i, j;
2780	for (i = 0, j = 0; i < array->rank; i++)
2781	if (i != d - 1)
2782	{
2783	if (!identical_dimen_shape (a: array, ai: i, b: shift, bi: j))
2784	{
2785	gfc_error ("%qs argument of %qs intrinsic at %L has "
2786	"invalid shape in dimension %d (%ld/%ld)",
2787	gfc_current_intrinsic_arg[1]->name,
2788	gfc_current_intrinsic, &shift->where, i + 1,
2789	mpz_get_si (array->shape[i]),
2790	mpz_get_si (shift->shape[j]));
2791	return false;
2792	}
2793
2794	j += 1;
2795	}
2796	}
2797	}
2798	else
2799	{
2800	gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
2801	"%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
2802	gfc_current_intrinsic, &shift->where, array->rank - 1);
2803	return false;
2804	}
2805
2806	if (boundary != NULL)
2807	{
2808	if (!same_type_check (e: array, n: 0, f: boundary, m: 2))
2809	return false;
2810
2811	/* Reject unequal string lengths and emit a better error message than
2812	gfc_check_same_strlen would. */
2813	if (array->ts.type == BT_CHARACTER)
2814	{
2815	ssize_t len_a, len_b;
2816
2817	len_a = gfc_var_strlen (a: array);
2818	len_b = gfc_var_strlen (a: boundary);
2819	if (len_a != -1 && len_b != -1 && len_a != len_b)
2820	{
2821	gfc_error ("%qs must be of same type and kind as %qs at %L in %qs",
2822	gfc_current_intrinsic_arg[2]->name,
2823	gfc_current_intrinsic_arg[0]->name,
2824	&boundary->where, gfc_current_intrinsic);
2825	return false;
2826	}
2827	}
2828
2829	if (array->rank == 1 || boundary->rank == 0)
2830	{
2831	if (!scalar_check (e: boundary, n: 2))
2832	return false;
2833	}
2834	else if (boundary->rank == array->rank - 1)
2835	{
2836	if (d > 0)
2837	{
2838	int i,j;
2839	for (i = 0, j = 0; i < array->rank; i++)
2840	{
2841	if (i != d - 1)
2842	{
2843	if (!identical_dimen_shape (a: array, ai: i, b: boundary, bi: j))
2844	{
2845	gfc_error ("%qs argument of %qs intrinsic at %L has "
2846	"invalid shape in dimension %d (%ld/%ld)",
2847	gfc_current_intrinsic_arg[2]->name,
2848	gfc_current_intrinsic, &shift->where, i+1,
2849	mpz_get_si (array->shape[i]),
2850	mpz_get_si (boundary->shape[j]));
2851	return false;
2852	}
2853	j += 1;
2854	}
2855	}
2856	}
2857	}
2858	else
2859	{
2860	gfc_error ("%qs argument of intrinsic %qs at %L of must have "
2861	"rank %d or be a scalar",
2862	gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
2863	&shift->where, array->rank - 1);
2864	return false;
2865	}
2866	}
2867	else
2868	{
2869	switch (array->ts.type)
2870	{
2871	case BT_INTEGER:
2872	case BT_LOGICAL:
2873	case BT_REAL:
2874	case BT_COMPLEX:
2875	case BT_CHARACTER:
2876	break;
2877
2878	default:
2879	gfc_error ("Missing %qs argument to %qs intrinsic at %L for %qs "
2880	"of type %qs", gfc_current_intrinsic_arg[2]->name,
2881	gfc_current_intrinsic, &array->where,
2882	gfc_current_intrinsic_arg[0]->name,
2883	gfc_typename (array));
2884	return false;
2885	}
2886	}
2887
2888	return true;
2889	}
2890
2891
2892	bool
2893	gfc_check_float (gfc_expr *a)
2894	{
2895	if (a->ts.type == BT_BOZ)
2896	{
2897	if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in the"
2898	" FLOAT intrinsic subprogram"), loc: &a->where))
2899	{
2900	reset_boz (x: a);
2901	return false;
2902	}
2903	if (!gfc_boz2int (x: a, kind: gfc_default_integer_kind))
2904	return false;
2905	}
2906
2907	if (!type_check (e: a, n: 0, type: BT_INTEGER))
2908	return false;
2909
2910	if ((a->ts.kind != gfc_default_integer_kind)
2911	&& !gfc_notify_std (GFC_STD_GNU, "non-default INTEGER "
2912	"kind argument to %s intrinsic at %L",
2913	gfc_current_intrinsic, &a->where))
2914	return false;
2915
2916	return true;
2917	}
2918
2919	/* A single complex argument. */
2920
2921	bool
2922	gfc_check_fn_c (gfc_expr *a)
2923	{
2924	if (!type_check (e: a, n: 0, type: BT_COMPLEX))
2925	return false;
2926
2927	return true;
2928	}
2929
2930
2931	/* A single real argument. */
2932
2933	bool
2934	gfc_check_fn_r (gfc_expr *a)
2935	{
2936	if (!type_check (e: a, n: 0, type: BT_REAL))
2937	return false;
2938
2939	return true;
2940	}
2941
2942	/* A single double argument. */
2943
2944	bool
2945	gfc_check_fn_d (gfc_expr *a)
2946	{
2947	if (!double_check (d: a, n: 0))
2948	return false;
2949
2950	return true;
2951	}
2952
2953	/* A single real or complex argument. */
2954
2955	bool
2956	gfc_check_fn_rc (gfc_expr *a)
2957	{
2958	if (!real_or_complex_check (e: a, n: 0))
2959	return false;
2960
2961	return true;
2962	}
2963
2964
2965	bool
2966	gfc_check_fn_rc2008 (gfc_expr *a)
2967	{
2968	if (!real_or_complex_check (e: a, n: 0))
2969	return false;
2970
2971	if (a->ts.type == BT_COMPLEX
2972	&& !gfc_notify_std (GFC_STD_F2008, "COMPLEX argument %qs "
2973	"of %qs intrinsic at %L",
2974	gfc_current_intrinsic_arg[0]->name,
2975	gfc_current_intrinsic, &a->where))
2976	return false;
2977
2978	return true;
2979	}
2980
2981
2982	bool
2983	gfc_check_fnum (gfc_expr *unit)
2984	{
2985	if (!type_check (e: unit, n: 0, type: BT_INTEGER))
2986	return false;
2987
2988	if (!scalar_check (e: unit, n: 0))
2989	return false;
2990
2991	return true;
2992	}
2993
2994
2995	bool
2996	gfc_check_huge (gfc_expr *x)
2997	{
2998	if (!int_or_real_check (e: x, n: 0))
2999	return false;
3000
3001	return true;
3002	}
3003
3004
3005	bool
3006	gfc_check_hypot (gfc_expr *x, gfc_expr *y)
3007	{
3008	if (!type_check (e: x, n: 0, type: BT_REAL))
3009	return false;
3010	if (!same_type_check (e: x, n: 0, f: y, m: 1))
3011	return false;
3012
3013	return true;
3014	}
3015
3016
3017	/* Check that the single argument is an integer. */
3018
3019	bool
3020	gfc_check_i (gfc_expr *i)
3021	{
3022	if (!type_check (e: i, n: 0, type: BT_INTEGER))
3023	return false;
3024
3025	return true;
3026	}
3027
3028
3029	bool
3030	gfc_check_iand_ieor_ior (gfc_expr *i, gfc_expr *j)
3031	{
3032	/* i and j cannot both be BOZ literal constants. */
3033	if (!boz_args_check (i, j))
3034	return false;
3035
3036	/* If i is BOZ and j is integer, convert i to type of j. */
3037	if (i->ts.type == BT_BOZ && j->ts.type == BT_INTEGER
3038	&& !gfc_boz2int (x: i, kind: j->ts.kind))
3039	return false;
3040
3041	/* If j is BOZ and i is integer, convert j to type of i. */
3042	if (j->ts.type == BT_BOZ && i->ts.type == BT_INTEGER
3043	&& !gfc_boz2int (x: j, kind: i->ts.kind))
3044	return false;
3045
3046	if (!type_check (e: i, n: 0, type: BT_INTEGER))
3047	return false;
3048
3049	if (!type_check (e: j, n: 1, type: BT_INTEGER))
3050	return false;
3051
3052	if (i->ts.kind != j->ts.kind)
3053	{
3054	gfc_error ("Arguments of %qs have different kind type parameters "
3055	"at %L", gfc_current_intrinsic, &i->where);
3056	return false;
3057	}
3058
3059	return true;
3060	}
3061
3062
3063	bool
3064	gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len)
3065	{
3066	if (!type_check (e: i, n: 0, type: BT_INTEGER))
3067	return false;
3068
3069	if (!type_check (e: pos, n: 1, type: BT_INTEGER))
3070	return false;
3071
3072	if (!type_check (e: len, n: 2, type: BT_INTEGER))
3073	return false;
3074
3075	if (!nonnegative_check (arg: "pos", expr: pos))
3076	return false;
3077
3078	if (!nonnegative_check (arg: "len", expr: len))
3079	return false;
3080
3081	if (!less_than_bitsize2 (arg1: "i", expr1: i, arg2: "pos", expr2: pos, arg3: "len", expr3: len))
3082	return false;
3083
3084	return true;
3085	}
3086
3087
3088	bool
3089	gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
3090	{
3091	int i;
3092
3093	if (!type_check (e: c, n: 0, type: BT_CHARACTER))
3094	return false;
3095
3096	if (!kind_check (k: kind, n: 1, type: BT_INTEGER))
3097	return false;
3098
3099	if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
3100	"with KIND argument at %L",
3101	gfc_current_intrinsic, &kind->where))
3102	return false;
3103
3104	if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
3105	{
3106	gfc_expr *start;
3107	gfc_expr *end;
3108	gfc_ref *ref;
3109
3110	/* Substring references don't have the charlength set. */
3111	ref = c->ref;
3112	while (ref && ref->type != REF_SUBSTRING)
3113	ref = ref->next;
3114
3115	gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
3116
3117	if (!ref)
3118	{
3119	/* Check that the argument is length one. Non-constant lengths
3120	can't be checked here, so assume they are ok. */
3121	if (c->ts.u.cl && c->ts.u.cl->length)
3122	{
3123	/* If we already have a length for this expression then use it. */
3124	if (c->ts.u.cl->length->expr_type != EXPR_CONSTANT)
3125	return true;
3126	i = mpz_get_si (c->ts.u.cl->length->value.integer);
3127	}
3128	else
3129	return true;
3130	}
3131	else
3132	{
3133	start = ref->u.ss.start;
3134	end = ref->u.ss.end;
3135
3136	gcc_assert (start);
3137	if (end == NULL || end->expr_type != EXPR_CONSTANT
3138	|| start->expr_type != EXPR_CONSTANT)
3139	return true;
3140
3141	i = mpz_get_si (end->value.integer) + 1
3142	- mpz_get_si (start->value.integer);
3143	}
3144	}
3145	else
3146	return true;
3147
3148	if (i != 1)
3149	{
3150	gfc_error ("Argument of %s at %L must be of length one",
3151	gfc_current_intrinsic, &c->where);
3152	return false;
3153	}
3154
3155	return true;
3156	}
3157
3158
3159	bool
3160	gfc_check_idnint (gfc_expr *a)
3161	{
3162	if (!double_check (d: a, n: 0))
3163	return false;
3164
3165	return true;
3166	}
3167
3168
3169	bool
3170	gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back,
3171	gfc_expr *kind)
3172	{
3173	if (!type_check (e: string, n: 0, type: BT_CHARACTER)
3174	|| !type_check (e: substring, n: 1, type: BT_CHARACTER))
3175	return false;
3176
3177	if (back != NULL && !type_check (e: back, n: 2, type: BT_LOGICAL))
3178	return false;
3179
3180	if (!kind_check (k: kind, n: 3, type: BT_INTEGER))
3181	return false;
3182	if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
3183	"with KIND argument at %L",
3184	gfc_current_intrinsic, &kind->where))
3185	return false;
3186
3187	if (string->ts.kind != substring->ts.kind)
3188	{
3189	gfc_error ("%qs argument of %qs intrinsic at %L must be the same "
3190	"kind as %qs", gfc_current_intrinsic_arg[1]->name,
3191	gfc_current_intrinsic, &substring->where,
3192	gfc_current_intrinsic_arg[0]->name);
3193	return false;
3194	}
3195
3196	return true;
3197	}
3198
3199
3200	bool
3201	gfc_check_int (gfc_expr *x, gfc_expr *kind)
3202	{
3203	/* BOZ is dealt within simplify_int*. */
3204	if (x->ts.type == BT_BOZ)
3205	return true;
3206
3207	if (!numeric_check (e: x, n: 0))
3208	return false;
3209
3210	if (!kind_check (k: kind, n: 1, type: BT_INTEGER))
3211	return false;
3212
3213	return true;
3214	}
3215
3216
3217	bool
3218	gfc_check_intconv (gfc_expr *x)
3219	{
3220	if (strcmp (s1: gfc_current_intrinsic, s2: "short") == 0
3221	|| strcmp (s1: gfc_current_intrinsic, s2: "long") == 0)
3222	{
3223	gfc_error ("%qs intrinsic subprogram at %L has been removed. "
3224	"Use INT intrinsic subprogram.", gfc_current_intrinsic,
3225	&x->where);
3226	return false;
3227	}
3228
3229	/* BOZ is dealt within simplify_int*. */
3230	if (x->ts.type == BT_BOZ)
3231	return true;
3232
3233	if (!numeric_check (e: x, n: 0))
3234	return false;
3235
3236	return true;
3237	}
3238
3239	bool
3240	gfc_check_ishft (gfc_expr *i, gfc_expr *shift)
3241	{
3242	if (!type_check (e: i, n: 0, type: BT_INTEGER)
3243	|| !type_check (e: shift, n: 1, type: BT_INTEGER))
3244	return false;
3245
3246	if (!less_than_bitsize1 (arg1: "I", expr1: i, NULL, expr2: shift, or_equal: true))
3247	return false;
3248
3249	return true;
3250	}
3251
3252
3253	bool
3254	gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size)
3255	{
3256	if (!type_check (e: i, n: 0, type: BT_INTEGER)
3257	|| !type_check (e: shift, n: 1, type: BT_INTEGER))
3258	return false;
3259
3260	if (size != NULL)
3261	{
3262	int i2, i3;
3263
3264	if (!type_check (e: size, n: 2, type: BT_INTEGER))
3265	return false;
3266
3267	if (!less_than_bitsize1 (arg1: "I", expr1: i, arg2: "SIZE", expr2: size, or_equal: true))
3268	return false;
3269
3270	if (size->expr_type == EXPR_CONSTANT)
3271	{
3272	gfc_extract_int (size, &i3);
3273	if (i3 <= 0)
3274	{
3275	gfc_error ("SIZE at %L must be positive", &size->where);
3276	return false;
3277	}
3278
3279	if (shift->expr_type == EXPR_CONSTANT)
3280	{
3281	gfc_extract_int (shift, &i2);
3282	if (i2 < 0)
3283	i2 = -i2;
3284
3285	if (i2 > i3)
3286	{
3287	gfc_error ("The absolute value of SHIFT at %L must be less "
3288	"than or equal to SIZE at %L", &shift->where,
3289	&size->where);
3290	return false;
3291	}
3292	}
3293	}
3294	}
3295	else if (!less_than_bitsize1 (arg1: "I", expr1: i, NULL, expr2: shift, or_equal: true))
3296	return false;
3297
3298	return true;
3299	}
3300
3301
3302	bool
3303	gfc_check_kill (gfc_expr *pid, gfc_expr *sig)
3304	{
3305	if (!type_check (e: pid, n: 0, type: BT_INTEGER))
3306	return false;
3307
3308	if (!scalar_check (e: pid, n: 0))
3309	return false;
3310
3311	if (!type_check (e: sig, n: 1, type: BT_INTEGER))
3312	return false;
3313
3314	if (!scalar_check (e: sig, n: 1))
3315	return false;
3316
3317	return true;
3318	}
3319
3320
3321	bool
3322	gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status)
3323	{
3324	if (!type_check (e: pid, n: 0, type: BT_INTEGER))
3325	return false;
3326
3327	if (!scalar_check (e: pid, n: 0))
3328	return false;
3329
3330	if (!type_check (e: sig, n: 1, type: BT_INTEGER))
3331	return false;
3332
3333	if (!scalar_check (e: sig, n: 1))
3334	return false;
3335
3336	if (status)
3337	{
3338	if (!type_check (e: status, n: 2, type: BT_INTEGER))
3339	return false;
3340
3341	if (!scalar_check (e: status, n: 2))
3342	return false;
3343
3344	if (status->expr_type != EXPR_VARIABLE)
3345	{
3346	gfc_error ("STATUS at %L shall be an INTENT(OUT) variable",
3347	&status->where);
3348	return false;
3349	}
3350
3351	if (status->expr_type == EXPR_VARIABLE
3352	&& status->symtree && status->symtree->n.sym
3353	&& status->symtree->n.sym->attr.intent == INTENT_IN)
3354	{
3355	gfc_error ("%qs at %L shall be an INTENT(OUT) variable",
3356	status->symtree->name, &status->where);
3357	return false;
3358	}
3359	}
3360
3361	return true;
3362	}
3363
3364
3365	bool
3366	gfc_check_kind (gfc_expr *x)
3367	{
3368	if (gfc_invalid_null_arg (x))
3369	return false;
3370
3371	if (gfc_bt_struct (x->ts.type) || x->ts.type == BT_CLASS)
3372	{
3373	gfc_error ("%qs argument of %qs intrinsic at %L must be of "
3374	"intrinsic type", gfc_current_intrinsic_arg[0]->name,
3375	gfc_current_intrinsic, &x->where);
3376	return false;
3377	}
3378	if (x->ts.type == BT_PROCEDURE)
3379	{
3380	gfc_error ("%qs argument of %qs intrinsic at %L must be a data entity",
3381	gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
3382	&x->where);
3383	return false;
3384	}
3385
3386	return true;
3387	}
3388
3389
3390	bool
3391	gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3392	{
3393	if (!array_check (e: array, n: 0))
3394	return false;
3395
3396	if (!dim_check (dim, n: 1, optional: false))
3397	return false;
3398
3399	if (!dim_rank_check (dim, array, allow_assumed: 1))
3400	return false;
3401
3402	if (!kind_check (k: kind, n: 2, type: BT_INTEGER))
3403	return false;
3404	if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
3405	"with KIND argument at %L",
3406	gfc_current_intrinsic, &kind->where))
3407	return false;
3408
3409	return true;
3410	}
3411
3412
3413	bool
3414	gfc_check_lcobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
3415	{
3416	if (flag_coarray == GFC_FCOARRAY_NONE)
3417	{
3418	gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3419	return false;
3420	}
3421
3422	if (!coarray_check (e: coarray, n: 0))
3423	return false;
3424
3425	if (dim != NULL)
3426	{
3427	if (!dim_check (dim, n: 1, optional: false))
3428	return false;
3429
3430	if (!dim_corank_check (dim, array: coarray))
3431	return false;
3432	}
3433
3434	if (!kind_check (k: kind, n: 2, type: BT_INTEGER))
3435	return false;
3436
3437	return true;
3438	}
3439
3440
3441	bool
3442	gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
3443	{
3444	if (!type_check (e: s, n: 0, type: BT_CHARACTER))
3445	return false;
3446
3447	if (gfc_invalid_null_arg (x: s))
3448	return false;
3449
3450	if (!kind_check (k: kind, n: 1, type: BT_INTEGER))
3451	return false;
3452	if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
3453	"with KIND argument at %L",
3454	gfc_current_intrinsic, &kind->where))
3455	return false;
3456
3457	return true;
3458	}
3459
3460
3461	bool
3462	gfc_check_lge_lgt_lle_llt (gfc_expr *a, gfc_expr *b)
3463	{
3464	if (!type_check (e: a, n: 0, type: BT_CHARACTER))
3465	return false;
3466	if (!kind_value_check (e: a, n: 0, k: gfc_default_character_kind))
3467	return false;
3468
3469	if (!type_check (e: b, n: 1, type: BT_CHARACTER))
3470	return false;
3471	if (!kind_value_check (e: b, n: 1, k: gfc_default_character_kind))
3472	return false;
3473
3474	return true;
3475	}
3476
3477
3478	bool
3479	gfc_check_link (gfc_expr *path1, gfc_expr *path2)
3480	{
3481	if (!type_check (e: path1, n: 0, type: BT_CHARACTER))
3482	return false;
3483	if (!kind_value_check (e: path1, n: 0, k: gfc_default_character_kind))
3484	return false;
3485
3486	if (!type_check (e: path2, n: 1, type: BT_CHARACTER))
3487	return false;
3488	if (!kind_value_check (e: path2, n: 1, k: gfc_default_character_kind))
3489	return false;
3490
3491	return true;
3492	}
3493
3494
3495	bool
3496	gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
3497	{
3498	if (!type_check (e: path1, n: 0, type: BT_CHARACTER))
3499	return false;
3500	if (!kind_value_check (e: path1, n: 0, k: gfc_default_character_kind))
3501	return false;
3502
3503	if (!type_check (e: path2, n: 1, type: BT_CHARACTER))
3504	return false;
3505	if (!kind_value_check (e: path2, n: 0, k: gfc_default_character_kind))
3506	return false;
3507
3508	if (status == NULL)
3509	return true;
3510
3511	if (!type_check (e: status, n: 2, type: BT_INTEGER))
3512	return false;
3513
3514	if (!scalar_check (e: status, n: 2))
3515	return false;
3516
3517	return true;
3518	}
3519
3520
3521	bool
3522	gfc_check_loc (gfc_expr *expr)
3523	{
3524	return variable_check (e: expr, n: 0, allow_proc: true);
3525	}
3526
3527
3528	bool
3529	gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2)
3530	{
3531	if (!type_check (e: path1, n: 0, type: BT_CHARACTER))
3532	return false;
3533	if (!kind_value_check (e: path1, n: 0, k: gfc_default_character_kind))
3534	return false;
3535
3536	if (!type_check (e: path2, n: 1, type: BT_CHARACTER))
3537	return false;
3538	if (!kind_value_check (e: path2, n: 1, k: gfc_default_character_kind))
3539	return false;
3540
3541	return true;
3542	}
3543
3544
3545	bool
3546	gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
3547	{
3548	if (!type_check (e: path1, n: 0, type: BT_CHARACTER))
3549	return false;
3550	if (!kind_value_check (e: path1, n: 0, k: gfc_default_character_kind))
3551	return false;
3552
3553	if (!type_check (e: path2, n: 1, type: BT_CHARACTER))
3554	return false;
3555	if (!kind_value_check (e: path2, n: 1, k: gfc_default_character_kind))
3556	return false;
3557
3558	if (status == NULL)
3559	return true;
3560
3561	if (!type_check (e: status, n: 2, type: BT_INTEGER))
3562	return false;
3563
3564	if (!scalar_check (e: status, n: 2))
3565	return false;
3566
3567	return true;
3568	}
3569
3570
3571	bool
3572	gfc_check_logical (gfc_expr *a, gfc_expr *kind)
3573	{
3574	if (!type_check (e: a, n: 0, type: BT_LOGICAL))
3575	return false;
3576	if (!kind_check (k: kind, n: 1, type: BT_LOGICAL))
3577	return false;
3578
3579	return true;
3580	}
3581
3582
3583	/* Min/max family. */
3584
3585	static bool
3586	min_max_args (gfc_actual_arglist *args)
3587	{
3588	gfc_actual_arglist *arg;
3589	int i, j, nargs, *nlabels, nlabelless;
3590	bool a1 = false, a2 = false;
3591
3592	if (args == NULL || args->next == NULL)
3593	{
3594	gfc_error ("Intrinsic %qs at %L must have at least two arguments",
3595	gfc_current_intrinsic, gfc_current_intrinsic_where);
3596	return false;
3597	}
3598
3599	if (!args->name)
3600	a1 = true;
3601
3602	if (!args->next->name)
3603	a2 = true;
3604
3605	nargs = 0;
3606	for (arg = args; arg; arg = arg->next)
3607	if (arg->name)
3608	nargs++;
3609
3610	if (nargs == 0)
3611	return true;
3612
3613	/* Note: Having a keywordless argument after an "arg=" is checked before. */
3614	nlabelless = 0;
3615	nlabels = XALLOCAVEC (int, nargs);
3616	for (arg = args, i = 0; arg; arg = arg->next, i++)
3617	if (arg->name)
3618	{
3619	int n;
3620	char *endp;
3621
3622	if (arg->name[0] != 'a' || arg->name[1] < '1' || arg->name[1] > '9')
3623	goto unknown;
3624	n = strtol (nptr: &arg->name[1], endptr: &endp, base: 10);
3625	if (endp[0] != '\0')
3626	goto unknown;
3627	if (n <= 0)
3628	goto unknown;
3629	if (n <= nlabelless)
3630	goto duplicate;
3631	nlabels[i] = n;
3632	if (n == 1)
3633	a1 = true;
3634	if (n == 2)
3635	a2 = true;
3636	}
3637	else
3638	nlabelless++;
3639
3640	if (!a1 || !a2)
3641	{
3642	gfc_error ("Missing %qs argument to the %s intrinsic at %L",
3643	!a1 ? "a1" : "a2", gfc_current_intrinsic,
3644	gfc_current_intrinsic_where);
3645	return false;
3646	}
3647
3648	/* Check for duplicates. */
3649	for (i = 0; i < nargs; i++)
3650	for (j = i + 1; j < nargs; j++)
3651	if (nlabels[i] == nlabels[j])
3652	goto duplicate;
3653
3654	return true;
3655
3656	duplicate:
3657	gfc_error ("Duplicate argument %qs at %L to intrinsic %s", arg->name,
3658	&arg->expr->where, gfc_current_intrinsic);
3659	return false;
3660
3661	unknown:
3662	gfc_error ("Unknown argument %qs at %L to intrinsic %s", arg->name,
3663	&arg->expr->where, gfc_current_intrinsic);
3664	return false;
3665	}
3666
3667
3668	static bool
3669	check_rest (bt type, int kind, gfc_actual_arglist *arglist)
3670	{
3671	gfc_actual_arglist *arg, *tmp;
3672	gfc_expr *x;
3673	int m, n;
3674
3675	if (!min_max_args (args: arglist))
3676	return false;
3677
3678	for (arg = arglist, n=1; arg; arg = arg->next, n++)
3679	{
3680	x = arg->expr;
3681	if (x->ts.type != type || x->ts.kind != kind)
3682	{
3683	if (x->ts.type == type)
3684	{
3685	if (x->ts.type == BT_CHARACTER)
3686	{
3687	gfc_error ("Different character kinds at %L", &x->where);
3688	return false;
3689	}
3690	if (!gfc_notify_std (GFC_STD_GNU, "Different type "
3691	"kinds at %L", &x->where))
3692	return false;
3693	}
3694	else
3695	{
3696	gfc_error ("%<a%d%> argument of %qs intrinsic at %L must be "
3697	"%s(%d)", n, gfc_current_intrinsic, &x->where,
3698	gfc_basic_typename (type), kind);
3699	return false;
3700	}
3701	}
3702
3703	for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++)
3704	if (!gfc_check_conformance (tmp->expr, x,
3705	_("arguments 'a%d' and 'a%d' for "
3706	"intrinsic '%s'"), m, n,
3707	gfc_current_intrinsic))
3708	return false;
3709	}
3710
3711	return true;
3712	}
3713
3714
3715	bool
3716	gfc_check_min_max (gfc_actual_arglist *arg)
3717	{
3718	gfc_expr *x;
3719
3720	if (!min_max_args (args: arg))
3721	return false;
3722
3723	x = arg->expr;
3724
3725	if (x->ts.type == BT_CHARACTER)
3726	{
3727	if (!gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
3728	"with CHARACTER argument at %L",
3729	gfc_current_intrinsic, &x->where))
3730	return false;
3731	}
3732	else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
3733	{
3734	gfc_error ("%<a1%> argument of %qs intrinsic at %L must be INTEGER, "
3735	"REAL or CHARACTER", gfc_current_intrinsic, &x->where);
3736	return false;
3737	}
3738
3739	return check_rest (type: x->ts.type, kind: x->ts.kind, arglist: arg);
3740	}
3741
3742
3743	bool
3744	gfc_check_min_max_integer (gfc_actual_arglist *arg)
3745	{
3746	return check_rest (type: BT_INTEGER, kind: gfc_default_integer_kind, arglist: arg);
3747	}
3748
3749
3750	bool
3751	gfc_check_min_max_real (gfc_actual_arglist *arg)
3752	{
3753	return check_rest (type: BT_REAL, kind: gfc_default_real_kind, arglist: arg);
3754	}
3755
3756
3757	bool
3758	gfc_check_min_max_double (gfc_actual_arglist *arg)
3759	{
3760	return check_rest (type: BT_REAL, kind: gfc_default_double_kind, arglist: arg);
3761	}
3762
3763
3764	/* End of min/max family. */
3765
3766	bool
3767	gfc_check_malloc (gfc_expr *size)
3768	{
3769	if (!type_check (e: size, n: 0, type: BT_INTEGER))
3770	return false;
3771
3772	if (!scalar_check (e: size, n: 0))
3773	return false;
3774
3775	return true;
3776	}
3777
3778
3779	bool
3780	gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
3781	{
3782	if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
3783	{
3784	gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
3785	"or LOGICAL", gfc_current_intrinsic_arg[0]->name,
3786	gfc_current_intrinsic, &matrix_a->where);
3787	return false;
3788	}
3789
3790	if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
3791	{
3792	gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
3793	"or LOGICAL", gfc_current_intrinsic_arg[1]->name,
3794	gfc_current_intrinsic, &matrix_b->where);
3795	return false;
3796	}
3797
3798	if ((matrix_a->ts.type == BT_LOGICAL && gfc_numeric_ts (&matrix_b->ts))
3799	|| (gfc_numeric_ts (&matrix_a->ts) && matrix_b->ts.type == BT_LOGICAL))
3800	{
3801	gfc_error ("Argument types of %qs intrinsic at %L must match (%s/%s)",
3802	gfc_current_intrinsic, &matrix_a->where,
3803	gfc_typename(&matrix_a->ts), gfc_typename(&matrix_b->ts));
3804	return false;
3805	}
3806
3807	switch (matrix_a->rank)
3808	{
3809	case 1:
3810	if (!rank_check (e: matrix_b, n: 1, rank: 2))
3811	return false;
3812	/* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
3813	if (!identical_dimen_shape (a: matrix_a, ai: 0, b: matrix_b, bi: 0))
3814	{
3815	gfc_error ("Different shape on dimension 1 for arguments %qs "
3816	"and %qs at %L for intrinsic matmul",
3817	gfc_current_intrinsic_arg[0]->name,
3818	gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
3819	return false;
3820	}
3821	break;
3822
3823	case 2:
3824	if (matrix_b->rank != 2)
3825	{
3826	if (!rank_check (e: matrix_b, n: 1, rank: 1))
3827	return false;
3828	}
3829	/* matrix_b has rank 1 or 2 here. Common check for the cases
3830	- matrix_a has shape (n,m) and matrix_b has shape (m, k)
3831	- matrix_a has shape (n,m) and matrix_b has shape (m). */
3832	if (!identical_dimen_shape (a: matrix_a, ai: 1, b: matrix_b, bi: 0))
3833	{
3834	gfc_error ("Different shape on dimension 2 for argument %qs and "
3835	"dimension 1 for argument %qs at %L for intrinsic "
3836	"matmul", gfc_current_intrinsic_arg[0]->name,
3837	gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
3838	return false;
3839	}
3840	break;
3841
3842	default:
3843	gfc_error ("%qs argument of %qs intrinsic at %L must be of rank "
3844	"1 or 2", gfc_current_intrinsic_arg[0]->name,
3845	gfc_current_intrinsic, &matrix_a->where);
3846	return false;
3847	}
3848
3849	return true;
3850	}
3851
3852
3853	/* Whoever came up with this interface was probably on something.
3854	The possibilities for the occupation of the second and third
3855	parameters are:
3856
3857	Arg #2 Arg #3
3858	NULL NULL
3859	DIM NULL
3860	MASK NULL
3861	NULL MASK minloc(array, mask=m)
3862	DIM MASK
3863
3864	I.e. in the case of minloc(array,mask), mask will be in the second
3865	position of the argument list and we'll have to fix that up. Also,
3866	add the BACK argument if that isn't present. */
3867
3868	bool
3869	gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
3870	{
3871	gfc_expr *a, *m, *d, *k, *b;
3872
3873	a = ap->expr;
3874	if (!int_or_real_or_char_check_f2003 (e: a, n: 0) || !array_check (e: a, n: 0))
3875	return false;
3876
3877	d = ap->next->expr;
3878	m = ap->next->next->expr;
3879	k = ap->next->next->next->expr;
3880	b = ap->next->next->next->next->expr;
3881
3882	if (b)
3883	{
3884	if (!type_check (e: b, n: 4, type: BT_LOGICAL) || !scalar_check (e: b,n: 4))
3885	return false;
3886	}
3887	else
3888	{
3889	b = gfc_get_logical_expr (gfc_logical_4_kind, NULL, 0);
3890	ap->next->next->next->next->expr = b;
3891	ap->next->next->next->next->name = gfc_get_string ("back");
3892	}
3893
3894	if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
3895	&& ap->next->name == NULL)
3896	{
3897	m = d;
3898	d = NULL;
3899	ap->next->expr = NULL;
3900	ap->next->next->expr = m;
3901	}
3902
3903	if (!dim_check (dim: d, n: 1, optional: false))
3904	return false;
3905
3906	if (!dim_rank_check (dim: d, array: a, allow_assumed: 0))
3907	return false;
3908
3909	if (m != NULL && !type_check (e: m, n: 2, type: BT_LOGICAL))
3910	return false;
3911
3912	if (m != NULL
3913	&& !gfc_check_conformance (a, m,
3914	_("arguments '%s' and '%s' for intrinsic %s"),
3915	gfc_current_intrinsic_arg[0]->name,
3916	gfc_current_intrinsic_arg[2]->name,
3917	gfc_current_intrinsic))
3918	return false;
3919
3920	if (!kind_check (k, n: 1, type: BT_INTEGER))
3921	return false;
3922
3923	return true;
3924	}
3925
3926	/* Check function for findloc. Mostly like gfc_check_minloc_maxloc
3927	above, with the additional "value" argument. */
3928
3929	bool
3930	gfc_check_findloc (gfc_actual_arglist *ap)
3931	{
3932	gfc_expr *a, *v, *m, *d, *k, *b;
3933	bool a1, v1;
3934
3935	a = ap->expr;
3936	if (!intrinsic_type_check (e: a, n: 0) || !array_check (e: a, n: 0))
3937	return false;
3938
3939	v = ap->next->expr;
3940	if (!intrinsic_type_check (e: v, n: 1) || !scalar_check (e: v,n: 1))
3941	return false;
3942
3943	/* Check if the type are both logical. */
3944	a1 = a->ts.type == BT_LOGICAL;
3945	v1 = v->ts.type == BT_LOGICAL;
3946	if ((a1 && !v1) || (!a1 && v1))
3947	goto incompat;
3948
3949	/* Check if the type are both character. */
3950	a1 = a->ts.type == BT_CHARACTER;
3951	v1 = v->ts.type == BT_CHARACTER;
3952	if ((a1 && !v1) || (!a1 && v1))
3953	goto incompat;
3954
3955	/* Check the kind of the characters argument match. */
3956	if (a1 && v1 && a->ts.kind != v->ts.kind)
3957	goto incompat;
3958
3959	d = ap->next->next->expr;
3960	m = ap->next->next->next->expr;
3961	k = ap->next->next->next->next->expr;
3962	b = ap->next->next->next->next->next->expr;
3963
3964	if (b)
3965	{
3966	if (!type_check (e: b, n: 5, type: BT_LOGICAL) || !scalar_check (e: b,n: 4))
3967	return false;
3968	}
3969	else
3970	{
3971	b = gfc_get_logical_expr (gfc_logical_4_kind, NULL, 0);
3972	ap->next->next->next->next->next->expr = b;
3973	ap->next->next->next->next->next->name = gfc_get_string ("back");
3974	}
3975
3976	if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
3977	&& ap->next->name == NULL)
3978	{
3979	m = d;
3980	d = NULL;
3981	ap->next->next->expr = NULL;
3982	ap->next->next->next->expr = m;
3983	}
3984
3985	if (!dim_check (dim: d, n: 2, optional: false))
3986	return false;
3987
3988	if (!dim_rank_check (dim: d, array: a, allow_assumed: 0))
3989	return false;
3990
3991	if (m != NULL && !type_check (e: m, n: 3, type: BT_LOGICAL))
3992	return false;
3993
3994	if (m != NULL
3995	&& !gfc_check_conformance (a, m,
3996	_("arguments '%s' and '%s' for intrinsic %s"),
3997	gfc_current_intrinsic_arg[0]->name,
3998	gfc_current_intrinsic_arg[3]->name,
3999	gfc_current_intrinsic))
4000	return false;
4001
4002	if (!kind_check (k, n: 1, type: BT_INTEGER))
4003	return false;
4004
4005	return true;
4006
4007	incompat:
4008	gfc_error ("Argument %qs of %qs intrinsic at %L must be in type "
4009	"conformance to argument %qs at %L",
4010	gfc_current_intrinsic_arg[0]->name,
4011	gfc_current_intrinsic, &a->where,
4012	gfc_current_intrinsic_arg[1]->name, &v->where);
4013	return false;
4014	}
4015
4016
4017	/* Similar to minloc/maxloc, the argument list might need to be
4018	reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
4019	difference is that MINLOC/MAXLOC take an additional KIND argument.
4020	The possibilities are:
4021
4022	Arg #2 Arg #3
4023	NULL NULL
4024	DIM NULL
4025	MASK NULL
4026	NULL MASK minval(array, mask=m)
4027	DIM MASK
4028
4029	I.e. in the case of minval(array,mask), mask will be in the second
4030	position of the argument list and we'll have to fix that up. */
4031
4032	static bool
4033	check_reduction (gfc_actual_arglist *ap)
4034	{
4035	gfc_expr *a, *m, *d;
4036
4037	a = ap->expr;
4038	d = ap->next->expr;
4039	m = ap->next->next->expr;
4040
4041	if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
4042	&& ap->next->name == NULL)
4043	{
4044	m = d;
4045	d = NULL;
4046	ap->next->expr = NULL;
4047	ap->next->next->expr = m;
4048	}
4049
4050	if (!dim_check (dim: d, n: 1, optional: false))
4051	return false;
4052
4053	if (!dim_rank_check (dim: d, array: a, allow_assumed: 0))
4054	return false;
4055
4056	if (m != NULL && !type_check (e: m, n: 2, type: BT_LOGICAL))
4057	return false;
4058
4059	if (m != NULL
4060	&& !gfc_check_conformance (a, m,
4061	_("arguments '%s' and '%s' for intrinsic %s"),
4062	gfc_current_intrinsic_arg[0]->name,
4063	gfc_current_intrinsic_arg[2]->name,
4064	gfc_current_intrinsic))
4065	return false;
4066
4067	return true;
4068	}
4069
4070
4071	bool
4072	gfc_check_minval_maxval (gfc_actual_arglist *ap)
4073	{
4074	if (!int_or_real_or_char_check_f2003 (e: ap->expr, n: 0)
4075	|| !array_check (e: ap->expr, n: 0))
4076	return false;
4077
4078	return check_reduction (ap);
4079	}
4080
4081
4082	bool
4083	gfc_check_product_sum (gfc_actual_arglist *ap)
4084	{
4085	if (!numeric_check (e: ap->expr, n: 0)
4086	|| !array_check (e: ap->expr, n: 0))
4087	return false;
4088
4089	return check_reduction (ap);
4090	}
4091
4092
4093	/* For IANY, IALL and IPARITY. */
4094
4095	bool
4096	gfc_check_mask (gfc_expr *i, gfc_expr *kind)
4097	{
4098	int k;
4099
4100	if (!type_check (e: i, n: 0, type: BT_INTEGER))
4101	return false;
4102
4103	if (!nonnegative_check (arg: "I", expr: i))
4104	return false;
4105
4106	if (!kind_check (k: kind, n: 1, type: BT_INTEGER))
4107	return false;
4108
4109	if (kind)
4110	gfc_extract_int (kind, &k);
4111	else
4112	k = gfc_default_integer_kind;
4113
4114	if (!less_than_bitsizekind (arg: "I", expr: i, k))
4115	return false;
4116
4117	return true;
4118	}
4119
4120
4121	bool
4122	gfc_check_transf_bit_intrins (gfc_actual_arglist *ap)
4123	{
4124	if (ap->expr->ts.type != BT_INTEGER)
4125	{
4126	gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
4127	gfc_current_intrinsic_arg[0]->name,
4128	gfc_current_intrinsic, &ap->expr->where);
4129	return false;
4130	}
4131
4132	if (!array_check (e: ap->expr, n: 0))
4133	return false;
4134
4135	return check_reduction (ap);
4136	}
4137
4138
4139	bool
4140	gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
4141	{
4142	if (gfc_invalid_null_arg (x: tsource))
4143	return false;
4144
4145	if (gfc_invalid_null_arg (x: fsource))
4146	return false;
4147
4148	if (!same_type_check (e: tsource, n: 0, f: fsource, m: 1))
4149	return false;
4150
4151	if (!type_check (e: mask, n: 2, type: BT_LOGICAL))
4152	return false;
4153
4154	if (tsource->ts.type == BT_CHARACTER)
4155	return gfc_check_same_strlen (a: tsource, b: fsource, name: "MERGE intrinsic");
4156
4157	return true;
4158	}
4159
4160
4161	bool
4162	gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask)
4163	{
4164	/* i and j cannot both be BOZ literal constants. */
4165	if (!boz_args_check (i, j))
4166	return false;
4167
4168	/* If i is BOZ and j is integer, convert i to type of j. */
4169	if (i->ts.type == BT_BOZ && j->ts.type == BT_INTEGER
4170	&& !gfc_boz2int (x: i, kind: j->ts.kind))
4171	return false;
4172
4173	/* If j is BOZ and i is integer, convert j to type of i. */
4174	if (j->ts.type == BT_BOZ && i->ts.type == BT_INTEGER
4175	&& !gfc_boz2int (x: j, kind: i->ts.kind))
4176	return false;
4177
4178	if (!type_check (e: i, n: 0, type: BT_INTEGER))
4179	return false;
4180
4181	if (!type_check (e: j, n: 1, type: BT_INTEGER))
4182	return false;
4183
4184	if (!same_type_check (e: i, n: 0, f: j, m: 1))
4185	return false;
4186
4187	if (mask->ts.type == BT_BOZ && !gfc_boz2int(x: mask, kind: i->ts.kind))
4188	return false;
4189
4190	if (!type_check (e: mask, n: 2, type: BT_INTEGER))
4191	return false;
4192
4193	if (!same_type_check (e: i, n: 0, f: mask, m: 2))
4194	return false;
4195
4196	return true;
4197	}
4198
4199
4200	bool
4201	gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
4202	{
4203	if (!variable_check (e: from, n: 0, allow_proc: false))
4204	return false;
4205	if (!allocatable_check (e: from, n: 0))
4206	return false;
4207	if (gfc_is_coindexed (from))
4208	{
4209	gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be "
4210	"coindexed", &from->where);
4211	return false;
4212	}
4213
4214	if (!variable_check (e: to, n: 1, allow_proc: false))
4215	return false;
4216	if (!allocatable_check (e: to, n: 1))
4217	return false;
4218	if (gfc_is_coindexed (to))
4219	{
4220	gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be "
4221	"coindexed", &to->where);
4222	return false;
4223	}
4224
4225	if (from->ts.type == BT_CLASS && to->ts.type == BT_DERIVED)
4226	{
4227	gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
4228	"polymorphic if FROM is polymorphic",
4229	&to->where);
4230	return false;
4231	}
4232
4233	if (!same_type_check (e: to, n: 1, f: from, m: 0))
4234	return false;
4235
4236	if (to->rank != from->rank)
4237	{
4238	gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
4239	"must have the same rank %d/%d", &to->where, from->rank,
4240	to->rank);
4241	return false;
4242	}
4243
4244	/* IR F08/0040; cf. 12-006A. */
4245	if (gfc_get_corank (to) != gfc_get_corank (from))
4246	{
4247	gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
4248	"must have the same corank %d/%d", &to->where,
4249	gfc_get_corank (from), gfc_get_corank (to));
4250	return false;
4251	}
4252
4253	/* This is based losely on F2003 12.4.1.7. It is intended to prevent
4254	the likes of to = sym->cmp1->cmp2 and from = sym->cmp1, where cmp1
4255	and cmp2 are allocatable. After the allocation is transferred,
4256	the 'to' chain is broken by the nullification of the 'from'. A bit
4257	of reflection reveals that this can only occur for derived types
4258	with recursive allocatable components. */
4259	if (to->expr_type == EXPR_VARIABLE && from->expr_type == EXPR_VARIABLE
4260	&& !strcmp (s1: to->symtree->n.sym->name, s2: from->symtree->n.sym->name))
4261	{
4262	gfc_ref *to_ref, *from_ref;
4263	to_ref = to->ref;
4264	from_ref = from->ref;
4265	bool aliasing = true;
4266
4267	for (; from_ref && to_ref;
4268	from_ref = from_ref->next, to_ref = to_ref->next)
4269	{
4270	if (to_ref->type != from->ref->type)
4271	aliasing = false;
4272	else if (to_ref->type == REF_ARRAY
4273	&& to_ref->u.ar.type != AR_FULL
4274	&& from_ref->u.ar.type != AR_FULL)
4275	/* Play safe; assume sections and elements are different. */
4276	aliasing = false;
4277	else if (to_ref->type == REF_COMPONENT
4278	&& to_ref->u.c.component != from_ref->u.c.component)
4279	aliasing = false;
4280
4281	if (!aliasing)
4282	break;
4283	}
4284
4285	if (aliasing)
4286	{
4287	gfc_error ("The FROM and TO arguments at %L violate aliasing "
4288	"restrictions (F2003 12.4.1.7)", &to->where);
4289	return false;
4290	}
4291	}
4292
4293	/* CLASS arguments: Make sure the vtab of from is present. */
4294	if (to->ts.type == BT_CLASS && !UNLIMITED_POLY (from))
4295	gfc_find_vtab (&from->ts);
4296
4297	return true;
4298	}
4299
4300
4301	bool
4302	gfc_check_nearest (gfc_expr *x, gfc_expr *s)
4303	{
4304	if (!type_check (e: x, n: 0, type: BT_REAL))
4305	return false;
4306
4307	if (!type_check (e: s, n: 1, type: BT_REAL))
4308	return false;
4309
4310	if (s->expr_type == EXPR_CONSTANT)
4311	{
4312	if (mpfr_sgn (s->value.real) == 0)
4313	{
4314	gfc_error ("Argument %<S%> of NEAREST at %L shall not be zero",
4315	&s->where);
4316	return false;
4317	}
4318	}
4319
4320	return true;
4321	}
4322
4323
4324	bool
4325	gfc_check_new_line (gfc_expr *a)
4326	{
4327	if (!type_check (e: a, n: 0, type: BT_CHARACTER))
4328	return false;
4329
4330	return true;
4331	}
4332
4333
4334	bool
4335	gfc_check_norm2 (gfc_expr *array, gfc_expr *dim)
4336	{
4337	if (!type_check (e: array, n: 0, type: BT_REAL))
4338	return false;
4339
4340	if (!array_check (e: array, n: 0))
4341	return false;
4342
4343	if (!dim_check (dim, n: 1, optional: false))
4344	return false;
4345
4346	if (!dim_rank_check (dim, array, allow_assumed: false))
4347	return false;
4348
4349	return true;
4350	}
4351
4352	bool
4353	gfc_check_null (gfc_expr *mold)
4354	{
4355	symbol_attribute attr;
4356
4357	if (mold == NULL)
4358	return true;
4359
4360	if (!variable_check (e: mold, n: 0, allow_proc: true))
4361	return false;
4362
4363	attr = gfc_variable_attr (mold, NULL);
4364
4365	if (!attr.pointer && !attr.proc_pointer && !attr.allocatable)
4366	{
4367	gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER, "
4368	"ALLOCATABLE or procedure pointer",
4369	gfc_current_intrinsic_arg[0]->name,
4370	gfc_current_intrinsic, &mold->where);
4371	return false;
4372	}
4373
4374	if (attr.allocatable
4375	&& !gfc_notify_std (GFC_STD_F2003, "NULL intrinsic with "
4376	"allocatable MOLD at %L", &mold->where))
4377	return false;
4378
4379	/* F2008, C1242. */
4380	if (gfc_is_coindexed (mold))
4381	{
4382	gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
4383	"coindexed", gfc_current_intrinsic_arg[0]->name,
4384	gfc_current_intrinsic, &mold->where);
4385	return false;
4386	}
4387
4388	return true;
4389	}
4390
4391
4392	bool
4393	gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
4394	{
4395	if (!array_check (e: array, n: 0))
4396	return false;
4397
4398	if (!type_check (e: mask, n: 1, type: BT_LOGICAL))
4399	return false;
4400
4401	if (!gfc_check_conformance (array, mask,
4402	_("arguments '%s' and '%s' for intrinsic '%s'"),
4403	gfc_current_intrinsic_arg[0]->name,
4404	gfc_current_intrinsic_arg[1]->name,
4405	gfc_current_intrinsic))
4406	return false;
4407
4408	if (vector != NULL)
4409	{
4410	mpz_t array_size, vector_size;
4411	bool have_array_size, have_vector_size;
4412
4413	if (!same_type_check (e: array, n: 0, f: vector, m: 2))
4414	return false;
4415
4416	if (!rank_check (e: vector, n: 2, rank: 1))
4417	return false;
4418
4419	/* VECTOR requires at least as many elements as MASK
4420	has .TRUE. values. */
4421	have_array_size = gfc_array_size(array, &array_size);
4422	have_vector_size = gfc_array_size(vector, &vector_size);
4423
4424	if (have_vector_size
4425	&& (mask->expr_type == EXPR_ARRAY
4426	|| (mask->expr_type == EXPR_CONSTANT
4427	&& have_array_size)))
4428	{
4429	int mask_true_values = 0;
4430
4431	if (mask->expr_type == EXPR_ARRAY)
4432	{
4433	gfc_constructor *mask_ctor;
4434	mask_ctor = gfc_constructor_first (base: mask->value.constructor);
4435	while (mask_ctor)
4436	{
4437	if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
4438	{
4439	mask_true_values = 0;
4440	break;
4441	}
4442
4443	if (mask_ctor->expr->value.logical)
4444	mask_true_values++;
4445
4446	mask_ctor = gfc_constructor_next (ctor: mask_ctor);
4447	}
4448	}
4449	else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical)
4450	mask_true_values = mpz_get_si (array_size);
4451
4452	if (mpz_get_si (vector_size) < mask_true_values)
4453	{
4454	gfc_error ("%qs argument of %qs intrinsic at %L must "
4455	"provide at least as many elements as there "
4456	"are .TRUE. values in %qs (%ld/%d)",
4457	gfc_current_intrinsic_arg[2]->name,
4458	gfc_current_intrinsic, &vector->where,
4459	gfc_current_intrinsic_arg[1]->name,
4460	mpz_get_si (vector_size), mask_true_values);
4461	return false;
4462	}
4463	}
4464
4465	if (have_array_size)
4466	mpz_clear (array_size);
4467	if (have_vector_size)
4468	mpz_clear (vector_size);
4469	}
4470
4471	return true;
4472	}
4473
4474
4475	bool
4476	gfc_check_parity (gfc_expr *mask, gfc_expr *dim)
4477	{
4478	if (!type_check (e: mask, n: 0, type: BT_LOGICAL))
4479	return false;
4480
4481	if (!array_check (e: mask, n: 0))
4482	return false;
4483
4484	if (!dim_check (dim, n: 1, optional: false))
4485	return false;
4486
4487	if (!dim_rank_check (dim, array: mask, allow_assumed: false))
4488	return false;
4489
4490	return true;
4491	}
4492
4493
4494	bool
4495	gfc_check_precision (gfc_expr *x)
4496	{
4497	if (!real_or_complex_check (e: x, n: 0))
4498	return false;
4499
4500	return true;
4501	}
4502
4503
4504	bool
4505	gfc_check_present (gfc_expr *a)
4506	{
4507	gfc_symbol *sym;
4508
4509	if (!variable_check (e: a, n: 0, allow_proc: true))
4510	return false;
4511
4512	sym = a->symtree->n.sym;
4513	if (!sym->attr.dummy)
4514	{
4515	gfc_error ("%qs argument of %qs intrinsic at %L must be of a "
4516	"dummy variable", gfc_current_intrinsic_arg[0]->name,
4517	gfc_current_intrinsic, &a->where);
4518	return false;
4519	}
4520
4521	/* For CLASS, the optional attribute might be set at either location. */
4522	if ((sym->ts.type != BT_CLASS || !CLASS_DATA (sym)->attr.optional)
4523	&& !sym->attr.optional)
4524	{
4525	gfc_error ("%qs argument of %qs intrinsic at %L must be of "
4526	"an OPTIONAL dummy variable",
4527	gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
4528	&a->where);
4529	return false;
4530	}
4531
4532	/* 13.14.82 PRESENT(A)
4533	......
4534	Argument. A shall be the name of an optional dummy argument that is
4535	accessible in the subprogram in which the PRESENT function reference
4536	appears... */
4537
4538	if (a->ref != NULL
4539	&& !(a->ref->next == NULL && a->ref->type == REF_ARRAY
4540	&& (a->ref->u.ar.type == AR_FULL
4541	|| (a->ref->u.ar.type == AR_ELEMENT
4542	&& a->ref->u.ar.as->rank == 0))))
4543	{
4544	gfc_error ("%qs argument of %qs intrinsic at %L must not be a "
4545	"subobject of %qs", gfc_current_intrinsic_arg[0]->name,
4546	gfc_current_intrinsic, &a->where, sym->name);
4547	return false;
4548	}
4549
4550	return true;
4551	}
4552
4553
4554	bool
4555	gfc_check_radix (gfc_expr *x)
4556	{
4557	if (!int_or_real_check (e: x, n: 0))
4558	return false;
4559
4560	return true;
4561	}
4562
4563
4564	bool
4565	gfc_check_range (gfc_expr *x)
4566	{
4567	if (!numeric_check (e: x, n: 0))
4568	return false;
4569
4570	return true;
4571	}
4572
4573
4574	bool
4575	gfc_check_rank (gfc_expr *a)
4576	{
4577	/* Any data object is allowed; a "data object" is a "constant (4.1.3),
4578	variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
4579
4580	bool is_variable = true;
4581
4582	/* Functions returning pointers are regarded as variable, cf. F2008, R602. */
4583	if (a->expr_type == EXPR_FUNCTION)
4584	is_variable = a->value.function.esym
4585	? a->value.function.esym->result->attr.pointer
4586	: a->symtree->n.sym->result->attr.pointer;
4587
4588	if (a->expr_type == EXPR_OP
4589	|| a->expr_type == EXPR_NULL
4590	|| a->expr_type == EXPR_COMPCALL
4591	|| a->expr_type == EXPR_PPC
4592	|| a->ts.type == BT_PROCEDURE
4593	|| !is_variable)
4594	{
4595	gfc_error ("The argument of the RANK intrinsic at %L must be a data "
4596	"object", &a->where);
4597	return false;
4598	}
4599
4600	return true;
4601	}
4602
4603
4604	bool
4605	gfc_check_real (gfc_expr *a, gfc_expr *kind)
4606	{
4607	if (!kind_check (k: kind, n: 1, type: BT_REAL))
4608	return false;
4609
4610	/* BOZ is dealt with in gfc_simplify_real. */
4611	if (a->ts.type == BT_BOZ)
4612	return true;
4613
4614	if (!numeric_check (e: a, n: 0))
4615	return false;
4616
4617	return true;
4618	}
4619
4620
4621	bool
4622	gfc_check_rename (gfc_expr *path1, gfc_expr *path2)
4623	{
4624	if (!type_check (e: path1, n: 0, type: BT_CHARACTER))
4625	return false;
4626	if (!kind_value_check (e: path1, n: 0, k: gfc_default_character_kind))
4627	return false;
4628
4629	if (!type_check (e: path2, n: 1, type: BT_CHARACTER))
4630	return false;
4631	if (!kind_value_check (e: path2, n: 1, k: gfc_default_character_kind))
4632	return false;
4633
4634	return true;
4635	}
4636
4637
4638	bool
4639	gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
4640	{
4641	if (!type_check (e: path1, n: 0, type: BT_CHARACTER))
4642	return false;
4643	if (!kind_value_check (e: path1, n: 0, k: gfc_default_character_kind))
4644	return false;
4645
4646	if (!type_check (e: path2, n: 1, type: BT_CHARACTER))
4647	return false;
4648	if (!kind_value_check (e: path2, n: 1, k: gfc_default_character_kind))
4649	return false;
4650
4651	if (status == NULL)
4652	return true;
4653
4654	if (!type_check (e: status, n: 2, type: BT_INTEGER))
4655	return false;
4656
4657	if (!scalar_check (e: status, n: 2))
4658	return false;
4659
4660	return true;
4661	}
4662
4663
4664	bool
4665	gfc_check_repeat (gfc_expr *x, gfc_expr *y)
4666	{
4667	if (!type_check (e: x, n: 0, type: BT_CHARACTER))
4668	return false;
4669
4670	if (!scalar_check (e: x, n: 0))
4671	return false;
4672
4673	if (!type_check (e: y, n: 0, type: BT_INTEGER))
4674	return false;
4675
4676	if (!scalar_check (e: y, n: 1))
4677	return false;
4678
4679	return true;
4680	}
4681
4682
4683	bool
4684	gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
4685	gfc_expr *pad, gfc_expr *order)
4686	{
4687	mpz_t size;
4688	mpz_t nelems;
4689	int shape_size;
4690	bool shape_is_const;
4691
4692	if (!array_check (e: source, n: 0))
4693	return false;
4694
4695	if (!rank_check (e: shape, n: 1, rank: 1))
4696	return false;
4697
4698	if (!type_check (e: shape, n: 1, type: BT_INTEGER))
4699	return false;
4700
4701	if (!gfc_array_size (shape, &size))
4702	{
4703	gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L must be an "
4704	"array of constant size", &shape->where);
4705	return false;
4706	}
4707
4708	shape_size = mpz_get_ui (gmp_z: size);
4709	mpz_clear (size);
4710
4711	if (shape_size <= 0)
4712	{
4713	gfc_error ("%qs argument of %qs intrinsic at %L is empty",
4714	gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
4715	&shape->where);
4716	return false;
4717	}
4718	else if (shape_size > GFC_MAX_DIMENSIONS)
4719	{
4720	gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L has more "
4721	"than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
4722	return false;
4723	}
4724
4725	gfc_simplify_expr (shape, 0);
4726	shape_is_const = gfc_is_constant_array_expr (shape);
4727
4728	if (shape->expr_type == EXPR_ARRAY && shape_is_const)
4729	{
4730	gfc_expr *e;
4731	int i, extent;
4732	for (i = 0; i < shape_size; ++i)
4733	{
4734	e = gfc_constructor_lookup_expr (base: shape->value.constructor, n: i);
4735	if (e == NULL)
4736	break;
4737	if (e->expr_type != EXPR_CONSTANT)
4738	continue;
4739
4740	gfc_extract_int (e, &extent);
4741	if (extent < 0)
4742	{
4743	gfc_error ("%qs argument of %qs intrinsic at %L has "
4744	"negative element (%d)",
4745	gfc_current_intrinsic_arg[1]->name,
4746	gfc_current_intrinsic, &shape->where, extent);
4747	return false;
4748	}
4749	}
4750	}
4751
4752	if (pad != NULL)
4753	{
4754	if (!same_type_check (e: source, n: 0, f: pad, m: 2))
4755	return false;
4756
4757	if (!array_check (e: pad, n: 2))
4758	return false;
4759	}
4760
4761	if (order != NULL)
4762	{
4763	if (!array_check (e: order, n: 3))
4764	return false;
4765
4766	if (!type_check (e: order, n: 3, type: BT_INTEGER))
4767	return false;
4768
4769	if (order->expr_type == EXPR_ARRAY && gfc_is_constant_array_expr (order))
4770	{
4771	int i, order_size, dim, perm[GFC_MAX_DIMENSIONS];
4772	gfc_expr *e;
4773
4774	for (i = 0; i < GFC_MAX_DIMENSIONS; ++i)
4775	perm[i] = 0;
4776
4777	gfc_array_size (order, &size);
4778	order_size = mpz_get_ui (gmp_z: size);
4779	mpz_clear (size);
4780
4781	if (order_size != shape_size)
4782	{
4783	gfc_error ("%qs argument of %qs intrinsic at %L "
4784	"has wrong number of elements (%d/%d)",
4785	gfc_current_intrinsic_arg[3]->name,
4786	gfc_current_intrinsic, &order->where,
4787	order_size, shape_size);
4788	return false;
4789	}
4790
4791	for (i = 1; i <= order_size; ++i)
4792	{
4793	e = gfc_constructor_lookup_expr (base: order->value.constructor, n: i-1);
4794	if (e->expr_type != EXPR_CONSTANT)
4795	continue;
4796
4797	gfc_extract_int (e, &dim);
4798
4799	if (dim < 1 || dim > order_size)
4800	{
4801	gfc_error ("%qs argument of %qs intrinsic at %L "
4802	"has out-of-range dimension (%d)",
4803	gfc_current_intrinsic_arg[3]->name,
4804	gfc_current_intrinsic, &e->where, dim);
4805	return false;
4806	}
4807
4808	if (perm[dim-1] != 0)
4809	{
4810	gfc_error ("%qs argument of %qs intrinsic at %L has "
4811	"invalid permutation of dimensions (dimension "
4812	"%qd duplicated)",
4813	gfc_current_intrinsic_arg[3]->name,
4814	gfc_current_intrinsic, &e->where, dim);
4815	return false;
4816	}
4817
4818	perm[dim-1] = 1;
4819	}
4820	}
4821	}
4822
4823	if (pad == NULL && shape->expr_type == EXPR_ARRAY && shape_is_const
4824	&& !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as
4825	&& source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
4826	{
4827	/* Check the match in size between source and destination. */
4828	if (gfc_array_size (source, &nelems))
4829	{
4830	gfc_constructor *c;
4831	bool test;
4832
4833
4834	mpz_init_set_ui (size, 1);
4835	for (c = gfc_constructor_first (base: shape->value.constructor);
4836	c; c = gfc_constructor_next (ctor: c))
4837	mpz_mul (size, size, c->expr->value.integer);
4838
4839	test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
4840	mpz_clear (nelems);
4841	mpz_clear (size);
4842
4843	if (test)
4844	{
4845	gfc_error ("Without padding, there are not enough elements "
4846	"in the intrinsic RESHAPE source at %L to match "
4847	"the shape", &source->where);
4848	return false;
4849	}
4850	}
4851	}
4852
4853	return true;
4854	}
4855
4856
4857	bool
4858	gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
4859	{
4860	if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS)
4861	{
4862	gfc_error ("%qs argument of %qs intrinsic at %L "
4863	"cannot be of type %s",
4864	gfc_current_intrinsic_arg[0]->name,
4865	gfc_current_intrinsic,
4866	&a->where, gfc_typename (a));
4867	return false;
4868	}
4869
4870	if (!(gfc_type_is_extensible (a->ts.u.derived) || UNLIMITED_POLY (a)))
4871	{
4872	gfc_error ("%qs argument of %qs intrinsic at %L "
4873	"must be of an extensible type",
4874	gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
4875	&a->where);
4876	return false;
4877	}
4878
4879	if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS)
4880	{
4881	gfc_error ("%qs argument of %qs intrinsic at %L "
4882	"cannot be of type %s",
4883	gfc_current_intrinsic_arg[0]->name,
4884	gfc_current_intrinsic,
4885	&b->where, gfc_typename (b));
4886	return false;
4887	}
4888
4889	if (!(gfc_type_is_extensible (b->ts.u.derived) || UNLIMITED_POLY (b)))
4890	{
4891	gfc_error ("%qs argument of %qs intrinsic at %L "
4892	"must be of an extensible type",
4893	gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
4894	&b->where);
4895	return false;
4896	}
4897
4898	return true;
4899	}
4900
4901
4902	bool
4903	gfc_check_scale (gfc_expr *x, gfc_expr *i)
4904	{
4905	if (!type_check (e: x, n: 0, type: BT_REAL))
4906	return false;
4907
4908	if (!type_check (e: i, n: 1, type: BT_INTEGER))
4909	return false;
4910
4911	return true;
4912	}
4913
4914
4915	bool
4916	gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
4917	{
4918	if (!type_check (e: x, n: 0, type: BT_CHARACTER))
4919	return false;
4920
4921	if (!type_check (e: y, n: 1, type: BT_CHARACTER))
4922	return false;
4923
4924	if (z != NULL && !type_check (e: z, n: 2, type: BT_LOGICAL))
4925	return false;
4926
4927	if (!kind_check (k: kind, n: 3, type: BT_INTEGER))
4928	return false;
4929	if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
4930	"with KIND argument at %L",
4931	gfc_current_intrinsic, &kind->where))
4932	return false;
4933
4934	if (!same_type_check (e: x, n: 0, f: y, m: 1))
4935	return false;
4936
4937	return true;
4938	}
4939
4940
4941	bool
4942	gfc_check_secnds (gfc_expr *r)
4943	{
4944	if (!type_check (e: r, n: 0, type: BT_REAL))
4945	return false;
4946
4947	if (!kind_value_check (e: r, n: 0, k: 4))
4948	return false;
4949
4950	if (!scalar_check (e: r, n: 0))
4951	return false;
4952
4953	return true;
4954	}
4955
4956
4957	bool
4958	gfc_check_selected_char_kind (gfc_expr *name)
4959	{
4960	if (!type_check (e: name, n: 0, type: BT_CHARACTER))
4961	return false;
4962
4963	if (!kind_value_check (e: name, n: 0, k: gfc_default_character_kind))
4964	return false;
4965
4966	if (!scalar_check (e: name, n: 0))
4967	return false;
4968
4969	return true;
4970	}
4971
4972
4973	bool
4974	gfc_check_selected_int_kind (gfc_expr *r)
4975	{
4976	if (!type_check (e: r, n: 0, type: BT_INTEGER))
4977	return false;
4978
4979	if (!scalar_check (e: r, n: 0))
4980	return false;
4981
4982	return true;
4983	}
4984
4985
4986	bool
4987	gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix)
4988	{
4989	if (p == NULL && r == NULL
4990	&& !gfc_notify_std (GFC_STD_F2008, "SELECTED_REAL_KIND with"
4991	" neither %<P%> nor %<R%> argument at %L",
4992	gfc_current_intrinsic_where))
4993	return false;
4994
4995	if (p)
4996	{
4997	if (!type_check (e: p, n: 0, type: BT_INTEGER))
4998	return false;
4999
5000	if (!scalar_check (e: p, n: 0))
5001	return false;
5002	}
5003
5004	if (r)
5005	{
5006	if (!type_check (e: r, n: 1, type: BT_INTEGER))
5007	return false;
5008
5009	if (!scalar_check (e: r, n: 1))
5010	return false;
5011	}
5012
5013	if (radix)
5014	{
5015	if (!type_check (e: radix, n: 1, type: BT_INTEGER))
5016	return false;
5017
5018	if (!scalar_check (e: radix, n: 1))
5019	return false;
5020
5021	if (!gfc_notify_std (GFC_STD_F2008, "%qs intrinsic with "
5022	"RADIX argument at %L", gfc_current_intrinsic,
5023	&radix->where))
5024	return false;
5025	}
5026
5027	return true;
5028	}
5029
5030
5031	bool
5032	gfc_check_set_exponent (gfc_expr *x, gfc_expr *i)
5033	{
5034	if (!type_check (e: x, n: 0, type: BT_REAL))
5035	return false;
5036
5037	if (!type_check (e: i, n: 1, type: BT_INTEGER))
5038	return false;
5039
5040	return true;
5041	}
5042
5043
5044	bool
5045	gfc_check_shape (gfc_expr *source, gfc_expr *kind)
5046	{
5047	gfc_array_ref *ar;
5048
5049	if (gfc_invalid_null_arg (x: source))
5050	return false;
5051
5052	if (!kind_check (k: kind, n: 1, type: BT_INTEGER))
5053	return false;
5054	if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
5055	"with KIND argument at %L",
5056	gfc_current_intrinsic, &kind->where))
5057	return false;
5058
5059	if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
5060	return true;
5061
5062	if (source->ref == NULL)
5063	return false;
5064
5065	ar = gfc_find_array_ref (source);
5066
5067	if (ar->as && ar->as->type == AS_ASSUMED_SIZE && ar->type == AR_FULL)
5068	{
5069	gfc_error ("%<source%> argument of %<shape%> intrinsic at %L must not be "
5070	"an assumed size array", &source->where);
5071	return false;
5072	}
5073
5074	return true;
5075	}
5076
5077
5078	bool
5079	gfc_check_shift (gfc_expr *i, gfc_expr *shift)
5080	{
5081	if (!type_check (e: i, n: 0, type: BT_INTEGER))
5082	return false;
5083
5084	if (!type_check (e: shift, n: 0, type: BT_INTEGER))
5085	return false;
5086
5087	if (!nonnegative_check (arg: "SHIFT", expr: shift))
5088	return false;
5089
5090	if (!less_than_bitsize1 (arg1: "I", expr1: i, arg2: "SHIFT", expr2: shift, or_equal: true))
5091	return false;
5092
5093	return true;
5094	}
5095
5096
5097	bool
5098	gfc_check_sign (gfc_expr *a, gfc_expr *b)
5099	{
5100	if (!int_or_real_check (e: a, n: 0))
5101	return false;
5102
5103	if (!same_type_check (e: a, n: 0, f: b, m: 1))
5104	return false;
5105
5106	return true;
5107	}
5108
5109
5110	bool
5111	gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
5112	{
5113	if (!array_check (e: array, n: 0))
5114	return false;
5115
5116	if (!dim_check (dim, n: 1, optional: true))
5117	return false;
5118
5119	if (!dim_rank_check (dim, array, allow_assumed: 0))
5120	return false;
5121
5122	if (!kind_check (k: kind, n: 2, type: BT_INTEGER))
5123	return false;
5124	if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
5125	"with KIND argument at %L",
5126	gfc_current_intrinsic, &kind->where))
5127	return false;
5128
5129
5130	return true;
5131	}
5132
5133
5134	bool
5135	gfc_check_sizeof (gfc_expr *arg)
5136	{
5137	if (gfc_invalid_null_arg (x: arg))
5138	return false;
5139
5140	if (arg->ts.type == BT_PROCEDURE)
5141	{
5142	gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure",
5143	gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
5144	&arg->where);
5145	return false;
5146	}
5147
5148	if (illegal_boz_arg (x: arg))
5149	return false;
5150
5151	/* TYPE(*) is acceptable if and only if it uses an array descriptor. */
5152	if (arg->ts.type == BT_ASSUMED
5153	&& (arg->symtree->n.sym->as == NULL
5154	|| (arg->symtree->n.sym->as->type != AS_ASSUMED_SHAPE
5155	&& arg->symtree->n.sym->as->type != AS_DEFERRED
5156	&& arg->symtree->n.sym->as->type != AS_ASSUMED_RANK)))
5157	{
5158	gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
5159	gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
5160	&arg->where);
5161	return false;
5162	}
5163
5164	if (arg->rank && arg->expr_type == EXPR_VARIABLE
5165	&& arg->symtree->n.sym->as != NULL
5166	&& arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref
5167	&& arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL)
5168	{
5169	gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
5170	"assumed-size array", gfc_current_intrinsic_arg[0]->name,
5171	gfc_current_intrinsic, &arg->where);
5172	return false;
5173	}
5174
5175	return true;
5176	}
5177
5178
5179	/* Check whether an expression is interoperable. When returning false,
5180	msg is set to a string telling why the expression is not interoperable,
5181	otherwise, it is set to NULL. The msg string can be used in diagnostics.
5182	If c_loc is true, character with len > 1 are allowed (cf. Fortran
5183	2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
5184	arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
5185	are permitted. */
5186
5187	static bool
5188	is_c_interoperable (gfc_expr *expr, const char **msg, bool c_loc, bool c_f_ptr)
5189	{
5190	*msg = NULL;
5191
5192	if (expr->expr_type == EXPR_NULL)
5193	{
5194	*msg = "NULL() is not interoperable";
5195	return false;
5196	}
5197
5198	if (expr->ts.type == BT_BOZ)
5199	{
5200	*msg = "BOZ literal constant";
5201	return false;
5202	}
5203
5204	if (expr->ts.type == BT_CLASS)
5205	{
5206	*msg = "Expression is polymorphic";
5207	return false;
5208	}
5209
5210	if (expr->ts.type == BT_DERIVED && !expr->ts.u.derived->attr.is_bind_c
5211	&& !expr->ts.u.derived->ts.is_iso_c)
5212	{
5213	*msg = "Expression is a noninteroperable derived type";
5214	return false;
5215	}
5216
5217	if (expr->ts.type == BT_PROCEDURE)
5218	{
5219	*msg = "Procedure unexpected as argument";
5220	return false;
5221	}
5222
5223	if (gfc_notification_std (GFC_STD_GNU) && expr->ts.type == BT_LOGICAL)
5224	{
5225	int i;
5226	for (i = 0; gfc_logical_kinds[i].kind; i++)
5227	if (gfc_logical_kinds[i].kind == expr->ts.kind)
5228	return true;
5229	*msg = "Extension to use a non-C_Bool-kind LOGICAL";
5230	return false;
5231	}
5232
5233	if (gfc_notification_std (GFC_STD_GNU) && expr->ts.type == BT_CHARACTER
5234	&& expr->ts.kind != 1)
5235	{
5236	*msg = "Extension to use a non-C_CHAR-kind CHARACTER";
5237	return false;
5238	}
5239
5240	if (expr->ts.type == BT_CHARACTER) {
5241	if (expr->ts.deferred)
5242	{
5243	/* TS 29113 allows deferred-length strings as dummy arguments,
5244	but it is not an interoperable type. */
5245	*msg = "Expression shall not be a deferred-length string";
5246	return false;
5247	}
5248
5249	if (expr->ts.u.cl && expr->ts.u.cl->length
5250	&& !gfc_simplify_expr (expr->ts.u.cl->length, 0))
5251	gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
5252
5253	if (!c_loc
5254	&& expr->ts.u.cl
5255	&& !gfc_length_one_character_type_p (ts: &expr->ts))
5256	{
5257	*msg = "Type shall have a character length of 1";
5258	return false;
5259	}
5260	}
5261
5262	/* Note: The following checks are about interoperatable variables, Fortran
5263	15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more
5264	is allowed, e.g. assumed-shape arrays with TS 29113. */
5265
5266	if (gfc_is_coarray (expr))
5267	{
5268	*msg = "Coarrays are not interoperable";
5269	return false;
5270	}
5271
5272	if (!c_loc && expr->rank > 0 && expr->expr_type != EXPR_ARRAY)
5273	{
5274	gfc_array_ref *ar = gfc_find_array_ref (expr);
5275	if (ar->type != AR_FULL)
5276	{
5277	*msg = "Only whole-arrays are interoperable";
5278	return false;
5279	}
5280	if (!c_f_ptr && ar->as->type != AS_EXPLICIT
5281	&& ar->as->type != AS_ASSUMED_SIZE)
5282	{
5283	*msg = "Only explicit-size and assumed-size arrays are interoperable";
5284	return false;
5285	}
5286	}
5287
5288	return true;
5289	}
5290
5291
5292	bool
5293	gfc_check_c_sizeof (gfc_expr *arg)
5294	{
5295	const char *msg;
5296
5297	if (!is_c_interoperable (expr: arg, msg: &msg, c_loc: false, c_f_ptr: false))
5298	{
5299	gfc_error ("%qs argument of %qs intrinsic at %L must be an "
5300	"interoperable data entity: %s",
5301	gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
5302	&arg->where, msg);
5303	return false;
5304	}
5305
5306	if (arg->ts.type == BT_ASSUMED)
5307	{
5308	gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
5309	"TYPE(*)",
5310	gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
5311	&arg->where);
5312	return false;
5313	}
5314
5315	if (arg->rank && arg->expr_type == EXPR_VARIABLE
5316	&& arg->symtree->n.sym->as != NULL
5317	&& arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref
5318	&& arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL)
5319	{
5320	gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
5321	"assumed-size array", gfc_current_intrinsic_arg[0]->name,
5322	gfc_current_intrinsic, &arg->where);
5323	return false;
5324	}
5325
5326	return true;
5327	}
5328
5329
5330	bool
5331	gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2)
5332	{
5333	if (c_ptr_1->ts.type != BT_DERIVED
5334	|| c_ptr_1->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
5335	|| (c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR
5336	&& c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR))
5337	{
5338	gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
5339	"type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1->where);
5340	return false;
5341	}
5342
5343	if (!scalar_check (e: c_ptr_1, n: 0))
5344	return false;
5345
5346	if (c_ptr_2
5347	&& (c_ptr_2->ts.type != BT_DERIVED
5348	|| c_ptr_2->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
5349	|| (c_ptr_1->ts.u.derived->intmod_sym_id
5350	!= c_ptr_2->ts.u.derived->intmod_sym_id)))
5351	{
5352	gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
5353	"same type as C_PTR_1: %s instead of %s", &c_ptr_1->where,
5354	gfc_typename (&c_ptr_1->ts),
5355	gfc_typename (&c_ptr_2->ts));
5356	return false;
5357	}
5358
5359	if (c_ptr_2 && !scalar_check (e: c_ptr_2, n: 1))
5360	return false;
5361
5362	return true;
5363	}
5364
5365
5366	bool
5367	gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape)
5368	{
5369	symbol_attribute attr;
5370	const char *msg;
5371
5372	if (cptr->ts.type != BT_DERIVED
5373	|| cptr->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
5374	|| cptr->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR)
5375	{
5376	gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
5377	"type TYPE(C_PTR)", &cptr->where);
5378	return false;
5379	}
5380
5381	if (!scalar_check (e: cptr, n: 0))
5382	return false;
5383
5384	attr = gfc_expr_attr (fptr);
5385
5386	if (!attr.pointer)
5387	{
5388	gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
5389	&fptr->where);
5390	return false;
5391	}
5392
5393	if (fptr->ts.type == BT_CLASS)
5394	{
5395	gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
5396	&fptr->where);
5397	return false;
5398	}
5399
5400	if (gfc_is_coindexed (fptr))
5401	{
5402	gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
5403	"coindexed", &fptr->where);
5404	return false;
5405	}
5406
5407	if (fptr->rank == 0 && shape)
5408	{
5409	gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
5410	"FPTR", &fptr->where);
5411	return false;
5412	}
5413	else if (fptr->rank && !shape)
5414	{
5415	gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
5416	"FPTR at %L", &fptr->where);
5417	return false;
5418	}
5419
5420	if (shape && !rank_check (e: shape, n: 2, rank: 1))
5421	return false;
5422
5423	if (shape && !type_check (e: shape, n: 2, type: BT_INTEGER))
5424	return false;
5425
5426	if (shape)
5427	{
5428	mpz_t size;
5429	if (gfc_array_size (shape, &size))
5430	{
5431	if (mpz_cmp_ui (size, fptr->rank) != 0)
5432	{
5433	mpz_clear (size);
5434	gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
5435	"size as the RANK of FPTR", &shape->where);
5436	return false;
5437	}
5438	mpz_clear (size);
5439	}
5440	}
5441
5442	if (fptr->ts.type == BT_CLASS)
5443	{
5444	gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr->where);
5445	return false;
5446	}
5447
5448	if (fptr->rank > 0 && !is_c_interoperable (expr: fptr, msg: &msg, c_loc: false, c_f_ptr: true))
5449	return gfc_notify_std (GFC_STD_F2018, "Noninteroperable array FPTR "
5450	"at %L to C_F_POINTER: %s", &fptr->where, msg);
5451
5452	return true;
5453	}
5454
5455
5456	bool
5457	gfc_check_c_f_procpointer (gfc_expr *cptr, gfc_expr *fptr)
5458	{
5459	symbol_attribute attr;
5460
5461	if (cptr->ts.type != BT_DERIVED
5462	|| cptr->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
5463	|| cptr->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR)
5464	{
5465	gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
5466	"type TYPE(C_FUNPTR)", &cptr->where);
5467	return false;
5468	}
5469
5470	if (!scalar_check (e: cptr, n: 0))
5471	return false;
5472
5473	attr = gfc_expr_attr (fptr);
5474
5475	if (!attr.proc_pointer)
5476	{
5477	gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
5478	"pointer", &fptr->where);
5479	return false;
5480	}
5481
5482	if (gfc_is_coindexed (fptr))
5483	{
5484	gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
5485	"coindexed", &fptr->where);
5486	return false;
5487	}
5488
5489	if (!attr.is_bind_c)
5490	return gfc_notify_std (GFC_STD_F2018, "Noninteroperable procedure "
5491	"pointer at %L to C_F_PROCPOINTER", &fptr->where);
5492
5493	return true;
5494	}
5495
5496
5497	bool
5498	gfc_check_c_funloc (gfc_expr *x)
5499	{
5500	symbol_attribute attr;
5501
5502	if (gfc_is_coindexed (x))
5503	{
5504	gfc_error ("Argument X at %L to C_FUNLOC shall not be "
5505	"coindexed", &x->where);
5506	return false;
5507	}
5508
5509	attr = gfc_expr_attr (x);
5510
5511	if (attr.function && !attr.proc_pointer && x->expr_type == EXPR_VARIABLE
5512	&& x->symtree->n.sym == x->symtree->n.sym->result)
5513	for (gfc_namespace *ns = gfc_current_ns; ns; ns = ns->parent)
5514	if (x->symtree->n.sym == ns->proc_name)
5515	{
5516	gfc_error ("Function result %qs at %L is invalid as X argument "
5517	"to C_FUNLOC", x->symtree->n.sym->name, &x->where);
5518	return false;
5519	}
5520
5521	if (attr.flavor != FL_PROCEDURE)
5522	{
5523	gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
5524	"or a procedure pointer", &x->where);
5525	return false;
5526	}
5527
5528	if (!attr.is_bind_c)
5529	return gfc_notify_std (GFC_STD_F2018, "Noninteroperable procedure "
5530	"at %L to C_FUNLOC", &x->where);
5531	return true;
5532	}
5533
5534
5535	bool
5536	gfc_check_c_loc (gfc_expr *x)
5537	{
5538	symbol_attribute attr;
5539	const char *msg;
5540
5541	if (gfc_is_coindexed (x))
5542	{
5543	gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x->where);
5544	return false;
5545	}
5546
5547	if (x->ts.type == BT_CLASS)
5548	{
5549	gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
5550	&x->where);
5551	return false;
5552	}
5553
5554	attr = gfc_expr_attr (x);
5555
5556	if (!attr.pointer
5557	&& (x->expr_type != EXPR_VARIABLE || !attr.target
5558	|| attr.flavor == FL_PARAMETER))
5559	{
5560	gfc_error ("Argument X at %L to C_LOC shall have either "
5561	"the POINTER or the TARGET attribute", &x->where);
5562	return false;
5563	}
5564
5565	if (x->ts.type == BT_CHARACTER
5566	&& gfc_var_strlen (a: x) == 0)
5567	{
5568	gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
5569	"string", &x->where);
5570	return false;
5571	}
5572
5573	if (!is_c_interoperable (expr: x, msg: &msg, c_loc: true, c_f_ptr: false))
5574	{
5575	if (x->ts.type == BT_CLASS)
5576	{
5577	gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
5578	&x->where);
5579	return false;
5580	}
5581
5582	if (x->rank
5583	&& !gfc_notify_std (GFC_STD_F2018,
5584	"Noninteroperable array at %L as"
5585	" argument to C_LOC: %s", &x->where, msg))
5586	return false;
5587	}
5588	else if (x->rank > 0 && gfc_notification_std (GFC_STD_F2008))
5589	{
5590	gfc_array_ref *ar = gfc_find_array_ref (x);
5591
5592	if (ar->as->type != AS_EXPLICIT && ar->as->type != AS_ASSUMED_SIZE
5593	&& !attr.allocatable
5594	&& !gfc_notify_std (GFC_STD_F2008,
5595	"Array of interoperable type at %L "
5596	"to C_LOC which is nonallocatable and neither "
5597	"assumed size nor explicit size", &x->where))
5598	return false;
5599	else if (ar->type != AR_FULL
5600	&& !gfc_notify_std (GFC_STD_F2008, "Array section at %L "
5601	"to C_LOC", &x->where))
5602	return false;
5603	}
5604
5605	return true;
5606	}
5607
5608
5609	bool
5610	gfc_check_sleep_sub (gfc_expr *seconds)
5611	{
5612	if (!type_check (e: seconds, n: 0, type: BT_INTEGER))
5613	return false;
5614
5615	if (!scalar_check (e: seconds, n: 0))
5616	return false;
5617
5618	return true;
5619	}
5620
5621	bool
5622	gfc_check_sngl (gfc_expr *a)
5623	{
5624	if (!type_check (e: a, n: 0, type: BT_REAL))
5625	return false;
5626
5627	if ((a->ts.kind != gfc_default_double_kind)
5628	&& !gfc_notify_std (GFC_STD_GNU, "non double precision "
5629	"REAL argument to %s intrinsic at %L",
5630	gfc_current_intrinsic, &a->where))
5631	return false;
5632
5633	return true;
5634	}
5635
5636	bool
5637	gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
5638	{
5639	if (gfc_invalid_null_arg (x: source))
5640	return false;
5641
5642	if (source->rank >= GFC_MAX_DIMENSIONS)
5643	{
5644	gfc_error ("%qs argument of %qs intrinsic at %L must be less "
5645	"than rank %d", gfc_current_intrinsic_arg[0]->name,
5646	gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
5647
5648	return false;
5649	}
5650
5651	if (dim == NULL)
5652	return false;
5653
5654	if (!dim_check (dim, n: 1, optional: false))
5655	return false;
5656
5657	/* dim_rank_check() does not apply here. */
5658	if (dim
5659	&& dim->expr_type == EXPR_CONSTANT
5660	&& (mpz_cmp_ui (dim->value.integer, 1) < 0
5661	|| mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0))
5662	{
5663	gfc_error ("%qs argument of %qs intrinsic at %L is not a valid "
5664	"dimension index", gfc_current_intrinsic_arg[1]->name,
5665	gfc_current_intrinsic, &dim->where);
5666	return false;
5667	}
5668
5669	if (!type_check (e: ncopies, n: 2, type: BT_INTEGER))
5670	return false;
5671
5672	if (!scalar_check (e: ncopies, n: 2))
5673	return false;
5674
5675	return true;
5676	}
5677
5678
5679	/* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
5680	functions). */
5681
5682	bool
5683	arg_strlen_is_zero (gfc_expr *c, int n)
5684	{
5685	if (gfc_var_strlen (a: c) == 0)
5686	{
5687	gfc_error ("%qs argument of %qs intrinsic at %L must have "
5688	"length at least 1", gfc_current_intrinsic_arg[n]->name,
5689	gfc_current_intrinsic, &c->where);
5690	return true;
5691	}
5692	return false;
5693	}
5694
5695	bool
5696	gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
5697	{
5698	if (!type_check (e: unit, n: 0, type: BT_INTEGER))
5699	return false;
5700
5701	if (!scalar_check (e: unit, n: 0))
5702	return false;
5703
5704	if (!type_check (e: c, n: 1, type: BT_CHARACTER))
5705	return false;
5706	if (!kind_value_check (e: c, n: 1, k: gfc_default_character_kind))
5707	return false;
5708	if (strcmp (s1: gfc_current_intrinsic, s2: "fgetc") == 0
5709	&& !variable_check (e: c, n: 1, allow_proc: false))
5710	return false;
5711	if (arg_strlen_is_zero (c, n: 1))
5712	return false;
5713
5714	if (status == NULL)
5715	return true;
5716
5717	if (!type_check (e: status, n: 2, type: BT_INTEGER)
5718	|| !kind_value_check (e: status, n: 2, k: gfc_default_integer_kind)
5719	|| !scalar_check (e: status, n: 2)
5720	|| !variable_check (e: status, n: 2, allow_proc: false))
5721	return false;
5722
5723	return true;
5724	}
5725
5726
5727	bool
5728	gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c)
5729	{
5730	return gfc_check_fgetputc_sub (unit, c, NULL);
5731	}
5732
5733
5734	bool
5735	gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
5736	{
5737	if (!type_check (e: c, n: 0, type: BT_CHARACTER))
5738	return false;
5739	if (!kind_value_check (e: c, n: 0, k: gfc_default_character_kind))
5740	return false;
5741	if (strcmp (s1: gfc_current_intrinsic, s2: "fget") == 0
5742	&& !variable_check (e: c, n: 0, allow_proc: false))
5743	return false;
5744	if (arg_strlen_is_zero (c, n: 0))
5745	return false;
5746
5747	if (status == NULL)
5748	return true;
5749
5750	if (!type_check (e: status, n: 1, type: BT_INTEGER)
5751	|| !kind_value_check (e: status, n: 1, k: gfc_default_integer_kind)
5752	|| !scalar_check (e: status, n: 1)
5753	|| !variable_check (e: status, n: 1, allow_proc: false))
5754	return false;
5755
5756	return true;
5757	}
5758
5759
5760	bool
5761	gfc_check_fgetput (gfc_expr *c)
5762	{
5763	return gfc_check_fgetput_sub (c, NULL);
5764	}
5765
5766
5767	bool
5768	gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status)
5769	{
5770	if (!type_check (e: unit, n: 0, type: BT_INTEGER))
5771	return false;
5772
5773	if (!scalar_check (e: unit, n: 0))
5774	return false;
5775
5776	if (!type_check (e: offset, n: 1, type: BT_INTEGER))
5777	return false;
5778
5779	if (!scalar_check (e: offset, n: 1))
5780	return false;
5781
5782	if (!type_check (e: whence, n: 2, type: BT_INTEGER))
5783	return false;
5784
5785	if (!scalar_check (e: whence, n: 2))
5786	return false;
5787
5788	if (status == NULL)
5789	return true;
5790
5791	if (!type_check (e: status, n: 3, type: BT_INTEGER))
5792	return false;
5793
5794	if (!kind_value_check (e: status, n: 3, k: 4))
5795	return false;
5796
5797	if (!scalar_check (e: status, n: 3))
5798	return false;
5799
5800	return true;
5801	}
5802
5803
5804
5805	bool
5806	gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
5807	{
5808	if (!type_check (e: unit, n: 0, type: BT_INTEGER))
5809	return false;
5810
5811	if (!scalar_check (e: unit, n: 0))
5812	return false;
5813
5814	if (!type_check (e: array, n: 1, type: BT_INTEGER)
5815	|| !kind_value_check (e: unit, n: 0, k: gfc_default_integer_kind))
5816	return false;
5817
5818	if (!array_check (e: array, n: 1))
5819	return false;
5820
5821	return true;
5822	}
5823
5824
5825	bool
5826	gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
5827	{
5828	if (!type_check (e: unit, n: 0, type: BT_INTEGER))
5829	return false;
5830
5831	if (!scalar_check (e: unit, n: 0))
5832	return false;
5833
5834	if (!type_check (e: array, n: 1, type: BT_INTEGER)
5835	|| !kind_value_check (e: array, n: 1, k: gfc_default_integer_kind))
5836	return false;
5837
5838	if (!array_check (e: array, n: 1))
5839	return false;
5840
5841	if (status == NULL)
5842	return true;
5843
5844	if (!type_check (e: status, n: 2, type: BT_INTEGER)
5845	|| !kind_value_check (e: status, n: 2, k: gfc_default_integer_kind))
5846	return false;
5847
5848	if (!scalar_check (e: status, n: 2))
5849	return false;
5850
5851	return true;
5852	}
5853
5854
5855	bool
5856	gfc_check_ftell (gfc_expr *unit)
5857	{
5858	if (!type_check (e: unit, n: 0, type: BT_INTEGER))
5859	return false;
5860
5861	if (!scalar_check (e: unit, n: 0))
5862	return false;
5863
5864	return true;
5865	}
5866
5867
5868	bool
5869	gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
5870	{
5871	if (!type_check (e: unit, n: 0, type: BT_INTEGER))
5872	return false;
5873
5874	if (!scalar_check (e: unit, n: 0))
5875	return false;
5876
5877	if (!type_check (e: offset, n: 1, type: BT_INTEGER))
5878	return false;
5879
5880	if (!scalar_check (e: offset, n: 1))
5881	return false;
5882
5883	return true;
5884	}
5885
5886
5887	bool
5888	gfc_check_stat (gfc_expr *name, gfc_expr *array)
5889	{
5890	if (!type_check (e: name, n: 0, type: BT_CHARACTER))
5891	return false;
5892	if (!kind_value_check (e: name, n: 0, k: gfc_default_character_kind))
5893	return false;
5894
5895	if (!type_check (e: array, n: 1, type: BT_INTEGER)
5896	|| !kind_value_check (e: array, n: 1, k: gfc_default_integer_kind))
5897	return false;
5898
5899	if (!array_check (e: array, n: 1))
5900	return false;
5901
5902	return true;
5903	}
5904
5905
5906	bool
5907	gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
5908	{
5909	if (!type_check (e: name, n: 0, type: BT_CHARACTER))
5910	return false;
5911	if (!kind_value_check (e: name, n: 0, k: gfc_default_character_kind))
5912	return false;
5913
5914	if (!type_check (e: array, n: 1, type: BT_INTEGER)
5915	|| !kind_value_check (e: array, n: 1, k: gfc_default_integer_kind))
5916	return false;
5917
5918	if (!array_check (e: array, n: 1))
5919	return false;
5920
5921	if (status == NULL)
5922	return true;
5923
5924	if (!type_check (e: status, n: 2, type: BT_INTEGER)
5925	|| !kind_value_check (e: array, n: 1, k: gfc_default_integer_kind))
5926	return false;
5927
5928	if (!scalar_check (e: status, n: 2))
5929	return false;
5930
5931	return true;
5932	}
5933
5934
5935	bool
5936	gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub)
5937	{
5938	mpz_t nelems;
5939
5940	if (flag_coarray == GFC_FCOARRAY_NONE)
5941	{
5942	gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5943	return false;
5944	}
5945
5946	if (!coarray_check (e: coarray, n: 0))
5947	return false;
5948
5949	if (sub->rank != 1)
5950	{
5951	gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
5952	gfc_current_intrinsic_arg[1]->name, &sub->where);
5953	return false;
5954	}
5955
5956	if (sub->ts.type != BT_INTEGER)
5957	{
5958	gfc_error ("Type of %s argument of IMAGE_INDEX at %L shall be INTEGER",
5959	gfc_current_intrinsic_arg[1]->name, &sub->where);
5960	return false;
5961	}
5962
5963	if (gfc_array_size (sub, &nelems))
5964	{
5965	int corank = gfc_get_corank (coarray);
5966
5967	if (mpz_cmp_ui (nelems, corank) != 0)
5968	{
5969	gfc_error ("The number of array elements of the SUB argument to "
5970	"IMAGE_INDEX at %L shall be %d (corank) not %d",
5971	&sub->where, corank, (int) mpz_get_si (nelems));
5972	mpz_clear (nelems);
5973	return false;
5974	}
5975	mpz_clear (nelems);
5976	}
5977
5978	return true;
5979	}
5980
5981
5982	bool
5983	gfc_check_num_images (gfc_expr *distance, gfc_expr *failed)
5984	{
5985	if (flag_coarray == GFC_FCOARRAY_NONE)
5986	{
5987	gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5988	return false;
5989	}
5990
5991	if (distance)
5992	{
5993	if (!type_check (e: distance, n: 0, type: BT_INTEGER))
5994	return false;
5995
5996	if (!nonnegative_check (arg: "DISTANCE", expr: distance))
5997	return false;
5998
5999	if (!scalar_check (e: distance, n: 0))
6000	return false;
6001
6002	if (!gfc_notify_std (GFC_STD_F2018, "DISTANCE= argument to "
6003	"NUM_IMAGES at %L", &distance->where))
6004	return false;
6005	}
6006
6007	if (failed)
6008	{
6009	if (!type_check (e: failed, n: 1, type: BT_LOGICAL))
6010	return false;
6011
6012	if (!scalar_check (e: failed, n: 1))
6013	return false;
6014
6015	if (!gfc_notify_std (GFC_STD_F2018, "FAILED= argument to "
6016	"NUM_IMAGES at %L", &failed->where))
6017	return false;
6018	}
6019
6020	return true;
6021	}
6022
6023
6024	bool
6025	gfc_check_team_number (gfc_expr *team)
6026	{
6027	if (flag_coarray == GFC_FCOARRAY_NONE)
6028	{
6029	gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6030	return false;
6031	}
6032
6033	if (team)
6034	{
6035	if (team->ts.type != BT_DERIVED
6036	|| team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
6037	|| team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE)
6038	{
6039	gfc_error ("TEAM argument at %L to the intrinsic TEAM_NUMBER "
6040	"shall be of type TEAM_TYPE", &team->where);
6041	return false;
6042	}
6043	}
6044	else
6045	return true;
6046
6047	return true;
6048	}
6049
6050
6051	bool
6052	gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim, gfc_expr *distance)
6053	{
6054	if (flag_coarray == GFC_FCOARRAY_NONE)
6055	{
6056	gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6057	return false;
6058	}
6059
6060	if (coarray == NULL && dim == NULL && distance == NULL)
6061	return true;
6062
6063	if (dim != NULL && coarray == NULL)
6064	{
6065	gfc_error ("DIM argument without COARRAY argument not allowed for "
6066	"THIS_IMAGE intrinsic at %L", &dim->where);
6067	return false;
6068	}
6069
6070	if (distance && (coarray || dim))
6071	{
6072	gfc_error ("The DISTANCE argument may not be specified together with the "
6073	"COARRAY or DIM argument in intrinsic at %L",
6074	&distance->where);
6075	return false;
6076	}
6077
6078	/* Assume that we have "this_image (distance)". */
6079	if (coarray && !gfc_is_coarray (coarray) && coarray->ts.type == BT_INTEGER)
6080	{
6081	if (dim)
6082	{
6083	gfc_error ("Unexpected DIM argument with noncoarray argument at %L",
6084	&coarray->where);
6085	return false;
6086	}
6087	distance = coarray;
6088	}
6089
6090	if (distance)
6091	{
6092	if (!type_check (e: distance, n: 2, type: BT_INTEGER))
6093	return false;
6094
6095	if (!nonnegative_check (arg: "DISTANCE", expr: distance))
6096	return false;
6097
6098	if (!scalar_check (e: distance, n: 2))
6099	return false;
6100
6101	if (!gfc_notify_std (GFC_STD_F2018, "DISTANCE= argument to "
6102	"THIS_IMAGE at %L", &distance->where))
6103	return false;
6104
6105	return true;
6106	}
6107
6108	if (!coarray_check (e: coarray, n: 0))
6109	return false;
6110
6111	if (dim != NULL)
6112	{
6113	if (!dim_check (dim, n: 1, optional: false))
6114	return false;
6115
6116	if (!dim_corank_check (dim, array: coarray))
6117	return false;
6118	}
6119
6120	return true;
6121	}
6122
6123	/* Calculate the sizes for transfer, used by gfc_check_transfer and also
6124	by gfc_simplify_transfer. Return false if we cannot do so. */
6125
6126	bool
6127	gfc_calculate_transfer_sizes (gfc_expr *source, gfc_expr *mold, gfc_expr *size,
6128	size_t *source_size, size_t *result_size,
6129	size_t *result_length_p)
6130	{
6131	size_t result_elt_size;
6132
6133	if (source->expr_type == EXPR_FUNCTION)
6134	return false;
6135
6136	if (size && size->expr_type != EXPR_CONSTANT)
6137	return false;
6138
6139	/* Calculate the size of the source. */
6140	if (!gfc_target_expr_size (source, source_size))
6141	return false;
6142
6143	/* Determine the size of the element. */
6144	if (!gfc_element_size (mold, &result_elt_size))
6145	return false;
6146
6147	/* If the storage size of SOURCE is greater than zero and MOLD is an array,
6148	* a scalar with the type and type parameters of MOLD shall not have a
6149	* storage size equal to zero.
6150	* If MOLD is a scalar and SIZE is absent, the result is a scalar.
6151	* If MOLD is an array and SIZE is absent, the result is an array and of
6152	* rank one. Its size is as small as possible such that its physical
6153	* representation is not shorter than that of SOURCE.
6154	* If SIZE is present, the result is an array of rank one and size SIZE.
6155	*/
6156	if (result_elt_size == 0 && *source_size > 0
6157	&& (mold->expr_type == EXPR_ARRAY || mold->rank))
6158	{
6159	gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L is an "
6160	"array and shall not have storage size 0 when %<SOURCE%> "
6161	"argument has size greater than 0", &mold->where);
6162	return false;
6163	}
6164
6165	if (result_elt_size == 0 && *source_size == 0 && !size)
6166	{
6167	*result_size = 0;
6168	if (result_length_p)
6169	*result_length_p = 0;
6170	return true;
6171	}
6172
6173	if ((result_elt_size > 0 && (mold->expr_type == EXPR_ARRAY || mold->rank))
6174	|| size)
6175	{
6176	int result_length;
6177
6178	if (size)
6179	result_length = (size_t)mpz_get_ui (gmp_z: size->value.integer);
6180	else
6181	{
6182	result_length = *source_size / result_elt_size;
6183	if (result_length * result_elt_size < *source_size)
6184	result_length += 1;
6185	}
6186
6187	*result_size = result_length * result_elt_size;
6188	if (result_length_p)
6189	*result_length_p = result_length;
6190	}
6191	else
6192	*result_size = result_elt_size;
6193
6194	return true;
6195	}
6196
6197
6198	bool
6199	gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
6200	{
6201	size_t source_size;
6202	size_t result_size;
6203
6204	if (gfc_invalid_null_arg (x: source))
6205	return false;
6206
6207	/* SOURCE shall be a scalar or array of any type. */
6208	if (source->ts.type == BT_PROCEDURE
6209	&& source->symtree->n.sym->attr.subroutine == 1)
6210	{
6211	gfc_error ("%<SOURCE%> argument of %<TRANSFER%> intrinsic at %L "
6212	"must not be a %s", &source->where,
6213	gfc_basic_typename (source->ts.type));
6214	return false;
6215	}
6216
6217	if (source->ts.type == BT_BOZ && illegal_boz_arg (x: source))
6218	return false;
6219
6220	if (mold->ts.type == BT_BOZ && illegal_boz_arg (x: mold))
6221	return false;
6222
6223	if (gfc_invalid_null_arg (x: mold))
6224	return false;
6225
6226	/* MOLD shall be a scalar or array of any type. */
6227	if (mold->ts.type == BT_PROCEDURE
6228	&& mold->symtree->n.sym->attr.subroutine == 1)
6229	{
6230	gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L "
6231	"must not be a %s", &mold->where,
6232	gfc_basic_typename (mold->ts.type));
6233	return false;
6234	}
6235
6236	if (mold->ts.type == BT_HOLLERITH)
6237	{
6238	gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L must not be"
6239	" %s", &mold->where, gfc_basic_typename (BT_HOLLERITH));
6240	return false;
6241	}
6242
6243	/* SIZE (optional) shall be an integer scalar. The corresponding actual
6244	argument shall not be an optional dummy argument. */
6245	if (size != NULL)
6246	{
6247	if (!type_check (e: size, n: 2, type: BT_INTEGER))
6248	{
6249	if (size->ts.type == BT_BOZ)
6250	reset_boz (x: size);
6251	return false;
6252	}
6253
6254	if (!scalar_check (e: size, n: 2))
6255	return false;
6256
6257	if (!nonoptional_check (e: size, n: 2))
6258	return false;
6259	}
6260
6261	if (!warn_surprising)
6262	return true;
6263
6264	/* If we can't calculate the sizes, we cannot check any more.
6265	Return true for that case. */
6266
6267	if (!gfc_calculate_transfer_sizes (source, mold, size, source_size: &source_size,
6268	result_size: &result_size, NULL))
6269	return true;
6270
6271	if (source_size < result_size)
6272	gfc_warning (opt: OPT_Wsurprising,
6273	"Intrinsic TRANSFER at %L has partly undefined result: "
6274	"source size %ld < result size %ld", &source->where,
6275	(long) source_size, (long) result_size);
6276
6277	return true;
6278	}
6279
6280
6281	bool
6282	gfc_check_transpose (gfc_expr *matrix)
6283	{
6284	if (!rank_check (e: matrix, n: 0, rank: 2))
6285	return false;
6286
6287	return true;
6288	}
6289
6290
6291	bool
6292	gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
6293	{
6294	if (!array_check (e: array, n: 0))
6295	return false;
6296
6297	if (!dim_check (dim, n: 1, optional: false))
6298	return false;
6299
6300	if (!dim_rank_check (dim, array, allow_assumed: 0))
6301	return false;
6302
6303	if (!kind_check (k: kind, n: 2, type: BT_INTEGER))
6304	return false;
6305	if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
6306	"with KIND argument at %L",
6307	gfc_current_intrinsic, &kind->where))
6308	return false;
6309
6310	return true;
6311	}
6312
6313
6314	bool
6315	gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
6316	{
6317	if (flag_coarray == GFC_FCOARRAY_NONE)
6318	{
6319	gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6320	return false;
6321	}
6322
6323	if (!coarray_check (e: coarray, n: 0))
6324	return false;
6325
6326	if (dim != NULL)
6327	{
6328	if (!dim_check (dim, n: 1, optional: false))
6329	return false;
6330
6331	if (!dim_corank_check (dim, array: coarray))
6332	return false;
6333	}
6334
6335	if (!kind_check (k: kind, n: 2, type: BT_INTEGER))
6336	return false;
6337
6338	return true;
6339	}
6340
6341
6342	bool
6343	gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
6344	{
6345	mpz_t vector_size;
6346
6347	if (!rank_check (e: vector, n: 0, rank: 1))
6348	return false;
6349
6350	if (!array_check (e: mask, n: 1))
6351	return false;
6352
6353	if (!type_check (e: mask, n: 1, type: BT_LOGICAL))
6354	return false;
6355
6356	if (!same_type_check (e: vector, n: 0, f: field, m: 2))
6357	return false;
6358
6359	gfc_simplify_expr (mask, 0);
6360
6361	if (mask->expr_type == EXPR_ARRAY
6362	&& gfc_array_size (vector, &vector_size))
6363	{
6364	int mask_true_count = 0;
6365	gfc_constructor *mask_ctor;
6366	mask_ctor = gfc_constructor_first (base: mask->value.constructor);
6367	while (mask_ctor)
6368	{
6369	if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
6370	{
6371	mask_true_count = 0;
6372	break;
6373	}
6374
6375	if (mask_ctor->expr->value.logical)
6376	mask_true_count++;
6377
6378	mask_ctor = gfc_constructor_next (ctor: mask_ctor);
6379	}
6380
6381	if (mpz_get_si (vector_size) < mask_true_count)
6382	{
6383	gfc_error ("%qs argument of %qs intrinsic at %L must "
6384	"provide at least as many elements as there "
6385	"are .TRUE. values in %qs (%ld/%d)",
6386	gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
6387	&vector->where, gfc_current_intrinsic_arg[1]->name,
6388	mpz_get_si (vector_size), mask_true_count);
6389	return false;
6390	}
6391
6392	mpz_clear (vector_size);
6393	}
6394
6395	if (mask->rank != field->rank && field->rank != 0)
6396	{
6397	gfc_error ("%qs argument of %qs intrinsic at %L must have "
6398	"the same rank as %qs or be a scalar",
6399	gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
6400	&field->where, gfc_current_intrinsic_arg[1]->name);
6401	return false;
6402	}
6403
6404	if (mask->rank == field->rank)
6405	{
6406	int i;
6407	for (i = 0; i < field->rank; i++)
6408	if (! identical_dimen_shape (a: mask, ai: i, b: field, bi: i))
6409	{
6410	gfc_error ("%qs and %qs arguments of %qs intrinsic at %L "
6411	"must have identical shape.",
6412	gfc_current_intrinsic_arg[2]->name,
6413	gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
6414	&field->where);
6415	}
6416	}
6417
6418	return true;
6419	}
6420
6421
6422	bool
6423	gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
6424	{
6425	if (!type_check (e: x, n: 0, type: BT_CHARACTER))
6426	return false;
6427
6428	if (!same_type_check (e: x, n: 0, f: y, m: 1))
6429	return false;
6430
6431	if (z != NULL && !type_check (e: z, n: 2, type: BT_LOGICAL))
6432	return false;
6433
6434	if (!kind_check (k: kind, n: 3, type: BT_INTEGER))
6435	return false;
6436	if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
6437	"with KIND argument at %L",
6438	gfc_current_intrinsic, &kind->where))
6439	return false;
6440
6441	return true;
6442	}
6443
6444
6445	bool
6446	gfc_check_trim (gfc_expr *x)
6447	{
6448	if (!type_check (e: x, n: 0, type: BT_CHARACTER))
6449	return false;
6450
6451	if (gfc_invalid_null_arg (x))
6452	return false;
6453
6454	if (!scalar_check (e: x, n: 0))
6455	return false;
6456
6457	return true;
6458	}
6459
6460
6461	bool
6462	gfc_check_ttynam (gfc_expr *unit)
6463	{
6464	if (!scalar_check (e: unit, n: 0))
6465	return false;
6466
6467	if (!type_check (e: unit, n: 0, type: BT_INTEGER))
6468	return false;
6469
6470	return true;
6471	}
6472
6473
6474	/************* Check functions for intrinsic subroutines *************/
6475
6476	bool
6477	gfc_check_cpu_time (gfc_expr *time)
6478	{
6479	if (!scalar_check (e: time, n: 0))
6480	return false;
6481
6482	if (!type_check (e: time, n: 0, type: BT_REAL))
6483	return false;
6484
6485	if (!variable_check (e: time, n: 0, allow_proc: false))
6486	return false;
6487
6488	return true;
6489	}
6490
6491
6492	bool
6493	gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
6494	gfc_expr *zone, gfc_expr *values)
6495	{
6496	if (date != NULL)
6497	{
6498	if (!type_check (e: date, n: 0, type: BT_CHARACTER))
6499	return false;
6500	if (!kind_value_check (e: date, n: 0, k: gfc_default_character_kind))
6501	return false;
6502	if (!scalar_check (e: date, n: 0))
6503	return false;
6504	if (!variable_check (e: date, n: 0, allow_proc: false))
6505	return false;
6506	}
6507
6508	if (time != NULL)
6509	{
6510	if (!type_check (e: time, n: 1, type: BT_CHARACTER))
6511	return false;
6512	if (!kind_value_check (e: time, n: 1, k: gfc_default_character_kind))
6513	return false;
6514	if (!scalar_check (e: time, n: 1))
6515	return false;
6516	if (!variable_check (e: time, n: 1, allow_proc: false))
6517	return false;
6518	}
6519
6520	if (zone != NULL)
6521	{
6522	if (!type_check (e: zone, n: 2, type: BT_CHARACTER))
6523	return false;
6524	if (!kind_value_check (e: zone, n: 2, k: gfc_default_character_kind))
6525	return false;
6526	if (!scalar_check (e: zone, n: 2))
6527	return false;
6528	if (!variable_check (e: zone, n: 2, allow_proc: false))
6529	return false;
6530	}
6531
6532	if (values != NULL)
6533	{
6534	if (!type_check (e: values, n: 3, type: BT_INTEGER))
6535	return false;
6536	if (!array_check (e: values, n: 3))
6537	return false;
6538	if (!rank_check (e: values, n: 3, rank: 1))
6539	return false;
6540	if (!variable_check (e: values, n: 3, allow_proc: false))
6541	return false;
6542	}
6543
6544	return true;
6545	}
6546
6547
6548	bool
6549	gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
6550	gfc_expr *to, gfc_expr *topos)
6551	{
6552	if (!type_check (e: from, n: 0, type: BT_INTEGER))
6553	return false;
6554
6555	if (!type_check (e: frompos, n: 1, type: BT_INTEGER))
6556	return false;
6557
6558	if (!type_check (e: len, n: 2, type: BT_INTEGER))
6559	return false;
6560
6561	if (!same_type_check (e: from, n: 0, f: to, m: 3))
6562	return false;
6563
6564	if (!variable_check (e: to, n: 3, allow_proc: false))
6565	return false;
6566
6567	if (!type_check (e: topos, n: 4, type: BT_INTEGER))
6568	return false;
6569
6570	if (!nonnegative_check (arg: "frompos", expr: frompos))
6571	return false;
6572
6573	if (!nonnegative_check (arg: "topos", expr: topos))
6574	return false;
6575
6576	if (!nonnegative_check (arg: "len", expr: len))
6577	return false;
6578
6579	if (!less_than_bitsize2 (arg1: "from", expr1: from, arg2: "frompos", expr2: frompos, arg3: "len", expr3: len))
6580	return false;
6581
6582	if (!less_than_bitsize2 (arg1: "to", expr1: to, arg2: "topos", expr2: topos, arg3: "len", expr3: len))
6583	return false;
6584
6585	return true;
6586	}
6587
6588
6589	/* Check the arguments for RANDOM_INIT. */
6590
6591	bool
6592	gfc_check_random_init (gfc_expr *repeatable, gfc_expr *image_distinct)
6593	{
6594	if (!type_check (e: repeatable, n: 0, type: BT_LOGICAL))
6595	return false;
6596
6597	if (!scalar_check (e: repeatable, n: 0))
6598	return false;
6599
6600	if (!type_check (e: image_distinct, n: 1, type: BT_LOGICAL))
6601	return false;
6602
6603	if (!scalar_check (e: image_distinct, n: 1))
6604	return false;
6605
6606	return true;
6607	}
6608
6609
6610	bool
6611	gfc_check_random_number (gfc_expr *harvest)
6612	{
6613	if (!type_check (e: harvest, n: 0, type: BT_REAL))
6614	return false;
6615
6616	if (!variable_check (e: harvest, n: 0, allow_proc: false))
6617	return false;
6618
6619	return true;
6620	}
6621
6622
6623	bool
6624	gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
6625	{
6626	unsigned int nargs = 0, seed_size;
6627	locus *where = NULL;
6628	mpz_t put_size, get_size;
6629
6630	/* Keep the number of bytes in sync with master_state in
6631	libgfortran/intrinsics/random.c. */
6632	seed_size = 32 / gfc_default_integer_kind;
6633
6634	if (size != NULL)
6635	{
6636	if (size->expr_type != EXPR_VARIABLE
6637	|| !size->symtree->n.sym->attr.optional)
6638	nargs++;
6639
6640	if (!scalar_check (e: size, n: 0))
6641	return false;
6642
6643	if (!type_check (e: size, n: 0, type: BT_INTEGER))
6644	return false;
6645
6646	if (!variable_check (e: size, n: 0, allow_proc: false))
6647	return false;
6648
6649	if (!kind_value_check (e: size, n: 0, k: gfc_default_integer_kind))
6650	return false;
6651	}
6652
6653	if (put != NULL)
6654	{
6655	if (put->expr_type != EXPR_VARIABLE
6656	|| !put->symtree->n.sym->attr.optional)
6657	{
6658	nargs++;
6659	where = &put->where;
6660	}
6661
6662	if (!array_check (e: put, n: 1))
6663	return false;
6664
6665	if (!rank_check (e: put, n: 1, rank: 1))
6666	return false;
6667
6668	if (!type_check (e: put, n: 1, type: BT_INTEGER))
6669	return false;
6670
6671	if (!kind_value_check (e: put, n: 1, k: gfc_default_integer_kind))
6672	return false;
6673
6674	if (gfc_array_size (put, &put_size)
6675	&& mpz_get_ui (gmp_z: put_size) < seed_size)
6676	gfc_error ("Size of %qs argument of %qs intrinsic at %L "
6677	"too small (%i/%i)",
6678	gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
6679	&put->where, (int) mpz_get_ui (gmp_z: put_size), seed_size);
6680	}
6681
6682	if (get != NULL)
6683	{
6684	if (get->expr_type != EXPR_VARIABLE
6685	|| !get->symtree->n.sym->attr.optional)
6686	{
6687	nargs++;
6688	where = &get->where;
6689	}
6690
6691	if (!array_check (e: get, n: 2))
6692	return false;
6693
6694	if (!rank_check (e: get, n: 2, rank: 1))
6695	return false;
6696
6697	if (!type_check (e: get, n: 2, type: BT_INTEGER))
6698	return false;
6699
6700	if (!variable_check (e: get, n: 2, allow_proc: false))
6701	return false;
6702
6703	if (!kind_value_check (e: get, n: 2, k: gfc_default_integer_kind))
6704	return false;
6705
6706	if (gfc_array_size (get, &get_size)
6707	&& mpz_get_ui (gmp_z: get_size) < seed_size)
6708	gfc_error ("Size of %qs argument of %qs intrinsic at %L "
6709	"too small (%i/%i)",
6710	gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
6711	&get->where, (int) mpz_get_ui (gmp_z: get_size), seed_size);
6712	}
6713
6714	/* RANDOM_SEED may not have more than one non-optional argument. */
6715	if (nargs > 1)
6716	gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where);
6717
6718	return true;
6719	}
6720
6721	bool
6722	gfc_check_fe_runtime_error (gfc_actual_arglist *a)
6723	{
6724	gfc_expr *e;
6725	size_t len, i;
6726	int num_percent, nargs;
6727
6728	e = a->expr;
6729	if (e->expr_type != EXPR_CONSTANT)
6730	return true;
6731
6732	len = e->value.character.length;
6733	if (e->value.character.string[len-1] != '\0')
6734	gfc_internal_error ("fe_runtime_error string must be null terminated");
6735
6736	num_percent = 0;
6737	for (i=0; i<len-1; i++)
6738	if (e->value.character.string[i] == '%')
6739	num_percent ++;
6740
6741	nargs = 0;
6742	for (; a; a = a->next)
6743	nargs ++;
6744
6745	if (nargs -1 != num_percent)
6746	gfc_internal_error ("fe_runtime_error: Wrong number of arguments (%d instead of %d)",
6747	nargs, num_percent++);
6748
6749	return true;
6750	}
6751
6752	bool
6753	gfc_check_second_sub (gfc_expr *time)
6754	{
6755	if (!scalar_check (e: time, n: 0))
6756	return false;
6757
6758	if (!type_check (e: time, n: 0, type: BT_REAL))
6759	return false;
6760
6761	if (!kind_value_check (e: time, n: 0, k: 4))
6762	return false;
6763
6764	return true;
6765	}
6766
6767
6768	/* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer
6769	variables in Fortran 95. In Fortran 2003 and later, they can be of any
6770	kind, and COUNT_RATE can be of type real. Note, count, count_rate, and
6771	count_max are all optional arguments */
6772
6773	bool
6774	gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
6775	gfc_expr *count_max)
6776	{
6777	if (count != NULL)
6778	{
6779	if (!scalar_check (e: count, n: 0))
6780	return false;
6781
6782	if (!type_check (e: count, n: 0, type: BT_INTEGER))
6783	return false;
6784
6785	if (count->ts.kind != gfc_default_integer_kind
6786	&& !gfc_notify_std (GFC_STD_F2003, "COUNT argument to "
6787	"SYSTEM_CLOCK at %L has non-default kind",
6788	&count->where))
6789	return false;
6790
6791	if (!variable_check (e: count, n: 0, allow_proc: false))
6792	return false;
6793	}
6794
6795	if (count_rate != NULL)
6796	{
6797	if (!scalar_check (e: count_rate, n: 1))
6798	return false;
6799
6800	if (!variable_check (e: count_rate, n: 1, allow_proc: false))
6801	return false;
6802
6803	if (count_rate->ts.type == BT_REAL)
6804	{
6805	if (!gfc_notify_std (GFC_STD_F2003, "Real COUNT_RATE argument to "
6806	"SYSTEM_CLOCK at %L", &count_rate->where))
6807	return false;
6808	}
6809	else
6810	{
6811	if (!type_check (e: count_rate, n: 1, type: BT_INTEGER))
6812	return false;
6813
6814	if (count_rate->ts.kind != gfc_default_integer_kind
6815	&& !gfc_notify_std (GFC_STD_F2003, "COUNT_RATE argument to "
6816	"SYSTEM_CLOCK at %L has non-default kind",
6817	&count_rate->where))
6818	return false;
6819	}
6820
6821	}
6822
6823	if (count_max != NULL)
6824	{
6825	if (!scalar_check (e: count_max, n: 2))
6826	return false;
6827
6828	if (!type_check (e: count_max, n: 2, type: BT_INTEGER))
6829	return false;
6830
6831	if (count_max->ts.kind != gfc_default_integer_kind
6832	&& !gfc_notify_std (GFC_STD_F2003, "COUNT_MAX argument to "
6833	"SYSTEM_CLOCK at %L has non-default kind",
6834	&count_max->where))
6835	return false;
6836
6837	if (!variable_check (e: count_max, n: 2, allow_proc: false))
6838	return false;
6839	}
6840
6841	return true;
6842	}
6843
6844
6845	bool
6846	gfc_check_irand (gfc_expr *x)
6847	{
6848	if (x == NULL)
6849	return true;
6850
6851	if (!scalar_check (e: x, n: 0))
6852	return false;
6853
6854	if (!type_check (e: x, n: 0, type: BT_INTEGER))
6855	return false;
6856
6857	if (!kind_value_check (e: x, n: 0, k: 4))
6858	return false;
6859
6860	return true;
6861	}
6862
6863
6864	bool
6865	gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
6866	{
6867	if (!scalar_check (e: seconds, n: 0))
6868	return false;
6869	if (!type_check (e: seconds, n: 0, type: BT_INTEGER))
6870	return false;
6871
6872	if (!int_or_proc_check (e: handler, n: 1))
6873	return false;
6874	if (handler->ts.type == BT_INTEGER && !scalar_check (e: handler, n: 1))
6875	return false;
6876
6877	if (status == NULL)
6878	return true;
6879
6880	if (!scalar_check (e: status, n: 2))
6881	return false;
6882	if (!type_check (e: status, n: 2, type: BT_INTEGER))
6883	return false;
6884	if (!kind_value_check (e: status, n: 2, k: gfc_default_integer_kind))
6885	return false;
6886
6887	return true;
6888	}
6889
6890
6891	bool
6892	gfc_check_rand (gfc_expr *x)
6893	{
6894	if (x == NULL)
6895	return true;
6896
6897	if (!scalar_check (e: x, n: 0))
6898	return false;
6899
6900	if (!type_check (e: x, n: 0, type: BT_INTEGER))
6901	return false;
6902
6903	if (!kind_value_check (e: x, n: 0, k: 4))
6904	return false;
6905
6906	return true;
6907	}
6908
6909
6910	bool
6911	gfc_check_srand (gfc_expr *x)
6912	{
6913	if (!scalar_check (e: x, n: 0))
6914	return false;
6915
6916	if (!type_check (e: x, n: 0, type: BT_INTEGER))
6917	return false;
6918
6919	if (!kind_value_check (e: x, n: 0, k: 4))
6920	return false;
6921
6922	return true;
6923	}
6924
6925
6926	bool
6927	gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result)
6928	{
6929	if (!scalar_check (e: time, n: 0))
6930	return false;
6931	if (!type_check (e: time, n: 0, type: BT_INTEGER))
6932	return false;
6933
6934	if (!type_check (e: result, n: 1, type: BT_CHARACTER))
6935	return false;
6936	if (!kind_value_check (e: result, n: 1, k: gfc_default_character_kind))
6937	return false;
6938
6939	return true;
6940	}
6941
6942
6943	bool
6944	gfc_check_dtime_etime (gfc_expr *x)
6945	{
6946	if (!array_check (e: x, n: 0))
6947	return false;
6948
6949	if (!rank_check (e: x, n: 0, rank: 1))
6950	return false;
6951
6952	if (!variable_check (e: x, n: 0, allow_proc: false))
6953	return false;
6954
6955	if (!type_check (e: x, n: 0, type: BT_REAL))
6956	return false;
6957
6958	if (!kind_value_check (e: x, n: 0, k: 4))
6959	return false;
6960
6961	return true;
6962	}
6963
6964
6965	bool
6966	gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time)
6967	{
6968	if (!array_check (e: values, n: 0))
6969	return false;
6970
6971	if (!rank_check (e: values, n: 0, rank: 1))
6972	return false;
6973
6974	if (!variable_check (e: values, n: 0, allow_proc: false))
6975	return false;
6976
6977	if (!type_check (e: values, n: 0, type: BT_REAL))
6978	return false;
6979
6980	if (!kind_value_check (e: values, n: 0, k: 4))
6981	return false;
6982
6983	if (!scalar_check (e: time, n: 1))
6984	return false;
6985
6986	if (!type_check (e: time, n: 1, type: BT_REAL))
6987	return false;
6988
6989	if (!kind_value_check (e: time, n: 1, k: 4))
6990	return false;
6991
6992	return true;
6993	}
6994
6995
6996	bool
6997	gfc_check_fdate_sub (gfc_expr *date)
6998	{
6999	if (!type_check (e: date, n: 0, type: BT_CHARACTER))
7000	return false;
7001	if (!kind_value_check (e: date, n: 0, k: gfc_default_character_kind))
7002	return false;
7003
7004	return true;
7005	}
7006
7007
7008	bool
7009	gfc_check_gerror (gfc_expr *msg)
7010	{
7011	if (!type_check (e: msg, n: 0, type: BT_CHARACTER))
7012	return false;
7013	if (!kind_value_check (e: msg, n: 0, k: gfc_default_character_kind))
7014	return false;
7015
7016	return true;
7017	}
7018
7019
7020	bool
7021	gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
7022	{
7023	if (!type_check (e: cwd, n: 0, type: BT_CHARACTER))
7024	return false;
7025	if (!kind_value_check (e: cwd, n: 0, k: gfc_default_character_kind))
7026	return false;
7027
7028	if (status == NULL)
7029	return true;
7030
7031	if (!scalar_check (e: status, n: 1))
7032	return false;
7033
7034	if (!type_check (e: status, n: 1, type: BT_INTEGER))
7035	return false;
7036
7037	return true;
7038	}
7039
7040
7041	bool
7042	gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
7043	{
7044	if (!type_check (e: pos, n: 0, type: BT_INTEGER))
7045	return false;
7046
7047	if (pos->ts.kind > gfc_default_integer_kind)
7048	{
7049	gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind "
7050	"not wider than the default kind (%d)",
7051	gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
7052	&pos->where, gfc_default_integer_kind);
7053	return false;
7054	}
7055
7056	if (!type_check (e: value, n: 1, type: BT_CHARACTER))
7057	return false;
7058	if (!kind_value_check (e: value, n: 1, k: gfc_default_character_kind))
7059	return false;
7060
7061	return true;
7062	}
7063
7064
7065	bool
7066	gfc_check_getlog (gfc_expr *msg)
7067	{
7068	if (!type_check (e: msg, n: 0, type: BT_CHARACTER))
7069	return false;
7070	if (!kind_value_check (e: msg, n: 0, k: gfc_default_character_kind))
7071	return false;
7072
7073	return true;
7074	}
7075
7076
7077	bool
7078	gfc_check_exit (gfc_expr *status)
7079	{
7080	if (status == NULL)
7081	return true;
7082
7083	if (!type_check (e: status, n: 0, type: BT_INTEGER))
7084	return false;
7085
7086	if (!scalar_check (e: status, n: 0))
7087	return false;
7088
7089	return true;
7090	}
7091
7092
7093	bool
7094	gfc_check_flush (gfc_expr *unit)
7095	{
7096	if (unit == NULL)
7097	return true;
7098
7099	if (!type_check (e: unit, n: 0, type: BT_INTEGER))
7100	return false;
7101
7102	if (!scalar_check (e: unit, n: 0))
7103	return false;
7104
7105	return true;
7106	}
7107
7108
7109	bool
7110	gfc_check_free (gfc_expr *i)
7111	{
7112	if (!type_check (e: i, n: 0, type: BT_INTEGER))
7113	return false;
7114
7115	if (!scalar_check (e: i, n: 0))
7116	return false;
7117
7118	return true;
7119	}
7120
7121
7122	bool
7123	gfc_check_hostnm (gfc_expr *name)
7124	{
7125	if (!type_check (e: name, n: 0, type: BT_CHARACTER))
7126	return false;
7127	if (!kind_value_check (e: name, n: 0, k: gfc_default_character_kind))
7128	return false;
7129
7130	return true;
7131	}
7132
7133
7134	bool
7135	gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
7136	{
7137	if (!type_check (e: name, n: 0, type: BT_CHARACTER))
7138	return false;
7139	if (!kind_value_check (e: name, n: 0, k: gfc_default_character_kind))
7140	return false;
7141
7142	if (status == NULL)
7143	return true;
7144
7145	if (!scalar_check (e: status, n: 1))
7146	return false;
7147
7148	if (!type_check (e: status, n: 1, type: BT_INTEGER))
7149	return false;
7150
7151	return true;
7152	}
7153
7154
7155	bool
7156	gfc_check_itime_idate (gfc_expr *values)
7157	{
7158	if (!array_check (e: values, n: 0))
7159	return false;
7160
7161	if (!rank_check (e: values, n: 0, rank: 1))
7162	return false;
7163
7164	if (!variable_check (e: values, n: 0, allow_proc: false))
7165	return false;
7166
7167	if (!type_check (e: values, n: 0, type: BT_INTEGER))
7168	return false;
7169
7170	if (!kind_value_check (e: values, n: 0, k: gfc_default_integer_kind))
7171	return false;
7172
7173	return true;
7174	}
7175
7176
7177	bool
7178	gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
7179	{
7180	if (!type_check (e: time, n: 0, type: BT_INTEGER))
7181	return false;
7182
7183	if (!kind_value_check (e: time, n: 0, k: gfc_default_integer_kind))
7184	return false;
7185
7186	if (!scalar_check (e: time, n: 0))
7187	return false;
7188
7189	if (!array_check (e: values, n: 1))
7190	return false;
7191
7192	if (!rank_check (e: values, n: 1, rank: 1))
7193	return false;
7194
7195	if (!variable_check (e: values, n: 1, allow_proc: false))
7196	return false;
7197
7198	if (!type_check (e: values, n: 1, type: BT_INTEGER))
7199	return false;
7200
7201	if (!kind_value_check (e: values, n: 1, k: gfc_default_integer_kind))
7202	return false;
7203
7204	return true;
7205	}
7206
7207
7208	bool
7209	gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
7210	{
7211	if (!scalar_check (e: unit, n: 0))
7212	return false;
7213
7214	if (!type_check (e: unit, n: 0, type: BT_INTEGER))
7215	return false;
7216
7217	if (!type_check (e: name, n: 1, type: BT_CHARACTER))
7218	return false;
7219	if (!kind_value_check (e: name, n: 1, k: gfc_default_character_kind))
7220	return false;
7221
7222	return true;
7223	}
7224
7225
7226	bool
7227	gfc_check_is_contiguous (gfc_expr *array)
7228	{
7229	if (array->expr_type == EXPR_NULL)
7230	{
7231	gfc_error ("Actual argument at %L of %qs intrinsic shall be an "
7232	"associated pointer", &array->where, gfc_current_intrinsic);
7233	return false;
7234	}
7235
7236	if (!array_check (e: array, n: 0))
7237	return false;
7238
7239	return true;
7240	}
7241
7242
7243	bool
7244	gfc_check_isatty (gfc_expr *unit)
7245	{
7246	if (unit == NULL)
7247	return false;
7248
7249	if (!type_check (e: unit, n: 0, type: BT_INTEGER))
7250	return false;
7251
7252	if (!scalar_check (e: unit, n: 0))
7253	return false;
7254
7255	return true;
7256	}
7257
7258
7259	bool
7260	gfc_check_isnan (gfc_expr *x)
7261	{
7262	if (!type_check (e: x, n: 0, type: BT_REAL))
7263	return false;
7264
7265	return true;
7266	}
7267
7268
7269	bool
7270	gfc_check_perror (gfc_expr *string)
7271	{
7272	if (!type_check (e: string, n: 0, type: BT_CHARACTER))
7273	return false;
7274	if (!kind_value_check (e: string, n: 0, k: gfc_default_character_kind))
7275	return false;
7276
7277	return true;
7278	}
7279
7280
7281	bool
7282	gfc_check_umask (gfc_expr *mask)
7283	{
7284	if (!type_check (e: mask, n: 0, type: BT_INTEGER))
7285	return false;
7286
7287	if (!scalar_check (e: mask, n: 0))
7288	return false;
7289
7290	return true;
7291	}
7292
7293
7294	bool
7295	gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
7296	{
7297	if (!type_check (e: mask, n: 0, type: BT_INTEGER))
7298	return false;
7299
7300	if (!scalar_check (e: mask, n: 0))
7301	return false;
7302
7303	if (old == NULL)
7304	return true;
7305
7306	if (!scalar_check (e: old, n: 1))
7307	return false;
7308
7309	if (!type_check (e: old, n: 1, type: BT_INTEGER))
7310	return false;
7311
7312	return true;
7313	}
7314
7315
7316	bool
7317	gfc_check_unlink (gfc_expr *name)
7318	{
7319	if (!type_check (e: name, n: 0, type: BT_CHARACTER))
7320	return false;
7321	if (!kind_value_check (e: name, n: 0, k: gfc_default_character_kind))
7322	return false;
7323
7324	return true;
7325	}
7326
7327
7328	bool
7329	gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
7330	{
7331	if (!type_check (e: name, n: 0, type: BT_CHARACTER))
7332	return false;
7333	if (!kind_value_check (e: name, n: 0, k: gfc_default_character_kind))
7334	return false;
7335
7336	if (status == NULL)
7337	return true;
7338
7339	if (!scalar_check (e: status, n: 1))
7340	return false;
7341
7342	if (!type_check (e: status, n: 1, type: BT_INTEGER))
7343	return false;
7344
7345	return true;
7346	}
7347
7348
7349	bool
7350	gfc_check_signal (gfc_expr *number, gfc_expr *handler)
7351	{
7352	if (!scalar_check (e: number, n: 0))
7353	return false;
7354	if (!type_check (e: number, n: 0, type: BT_INTEGER))
7355	return false;
7356
7357	if (!int_or_proc_check (e: handler, n: 1))
7358	return false;
7359	if (handler->ts.type == BT_INTEGER && !scalar_check (e: handler, n: 1))
7360	return false;
7361
7362	return true;
7363	}
7364
7365
7366	bool
7367	gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
7368	{
7369	if (!scalar_check (e: number, n: 0))
7370	return false;
7371	if (!type_check (e: number, n: 0, type: BT_INTEGER))
7372	return false;
7373
7374	if (!int_or_proc_check (e: handler, n: 1))
7375	return false;
7376	if (handler->ts.type == BT_INTEGER && !scalar_check (e: handler, n: 1))
7377	return false;
7378
7379	if (status == NULL)
7380	return true;
7381
7382	if (!type_check (e: status, n: 2, type: BT_INTEGER))
7383	return false;
7384	if (!scalar_check (e: status, n: 2))
7385	return false;
7386
7387	return true;
7388	}
7389
7390
7391	bool
7392	gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
7393	{
7394	if (!type_check (e: cmd, n: 0, type: BT_CHARACTER))
7395	return false;
7396	if (!kind_value_check (e: cmd, n: 0, k: gfc_default_character_kind))
7397	return false;
7398
7399	if (!scalar_check (e: status, n: 1))
7400	return false;
7401
7402	if (!type_check (e: status, n: 1, type: BT_INTEGER))
7403	return false;
7404
7405	if (!kind_value_check (e: status, n: 1, k: gfc_default_integer_kind))
7406	return false;
7407
7408	return true;
7409	}
7410
7411
7412	/* This is used for the GNU intrinsics AND, OR and XOR. */
7413	bool
7414	gfc_check_and (gfc_expr *i, gfc_expr *j)
7415	{
7416	if (i->ts.type != BT_INTEGER
7417	&& i->ts.type != BT_LOGICAL
7418	&& i->ts.type != BT_BOZ)
7419	{
7420	gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, "
7421	"LOGICAL, or a BOZ literal constant",
7422	gfc_current_intrinsic_arg[0]->name,
7423	gfc_current_intrinsic, &i->where);
7424	return false;
7425	}
7426
7427	if (j->ts.type != BT_INTEGER
7428	&& j->ts.type != BT_LOGICAL
7429	&& j->ts.type != BT_BOZ)
7430	{
7431	gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, "
7432	"LOGICAL, or a BOZ literal constant",
7433	gfc_current_intrinsic_arg[1]->name,
7434	gfc_current_intrinsic, &j->where);
7435	return false;
7436	}
7437
7438	/* i and j cannot both be BOZ literal constants. */
7439	if (!boz_args_check (i, j))
7440	return false;
7441
7442	/* If i is BOZ and j is integer, convert i to type of j. */
7443	if (i->ts.type == BT_BOZ)
7444	{
7445	if (j->ts.type != BT_INTEGER)
7446	{
7447	gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
7448	gfc_current_intrinsic_arg[1]->name,
7449	gfc_current_intrinsic, &j->where);
7450	reset_boz (x: i);
7451	return false;
7452	}
7453	if (!gfc_boz2int (x: i, kind: j->ts.kind))
7454	return false;
7455	}
7456
7457	/* If j is BOZ and i is integer, convert j to type of i. */
7458	if (j->ts.type == BT_BOZ)
7459	{
7460	if (i->ts.type != BT_INTEGER)
7461	{
7462	gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
7463	gfc_current_intrinsic_arg[0]->name,
7464	gfc_current_intrinsic, &j->where);
7465	reset_boz (x: j);
7466	return false;
7467	}
7468	if (!gfc_boz2int (x: j, kind: i->ts.kind))
7469	return false;
7470	}
7471
7472	if (!same_type_check (e: i, n: 0, f: j, m: 1, assoc: false))
7473	return false;
7474
7475	if (!scalar_check (e: i, n: 0))
7476	return false;
7477
7478	if (!scalar_check (e: j, n: 1))
7479	return false;
7480
7481	return true;
7482	}
7483
7484
7485	bool
7486	gfc_check_storage_size (gfc_expr *a, gfc_expr *kind)
7487	{
7488
7489	if (a->expr_type == EXPR_NULL)
7490	{
7491	gfc_error ("Intrinsic function NULL at %L cannot be an actual "
7492	"argument to STORAGE_SIZE, because it returns a "
7493	"disassociated pointer", &a->where);
7494	return false;
7495	}
7496
7497	if (a->ts.type == BT_ASSUMED)
7498	{
7499	gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
7500	gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
7501	&a->where);
7502	return false;
7503	}
7504
7505	if (a->ts.type == BT_PROCEDURE)
7506	{
7507	gfc_error ("%qs argument of %qs intrinsic at %L shall not be a "
7508	"procedure", gfc_current_intrinsic_arg[0]->name,
7509	gfc_current_intrinsic, &a->where);
7510	return false;
7511	}
7512
7513	if (a->ts.type == BT_BOZ && illegal_boz_arg (x: a))
7514	return false;
7515
7516	if (kind == NULL)
7517	return true;
7518
7519	if (!type_check (e: kind, n: 1, type: BT_INTEGER))
7520	return false;
7521
7522	if (!scalar_check (e: kind, n: 1))
7523	return false;
7524
7525	if (kind->expr_type != EXPR_CONSTANT)
7526	{
7527	gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
7528	gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
7529	&kind->where);
7530	return false;
7531	}
7532
7533	return true;
7534	}
7535