/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c

Bug Summary

File:	build/gcc/fortran/expr.c
Warning:	line 2910, 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-unknown-linux-gnu -analyze -disable-free -disable-llvm-verifier -discard-value-names -main-file-name expr.c -analyzer-store=region -analyzer-opt-analyze-nested-blocks -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 -fno-rounding-math -mconstructor-aliases -munwind-tables -target-cpu x86-64 -fno-split-dwarf-inlining -debugger-tuning=gdb -resource-dir /usr/lib64/clang/11.0.0 -D IN_GCC_FRONTEND -D IN_GCC -D HAVE_CONFIG_H -I . -I fortran -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../include -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libcpp/include -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libcody -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libdecnumber -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libdecnumber/bid -I ../libdecnumber -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libbacktrace -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/10/../../../../include/c++/10 -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/10/../../../../include/c++/10/x86_64-suse-linux -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/10/../../../../include/c++/10/backward -internal-isystem /usr/local/include -internal-isystem /usr/lib64/clang/11.0.0/include -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -Wno-narrowing -Wwrite-strings -Wno-error=format-diag -Wno-long-long -Wno-variadic-macros -Wno-overlength-strings -fdeprecated-macro -fdebug-compilation-dir /home/marxin/BIG/buildbot/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 -o /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/objdir/clang-static-analyzer/2021-01-16-135054-17580-1/report-4toAtd.plist -x c++ /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c

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