/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc

Bug Summary

File:	build/gcc/fortran/expr.cc
Warning:	line 2999, column 10 Although the value stored to 'm' is used in the enclosing expression, the value is never actually read from 'm'

Annotated Source Code

Press '?' to see keyboard shortcuts

Show analyzer invocation

clang -cc1 -cc1 -triple x86_64-suse-linux -analyze -disable-free -clear-ast-before-backend -disable-llvm-verifier -discard-value-names -main-file-name expr.cc -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=cplusplus -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -analyzer-config-compatibility-mode=true -mrelocation-model static -mframe-pointer=none -fmath-errno -ffp-contract=on -fno-rounding-math -mconstructor-aliases -funwind-tables=2 -target-cpu x86-64 -tune-cpu generic -debugger-tuning=gdb -fcoverage-compilation-dir=/buildworker/marxinbox-gcc-clang-static-analyzer/objdir/gcc -resource-dir /usr/lib64/clang/15.0.7 -D IN_GCC_FRONTEND -D IN_GCC -D HAVE_CONFIG_H -I . -I fortran -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../include -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libcpp/include -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libcody -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libdecnumber -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libdecnumber/bid -I ../libdecnumber -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libbacktrace -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/13/../../../../include/c++/13 -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/13/../../../../include/c++/13/x86_64-suse-linux -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/13/../../../../include/c++/13/backward -internal-isystem /usr/lib64/clang/15.0.7/include -internal-isystem /usr/local/include -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/13/../../../../x86_64-suse-linux/include -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -Wno-narrowing -Wwrite-strings -Wno-long-long -Wno-variadic-macros -Wno-overlength-strings -fdeprecated-macro -fdebug-compilation-dir=/buildworker/marxinbox-gcc-clang-static-analyzer/objdir/gcc -ferror-limit 19 -fno-rtti -fgnuc-version=4.2.1 -vectorize-loops -vectorize-slp -analyzer-output=plist-html -analyzer-config silence-checkers=core.NullDereference -faddrsig -D__GCC_HAVE_DWARF2_CFI_ASM=1 -o /buildworker/marxinbox-gcc-clang-static-analyzer/objdir/clang-static-analyzer/2023-03-27-141847-20772-1/report-VzyIEi.plist -x c++ /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc

1	/* Routines for manipulation of expression nodes.
2	Copyright (C) 2000-2023 Free Software Foundation, Inc.
3	Contributed by Andy Vaught
4
5	This file is part of GCC.
6
7	GCC is free software; you can redistribute it and/or modify it under
8	the terms of the GNU General Public License as published by the Free
9	Software Foundation; either version 3, or (at your option) any later
10	version.
11
12	GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13	WARRANTY; without even the implied warranty of MERCHANTABILITY or
14	FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15	for more details.
16
17	You should have received a copy of the GNU General Public License
18	along with GCC; see the file COPYING3. If not see
19	<http://www.gnu.org/licenses/>. */
20
21	#include "config.h"
22	#include "system.h"
23	#include "coretypes.h"
24	#include "options.h"
25	#include "gfortran.h"
26	#include "arith.h"
27	#include "match.h"
28	#include "target-memory.h" /* for gfc_convert_boz */
29	#include "constructor.h"
30	#include "tree.h"
31
32
33	/* The following set of functions provide access to gfc_expr* of
34	various types - actual all but EXPR_FUNCTION and EXPR_VARIABLE.
35
36	There are two functions available elsewhere that provide
37	slightly different flavours of variables. Namely:
38	expr.cc (gfc_get_variable_expr)
39	symbol.cc (gfc_lval_expr_from_sym)
40	TODO: Merge these functions, if possible. */
41
42	/* Get a new expression node. */
43
44	gfc_expr *
45	gfc_get_expr (void)
46	{
47	gfc_expr *e;
48
49	e = XCNEW (gfc_expr)((gfc_expr *) xcalloc (1, sizeof (gfc_expr)));
50	gfc_clear_ts (&e->ts);
51	e->shape = NULL__null;
52	e->ref = NULL__null;
53	e->symtree = NULL__null;
54	return e;
55	}
56
57
58	/* Get a new expression node that is an array constructor
59	of given type and kind. */
60
61	gfc_expr *
62	gfc_get_array_expr (bt type, int kind, locus *where)
63	{
64	gfc_expr *e;
65
66	e = gfc_get_expr ();
67	e->expr_type = EXPR_ARRAY;
68	e->value.constructor = NULL__null;
69	e->rank = 1;
70	e->shape = NULL__null;
71
72	e->ts.type = type;
73	e->ts.kind = kind;
74	if (where)
75	e->where = *where;
76
77	return e;
78	}
79
80
81	/* Get a new expression node that is the NULL expression. */
82
83	gfc_expr *
84	gfc_get_null_expr (locus *where)
85	{
86	gfc_expr *e;
87
88	e = gfc_get_expr ();
89	e->expr_type = EXPR_NULL;
90	e->ts.type = BT_UNKNOWN;
91
92	if (where)
93	e->where = *where;
94
95	return e;
96	}
97
98
99	/* Get a new expression node that is an operator expression node. */
100
101	gfc_expr *
102	gfc_get_operator_expr (locus *where, gfc_intrinsic_op op,
103	gfc_expr op1, gfc_expr op2)
104	{
105	gfc_expr *e;
106
107	e = gfc_get_expr ();
108	e->expr_type = EXPR_OP;
109	e->value.op.op = op;
110	e->value.op.op1 = op1;
111	e->value.op.op2 = op2;
112
113	if (where)
114	e->where = *where;
115
116	return e;
117	}
118
119
120	/* Get a new expression node that is an structure constructor
121	of given type and kind. */
122
123	gfc_expr *
124	gfc_get_structure_constructor_expr (bt type, int kind, locus *where)
125	{
126	gfc_expr *e;
127
128	e = gfc_get_expr ();
129	e->expr_type = EXPR_STRUCTURE;
130	e->value.constructor = NULL__null;
131
132	e->ts.type = type;
133	e->ts.kind = kind;
134	if (where)
135	e->where = *where;
136
137	return e;
138	}
139
140
141	/* Get a new expression node that is an constant of given type and kind. */
142
143	gfc_expr *
144	gfc_get_constant_expr (bt type, int kind, locus *where)
145	{
146	gfc_expr *e;
147
148	if (!where)
149	gfc_internal_error ("gfc_get_constant_expr(): locus %<where%> cannot be "
150	"NULL");
151
152	e = gfc_get_expr ();
153
154	e->expr_type = EXPR_CONSTANT;
155	e->ts.type = type;
156	e->ts.kind = kind;
157	e->where = *where;
158
159	switch (type)
160	{
161	case BT_INTEGER:
162	mpz_init__gmpz_init (e->value.integer);
163	break;
164
165	case BT_REAL:
166	gfc_set_model_kind (kind);
167	mpfr_init (e->value.real);
168	break;
169
170	case BT_COMPLEX:
171	gfc_set_model_kind (kind);
172	mpc_init2 (e->value.complex, mpfr_get_default_prec());
173	break;
174
175	default:
176	break;
177	}
178
179	return e;
180	}
181
182
183	/* Get a new expression node that is an string constant.
184	If no string is passed, a string of len is allocated,
185	blanked and null-terminated. */
186
187	gfc_expr *
188	gfc_get_character_expr (int kind, locus where, const char src, gfc_charlen_t len)
189	{
190	gfc_expr *e;
191	gfc_char_t *dest;
192
193	if (!src)
194	{
195	dest = gfc_get_wide_string (len + 1)((gfc_char_t *) xcalloc ((len + 1), sizeof (gfc_char_t)));
196	gfc_wide_memset (dest, ' ', len);
197	dest[len] = '\0';
198	}
199	else
200	dest = gfc_char_to_widechar (src);
201
202	e = gfc_get_constant_expr (BT_CHARACTER, kind,
203	where ? where : &gfc_current_locus);
204	e->value.character.string = dest;
205	e->value.character.length = len;
206
207	return e;
208	}
209
210
211	/* Get a new expression node that is an integer constant. */
212
213	gfc_expr *
214	gfc_get_int_expr (int kind, locus *where, HOST_WIDE_INTlong value)
215	{
216	gfc_expr *p;
217	p = gfc_get_constant_expr (BT_INTEGER, kind,
218	where ? where : &gfc_current_locus);
219
220	const wide_int w = wi::shwi (value, kind * BITS_PER_UNIT(8));
221	wi::to_mpz (w, p->value.integer, SIGNED);
222
223	return p;
224	}
225
226
227	/* Get a new expression node that is a logical constant. */
228
229	gfc_expr *
230	gfc_get_logical_expr (int kind, locus *where, bool value)
231	{
232	gfc_expr *p;
233	p = gfc_get_constant_expr (BT_LOGICAL, kind,
234	where ? where : &gfc_current_locus);
235
236	p->value.logical = value;
237
238	return p;
239	}
240
241
242	gfc_expr *
243	gfc_get_iokind_expr (locus *where, io_kind k)
244	{
245	gfc_expr *e;
246
247	/* Set the types to something compatible with iokind. This is needed to
248	get through gfc_free_expr later since iokind really has no Basic Type,
249	BT, of its own. */
250
251	e = gfc_get_expr ();
252	e->expr_type = EXPR_CONSTANT;
253	e->ts.type = BT_LOGICAL;
254	e->value.iokind = k;
255	e->where = *where;
256
257	return e;
258	}
259
260
261	/* Given an expression pointer, return a copy of the expression. This
262	subroutine is recursive. */
263
264	gfc_expr *
265	gfc_copy_expr (gfc_expr *p)
266	{
267	gfc_expr *q;
268	gfc_char_t *s;
269	char *c;
270
271	if (p == NULL__null)
272	return NULL__null;
273
274	q = gfc_get_expr ();
275	q = p;
276
277	switch (q->expr_type)
278	{
279	case EXPR_SUBSTRING:
280	s = gfc_get_wide_string (p->value.character.length + 1)((gfc_char_t *) xcalloc ((p->value.character.length + 1), sizeof (gfc_char_t)));
281	q->value.character.string = s;
282	memcpy (s, p->value.character.string,
283	(p->value.character.length + 1) * sizeof (gfc_char_t));
284	break;
285
286	case EXPR_CONSTANT:
287	/* Copy target representation, if it exists. */
288	if (p->representation.string)
289	{
290	c = XCNEWVEC (char, p->representation.length + 1)((char *) xcalloc ((p->representation.length + 1), sizeof ( char)));
291	q->representation.string = c;
292	memcpy (c, p->representation.string, (p->representation.length + 1));
293	}
294
295	/* Copy the values of any pointer components of p->value. */
296	switch (q->ts.type)
297	{
298	case BT_INTEGER:
299	mpz_init_set__gmpz_init_set (q->value.integer, p->value.integer);
300	break;
301
302	case BT_REAL:
303	gfc_set_model_kind (q->ts.kind);
304	mpfr_init (q->value.real);
305	mpfr_set (q->value.real, p->value.real, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (p->value.real); mpfr_set4 (q->value.real,_p,MPFR_RNDN,((_p)->_mpfr_sign)); });
306	break;
307
308	case BT_COMPLEX:
309	gfc_set_model_kind (q->ts.kind);
310	mpc_init2 (q->value.complex, mpfr_get_default_prec());
311	mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
312	break;
313
314	case BT_CHARACTER:
315	if (p->representation.string
316	&& p->ts.kind == gfc_default_character_kind)
317	q->value.character.string
318	= gfc_char_to_widechar (q->representation.string);
319	else
320	{
321	s = gfc_get_wide_string (p->value.character.length + 1)((gfc_char_t *) xcalloc ((p->value.character.length + 1), sizeof (gfc_char_t)));
322	q->value.character.string = s;
323
324	/* This is the case for the C_NULL_CHAR named constant. */
325	if (p->value.character.length == 0
326	&& (p->ts.is_c_interop \|\| p->ts.is_iso_c))
327	{
328	*s = '\0';
329	/* Need to set the length to 1 to make sure the NUL
330	terminator is copied. */
331	q->value.character.length = 1;
332	}
333	else
334	memcpy (s, p->value.character.string,
335	(p->value.character.length + 1) * sizeof (gfc_char_t));
336	}
337	break;
338
339	case BT_HOLLERITH:
340	case BT_LOGICAL:
341	case_bt_structcase BT_DERIVED: case BT_UNION:
342	case BT_CLASS:
343	case BT_ASSUMED:
344	break; /* Already done. */
345
346	case BT_BOZ:
347	q->boz.len = p->boz.len;
348	q->boz.rdx = p->boz.rdx;
349	q->boz.str = XCNEWVEC (char, q->boz.len + 1)((char *) xcalloc ((q->boz.len + 1), sizeof (char)));
350	strncpy (q->boz.str, p->boz.str, p->boz.len);
351	break;
352
353	case BT_PROCEDURE:
354	case BT_VOID:
355	/* Should never be reached. */
356	case BT_UNKNOWN:
357	gfc_internal_error ("gfc_copy_expr(): Bad expr node");
358	/* Not reached. */
359	}
360
361	break;
362
363	case EXPR_OP:
364	switch (q->value.op.op)
365	{
366	case INTRINSIC_NOT:
367	case INTRINSIC_PARENTHESES:
368	case INTRINSIC_UPLUS:
369	case INTRINSIC_UMINUS:
370	q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
371	break;
372
373	default: /* Binary operators. */
374	q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
375	q->value.op.op2 = gfc_copy_expr (p->value.op.op2);
376	break;
377	}
378
379	break;
380
381	case EXPR_FUNCTION:
382	q->value.function.actual =
383	gfc_copy_actual_arglist (p->value.function.actual);
384	break;
385
386	case EXPR_COMPCALL:
387	case EXPR_PPC:
388	q->value.compcall.actual =
389	gfc_copy_actual_arglist (p->value.compcall.actual);
390	q->value.compcall.tbp = p->value.compcall.tbp;
391	break;
392
393	case EXPR_STRUCTURE:
394	case EXPR_ARRAY:
395	q->value.constructor = gfc_constructor_copy (p->value.constructor);
396	break;
397
398	case EXPR_VARIABLE:
399	case EXPR_NULL:
400	break;
401
402	case EXPR_UNKNOWN:
403	gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 403, __FUNCTION__));
404	}
405
406	q->shape = gfc_copy_shape (p->shape, p->rank);
407
408	q->ref = gfc_copy_ref (p->ref);
409
410	if (p->param_list)
411	q->param_list = gfc_copy_actual_arglist (p->param_list);
412
413	return q;
414	}
415
416
417	void
418	gfc_clear_shape (mpz_t *shape, int rank)
419	{
420	int i;
421
422	for (i = 0; i < rank; i++)
423	mpz_clear__gmpz_clear (shape[i]);
424	}
425
426
427	void
428	gfc_free_shape (mpz_t **shape, int rank)
429	{
430	if (*shape == NULL__null)
431	return;
432
433	gfc_clear_shape (*shape, rank);
434	free (*shape);
435	*shape = NULL__null;
436	}
437
438
439	/* Workhorse function for gfc_free_expr() that frees everything
440	beneath an expression node, but not the node itself. This is
441	useful when we want to simplify a node and replace it with
442	something else or the expression node belongs to another structure. */
443
444	static void
445	free_expr0 (gfc_expr *e)
446	{
447	switch (e->expr_type)
448	{
449	case EXPR_CONSTANT:
450	/* Free any parts of the value that need freeing. */
451	switch (e->ts.type)
452	{
453	case BT_INTEGER:
454	mpz_clear__gmpz_clear (e->value.integer);
455	break;
456
457	case BT_REAL:
458	mpfr_clear (e->value.real);
459	break;
460
461	case BT_CHARACTER:
462	free (e->value.character.string);
463	break;
464
465	case BT_COMPLEX:
466	mpc_clear (e->value.complex);
467	break;
468
469	case BT_BOZ:
470	free (e->boz.str);
471	break;
472
473	default:
474	break;
475	}
476
477	/* Free the representation. */
478	free (e->representation.string);
479
480	break;
481
482	case EXPR_OP:
483	if (e->value.op.op1 != NULL__null)
484	gfc_free_expr (e->value.op.op1);
485	if (e->value.op.op2 != NULL__null)
486	gfc_free_expr (e->value.op.op2);
487	break;
488
489	case EXPR_FUNCTION:
490	gfc_free_actual_arglist (e->value.function.actual);
491	break;
492
493	case EXPR_COMPCALL:
494	case EXPR_PPC:
495	gfc_free_actual_arglist (e->value.compcall.actual);
496	break;
497
498	case EXPR_VARIABLE:
499	break;
500
501	case EXPR_ARRAY:
502	case EXPR_STRUCTURE:
503	gfc_constructor_free (e->value.constructor);
504	break;
505
506	case EXPR_SUBSTRING:
507	free (e->value.character.string);
508	break;
509
510	case EXPR_NULL:
511	break;
512
513	default:
514	gfc_internal_error ("free_expr0(): Bad expr type");
515	}
516
517	/* Free a shape array. */
518	gfc_free_shape (&e->shape, e->rank);
519
520	gfc_free_ref_list (e->ref);
521
522	gfc_free_actual_arglist (e->param_list);
523
524	memset (e, '\0', sizeof (gfc_expr));
525	}
526
527
528	/* Free an expression node and everything beneath it. */
529
530	void
531	gfc_free_expr (gfc_expr *e)
532	{
533	if (e == NULL__null)
534	return;
535	free_expr0 (e);
536	free (e);
537	}
538
539
540	/* Free an argument list and everything below it. */
541
542	void
543	gfc_free_actual_arglist (gfc_actual_arglist *a1)
544	{
545	gfc_actual_arglist *a2;
546
547	while (a1)
548	{
549	a2 = a1->next;
550	if (a1->expr)
551	gfc_free_expr (a1->expr);
552	free (a1->associated_dummy);
553	free (a1);
554	a1 = a2;
555	}
556	}
557
558
559	/* Copy an arglist structure and all of the arguments. */
560
561	gfc_actual_arglist *
562	gfc_copy_actual_arglist (gfc_actual_arglist *p)
563	{
564	gfc_actual_arglist head, tail, *new_arg;
565
566	head = tail = NULL__null;
567
568	for (; p; p = p->next)
569	{
570	new_arg = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist )));
571	new_arg = p;
572
573	if (p->associated_dummy != NULL__null)
574	{
575	new_arg->associated_dummy = gfc_get_dummy_arg ()((gfc_dummy_arg *) xcalloc (1, sizeof (gfc_dummy_arg)));
576	new_arg->associated_dummy = p->associated_dummy;
577	}
578
579	new_arg->expr = gfc_copy_expr (p->expr);
580	new_arg->next = NULL__null;
581
582	if (head == NULL__null)
583	head = new_arg;
584	else
585	tail->next = new_arg;
586
587	tail = new_arg;
588	}
589
590	return head;
591	}
592
593
594	/* Free a list of reference structures. */
595
596	void
597	gfc_free_ref_list (gfc_ref *p)
598	{
599	gfc_ref *q;
600	int i;
601
602	for (; p; p = q)
603	{
604	q = p->next;
605
606	switch (p->type)
607	{
608	case REF_ARRAY:
609	for (i = 0; i < GFC_MAX_DIMENSIONS15; i++)
610	{
611	gfc_free_expr (p->u.ar.start[i]);
612	gfc_free_expr (p->u.ar.end[i]);
613	gfc_free_expr (p->u.ar.stride[i]);
614	}
615
616	break;
617
618	case REF_SUBSTRING:
619	gfc_free_expr (p->u.ss.start);
620	gfc_free_expr (p->u.ss.end);
621	break;
622
623	case REF_COMPONENT:
624	case REF_INQUIRY:
625	break;
626	}
627
628	free (p);
629	}
630	}
631
632
633	/* Graft the src expression onto the dest subexpression. */
634
635	void
636	gfc_replace_expr (gfc_expr dest, gfc_expr src)
637	{
638	free_expr0 (dest);
639	dest = src;
640	free (src);
641	}
642
643
644	/* Try to extract an integer constant from the passed expression node.
645	Return true if some error occurred, false on success. If REPORT_ERROR
646	is non-zero, emit error, for positive REPORT_ERROR using gfc_error,
647	for negative using gfc_error_now. */
648
649	bool
650	gfc_extract_int (gfc_expr expr, int result, int report_error)
651	{
652	gfc_ref *ref;
653
654	/* A KIND component is a parameter too. The expression for it
655	is stored in the initializer and should be consistent with
656	the tests below. */
657	if (gfc_expr_attr(expr).pdt_kind)
658	{
659	for (ref = expr->ref; ref; ref = ref->next)
660	{
661	if (ref->u.c.component->attr.pdt_kind)
662	expr = ref->u.c.component->initializer;
663	}
664	}
665
666	if (expr->expr_type != EXPR_CONSTANT)
667	{
668	if (report_error > 0)
669	gfc_error ("Constant expression required at %C");
670	else if (report_error < 0)
671	gfc_error_now ("Constant expression required at %C");
672	return true;
673	}
674
675	if (expr->ts.type != BT_INTEGER)
676	{
677	if (report_error > 0)
678	gfc_error ("Integer expression required at %C");
679	else if (report_error < 0)
680	gfc_error_now ("Integer expression required at %C");
681	return true;
682	}
683
684	if ((mpz_cmp_si (expr->value.integer, INT_MAX)(__builtin_constant_p ((2147483647) >= 0) && (2147483647 ) >= 0 ? (__builtin_constant_p ((static_cast<unsigned long > (2147483647))) && ((static_cast<unsigned long > (2147483647))) == 0 ? ((expr->value.integer)->_mp_size < 0 ? -1 : (expr->value.integer)->_mp_size > 0) : __gmpz_cmp_ui (expr->value.integer,(static_cast<unsigned long> (2147483647)))) : __gmpz_cmp_si (expr->value.integer ,2147483647)) > 0)
685	\|\| (mpz_cmp_si (expr->value.integer, INT_MIN)(__builtin_constant_p (((-2147483647 -1)) >= 0) && ((-2147483647 -1)) >= 0 ? (__builtin_constant_p ((static_cast <unsigned long> ((-2147483647 -1)))) && ((static_cast <unsigned long> ((-2147483647 -1)))) == 0 ? ((expr-> value.integer)->_mp_size < 0 ? -1 : (expr->value.integer )->_mp_size > 0) : __gmpz_cmp_ui (expr->value.integer ,(static_cast<unsigned long> ((-2147483647 -1))))) : __gmpz_cmp_si (expr->value.integer,(-2147483647 -1))) < 0))
686	{
687	if (report_error > 0)
688	gfc_error ("Integer value too large in expression at %C");
689	else if (report_error < 0)
690	gfc_error_now ("Integer value too large in expression at %C");
691	return true;
692	}
693
694	*result = (int) mpz_get_si__gmpz_get_si (expr->value.integer);
695
696	return false;
697	}
698
699
700	/* Same as gfc_extract_int, but use a HWI. */
701
702	bool
703	gfc_extract_hwi (gfc_expr expr, HOST_WIDE_INTlong result, int report_error)
704	{
705	gfc_ref *ref;
706
707	/* A KIND component is a parameter too. The expression for it is
708	stored in the initializer and should be consistent with the tests
709	below. */
710	if (gfc_expr_attr(expr).pdt_kind)
711	{
712	for (ref = expr->ref; ref; ref = ref->next)
713	{
714	if (ref->u.c.component->attr.pdt_kind)
715	expr = ref->u.c.component->initializer;
716	}
717	}
718
719	if (expr->expr_type != EXPR_CONSTANT)
720	{
721	if (report_error > 0)
722	gfc_error ("Constant expression required at %C");
723	else if (report_error < 0)
724	gfc_error_now ("Constant expression required at %C");
725	return true;
726	}
727
728	if (expr->ts.type != BT_INTEGER)
729	{
730	if (report_error > 0)
731	gfc_error ("Integer expression required at %C");
732	else if (report_error < 0)
733	gfc_error_now ("Integer expression required at %C");
734	return true;
735	}
736
737	/* Use long_long_integer_type_node to determine when to saturate. */
738	const wide_int val = wi::from_mpz (long_long_integer_type_nodeinteger_types[itk_long_long],
739	expr->value.integer, false);
740
741	if (!wi::fits_shwi_p (val))
742	{
743	if (report_error > 0)
744	gfc_error ("Integer value too large in expression at %C");
745	else if (report_error < 0)
746	gfc_error_now ("Integer value too large in expression at %C");
747	return true;
748	}
749
750	*result = val.to_shwi ();
751
752	return false;
753	}
754
755
756	/* Recursively copy a list of reference structures. */
757
758	gfc_ref *
759	gfc_copy_ref (gfc_ref *src)
760	{
761	gfc_array_ref *ar;
762	gfc_ref *dest;
763
764	if (src == NULL__null)
765	return NULL__null;
766
767	dest = gfc_get_ref ()((gfc_ref *) xcalloc (1, sizeof (gfc_ref)));
768	dest->type = src->type;
769
770	switch (src->type)
771	{
772	case REF_ARRAY:
773	ar = gfc_copy_array_ref (&src->u.ar);
774	dest->u.ar = *ar;
775	free (ar);
776	break;
777
778	case REF_COMPONENT:
779	dest->u.c = src->u.c;
780	break;
781
782	case REF_INQUIRY:
783	dest->u.i = src->u.i;
784	break;
785
786	case REF_SUBSTRING:
787	dest->u.ss = src->u.ss;
788	dest->u.ss.start = gfc_copy_expr (src->u.ss.start);
789	dest->u.ss.end = gfc_copy_expr (src->u.ss.end);
790	break;
791	}
792
793	dest->next = gfc_copy_ref (src->next);
794
795	return dest;
796	}
797
798
799	/* Detect whether an expression has any vector index array references. */
800
801	int
802	gfc_has_vector_index (gfc_expr *e)
803	{
804	gfc_ref *ref;
805	int i;
806	for (ref = e->ref; ref; ref = ref->next)
807	if (ref->type == REF_ARRAY)
808	for (i = 0; i < ref->u.ar.dimen; i++)
809	if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
810	return 1;
811	return 0;
812	}
813
814
815	/* Copy a shape array. */
816
817	mpz_t *
818	gfc_copy_shape (mpz_t *shape, int rank)
819	{
820	mpz_t *new_shape;
821	int n;
822
823	if (shape == NULL__null)
824	return NULL__null;
825
826	new_shape = gfc_get_shape (rank)(((mpz_t *) xcalloc (((rank)), sizeof (mpz_t))));
827
828	for (n = 0; n < rank; n++)
829	mpz_init_set__gmpz_init_set (new_shape[n], shape[n]);
830
831	return new_shape;
832	}
833
834
835	/* Copy a shape array excluding dimension N, where N is an integer
836	constant expression. Dimensions are numbered in Fortran style --
837	starting with ONE.
838
839	So, if the original shape array contains R elements
840	{ s1 ... sN-1 sN sN+1 ... sR-1 sR}
841	the result contains R-1 elements:
842	{ s1 ... sN-1 sN+1 ... sR-1}
843
844	If anything goes wrong -- N is not a constant, its value is out
845	of range -- or anything else, just returns NULL. */
846
847	mpz_t *
848	gfc_copy_shape_excluding (mpz_t shape, int rank, gfc_expr dim)
849	{
850	mpz_t new_shape, s;
851	int i, n;
852
853	if (shape == NULL__null
854	\|\| rank <= 1
855	\|\| dim == NULL__null
856	\|\| dim->expr_type != EXPR_CONSTANT
857	\|\| dim->ts.type != BT_INTEGER)
858	return NULL__null;
859
860	n = mpz_get_si__gmpz_get_si (dim->value.integer);
861	n--; /* Convert to zero based index. */
862	if (n < 0 \|\| n >= rank)
863	return NULL__null;
864
865	s = new_shape = gfc_get_shape (rank - 1)(((mpz_t *) xcalloc (((rank - 1)), sizeof (mpz_t))));
866
867	for (i = 0; i < rank; i++)
868	{
869	if (i == n)
870	continue;
871	mpz_init_set__gmpz_init_set (*s, shape[i]);
872	s++;
873	}
874
875	return new_shape;
876	}
877
878
879	/* Return the maximum kind of two expressions. In general, higher
880	kind numbers mean more precision for numeric types. */
881
882	int
883	gfc_kind_max (gfc_expr e1, gfc_expr e2)
884	{
885	return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind;
886	}
887
888
889	/* Returns nonzero if the type is numeric, zero otherwise. */
890
891	static int
892	numeric_type (bt type)
893	{
894	return type == BT_COMPLEX \|\| type == BT_REAL \|\| type == BT_INTEGER;
895	}
896
897
898	/* Returns nonzero if the typespec is a numeric type, zero otherwise. */
899
900	int
901	gfc_numeric_ts (gfc_typespec *ts)
902	{
903	return numeric_type (ts->type);
904	}
905
906
907	/* Return an expression node with an optional argument list attached.
908	A variable number of gfc_expr pointers are strung together in an
909	argument list with a NULL pointer terminating the list. */
910
911	gfc_expr *
912	gfc_build_conversion (gfc_expr *e)
913	{
914	gfc_expr *p;
915
916	p = gfc_get_expr ();
917	p->expr_type = EXPR_FUNCTION;
918	p->symtree = NULL__null;
919	p->value.function.actual = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist )));
920	p->value.function.actual->expr = e;
921
922	return p;
923	}
924
925
926	/* Given an expression node with some sort of numeric binary
927	expression, insert type conversions required to make the operands
928	have the same type. Conversion warnings are disabled if wconversion
929	is set to 0.
930
931	The exception is that the operands of an exponential don't have to
932	have the same type. If possible, the base is promoted to the type
933	of the exponent. For example, 12.3 becomes 1.02.3, but
934	1.0*2 stays as it is. /
935
936	void
937	gfc_type_convert_binary (gfc_expr *e, int wconversion)
938	{
939	gfc_expr op1, op2;
940
941	op1 = e->value.op.op1;
942	op2 = e->value.op.op2;
943
944	if (op1->ts.type == BT_UNKNOWN \|\| op2->ts.type == BT_UNKNOWN)
945	{
946	gfc_clear_ts (&e->ts);
947	return;
948	}
949
950	/* Kind conversions of same type. */
951	if (op1->ts.type == op2->ts.type)
952	{
953	if (op1->ts.kind == op2->ts.kind)
954	{
955	/* No type conversions. */
956	e->ts = op1->ts;
957	goto done;
958	}
959
960	if (op1->ts.kind > op2->ts.kind)
961	gfc_convert_type_warn (op2, &op1->ts, 2, wconversion);
962	else
963	gfc_convert_type_warn (op1, &op2->ts, 2, wconversion);
964
965	e->ts = op1->ts;
966	goto done;
967	}
968
969	/* Integer combined with real or complex. */
970	if (op2->ts.type == BT_INTEGER)
971	{
972	e->ts = op1->ts;
973
974	/* Special case for ** operator. */
975	if (e->value.op.op == INTRINSIC_POWER)
976	goto done;
977
978	gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion);
979	goto done;
980	}
981
982	if (op1->ts.type == BT_INTEGER)
983	{
984	e->ts = op2->ts;
985	gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion);
986	goto done;
987	}
988
989	/* Real combined with complex. */
990	e->ts.type = BT_COMPLEX;
991	if (op1->ts.kind > op2->ts.kind)
992	e->ts.kind = op1->ts.kind;
993	else
994	e->ts.kind = op2->ts.kind;
995	if (op1->ts.type != BT_COMPLEX \|\| op1->ts.kind != e->ts.kind)
996	gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion);
997	if (op2->ts.type != BT_COMPLEX \|\| op2->ts.kind != e->ts.kind)
998	gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion);
999
1000	done:
1001	return;
1002	}
1003
1004
1005	/* Standard intrinsics listed under F2018:10.1.12 (6), which are excluded in
1006	constant expressions, except TRANSFER (c.f. item (8)), which would need
1007	separate treatment. */
1008
1009	static bool
1010	is_non_constant_intrinsic (gfc_expr *e)
1011	{
1012	if (e->expr_type == EXPR_FUNCTION
1013	&& e->value.function.isym)
1014	{
1015	switch (e->value.function.isym->id)
1016	{
1017	case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
1018	case GFC_ISYM_GET_TEAM:
1019	case GFC_ISYM_NULL:
1020	case GFC_ISYM_NUM_IMAGES:
1021	case GFC_ISYM_TEAM_NUMBER:
1022	case GFC_ISYM_THIS_IMAGE:
1023	return true;
1024
1025	default:
1026	return false;
1027	}
1028	}
1029	return false;
1030	}
1031
1032
1033	/* Determine if an expression is constant in the sense of F08:7.1.12.
1034	* This function expects that the expression has already been simplified. */
1035
1036	bool
1037	gfc_is_constant_expr (gfc_expr *e)
1038	{
1039	gfc_constructor *c;
1040	gfc_actual_arglist *arg;
1041
1042	if (e == NULL__null)
1043	return true;
1044
1045	switch (e->expr_type)
1046	{
1047	case EXPR_OP:
1048	return (gfc_is_constant_expr (e->value.op.op1)
1049	&& (e->value.op.op2 == NULL__null
1050	\|\| gfc_is_constant_expr (e->value.op.op2)));
1051
1052	case EXPR_VARIABLE:
1053	/* The only context in which this can occur is in a parameterized
1054	derived type declaration, so returning true is OK. */
1055	if (e->symtree->n.sym->attr.pdt_len
1056	\|\| e->symtree->n.sym->attr.pdt_kind)
1057	return true;
1058	return false;
1059
1060	case EXPR_FUNCTION:
1061	case EXPR_PPC:
1062	case EXPR_COMPCALL:
1063	gcc_assert (e->symtree \|\| e->value.function.esym((void)(!(e->symtree \|\| e->value.function.esym \|\| e-> value.function.isym) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 1064, __FUNCTION__), 0 : 0))
1064	\|\| e->value.function.isym)((void)(!(e->symtree \|\| e->value.function.esym \|\| e-> value.function.isym) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 1064, __FUNCTION__), 0 : 0));
1065
1066	/* Check for intrinsics excluded in constant expressions. */
1067	if (e->value.function.isym && is_non_constant_intrinsic (e))
1068	return false;
1069
1070	/* Call to intrinsic with at least one argument. */
1071	if (e->value.function.isym && e->value.function.actual)
1072	{
1073	for (arg = e->value.function.actual; arg; arg = arg->next)
1074	if (!gfc_is_constant_expr (arg->expr))
1075	return false;
1076	}
1077
1078	if (e->value.function.isym
1079	&& (e->value.function.isym->elemental
1080	\|\| e->value.function.isym->pure
1081	\|\| e->value.function.isym->inquiry
1082	\|\| e->value.function.isym->transformational))
1083	return true;
1084
1085	return false;
1086
1087	case EXPR_CONSTANT:
1088	case EXPR_NULL:
1089	return true;
1090
1091	case EXPR_SUBSTRING:
1092	return e->ref == NULL__null \|\| (gfc_is_constant_expr (e->ref->u.ss.start)
1093	&& gfc_is_constant_expr (e->ref->u.ss.end));
1094
1095	case EXPR_ARRAY:
1096	case EXPR_STRUCTURE:
1097	c = gfc_constructor_first (e->value.constructor);
1098	if ((e->expr_type == EXPR_ARRAY) && c && c->iterator)
1099	return gfc_constant_ac (e);
1100
1101	for (; c; c = gfc_constructor_next (c))
1102	if (!gfc_is_constant_expr (c->expr))
1103	return false;
1104
1105	return true;
1106
1107
1108	default:
1109	gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
1110	return false;
1111	}
1112	}
1113
1114
1115	/* Is true if the expression or symbol is a passed CFI descriptor. */
1116	bool
1117	is_CFI_desc (gfc_symbol sym, gfc_expr e)
1118	{
1119	if (sym == NULL__null
1120	&& e && e->expr_type == EXPR_VARIABLE)
1121	sym = e->symtree->n.sym;
1122
1123	if (sym && sym->attr.dummy
1124	&& sym->ns->proc_name->attr.is_bind_c
1125	&& (sym->attr.pointer
1126	\|\| sym->attr.allocatable
1127	\|\| (sym->attr.dimension
1128	&& (sym->as->type == AS_ASSUMED_SHAPE
1129	\|\| sym->as->type == AS_ASSUMED_RANK))
1130	\|\| (sym->ts.type == BT_CHARACTER
1131	&& (!sym->ts.u.cl \|\| !sym->ts.u.cl->length))))
1132	return true;
1133
1134	return false;
1135	}
1136
1137
1138	/* Is true if an array reference is followed by a component or substring
1139	reference. */
1140	bool
1141	is_subref_array (gfc_expr * e)
1142	{
1143	gfc_ref * ref;
1144	bool seen_array;
1145	gfc_symbol *sym;
1146
1147	if (e->expr_type != EXPR_VARIABLE)
1148	return false;
1149
1150	sym = e->symtree->n.sym;
1151
1152	if (sym->attr.subref_array_pointer)
1153	return true;
1154
1155	seen_array = false;
1156
1157	for (ref = e->ref; ref; ref = ref->next)
1158	{
1159	/* If we haven't seen the array reference and this is an intrinsic,
1160	what follows cannot be a subreference array, unless there is a
1161	substring reference. */
1162	if (!seen_array && ref->type == REF_COMPONENT
1163	&& ref->u.c.component->ts.type != BT_CHARACTER
1164	&& ref->u.c.component->ts.type != BT_CLASS
1165	&& !gfc_bt_struct (ref->u.c.component->ts.type)((ref->u.c.component->ts.type) == BT_DERIVED \|\| (ref-> u.c.component->ts.type) == BT_UNION))
1166	return false;
1167
1168	if (ref->type == REF_ARRAY
1169	&& ref->u.ar.type != AR_ELEMENT)
1170	seen_array = true;
1171
1172	if (seen_array
1173	&& ref->type != REF_ARRAY)
1174	return seen_array;
1175	}
1176
1177	if (sym->ts.type == BT_CLASS
1178	&& sym->attr.dummy
1179	&& CLASS_DATA (sym)sym->ts.u.derived->components->attr.dimension
1180	&& CLASS_DATA (sym)sym->ts.u.derived->components->attr.class_pointer)
1181	return true;
1182
1183	return false;
1184	}
1185
1186
1187	/* Try to collapse intrinsic expressions. */
1188
1189	static bool
1190	simplify_intrinsic_op (gfc_expr *p, int type)
1191	{
1192	gfc_intrinsic_op op;
1193	gfc_expr op1, op2, *result;
1194
1195	if (p->value.op.op == INTRINSIC_USER)
1196	return true;
1197
1198	op1 = p->value.op.op1;
1199	op2 = p->value.op.op2;
1200	op = p->value.op.op;
1201
1202	if (!gfc_simplify_expr (op1, type))
1203	return false;
1204	if (!gfc_simplify_expr (op2, type))
1205	return false;
1206
1207	if (!gfc_is_constant_expr (op1)
1208	\|\| (op2 != NULL__null && !gfc_is_constant_expr (op2)))
1209	return true;
1210
1211	/* Rip p apart. */
1212	p->value.op.op1 = NULL__null;
1213	p->value.op.op2 = NULL__null;
1214
1215	switch (op)
1216	{
1217	case INTRINSIC_PARENTHESES:
1218	result = gfc_parentheses (op1);
1219	break;
1220
1221	case INTRINSIC_UPLUS:
1222	result = gfc_uplus (op1);
1223	break;
1224
1225	case INTRINSIC_UMINUS:
1226	result = gfc_uminus (op1);
1227	break;
1228
1229	case INTRINSIC_PLUS:
1230	result = gfc_add (op1, op2);
1231	break;
1232
1233	case INTRINSIC_MINUS:
1234	result = gfc_subtract (op1, op2);
1235	break;
1236
1237	case INTRINSIC_TIMES:
1238	result = gfc_multiply (op1, op2);
1239	break;
1240
1241	case INTRINSIC_DIVIDE:
1242	result = gfc_divide (op1, op2);
1243	break;
1244
1245	case INTRINSIC_POWER:
1246	result = gfc_power (op1, op2);
1247	break;
1248
1249	case INTRINSIC_CONCAT:
1250	result = gfc_concat (op1, op2);
1251	break;
1252
1253	case INTRINSIC_EQ:
1254	case INTRINSIC_EQ_OS:
1255	result = gfc_eq (op1, op2, op);
1256	break;
1257
1258	case INTRINSIC_NE:
1259	case INTRINSIC_NE_OS:
1260	result = gfc_ne (op1, op2, op);
1261	break;
1262
1263	case INTRINSIC_GT:
1264	case INTRINSIC_GT_OS:
1265	result = gfc_gt (op1, op2, op);
1266	break;
1267
1268	case INTRINSIC_GE:
1269	case INTRINSIC_GE_OS:
1270	result = gfc_ge (op1, op2, op);
1271	break;
1272
1273	case INTRINSIC_LT:
1274	case INTRINSIC_LT_OS:
1275	result = gfc_lt (op1, op2, op);
1276	break;
1277
1278	case INTRINSIC_LE:
1279	case INTRINSIC_LE_OS:
1280	result = gfc_le (op1, op2, op);
1281	break;
1282
1283	case INTRINSIC_NOT:
1284	result = gfc_not (op1);
1285	break;
1286
1287	case INTRINSIC_AND:
1288	result = gfc_and (op1, op2);
1289	break;
1290
1291	case INTRINSIC_OR:
1292	result = gfc_or (op1, op2);
1293	break;
1294
1295	case INTRINSIC_EQV:
1296	result = gfc_eqv (op1, op2);
1297	break;
1298
1299	case INTRINSIC_NEQV:
1300	result = gfc_neqv (op1, op2);
1301	break;
1302
1303	default:
1304	gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1305	}
1306
1307	if (result == NULL__null)
1308	{
1309	gfc_free_expr (op1);
1310	gfc_free_expr (op2);
1311	return false;
1312	}
1313
1314	result->rank = p->rank;
1315	result->where = p->where;
1316	gfc_replace_expr (p, result);
1317
1318	return true;
1319	}
1320
1321
1322	/* Subroutine to simplify constructor expressions. Mutually recursive
1323	with gfc_simplify_expr(). */
1324
1325	static bool
1326	simplify_constructor (gfc_constructor_base base, int type)
1327	{
1328	gfc_constructor *c;
1329	gfc_expr *p;
1330
1331	for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1332	{
1333	if (c->iterator
1334	&& (!gfc_simplify_expr(c->iterator->start, type)
1335	\|\| !gfc_simplify_expr (c->iterator->end, type)
1336	\|\| !gfc_simplify_expr (c->iterator->step, type)))
1337	return false;
1338
1339	if (c->expr)
1340	{
1341	/* Try and simplify a copy. Replace the original if successful
1342	but keep going through the constructor at all costs. Not
1343	doing so can make a dog's dinner of complicated things. */
1344	p = gfc_copy_expr (c->expr);
1345
1346	if (!gfc_simplify_expr (p, type))
1347	{
1348	gfc_free_expr (p);
1349	continue;
1350	}
1351
1352	gfc_replace_expr (c->expr, p);
1353	}
1354	}
1355
1356	return true;
1357	}
1358
1359
1360	/* Pull a single array element out of an array constructor. */
1361
1362	static bool
1363	find_array_element (gfc_constructor_base base, gfc_array_ref *ar,
1364	gfc_constructor **rval)
1365	{
1366	unsigned long nelemen;
1367	int i;
1368	mpz_t delta;
1369	mpz_t offset;
1370	mpz_t span;
1371	mpz_t tmp;
1372	gfc_constructor *cons;
1373	gfc_expr *e;
1374	bool t;
1375
1376	t = true;
1377	e = NULL__null;
1378
1379	mpz_init_set_ui__gmpz_init_set_ui (offset, 0);
1380	mpz_init__gmpz_init (delta);
1381	mpz_init__gmpz_init (tmp);
1382	mpz_init_set_ui__gmpz_init_set_ui (span, 1);
1383	for (i = 0; i < ar->dimen; i++)
1384	{
1385	if (!gfc_reduce_init_expr (ar->as->lower[i])
1386	\|\| !gfc_reduce_init_expr (ar->as->upper[i])
1387	\|\| ar->as->upper[i]->expr_type != EXPR_CONSTANT
1388	\|\| ar->as->lower[i]->expr_type != EXPR_CONSTANT)
1389	{
1390	t = false;
1391	cons = NULL__null;
1392	goto depart;
1393	}
1394
1395	e = ar->start[i];
1396	if (e->expr_type != EXPR_CONSTANT)
1397	{
1398	cons = NULL__null;
1399	goto depart;
1400	}
1401
1402	/* Check the bounds. */
1403	if ((ar->as->upper[i]
1404	&& mpz_cmp__gmpz_cmp (e->value.integer,
1405	ar->as->upper[i]->value.integer) > 0)
1406	\|\| (mpz_cmp__gmpz_cmp (e->value.integer,
1407	ar->as->lower[i]->value.integer) < 0))
1408	{
1409	gfc_error ("Index in dimension %d is out of bounds "
1410	"at %L", i + 1, &ar->c_where[i]);
1411	cons = NULL__null;
1412	t = false;
1413	goto depart;
1414	}
1415
1416	mpz_sub__gmpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer);
1417	mpz_mul__gmpz_mul (delta, delta, span);
1418	mpz_add__gmpz_add (offset, offset, delta);
1419
1420	mpz_set_ui__gmpz_set_ui (tmp, 1);
1421	mpz_add__gmpz_add (tmp, tmp, ar->as->upper[i]->value.integer);
1422	mpz_sub__gmpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
1423	mpz_mul__gmpz_mul (span, span, tmp);
1424	}
1425
1426	for (cons = gfc_constructor_first (base), nelemen = mpz_get_ui__gmpz_get_ui (offset);
1427	cons && nelemen > 0; cons = gfc_constructor_next (cons), nelemen--)
1428	{
1429	if (cons->iterator)
1430	{
1431	cons = NULL__null;
1432	goto depart;
1433	}
1434	}
1435
1436	depart:
1437	mpz_clear__gmpz_clear (delta);
1438	mpz_clear__gmpz_clear (offset);
1439	mpz_clear__gmpz_clear (span);
1440	mpz_clear__gmpz_clear (tmp);
1441	*rval = cons;
1442	return t;
1443	}
1444
1445
1446	/* Find a component of a structure constructor. */
1447
1448	static gfc_constructor *
1449	find_component_ref (gfc_constructor_base base, gfc_ref *ref)
1450	{
1451	gfc_component *pick = ref->u.c.component;
1452	gfc_constructor *c = gfc_constructor_first (base);
1453
1454	gfc_symbol *dt = ref->u.c.sym;
1455	int ext = dt->attr.extension;
1456
1457	/* For extended types, check if the desired component is in one of the
1458	* parent types. */
1459	while (ext > 0 && gfc_find_component (dt->components->ts.u.derived,
1460	pick->name, true, true, NULL__null))
1461	{
1462	dt = dt->components->ts.u.derived;
1463	c = gfc_constructor_first (c->expr->value.constructor);
1464	ext--;
1465	}
1466
1467	gfc_component *comp = dt->components;
1468	while (comp != pick)
1469	{
1470	comp = comp->next;
1471	c = gfc_constructor_next (c);
1472	}
1473
1474	return c;
1475	}
1476
1477
1478	/* Replace an expression with the contents of a constructor, removing
1479	the subobject reference in the process. */
1480
1481	static void
1482	remove_subobject_ref (gfc_expr p, gfc_constructor cons)
1483	{
1484	gfc_expr *e;
1485
1486	if (cons)
1487	{
1488	e = cons->expr;
1489	cons->expr = NULL__null;
1490	}
1491	else
1492	e = gfc_copy_expr (p);
1493	e->ref = p->ref->next;
1494	p->ref->next = NULL__null;
1495	gfc_replace_expr (p, e);
1496	}
1497
1498
1499	/* Pull an array section out of an array constructor. */
1500
1501	static bool
1502	find_array_section (gfc_expr expr, gfc_ref ref)
1503	{
1504	int idx;
1505	int rank;
1506	int d;
1507	int shape_i;
1508	int limit;
1509	long unsigned one = 1;
1510	bool incr_ctr;
1511	mpz_t start[GFC_MAX_DIMENSIONS15];
1512	mpz_t end[GFC_MAX_DIMENSIONS15];
1513	mpz_t stride[GFC_MAX_DIMENSIONS15];
1514	mpz_t delta[GFC_MAX_DIMENSIONS15];
1515	mpz_t ctr[GFC_MAX_DIMENSIONS15];
1516	mpz_t delta_mpz;
1517	mpz_t tmp_mpz;
1518	mpz_t nelts;
1519	mpz_t ptr;
1520	gfc_constructor_base base;
1521	gfc_constructor cons, vecsub[GFC_MAX_DIMENSIONS15];
1522	gfc_expr *begin;
1523	gfc_expr *finish;
1524	gfc_expr *step;
1525	gfc_expr *upper;
1526	gfc_expr *lower;
1527	bool t;
1528
1529	t = true;
1530
1531	base = expr->value.constructor;
1532	expr->value.constructor = NULL__null;
1533
1534	rank = ref->u.ar.as->rank;
1535
1536	if (expr->shape == NULL__null)
1537	expr->shape = gfc_get_shape (rank)(((mpz_t *) xcalloc (((rank)), sizeof (mpz_t))));
1538
1539	mpz_init_set_ui__gmpz_init_set_ui (delta_mpz, one);
1540	mpz_init_set_ui__gmpz_init_set_ui (nelts, one);
1541	mpz_init__gmpz_init (tmp_mpz);
1542
1543	/* Do the initialization now, so that we can cleanup without
1544	keeping track of where we were. */
1545	for (d = 0; d < rank; d++)
1546	{
1547	mpz_init__gmpz_init (delta[d]);
1548	mpz_init__gmpz_init (start[d]);
1549	mpz_init__gmpz_init (end[d]);
1550	mpz_init__gmpz_init (ctr[d]);
1551	mpz_init__gmpz_init (stride[d]);
1552	vecsub[d] = NULL__null;
1553	}
1554
1555	/* Build the counters to clock through the array reference. */
1556	shape_i = 0;
1557	for (d = 0; d < rank; d++)
1558	{
1559	/* Make this stretch of code easier on the eye! */
1560	begin = ref->u.ar.start[d];
1561	finish = ref->u.ar.end[d];
1562	step = ref->u.ar.stride[d];
1563	lower = ref->u.ar.as->lower[d];
1564	upper = ref->u.ar.as->upper[d];
1565
1566	if (!lower \|\| !upper
1567	\|\| lower->expr_type != EXPR_CONSTANT
1568	\|\| upper->expr_type != EXPR_CONSTANT
1569	\|\| lower->ts.type != BT_INTEGER
1570	\|\| upper->ts.type != BT_INTEGER)
1571	{
1572	t = false;
1573	goto cleanup;
1574	}
1575
1576	if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
1577	{
1578	gfc_constructor *ci;
1579	gcc_assert (begin)((void)(!(begin) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 1579, __FUNCTION__), 0 : 0));
1580
1581	if (begin->expr_type != EXPR_ARRAY \|\| !gfc_is_constant_expr (begin))
1582	{
1583	t = false;
1584	goto cleanup;
1585	}
1586
1587	gcc_assert (begin->rank == 1)((void)(!(begin->rank == 1) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 1587, __FUNCTION__), 0 : 0));
1588	/* Zero-sized arrays have no shape and no elements, stop early. */
1589	if (!begin->shape)
1590	{
1591	mpz_init_set_ui__gmpz_init_set_ui (nelts, 0);
1592	break;
1593	}
1594
1595	vecsub[d] = gfc_constructor_first (begin->value.constructor);
1596	mpz_set__gmpz_set (ctr[d], vecsub[d]->expr->value.integer);
1597	mpz_mul__gmpz_mul (nelts, nelts, begin->shape[0]);
1598	mpz_set__gmpz_set (expr->shape[shape_i++], begin->shape[0]);
1599
1600	/* Check bounds. */
1601	for (ci = vecsub[d]; ci; ci = gfc_constructor_next (ci))
1602	{
1603	if (mpz_cmp__gmpz_cmp (ci->expr->value.integer, upper->value.integer) > 0
1604	\|\| mpz_cmp__gmpz_cmp (ci->expr->value.integer,
1605	lower->value.integer) < 0)
1606	{
1607	gfc_error ("index in dimension %d is out of bounds "
1608	"at %L", d + 1, &ref->u.ar.c_where[d]);
1609	t = false;
1610	goto cleanup;
1611	}
1612	}
1613	}
1614	else
1615	{
1616	if ((begin && begin->expr_type != EXPR_CONSTANT)
1617	\|\| (finish && finish->expr_type != EXPR_CONSTANT)
1618	\|\| (step && step->expr_type != EXPR_CONSTANT))
1619	{
1620	t = false;
1621	goto cleanup;
1622	}
1623
1624	/* Obtain the stride. */
1625	if (step)
1626	mpz_set__gmpz_set (stride[d], step->value.integer);
1627	else
1628	mpz_set_ui__gmpz_set_ui (stride[d], one);
1629
1630	if (mpz_cmp_ui (stride[d], 0)(__builtin_constant_p (0) && (0) == 0 ? ((stride[d])-> _mp_size < 0 ? -1 : (stride[d])->_mp_size > 0) : __gmpz_cmp_ui (stride[d],0)) == 0)
1631	mpz_set_ui__gmpz_set_ui (stride[d], one);
1632
1633	/* Obtain the start value for the index. */
1634	if (begin)
1635	mpz_set__gmpz_set (start[d], begin->value.integer);
1636	else
1637	mpz_set__gmpz_set (start[d], lower->value.integer);
1638
1639	mpz_set__gmpz_set (ctr[d], start[d]);
1640
1641	/* Obtain the end value for the index. */
1642	if (finish)
1643	mpz_set__gmpz_set (end[d], finish->value.integer);
1644	else
1645	mpz_set__gmpz_set (end[d], upper->value.integer);
1646
1647	/* Separate 'if' because elements sometimes arrive with
1648	non-null end. */
1649	if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT)
1650	mpz_set__gmpz_set (end [d], begin->value.integer);
1651
1652	/* Check the bounds. */
1653	if (mpz_cmp__gmpz_cmp (ctr[d], upper->value.integer) > 0
1654	\|\| mpz_cmp__gmpz_cmp (end[d], upper->value.integer) > 0
1655	\|\| mpz_cmp__gmpz_cmp (ctr[d], lower->value.integer) < 0
1656	\|\| mpz_cmp__gmpz_cmp (end[d], lower->value.integer) < 0)
1657	{
1658	gfc_error ("index in dimension %d is out of bounds "
1659	"at %L", d + 1, &ref->u.ar.c_where[d]);
1660	t = false;
1661	goto cleanup;
1662	}
1663
1664	/* Calculate the number of elements and the shape. */
1665	mpz_set__gmpz_set (tmp_mpz, stride[d]);
1666	mpz_add__gmpz_add (tmp_mpz, end[d], tmp_mpz);
1667	mpz_sub__gmpz_sub (tmp_mpz, tmp_mpz, ctr[d]);
1668	mpz_div__gmpz_fdiv_q (tmp_mpz, tmp_mpz, stride[d]);
1669	mpz_mul__gmpz_mul (nelts, nelts, tmp_mpz);
1670
1671	/* An element reference reduces the rank of the expression; don't
1672	add anything to the shape array. */
1673	if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT)
1674	mpz_set__gmpz_set (expr->shape[shape_i++], tmp_mpz);
1675	}
1676
1677	/* Calculate the 'stride' (=delta) for conversion of the
1678	counter values into the index along the constructor. */
1679	mpz_set__gmpz_set (delta[d], delta_mpz);
1680	mpz_sub__gmpz_sub (tmp_mpz, upper->value.integer, lower->value.integer);
1681	mpz_add_ui__gmpz_add_ui (tmp_mpz, tmp_mpz, one);
1682	mpz_mul__gmpz_mul (delta_mpz, delta_mpz, tmp_mpz);
1683	}
1684
1685	mpz_init__gmpz_init (ptr);
1686	cons = gfc_constructor_first (base);
1687
1688	/* Now clock through the array reference, calculating the index in
1689	the source constructor and transferring the elements to the new
1690	constructor. */
1691	for (idx = 0; idx < (int) mpz_get_si__gmpz_get_si (nelts); idx++)
1692	{
1693	mpz_init_set_ui__gmpz_init_set_ui (ptr, 0);
1694
1695	incr_ctr = true;
1696	for (d = 0; d < rank; d++)
1697	{
1698	mpz_set__gmpz_set (tmp_mpz, ctr[d]);
1699	mpz_sub__gmpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer);
1700	mpz_mul__gmpz_mul (tmp_mpz, tmp_mpz, delta[d]);
1701	mpz_add__gmpz_add (ptr, ptr, tmp_mpz);
1702
1703	if (!incr_ctr) continue;
1704
1705	if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
1706	{
1707	gcc_assert(vecsub[d])((void)(!(vecsub[d]) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 1707, __FUNCTION__), 0 : 0));
1708
1709	if (!gfc_constructor_next (vecsub[d]))
1710	vecsub[d] = gfc_constructor_first (ref->u.ar.start[d]->value.constructor);
1711	else
1712	{
1713	vecsub[d] = gfc_constructor_next (vecsub[d]);
1714	incr_ctr = false;
1715	}
1716	mpz_set__gmpz_set (ctr[d], vecsub[d]->expr->value.integer);
1717	}
1718	else
1719	{
1720	mpz_add__gmpz_add (ctr[d], ctr[d], stride[d]);
1721
1722	if (mpz_cmp_ui (stride[d], 0)(__builtin_constant_p (0) && (0) == 0 ? ((stride[d])-> _mp_size < 0 ? -1 : (stride[d])->_mp_size > 0) : __gmpz_cmp_ui (stride[d],0)) > 0
1723	? mpz_cmp__gmpz_cmp (ctr[d], end[d]) > 0
1724	: mpz_cmp__gmpz_cmp (ctr[d], end[d]) < 0)
1725	mpz_set__gmpz_set (ctr[d], start[d]);
1726	else
1727	incr_ctr = false;
1728	}
1729	}
1730
1731	limit = mpz_get_ui__gmpz_get_ui (ptr);
1732	if (limit >= flag_max_array_constructorglobal_options.x_flag_max_array_constructor)
1733	{
1734	gfc_error ("The number of elements in the array constructor "
1735	"at %L requires an increase of the allowed %d "
1736	"upper limit. See %<-fmax-array-constructor%> "
1737	"option", &expr->where, flag_max_array_constructorglobal_options.x_flag_max_array_constructor);
1738	return false;
1739	}
1740
1741	cons = gfc_constructor_lookup (base, limit);
1742	if (cons == NULL__null)
1743	{
1744	gfc_error ("Error in array constructor referenced at %L",
1745	&ref->u.ar.where);
1746	t = false;
1747	goto cleanup;
1748	}
1749	gfc_constructor_append_expr (&expr->value.constructor,
1750	gfc_copy_expr (cons->expr), NULL__null);
1751	}
1752
1753	mpz_clear__gmpz_clear (ptr);
1754
1755	cleanup:
1756
1757	mpz_clear__gmpz_clear (delta_mpz);
1758	mpz_clear__gmpz_clear (tmp_mpz);
1759	mpz_clear__gmpz_clear (nelts);
1760	for (d = 0; d < rank; d++)
1761	{
1762	mpz_clear__gmpz_clear (delta[d]);
1763	mpz_clear__gmpz_clear (start[d]);
1764	mpz_clear__gmpz_clear (end[d]);
1765	mpz_clear__gmpz_clear (ctr[d]);
1766	mpz_clear__gmpz_clear (stride[d]);
1767	}
1768	gfc_constructor_free (base);
1769	return t;
1770	}
1771
1772	/* Pull a substring out of an expression. */
1773
1774	static bool
1775	find_substring_ref (gfc_expr p, gfc_expr *newp)
1776	{
1777	gfc_charlen_t end;
1778	gfc_charlen_t start;
1779	gfc_charlen_t length;
1780	gfc_char_t *chr;
1781
1782	if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
1783	\|\| p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
1784	return false;
1785
1786	*newp = gfc_copy_expr (p);
1787	free ((*newp)->value.character.string);
1788
1789	end = (gfc_charlen_t) mpz_get_si__gmpz_get_si (p->ref->u.ss.end->value.integer);
1790	start = (gfc_charlen_t) mpz_get_si__gmpz_get_si (p->ref->u.ss.start->value.integer);
1791	if (end >= start)
1792	length = end - start + 1;
1793	else
1794	length = 0;
1795
1796	chr = (newp)->value.character.string = gfc_get_wide_string (length + 1)((gfc_char_t ) xcalloc ((length + 1), sizeof (gfc_char_t)));
1797	(*newp)->value.character.length = length;
1798	memcpy (chr, &p->value.character.string[start - 1],
1799	length * sizeof (gfc_char_t));
1800	chr[length] = '\0';
1801	return true;
1802	}
1803
1804
1805	/* Pull an inquiry result out of an expression. */
1806
1807	static bool
1808	find_inquiry_ref (gfc_expr p, gfc_expr *newp)
1809	{
1810	gfc_ref *ref;
1811	gfc_ref *inquiry = NULL__null;
1812	gfc_expr *tmp;
1813
1814	tmp = gfc_copy_expr (p);
1815
1816	if (tmp->ref && tmp->ref->type == REF_INQUIRY)
1817	{
1818	inquiry = tmp->ref;
1819	tmp->ref = NULL__null;
1820	}
1821	else
1822	{
1823	for (ref = tmp->ref; ref; ref = ref->next)
1824	if (ref->next && ref->next->type == REF_INQUIRY)
1825	{
1826	inquiry = ref->next;
1827	ref->next = NULL__null;
1828	}
1829	}
1830
1831	if (!inquiry)
1832	{
1833	gfc_free_expr (tmp);
1834	return false;
1835	}
1836
1837	gfc_resolve_expr (tmp);
1838
1839	/* In principle there can be more than one inquiry reference. */
1840	for (; inquiry; inquiry = inquiry->next)
1841	{
1842	switch (inquiry->u.i)
1843	{
1844	case INQUIRY_LEN:
1845	if (tmp->ts.type != BT_CHARACTER)
1846	goto cleanup;
1847
1848	if (!gfc_notify_std (GFC_STD_F2003(1<<4), "LEN part_ref at %C"))
1849	goto cleanup;
1850
1851	if (tmp->ts.u.cl->length
1852	&& tmp->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1853	*newp = gfc_copy_expr (tmp->ts.u.cl->length);
1854	else if (tmp->expr_type == EXPR_CONSTANT)
1855	*newp = gfc_get_int_expr (gfc_default_integer_kind,
1856	NULL__null, tmp->value.character.length);
1857	else
1858	goto cleanup;
1859
1860	break;
1861
1862	case INQUIRY_KIND:
1863	if (tmp->ts.type == BT_DERIVED \|\| tmp->ts.type == BT_CLASS)
1864	goto cleanup;
1865
1866	if (!gfc_notify_std (GFC_STD_F2003(1<<4), "KIND part_ref at %C"))
1867	goto cleanup;
1868
1869	*newp = gfc_get_int_expr (gfc_default_integer_kind,
1870	NULL__null, tmp->ts.kind);
1871	break;
1872
1873	case INQUIRY_RE:
1874	if (tmp->ts.type != BT_COMPLEX \|\| tmp->expr_type != EXPR_CONSTANT)
1875	goto cleanup;
1876
1877	if (!gfc_notify_std (GFC_STD_F2008(1<<7), "RE part_ref at %C"))
1878	goto cleanup;
1879
1880	*newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where);
1881	mpfr_set ((newp)->value.real,__extension__ ({ mpfr_srcptr _p = (((tmp->value.complex)-> re)); mpfr_set4((newp)->value.real,_p,MPFR_RNDN,((_p)-> _mpfr_sign)); })
1882	mpc_realref (tmp->value.complex), GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (((tmp->value.complex)-> re)); mpfr_set4((*newp)->value.real,_p,MPFR_RNDN,((_p)-> _mpfr_sign)); });
1883	break;
1884
1885	case INQUIRY_IM:
1886	if (tmp->ts.type != BT_COMPLEX \|\| tmp->expr_type != EXPR_CONSTANT)
1887	goto cleanup;
1888
1889	if (!gfc_notify_std (GFC_STD_F2008(1<<7), "IM part_ref at %C"))
1890	goto cleanup;
1891
1892	*newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where);
1893	mpfr_set ((newp)->value.real,__extension__ ({ mpfr_srcptr _p = (((tmp->value.complex)-> im)); mpfr_set4((newp)->value.real,_p,MPFR_RNDN,((_p)-> _mpfr_sign)); })
1894	mpc_imagref (tmp->value.complex), GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (((tmp->value.complex)-> im)); mpfr_set4((*newp)->value.real,_p,MPFR_RNDN,((_p)-> _mpfr_sign)); });
1895	break;
1896	}
1897	tmp = gfc_copy_expr (*newp);
1898	}
1899
1900	if (!(*newp))
1901	goto cleanup;
1902	else if ((*newp)->expr_type != EXPR_CONSTANT)
1903	{
1904	gfc_free_expr (*newp);
1905	goto cleanup;
1906	}
1907
1908	gfc_free_expr (tmp);
1909	return true;
1910
1911	cleanup:
1912	gfc_free_expr (tmp);
1913	return false;
1914	}
1915
1916
1917
1918	/* Simplify a subobject reference of a constructor. This occurs when
1919	parameter variable values are substituted. */
1920
1921	static bool
1922	simplify_const_ref (gfc_expr *p)
1923	{
1924	gfc_constructor cons, c;
1925	gfc_expr *newp = NULL__null;
1926	gfc_ref *last_ref;
1927
1928	while (p->ref)
1929	{
1930	switch (p->ref->type)
1931	{
1932	case REF_ARRAY:
1933	switch (p->ref->u.ar.type)
1934	{
1935	case AR_ELEMENT:
1936	/* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1937	will generate this. */
1938	if (p->expr_type != EXPR_ARRAY)
1939	{
1940	remove_subobject_ref (p, NULL__null);
1941	break;
1942	}
1943	if (!find_array_element (p->value.constructor, &p->ref->u.ar, &cons))
1944	return false;
1945
1946	if (!cons)
1947	return true;
1948
1949	remove_subobject_ref (p, cons);
1950	break;
1951
1952	case AR_SECTION:
1953	if (!find_array_section (p, p->ref))
1954	return false;
1955	p->ref->u.ar.type = AR_FULL;
1956
1957	/* Fall through. */
1958
1959	case AR_FULL:
1960	if (p->ref->next != NULL__null
1961	&& (p->ts.type == BT_CHARACTER \|\| gfc_bt_struct (p->ts.type)((p->ts.type) == BT_DERIVED \|\| (p->ts.type) == BT_UNION )))
1962	{
1963	for (c = gfc_constructor_first (p->value.constructor);
1964	c; c = gfc_constructor_next (c))
1965	{
1966	c->expr->ref = gfc_copy_ref (p->ref->next);
1967	if (!simplify_const_ref (c->expr))
1968	return false;
1969	}
1970
1971	if (gfc_bt_struct (p->ts.type)((p->ts.type) == BT_DERIVED \|\| (p->ts.type) == BT_UNION )
1972	&& p->ref->next
1973	&& (c = gfc_constructor_first (p->value.constructor)))
1974	{
1975	/* There may have been component references. */
1976	p->ts = c->expr->ts;
1977	}
1978
1979	last_ref = p->ref;
1980	for (; last_ref->next; last_ref = last_ref->next) {};
1981
1982	if (p->ts.type == BT_CHARACTER
1983	&& last_ref->type == REF_SUBSTRING)
1984	{
1985	/* If this is a CHARACTER array and we possibly took
1986	a substring out of it, update the type-spec's
1987	character length according to the first element
1988	(as all should have the same length). */
1989	gfc_charlen_t string_len;
1990	if ((c = gfc_constructor_first (p->value.constructor)))
1991	{
1992	const gfc_expr* first = c->expr;
1993	gcc_assert (first->expr_type == EXPR_CONSTANT)((void)(!(first->expr_type == EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 1993, __FUNCTION__), 0 : 0));
1994	gcc_assert (first->ts.type == BT_CHARACTER)((void)(!(first->ts.type == BT_CHARACTER) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 1994, __FUNCTION__), 0 : 0));
1995	string_len = first->value.character.length;
1996	}
1997	else
1998	string_len = 0;
1999
2000	if (!p->ts.u.cl)
2001	{
2002	if (p->symtree)
2003	p->ts.u.cl = gfc_new_charlen (p->symtree->n.sym->ns,
2004	NULL__null);
2005	else
2006	p->ts.u.cl = gfc_new_charlen (gfc_current_ns,
2007	NULL__null);
2008	}
2009	else
2010	gfc_free_expr (p->ts.u.cl->length);
2011
2012	p->ts.u.cl->length
2013	= gfc_get_int_expr (gfc_charlen_int_kind,
2014	NULL__null, string_len);
2015	}
2016	}
2017	gfc_free_ref_list (p->ref);
2018	p->ref = NULL__null;
2019	break;
2020
2021	default:
2022	return true;
2023	}
2024
2025	break;
2026
2027	case REF_COMPONENT:
2028	cons = find_component_ref (p->value.constructor, p->ref);
2029	remove_subobject_ref (p, cons);
2030	break;
2031
2032	case REF_INQUIRY:
2033	if (!find_inquiry_ref (p, &newp))
2034	return false;
2035
2036	gfc_replace_expr (p, newp);
2037	gfc_free_ref_list (p->ref);
2038	p->ref = NULL__null;
2039	break;
2040
2041	case REF_SUBSTRING:
2042	if (!find_substring_ref (p, &newp))
2043	return false;
2044
2045	gfc_replace_expr (p, newp);
2046	gfc_free_ref_list (p->ref);
2047	p->ref = NULL__null;
2048	break;
2049	}
2050	}
2051
2052	return true;
2053	}
2054
2055
2056	/* Simplify a chain of references. */
2057
2058	static bool
2059	simplify_ref_chain (gfc_ref ref, int type, gfc_expr *p)
2060	{
2061	int n;
2062	gfc_expr *newp;
2063
2064	for (; ref; ref = ref->next)
2065	{
2066	switch (ref->type)
2067	{
2068	case REF_ARRAY:
2069	for (n = 0; n < ref->u.ar.dimen; n++)
2070	{
2071	if (!gfc_simplify_expr (ref->u.ar.start[n], type))
2072	return false;
2073	if (!gfc_simplify_expr (ref->u.ar.end[n], type))
2074	return false;
2075	if (!gfc_simplify_expr (ref->u.ar.stride[n], type))
2076	return false;
2077	}
2078	break;
2079
2080	case REF_SUBSTRING:
2081	if (!gfc_simplify_expr (ref->u.ss.start, type))
2082	return false;
2083	if (!gfc_simplify_expr (ref->u.ss.end, type))
2084	return false;
2085	break;
2086
2087	case REF_INQUIRY:
2088	if (!find_inquiry_ref (*p, &newp))
2089	return false;
2090
2091	gfc_replace_expr (*p, newp);
2092	gfc_free_ref_list ((*p)->ref);
2093	(*p)->ref = NULL__null;
2094	return true;
2095
2096	default:
2097	break;
2098	}
2099	}
2100	return true;
2101	}
2102
2103
2104	/* Try to substitute the value of a parameter variable. */
2105
2106	static bool
2107	simplify_parameter_variable (gfc_expr *p, int type)
2108	{
2109	gfc_expr *e;
2110	bool t;
2111
2112	/* Set rank and check array ref; as resolve_variable calls
2113	gfc_simplify_expr, call gfc_resolve_ref + gfc_expression_rank instead. */
2114	if (!gfc_resolve_ref (p))
2115	{
2116	gfc_error_check ();
2117	return false;
2118	}
2119	gfc_expression_rank (p);
2120
2121	/* Is this an inquiry? */
2122	bool inquiry = false;
2123	gfc_ref* ref = p->ref;
2124	while (ref)
2125	{
2126	if (ref->type == REF_INQUIRY)
2127	break;
2128	ref = ref->next;
2129	}
2130	if (ref && ref->type == REF_INQUIRY)
2131	inquiry = ref->u.i == INQUIRY_LEN \|\| ref->u.i == INQUIRY_KIND;
2132
2133	if (gfc_is_size_zero_array (p))
2134	{
2135	if (p->expr_type == EXPR_ARRAY)
2136	return true;
2137
2138	e = gfc_get_expr ();
2139	e->expr_type = EXPR_ARRAY;
2140	e->ts = p->ts;
2141	e->rank = p->rank;
2142	e->value.constructor = NULL__null;
2143	e->shape = gfc_copy_shape (p->shape, p->rank);
2144	e->where = p->where;
2145	/* If %kind and %len are not used then we're done, otherwise
2146	drop through for simplification. */
2147	if (!inquiry)
2148	{
2149	gfc_replace_expr (p, e);
2150	return true;
2151	}
2152	}
2153	else
2154	{
2155	e = gfc_copy_expr (p->symtree->n.sym->value);
2156	if (e == NULL__null)
2157	return false;
2158
2159	gfc_free_shape (&e->shape, e->rank);
2160	e->shape = gfc_copy_shape (p->shape, p->rank);
2161	e->rank = p->rank;
2162
2163	if (e->ts.type == BT_CHARACTER && p->ts.u.cl)
2164	e->ts = p->ts;
2165	}
2166
2167	if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL__null)
2168	e->ts.u.cl = gfc_new_charlen (gfc_current_ns, p->ts.u.cl);
2169
2170	/* Do not copy subobject refs for constant. */
2171	if (e->expr_type != EXPR_CONSTANT && p->ref != NULL__null)
2172	e->ref = gfc_copy_ref (p->ref);
2173	t = gfc_simplify_expr (e, type);
2174	e->where = p->where;
2175
2176	/* Only use the simplification if it eliminated all subobject references. */
2177	if (t && !e->ref)
2178	gfc_replace_expr (p, e);
2179	else
2180	gfc_free_expr (e);
2181
2182	return t;
2183	}
2184
2185
2186	static bool
2187	scalarize_intrinsic_call (gfc_expr *, bool init_flag);
2188
2189	/* Given an expression, simplify it by collapsing constant
2190	expressions. Most simplification takes place when the expression
2191	tree is being constructed. If an intrinsic function is simplified
2192	at some point, we get called again to collapse the result against
2193	other constants.
2194
2195	We work by recursively simplifying expression nodes, simplifying
2196	intrinsic functions where possible, which can lead to further
2197	constant collapsing. If an operator has constant operand(s), we
2198	rip the expression apart, and rebuild it, hoping that it becomes
2199	something simpler.
2200
2201	The expression type is defined for:
2202	0 Basic expression parsing
2203	1 Simplifying array constructors -- will substitute
2204	iterator values.
2205	Returns false on error, true otherwise.
2206	NOTE: Will return true even if the expression cannot be simplified. */
2207
2208	bool
2209	gfc_simplify_expr (gfc_expr *p, int type)
2210	{
2211	gfc_actual_arglist *ap;
2212	gfc_intrinsic_sym* isym = NULL__null;
2213
2214
2215	if (p == NULL__null)
2216	return true;
2217
2218	switch (p->expr_type)
2219	{
2220	case EXPR_CONSTANT:
2221	if (p->ref && p->ref->type == REF_INQUIRY)
2222	simplify_ref_chain (p->ref, type, &p);
2223	break;
2224	case EXPR_NULL:
2225	break;
2226
2227	case EXPR_FUNCTION:
2228	// For array-bound functions, we don't need to optimize
2229	// the 'array' argument. In particular, if the argument
2230	// is a PARAMETER, simplifying might convert an EXPR_VARIABLE
2231	// into an EXPR_ARRAY; the latter has lbound = 1, the former
2232	// can have any lbound.
2233	ap = p->value.function.actual;
2234	if (p->value.function.isym &&
2235	(p->value.function.isym->id == GFC_ISYM_LBOUND
2236	\|\| p->value.function.isym->id == GFC_ISYM_UBOUND
2237	\|\| p->value.function.isym->id == GFC_ISYM_LCOBOUND
2238	\|\| p->value.function.isym->id == GFC_ISYM_UCOBOUND
2239	\|\| p->value.function.isym->id == GFC_ISYM_SHAPE))
2240	ap = ap->next;
2241
2242	for ( ; ap; ap = ap->next)
2243	if (!gfc_simplify_expr (ap->expr, type))
2244	return false;
2245
2246	if (p->value.function.isym != NULL__null
2247	&& gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR)
2248	return false;
2249
2250	if (p->symtree && (p->value.function.isym \|\| p->ts.type == BT_UNKNOWN))
2251	{
2252	isym = gfc_find_function (p->symtree->n.sym->name);
2253	if (isym && isym->elemental)
2254	scalarize_intrinsic_call (p, false);
2255	}
2256
2257	break;
2258
2259	case EXPR_SUBSTRING:
2260	if (!simplify_ref_chain (p->ref, type, &p))
2261	return false;
2262
2263	if (gfc_is_constant_expr (p))
2264	{
2265	gfc_char_t *s;
2266	HOST_WIDE_INTlong start, end;
2267
2268	start = 0;
2269	if (p->ref && p->ref->u.ss.start)
2270	{
2271	gfc_extract_hwi (p->ref->u.ss.start, &start);
2272	start--; /* Convert from one-based to zero-based. */
2273	}
2274
2275	end = p->value.character.length;
2276	if (p->ref && p->ref->u.ss.end)
2277	gfc_extract_hwi (p->ref->u.ss.end, &end);
2278
2279	if (end < start)
2280	end = start;
2281
2282	s = gfc_get_wide_string (end - start + 2)((gfc_char_t *) xcalloc ((end - start + 2), sizeof (gfc_char_t )));
2283	memcpy (s, p->value.character.string + start,
2284	(end - start) * sizeof (gfc_char_t));
2285	s[end - start + 1] = '\0'; /* TODO: C-style string. */
2286	free (p->value.character.string);
2287	p->value.character.string = s;
2288	p->value.character.length = end - start;
2289	p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL__null);
2290	p->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
2291	NULL__null,
2292	p->value.character.length);
2293	gfc_free_ref_list (p->ref);
2294	p->ref = NULL__null;
2295	p->expr_type = EXPR_CONSTANT;
2296	}
2297	break;
2298
2299	case EXPR_OP:
2300	if (!simplify_intrinsic_op (p, type))
2301	return false;
2302	break;
2303
2304	case EXPR_VARIABLE:
2305	/* Only substitute array parameter variables if we are in an
2306	initialization expression, or we want a subsection. */
2307	if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
2308	&& (gfc_init_expr_flag \|\| p->ref
2309	\|\| (p->symtree->n.sym->value
2310	&& p->symtree->n.sym->value->expr_type != EXPR_ARRAY)))
2311	{
2312	if (!simplify_parameter_variable (p, type))
2313	return false;
2314	break;
2315	}
2316
2317	if (type == 1)
2318	{
2319	gfc_simplify_iterator_var (p);
2320	}
2321
2322	/* Simplify subcomponent references. */
2323	if (!simplify_ref_chain (p->ref, type, &p))
2324	return false;
2325
2326	break;
2327
2328	case EXPR_STRUCTURE:
2329	case EXPR_ARRAY:
2330	if (!simplify_ref_chain (p->ref, type, &p))
2331	return false;
2332
2333	/* If the following conditions hold, we found something like kind type
2334	inquiry of the form a(2)%kind while simplify the ref chain. */
2335	if (p->expr_type == EXPR_CONSTANT && !p->ref && !p->rank && !p->shape)
2336	return true;
2337
2338	if (!simplify_constructor (p->value.constructor, type))
2339	return false;
2340
2341	if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY
2342	&& p->ref->u.ar.type == AR_FULL)
2343	gfc_expand_constructor (p, false);
2344
2345	if (!simplify_const_ref (p))
2346	return false;
2347
2348	break;
2349
2350	case EXPR_COMPCALL:
2351	case EXPR_PPC:
2352	break;
2353
2354	case EXPR_UNKNOWN:
2355	gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 2355, __FUNCTION__));
2356	}
2357
2358	return true;
2359	}
2360
2361
2362	/* Try simplification of an expression via gfc_simplify_expr.
2363	When an error occurs (arithmetic or otherwise), roll back. */
2364
2365	bool
2366	gfc_try_simplify_expr (gfc_expr *e, int type)
2367	{
2368	gfc_expr *n;
2369	bool t, saved_div0;
2370
2371	if (e == NULL__null \|\| e->expr_type == EXPR_CONSTANT)
2372	return true;
2373
2374	saved_div0 = gfc_seen_div0;
2375	gfc_seen_div0 = false;
2376	n = gfc_copy_expr (e);
2377	t = gfc_simplify_expr (n, type) && !gfc_seen_div0;
2378	if (t)
2379	gfc_replace_expr (e, n);
2380	else
2381	gfc_free_expr (n);
2382	gfc_seen_div0 = saved_div0;
2383	return t;
2384	}
2385
2386
2387	/* Returns the type of an expression with the exception that iterator
2388	variables are automatically integers no matter what else they may
2389	be declared as. */
2390
2391	static bt
2392	et0 (gfc_expr *e)
2393	{
2394	if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e))
2395	return BT_INTEGER;
2396
2397	return e->ts.type;
2398	}
2399
2400
2401	/* Scalarize an expression for an elemental intrinsic call. */
2402
2403	static bool
2404	scalarize_intrinsic_call (gfc_expr *e, bool init_flag)
2405	{
2406	gfc_actual_arglist a, b;
2407	gfc_constructor_base ctor;
2408	gfc_constructor args[5] = {}; / Avoid uninitialized warnings. */
2409	gfc_constructor ci, new_ctor;
2410	gfc_expr expr, old, *p;
2411	int n, i, rank[5], array_arg;
2412
2413	if (e == NULL__null)
2414	return false;
2415
2416	a = e->value.function.actual;
2417	for (; a; a = a->next)
2418	if (a->expr && !gfc_is_constant_expr (a->expr))
2419	return false;
2420
2421	/* Find which, if any, arguments are arrays. Assume that the old
2422	expression carries the type information and that the first arg
2423	that is an array expression carries all the shape information.*/
2424	n = array_arg = 0;
2425	a = e->value.function.actual;
2426	for (; a; a = a->next)
2427	{
2428	n++;
2429	if (!a->expr \|\| a->expr->expr_type != EXPR_ARRAY)
2430	continue;
2431	array_arg = n;
2432	expr = gfc_copy_expr (a->expr);
2433	break;
2434	}
2435
2436	if (!array_arg)
2437	return false;
2438
2439	old = gfc_copy_expr (e);
2440
2441	gfc_constructor_free (expr->value.constructor);
2442	expr->value.constructor = NULL__null;
2443	expr->ts = old->ts;
2444	expr->where = old->where;
2445	expr->expr_type = EXPR_ARRAY;
2446
2447	/* Copy the array argument constructors into an array, with nulls
2448	for the scalars. */
2449	n = 0;
2450	a = old->value.function.actual;
2451	for (; a; a = a->next)
2452	{
2453	/* Check that this is OK for an initialization expression. */
2454	if (a->expr && init_flag && !gfc_check_init_expr (a->expr))
2455	goto cleanup;
2456
2457	rank[n] = 0;
2458	if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE)
2459	{
2460	rank[n] = a->expr->rank;
2461	ctor = a->expr->symtree->n.sym->value->value.constructor;
2462	args[n] = gfc_constructor_first (ctor);
2463	}
2464	else if (a->expr && a->expr->expr_type == EXPR_ARRAY)
2465	{
2466	if (a->expr->rank)
2467	rank[n] = a->expr->rank;
2468	else
2469	rank[n] = 1;
2470	ctor = gfc_constructor_copy (a->expr->value.constructor);
2471	args[n] = gfc_constructor_first (ctor);
2472	}
2473	else
2474	args[n] = NULL__null;
2475
2476	n++;
2477	}
2478
2479	/* Using the array argument as the master, step through the array
2480	calling the function for each element and advancing the array
2481	constructors together. */
2482	for (ci = args[array_arg - 1]; ci; ci = gfc_constructor_next (ci))
2483	{
2484	new_ctor = gfc_constructor_append_expr (&expr->value.constructor,
2485	gfc_copy_expr (old), NULL__null);
2486
2487	gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
2488	a = NULL__null;
2489	b = old->value.function.actual;
2490	for (i = 0; i < n; i++)
2491	{
2492	if (a == NULL__null)
2493	new_ctor->expr->value.function.actual
2494	= a = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist )));
2495	else
2496	{
2497	a->next = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist )));
2498	a = a->next;
2499	}
2500
2501	if (args[i])
2502	a->expr = gfc_copy_expr (args[i]->expr);
2503	else
2504	a->expr = gfc_copy_expr (b->expr);
2505
2506	b = b->next;
2507	}
2508
2509	/* Simplify the function calls. If the simplification fails, the
2510	error will be flagged up down-stream or the library will deal
2511	with it. */
2512	p = gfc_copy_expr (new_ctor->expr);
2513
2514	if (!gfc_simplify_expr (p, init_flag))
2515	gfc_free_expr (p);
2516	else
2517	gfc_replace_expr (new_ctor->expr, p);
2518
2519	for (i = 0; i < n; i++)
2520	if (args[i])
2521	args[i] = gfc_constructor_next (args[i]);
2522
2523	for (i = 1; i < n; i++)
2524	if (rank[i] && ((args[i] != NULL__null && args[array_arg - 1] == NULL__null)
2525	\|\| (args[i] == NULL__null && args[array_arg - 1] != NULL__null)))
2526	goto compliance;
2527	}
2528
2529	free_expr0 (e);
2530	e = expr;
2531	/* Free "expr" but not the pointers it contains. */
2532	free (expr);
2533	gfc_free_expr (old);
2534	return true;
2535
2536	compliance:
2537	gfc_error_now ("elemental function arguments at %C are not compliant");
2538
2539	cleanup:
2540	gfc_free_expr (expr);
2541	gfc_free_expr (old);
2542	return false;
2543	}
2544
2545
2546	static bool
2547	check_intrinsic_op (gfc_expr e, bool (check_function) (gfc_expr *))
2548	{
2549	gfc_expr *op1 = e->value.op.op1;
2550	gfc_expr *op2 = e->value.op.op2;
2551
2552	if (!(*check_function)(op1))
2553	return false;
2554
2555	switch (e->value.op.op)
2556	{
2557	case INTRINSIC_UPLUS:
2558	case INTRINSIC_UMINUS:
2559	if (!numeric_type (et0 (op1)))
2560	goto not_numeric;
2561	break;
2562
2563	case INTRINSIC_EQ:
2564	case INTRINSIC_EQ_OS:
2565	case INTRINSIC_NE:
2566	case INTRINSIC_NE_OS:
2567	case INTRINSIC_GT:
2568	case INTRINSIC_GT_OS:
2569	case INTRINSIC_GE:
2570	case INTRINSIC_GE_OS:
2571	case INTRINSIC_LT:
2572	case INTRINSIC_LT_OS:
2573	case INTRINSIC_LE:
2574	case INTRINSIC_LE_OS:
2575	if (!(*check_function)(op2))
2576	return false;
2577
2578	if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
2579	&& !(numeric_type (et0 (op1)) && numeric_type (et0 (op2))))
2580	{
2581	gfc_error ("Numeric or CHARACTER operands are required in "
2582	"expression at %L", &e->where);
2583	return false;
2584	}
2585	break;
2586
2587	case INTRINSIC_PLUS:
2588	case INTRINSIC_MINUS:
2589	case INTRINSIC_TIMES:
2590	case INTRINSIC_DIVIDE:
2591	case INTRINSIC_POWER:
2592	if (!(*check_function)(op2))
2593	return false;
2594
2595	if (!numeric_type (et0 (op1)) \|\| !numeric_type (et0 (op2)))
2596	goto not_numeric;
2597
2598	break;
2599
2600	case INTRINSIC_CONCAT:
2601	if (!(*check_function)(op2))
2602	return false;
2603
2604	if (et0 (op1) != BT_CHARACTER \|\| et0 (op2) != BT_CHARACTER)
2605	{
2606	gfc_error ("Concatenation operator in expression at %L "
2607	"must have two CHARACTER operands", &op1->where);
2608	return false;
2609	}
2610
2611	if (op1->ts.kind != op2->ts.kind)
2612	{
2613	gfc_error ("Concat operator at %L must concatenate strings of the "
2614	"same kind", &e->where);
2615	return false;
2616	}
2617
2618	break;
2619
2620	case INTRINSIC_NOT:
2621	if (et0 (op1) != BT_LOGICAL)
2622	{
2623	gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2624	"operand", &op1->where);
2625	return false;
2626	}
2627
2628	break;
2629
2630	case INTRINSIC_AND:
2631	case INTRINSIC_OR:
2632	case INTRINSIC_EQV:
2633	case INTRINSIC_NEQV:
2634	if (!(*check_function)(op2))
2635	return false;
2636
2637	if (et0 (op1) != BT_LOGICAL \|\| et0 (op2) != BT_LOGICAL)
2638	{
2639	gfc_error ("LOGICAL operands are required in expression at %L",
2640	&e->where);
2641	return false;
2642	}
2643
2644	break;
2645
2646	case INTRINSIC_PARENTHESES:
2647	break;
2648
2649	default:
2650	gfc_error ("Only intrinsic operators can be used in expression at %L",
2651	&e->where);
2652	return false;
2653	}
2654
2655	return true;
2656
2657	not_numeric:
2658	gfc_error ("Numeric operands are required in expression at %L", &e->where);
2659
2660	return false;
2661	}
2662
2663	/* F2003, 7.1.7 (3): In init expression, allocatable components
2664	must not be data-initialized. */
2665	static bool
2666	check_alloc_comp_init (gfc_expr *e)
2667	{
2668	gfc_component *comp;
2669	gfc_constructor *ctor;
2670
2671	gcc_assert (e->expr_type == EXPR_STRUCTURE)((void)(!(e->expr_type == EXPR_STRUCTURE) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 2671, __FUNCTION__), 0 : 0));
2672	gcc_assert (e->ts.type == BT_DERIVED \|\| e->ts.type == BT_CLASS)((void)(!(e->ts.type == BT_DERIVED \|\| e->ts.type == BT_CLASS ) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 2672, __FUNCTION__), 0 : 0));
2673
2674	for (comp = e->ts.u.derived->components,
2675	ctor = gfc_constructor_first (e->value.constructor);
2676	comp; comp = comp->next, ctor = gfc_constructor_next (ctor))
2677	{
2678	if (comp->attr.allocatable && ctor->expr
2679	&& ctor->expr->expr_type != EXPR_NULL)
2680	{
2681	gfc_error ("Invalid initialization expression for ALLOCATABLE "
2682	"component %qs in structure constructor at %L",
2683	comp->name, &ctor->expr->where);
2684	return false;
2685	}
2686	}
2687
2688	return true;
2689	}
2690
2691	static match
2692	check_init_expr_arguments (gfc_expr *e)
2693	{
2694	gfc_actual_arglist *ap;
2695
2696	for (ap = e->value.function.actual; ap; ap = ap->next)
2697	if (!gfc_check_init_expr (ap->expr))
2698	return MATCH_ERROR;
2699
2700	return MATCH_YES;
2701	}
2702
2703	static bool check_restricted (gfc_expr *);
2704
2705	/* F95, 7.1.6.1, Initialization expressions, (7)
2706	F2003, 7.1.7 Initialization expression, (8)
2707	F2008, 7.1.12 Constant expression, (4) */
2708
2709	static match
2710	check_inquiry (gfc_expr *e, int not_restricted)
2711	{
2712	const char *name;
2713	const char const functions;
2714
2715	static const char *const inquiry_func_f95[] = {
2716	"lbound", "shape", "size", "ubound",
2717	"bit_size", "len", "kind",
2718	"digits", "epsilon", "huge", "maxexponent", "minexponent",
2719	"precision", "radix", "range", "tiny",
2720	NULL__null
2721	};
2722
2723	static const char *const inquiry_func_f2003[] = {
2724	"lbound", "shape", "size", "ubound",
2725	"bit_size", "len", "kind",
2726	"digits", "epsilon", "huge", "maxexponent", "minexponent",
2727	"precision", "radix", "range", "tiny",
2728	"new_line", NULL__null
2729	};
2730
2731	/* std=f2008+ or -std=gnu */
2732	static const char *const inquiry_func_gnu[] = {
2733	"lbound", "shape", "size", "ubound",
2734	"bit_size", "len", "kind",
2735	"digits", "epsilon", "huge", "maxexponent", "minexponent",
2736	"precision", "radix", "range", "tiny",
2737	"new_line", "storage_size", NULL__null
2738	};
2739
2740	int i = 0;
2741	gfc_actual_arglist *ap;
2742	gfc_symbol *sym;
2743	gfc_symbol *asym;
2744
2745	if (!e->value.function.isym
2746	\|\| !e->value.function.isym->inquiry)
2747	return MATCH_NO;
2748
2749	/* An undeclared parameter will get us here (PR25018). */
2750	if (e->symtree == NULL__null)
2751	return MATCH_NO;
2752
2753	sym = e->symtree->n.sym;
2754
2755	if (sym->from_intmod)
2756	{
2757	if (sym->from_intmod == INTMOD_ISO_FORTRAN_ENV
2758	&& sym->intmod_sym_id != ISOFORTRAN_COMPILER_OPTIONS
2759	&& sym->intmod_sym_id != ISOFORTRAN_COMPILER_VERSION)
2760	return MATCH_NO;
2761
2762	if (sym->from_intmod == INTMOD_ISO_C_BINDING
2763	&& sym->intmod_sym_id != ISOCBINDING_C_SIZEOF)
2764	return MATCH_NO;
2765	}
2766	else
2767	{
2768	name = sym->name;
2769
2770	functions = inquiry_func_gnu;
2771	if (gfc_option.warn_std & GFC_STD_F2003(1<<4))
2772	functions = inquiry_func_f2003;
2773	if (gfc_option.warn_std & GFC_STD_F95(1<<3))
2774	functions = inquiry_func_f95;
2775
2776	for (i = 0; functions[i]; i++)
2777	if (strcmp (functions[i], name) == 0)
2778	break;
2779
2780	if (functions[i] == NULL__null)
2781	return MATCH_ERROR;
2782	}
2783
2784	/* At this point we have an inquiry function with a variable argument. The
2785	type of the variable might be undefined, but we need it now, because the
2786	arguments of these functions are not allowed to be undefined. */
2787
2788	for (ap = e->value.function.actual; ap; ap = ap->next)
2789	{
2790	if (!ap->expr)
2791	continue;
2792
2793	asym = ap->expr->symtree ? ap->expr->symtree->n.sym : NULL__null;
2794
2795	if (ap->expr->ts.type == BT_UNKNOWN)
2796	{
2797	if (asym && asym->ts.type == BT_UNKNOWN
2798	&& !gfc_set_default_type (asym, 0, gfc_current_ns))
2799	return MATCH_NO;
2800
2801	ap->expr->ts = asym->ts;
2802	}
2803
2804	if (asym && asym->assoc && asym->assoc->target
2805	&& asym->assoc->target->expr_type == EXPR_CONSTANT)
2806	{
2807	gfc_free_expr (ap->expr);
2808	ap->expr = gfc_copy_expr (asym->assoc->target);
2809	}
2810
2811	/* Assumed character length will not reduce to a constant expression
2812	with LEN, as required by the standard. */
2813	if (i == 5 && not_restricted && asym
2814	&& asym->ts.type == BT_CHARACTER
2815	&& ((asym->ts.u.cl && asym->ts.u.cl->length == NULL__null)
2816	\|\| asym->ts.deferred))
2817	{
2818	gfc_error ("Assumed or deferred character length variable %qs "
2819	"in constant expression at %L",
2820	asym->name, &ap->expr->where);
2821	return MATCH_ERROR;
2822	}
2823	else if (not_restricted && !gfc_check_init_expr (ap->expr))
2824	return MATCH_ERROR;
2825
2826	if (not_restricted == 0
2827	&& ap->expr->expr_type != EXPR_VARIABLE
2828	&& !check_restricted (ap->expr))
2829	return MATCH_ERROR;
2830
2831	if (not_restricted == 0
2832	&& ap->expr->expr_type == EXPR_VARIABLE
2833	&& asym->attr.dummy && asym->attr.optional)
2834	return MATCH_NO;
2835	}
2836
2837	return MATCH_YES;
2838	}
2839
2840
2841	/* F95, 7.1.6.1, Initialization expressions, (5)
2842	F2003, 7.1.7 Initialization expression, (5) */
2843
2844	static match
2845	check_transformational (gfc_expr *e)
2846	{
2847	static const char * const trans_func_f95[] = {
2848	"repeat", "reshape", "selected_int_kind",
2849	"selected_real_kind", "transfer", "trim", NULL__null
2850	};
2851
2852	static const char * const trans_func_f2003[] = {
2853	"all", "any", "count", "dot_product", "matmul", "null", "pack",
2854	"product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2855	"selected_real_kind", "spread", "sum", "transfer", "transpose",
2856	"trim", "unpack", NULL__null
2857	};
2858
2859	static const char * const trans_func_f2008[] = {
2860	"all", "any", "count", "dot_product", "matmul", "null", "pack",
2861	"product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2862	"selected_real_kind", "spread", "sum", "transfer", "transpose",
2863	"trim", "unpack", "findloc", NULL__null
2864	};
2865
2866	int i;
2867	const char *name;
2868	const char const functions;
2869
2870	if (!e->value.function.isym
2871	\|\| !e->value.function.isym->transformational)
2872	return MATCH_NO;
2873
2874	name = e->symtree->n.sym->name;
2875
2876	if (gfc_option.allow_std & GFC_STD_F2008(1<<7))
2877	functions = trans_func_f2008;
2878	else if (gfc_option.allow_std & GFC_STD_F2003(1<<4))
2879	functions = trans_func_f2003;
2880	else
2881	functions = trans_func_f95;
2882
2883	/* NULL() is dealt with below. */
2884	if (strcmp ("null", name) == 0)
2885	return MATCH_NO;
2886
2887	for (i = 0; functions[i]; i++)
2888	if (strcmp (functions[i], name) == 0)
2889	break;
2890
2891	if (functions[i] == NULL__null)
2892	{
2893	gfc_error ("transformational intrinsic %qs at %L is not permitted "
2894	"in an initialization expression", name, &e->where);
2895	return MATCH_ERROR;
2896	}
2897
2898	return check_init_expr_arguments (e);
2899	}
2900
2901
2902	/* F95, 7.1.6.1, Initialization expressions, (6)
2903	F2003, 7.1.7 Initialization expression, (6) */
2904
2905	static match
2906	check_null (gfc_expr *e)
2907	{
2908	if (strcmp ("null", e->symtree->n.sym->name) != 0)
2909	return MATCH_NO;
2910
2911	return check_init_expr_arguments (e);
2912	}
2913
2914
2915	static match
2916	check_elemental (gfc_expr *e)
2917	{
2918	if (!e->value.function.isym
2919	\|\| !e->value.function.isym->elemental)
2920	return MATCH_NO;
2921
2922	if (e->ts.type != BT_INTEGER
2923	&& e->ts.type != BT_CHARACTER
2924	&& !gfc_notify_std (GFC_STD_F2003(1<<4), "Evaluation of nonstandard "
2925	"initialization expression at %L", &e->where))
2926	return MATCH_ERROR;
2927
2928	return check_init_expr_arguments (e);
2929	}
2930
2931
2932	static match
2933	check_conversion (gfc_expr *e)
2934	{
2935	if (!e->value.function.isym
2936	\|\| !e->value.function.isym->conversion)
2937	return MATCH_NO;
2938
2939	return check_init_expr_arguments (e);
2940	}
2941
2942
2943	/* Verify that an expression is an initialization expression. A side
2944	effect is that the expression tree is reduced to a single constant
2945	node if all goes well. This would normally happen when the
2946	expression is constructed but function references are assumed to be
2947	intrinsics in the context of initialization expressions. If
2948	false is returned an error message has been generated. */
2949
2950	bool
2951	gfc_check_init_expr (gfc_expr *e)
2952	{
2953	match m;
2954	bool t;
2955
2956	if (e == NULL__null)
2957	return true;
2958
2959	switch (e->expr_type)
2960	{
2961	case EXPR_OP:
2962	t = check_intrinsic_op (e, gfc_check_init_expr);
2963	if (t)
2964	t = gfc_simplify_expr (e, 0);
2965
2966	break;
2967
2968	case EXPR_FUNCTION:
2969	t = false;
2970
2971	{
2972	bool conversion;
2973	gfc_intrinsic_sym* isym = NULL__null;
2974	gfc_symbol* sym = e->symtree->n.sym;
2975
2976	/* Simplify here the intrinsics from the IEEE_ARITHMETIC and
2977	IEEE_EXCEPTIONS modules. */
2978	int mod = sym->from_intmod;
2979	if (mod == INTMOD_NONE && sym->generic)
2980	mod = sym->generic->sym->from_intmod;
2981	if (mod == INTMOD_IEEE_ARITHMETIC \|\| mod == INTMOD_IEEE_EXCEPTIONS)
2982	{
2983	gfc_expr *new_expr = gfc_simplify_ieee_functions (e);
2984	if (new_expr)
2985	{
2986	gfc_replace_expr (e, new_expr);
2987	t = true;
2988	break;
2989	}
2990	}
2991
2992	/* If a conversion function, e.g., __convert_i8_i4, was inserted
2993	into an array constructor, we need to skip the error check here.
2994	Conversion errors are caught below in scalarize_intrinsic_call. */
2995	conversion = e->value.function.isym
2996	&& (e->value.function.isym->conversion == 1);
2997
2998	if (!conversion && (!gfc_is_intrinsic (sym, 0, e->where)
2999	\|\| (m = gfc_intrinsic_func_interface (e, 0)) == MATCH_NO))
	Although the value stored to 'm' is used in the enclosing expression, the value is never actually read from 'm'
3000	{
3001	gfc_error ("Function %qs in initialization expression at %L "
3002	"must be an intrinsic function",
3003	e->symtree->n.sym->name, &e->where);
3004	break;
3005	}
3006
3007	if ((m = check_conversion (e)) == MATCH_NO
3008	&& (m = check_inquiry (e, 1)) == MATCH_NO
3009	&& (m = check_null (e)) == MATCH_NO
3010	&& (m = check_transformational (e)) == MATCH_NO
3011	&& (m = check_elemental (e)) == MATCH_NO)
3012	{
3013	gfc_error ("Intrinsic function %qs at %L is not permitted "
3014	"in an initialization expression",
3015	e->symtree->n.sym->name, &e->where);
3016	m = MATCH_ERROR;
3017	}
3018
3019	if (m == MATCH_ERROR)
3020	return false;
3021
3022	/* Try to scalarize an elemental intrinsic function that has an
3023	array argument. */
3024	isym = gfc_find_function (e->symtree->n.sym->name);
3025	if (isym && isym->elemental
3026	&& (t = scalarize_intrinsic_call (e, true)))
3027	break;
3028	}
3029
3030	if (m == MATCH_YES)
3031	t = gfc_simplify_expr (e, 0);
3032
3033	break;
3034
3035	case EXPR_VARIABLE:
3036	t = true;
3037
3038	/* This occurs when parsing pdt templates. */
3039	if (gfc_expr_attr (e).pdt_kind)
3040	break;
3041
3042	if (gfc_check_iter_variable (e))
3043	break;
3044
3045	if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
3046	{
3047	/* A PARAMETER shall not be used to define itself, i.e.
3048	REAL, PARAMETER :: x = transfer(0, x)
3049	is invalid. */
3050	if (!e->symtree->n.sym->value)
3051	{
3052	gfc_error ("PARAMETER %qs is used at %L before its definition "
3053	"is complete", e->symtree->n.sym->name, &e->where);
3054	t = false;
3055	}
3056	else
3057	t = simplify_parameter_variable (e, 0);
3058
3059	break;
3060	}
3061
3062	if (gfc_in_match_data ())
3063	break;
3064
3065	t = false;
3066
3067	if (e->symtree->n.sym->as)
3068	{
3069	switch (e->symtree->n.sym->as->type)
3070	{
3071	case AS_ASSUMED_SIZE:
3072	gfc_error ("Assumed size array %qs at %L is not permitted "
3073	"in an initialization expression",
3074	e->symtree->n.sym->name, &e->where);
3075	break;
3076
3077	case AS_ASSUMED_SHAPE:
3078	gfc_error ("Assumed shape array %qs at %L is not permitted "
3079	"in an initialization expression",
3080	e->symtree->n.sym->name, &e->where);
3081	break;
3082
3083	case AS_DEFERRED:
3084	if (!e->symtree->n.sym->attr.allocatable
3085	&& !e->symtree->n.sym->attr.pointer
3086	&& e->symtree->n.sym->attr.dummy)
3087	gfc_error ("Assumed-shape array %qs at %L is not permitted "
3088	"in an initialization expression",
3089	e->symtree->n.sym->name, &e->where);
3090	else
3091	gfc_error ("Deferred array %qs at %L is not permitted "
3092	"in an initialization expression",
3093	e->symtree->n.sym->name, &e->where);
3094	break;
3095
3096	case AS_EXPLICIT:
3097	gfc_error ("Array %qs at %L is a variable, which does "
3098	"not reduce to a constant expression",
3099	e->symtree->n.sym->name, &e->where);
3100	break;
3101
3102	case AS_ASSUMED_RANK:
3103	gfc_error ("Assumed-rank array %qs at %L is not permitted "
3104	"in an initialization expression",
3105	e->symtree->n.sym->name, &e->where);
3106	break;
3107
3108	default:
3109	gcc_unreachable()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 3109, __FUNCTION__));
3110	}
3111	}
3112	else
3113	gfc_error ("Parameter %qs at %L has not been declared or is "
3114	"a variable, which does not reduce to a constant "
3115	"expression", e->symtree->name, &e->where);
3116
3117	break;
3118
3119	case EXPR_CONSTANT:
3120	case EXPR_NULL:
3121	t = true;
3122	break;
3123
3124	case EXPR_SUBSTRING:
3125	if (e->ref)
3126	{
3127	t = gfc_check_init_expr (e->ref->u.ss.start);
3128	if (!t)
3129	break;
3130
3131	t = gfc_check_init_expr (e->ref->u.ss.end);
3132	if (t)
3133	t = gfc_simplify_expr (e, 0);
3134	}
3135	else
3136	t = false;
3137	break;
3138
3139	case EXPR_STRUCTURE:
3140	t = e->ts.is_iso_c ? true : false;
3141	if (t)
3142	break;
3143
3144	t = check_alloc_comp_init (e);
3145	if (!t)
3146	break;
3147
3148	t = gfc_check_constructor (e, gfc_check_init_expr);
3149	if (!t)
3150	break;
3151
3152	break;
3153
3154	case EXPR_ARRAY:
3155	t = gfc_check_constructor (e, gfc_check_init_expr);
3156	if (!t)
3157	break;
3158
3159	t = gfc_expand_constructor (e, true);
3160	if (!t)
3161	break;
3162
3163	t = gfc_check_constructor_type (e);
3164	break;
3165
3166	default:
3167	gfc_internal_error ("check_init_expr(): Unknown expression type");
3168	}
3169
3170	return t;
3171	}
3172
3173	/* Reduces a general expression to an initialization expression (a constant).
3174	This used to be part of gfc_match_init_expr.
3175	Note that this function doesn't free the given expression on false. */
3176
3177	bool
3178	gfc_reduce_init_expr (gfc_expr *expr)
3179	{
3180	bool t;
3181
3182	gfc_init_expr_flag = true;
3183	t = gfc_resolve_expr (expr);
3184	if (t)
3185	t = gfc_check_init_expr (expr);
3186	gfc_init_expr_flag = false;
3187
3188	if (!t \|\| !expr)
3189	return false;
3190
3191	if (expr->expr_type == EXPR_ARRAY)
3192	{
3193	if (!gfc_check_constructor_type (expr))
3194	return false;
3195	if (!gfc_expand_constructor (expr, true))
3196	return false;
3197	}
3198
3199	return true;
3200	}
3201
3202
3203	/* Match an initialization expression. We work by first matching an
3204	expression, then reducing it to a constant. */
3205
3206	match
3207	gfc_match_init_expr (gfc_expr **result)
3208	{
3209	gfc_expr *expr;
3210	match m;
3211	bool t;
3212
3213	expr = NULL__null;
3214
3215	gfc_init_expr_flag = true;
3216
3217	m = gfc_match_expr (&expr);
3218	if (m != MATCH_YES)
3219	{
3220	gfc_init_expr_flag = false;
3221	return m;
3222	}
3223
3224	if (gfc_derived_parameter_expr (expr))
3225	{
3226	*result = expr;
3227	gfc_init_expr_flag = false;
3228	return m;
3229	}
3230
3231	t = gfc_reduce_init_expr (expr);
3232	if (!t)
3233	{
3234	gfc_free_expr (expr);
3235	gfc_init_expr_flag = false;
3236	return MATCH_ERROR;
3237	}
3238
3239	*result = expr;
3240	gfc_init_expr_flag = false;
3241
3242	return MATCH_YES;
3243	}
3244
3245
3246	/* Given an actual argument list, test to see that each argument is a
3247	restricted expression and optionally if the expression type is
3248	integer or character. */
3249
3250	static bool
3251	restricted_args (gfc_actual_arglist *a)
3252	{
3253	for (; a; a = a->next)
3254	{
3255	if (!check_restricted (a->expr))
3256	return false;
3257	}
3258
3259	return true;
3260	}
3261
3262
3263	/*********** Restricted/specification expressions ***********/
3264
3265
3266	/* Make sure a non-intrinsic function is a specification function,
3267	* see F08:7.1.11.5. */
3268
3269	static bool
3270	external_spec_function (gfc_expr *e)
3271	{
3272	gfc_symbol *f;
3273
3274	f = e->value.function.esym;
3275
3276	/* IEEE functions allowed are "a reference to a transformational function
3277	from the intrinsic module IEEE_ARITHMETIC or IEEE_EXCEPTIONS", and
3278	"inquiry function from the intrinsic modules IEEE_ARITHMETIC and
3279	IEEE_EXCEPTIONS". */
3280	if (f->from_intmod == INTMOD_IEEE_ARITHMETIC
3281	\|\| f->from_intmod == INTMOD_IEEE_EXCEPTIONS)
3282	{
3283	if (!strcmp (f->name, "ieee_selected_real_kind")
3284	\|\| !strcmp (f->name, "ieee_support_rounding")
3285	\|\| !strcmp (f->name, "ieee_support_flag")
3286	\|\| !strcmp (f->name, "ieee_support_halting")
3287	\|\| !strcmp (f->name, "ieee_support_datatype")
3288	\|\| !strcmp (f->name, "ieee_support_denormal")
3289	\|\| !strcmp (f->name, "ieee_support_subnormal")
3290	\|\| !strcmp (f->name, "ieee_support_divide")
3291	\|\| !strcmp (f->name, "ieee_support_inf")
3292	\|\| !strcmp (f->name, "ieee_support_io")
3293	\|\| !strcmp (f->name, "ieee_support_nan")
3294	\|\| !strcmp (f->name, "ieee_support_sqrt")
3295	\|\| !strcmp (f->name, "ieee_support_standard")
3296	\|\| !strcmp (f->name, "ieee_support_underflow_control"))
3297	goto function_allowed;
3298	}
3299
3300	if (f->attr.proc == PROC_ST_FUNCTION)
3301	{
3302	gfc_error ("Specification function %qs at %L cannot be a statement "
3303	"function", f->name, &e->where);
3304	return false;
3305	}
3306
3307	if (f->attr.proc == PROC_INTERNAL)
3308	{
3309	gfc_error ("Specification function %qs at %L cannot be an internal "
3310	"function", f->name, &e->where);
3311	return false;
3312	}
3313
3314	if (!f->attr.pure && !f->attr.elemental)
3315	{
3316	gfc_error ("Specification function %qs at %L must be PURE", f->name,
3317	&e->where);
3318	return false;
3319	}
3320
3321	/* F08:7.1.11.6. */
3322	if (f->attr.recursive
3323	&& !gfc_notify_std (GFC_STD_F2003(1<<4),
3324	"Specification function %qs "
3325	"at %L cannot be RECURSIVE", f->name, &e->where))
3326	return false;
3327
3328	function_allowed:
3329	return restricted_args (e->value.function.actual);
3330	}
3331
3332
3333	/* Check to see that a function reference to an intrinsic is a
3334	restricted expression. */
3335
3336	static bool
3337	restricted_intrinsic (gfc_expr *e)
3338	{
3339	/* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
3340	if (check_inquiry (e, 0) == MATCH_YES)
3341	return true;
3342
3343	return restricted_args (e->value.function.actual);
3344	}
3345
3346
3347	/* Check the expressions of an actual arglist. Used by check_restricted. */
3348
3349	static bool
3350	check_arglist (gfc_actual_arglist* arg, bool (checker) (gfc_expr))
3351	{
3352	for (; arg; arg = arg->next)
3353	if (!checker (arg->expr))
3354	return false;
3355
3356	return true;
3357	}
3358
3359
3360	/* Check the subscription expressions of a reference chain with a checking
3361	function; used by check_restricted. */
3362
3363	static bool
3364	check_references (gfc_ref* ref, bool (checker) (gfc_expr))
3365	{
3366	int dim;
3367
3368	if (!ref)
3369	return true;
3370
3371	switch (ref->type)
3372	{
3373	case REF_ARRAY:
3374	for (dim = 0; dim < ref->u.ar.dimen; ++dim)
3375	{
3376	if (!checker (ref->u.ar.start[dim]))
3377	return false;
3378	if (!checker (ref->u.ar.end[dim]))
3379	return false;
3380	if (!checker (ref->u.ar.stride[dim]))
3381	return false;
3382	}
3383	break;
3384
3385	case REF_COMPONENT:
3386	/* Nothing needed, just proceed to next reference. */
3387	break;
3388
3389	case REF_SUBSTRING:
3390	if (!checker (ref->u.ss.start))
3391	return false;
3392	if (!checker (ref->u.ss.end))
3393	return false;
3394	break;
3395
3396	default:
3397	gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 3397, __FUNCTION__));
3398	break;
3399	}
3400
3401	return check_references (ref->next, checker);
3402	}
3403
3404	/* Return true if ns is a parent of the current ns. */
3405
3406	static bool
3407	is_parent_of_current_ns (gfc_namespace *ns)
3408	{
3409	gfc_namespace *p;
3410	for (p = gfc_current_ns->parent; p; p = p->parent)
3411	if (ns == p)
3412	return true;
3413
3414	return false;
3415	}
3416
3417	/* Verify that an expression is a restricted expression. Like its
3418	cousin check_init_expr(), an error message is generated if we
3419	return false. */
3420
3421	static bool
3422	check_restricted (gfc_expr *e)
3423	{
3424	gfc_symbol* sym;
3425	bool t;
3426
3427	if (e == NULL__null)
3428	return true;
3429
3430	switch (e->expr_type)
3431	{
3432	case EXPR_OP:
3433	t = check_intrinsic_op (e, check_restricted);
3434	if (t)
3435	t = gfc_simplify_expr (e, 0);
3436
3437	break;
3438
3439	case EXPR_FUNCTION:
3440	if (e->value.function.esym)
3441	{
3442	t = check_arglist (e->value.function.actual, &check_restricted);
3443	if (t)
3444	t = external_spec_function (e);
3445	}
3446	else
3447	{
3448	if (e->value.function.isym && e->value.function.isym->inquiry)
3449	t = true;
3450	else
3451	t = check_arglist (e->value.function.actual, &check_restricted);
3452
3453	if (t)
3454	t = restricted_intrinsic (e);
3455	}
3456	break;
3457
3458	case EXPR_VARIABLE:
3459	sym = e->symtree->n.sym;
3460	t = false;
3461
3462	/* If a dummy argument appears in a context that is valid for a
3463	restricted expression in an elemental procedure, it will have
3464	already been simplified away once we get here. Therefore we
3465	don't need to jump through hoops to distinguish valid from
3466	invalid cases. Allowed in F2008 and F2018. */
3467	if (gfc_notification_std (GFC_STD_F2008(1<<7))
3468	&& sym->attr.dummy && sym->ns == gfc_current_ns
3469	&& sym->ns->proc_name && sym->ns->proc_name->attr.elemental)
3470	{
3471	gfc_error_now ("Dummy argument %qs not "
3472	"allowed in expression at %L",
3473	sym->name, &e->where);
3474	break;
3475	}
3476
3477	if (sym->attr.optional)
3478	{
3479	gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL",
3480	sym->name, &e->where);
3481	break;
3482	}
3483
3484	if (sym->attr.intent == INTENT_OUT)
3485	{
3486	gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)",
3487	sym->name, &e->where);
3488	break;
3489	}
3490
3491	/* Check reference chain if any. */
3492	if (!check_references (e->ref, &check_restricted))
3493	break;
3494
3495	/* gfc_is_formal_arg broadcasts that a formal argument list is being
3496	processed in resolve.cc(resolve_formal_arglist). This is done so
3497	that host associated dummy array indices are accepted (PR23446).
3498	This mechanism also does the same for the specification expressions
3499	of array-valued functions. */
3500	if (e->error
3501	\|\| sym->attr.in_common
3502	\|\| sym->attr.use_assoc
3503	\|\| sym->attr.dummy
3504	\|\| sym->attr.implied_index
3505	\|\| sym->attr.flavor == FL_PARAMETER
3506	\|\| is_parent_of_current_ns (sym->ns)
3507	\|\| (sym->ns->proc_name != NULL__null
3508	&& sym->ns->proc_name->attr.flavor == FL_MODULE)
3509	\|\| (gfc_is_formal_arg () && (sym->ns == gfc_current_ns)))
3510	{
3511	t = true;
3512	break;
3513	}
3514
3515	gfc_error ("Variable %qs cannot appear in the expression at %L",
3516	sym->name, &e->where);
3517	/* Prevent a repetition of the error. */
3518	e->error = 1;
3519	break;
3520
3521	case EXPR_NULL:
3522	case EXPR_CONSTANT:
3523	t = true;
3524	break;
3525
3526	case EXPR_SUBSTRING:
3527	t = gfc_specification_expr (e->ref->u.ss.start);
3528	if (!t)
3529	break;
3530
3531	t = gfc_specification_expr (e->ref->u.ss.end);
3532	if (t)
3533	t = gfc_simplify_expr (e, 0);
3534
3535	break;
3536
3537	case EXPR_STRUCTURE:
3538	t = gfc_check_constructor (e, check_restricted);
3539	break;
3540
3541	case EXPR_ARRAY:
3542	t = gfc_check_constructor (e, check_restricted);
3543	break;
3544
3545	default:
3546	gfc_internal_error ("check_restricted(): Unknown expression type");
3547	}
3548
3549	return t;
3550	}
3551
3552
3553	/* Check to see that an expression is a specification expression. If
3554	we return false, an error has been generated. */
3555
3556	bool
3557	gfc_specification_expr (gfc_expr *e)
3558	{
3559	gfc_component *comp;
3560
3561	if (e == NULL__null)
3562	return true;
3563
3564	if (e->ts.type != BT_INTEGER)
3565	{
3566	gfc_error ("Expression at %L must be of INTEGER type, found %s",
3567	&e->where, gfc_basic_typename (e->ts.type));
3568	return false;
3569	}
3570
3571	comp = gfc_get_proc_ptr_comp (e);
3572	if (e->expr_type == EXPR_FUNCTION
3573	&& !e->value.function.isym
3574	&& !e->value.function.esym
3575	&& !gfc_pure (e->symtree->n.sym)
3576	&& (!comp \|\| !comp->attr.pure))
3577	{
3578	gfc_error ("Function %qs at %L must be PURE",
3579	e->symtree->n.sym->name, &e->where);
3580	/* Prevent repeat error messages. */
3581	e->symtree->n.sym->attr.pure = 1;
3582	return false;
3583	}
3584
3585	if (e->rank != 0)
3586	{
3587	gfc_error ("Expression at %L must be scalar", &e->where);
3588	return false;
3589	}
3590
3591	if (!gfc_simplify_expr (e, 0))
3592	return false;
3593
3594	return check_restricted (e);
3595	}
3596
3597
3598	/************ Expression conformance checks. ***********/
3599
3600	/* Given two expressions, make sure that the arrays are conformable. */
3601
3602	bool
3603	gfc_check_conformance (gfc_expr op1, gfc_expr op2, const char *optype_msgid, ...)
3604	{
3605	int op1_flag, op2_flag, d;
3606	mpz_t op1_size, op2_size;
3607	bool t;
3608
3609	va_list argp;
3610	char buffer[240];
3611
3612	if (op1->rank == 0 \|\| op2->rank == 0)
3613	return true;
3614
3615	va_start (argp, optype_msgid)__builtin_va_start(argp, optype_msgid);
3616	d = vsnprintf (buffer, sizeof (buffer), optype_msgid, argp);
3617	va_end (argp)__builtin_va_end(argp);
3618	if (d < 1 \|\| d >= (int) sizeof (buffer)) /* Reject truncation. */
3619	gfc_internal_error ("optype_msgid overflow: %d", d);
3620
3621	if (op1->rank != op2->rank)
3622	{
3623	gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer)gettext (buffer),
3624	op1->rank, op2->rank, &op1->where);
3625	return false;
3626	}
3627
3628	t = true;
3629
3630	for (d = 0; d < op1->rank; d++)
3631	{
3632	op1_flag = gfc_array_dimen_size(op1, d, &op1_size);
3633	op2_flag = gfc_array_dimen_size(op2, d, &op2_size);
3634
3635	if (op1_flag && op2_flag && mpz_cmp__gmpz_cmp (op1_size, op2_size) != 0)
3636	{
3637	gfc_error ("Different shape for %s at %L on dimension %d "
3638	"(%d and %d)", _(buffer)gettext (buffer), &op1->where, d + 1,
3639	(int) mpz_get_si__gmpz_get_si (op1_size),
3640	(int) mpz_get_si__gmpz_get_si (op2_size));
3641
3642	t = false;
3643	}
3644
3645	if (op1_flag)
3646	mpz_clear__gmpz_clear (op1_size);
3647	if (op2_flag)
3648	mpz_clear__gmpz_clear (op2_size);
3649
3650	if (!t)
3651	return false;
3652	}
3653
3654	return true;
3655	}
3656
3657
3658	/* Given an assignable expression and an arbitrary expression, make
3659	sure that the assignment can take place. Only add a call to the intrinsic
3660	conversion routines, when allow_convert is set. When this assign is a
3661	coarray call, then the convert is done by the coarray routine implictly and
3662	adding the intrinsic conversion would do harm in most cases. */
3663
3664	bool
3665	gfc_check_assign (gfc_expr lvalue, gfc_expr rvalue, int conform,
3666	bool allow_convert)
3667	{
3668	gfc_symbol *sym;
3669	gfc_ref *ref;
3670	int has_pointer;
3671
3672	sym = lvalue->symtree->n.sym;
3673
3674	/* See if this is the component or subcomponent of a pointer and guard
3675	against assignment to LEN or KIND part-refs. */
3676	has_pointer = sym->attr.pointer;
3677	for (ref = lvalue->ref; ref; ref = ref->next)
3678	{
3679	if (!has_pointer && ref->type == REF_COMPONENT
3680	&& ref->u.c.component->attr.pointer)
3681	has_pointer = 1;
3682	else if (ref->type == REF_INQUIRY
3683	&& (ref->u.i == INQUIRY_LEN \|\| ref->u.i == INQUIRY_KIND))
3684	{
3685	gfc_error ("Assignment to a LEN or KIND part_ref at %L is not "
3686	"allowed", &lvalue->where);
3687	return false;
3688	}
3689	}
3690
3691	/* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3692	variable local to a function subprogram. Its existence begins when
3693	execution of the function is initiated and ends when execution of the
3694	function is terminated...
3695	Therefore, the left hand side is no longer a variable, when it is: */
3696	if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION
3697	&& !sym->attr.external)
3698	{
3699	bool bad_proc;
3700	bad_proc = false;
3701
3702	/* (i) Use associated; */
3703	if (sym->attr.use_assoc)
3704	bad_proc = true;
3705
3706	/* (ii) The assignment is in the main program; or */
3707	if (gfc_current_ns->proc_name
3708	&& gfc_current_ns->proc_name->attr.is_main_program)
3709	bad_proc = true;
3710
3711	/* (iii) A module or internal procedure... */
3712	if (gfc_current_ns->proc_name
3713	&& (gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL
3714	\|\| gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
3715	&& gfc_current_ns->parent
3716	&& (!(gfc_current_ns->parent->proc_name->attr.function
3717	\|\| gfc_current_ns->parent->proc_name->attr.subroutine)
3718	\|\| gfc_current_ns->parent->proc_name->attr.is_main_program))
3719	{
3720	/* ... that is not a function... */
3721	if (gfc_current_ns->proc_name
3722	&& !gfc_current_ns->proc_name->attr.function)
3723	bad_proc = true;
3724
3725	/* ... or is not an entry and has a different name. */
3726	if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name)
3727	bad_proc = true;
3728	}
3729
3730	/* (iv) Host associated and not the function symbol or the
3731	parent result. This picks up sibling references, which
3732	cannot be entries. */
3733	if (!sym->attr.entry
3734	&& sym->ns == gfc_current_ns->parent
3735	&& sym != gfc_current_ns->proc_name
3736	&& sym != gfc_current_ns->parent->proc_name->result)
3737	bad_proc = true;
3738
3739	if (bad_proc)
3740	{
3741	gfc_error ("%qs at %L is not a VALUE", sym->name, &lvalue->where);
3742	return false;
3743	}
3744	}
3745	else
3746	{
3747	/* Reject assigning to an external symbol. For initializers, this
3748	was already done before, in resolve_fl_procedure. */
3749	if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
3750	&& sym->attr.proc != PROC_MODULE && !rvalue->error)
3751	{
3752	gfc_error ("Illegal assignment to external procedure at %L",
3753	&lvalue->where);
3754	return false;
3755	}
3756	}
3757
3758	if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
3759	{
3760	gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3761	lvalue->rank, rvalue->rank, &lvalue->where);
3762	return false;
3763	}
3764
3765	if (lvalue->ts.type == BT_UNKNOWN)
3766	{
3767	gfc_error ("Variable type is UNKNOWN in assignment at %L",
3768	&lvalue->where);
3769	return false;
3770	}
3771
3772	if (rvalue->expr_type == EXPR_NULL)
3773	{
3774	if (has_pointer && (ref == NULL__null \|\| ref->next == NULL__null)
3775	&& lvalue->symtree->n.sym->attr.data)
3776	return true;
3777	else
3778	{
3779	gfc_error ("NULL appears on right-hand side in assignment at %L",
3780	&rvalue->where);
3781	return false;
3782	}
3783	}
3784
3785	/* This is possibly a typo: x = f() instead of x => f(). */
3786	if (warn_surprisingglobal_options.x_warn_surprising
3787	&& rvalue->expr_type == EXPR_FUNCTION && gfc_expr_attr (rvalue).pointer)
3788	gfc_warning (OPT_Wsurprising,
3789	"POINTER-valued function appears on right-hand side of "
3790	"assignment at %L", &rvalue->where);
3791
3792	/* Check size of array assignments. */
3793	if (lvalue->rank != 0 && rvalue->rank != 0
3794	&& !gfc_check_conformance (lvalue, rvalue, _("array assignment")gettext ("array assignment")))
3795	return false;
3796
3797	/* Handle the case of a BOZ literal on the RHS. */
3798	if (rvalue->ts.type == BT_BOZ)
3799	{
3800	if (lvalue->symtree->n.sym->attr.data)
3801	{
3802	if (lvalue->ts.type == BT_INTEGER
3803	&& gfc_boz2int (rvalue, lvalue->ts.kind))
3804	return true;
3805
3806	if (lvalue->ts.type == BT_REAL
3807	&& gfc_boz2real (rvalue, lvalue->ts.kind))
3808	{
3809	if (gfc_invalid_boz ("BOZ literal constant near %L cannot "
3810	"be assigned to a REAL variable",
3811	&rvalue->where))
3812	return false;
3813	return true;
3814	}
3815	}
3816
3817	if (!lvalue->symtree->n.sym->attr.data
3818	&& gfc_invalid_boz ("BOZ literal constant at %L is neither a "
3819	"data-stmt-constant nor an actual argument to "
3820	"INT, REAL, DBLE, or CMPLX intrinsic function",
3821	&rvalue->where))
3822	return false;
3823
3824	if (lvalue->ts.type == BT_INTEGER
3825	&& gfc_boz2int (rvalue, lvalue->ts.kind))
3826	return true;
3827
3828	if (lvalue->ts.type == BT_REAL
3829	&& gfc_boz2real (rvalue, lvalue->ts.kind))
3830	return true;
3831
3832	gfc_error ("BOZ literal constant near %L cannot be assigned to a "
3833	"%qs variable", &rvalue->where, gfc_typename (lvalue));
3834	return false;
3835	}
3836
3837	if (gfc_expr_attr (lvalue).pdt_kind \|\| gfc_expr_attr (lvalue).pdt_len)
3838	{
3839	gfc_error ("The assignment to a KIND or LEN component of a "
3840	"parameterized type at %L is not allowed",
3841	&lvalue->where);
3842	return false;
3843	}
3844
3845	if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
3846	return true;
3847
3848	/* Only DATA Statements come here. */
3849	if (!conform)
3850	{
3851	locus *where;
3852
3853	/* Numeric can be converted to any other numeric. And Hollerith can be
3854	converted to any other type. */
3855	if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
3856	\|\| rvalue->ts.type == BT_HOLLERITH)
3857	return true;
3858
3859	if (flag_dec_char_conversionsglobal_options.x_flag_dec_char_conversions && (gfc_numeric_ts (&lvalue->ts)
3860	\|\| lvalue->ts.type == BT_LOGICAL)
3861	&& rvalue->ts.type == BT_CHARACTER
3862	&& rvalue->ts.kind == gfc_default_character_kind)
3863	return true;
3864
3865	if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
3866	return true;
3867
3868	where = lvalue->where.lb ? &lvalue->where : &rvalue->where;
3869	gfc_error ("Incompatible types in DATA statement at %L; attempted "
3870	"conversion of %s to %s", where,
3871	gfc_typename (rvalue), gfc_typename (lvalue));
3872
3873	return false;
3874	}
3875
3876	/* Assignment is the only case where character variables of different
3877	kind values can be converted into one another. */
3878	if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER)
3879	{
3880	if (lvalue->ts.kind != rvalue->ts.kind && allow_convert)
3881	return gfc_convert_chartype (rvalue, &lvalue->ts);
3882	else
3883	return true;
3884	}
3885
3886	if (!allow_convert)
3887	return true;
3888
3889	return gfc_convert_type (rvalue, &lvalue->ts, 1);
3890	}
3891
3892
3893	/* Check that a pointer assignment is OK. We first check lvalue, and
3894	we only check rvalue if it's not an assignment to NULL() or a
3895	NULLIFY statement. */
3896
3897	bool
3898	gfc_check_pointer_assign (gfc_expr lvalue, gfc_expr rvalue,
3899	bool suppress_type_test, bool is_init_expr)
3900	{
3901	symbol_attribute attr, lhs_attr;
3902	gfc_ref *ref;
3903	bool is_pure, is_implicit_pure, rank_remap;
3904	int proc_pointer;
3905	bool same_rank;
3906
3907	if (!lvalue->symtree)
3908	return false;
3909
3910	lhs_attr = gfc_expr_attr (lvalue);
3911	if (lvalue->ts.type == BT_UNKNOWN && !lhs_attr.proc_pointer)
3912	{
3913	gfc_error ("Pointer assignment target is not a POINTER at %L",
3914	&lvalue->where);
3915	return false;
3916	}
3917
3918	if (lhs_attr.flavor == FL_PROCEDURE && lhs_attr.use_assoc
3919	&& !lhs_attr.proc_pointer)
3920	{
3921	gfc_error ("%qs in the pointer assignment at %L cannot be an "
3922	"l-value since it is a procedure",
3923	lvalue->symtree->n.sym->name, &lvalue->where);
3924	return false;
3925	}
3926
3927	proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer;
3928
3929	rank_remap = false;
3930	same_rank = lvalue->rank == rvalue->rank;
3931	for (ref = lvalue->ref; ref; ref = ref->next)
3932	{
3933	if (ref->type == REF_COMPONENT)
3934	proc_pointer = ref->u.c.component->attr.proc_pointer;
3935
3936	if (ref->type == REF_ARRAY && ref->next == NULL__null)
3937	{
3938	int dim;
3939
3940	if (ref->u.ar.type == AR_FULL)
3941	break;
3942
3943	if (ref->u.ar.type != AR_SECTION)
3944	{
3945	gfc_error ("Expected bounds specification for %qs at %L",
3946	lvalue->symtree->n.sym->name, &lvalue->where);
3947	return false;
3948	}
3949
3950	if (!gfc_notify_std (GFC_STD_F2003(1<<4), "Bounds specification "
3951	"for %qs in pointer assignment at %L",
3952	lvalue->symtree->n.sym->name, &lvalue->where))
3953	return false;
3954
3955	/* Fortran standard (e.g. F2018, 10.2.2 Pointer assignment):
3956	*
3957	* (C1017) If bounds-spec-list is specified, the number of
3958	* bounds-specs shall equal the rank of data-pointer-object.
3959	*
3960	* If bounds-spec-list appears, it specifies the lower bounds.
3961	*
3962	* (C1018) If bounds-remapping-list is specified, the number of
3963	* bounds-remappings shall equal the rank of data-pointer-object.
3964	*
3965	* If bounds-remapping-list appears, it specifies the upper and
3966	* lower bounds of each dimension of the pointer; the pointer target
3967	* shall be simply contiguous or of rank one.
3968	*
3969	* (C1019) If bounds-remapping-list is not specified, the ranks of
3970	* data-pointer-object and data-target shall be the same.
3971	*
3972	* Thus when bounds are given, all lbounds are necessary and either
3973	* all or none of the upper bounds; no strides are allowed. If the
3974	* upper bounds are present, we may do rank remapping. */
3975	for (dim = 0; dim < ref->u.ar.dimen; ++dim)
3976	{
3977	if (ref->u.ar.stride[dim])
3978	{
3979	gfc_error ("Stride must not be present at %L",
3980	&lvalue->where);
3981	return false;
3982	}
3983	if (!same_rank && (!ref->u.ar.start[dim] \|\|!ref->u.ar.end[dim]))
3984	{
3985	gfc_error ("Rank remapping requires a "
3986	"list of %<lower-bound : upper-bound%> "
3987	"specifications at %L", &lvalue->where);
3988	return false;
3989	}
3990	if (!ref->u.ar.start[dim]
3991	\|\| ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3992	{
3993	gfc_error ("Expected list of %<lower-bound :%> or "
3994	"list of %<lower-bound : upper-bound%> "
3995	"specifications at %L", &lvalue->where);
3996	return false;
3997	}
3998
3999	if (dim == 0)
4000	rank_remap = (ref->u.ar.end[dim] != NULL__null);
4001	else
4002	{
4003	if ((rank_remap && !ref->u.ar.end[dim]))
4004	{
4005	gfc_error ("Rank remapping requires a "
4006	"list of %<lower-bound : upper-bound%> "
4007	"specifications at %L", &lvalue->where);
4008	return false;
4009	}
4010	if (!rank_remap && ref->u.ar.end[dim])
4011	{
4012	gfc_error ("Expected list of %<lower-bound :%> or "
4013	"list of %<lower-bound : upper-bound%> "
4014	"specifications at %L", &lvalue->where);
4015	return false;
4016	}
4017	}
4018	}
4019	}
4020	}
4021
4022	is_pure = gfc_pure (NULL__null);
4023	is_implicit_pure = gfc_implicit_pure (NULL__null);
4024
4025	/* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
4026	kind, etc for lvalue and rvalue must match, and rvalue must be a
4027	pure variable if we're in a pure function. */
4028	if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
4029	return true;
4030
4031	/* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
4032	if (lvalue->expr_type == EXPR_VARIABLE
4033	&& gfc_is_coindexed (lvalue))
4034	{
4035	gfc_ref *ref;
4036	for (ref = lvalue->ref; ref; ref = ref->next)
4037	if (ref->type == REF_ARRAY && ref->u.ar.codimen)
4038	{
4039	gfc_error ("Pointer object at %L shall not have a coindex",
4040	&lvalue->where);
4041	return false;
4042	}
4043	}
4044
4045	/* Checks on rvalue for procedure pointer assignments. */
4046	if (proc_pointer)
4047	{
4048	char err[200];
4049	gfc_symbol s1,s2;
4050	gfc_component comp1, comp2;
4051	const char *name;
4052
4053	attr = gfc_expr_attr (rvalue);
4054	if (!((rvalue->expr_type == EXPR_NULL)
4055	\|\| (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
4056	\|\| (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer)
4057	\|\| (rvalue->expr_type == EXPR_VARIABLE
4058	&& attr.flavor == FL_PROCEDURE)))
4059	{
4060	gfc_error ("Invalid procedure pointer assignment at %L",
4061	&rvalue->where);
4062	return false;
4063	}
4064
4065	if (rvalue->expr_type == EXPR_VARIABLE && !attr.proc_pointer)
4066	{
4067	/* Check for intrinsics. */
4068	gfc_symbol *sym = rvalue->symtree->n.sym;
4069	if (!sym->attr.intrinsic
4070	&& (gfc_is_intrinsic (sym, 0, sym->declared_at)
4071	\|\| gfc_is_intrinsic (sym, 1, sym->declared_at)))
4072	{
4073	sym->attr.intrinsic = 1;
4074	gfc_resolve_intrinsic (sym, &rvalue->where);
4075	attr = gfc_expr_attr (rvalue);
4076	}
4077	/* Check for result of embracing function. */
4078	if (sym->attr.function && sym->result == sym)
4079	{
4080	gfc_namespace *ns;
4081
4082	for (ns = gfc_current_ns; ns; ns = ns->parent)
4083	if (sym == ns->proc_name)
4084	{
4085	gfc_error ("Function result %qs is invalid as proc-target "
4086	"in procedure pointer assignment at %L",
4087	sym->name, &rvalue->where);
4088	return false;
4089	}
4090	}
4091	}
4092	if (attr.abstract)
4093	{
4094	gfc_error ("Abstract interface %qs is invalid "
4095	"in procedure pointer assignment at %L",
4096	rvalue->symtree->name, &rvalue->where);
4097	return false;
4098	}
4099	/* Check for F08:C729. */
4100	if (attr.flavor == FL_PROCEDURE)
4101	{
4102	if (attr.proc == PROC_ST_FUNCTION)
4103	{
4104	gfc_error ("Statement function %qs is invalid "
4105	"in procedure pointer assignment at %L",
4106	rvalue->symtree->name, &rvalue->where);
4107	return false;
4108	}
4109	if (attr.proc == PROC_INTERNAL &&
4110	!gfc_notify_std(GFC_STD_F2008(1<<7), "Internal procedure %qs "
4111	"is invalid in procedure pointer assignment "
4112	"at %L", rvalue->symtree->name, &rvalue->where))
4113	return false;
4114	if (attr.intrinsic && gfc_intrinsic_actual_ok (rvalue->symtree->name,
4115	attr.subroutine) == 0)
4116	{
4117	gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer "
4118	"assignment", rvalue->symtree->name, &rvalue->where);
4119	return false;
4120	}
4121	}
4122	/* Check for F08:C730. */
4123	if (attr.elemental && !attr.intrinsic)
4124	{
4125	gfc_error ("Nonintrinsic elemental procedure %qs is invalid "
4126	"in procedure pointer assignment at %L",
4127	rvalue->symtree->name, &rvalue->where);
4128	return false;
4129	}
4130
4131	/* Ensure that the calling convention is the same. As other attributes
4132	such as DLLEXPORT may differ, one explicitly only tests for the
4133	calling conventions. */
4134	if (rvalue->expr_type == EXPR_VARIABLE
4135	&& lvalue->symtree->n.sym->attr.ext_attr
4136	!= rvalue->symtree->n.sym->attr.ext_attr)
4137	{
4138	symbol_attribute calls;
4139
4140	calls.ext_attr = 0;
4141	gfc_add_ext_attribute (&calls, EXT_ATTR_CDECL, NULL__null);
4142	gfc_add_ext_attribute (&calls, EXT_ATTR_STDCALL, NULL__null);
4143	gfc_add_ext_attribute (&calls, EXT_ATTR_FASTCALL, NULL__null);
4144
4145	if ((calls.ext_attr & lvalue->symtree->n.sym->attr.ext_attr)
4146	!= (calls.ext_attr & rvalue->symtree->n.sym->attr.ext_attr))
4147	{
4148	gfc_error ("Mismatch in the procedure pointer assignment "
4149	"at %L: mismatch in the calling convention",
4150	&rvalue->where);
4151	return false;
4152	}
4153	}
4154
4155	comp1 = gfc_get_proc_ptr_comp (lvalue);
4156	if (comp1)
4157	s1 = comp1->ts.interface;
4158	else
4159	{
4160	s1 = lvalue->symtree->n.sym;
4161	if (s1->ts.interface)
4162	s1 = s1->ts.interface;
4163	}
4164
4165	comp2 = gfc_get_proc_ptr_comp (rvalue);
4166	if (comp2)
4167	{
4168	if (rvalue->expr_type == EXPR_FUNCTION)
4169	{
4170	s2 = comp2->ts.interface->result;
4171	name = s2->name;
4172	}
4173	else
4174	{
4175	s2 = comp2->ts.interface;
4176	name = comp2->name;
4177	}
4178	}
4179	else if (rvalue->expr_type == EXPR_FUNCTION)
4180	{
4181	if (rvalue->value.function.esym)
4182	s2 = rvalue->value.function.esym->result;
4183	else
4184	s2 = rvalue->symtree->n.sym->result;
4185
4186	name = s2->name;
4187	}
4188	else
4189	{
4190	s2 = rvalue->symtree->n.sym;
4191	name = s2->name;
4192	}
4193
4194	if (s2 && s2->attr.proc_pointer && s2->ts.interface)
4195	s2 = s2->ts.interface;
4196
4197	/* Special check for the case of absent interface on the lvalue.
4198	* All other interface checks are done below. */
4199	if (!s1 && comp1 && comp1->attr.subroutine && s2 && s2->attr.function)
4200	{
4201	gfc_error ("Interface mismatch in procedure pointer assignment "
4202	"at %L: %qs is not a subroutine", &rvalue->where, name);
4203	return false;
4204	}
4205
4206	/* F08:7.2.2.4 (4) */
4207	if (s2 && gfc_explicit_interface_required (s2, err, sizeof(err)))
4208	{
4209	if (comp1 && !s1)
4210	{
4211	gfc_error ("Explicit interface required for component %qs at %L: %s",
4212	comp1->name, &lvalue->where, err);
4213	return false;
4214	}
4215	else if (s1->attr.if_source == IFSRC_UNKNOWN)
4216	{
4217	gfc_error ("Explicit interface required for %qs at %L: %s",
4218	s1->name, &lvalue->where, err);
4219	return false;
4220	}
4221	}
4222	if (s1 && gfc_explicit_interface_required (s1, err, sizeof(err)))
4223	{
4224	if (comp2 && !s2)
4225	{
4226	gfc_error ("Explicit interface required for component %qs at %L: %s",
4227	comp2->name, &rvalue->where, err);
4228	return false;
4229	}
4230	else if (s2->attr.if_source == IFSRC_UNKNOWN)
4231	{
4232	gfc_error ("Explicit interface required for %qs at %L: %s",
4233	s2->name, &rvalue->where, err);
4234	return false;
4235	}
4236	}
4237
4238	if (s1 == s2 \|\| !s1 \|\| !s2)
4239	return true;
4240
4241	if (!gfc_compare_interfaces (s1, s2, name, 0, 1,
4242	err, sizeof(err), NULL__null, NULL__null))
4243	{
4244	gfc_error ("Interface mismatch in procedure pointer assignment "
4245	"at %L: %s", &rvalue->where, err);
4246	return false;
4247	}
4248
4249	/* Check F2008Cor2, C729. */
4250	if (!s2->attr.intrinsic && s2->attr.if_source == IFSRC_UNKNOWN
4251	&& !s2->attr.external && !s2->attr.subroutine && !s2->attr.function)
4252	{
4253	gfc_error ("Procedure pointer target %qs at %L must be either an "
4254	"intrinsic, host or use associated, referenced or have "
4255	"the EXTERNAL attribute", s2->name, &rvalue->where);
4256	return false;
4257	}
4258
4259	return true;
4260	}
4261	else
4262	{
4263	/* A non-proc pointer cannot point to a constant. */
4264	if (rvalue->expr_type == EXPR_CONSTANT)
4265	{
4266	gfc_error_now ("Pointer assignment target cannot be a constant at %L",
4267	&rvalue->where);
4268	return false;
4269	}
4270	}
4271
4272	if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
4273	{
4274	/* Check for F03:C717. */
4275	if (UNLIMITED_POLY (rvalue)(rvalue != __null && rvalue->ts.type == BT_CLASS && rvalue->ts.u.derived->components && rvalue-> ts.u.derived->components->ts.u.derived && rvalue ->ts.u.derived->components->ts.u.derived->attr.unlimited_polymorphic )
4276	&& !(UNLIMITED_POLY (lvalue)(lvalue != __null && lvalue->ts.type == BT_CLASS && lvalue->ts.u.derived->components && lvalue-> ts.u.derived->components->ts.u.derived && lvalue ->ts.u.derived->components->ts.u.derived->attr.unlimited_polymorphic )
4277	\|\| (lvalue->ts.type == BT_DERIVED
4278	&& (lvalue->ts.u.derived->attr.is_bind_c
4279	\|\| lvalue->ts.u.derived->attr.sequence))))
4280	gfc_error ("Data-pointer-object at %L must be unlimited "
4281	"polymorphic, or of a type with the BIND or SEQUENCE "
4282	"attribute, to be compatible with an unlimited "
4283	"polymorphic target", &lvalue->where);
4284	else if (!suppress_type_test)
4285	gfc_error ("Different types in pointer assignment at %L; "
4286	"attempted assignment of %s to %s", &lvalue->where,
4287	gfc_typename (rvalue), gfc_typename (lvalue));
4288	return false;
4289	}
4290
4291	if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind)
4292	{
4293	gfc_error ("Different kind type parameters in pointer "
4294	"assignment at %L", &lvalue->where);
4295	return false;
4296	}
4297
4298	if (lvalue->rank != rvalue->rank && !rank_remap)
4299	{
4300	gfc_error ("Different ranks in pointer assignment at %L", &lvalue->where);
4301	return false;
4302	}
4303
4304	/* Make sure the vtab is present. */
4305	if (lvalue->ts.type == BT_CLASS && !UNLIMITED_POLY (rvalue)(rvalue != __null && rvalue->ts.type == BT_CLASS && rvalue->ts.u.derived->components && rvalue-> ts.u.derived->components->ts.u.derived && rvalue ->ts.u.derived->components->ts.u.derived->attr.unlimited_polymorphic ))
4306	gfc_find_vtab (&rvalue->ts);
4307
4308	/* Check rank remapping. */
4309	if (rank_remap)
4310	{
4311	mpz_t lsize, rsize;
4312
4313	/* If this can be determined, check that the target must be at least as
4314	large as the pointer assigned to it is. */
4315	if (gfc_array_size (lvalue, &lsize)
4316	&& gfc_array_size (rvalue, &rsize)
4317	&& mpz_cmp__gmpz_cmp (rsize, lsize) < 0)
4318	{
4319	gfc_error ("Rank remapping target is smaller than size of the"
4320	" pointer (%ld < %ld) at %L",
4321	mpz_get_si__gmpz_get_si (rsize), mpz_get_si__gmpz_get_si (lsize),
4322	&lvalue->where);
4323	return false;
4324	}
4325
4326	/* The target must be either rank one or it must be simply contiguous
4327	and F2008 must be allowed. */
4328	if (rvalue->rank != 1)
4329	{
4330	if (!gfc_is_simply_contiguous (rvalue, true, false))
4331	{
4332	gfc_error ("Rank remapping target must be rank 1 or"
4333	" simply contiguous at %L", &rvalue->where);
4334	return false;
4335	}
4336	if (!gfc_notify_std (GFC_STD_F2008(1<<7), "Rank remapping target is not "
4337	"rank 1 at %L", &rvalue->where))
4338	return false;
4339	}
4340	}
4341
4342	/* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
4343	if (rvalue->expr_type == EXPR_NULL)
4344	return true;
4345
4346	if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
4347	lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
4348
4349	attr = gfc_expr_attr (rvalue);
4350
4351	if (rvalue->expr_type == EXPR_FUNCTION && !attr.pointer)
4352	{
4353	/* F2008, C725. For PURE also C1283. Sometimes rvalue is a function call
4354	to caf_get. Map this to the same error message as below when it is
4355	still a variable expression. */
4356	if (rvalue->value.function.isym
4357	&& rvalue->value.function.isym->id == GFC_ISYM_CAF_GET)
4358	/* The test above might need to be extend when F08, Note 5.4 has to be
4359	interpreted in the way that target and pointer with the same coindex
4360	are allowed. */
4361	gfc_error ("Data target at %L shall not have a coindex",
4362	&rvalue->where);
4363	else
4364	gfc_error ("Target expression in pointer assignment "
4365	"at %L must deliver a pointer result",
4366	&rvalue->where);
4367	return false;
4368	}
4369
4370	if (is_init_expr)
4371	{
4372	gfc_symbol *sym;
4373	bool target;
4374	gfc_ref *ref;
4375
4376	if (gfc_is_size_zero_array (rvalue))
4377	{
4378	gfc_error ("Zero-sized array detected at %L where an entity with "
4379	"the TARGET attribute is expected", &rvalue->where);
4380	return false;
4381	}
4382	else if (!rvalue->symtree)
4383	{
4384	gfc_error ("Pointer assignment target in initialization expression "
4385	"does not have the TARGET attribute at %L",
4386	&rvalue->where);
4387	return false;
4388	}
4389
4390	sym = rvalue->symtree->n.sym;
4391
4392	if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
4393	target = CLASS_DATA (sym)sym->ts.u.derived->components->attr.target;
4394	else
4395	target = sym->attr.target;
4396
4397	if (!target && !proc_pointer)
4398	{
4399	gfc_error ("Pointer assignment target in initialization expression "
4400	"does not have the TARGET attribute at %L",
4401	&rvalue->where);
4402	return false;
4403	}
4404
4405	for (ref = rvalue->ref; ref; ref = ref->next)
4406	{
4407	switch (ref->type)
4408	{
4409	case REF_ARRAY:
4410	for (int n = 0; n < ref->u.ar.dimen; n++)
4411	if (!gfc_is_constant_expr (ref->u.ar.start[n])
4412	\|\| !gfc_is_constant_expr (ref->u.ar.end[n])
4413	\|\| !gfc_is_constant_expr (ref->u.ar.stride[n]))
4414	{
4415	gfc_error ("Every subscript of target specification "
4416	"at %L must be a constant expression",
4417	&ref->u.ar.where);
4418	return false;
4419	}
4420	break;
4421
4422	case REF_SUBSTRING:
4423	if (!gfc_is_constant_expr (ref->u.ss.start)
4424	\|\| !gfc_is_constant_expr (ref->u.ss.end))
4425	{
4426	gfc_error ("Substring starting and ending points of target "
4427	"specification at %L must be constant expressions",
4428	&ref->u.ss.start->where);
4429	return false;
4430	}
4431	break;
4432
4433	default:
4434	break;
4435	}
4436	}
4437	}
4438	else
4439	{
4440	if (!attr.target && !attr.pointer)
4441	{
4442	gfc_error ("Pointer assignment target is neither TARGET "
4443	"nor POINTER at %L", &rvalue->where);
4444	return false;
4445	}
4446	}
4447
4448	if (lvalue->ts.type == BT_CHARACTER)
4449	{
4450	bool t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment");
4451	if (!t)
4452	return false;
4453	}
4454
4455	if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
4456	{
4457	gfc_error ("Bad target in pointer assignment in PURE "
4458	"procedure at %L", &rvalue->where);
4459	}
4460
4461	if (is_implicit_pure && gfc_impure_variable (rvalue->symtree->n.sym))
4462	gfc_unset_implicit_pure (gfc_current_ns->proc_name);
4463
4464	if (gfc_has_vector_index (rvalue))
4465	{
4466	gfc_error ("Pointer assignment with vector subscript "
4467	"on rhs at %L", &rvalue->where);
4468	return false;
4469	}
4470
4471	if (attr.is_protected && attr.use_assoc
4472	&& !(attr.pointer \|\| attr.proc_pointer))
4473	{
4474	gfc_error ("Pointer assignment target has PROTECTED "
4475	"attribute at %L", &rvalue->where);
4476	return false;
4477	}
4478
4479	/* F2008, C725. For PURE also C1283. */
4480	if (rvalue->expr_type == EXPR_VARIABLE
4481	&& gfc_is_coindexed (rvalue))
4482	{
4483	gfc_ref *ref;
4484	for (ref = rvalue->ref; ref; ref = ref->next)
4485	if (ref->type == REF_ARRAY && ref->u.ar.codimen)
4486	{
4487	gfc_error ("Data target at %L shall not have a coindex",
4488	&rvalue->where);
4489	return false;
4490	}
4491	}
4492
4493	/* Warn for assignments of contiguous pointers to targets which is not
4494	contiguous. Be lenient in the definition of what counts as
4495	contiguous. */
4496
4497	if (lhs_attr.contiguous
4498	&& lhs_attr.dimension > 0)
4499	{
4500	if (gfc_is_not_contiguous (rvalue))
4501	{
4502	gfc_error ("Assignment to contiguous pointer from "
4503	"non-contiguous target at %L", &rvalue->where);
4504	return false;
4505	}
4506	if (!gfc_is_simply_contiguous (rvalue, false, true))
4507	gfc_warning (OPT_Wextra, "Assignment to contiguous pointer from "
4508	"non-contiguous target at %L", &rvalue->where);
4509	}
4510
4511	/* Warn if it is the LHS pointer may lives longer than the RHS target. */
4512	if (warn_target_lifetimeglobal_options.x_warn_target_lifetime
4513	&& rvalue->expr_type == EXPR_VARIABLE
4514	&& !rvalue->symtree->n.sym->attr.save
4515	&& !rvalue->symtree->n.sym->attr.pointer && !attr.pointer
4516	&& !rvalue->symtree->n.sym->attr.host_assoc
4517	&& !rvalue->symtree->n.sym->attr.in_common
4518	&& !rvalue->symtree->n.sym->attr.use_assoc
4519	&& !rvalue->symtree->n.sym->attr.dummy)
4520	{
4521	bool warn;
4522	gfc_namespace *ns;
4523
4524	warn = lvalue->symtree->n.sym->attr.dummy
4525	\|\| lvalue->symtree->n.sym->attr.result
4526	\|\| lvalue->symtree->n.sym->attr.function
4527	\|\| (lvalue->symtree->n.sym->attr.host_assoc
4528	&& lvalue->symtree->n.sym->ns
4529	!= rvalue->symtree->n.sym->ns)
4530	\|\| lvalue->symtree->n.sym->attr.use_assoc
4531	\|\| lvalue->symtree->n.sym->attr.in_common;
4532
4533	if (rvalue->symtree->n.sym->ns->proc_name
4534	&& rvalue->symtree->n.sym->ns->proc_name->attr.flavor != FL_PROCEDURE
4535	&& rvalue->symtree->n.sym->ns->proc_name->attr.flavor != FL_PROGRAM)
4536	for (ns = rvalue->symtree->n.sym->ns;
4537	ns && ns->proc_name && ns->proc_name->attr.flavor != FL_PROCEDURE;
4538	ns = ns->parent)
4539	if (ns->parent == lvalue->symtree->n.sym->ns)
4540	{
4541	warn = true;
4542	break;
4543	}
4544
4545	if (warn)
4546	gfc_warning (OPT_Wtarget_lifetime,
4547	"Pointer at %L in pointer assignment might outlive the "
4548	"pointer target", &lvalue->where);
4549	}
4550
4551	return true;
4552	}
4553
4554
4555	/* Relative of gfc_check_assign() except that the lvalue is a single
4556	symbol. Used for initialization assignments. */
4557
4558	bool
4559	gfc_check_assign_symbol (gfc_symbol sym, gfc_component comp, gfc_expr *rvalue)
4560	{
4561	gfc_expr lvalue;
4562	bool r;
4563	bool pointer, proc_pointer;
4564
4565	memset (&lvalue, '\0', sizeof (gfc_expr));
4566
4567	lvalue.expr_type = EXPR_VARIABLE;
4568	lvalue.ts = sym->ts;
4569	if (sym->as)
4570	lvalue.rank = sym->as->rank;
4571	lvalue.symtree = XCNEW (gfc_symtree)((gfc_symtree *) xcalloc (1, sizeof (gfc_symtree)));
4572	lvalue.symtree->n.sym = sym;
4573	lvalue.where = sym->declared_at;
4574
4575	if (comp)
4576	{
4577	lvalue.ref = gfc_get_ref ()((gfc_ref *) xcalloc (1, sizeof (gfc_ref)));
4578	lvalue.ref->type = REF_COMPONENT;
4579	lvalue.ref->u.c.component = comp;
4580	lvalue.ref->u.c.sym = sym;
4581	lvalue.ts = comp->ts;
4582	lvalue.rank = comp->as ? comp->as->rank : 0;
4583	lvalue.where = comp->loc;
4584	pointer = comp->ts.type == BT_CLASS && CLASS_DATA (comp)comp->ts.u.derived->components
4585	? CLASS_DATA (comp)comp->ts.u.derived->components->attr.class_pointer : comp->attr.pointer;
4586	proc_pointer = comp->attr.proc_pointer;
4587	}
4588	else
4589	{
4590	pointer = sym->ts.type == BT_CLASS && CLASS_DATA (sym)sym->ts.u.derived->components
4591	? CLASS_DATA (sym)sym->ts.u.derived->components->attr.class_pointer : sym->attr.pointer;
4592	proc_pointer = sym->attr.proc_pointer;
4593	}
4594
4595	if (pointer \|\| proc_pointer)
4596	r = gfc_check_pointer_assign (&lvalue, rvalue, false, true);
4597	else
4598	{
4599	/* If a conversion function, e.g., __convert_i8_i4, was inserted
4600	into an array constructor, we should check if it can be reduced
4601	as an initialization expression. */
4602	if (rvalue->expr_type == EXPR_FUNCTION
4603	&& rvalue->value.function.isym
4604	&& (rvalue->value.function.isym->conversion == 1))
4605	gfc_check_init_expr (rvalue);
4606
4607	r = gfc_check_assign (&lvalue, rvalue, 1);
4608	}
4609
4610	free (lvalue.symtree);
4611	free (lvalue.ref);
4612
4613	if (!r)
4614	return r;
4615
4616	if (pointer && rvalue->expr_type != EXPR_NULL && !proc_pointer)
4617	{
4618	/* F08:C461. Additional checks for pointer initialization. */
4619	symbol_attribute attr;
4620	attr = gfc_expr_attr (rvalue);
4621	if (attr.allocatable)
4622	{
4623	gfc_error ("Pointer initialization target at %L "
4624	"must not be ALLOCATABLE", &rvalue->where);
4625	return false;
4626	}
4627	if (!attr.target \|\| attr.pointer)
4628	{
4629	gfc_error ("Pointer initialization target at %L "
4630	"must have the TARGET attribute", &rvalue->where);
4631	return false;
4632	}
4633
4634	if (!attr.save && rvalue->expr_type == EXPR_VARIABLE
4635	&& rvalue->symtree->n.sym->ns->proc_name
4636	&& rvalue->symtree->n.sym->ns->proc_name->attr.is_main_program)
4637	{
4638	rvalue->symtree->n.sym->ns->proc_name->attr.save = SAVE_IMPLICIT;
4639	attr.save = SAVE_IMPLICIT;
4640	}
4641
4642	if (!attr.save)
4643	{
4644	gfc_error ("Pointer initialization target at %L "
4645	"must have the SAVE attribute", &rvalue->where);
4646	return false;
4647	}
4648	}
4649
4650	if (proc_pointer && rvalue->expr_type != EXPR_NULL)
4651	{
4652	/* F08:C1220. Additional checks for procedure pointer initialization. */
4653	symbol_attribute attr = gfc_expr_attr (rvalue);
4654	if (attr.proc_pointer)
4655	{
4656	gfc_error ("Procedure pointer initialization target at %L "
4657	"may not be a procedure pointer", &rvalue->where);
4658	return false;
4659	}
4660	if (attr.proc == PROC_INTERNAL)
4661	{
4662	gfc_error ("Internal procedure %qs is invalid in "
4663	"procedure pointer initialization at %L",
4664	rvalue->symtree->name, &rvalue->where);
4665	return false;
4666	}
4667	if (attr.dummy)
4668	{
4669	gfc_error ("Dummy procedure %qs is invalid in "
4670	"procedure pointer initialization at %L",
4671	rvalue->symtree->name, &rvalue->where);
4672	return false;
4673	}
4674	}
4675
4676	return true;
4677	}
4678
4679	/* Build an initializer for a local integer, real, complex, logical, or
4680	character variable, based on the command line flags finit-local-zero,
4681	finit-integer=, finit-real=, finit-logical=, and finit-character=.
4682	With force, an initializer is ALWAYS generated. */
4683
4684	static gfc_expr *
4685	gfc_build_init_expr (gfc_typespec ts, locus where, bool force)
4686	{
4687	gfc_expr *init_expr;
4688
4689	/* Try to build an initializer expression. */
4690	init_expr = gfc_get_constant_expr (ts->type, ts->kind, where);
4691
4692	/* If we want to force generation, make sure we default to zero. */
4693	gfc_init_local_real init_real = flag_init_realglobal_options.x_flag_init_real;
4694	int init_logical = gfc_option.flag_init_logical;
4695	if (force)
4696	{
4697	if (init_real == GFC_INIT_REAL_OFF)
4698	init_real = GFC_INIT_REAL_ZERO;
4699	if (init_logical == GFC_INIT_LOGICAL_OFF)
4700	init_logical = GFC_INIT_LOGICAL_FALSE;
4701	}
4702
4703	/* We will only initialize integers, reals, complex, logicals, and
4704	characters, and only if the corresponding command-line flags
4705	were set. Otherwise, we free init_expr and return null. */
4706	switch (ts->type)
4707	{
4708	case BT_INTEGER:
4709	if (force \|\| gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
4710	mpz_set_si__gmpz_set_si (init_expr->value.integer,
4711	gfc_option.flag_init_integer_value);
4712	else
4713	{
4714	gfc_free_expr (init_expr);
4715	init_expr = NULL__null;
4716	}
4717	break;
4718
4719	case BT_REAL:
4720	switch (init_real)
4721	{
4722	case GFC_INIT_REAL_SNAN:
4723	init_expr->is_snan = 1;
4724	/* Fall through. */
4725	case GFC_INIT_REAL_NAN:
4726	mpfr_set_nan (init_expr->value.real);
4727	break;
4728
4729	case GFC_INIT_REAL_INF:
4730	mpfr_set_inf (init_expr->value.real, 1);
4731	break;
4732
4733	case GFC_INIT_REAL_NEG_INF:
4734	mpfr_set_inf (init_expr->value.real, -1);
4735	break;
4736
4737	case GFC_INIT_REAL_ZERO:
4738	mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODEMPFR_RNDN);
4739	break;
4740
4741	default:
4742	gfc_free_expr (init_expr);
4743	init_expr = NULL__null;
4744	break;
4745	}
4746	break;
4747
4748	case BT_COMPLEX:
4749	switch (init_real)
4750	{
4751	case GFC_INIT_REAL_SNAN:
4752	init_expr->is_snan = 1;
4753	/* Fall through. */
4754	case GFC_INIT_REAL_NAN:
4755	mpfr_set_nan (mpc_realref (init_expr->value.complex)((init_expr->value.complex)->re));
4756	mpfr_set_nan (mpc_imagref (init_expr->value.complex)((init_expr->value.complex)->im));
4757	break;
4758
4759	case GFC_INIT_REAL_INF:
4760	mpfr_set_inf (mpc_realref (init_expr->value.complex)((init_expr->value.complex)->re), 1);
4761	mpfr_set_inf (mpc_imagref (init_expr->value.complex)((init_expr->value.complex)->im), 1);
4762	break;
4763
4764	case GFC_INIT_REAL_NEG_INF:
4765	mpfr_set_inf (mpc_realref (init_expr->value.complex)((init_expr->value.complex)->re), -1);
4766	mpfr_set_inf (mpc_imagref (init_expr->value.complex)((init_expr->value.complex)->im), -1);
4767	break;
4768
4769	case GFC_INIT_REAL_ZERO:
4770	mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
4771	break;
4772
4773	default:
4774	gfc_free_expr (init_expr);
4775	init_expr = NULL__null;
4776	break;
4777	}
4778	break;
4779
4780	case BT_LOGICAL:
4781	if (init_logical == GFC_INIT_LOGICAL_FALSE)
4782	init_expr->value.logical = 0;
4783	else if (init_logical == GFC_INIT_LOGICAL_TRUE)
4784	init_expr->value.logical = 1;
4785	else
4786	{
4787	gfc_free_expr (init_expr);
4788	init_expr = NULL__null;
4789	}
4790	break;
4791
4792	case BT_CHARACTER:
4793	/* For characters, the length must be constant in order to
4794	create a default initializer. */
4795	if ((force \|\| gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON)
4796	&& ts->u.cl->length
4797	&& ts->u.cl->length->expr_type == EXPR_CONSTANT)
4798	{
4799	HOST_WIDE_INTlong char_len = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
4800	init_expr->value.character.length = char_len;
4801	init_expr->value.character.string = gfc_get_wide_string (char_len+1)((gfc_char_t *) xcalloc ((char_len+1), sizeof (gfc_char_t)));
4802	for (size_t i = 0; i < (size_t) char_len; i++)
4803	init_expr->value.character.string[i]
4804	= (unsigned char) gfc_option.flag_init_character_value;
4805	}
4806	else
4807	{
4808	gfc_free_expr (init_expr);
4809	init_expr = NULL__null;
4810	}
4811	if (!init_expr
4812	&& (force \|\| gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON)
4813	&& ts->u.cl->length && flag_max_stack_var_sizeglobal_options.x_flag_max_stack_var_size != 0)
4814	{
4815	gfc_actual_arglist *arg;
4816	init_expr = gfc_get_expr ();
4817	init_expr->where = *where;
4818	init_expr->ts = *ts;
4819	init_expr->expr_type = EXPR_FUNCTION;
4820	init_expr->value.function.isym =
4821	gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT);
4822	init_expr->value.function.name = "repeat";
4823	arg = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist )));
4824	arg->expr = gfc_get_character_expr (ts->kind, where, NULL__null, 1);
4825	arg->expr->value.character.string[0] =
4826	gfc_option.flag_init_character_value;
4827	arg->next = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist )));
4828	arg->next->expr = gfc_copy_expr (ts->u.cl->length);
4829	init_expr->value.function.actual = arg;
4830	}
4831	break;
4832
4833	default:
4834	gfc_free_expr (init_expr);
4835	init_expr = NULL__null;
4836	}
4837
4838	return init_expr;
4839	}
4840
4841	/* Invoke gfc_build_init_expr to create an initializer expression, but do not
4842	* require that an expression be built. */
4843
4844	gfc_expr *
4845	gfc_build_default_init_expr (gfc_typespec ts, locus where)
4846	{
4847	return gfc_build_init_expr (ts, where, false);
4848	}
4849
4850	/* Apply an initialization expression to a typespec. Can be used for symbols or
4851	components. Similar to add_init_expr_to_sym in decl.cc; could probably be
4852	combined with some effort. */
4853
4854	void
4855	gfc_apply_init (gfc_typespec ts, symbol_attribute attr, gfc_expr *init)
4856	{
4857	if (ts->type == BT_CHARACTER && !attr->pointer && init
4858	&& ts->u.cl
4859	&& ts->u.cl->length
4860	&& ts->u.cl->length->expr_type == EXPR_CONSTANT
4861	&& ts->u.cl->length->ts.type == BT_INTEGER)
4862	{
4863	HOST_WIDE_INTlong len = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
4864
4865	if (init->expr_type == EXPR_CONSTANT)
4866	gfc_set_constant_character_len (len, init, -1);
4867	else if (init
4868	&& init->ts.type == BT_CHARACTER
4869	&& init->ts.u.cl && init->ts.u.cl->length
4870	&& mpz_cmp__gmpz_cmp (ts->u.cl->length->value.integer,
4871	init->ts.u.cl->length->value.integer))
4872	{
4873	gfc_constructor *ctor;
4874	ctor = gfc_constructor_first (init->value.constructor);
4875
4876	if (ctor)
4877	{
4878	bool has_ts = (init->ts.u.cl
4879	&& init->ts.u.cl->length_from_typespec);
4880
4881	/* Remember the length of the first element for checking
4882	that all elements in the constructor have the same
4883	length. This need not be the length of the LHS! */
4884	gcc_assert (ctor->expr->expr_type == EXPR_CONSTANT)((void)(!(ctor->expr->expr_type == EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 4884, __FUNCTION__), 0 : 0));
4885	gcc_assert (ctor->expr->ts.type == BT_CHARACTER)((void)(!(ctor->expr->ts.type == BT_CHARACTER) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 4885, __FUNCTION__), 0 : 0));
4886	gfc_charlen_t first_len = ctor->expr->value.character.length;
4887
4888	for ( ; ctor; ctor = gfc_constructor_next (ctor))
4889	if (ctor->expr->expr_type == EXPR_CONSTANT)
4890	{
4891	gfc_set_constant_character_len (len, ctor->expr,
4892	has_ts ? -1 : first_len);
4893	if (!ctor->expr->ts.u.cl)
4894	ctor->expr->ts.u.cl
4895	= gfc_new_charlen (gfc_current_ns, ts->u.cl);
4896	else
4897	ctor->expr->ts.u.cl->length
4898	= gfc_copy_expr (ts->u.cl->length);
4899	}
4900	}
4901	}
4902	}
4903	}
4904
4905
4906	/* Check whether an expression is a structure constructor and whether it has
4907	other values than NULL. */
4908
4909	static bool
4910	is_non_empty_structure_constructor (gfc_expr * e)
4911	{
4912	if (e->expr_type != EXPR_STRUCTURE)
4913	return false;
4914
4915	gfc_constructor *cons = gfc_constructor_first (e->value.constructor);
4916	while (cons)
4917	{
4918	if (!cons->expr \|\| cons->expr->expr_type != EXPR_NULL)
4919	return true;
4920	cons = gfc_constructor_next (cons);
4921	}
4922	return false;
4923	}
4924
4925
4926	/* Check for default initializer; sym->value is not enough
4927	as it is also set for EXPR_NULL of allocatables. */
4928
4929	bool
4930	gfc_has_default_initializer (gfc_symbol *der)
4931	{
4932	gfc_component *c;
4933
4934	gcc_assert (gfc_fl_struct (der->attr.flavor))((void)(!(((der->attr.flavor) == FL_DERIVED \|\| (der->attr .flavor) == FL_UNION \|\| (der->attr.flavor) == FL_STRUCT)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 4934, __FUNCTION__), 0 : 0));
4935	for (c = der->components; c; c = c->next)
4936	if (gfc_bt_struct (c->ts.type)((c->ts.type) == BT_DERIVED \|\| (c->ts.type) == BT_UNION ))
4937	{
4938	if (!c->attr.pointer && !c->attr.proc_pointer
4939	&& !(c->attr.allocatable && der == c->ts.u.derived)
4940	&& ((c->initializer
4941	&& is_non_empty_structure_constructor (c->initializer))
4942	\|\| gfc_has_default_initializer (c->ts.u.derived)))
4943	return true;
4944	if (c->attr.pointer && c->initializer)
4945	return true;
4946	}
4947	else
4948	{
4949	if (c->initializer)
4950	return true;
4951	}
4952
4953	return false;
4954	}
4955
4956
4957	/*
4958	Generate an initializer expression which initializes the entirety of a union.
4959	A normal structure constructor is insufficient without undue effort, because
4960	components of maps may be oddly aligned/overlapped. (For example if a
4961	character is initialized from one map overtop a real from the other, only one
4962	byte of the real is actually initialized.) Unfortunately we don't know the
4963	size of the union right now, so we can't generate a proper initializer, but
4964	we use a NULL expr as a placeholder and do the right thing later in
4965	gfc_trans_subcomponent_assign.
4966	*/
4967	static gfc_expr *
4968	generate_union_initializer (gfc_component *un)
4969	{
4970	if (un == NULL__null \|\| un->ts.type != BT_UNION)
4971	return NULL__null;
4972
4973	gfc_expr *placeholder = gfc_get_null_expr (&un->loc);
4974	placeholder->ts = un->ts;
4975	return placeholder;
4976	}
4977
4978
4979	/* Get the user-specified initializer for a union, if any. This means the user
4980	has said to initialize component(s) of a map. For simplicity's sake we
4981	only allow the user to initialize the first map. We don't have to worry
4982	about overlapping initializers as they are released early in resolution (see
4983	resolve_fl_struct). */
4984
4985	static gfc_expr *
4986	get_union_initializer (gfc_symbol union_type, gfc_component *map_p)
4987	{
4988	gfc_component *map;
4989	gfc_expr *init=NULL__null;
4990
4991	if (!union_type \|\| union_type->attr.flavor != FL_UNION)
4992	return NULL__null;
4993
4994	for (map = union_type->components; map; map = map->next)
4995	{
4996	if (gfc_has_default_initializer (map->ts.u.derived))
4997	{
4998	init = gfc_default_initializer (&map->ts);
4999	if (map_p)
5000	*map_p = map;
5001	break;
5002	}
5003	}
5004
5005	if (map_p && !init)
5006	*map_p = NULL__null;
5007
5008	return init;
5009	}
5010
5011	static bool
5012	class_allocatable (gfc_component *comp)
5013	{
5014	return comp->ts.type == BT_CLASS && comp->attr.class_ok && CLASS_DATA (comp)comp->ts.u.derived->components
5015	&& CLASS_DATA (comp)comp->ts.u.derived->components->attr.allocatable;
5016	}
5017
5018	static bool
5019	class_pointer (gfc_component *comp)
5020	{
5021	return comp->ts.type == BT_CLASS && comp->attr.class_ok && CLASS_DATA (comp)comp->ts.u.derived->components
5022	&& CLASS_DATA (comp)comp->ts.u.derived->components->attr.pointer;
5023	}
5024
5025	static bool
5026	comp_allocatable (gfc_component *comp)
5027	{
5028	return comp->attr.allocatable \|\| class_allocatable (comp);
5029	}
5030
5031	static bool
5032	comp_pointer (gfc_component *comp)
5033	{
5034	return comp->attr.pointer
5035	\|\| comp->attr.proc_pointer
5036	\|\| comp->attr.class_pointer
5037	\|\| class_pointer (comp);
5038	}
5039
5040	/* Fetch or generate an initializer for the given component.
5041	Only generate an initializer if generate is true. */
5042
5043	static gfc_expr *
5044	component_initializer (gfc_component *c, bool generate)
5045	{
5046	gfc_expr *init = NULL__null;
5047
5048	/* Allocatable components always get EXPR_NULL.
5049	Pointer components are only initialized when generating, and only if they
5050	do not already have an initializer. */
5051	if (comp_allocatable (c) \|\| (generate && comp_pointer (c) && !c->initializer))
5052	{
5053	init = gfc_get_null_expr (&c->loc);
5054	init->ts = c->ts;
5055	return init;
5056	}
5057
5058	/* See if we can find the initializer immediately. */
5059	if (c->initializer \|\| !generate)
5060	return c->initializer;
5061
5062	/* Recursively handle derived type components. */
5063	else if (c->ts.type == BT_DERIVED \|\| c->ts.type == BT_CLASS)
5064	init = gfc_generate_initializer (&c->ts, true);
5065
5066	else if (c->ts.type == BT_UNION && c->ts.u.derived->components)
5067	{
5068	gfc_component *map = NULL__null;
5069	gfc_constructor *ctor;
5070	gfc_expr *user_init;
5071
5072	/* If we don't have a user initializer and we aren't generating one, this
5073	union has no initializer. */
5074	user_init = get_union_initializer (c->ts.u.derived, &map);
5075	if (!user_init && !generate)
5076	return NULL__null;
5077
5078	/* Otherwise use a structure constructor. */
5079	init = gfc_get_structure_constructor_expr (c->ts.type, c->ts.kind,
5080	&c->loc);
5081	init->ts = c->ts;
5082
5083	/* If we are to generate an initializer for the union, add a constructor
5084	which initializes the whole union first. */
5085	if (generate)
5086	{
5087	ctor = gfc_constructor_get ();
5088	ctor->expr = generate_union_initializer (c);
5089	gfc_constructor_append (&init->value.constructor, ctor);
5090	}
5091
5092	/* If we found an initializer in one of our maps, apply it. Note this
5093	is applied _after_ the entire-union initializer above if any. */
5094	if (user_init)
5095	{
5096	ctor = gfc_constructor_get ();
5097	ctor->expr = user_init;
5098	ctor->n.component = map;
5099	gfc_constructor_append (&init->value.constructor, ctor);
5100	}
5101	}
5102
5103	/* Treat simple components like locals. */
5104	else
5105	{
5106	/* We MUST give an initializer, so force generation. */
5107	init = gfc_build_init_expr (&c->ts, &c->loc, true);
5108	gfc_apply_init (&c->ts, &c->attr, init);
5109	}
5110
5111	return init;
5112	}
5113
5114
5115	/* Get an expression for a default initializer of a derived type. */
5116
5117	gfc_expr *
5118	gfc_default_initializer (gfc_typespec *ts)
5119	{
5120	return gfc_generate_initializer (ts, false);
5121	}
5122
5123	/* Generate an initializer expression for an iso_c_binding type
5124	such as c_[fun]ptr. The appropriate initializer is c_null_[fun]ptr. */
5125
5126	static gfc_expr *
5127	generate_isocbinding_initializer (gfc_symbol *derived)
5128	{
5129	/* The initializers have already been built into the c_null_[fun]ptr symbols
5130	from gen_special_c_interop_ptr. */
5131	gfc_symtree *npsym = NULL__null;
5132	if (0 == strcmp (derived->name, "c_ptr"))
5133	gfc_find_sym_tree ("c_null_ptr", gfc_current_ns, true, &npsym);
5134	else if (0 == strcmp (derived->name, "c_funptr"))
5135	gfc_find_sym_tree ("c_null_funptr", gfc_current_ns, true, &npsym);
5136	else
5137	gfc_internal_error ("generate_isocbinding_initializer(): bad iso_c_binding"
5138	" type, expected %<c_ptr%> or %<c_funptr%>");
5139	if (npsym)
5140	{
5141	gfc_expr *init = gfc_copy_expr (npsym->n.sym->value);
5142	init->symtree = npsym;
5143	init->ts.is_iso_c = true;
5144	return init;
5145	}
5146
5147	return NULL__null;
5148	}
5149
5150	/* Get or generate an expression for a default initializer of a derived type.
5151	If -finit-derived is specified, generate default initialization expressions
5152	for components that lack them when generate is set. */
5153
5154	gfc_expr *
5155	gfc_generate_initializer (gfc_typespec *ts, bool generate)
5156	{
5157	gfc_expr init, tmp;
5158	gfc_component *comp;
5159
5160	generate = flag_init_derivedglobal_options.x_flag_init_derived && generate;
5161
5162	if (ts->u.derived->ts.is_iso_c && generate)
5163	return generate_isocbinding_initializer (ts->u.derived);
5164
5165	/* See if we have a default initializer in this, but not in nested
5166	types (otherwise we could use gfc_has_default_initializer()).
5167	We don't need to check if we are going to generate them. */
5168	comp = ts->u.derived->components;
5169	if (!generate)
5170	{
5171	for (; comp; comp = comp->next)
5172	if (comp->initializer \|\| comp_allocatable (comp))
5173	break;
5174	}
5175
5176	if (!comp)
5177	return NULL__null;
5178
5179	init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
5180	&ts->u.derived->declared_at);
5181	init->ts = *ts;
5182
5183	for (comp = ts->u.derived->components; comp; comp = comp->next)
5184	{
5185	gfc_constructor *ctor = gfc_constructor_get();
5186
5187	/* Fetch or generate an initializer for the component. */
5188	tmp = component_initializer (comp, generate);
5189	if (tmp)
5190	{
5191	/* Save the component ref for STRUCTUREs and UNIONs. */
5192	if (ts->u.derived->attr.flavor == FL_STRUCT
5193	\|\| ts->u.derived->attr.flavor == FL_UNION)
5194	ctor->n.component = comp;
5195
5196	/* If the initializer was not generated, we need a copy. */
5197	ctor->expr = comp->initializer ? gfc_copy_expr (tmp) : tmp;
5198	if ((comp->ts.type != tmp->ts.type \|\| comp->ts.kind != tmp->ts.kind)
5199	&& !comp->attr.pointer && !comp->attr.proc_pointer)
5200	{
5201	bool val;
5202	val = gfc_convert_type_warn (ctor->expr, &comp->ts, 1, false);
5203	if (val == false)
5204	return NULL__null;
5205	}
5206	}
5207
5208	gfc_constructor_append (&init->value.constructor, ctor);
5209	}
5210
5211	return init;
5212	}
5213
5214
5215	/* Given a symbol, create an expression node with that symbol as a
5216	variable. If the symbol is array valued, setup a reference of the
5217	whole array. */
5218
5219	gfc_expr *
5220	gfc_get_variable_expr (gfc_symtree *var)
5221	{
5222	gfc_expr *e;
5223
5224	e = gfc_get_expr ();
5225	e->expr_type = EXPR_VARIABLE;
5226	e->symtree = var;
5227	e->ts = var->n.sym->ts;
5228
5229	if (var->n.sym->attr.flavor != FL_PROCEDURE
5230	&& ((var->n.sym->as != NULL__null && var->n.sym->ts.type != BT_CLASS)
5231	\|\| (var->n.sym->ts.type == BT_CLASS && var->n.sym->ts.u.derived
5232	&& CLASS_DATA (var->n.sym)var->n.sym->ts.u.derived->components
5233	&& CLASS_DATA (var->n.sym)var->n.sym->ts.u.derived->components->as)))
5234	{
5235	e->rank = var->n.sym->ts.type == BT_CLASS
5236	? CLASS_DATA (var->n.sym)var->n.sym->ts.u.derived->components->as->rank : var->n.sym->as->rank;
5237	e->ref = gfc_get_ref ()((gfc_ref *) xcalloc (1, sizeof (gfc_ref)));
5238	e->ref->type = REF_ARRAY;
5239	e->ref->u.ar.type = AR_FULL;
5240	e->ref->u.ar.as = gfc_copy_array_spec (var->n.sym->ts.type == BT_CLASS
5241	? CLASS_DATA (var->n.sym)var->n.sym->ts.u.derived->components->as
5242	: var->n.sym->as);
5243	}
5244
5245	return e;
5246	}
5247
5248
5249	/* Adds a full array reference to an expression, as needed. */
5250
5251	void
5252	gfc_add_full_array_ref (gfc_expr e, gfc_array_spec as)
5253	{
5254	gfc_ref *ref;
5255	for (ref = e->ref; ref; ref = ref->next)
5256	if (!ref->next)
5257	break;
5258	if (ref)
5259	{
5260	ref->next = gfc_get_ref ()((gfc_ref *) xcalloc (1, sizeof (gfc_ref)));
5261	ref = ref->next;
5262	}
5263	else
5264	{
5265	e->ref = gfc_get_ref ()((gfc_ref *) xcalloc (1, sizeof (gfc_ref)));
5266	ref = e->ref;
5267	}
5268	ref->type = REF_ARRAY;
5269	ref->u.ar.type = AR_FULL;
5270	ref->u.ar.dimen = e->rank;
5271	ref->u.ar.where = e->where;
5272	ref->u.ar.as = as;
5273	}
5274
5275
5276	gfc_expr *
5277	gfc_lval_expr_from_sym (gfc_symbol *sym)
5278	{
5279	gfc_expr *lval;
5280	gfc_array_spec *as;
5281	lval = gfc_get_expr ();
5282	lval->expr_type = EXPR_VARIABLE;
5283	lval->where = sym->declared_at;
5284	lval->ts = sym->ts;
5285	lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
5286
5287	/* It will always be a full array. */
5288	as = IS_CLASS_ARRAY (sym)(sym->ts.type == BT_CLASS && sym->ts.u.derived-> components && sym->ts.u.derived->components-> attr.dimension && !sym->ts.u.derived->components ->attr.class_pointer) ? CLASS_DATA (sym)sym->ts.u.derived->components->as : sym->as;
5289	lval->rank = as ? as->rank : 0;
5290	if (lval->rank)
5291	gfc_add_full_array_ref (lval, as);
5292	return lval;
5293	}
5294
5295
5296	/* Returns the array_spec of a full array expression. A NULL is
5297	returned otherwise. */
5298	gfc_array_spec *
5299	gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
5300	{
5301	gfc_array_spec *as;
5302	gfc_ref *ref;
5303
5304	if (expr->rank == 0)
5305	return NULL__null;
5306
5307	/* Follow any component references. */
5308	if (expr->expr_type == EXPR_VARIABLE
5309	\|\| expr->expr_type == EXPR_CONSTANT)
5310	{
5311	if (expr->symtree)
5312	as = expr->symtree->n.sym->as;
5313	else
5314	as = NULL__null;
5315
5316	for (ref = expr->ref; ref; ref = ref->next)
5317	{
5318	switch (ref->type)
5319	{
5320	case REF_COMPONENT:
5321	as = ref->u.c.component->as;
5322	continue;
5323
5324	case REF_SUBSTRING:
5325	case REF_INQUIRY:
5326	continue;
5327
5328	case REF_ARRAY:
5329	{
5330	switch (ref->u.ar.type)
5331	{
5332	case AR_ELEMENT:
5333	case AR_SECTION:
5334	case AR_UNKNOWN:
5335	as = NULL__null;
5336	continue;
5337
5338	case AR_FULL:
5339	break;
5340	}
5341	break;
5342	}
5343	}
5344	}
5345	}
5346	else
5347	as = NULL__null;
5348
5349	return as;
5350	}
5351
5352
5353	/* General expression traversal function. */
5354
5355	bool
5356	gfc_traverse_expr (gfc_expr expr, gfc_symbol sym,
5357	bool (func)(gfc_expr , gfc_symbol , int),
5358	int f)
5359	{
5360	gfc_array_ref ar;
5361	gfc_ref *ref;
5362	gfc_actual_arglist *args;
5363	gfc_constructor *c;
5364	int i;
5365
5366	if (!expr)
5367	return false;
5368
5369	if ((*func) (expr, sym, &f))
5370	return true;
5371
5372	if (expr->ts.type == BT_CHARACTER
5373	&& expr->ts.u.cl
5374	&& expr->ts.u.cl->length
5375	&& expr->ts.u.cl->length->expr_type != EXPR_CONSTANT
5376	&& gfc_traverse_expr (expr->ts.u.cl->length, sym, func, f))
5377	return true;
5378
5379	switch (expr->expr_type)
5380	{
5381	case EXPR_PPC:
5382	case EXPR_COMPCALL:
5383	case EXPR_FUNCTION:
5384	for (args = expr->value.function.actual; args; args = args->next)
5385	{
5386	if (gfc_traverse_expr (args->expr, sym, func, f))
5387	return true;
5388	}
5389	break;
5390
5391	case EXPR_VARIABLE:
5392	case EXPR_CONSTANT:
5393	case EXPR_NULL:
5394	case EXPR_SUBSTRING:
5395	break;
5396
5397	case EXPR_STRUCTURE:
5398	case EXPR_ARRAY:
5399	for (c = gfc_constructor_first (expr->value.constructor);
5400	c; c = gfc_constructor_next (c))
5401	{
5402	if (gfc_traverse_expr (c->expr, sym, func, f))
5403	return true;
5404	if (c->iterator)
5405	{
5406	if (gfc_traverse_expr (c->iterator->var, sym, func, f))
5407	return true;
5408	if (gfc_traverse_expr (c->iterator->start, sym, func, f))
5409	return true;
5410	if (gfc_traverse_expr (c->iterator->end, sym, func, f))
5411	return true;
5412	if (gfc_traverse_expr (c->iterator->step, sym, func, f))
5413	return true;
5414	}
5415	}
5416	break;
5417
5418	case EXPR_OP:
5419	if (gfc_traverse_expr (expr->value.op.op1, sym, func, f))
5420	return true;
5421	if (gfc_traverse_expr (expr->value.op.op2, sym, func, f))
5422	return true;
5423	break;
5424
5425	default:
5426	gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 5426, __FUNCTION__));
5427	break;
5428	}
5429
5430	ref = expr->ref;
5431	while (ref != NULL__null)
5432	{
5433	switch (ref->type)
5434	{
5435	case REF_ARRAY:
5436	ar = ref->u.ar;
5437	for (i = 0; i < GFC_MAX_DIMENSIONS15; i++)
5438	{
5439	if (gfc_traverse_expr (ar.start[i], sym, func, f))
5440	return true;
5441	if (gfc_traverse_expr (ar.end[i], sym, func, f))
5442	return true;
5443	if (gfc_traverse_expr (ar.stride[i], sym, func, f))
5444	return true;
5445	}
5446	break;
5447
5448	case REF_SUBSTRING:
5449	if (gfc_traverse_expr (ref->u.ss.start, sym, func, f))
5450	return true;
5451	if (gfc_traverse_expr (ref->u.ss.end, sym, func, f))
5452	return true;
5453	break;
5454
5455	case REF_COMPONENT:
5456	if (ref->u.c.component->ts.type == BT_CHARACTER
5457	&& ref->u.c.component->ts.u.cl
5458	&& ref->u.c.component->ts.u.cl->length
5459	&& ref->u.c.component->ts.u.cl->length->expr_type
5460	!= EXPR_CONSTANT
5461	&& gfc_traverse_expr (ref->u.c.component->ts.u.cl->length,
5462	sym, func, f))
5463	return true;
5464
5465	if (ref->u.c.component->as)
5466	for (i = 0; i < ref->u.c.component->as->rank
5467	+ ref->u.c.component->as->corank; i++)
5468	{
5469	if (gfc_traverse_expr (ref->u.c.component->as->lower[i],
5470	sym, func, f))
5471	return true;
5472	if (gfc_traverse_expr (ref->u.c.component->as->upper[i],
5473	sym, func, f))
5474	return true;
5475	}
5476	break;
5477
5478	case REF_INQUIRY:
5479	return true;
5480
5481	default:
5482	gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 5482, __FUNCTION__));
5483	}
5484	ref = ref->next;
5485	}
5486	return false;
5487	}
5488
5489	/* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
5490
5491	static bool
5492	expr_set_symbols_referenced (gfc_expr *expr,
5493	gfc_symbol *sym ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
5494	int *f ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
5495	{
5496	if (expr->expr_type != EXPR_VARIABLE)
5497	return false;
5498	gfc_set_sym_referenced (expr->symtree->n.sym);
5499	return false;
5500	}
5501
5502	void
5503	gfc_expr_set_symbols_referenced (gfc_expr *expr)
5504	{
5505	gfc_traverse_expr (expr, NULL__null, expr_set_symbols_referenced, 0);
5506	}
5507
5508
5509	/* Determine if an expression is a procedure pointer component and return
5510	the component in that case. Otherwise return NULL. */
5511
5512	gfc_component *
5513	gfc_get_proc_ptr_comp (gfc_expr *expr)
5514	{
5515	gfc_ref *ref;
5516
5517	if (!expr \|\| !expr->ref)
5518	return NULL__null;
5519
5520	ref = expr->ref;
5521	while (ref->next)
5522	ref = ref->next;
5523
5524	if (ref->type == REF_COMPONENT
5525	&& ref->u.c.component->attr.proc_pointer)
5526	return ref->u.c.component;
5527
5528	return NULL__null;
5529	}
5530
5531
5532	/* Determine if an expression is a procedure pointer component. */
5533
5534	bool
5535	gfc_is_proc_ptr_comp (gfc_expr *expr)
5536	{
5537	return (gfc_get_proc_ptr_comp (expr) != NULL__null);
5538	}
5539
5540
5541	/* Determine if an expression is a function with an allocatable class scalar
5542	result. */
5543	bool
5544	gfc_is_alloc_class_scalar_function (gfc_expr *expr)
5545	{
5546	if (expr->expr_type == EXPR_FUNCTION
5547	&& expr->value.function.esym
5548	&& expr->value.function.esym->result
5549	&& expr->value.function.esym->result->ts.type == BT_CLASS
5550	&& !CLASS_DATA (expr->value.function.esym->result)expr->value.function.esym->result->ts.u.derived-> components->attr.dimension
5551	&& CLASS_DATA (expr->value.function.esym->result)expr->value.function.esym->result->ts.u.derived-> components->attr.allocatable)
5552	return true;
5553
5554	return false;
5555	}
5556
5557
5558	/* Determine if an expression is a function with an allocatable class array
5559	result. */
5560	bool
5561	gfc_is_class_array_function (gfc_expr *expr)
5562	{
5563	if (expr->expr_type == EXPR_FUNCTION
5564	&& expr->value.function.esym
5565	&& expr->value.function.esym->result
5566	&& expr->value.function.esym->result->ts.type == BT_CLASS
5567	&& CLASS_DATA (expr->value.function.esym->result)expr->value.function.esym->result->ts.u.derived-> components->attr.dimension
5568	&& (CLASS_DATA (expr->value.function.esym->result)expr->value.function.esym->result->ts.u.derived-> components->attr.allocatable
5569	\|\| CLASS_DATA (expr->value.function.esym->result)expr->value.function.esym->result->ts.u.derived-> components->attr.pointer))
5570	return true;
5571
5572	return false;
5573	}
5574
5575
5576	/* Walk an expression tree and check each variable encountered for being typed.
5577	If strict is not set, a top-level variable is tolerated untyped in -std=gnu
5578	mode as is a basic arithmetic expression using those; this is for things in
5579	legacy-code like:
5580
5581	INTEGER :: arr(n), n
5582	INTEGER :: arr(n + 1), n
5583
5584	The namespace is needed for IMPLICIT typing. */
5585
5586	static gfc_namespace* check_typed_ns;
5587
5588	static bool
5589	expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
5590	int* f ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
5591	{
5592	bool t;
5593
5594	if (e->expr_type != EXPR_VARIABLE)
5595	return false;
5596
5597	gcc_assert (e->symtree)((void)(!(e->symtree) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 5597, __FUNCTION__), 0 : 0));
5598	t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns,
5599	true, e->where);
5600
5601	return (!t);
5602	}
5603
5604	bool
5605	gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
5606	{
5607	bool error_found;
5608
5609	/* If this is a top-level variable or EXPR_OP, do the check with strict given
5610	to us. */
5611	if (!strict)
5612	{
5613	if (e->expr_type == EXPR_VARIABLE && !e->ref)
5614	return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where);
5615
5616	if (e->expr_type == EXPR_OP)
5617	{
5618	bool t = true;
5619
5620	gcc_assert (e->value.op.op1)((void)(!(e->value.op.op1) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 5620, __FUNCTION__), 0 : 0));
5621	t = gfc_expr_check_typed (e->value.op.op1, ns, strict);
5622
5623	if (t && e->value.op.op2)
5624	t = gfc_expr_check_typed (e->value.op.op2, ns, strict);
5625
5626	return t;
5627	}
5628	}
5629
5630	/* Otherwise, walk the expression and do it strictly. */
5631	check_typed_ns = ns;
5632	error_found = gfc_traverse_expr (e, NULL__null, &expr_check_typed_help, 0);
5633
5634	return error_found ? false : true;
5635	}
5636
5637
5638	/* This function returns true if it contains any references to PDT KIND
5639	or LEN parameters. */
5640
5641	static bool
5642	derived_parameter_expr (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
5643	int* f ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
5644	{
5645	if (e->expr_type != EXPR_VARIABLE)
5646	return false;
5647
5648	gcc_assert (e->symtree)((void)(!(e->symtree) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 5648, __FUNCTION__), 0 : 0));
5649	if (e->symtree->n.sym->attr.pdt_kind
5650	\|\| e->symtree->n.sym->attr.pdt_len)
5651	return true;
5652
5653	return false;
5654	}
5655
5656
5657	bool
5658	gfc_derived_parameter_expr (gfc_expr *e)
5659	{
5660	return gfc_traverse_expr (e, NULL__null, &derived_parameter_expr, 0);
5661	}
5662
5663
5664	/* This function returns the overall type of a type parameter spec list.
5665	If all the specs are explicit, SPEC_EXPLICIT is returned. If any of the
5666	parameters are assumed/deferred then SPEC_ASSUMED/DEFERRED is returned
5667	unless derived is not NULL. In this latter case, all the LEN parameters
5668	must be either assumed or deferred for the return argument to be set to
5669	anything other than SPEC_EXPLICIT. */
5670
5671	gfc_param_spec_type
5672	gfc_spec_list_type (gfc_actual_arglist param_list, gfc_symbol derived)
5673	{
5674	gfc_param_spec_type res = SPEC_EXPLICIT;
5675	gfc_component *c;
5676	bool seen_assumed = false;
5677	bool seen_deferred = false;
5678
5679	if (derived == NULL__null)
5680	{
5681	for (; param_list; param_list = param_list->next)
5682	if (param_list->spec_type == SPEC_ASSUMED
5683	\|\| param_list->spec_type == SPEC_DEFERRED)
5684	return param_list->spec_type;
5685	}
5686	else
5687	{
5688	for (; param_list; param_list = param_list->next)
5689	{
5690	c = gfc_find_component (derived, param_list->name,
5691	true, true, NULL__null);
5692	gcc_assert (c != NULL)((void)(!(c != __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 5692, __FUNCTION__), 0 : 0));
5693	if (c->attr.pdt_kind)
5694	continue;
5695	else if (param_list->spec_type == SPEC_EXPLICIT)
5696	return SPEC_EXPLICIT;
5697	seen_assumed = param_list->spec_type == SPEC_ASSUMED;
5698	seen_deferred = param_list->spec_type == SPEC_DEFERRED;
5699	if (seen_assumed && seen_deferred)
5700	return SPEC_EXPLICIT;
5701	}
5702	res = seen_assumed ? SPEC_ASSUMED : SPEC_DEFERRED;
5703	}
5704	return res;
5705	}
5706
5707
5708	bool
5709	gfc_ref_this_image (gfc_ref *ref)
5710	{
5711	int n;
5712
5713	gcc_assert (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)((void)(!(ref->type == REF_ARRAY && ref->u.ar.codimen > 0) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 5713, __FUNCTION__), 0 : 0));
5714
5715	for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
5716	if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
5717	return false;
5718
5719	return true;
5720	}
5721
5722	gfc_expr *
5723	gfc_find_team_co (gfc_expr *e)
5724	{
5725	gfc_ref *ref;
5726
5727	for (ref = e->ref; ref; ref = ref->next)
5728	if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5729	return ref->u.ar.team;
5730
5731	if (e->value.function.actual->expr)
5732	for (ref = e->value.function.actual->expr->ref; ref;
5733	ref = ref->next)
5734	if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5735	return ref->u.ar.team;
5736
5737	return NULL__null;
5738	}
5739
5740	gfc_expr *
5741	gfc_find_stat_co (gfc_expr *e)
5742	{
5743	gfc_ref *ref;
5744
5745	for (ref = e->ref; ref; ref = ref->next)
5746	if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5747	return ref->u.ar.stat;
5748
5749	if (e->value.function.actual->expr)
5750	for (ref = e->value.function.actual->expr->ref; ref;
5751	ref = ref->next)
5752	if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5753	return ref->u.ar.stat;
5754
5755	return NULL__null;
5756	}
5757
5758	bool
5759	gfc_is_coindexed (gfc_expr *e)
5760	{
5761	gfc_ref *ref;
5762
5763	for (ref = e->ref; ref; ref = ref->next)
5764	if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5765	return !gfc_ref_this_image (ref);
5766
5767	return false;
5768	}
5769
5770
5771	/* Coarrays are variables with a corank but not being coindexed. However, also
5772	the following is a coarray: A subobject of a coarray is a coarray if it does
5773	not have any cosubscripts, vector subscripts, allocatable component
5774	selection, or pointer component selection. (F2008, 2.4.7) */
5775
5776	bool
5777	gfc_is_coarray (gfc_expr *e)
5778	{
5779	gfc_ref *ref;
5780	gfc_symbol *sym;
5781	gfc_component *comp;
5782	bool coindexed;
5783	bool coarray;
5784	int i;
5785
5786	if (e->expr_type != EXPR_VARIABLE)
5787	return false;
5788
5789	coindexed = false;
5790	sym = e->symtree->n.sym;
5791
5792	if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
5793	coarray = CLASS_DATA (sym)sym->ts.u.derived->components->attr.codimension;
5794	else
5795	coarray = sym->attr.codimension;
5796
5797	for (ref = e->ref; ref; ref = ref->next)
5798	switch (ref->type)
5799	{
5800	case REF_COMPONENT:
5801	comp = ref->u.c.component;
5802	if (comp->ts.type == BT_CLASS && comp->attr.class_ok
5803	&& (CLASS_DATA (comp)comp->ts.u.derived->components->attr.class_pointer
5804	\|\| CLASS_DATA (comp)comp->ts.u.derived->components->attr.allocatable))
5805	{
5806	coindexed = false;
5807	coarray = CLASS_DATA (comp)comp->ts.u.derived->components->attr.codimension;
5808	}
5809	else if (comp->attr.pointer \|\| comp->attr.allocatable)
5810	{
5811	coindexed = false;
5812	coarray = comp->attr.codimension;
5813	}
5814	break;
5815
5816	case REF_ARRAY:
5817	if (!coarray)
5818	break;
5819
5820	if (ref->u.ar.codimen > 0 && !gfc_ref_this_image (ref))
5821	{
5822	coindexed = true;
5823	break;
5824	}
5825
5826	for (i = 0; i < ref->u.ar.dimen; i++)
5827	if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
5828	{
5829	coarray = false;
5830	break;
5831	}
5832	break;
5833
5834	case REF_SUBSTRING:
5835	case REF_INQUIRY:
5836	break;
5837	}
5838
5839	return coarray && !coindexed;
5840	}
5841
5842
5843	int
5844	gfc_get_corank (gfc_expr *e)
5845	{
5846	int corank;
5847	gfc_ref *ref;
5848
5849	if (!gfc_is_coarray (e))
5850	return 0;
5851
5852	if (e->ts.type == BT_CLASS && e->ts.u.derived->components)
5853	corank = e->ts.u.derived->components->as
5854	? e->ts.u.derived->components->as->corank : 0;
5855	else
5856	corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0;
5857
5858	for (ref = e->ref; ref; ref = ref->next)
5859	{
5860	if (ref->type == REF_ARRAY)
5861	corank = ref->u.ar.as->corank;
5862	gcc_assert (ref->type != REF_SUBSTRING)((void)(!(ref->type != REF_SUBSTRING) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 5862, __FUNCTION__), 0 : 0));
5863	}
5864
5865	return corank;
5866	}
5867
5868
5869	/* Check whether the expression has an ultimate allocatable component.
5870	Being itself allocatable does not count. */
5871	bool
5872	gfc_has_ultimate_allocatable (gfc_expr *e)
5873	{
5874	gfc_ref ref, last = NULL__null;
5875
5876	if (e->expr_type != EXPR_VARIABLE)
5877	return false;
5878
5879	for (ref = e->ref; ref; ref = ref->next)
5880	if (ref->type == REF_COMPONENT)
5881	last = ref;
5882
5883	if (last && last->u.c.component->ts.type == BT_CLASS)
5884	return CLASS_DATA (last->u.c.component)last->u.c.component->ts.u.derived->components->attr.alloc_comp;
5885	else if (last && last->u.c.component->ts.type == BT_DERIVED)
5886	return last->u.c.component->ts.u.derived->attr.alloc_comp;
5887	else if (last)
5888	return false;
5889
5890	if (e->ts.type == BT_CLASS)
5891	return CLASS_DATA (e)e->ts.u.derived->components->attr.alloc_comp;
5892	else if (e->ts.type == BT_DERIVED)
5893	return e->ts.u.derived->attr.alloc_comp;
5894	else
5895	return false;
5896	}
5897
5898
5899	/* Check whether the expression has an pointer component.
5900	Being itself a pointer does not count. */
5901	bool
5902	gfc_has_ultimate_pointer (gfc_expr *e)
5903	{
5904	gfc_ref ref, last = NULL__null;
5905
5906	if (e->expr_type != EXPR_VARIABLE)
5907	return false;
5908
5909	for (ref = e->ref; ref; ref = ref->next)
5910	if (ref->type == REF_COMPONENT)
5911	last = ref;
5912
5913	if (last && last->u.c.component->ts.type == BT_CLASS)
5914	return CLASS_DATA (last->u.c.component)last->u.c.component->ts.u.derived->components->attr.pointer_comp;
5915	else if (last && last->u.c.component->ts.type == BT_DERIVED)
5916	return last->u.c.component->ts.u.derived->attr.pointer_comp;
5917	else if (last)
5918	return false;
5919
5920	if (e->ts.type == BT_CLASS)
5921	return CLASS_DATA (e)e->ts.u.derived->components->attr.pointer_comp;
5922	else if (e->ts.type == BT_DERIVED)
5923	return e->ts.u.derived->attr.pointer_comp;
5924	else
5925	return false;
5926	}
5927
5928
5929	/* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
5930	Note: A scalar is not regarded as "simply contiguous" by the standard.
5931	if bool is not strict, some further checks are done - for instance,
5932	a "(::1)" is accepted. */
5933
5934	bool
5935	gfc_is_simply_contiguous (gfc_expr *expr, bool strict, bool permit_element)
5936	{
5937	bool colon;
5938	int i;
5939	gfc_array_ref *ar = NULL__null;
5940	gfc_ref ref, part_ref = NULL__null;
5941	gfc_symbol *sym;
5942
5943	if (expr->expr_type == EXPR_ARRAY)
5944	return true;
5945
5946	if (expr->expr_type == EXPR_FUNCTION)
5947	{
5948	if (expr->value.function.isym)
5949	/* TRANSPOSE is the only intrinsic that may return a
5950	non-contiguous array. It's treated as a special case in
5951	gfc_conv_expr_descriptor too. */
5952	return (expr->value.function.isym->id != GFC_ISYM_TRANSPOSE);
5953	else if (expr->value.function.esym)
5954	/* Only a pointer to an array without the contiguous attribute
5955	can be non-contiguous as a result value. */
5956	return (expr->value.function.esym->result->attr.contiguous
5957	\|\| !expr->value.function.esym->result->attr.pointer);
5958	else
5959	{
5960	/* Type-bound procedures. */
5961	gfc_symbol *s = expr->symtree->n.sym;
5962	if (s->ts.type != BT_CLASS && s->ts.type != BT_DERIVED)
5963	return false;
5964
5965	gfc_ref *rc = NULL__null;
5966	for (gfc_ref *r = expr->ref; r; r = r->next)
5967	if (r->type == REF_COMPONENT)
5968	rc = r;
5969
5970	if (rc == NULL__null \|\| rc->u.c.component == NULL__null
5971	\|\| rc->u.c.component->ts.interface == NULL__null)
5972	return false;
5973
5974	return rc->u.c.component->ts.interface->attr.contiguous;
5975	}
5976	}
5977	else if (expr->expr_type != EXPR_VARIABLE)
5978	return false;
5979
5980	if (!permit_element && expr->rank == 0)
5981	return false;
5982
5983	for (ref = expr->ref; ref; ref = ref->next)
5984	{
5985	if (ar)
5986	return false; /* Array shall be last part-ref. */
5987
5988	if (ref->type == REF_COMPONENT)
5989	part_ref = ref;
5990	else if (ref->type == REF_SUBSTRING)
5991	return false;
5992	else if (ref->type == REF_INQUIRY)
5993	return false;
5994	else if (ref->u.ar.type != AR_ELEMENT)
5995	ar = &ref->u.ar;
5996	}
5997
5998	sym = expr->symtree->n.sym;
5999	if (expr->ts.type != BT_CLASS
6000	&& ((part_ref
6001	&& !part_ref->u.c.component->attr.contiguous
6002	&& part_ref->u.c.component->attr.pointer)
6003	\|\| (!part_ref
6004	&& !sym->attr.contiguous
6005	&& (sym->attr.pointer
6006	\|\| (sym->as && sym->as->type == AS_ASSUMED_RANK)
6007	\|\| (sym->as && sym->as->type == AS_ASSUMED_SHAPE)))))
6008	return false;
6009
6010	if (!ar \|\| ar->type == AR_FULL)
6011	return true;
6012
6013	gcc_assert (ar->type == AR_SECTION)((void)(!(ar->type == AR_SECTION) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 6013, __FUNCTION__), 0 : 0));
6014
6015	/* Check for simply contiguous array */
6016	colon = true;
6017	for (i = 0; i < ar->dimen; i++)
6018	{
6019	if (ar->dimen_type[i] == DIMEN_VECTOR)
6020	return false;
6021
6022	if (ar->dimen_type[i] == DIMEN_ELEMENT)
6023	{
6024	colon = false;
6025	continue;
6026	}
6027
6028	gcc_assert (ar->dimen_type[i] == DIMEN_RANGE)((void)(!(ar->dimen_type[i] == DIMEN_RANGE) ? fancy_abort ( "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 6028, __FUNCTION__), 0 : 0));
6029
6030
6031	/* If the previous section was not contiguous, that's an error,
6032	unless we have effective only one element and checking is not
6033	strict. */
6034	if (!colon && (strict \|\| !ar->start[i] \|\| !ar->end[i]
6035	\|\| ar->start[i]->expr_type != EXPR_CONSTANT
6036	\|\| ar->end[i]->expr_type != EXPR_CONSTANT
6037	\|\| mpz_cmp__gmpz_cmp (ar->start[i]->value.integer,
6038	ar->end[i]->value.integer) != 0))
6039	return false;
6040
6041	/* Following the standard, "(::1)" or - if known at compile time -
6042	"(lbound:ubound)" are not simply contiguous; if strict
6043	is false, they are regarded as simply contiguous. */
6044	if (ar->stride[i] && (strict \|\| ar->stride[i]->expr_type != EXPR_CONSTANT
6045	\|\| ar->stride[i]->ts.type != BT_INTEGER
6046	\|\| mpz_cmp_si (ar->stride[i]->value.integer, 1)(__builtin_constant_p ((1) >= 0) && (1) >= 0 ? ( __builtin_constant_p ((static_cast<unsigned long> (1))) && ((static_cast<unsigned long> (1))) == 0 ? ( (ar->stride[i]->value.integer)->_mp_size < 0 ? -1 : (ar->stride[i]->value.integer)->_mp_size > 0) : __gmpz_cmp_ui (ar->stride[i]->value.integer,(static_cast <unsigned long> (1)))) : __gmpz_cmp_si (ar->stride[i ]->value.integer,1)) != 0))
6047	return false;
6048
6049	if (ar->start[i]
6050	&& (strict \|\| ar->start[i]->expr_type != EXPR_CONSTANT
6051	\|\| !ar->as->lower[i]
6052	\|\| ar->as->lower[i]->expr_type != EXPR_CONSTANT
6053	\|\| mpz_cmp__gmpz_cmp (ar->start[i]->value.integer,
6054	ar->as->lower[i]->value.integer) != 0))
6055	colon = false;
6056
6057	if (ar->end[i]
6058	&& (strict \|\| ar->end[i]->expr_type != EXPR_CONSTANT
6059	\|\| !ar->as->upper[i]
6060	\|\| ar->as->upper[i]->expr_type != EXPR_CONSTANT
6061	\|\| mpz_cmp__gmpz_cmp (ar->end[i]->value.integer,
6062	ar->as->upper[i]->value.integer) != 0))
6063	colon = false;
6064	}
6065
6066	return true;
6067	}
6068
6069	/* Return true if the expression is guaranteed to be non-contiguous,
6070	false if we cannot prove anything. It is probably best to call
6071	this after gfc_is_simply_contiguous. If neither of them returns
6072	true, we cannot say (at compile-time). */
6073
6074	bool
6075	gfc_is_not_contiguous (gfc_expr *array)
6076	{
6077	int i;
6078	gfc_array_ref *ar = NULL__null;
6079	gfc_ref *ref;
6080	bool previous_incomplete;
6081
6082	for (ref = array->ref; ref; ref = ref->next)
6083	{
6084	/* Array-ref shall be last ref. */
6085
6086	if (ar && ar->type != AR_ELEMENT)
6087	return true;
6088
6089	if (ref->type == REF_ARRAY)
6090	ar = &ref->u.ar;
6091	}
6092
6093	if (ar == NULL__null \|\| ar->type != AR_SECTION)
6094	return false;
6095
6096	previous_incomplete = false;
6097
6098	/* Check if we can prove that the array is not contiguous. */
6099
6100	for (i = 0; i < ar->dimen; i++)
6101	{
6102	mpz_t arr_size, ref_size;
6103
6104	if (gfc_ref_dimen_size (ar, i, &ref_size, NULL__null))
6105	{
6106	if (gfc_dep_difference (ar->as->upper[i], ar->as->lower[i], &arr_size))
6107	{
6108	/* a(2:4,2:) is known to be non-contiguous, but
6109	a(2:4,i:i) can be contiguous. */
6110	mpz_add_ui__gmpz_add_ui (arr_size, arr_size, 1L);
6111	if (previous_incomplete && mpz_cmp_si (ref_size, 1)(__builtin_constant_p ((1) >= 0) && (1) >= 0 ? ( __builtin_constant_p ((static_cast<unsigned long> (1))) && ((static_cast<unsigned long> (1))) == 0 ? ( (ref_size)->_mp_size < 0 ? -1 : (ref_size)->_mp_size > 0) : __gmpz_cmp_ui (ref_size,(static_cast<unsigned long > (1)))) : __gmpz_cmp_si (ref_size,1)) != 0)
6112	{
6113	mpz_clear__gmpz_clear (arr_size);
6114	mpz_clear__gmpz_clear (ref_size);
6115	return true;
6116	}
6117	else if (mpz_cmp__gmpz_cmp (arr_size, ref_size) != 0)
6118	previous_incomplete = true;
6119
6120	mpz_clear__gmpz_clear (arr_size);
6121	}
6122
6123	/* Check for a(::2), i.e. where the stride is not unity.
6124	This is only done if there is more than one element in
6125	the reference along this dimension. */
6126
6127	if (mpz_cmp_ui (ref_size, 1)(__builtin_constant_p (1) && (1) == 0 ? ((ref_size)-> _mp_size < 0 ? -1 : (ref_size)->_mp_size > 0) : __gmpz_cmp_ui (ref_size,1)) > 0 && ar->type == AR_SECTION
6128	&& ar->dimen_type[i] == DIMEN_RANGE
6129	&& ar->stride[i] && ar->stride[i]->expr_type == EXPR_CONSTANT
6130	&& mpz_cmp_si (ar->stride[i]->value.integer, 1)(__builtin_constant_p ((1) >= 0) && (1) >= 0 ? ( __builtin_constant_p ((static_cast<unsigned long> (1))) && ((static_cast<unsigned long> (1))) == 0 ? ( (ar->stride[i]->value.integer)->_mp_size < 0 ? -1 : (ar->stride[i]->value.integer)->_mp_size > 0) : __gmpz_cmp_ui (ar->stride[i]->value.integer,(static_cast <unsigned long> (1)))) : __gmpz_cmp_si (ar->stride[i ]->value.integer,1)) != 0)
6131	{
6132	mpz_clear__gmpz_clear (ref_size);
6133	return true;
6134	}
6135
6136	mpz_clear__gmpz_clear (ref_size);
6137	}
6138	}
6139	/* We didn't find anything definitive. */
6140	return false;
6141	}
6142
6143	/* Build call to an intrinsic procedure. The number of arguments has to be
6144	passed (rather than ending the list with a NULL value) because we may
6145	want to add arguments but with a NULL-expression. */
6146
6147	gfc_expr*
6148	gfc_build_intrinsic_call (gfc_namespace ns, gfc_isym_id id, const char name,
6149	locus where, unsigned numarg, ...)
6150	{
6151	gfc_expr* result;
6152	gfc_actual_arglist* atail;
6153	gfc_intrinsic_sym* isym;
6154	va_list ap;
6155	unsigned i;
6156	const char *mangled_name = gfc_get_string (GFC_PREFIX ("%s")"_F." "%s", name);
6157
6158	isym = gfc_intrinsic_function_by_id (id);
6159	gcc_assert (isym)((void)(!(isym) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 6159, __FUNCTION__), 0 : 0));
6160
6161	result = gfc_get_expr ();
6162	result->expr_type = EXPR_FUNCTION;
6163	result->ts = isym->ts;
6164	result->where = where;
6165	result->value.function.name = mangled_name;
6166	result->value.function.isym = isym;
6167
6168	gfc_get_sym_tree (mangled_name, ns, &result->symtree, false);
6169	gfc_commit_symbol (result->symtree->n.sym);
6170	gcc_assert (result->symtree((void)(!(result->symtree && (result->symtree-> n.sym->attr.flavor == FL_PROCEDURE \|\| result->symtree-> n.sym->attr.flavor == FL_UNKNOWN)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 6172, __FUNCTION__), 0 : 0))
6171	&& (result->symtree->n.sym->attr.flavor == FL_PROCEDURE((void)(!(result->symtree && (result->symtree-> n.sym->attr.flavor == FL_PROCEDURE \|\| result->symtree-> n.sym->attr.flavor == FL_UNKNOWN)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 6172, __FUNCTION__), 0 : 0))
6172	\|\| result->symtree->n.sym->attr.flavor == FL_UNKNOWN))((void)(!(result->symtree && (result->symtree-> n.sym->attr.flavor == FL_PROCEDURE \|\| result->symtree-> n.sym->attr.flavor == FL_UNKNOWN)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 6172, __FUNCTION__), 0 : 0));
6173	result->symtree->n.sym->intmod_sym_id = id;
6174	result->symtree->n.sym->attr.flavor = FL_PROCEDURE;
6175	result->symtree->n.sym->attr.intrinsic = 1;
6176	result->symtree->n.sym->attr.artificial = 1;
6177
6178	va_start (ap, numarg)__builtin_va_start(ap, numarg);
6179	atail = NULL__null;
6180	for (i = 0; i < numarg; ++i)
6181	{
6182	if (atail)
6183	{
6184	atail->next = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist )));
6185	atail = atail->next;
6186	}
6187	else
6188	atail = result->value.function.actual = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist )));
6189
6190	atail->expr = va_arg (ap, gfc_expr)__builtin_va_arg(ap, gfc_expr);
6191	}
6192	va_end (ap)__builtin_va_end(ap);
6193
6194	return result;
6195	}
6196
6197
6198	/* Check if an expression may appear in a variable definition context
6199	(F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
6200	This is called from the various places when resolving
6201	the pieces that make up such a context.
6202	If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do
6203	variables), some checks are not performed.
6204
6205	Optionally, a possible error message can be suppressed if context is NULL
6206	and just the return status (true / false) be requested. */
6207
6208	bool
6209	gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
6210	bool own_scope, const char* context)
6211	{
6212	gfc_symbol* sym = NULL__null;
6213	bool is_pointer;
6214	bool check_intentin;
6215	bool ptr_component;
6216	symbol_attribute attr;
6217	gfc_ref* ref;
6218	int i;
6219
6220	if (e->expr_type == EXPR_VARIABLE)
6221	{
6222	gcc_assert (e->symtree)((void)(!(e->symtree) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 6222, __FUNCTION__), 0 : 0));
6223	sym = e->symtree->n.sym;
6224	}
6225	else if (e->expr_type == EXPR_FUNCTION)
6226	{
6227	gcc_assert (e->symtree)((void)(!(e->symtree) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 6227, __FUNCTION__), 0 : 0));
6228	sym = e->value.function.esym ? e->value.function.esym : e->symtree->n.sym;
6229	}
6230
6231	attr = gfc_expr_attr (e);
6232	if (!pointer && e->expr_type == EXPR_FUNCTION && attr.pointer)
6233	{
6234	if (!(gfc_option.allow_std & GFC_STD_F2008(1<<7)))
6235	{
6236	if (context)
6237	gfc_error ("Fortran 2008: Pointer functions in variable definition"
6238	" context (%s) at %L", context, &e->where);
6239	return false;
6240	}
6241	}
6242	else if (e->expr_type != EXPR_VARIABLE)
6243	{
6244	if (context)
6245	gfc_error ("Non-variable expression in variable definition context (%s)"
6246	" at %L", context, &e->where);
6247	return false;
6248	}
6249
6250	if (!pointer && sym->attr.flavor == FL_PARAMETER)
6251	{
6252	if (context)
6253	gfc_error ("Named constant %qs in variable definition context (%s)"
6254	" at %L", sym->name, context, &e->where);
6255	return false;
6256	}
6257	if (!pointer && sym->attr.flavor != FL_VARIABLE
6258	&& !(sym->attr.flavor == FL_PROCEDURE && sym == sym->result)
6259	&& !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer)
6260	&& !(sym->attr.flavor == FL_PROCEDURE
6261	&& sym->attr.function && sym->attr.pointer))
6262	{
6263	if (context)
6264	gfc_error ("%qs in variable definition context (%s) at %L is not"
6265	" a variable", sym->name, context, &e->where);
6266	return false;
6267	}
6268
6269	/* Find out whether the expr is a pointer; this also means following
6270	component references to the last one. */
6271	is_pointer = (attr.pointer \|\| attr.proc_pointer);
6272	if (pointer && !is_pointer)
6273	{
6274	if (context)
6275	gfc_error ("Non-POINTER in pointer association context (%s)"
6276	" at %L", context, &e->where);
6277	return false;
6278	}
6279
6280	if (e->ts.type == BT_DERIVED
6281	&& e->ts.u.derived == NULL__null)
6282	{
6283	if (context)
6284	gfc_error ("Type inaccessible in variable definition context (%s) "
6285	"at %L", context, &e->where);
6286	return false;
6287	}
6288
6289	/* F2008, C1303. */
6290	if (!alloc_obj
6291	&& (attr.lock_comp
6292	\|\| (e->ts.type == BT_DERIVED
6293	&& e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
6294	&& e->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)))
6295	{
6296	if (context)
6297	gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
6298	context, &e->where);
6299	return false;
6300	}
6301
6302	/* TS18508, C702/C203. */
6303	if (!alloc_obj
6304	&& (attr.lock_comp
6305	\|\| (e->ts.type == BT_DERIVED
6306	&& e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
6307	&& e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)))
6308	{
6309	if (context)
6310	gfc_error ("LOCK_EVENT in variable definition context (%s) at %L",
6311	context, &e->where);
6312	return false;
6313	}
6314
6315	/* INTENT(IN) dummy argument. Check this, unless the object itself is the
6316	component of sub-component of a pointer; we need to distinguish
6317	assignment to a pointer component from pointer-assignment to a pointer
6318	component. Note that (normal) assignment to procedure pointers is not
6319	possible. */
6320	check_intentin = !own_scope;
6321	ptr_component = (sym->ts.type == BT_CLASS && sym->ts.u.derived
6322	&& CLASS_DATA (sym)sym->ts.u.derived->components)
6323	? CLASS_DATA (sym)sym->ts.u.derived->components->attr.class_pointer : sym->attr.pointer;
6324	for (ref = e->ref; ref && check_intentin; ref = ref->next)
6325	{
6326	if (ptr_component && ref->type == REF_COMPONENT)
6327	check_intentin = false;
6328	if (ref->type == REF_COMPONENT)
6329	{
6330	gfc_component *comp = ref->u.c.component;
6331	ptr_component = (comp->ts.type == BT_CLASS && comp->attr.class_ok)
6332	? CLASS_DATA (comp)comp->ts.u.derived->components->attr.class_pointer
6333	: comp->attr.pointer;
6334	if (ptr_component && !pointer)
6335	check_intentin = false;
6336	}
6337	if (ref->type == REF_INQUIRY
6338	&& (ref->u.i == INQUIRY_KIND \|\| ref->u.i == INQUIRY_LEN))
6339	{
6340	if (context)
6341	gfc_error ("%qs parameter inquiry for %qs in "
6342	"variable definition context (%s) at %L",
6343	ref->u.i == INQUIRY_KIND ? "KIND" : "LEN",
6344	sym->name, context, &e->where);
6345	return false;
6346	}
6347	}
6348
6349	if (check_intentin
6350	&& (sym->attr.intent == INTENT_IN
6351	\|\| (sym->attr.select_type_temporary && sym->assoc
6352	&& sym->assoc->target && sym->assoc->target->symtree
6353	&& sym->assoc->target->symtree->n.sym->attr.intent == INTENT_IN)))
6354	{
6355	if (pointer && is_pointer)
6356	{
6357	if (context)
6358	gfc_error ("Dummy argument %qs with INTENT(IN) in pointer"
6359	" association context (%s) at %L",
6360	sym->name, context, &e->where);
6361	return false;
6362	}
6363	if (!pointer && !is_pointer && !sym->attr.pointer)
6364	{
6365	const char *name = sym->attr.select_type_temporary
6366	? sym->assoc->target->symtree->name : sym->name;
6367	if (context)
6368	gfc_error ("Dummy argument %qs with INTENT(IN) in variable"
6369	" definition context (%s) at %L",
6370	name, context, &e->where);
6371	return false;
6372	}
6373	}
6374
6375	/* PROTECTED and use-associated. */
6376	if (sym->attr.is_protected && sym->attr.use_assoc && check_intentin)
6377	{
6378	if (pointer && is_pointer)
6379	{
6380	if (context)
6381	gfc_error ("Variable %qs is PROTECTED and cannot appear in a"
6382	" pointer association context (%s) at %L",
6383	sym->name, context, &e->where);
6384	return false;
6385	}
6386	if (!pointer && !is_pointer)
6387	{
6388	if (context)
6389	gfc_error ("Variable %qs is PROTECTED and cannot appear in a"
6390	" variable definition context (%s) at %L",
6391	sym->name, context, &e->where);
6392	return false;
6393	}
6394	}
6395
6396	/* Variable not assignable from a PURE procedure but appears in
6397	variable definition context. */
6398	own_scope = own_scope
6399	\|\| (sym->attr.result && sym->ns->proc_name
6400	&& sym == sym->ns->proc_name->result);
6401	if (!pointer && !own_scope && gfc_pure (NULL__null) && gfc_impure_variable (sym))
6402	{
6403	if (context)
6404	gfc_error ("Variable %qs cannot appear in a variable definition"
6405	" context (%s) at %L in PURE procedure",
6406	sym->name, context, &e->where);
6407	return false;
6408	}
6409
6410	if (!pointer && context && gfc_implicit_pure (NULL__null)
6411	&& gfc_impure_variable (sym))
6412	{
6413	gfc_namespace *ns;
6414	gfc_symbol *sym;
6415
6416	for (ns = gfc_current_ns; ns; ns = ns->parent)
6417	{
6418	sym = ns->proc_name;
6419	if (sym == NULL__null)
6420	break;
6421	if (sym->attr.flavor == FL_PROCEDURE)
6422	{
6423	sym->attr.implicit_pure = 0;
6424	break;
6425	}
6426	}
6427	}
6428	/* Check variable definition context for associate-names. */
6429	if (!pointer && sym->assoc && !sym->attr.select_rank_temporary)
6430	{
6431	const char* name;
6432	gfc_association_list* assoc;
6433
6434	gcc_assert (sym->assoc->target)((void)(!(sym->assoc->target) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 6434, __FUNCTION__), 0 : 0));
6435
6436	/* If this is a SELECT TYPE temporary (the association is used internally
6437	for SELECT TYPE), silently go over to the target. */
6438	if (sym->attr.select_type_temporary)
6439	{
6440	gfc_expr* t = sym->assoc->target;
6441
6442	gcc_assert (t->expr_type == EXPR_VARIABLE)((void)(!(t->expr_type == EXPR_VARIABLE) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 6442, __FUNCTION__), 0 : 0));
6443	name = t->symtree->name;
6444
6445	if (t->symtree->n.sym->assoc)
6446	assoc = t->symtree->n.sym->assoc;
6447	else
6448	assoc = sym->assoc;
6449	}
6450	else
6451	{
6452	name = sym->name;
6453	assoc = sym->assoc;
6454	}
6455	gcc_assert (name && assoc)((void)(!(name && assoc) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 6455, __FUNCTION__), 0 : 0));
6456
6457	/* Is association to a valid variable? */
6458	if (!assoc->variable)
6459	{
6460	if (context)
6461	{
6462	if (assoc->target->expr_type == EXPR_VARIABLE)
6463	gfc_error ("%qs at %L associated to vector-indexed target"
6464	" cannot be used in a variable definition"
6465	" context (%s)",
6466	name, &e->where, context);
6467	else
6468	gfc_error ("%qs at %L associated to expression"
6469	" cannot be used in a variable definition"
6470	" context (%s)",
6471	name, &e->where, context);
6472	}
6473	return false;
6474	}
6475
6476	/* Target must be allowed to appear in a variable definition context. */
6477	if (!gfc_check_vardef_context (assoc->target, pointer, false, false, NULL__null))
6478	{
6479	if (context)
6480	gfc_error ("Associate-name %qs cannot appear in a variable"
6481	" definition context (%s) at %L because its target"
6482	" at %L cannot, either",
6483	name, context, &e->where,
6484	&assoc->target->where);
6485	return false;
6486	}
6487	}
6488
6489	/* Check for same value in vector expression subscript. */
6490
6491	if (e->rank > 0)
6492	for (ref = e->ref; ref != NULL__null; ref = ref->next)
6493	if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
6494	for (i = 0; i < GFC_MAX_DIMENSIONS15
6495	&& ref->u.ar.dimen_type[i] != 0; i++)
6496	if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
6497	{
6498	gfc_expr *arr = ref->u.ar.start[i];
6499	if (arr->expr_type == EXPR_ARRAY)
6500	{
6501	gfc_constructor c, n;
6502	gfc_expr ec, en;
6503
6504	for (c = gfc_constructor_first (arr->value.constructor);
6505	c != NULL__null; c = gfc_constructor_next (c))
6506	{
6507