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

Bug Summary

File:	build/gcc/fortran/expr.cc
Warning:	line 2801, column 4 Forming reference to null pointer

Annotated Source Code

Press '?' to see keyboard shortcuts

Show analyzer invocation

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

1	/* Routines for manipulation of expression nodes.
2	Copyright (C) 2000-2023 Free Software Foundation, Inc.
3	Contributed by Andy Vaught
4
5	This file is part of GCC.
6
7	GCC is free software; you can redistribute it and/or modify it under
8	the terms of the GNU General Public License as published by the Free
9	Software Foundation; either version 3, or (at your option) any later
10	version.
11
12	GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13	WARRANTY; without even the implied warranty of MERCHANTABILITY or
14	FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15	for more details.
16
17	You should have received a copy of the GNU General Public License
18	along with GCC; see the file COPYING3. If not see
19	<http://www.gnu.org/licenses/>. */
20
21	#include "config.h"
22	#include "system.h"
23	#include "coretypes.h"
24	#include "options.h"
25	#include "gfortran.h"
26	#include "arith.h"
27	#include "match.h"
28	#include "target-memory.h" /* for gfc_convert_boz */
29	#include "constructor.h"
30	#include "tree.h"
31
32
33	/* The following set of functions provide access to gfc_expr* of
34	various types - actual all but EXPR_FUNCTION and EXPR_VARIABLE.
35
36	There are two functions available elsewhere that provide
37	slightly different flavours of variables. Namely:
38	expr.cc (gfc_get_variable_expr)
39	symbol.cc (gfc_lval_expr_from_sym)
40	TODO: Merge these functions, if possible. */
41
42	/* Get a new expression node. */
43
44	gfc_expr *
45	gfc_get_expr (void)
46	{
47	gfc_expr *e;
48
49	e = XCNEW (gfc_expr)((gfc_expr *) xcalloc (1, sizeof (gfc_expr)));
50	gfc_clear_ts (&e->ts);
51	e->shape = NULL__null;
52	e->ref = NULL__null;
53	e->symtree = NULL__null;
54	return e;
55	}
56
57
58	/* Get a new expression node that is an array constructor
59	of given type and kind. */
60
61	gfc_expr *
62	gfc_get_array_expr (bt type, int kind, locus *where)
63	{
64	gfc_expr *e;
65
66	e = gfc_get_expr ();
67	e->expr_type = EXPR_ARRAY;
68	e->value.constructor = NULL__null;
69	e->rank = 1;
70	e->shape = NULL__null;
71
72	e->ts.type = type;
73	e->ts.kind = kind;
74	if (where)
75	e->where = *where;
76
77	return e;
78	}
79
80
81	/* Get a new expression node that is the NULL expression. */
82
83	gfc_expr *
84	gfc_get_null_expr (locus *where)
85	{
86	gfc_expr *e;
87
88	e = gfc_get_expr ();
89	e->expr_type = EXPR_NULL;
90	e->ts.type = BT_UNKNOWN;
91
92	if (where)
93	e->where = *where;
94
95	return e;
96	}
97
98
99	/* Get a new expression node that is an operator expression node. */
100
101	gfc_expr *
102	gfc_get_operator_expr (locus *where, gfc_intrinsic_op op,
103	gfc_expr op1, gfc_expr op2)
104	{
105	gfc_expr *e;
106
107	e = gfc_get_expr ();
108	e->expr_type = EXPR_OP;
109	e->value.op.op = op;
110	e->value.op.op1 = op1;
111	e->value.op.op2 = op2;
112
113	if (where)
114	e->where = *where;
115
116	return e;
117	}
118
119
120	/* Get a new expression node that is an structure constructor
121	of given type and kind. */
122
123	gfc_expr *
124	gfc_get_structure_constructor_expr (bt type, int kind, locus *where)
125	{
126	gfc_expr *e;
127
128	e = gfc_get_expr ();
129	e->expr_type = EXPR_STRUCTURE;
130	e->value.constructor = NULL__null;
131
132	e->ts.type = type;
133	e->ts.kind = kind;
134	if (where)
135	e->where = *where;
136
137	return e;
138	}
139
140
141	/* Get a new expression node that is an constant of given type and kind. */
142
143	gfc_expr *
144	gfc_get_constant_expr (bt type, int kind, locus *where)
145	{
146	gfc_expr *e;
147
148	if (!where)
149	gfc_internal_error ("gfc_get_constant_expr(): locus %<where%> cannot be "
150	"NULL");
151
152	e = gfc_get_expr ();
153
154	e->expr_type = EXPR_CONSTANT;
155	e->ts.type = type;
156	e->ts.kind = kind;
157	e->where = *where;
158
159	switch (type)
160	{
161	case BT_INTEGER:
162	mpz_init__gmpz_init (e->value.integer);
163	break;
164
165	case BT_REAL:
166	gfc_set_model_kind (kind);
167	mpfr_init (e->value.real);
168	break;
169
170	case BT_COMPLEX:
171	gfc_set_model_kind (kind);
172	mpc_init2 (e->value.complex, mpfr_get_default_prec());
173	break;
174
175	default:
176	break;
177	}
178
179	return e;
180	}
181
182
183	/* Get a new expression node that is an string constant.
184	If no string is passed, a string of len is allocated,
185	blanked and null-terminated. */
186
187	gfc_expr *
188	gfc_get_character_expr (int kind, locus where, const char src, gfc_charlen_t len)
189	{
190	gfc_expr *e;
191	gfc_char_t *dest;
192
193	if (!src)
194	{
195	dest = gfc_get_wide_string (len + 1)((gfc_char_t *) xcalloc ((len + 1), sizeof (gfc_char_t)));
196	gfc_wide_memset (dest, ' ', len);
197	dest[len] = '\0';
198	}
199	else
200	dest = gfc_char_to_widechar (src);
201
202	e = gfc_get_constant_expr (BT_CHARACTER, kind,
203	where ? where : &gfc_current_locus);
204	e->value.character.string = dest;
205	e->value.character.length = len;
206
207	return e;
208	}
209
210
211	/* Get a new expression node that is an integer constant. */
212
213	gfc_expr *
214	gfc_get_int_expr (int kind, locus *where, HOST_WIDE_INTlong value)
215	{
216	gfc_expr *p;
217	p = gfc_get_constant_expr (BT_INTEGER, kind,
218	where ? where : &gfc_current_locus);
219
220	const wide_int w = wi::shwi (value, kind * BITS_PER_UNIT(8));
221	wi::to_mpz (w, p->value.integer, SIGNED);
222
223	return p;
224	}
225
226
227	/* Get a new expression node that is a logical constant. */
228
229	gfc_expr *
230	gfc_get_logical_expr (int kind, locus *where, bool value)
231	{
232	gfc_expr *p;
233	p = gfc_get_constant_expr (BT_LOGICAL, kind,
234	where ? where : &gfc_current_locus);
235
236	p->value.logical = value;
237
238	return p;
239	}
240
241
242	gfc_expr *
243	gfc_get_iokind_expr (locus *where, io_kind k)
244	{
245	gfc_expr *e;
246
247	/* Set the types to something compatible with iokind. This is needed to
248	get through gfc_free_expr later since iokind really has no Basic Type,
249	BT, of its own. */
250
251	e = gfc_get_expr ();
252	e->expr_type = EXPR_CONSTANT;
253	e->ts.type = BT_LOGICAL;
254	e->value.iokind = k;
255	e->where = *where;
256
257	return e;
258	}
259
260
261	/* Given an expression pointer, return a copy of the expression. This
262	subroutine is recursive. */
263
264	gfc_expr *
265	gfc_copy_expr (gfc_expr *p)
266	{
267	gfc_expr *q;
268	gfc_char_t *s;
269	char *c;
270
271	if (p == NULL__null)
272	return NULL__null;
273
274	q = gfc_get_expr ();
275	q = p;
276
277	switch (q->expr_type)
278	{
279	case EXPR_SUBSTRING:
280	s = gfc_get_wide_string (p->value.character.length + 1)((gfc_char_t *) xcalloc ((p->value.character.length + 1), sizeof (gfc_char_t)));
281	q->value.character.string = s;
282	memcpy (s, p->value.character.string,
283	(p->value.character.length + 1) * sizeof (gfc_char_t));
284	break;
285
286	case EXPR_CONSTANT:
287	/* Copy target representation, if it exists. */
288	if (p->representation.string)
289	{
290	c = XCNEWVEC (char, p->representation.length + 1)((char *) xcalloc ((p->representation.length + 1), sizeof ( char)));
291	q->representation.string = c;
292	memcpy (c, p->representation.string, (p->representation.length + 1));
293	}
294
295	/* Copy the values of any pointer components of p->value. */
296	switch (q->ts.type)
297	{
298	case BT_INTEGER:
299	mpz_init_set__gmpz_init_set (q->value.integer, p->value.integer);
300	break;
301
302	case BT_REAL:
303	gfc_set_model_kind (q->ts.kind);
304	mpfr_init (q->value.real);
305	mpfr_set (q->value.real, p->value.real, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (p->value.real); mpfr_set4 (q->value.real,_p,MPFR_RNDN,((_p)->_mpfr_sign)); });
306	break;
307
308	case BT_COMPLEX:
309	gfc_set_model_kind (q->ts.kind);
310	mpc_init2 (q->value.complex, mpfr_get_default_prec());
311	mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
312	break;
313
314	case BT_CHARACTER:
315	if (p->representation.string
316	&& p->ts.kind == gfc_default_character_kind)
317	q->value.character.string
318	= gfc_char_to_widechar (q->representation.string);
319	else
320	{
321	s = gfc_get_wide_string (p->value.character.length + 1)((gfc_char_t *) xcalloc ((p->value.character.length + 1), sizeof (gfc_char_t)));
322	q->value.character.string = s;
323
324	/* This is the case for the C_NULL_CHAR named constant. */
325	if (p->value.character.length == 0
326	&& (p->ts.is_c_interop \|\| p->ts.is_iso_c))
327	{
328	*s = '\0';
329	/* Need to set the length to 1 to make sure the NUL
330	terminator is copied. */
331	q->value.character.length = 1;
332	}
333	else
334	memcpy (s, p->value.character.string,
335	(p->value.character.length + 1) * sizeof (gfc_char_t));
336	}
337	break;
338
339	case BT_HOLLERITH:
340	case BT_LOGICAL:
341	case_bt_structcase BT_DERIVED: case BT_UNION:
342	case BT_CLASS:
343	case BT_ASSUMED:
344	break; /* Already done. */
345
346	case BT_BOZ:
347	q->boz.len = p->boz.len;
348	q->boz.rdx = p->boz.rdx;
349	q->boz.str = XCNEWVEC (char, q->boz.len + 1)((char *) xcalloc ((q->boz.len + 1), sizeof (char)));
350	strncpy (q->boz.str, p->boz.str, p->boz.len);
351	break;
352
353	case BT_PROCEDURE:
354	case BT_VOID:
355	/* Should never be reached. */
356	case BT_UNKNOWN:
357	gfc_internal_error ("gfc_copy_expr(): Bad expr node");
358	/* Not reached. */
359	}
360
361	break;
362
363	case EXPR_OP:
364	switch (q->value.op.op)
365	{
366	case INTRINSIC_NOT:
367	case INTRINSIC_PARENTHESES:
368	case INTRINSIC_UPLUS:
369	case INTRINSIC_UMINUS:
370	q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
371	break;
372
373	default: /* Binary operators. */
374	q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
375	q->value.op.op2 = gfc_copy_expr (p->value.op.op2);
376	break;
377	}
378
379	break;
380
381	case EXPR_FUNCTION:
382	q->value.function.actual =
383	gfc_copy_actual_arglist (p->value.function.actual);
384	break;
385
386	case EXPR_COMPCALL:
387	case EXPR_PPC:
388	q->value.compcall.actual =
389	gfc_copy_actual_arglist (p->value.compcall.actual);
390	q->value.compcall.tbp = p->value.compcall.tbp;
391	break;
392
393	case EXPR_STRUCTURE:
394	case EXPR_ARRAY:
395	q->value.constructor = gfc_constructor_copy (p->value.constructor);
396	break;
397
398	case EXPR_VARIABLE:
399	case EXPR_NULL:
400	break;
401
402	case EXPR_UNKNOWN:
403	gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 403, __FUNCTION__));
404	}
405
406	q->shape = gfc_copy_shape (p->shape, p->rank);
407
408	q->ref = gfc_copy_ref (p->ref);
409
410	if (p->param_list)
411	q->param_list = gfc_copy_actual_arglist (p->param_list);
412
413	return q;
414	}
415
416
417	void
418	gfc_clear_shape (mpz_t *shape, int rank)
419	{
420	int i;
421
422	for (i = 0; i < rank; i++)
423	mpz_clear__gmpz_clear (shape[i]);
424	}
425
426
427	void
428	gfc_free_shape (mpz_t **shape, int rank)
429	{
430	if (*shape == NULL__null)
431	return;
432
433	gfc_clear_shape (*shape, rank);
434	free (*shape);
435	*shape = NULL__null;
436	}
437
438
439	/* Workhorse function for gfc_free_expr() that frees everything
440	beneath an expression node, but not the node itself. This is
441	useful when we want to simplify a node and replace it with
442	something else or the expression node belongs to another structure. */
443
444	static void
445	free_expr0 (gfc_expr *e)
446	{
447	switch (e->expr_type)
448	{
449	case EXPR_CONSTANT:
450	/* Free any parts of the value that need freeing. */
451	switch (e->ts.type)
452	{
453	case BT_INTEGER:
454	mpz_clear__gmpz_clear (e->value.integer);
455	break;
456
457	case BT_REAL:
458	mpfr_clear (e->value.real);
459	break;
460
461	case BT_CHARACTER:
462	free (e->value.character.string);
463	break;
464
465	case BT_COMPLEX:
466	mpc_clear (e->value.complex);
467	break;
468
469	case BT_BOZ:
470	free (e->boz.str);
471	break;
472
473	default:
474	break;
475	}
476
477	/* Free the representation. */
478	free (e->representation.string);
479
480	break;
481
482	case EXPR_OP:
483	if (e->value.op.op1 != NULL__null)
484	gfc_free_expr (e->value.op.op1);
485	if (e->value.op.op2 != NULL__null)
486	gfc_free_expr (e->value.op.op2);
487	break;
488
489	case EXPR_FUNCTION:
490	gfc_free_actual_arglist (e->value.function.actual);
491	break;
492
493	case EXPR_COMPCALL:
494	case EXPR_PPC:
495	gfc_free_actual_arglist (e->value.compcall.actual);
496	break;
497
498	case EXPR_VARIABLE:
499	break;
500
501	case EXPR_ARRAY:
502	case EXPR_STRUCTURE:
503	gfc_constructor_free (e->value.constructor);
504	break;
505
506	case EXPR_SUBSTRING:
507	free (e->value.character.string);
508	break;
509
510	case EXPR_NULL:
511	break;
512
513	default:
514	gfc_internal_error ("free_expr0(): Bad expr type");
515	}
516
517	/* Free a shape array. */
518	gfc_free_shape (&e->shape, e->rank);
519
520	gfc_free_ref_list (e->ref);
521
522	gfc_free_actual_arglist (e->param_list);
523
524	memset (e, '\0', sizeof (gfc_expr));
525	}
526
527
528	/* Free an expression node and everything beneath it. */
529
530	void
531	gfc_free_expr (gfc_expr *e)
532	{
533	if (e == NULL__null)
534	return;
535	free_expr0 (e);
536	free (e);
537	}
538
539
540	/* Free an argument list and everything below it. */
541
542	void
543	gfc_free_actual_arglist (gfc_actual_arglist *a1)
544	{
545	gfc_actual_arglist *a2;
546
547	while (a1)
548	{
549	a2 = a1->next;
550	if (a1->expr)
551	gfc_free_expr (a1->expr);
552	free (a1->associated_dummy);
553	free (a1);
554	a1 = a2;
555	}
556	}
557
558
559	/* Copy an arglist structure and all of the arguments. */
560
561	gfc_actual_arglist *
562	gfc_copy_actual_arglist (gfc_actual_arglist *p)
563	{
564	gfc_actual_arglist head, tail, *new_arg;
565
566	head = tail = NULL__null;
567
568	for (; p; p = p->next)
569	{
570	new_arg = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist )));
571	new_arg = p;
572
573	if (p->associated_dummy != NULL__null)
574	{
575	new_arg->associated_dummy = gfc_get_dummy_arg ()((gfc_dummy_arg *) xcalloc (1, sizeof (gfc_dummy_arg)));
576	new_arg->associated_dummy = p->associated_dummy;
577	}
578
579	new_arg->expr = gfc_copy_expr (p->expr);
580	new_arg->next = NULL__null;
581
582	if (head == NULL__null)
583	head = new_arg;
584	else
585	tail->next = new_arg;
586
587	tail = new_arg;
588	}
589
590	return head;
591	}
592
593
594	/* Free a list of reference structures. */
595
596	void
597	gfc_free_ref_list (gfc_ref *p)
598	{
599	gfc_ref *q;
600	int i;
601
602	for (; p; p = q)
603	{
604	q = p->next;
605
606	switch (p->type)
607	{
608	case REF_ARRAY:
609	for (i = 0; i < GFC_MAX_DIMENSIONS15; i++)
610	{
611	gfc_free_expr (p->u.ar.start[i]);
612	gfc_free_expr (p->u.ar.end[i]);
613	gfc_free_expr (p->u.ar.stride[i]);
614	}
615
616	break;
617
618	case REF_SUBSTRING:
619	gfc_free_expr (p->u.ss.start);
620	gfc_free_expr (p->u.ss.end);
621	break;
622
623	case REF_COMPONENT:
624	case REF_INQUIRY:
625	break;
626	}
627
628	free (p);
629	}
630	}
631
632
633	/* Graft the src expression onto the dest subexpression. */
634
635	void
636	gfc_replace_expr (gfc_expr dest, gfc_expr src)
637	{
638	free_expr0 (dest);
639	dest = src;
640	free (src);
641	}
642
643
644	/* Try to extract an integer constant from the passed expression node.
645	Return true if some error occurred, false on success. If REPORT_ERROR
646	is non-zero, emit error, for positive REPORT_ERROR using gfc_error,
647	for negative using gfc_error_now. */
648
649	bool
650	gfc_extract_int (gfc_expr expr, int result, int report_error)
651	{
652	gfc_ref *ref;
653
654	/* A KIND component is a parameter too. The expression for it
655	is stored in the initializer and should be consistent with
656	the tests below. */
657	if (gfc_expr_attr(expr).pdt_kind)
658	{
659	for (ref = expr->ref; ref; ref = ref->next)
660	{
661	if (ref->u.c.component->attr.pdt_kind)
662	expr = ref->u.c.component->initializer;
663	}
664	}
665
666	if (expr->expr_type != EXPR_CONSTANT)
667	{
668	if (report_error > 0)
669	gfc_error ("Constant expression required at %C");
670	else if (report_error < 0)
671	gfc_error_now ("Constant expression required at %C");
672	return true;
673	}
674
675	if (expr->ts.type != BT_INTEGER)
676	{
677	if (report_error > 0)
678	gfc_error ("Integer expression required at %C");
679	else if (report_error < 0)
680	gfc_error_now ("Integer expression required at %C");
681	return true;
682	}
683
684	if ((mpz_cmp_si (expr->value.integer, INT_MAX)(__builtin_constant_p ((2147483647) >= 0) && (2147483647 ) >= 0 ? (__builtin_constant_p ((static_cast<unsigned long > (2147483647))) && ((static_cast<unsigned long > (2147483647))) == 0 ? ((expr->value.integer)->_mp_size < 0 ? -1 : (expr->value.integer)->_mp_size > 0) : __gmpz_cmp_ui (expr->value.integer,(static_cast<unsigned long> (2147483647)))) : __gmpz_cmp_si (expr->value.integer ,2147483647)) > 0)
685	\|\| (mpz_cmp_si (expr->value.integer, INT_MIN)(__builtin_constant_p (((-2147483647 -1)) >= 0) && ((-2147483647 -1)) >= 0 ? (__builtin_constant_p ((static_cast <unsigned long> ((-2147483647 -1)))) && ((static_cast <unsigned long> ((-2147483647 -1)))) == 0 ? ((expr-> value.integer)->_mp_size < 0 ? -1 : (expr->value.integer )->_mp_size > 0) : __gmpz_cmp_ui (expr->value.integer ,(static_cast<unsigned long> ((-2147483647 -1))))) : __gmpz_cmp_si (expr->value.integer,(-2147483647 -1))) < 0))
686	{
687	if (report_error > 0)
688	gfc_error ("Integer value too large in expression at %C");
689	else if (report_error < 0)
690	gfc_error_now ("Integer value too large in expression at %C");
691	return true;
692	}
693
694	*result = (int) mpz_get_si__gmpz_get_si (expr->value.integer);
695
696	return false;
697	}
698
699
700	/* Same as gfc_extract_int, but use a HWI. */
701
702	bool
703	gfc_extract_hwi (gfc_expr expr, HOST_WIDE_INTlong result, int report_error)
704	{
705	gfc_ref *ref;
706
707	/* A KIND component is a parameter too. The expression for it is
708	stored in the initializer and should be consistent with the tests
709	below. */
710	if (gfc_expr_attr(expr).pdt_kind)
711	{
712	for (ref = expr->ref; ref; ref = ref->next)
713	{
714	if (ref->u.c.component->attr.pdt_kind)
715	expr = ref->u.c.component->initializer;
716	}
717	}
718
719	if (expr->expr_type != EXPR_CONSTANT)
720	{
721	if (report_error > 0)
722	gfc_error ("Constant expression required at %C");
723	else if (report_error < 0)
724	gfc_error_now ("Constant expression required at %C");
725	return true;
726	}
727
728	if (expr->ts.type != BT_INTEGER)
729	{
730	if (report_error > 0)
731	gfc_error ("Integer expression required at %C");
732	else if (report_error < 0)
733	gfc_error_now ("Integer expression required at %C");
734	return true;
735	}
736
737	/* Use long_long_integer_type_node to determine when to saturate. */
738	const wide_int val = wi::from_mpz (long_long_integer_type_nodeinteger_types[itk_long_long],
739	expr->value.integer, false);
740
741	if (!wi::fits_shwi_p (val))
742	{
743	if (report_error > 0)
744	gfc_error ("Integer value too large in expression at %C");
745	else if (report_error < 0)
746	gfc_error_now ("Integer value too large in expression at %C");
747	return true;
748	}
749
750	*result = val.to_shwi ();
751
752	return false;
753	}
754
755
756	/* Recursively copy a list of reference structures. */
757
758	gfc_ref *
759	gfc_copy_ref (gfc_ref *src)
760	{
761	gfc_array_ref *ar;
762	gfc_ref *dest;
763
764	if (src == NULL__null)
765	return NULL__null;
766
767	dest = gfc_get_ref ()((gfc_ref *) xcalloc (1, sizeof (gfc_ref)));
768	dest->type = src->type;
769
770	switch (src->type)
771	{
772	case REF_ARRAY:
773	ar = gfc_copy_array_ref (&src->u.ar);
774	dest->u.ar = *ar;
775	free (ar);
776	break;
777
778	case REF_COMPONENT:
779	dest->u.c = src->u.c;
780	break;
781
782	case REF_INQUIRY:
783	dest->u.i = src->u.i;
784	break;
785
786	case REF_SUBSTRING:
787	dest->u.ss = src->u.ss;
788	dest->u.ss.start = gfc_copy_expr (src->u.ss.start);
789	dest->u.ss.end = gfc_copy_expr (src->u.ss.end);
790	break;
791	}
792
793	dest->next = gfc_copy_ref (src->next);
794
795	return dest;
796	}
797
798
799	/* Detect whether an expression has any vector index array references. */
800
801	int
802	gfc_has_vector_index (gfc_expr *e)
803	{
804	gfc_ref *ref;
805	int i;
806	for (ref = e->ref; ref; ref = ref->next)
807	if (ref->type == REF_ARRAY)
808	for (i = 0; i < ref->u.ar.dimen; i++)
809	if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
810	return 1;
811	return 0;
812	}
813
814
815	/* Copy a shape array. */
816
817	mpz_t *
818	gfc_copy_shape (mpz_t *shape, int rank)
819	{
820	mpz_t *new_shape;
821	int n;
822
823	if (shape == NULL__null)
824	return NULL__null;
825
826	new_shape = gfc_get_shape (rank)(((mpz_t *) xcalloc (((rank)), sizeof (mpz_t))));
827
828	for (n = 0; n < rank; n++)
829	mpz_init_set__gmpz_init_set (new_shape[n], shape[n]);
830
831	return new_shape;
832	}
833
834
835	/* Copy a shape array excluding dimension N, where N is an integer
836	constant expression. Dimensions are numbered in Fortran style --
837	starting with ONE.
838
839	So, if the original shape array contains R elements
840	{ s1 ... sN-1 sN sN+1 ... sR-1 sR}
841	the result contains R-1 elements:
842	{ s1 ... sN-1 sN+1 ... sR-1}
843
844	If anything goes wrong -- N is not a constant, its value is out
845	of range -- or anything else, just returns NULL. */
846
847	mpz_t *
848	gfc_copy_shape_excluding (mpz_t shape, int rank, gfc_expr dim)
849	{
850	mpz_t new_shape, s;
851	int i, n;
852
853	if (shape == NULL__null
854	\|\| rank <= 1
855	\|\| dim == NULL__null
856	\|\| dim->expr_type != EXPR_CONSTANT
857	\|\| dim->ts.type != BT_INTEGER)
858	return NULL__null;
859
860	n = mpz_get_si__gmpz_get_si (dim->value.integer);
861	n--; /* Convert to zero based index. */
862	if (n < 0 \|\| n >= rank)
863	return NULL__null;
864
865	s = new_shape = gfc_get_shape (rank - 1)(((mpz_t *) xcalloc (((rank - 1)), sizeof (mpz_t))));
866
867	for (i = 0; i < rank; i++)
868	{
869	if (i == n)
870	continue;
871	mpz_init_set__gmpz_init_set (*s, shape[i]);
872	s++;
873	}
874
875	return new_shape;
876	}
877
878
879	/* Return the maximum kind of two expressions. In general, higher
880	kind numbers mean more precision for numeric types. */
881
882	int
883	gfc_kind_max (gfc_expr e1, gfc_expr e2)
884	{
885	return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind;
886	}
887
888
889	/* Returns nonzero if the type is numeric, zero otherwise. */
890
891	static int
892	numeric_type (bt type)
893	{
894	return type == BT_COMPLEX \|\| type == BT_REAL \|\| type == BT_INTEGER;
895	}
896
897
898	/* Returns nonzero if the typespec is a numeric type, zero otherwise. */
899
900	int
901	gfc_numeric_ts (gfc_typespec *ts)
902	{
903	return numeric_type (ts->type);
904	}
905
906
907	/* Return an expression node with an optional argument list attached.
908	A variable number of gfc_expr pointers are strung together in an
909	argument list with a NULL pointer terminating the list. */
910
911	gfc_expr *
912	gfc_build_conversion (gfc_expr *e)
913	{
914	gfc_expr *p;
915
916	p = gfc_get_expr ();
917	p->expr_type = EXPR_FUNCTION;
918	p->symtree = NULL__null;
919	p->value.function.actual = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist )));
920	p->value.function.actual->expr = e;
921
922	return p;
923	}
924
925
926	/* Given an expression node with some sort of numeric binary
927	expression, insert type conversions required to make the operands
928	have the same type. Conversion warnings are disabled if wconversion
929	is set to 0.
930
931	The exception is that the operands of an exponential don't have to
932	have the same type. If possible, the base is promoted to the type
933	of the exponent. For example, 12.3 becomes 1.02.3, but
934	1.0*2 stays as it is. /
935
936	void
937	gfc_type_convert_binary (gfc_expr *e, int wconversion)
938	{
939	gfc_expr op1, op2;
940
941	op1 = e->value.op.op1;
942	op2 = e->value.op.op2;
943
944	if (op1->ts.type == BT_UNKNOWN \|\| op2->ts.type == BT_UNKNOWN)
945	{
946	gfc_clear_ts (&e->ts);
947	return;
948	}
949
950	/* Kind conversions of same type. */
951	if (op1->ts.type == op2->ts.type)
952	{
953	if (op1->ts.kind == op2->ts.kind)
954	{
955	/* No type conversions. */
956	e->ts = op1->ts;
957	goto done;
958	}
959
960	if (op1->ts.kind > op2->ts.kind)
961	gfc_convert_type_warn (op2, &op1->ts, 2, wconversion);
962	else
963	gfc_convert_type_warn (op1, &op2->ts, 2, wconversion);
964
965	e->ts = op1->ts;
966	goto done;
967	}
968
969	/* Integer combined with real or complex. */
970	if (op2->ts.type == BT_INTEGER)
971	{
972	e->ts = op1->ts;
973
974	/* Special case for ** operator. */
975	if (e->value.op.op == INTRINSIC_POWER)
976	goto done;
977
978	gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion);
979	goto done;
980	}
981
982	if (op1->ts.type == BT_INTEGER)
983	{
984	e->ts = op2->ts;
985	gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion);
986	goto done;
987	}
988
989	/* Real combined with complex. */
990	e->ts.type = BT_COMPLEX;
991	if (op1->ts.kind > op2->ts.kind)
992	e->ts.kind = op1->ts.kind;
993	else
994	e->ts.kind = op2->ts.kind;
995	if (op1->ts.type != BT_COMPLEX \|\| op1->ts.kind != e->ts.kind)
996	gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion);
997	if (op2->ts.type != BT_COMPLEX \|\| op2->ts.kind != e->ts.kind)
998	gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion);
999
1000	done:
1001	return;
1002	}
1003
1004
1005	/* Standard intrinsics listed under F2018:10.1.12 (6), which are excluded in
1006	constant expressions, except TRANSFER (c.f. item (8)), which would need
1007	separate treatment. */
1008
1009	static bool
1010	is_non_constant_intrinsic (gfc_expr *e)
1011	{
1012	if (e->expr_type == EXPR_FUNCTION
1013	&& e->value.function.isym)
1014	{
1015	switch (e->value.function.isym->id)
1016	{
1017	case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
1018	case GFC_ISYM_GET_TEAM:
1019	case GFC_ISYM_NULL:
1020	case GFC_ISYM_NUM_IMAGES:
1021	case GFC_ISYM_TEAM_NUMBER:
1022	case GFC_ISYM_THIS_IMAGE:
1023	return true;
1024
1025	default:
1026	return false;
1027	}
1028	}
1029	return false;
1030	}
1031
1032
1033	/* Determine if an expression is constant in the sense of F08:7.1.12.
1034	* This function expects that the expression has already been simplified. */
1035
1036	bool
1037	gfc_is_constant_expr (gfc_expr *e)
1038	{
1039	gfc_constructor *c;
1040	gfc_actual_arglist *arg;
1041
1042	if (e == NULL__null)
1043	return true;
1044
1045	switch (e->expr_type)
1046	{
1047	case EXPR_OP:
1048	return (gfc_is_constant_expr (e->value.op.op1)
1049	&& (e->value.op.op2 == NULL__null
1050	\|\| gfc_is_constant_expr (e->value.op.op2)));
1051
1052	case EXPR_VARIABLE:
1053	/* The only context in which this can occur is in a parameterized
1054	derived type declaration, so returning true is OK. */
1055	if (e->symtree->n.sym->attr.pdt_len
1056	\|\| e->symtree->n.sym->attr.pdt_kind)
1057	return true;
1058	return false;
1059
1060	case EXPR_FUNCTION:
1061	case EXPR_PPC:
1062	case EXPR_COMPCALL:
1063	gcc_assert (e->symtree \|\| e->value.function.esym((void)(!(e->symtree \|\| e->value.function.esym \|\| e-> value.function.isym) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 1064, __FUNCTION__), 0 : 0))
1064	\|\| e->value.function.isym)((void)(!(e->symtree \|\| e->value.function.esym \|\| e-> value.function.isym) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 1064, __FUNCTION__), 0 : 0));
1065
1066	/* Check for intrinsics excluded in constant expressions. */
1067	if (e->value.function.isym && is_non_constant_intrinsic (e))
1068	return false;
1069
1070	/* Call to intrinsic with at least one argument. */
1071	if (e->value.function.isym && e->value.function.actual)
1072	{
1073	for (arg = e->value.function.actual; arg; arg = arg->next)
1074	if (!gfc_is_constant_expr (arg->expr))
1075	return false;
1076	}
1077
1078	if (e->value.function.isym
1079	&& (e->value.function.isym->elemental
1080	\|\| e->value.function.isym->pure
1081	\|\| e->value.function.isym->inquiry
1082	\|\| e->value.function.isym->transformational))
1083	return true;
1084
1085	return false;
1086
1087	case EXPR_CONSTANT:
1088	case EXPR_NULL:
1089	return true;
1090
1091	case EXPR_SUBSTRING:
1092	return e->ref == NULL__null \|\| (gfc_is_constant_expr (e->ref->u.ss.start)
1093	&& gfc_is_constant_expr (e->ref->u.ss.end));
1094
1095	case EXPR_ARRAY:
1096	case EXPR_STRUCTURE:
1097	c = gfc_constructor_first (e->value.constructor);
1098	if ((e->expr_type == EXPR_ARRAY) && c && c->iterator)
1099	return gfc_constant_ac (e);
1100
1101	for (; c; c = gfc_constructor_next (c))
1102	if (!gfc_is_constant_expr (c->expr))
1103	return false;
1104
1105	return true;
1106
1107
1108	default:
1109	gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
1110	return false;
1111	}
1112	}
1113
1114
1115	/* Is true if the expression or symbol is a passed CFI descriptor. */
1116	bool
1117	is_CFI_desc (gfc_symbol sym, gfc_expr e)
1118	{
1119	if (sym == NULL__null
1120	&& e && e->expr_type == EXPR_VARIABLE)
1121	sym = e->symtree->n.sym;
1122
1123	if (sym && sym->attr.dummy
1124	&& sym->ns->proc_name->attr.is_bind_c
1125	&& (sym->attr.pointer
1126	\|\| sym->attr.allocatable
1127	\|\| (sym->attr.dimension
1128	&& (sym->as->type == AS_ASSUMED_SHAPE
1129	\|\| sym->as->type == AS_ASSUMED_RANK))
1130	\|\| (sym->ts.type == BT_CHARACTER
1131	&& (!sym->ts.u.cl \|\| !sym->ts.u.cl->length))))
1132	return true;
1133
1134	return false;
1135	}
1136
1137
1138	/* Is true if an array reference is followed by a component or substring
1139	reference. */
1140	bool
1141	is_subref_array (gfc_expr * e)
1142	{
1143	gfc_ref * ref;
1144	bool seen_array;
1145	gfc_symbol *sym;
1146
1147	if (e->expr_type != EXPR_VARIABLE)
1148	return false;
1149
1150	sym = e->symtree->n.sym;
1151
1152	if (sym->attr.subref_array_pointer)
1153	return true;
1154
1155	seen_array = false;
1156
1157	for (ref = e->ref; ref; ref = ref->next)
1158	{
1159	/* If we haven't seen the array reference and this is an intrinsic,
1160	what follows cannot be a subreference array, unless there is a
1161	substring reference. */
1162	if (!seen_array && ref->type == REF_COMPONENT
1163	&& ref->u.c.component->ts.type != BT_CHARACTER
1164	&& ref->u.c.component->ts.type != BT_CLASS
1165	&& !gfc_bt_struct (ref->u.c.component->ts.type)((ref->u.c.component->ts.type) == BT_DERIVED \|\| (ref-> u.c.component->ts.type) == BT_UNION))
1166	return false;
1167
1168	if (ref->type == REF_ARRAY
1169	&& ref->u.ar.type != AR_ELEMENT)
1170	seen_array = true;
1171
1172	if (seen_array
1173	&& ref->type != REF_ARRAY)
1174	return seen_array;
1175	}
1176
1177	if (sym->ts.type == BT_CLASS
1178	&& sym->attr.dummy
1179	&& CLASS_DATA (sym)sym->ts.u.derived->components->attr.dimension
1180	&& CLASS_DATA (sym)sym->ts.u.derived->components->attr.class_pointer)
1181	return true;
1182
1183	return false;
1184	}
1185
1186
1187	/* Try to collapse intrinsic expressions. */
1188
1189	static bool
1190	simplify_intrinsic_op (gfc_expr *p, int type)
1191	{
1192	gfc_intrinsic_op op;
1193	gfc_expr op1, op2, *result;
1194
1195	if (p->value.op.op == INTRINSIC_USER)
1196	return true;
1197
1198	op1 = p->value.op.op1;
1199	op2 = p->value.op.op2;
1200	op = p->value.op.op;
1201
1202	if (!gfc_simplify_expr (op1, type))
1203	return false;
1204	if (!gfc_simplify_expr (op2, type))
1205	return false;
1206
1207	if (!gfc_is_constant_expr (op1)
1208	\|\| (op2 != NULL__null && !gfc_is_constant_expr (op2)))
1209	return true;
1210
1211	/* Rip p apart. */
1212	p->value.op.op1 = NULL__null;
1213	p->value.op.op2 = NULL__null;
1214
1215	switch (op)
1216	{
1217	case INTRINSIC_PARENTHESES:
1218	result = gfc_parentheses (op1);
1219	break;
1220
1221	case INTRINSIC_UPLUS:
1222	result = gfc_uplus (op1);
1223	break;
1224
1225	case INTRINSIC_UMINUS:
1226	result = gfc_uminus (op1);
1227	break;
1228
1229	case INTRINSIC_PLUS:
1230	result = gfc_add (op1, op2);
1231	break;
1232
1233	case INTRINSIC_MINUS:
1234	result = gfc_subtract (op1, op2);
1235	break;
1236
1237	case INTRINSIC_TIMES:
1238	result = gfc_multiply (op1, op2);
1239	break;
1240
1241	case INTRINSIC_DIVIDE:
1242	result = gfc_divide (op1, op2);
1243	break;
1244
1245	case INTRINSIC_POWER:
1246	result = gfc_power (op1, op2);
1247	break;
1248
1249	case INTRINSIC_CONCAT:
1250	result = gfc_concat (op1, op2);
1251	break;
1252
1253	case INTRINSIC_EQ:
1254	case INTRINSIC_EQ_OS:
1255	result = gfc_eq (op1, op2, op);
1256	break;
1257
1258	case INTRINSIC_NE:
1259	case INTRINSIC_NE_OS:
1260	result = gfc_ne (op1, op2, op);
1261	break;
1262
1263	case INTRINSIC_GT:
1264	case INTRINSIC_GT_OS:
1265	result = gfc_gt (op1, op2, op);
1266	break;
1267
1268	case INTRINSIC_GE:
1269	case INTRINSIC_GE_OS:
1270	result = gfc_ge (op1, op2, op);
1271	break;
1272
1273	case INTRINSIC_LT:
1274	case INTRINSIC_LT_OS:
1275	result = gfc_lt (op1, op2, op);
1276	break;
1277
1278	case INTRINSIC_LE:
1279	case INTRINSIC_LE_OS:
1280	result = gfc_le (op1, op2, op);
1281	break;
1282
1283	case INTRINSIC_NOT:
1284	result = gfc_not (op1);
1285	break;
1286
1287	case INTRINSIC_AND:
1288	result = gfc_and (op1, op2);
1289	break;
1290
1291	case INTRINSIC_OR:
1292	result = gfc_or (op1, op2);
1293	break;
1294
1295	case INTRINSIC_EQV:
1296	result = gfc_eqv (op1, op2);
1297	break;
1298
1299	case INTRINSIC_NEQV:
1300	result = gfc_neqv (op1, op2);
1301	break;
1302
1303	default:
1304	gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1305	}
1306
1307	if (result == NULL__null)
1308	{
1309	gfc_free_expr (op1);
1310	gfc_free_expr (op2);
1311	return false;
1312	}
1313
1314	result->rank = p->rank;
1315	result->where = p->where;
1316	gfc_replace_expr (p, result);
1317
1318	return true;
1319	}
1320
1321
1322	/* Subroutine to simplify constructor expressions. Mutually recursive
1323	with gfc_simplify_expr(). */
1324
1325	static bool
1326	simplify_constructor (gfc_constructor_base base, int type)
1327	{
1328	gfc_constructor *c;
1329	gfc_expr *p;
1330
1331	for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1332	{
1333	if (c->iterator
1334	&& (!gfc_simplify_expr(c->iterator->start, type)
1335	\|\| !gfc_simplify_expr (c->iterator->end, type)
1336	\|\| !gfc_simplify_expr (c->iterator->step, type)))
1337	return false;
1338
1339	if (c->expr)
1340	{
1341	/* Try and simplify a copy. Replace the original if successful
1342	but keep going through the constructor at all costs. Not
1343	doing so can make a dog's dinner of complicated things. */
1344	p = gfc_copy_expr (c->expr);
1345
1346	if (!gfc_simplify_expr (p, type))
1347	{
1348	gfc_free_expr (p);
1349	continue;
1350	}
1351
1352	gfc_replace_expr (c->expr, p);
1353	}
1354	}
1355
1356	return true;
1357	}
1358
1359
1360	/* Pull a single array element out of an array constructor. */
1361
1362	static bool
1363	find_array_element (gfc_constructor_base base, gfc_array_ref *ar,
1364	gfc_constructor **rval)
1365	{
1366	unsigned long nelemen;
1367	int i;
1368	mpz_t delta;
1369	mpz_t offset;
1370	mpz_t span;
1371	mpz_t tmp;
1372	gfc_constructor *cons;
1373	gfc_expr *e;
1374	bool t;
1375
1376	t = true;
1377	e = NULL__null;
1378
1379	mpz_init_set_ui__gmpz_init_set_ui (offset, 0);
1380	mpz_init__gmpz_init (delta);
1381	mpz_init__gmpz_init (tmp);
1382	mpz_init_set_ui__gmpz_init_set_ui (span, 1);
1383	for (i = 0; i < ar->dimen; i++)
1384	{
1385	if (!gfc_reduce_init_expr (ar->as->lower[i])
1386	\|\| !gfc_reduce_init_expr (ar->as->upper[i])
1387	\|\| ar->as->upper[i]->expr_type != EXPR_CONSTANT
1388	\|\| ar->as->lower[i]->expr_type != EXPR_CONSTANT)
1389	{
1390	t = false;
1391	cons = NULL__null;
1392	goto depart;
1393	}
1394
1395	e = ar->start[i];
1396	if (e->expr_type != EXPR_CONSTANT)
1397	{
1398	cons = NULL__null;
1399	goto depart;
1400	}
1401
1402	/* Check the bounds. */
1403	if ((ar->as->upper[i]
1404	&& mpz_cmp__gmpz_cmp (e->value.integer,
1405	ar->as->upper[i]->value.integer) > 0)
1406	\|\| (mpz_cmp__gmpz_cmp (e->value.integer,
1407	ar->as->lower[i]->value.integer) < 0))
1408	{
1409	gfc_error ("Index in dimension %d is out of bounds "
1410	"at %L", i + 1, &ar->c_where[i]);
1411	cons = NULL__null;
1412	t = false;
1413	goto depart;
1414	}
1415
1416	mpz_sub__gmpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer);
1417	mpz_mul__gmpz_mul (delta, delta, span);
1418	mpz_add__gmpz_add (offset, offset, delta);
1419
1420	mpz_set_ui__gmpz_set_ui (tmp, 1);
1421	mpz_add__gmpz_add (tmp, tmp, ar->as->upper[i]->value.integer);
1422	mpz_sub__gmpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
1423	mpz_mul__gmpz_mul (span, span, tmp);
1424	}
1425
1426	for (cons = gfc_constructor_first (base), nelemen = mpz_get_ui__gmpz_get_ui (offset);
1427	cons && nelemen > 0; cons = gfc_constructor_next (cons), nelemen--)
1428	{
1429	if (cons->iterator)
1430	{
1431	cons = NULL__null;
1432	goto depart;
1433	}
1434	}
1435
1436	depart:
1437	mpz_clear__gmpz_clear (delta);
1438	mpz_clear__gmpz_clear (offset);
1439	mpz_clear__gmpz_clear (span);
1440	mpz_clear__gmpz_clear (tmp);
1441	*rval = cons;
1442	return t;
1443	}
1444
1445
1446	/* Find a component of a structure constructor. */
1447
1448	static gfc_constructor *
1449	find_component_ref (gfc_constructor_base base, gfc_ref *ref)
1450	{
1451	gfc_component *pick = ref->u.c.component;
1452	gfc_constructor *c = gfc_constructor_first (base);
1453
1454	gfc_symbol *dt = ref->u.c.sym;
1455	int ext = dt->attr.extension;
1456
1457	/* For extended types, check if the desired component is in one of the
1458	* parent types. */
1459	while (ext > 0 && gfc_find_component (dt->components->ts.u.derived,
1460	pick->name, true, true, NULL__null))
1461	{
1462	dt = dt->components->ts.u.derived;
1463	c = gfc_constructor_first (c->expr->value.constructor);
1464	ext--;
1465	}
1466
1467	gfc_component *comp = dt->components;
1468	while (comp != pick)
1469	{
1470	comp = comp->next;
1471	c = gfc_constructor_next (c);
1472	}
1473
1474	return c;
1475	}
1476
1477
1478	/* Replace an expression with the contents of a constructor, removing
1479	the subobject reference in the process. */
1480
1481	static void
1482	remove_subobject_ref (gfc_expr p, gfc_constructor cons)
1483	{
1484	gfc_expr *e;
1485
1486	if (cons)
1487	{
1488	e = cons->expr;
1489	cons->expr = NULL__null;
1490	}
1491	else
1492	e = gfc_copy_expr (p);
1493	e->ref = p->ref->next;
1494	p->ref->next = NULL__null;
1495	gfc_replace_expr (p, e);
1496	}
1497
1498
1499	/* Pull an array section out of an array constructor. */
1500
1501	static bool
1502	find_array_section (gfc_expr expr, gfc_ref ref)
1503	{
1504	int idx;
1505	int rank;
1506	int d;
1507	int shape_i;
1508	int limit;
1509	long unsigned one = 1;
1510	bool incr_ctr;
1511	mpz_t start[GFC_MAX_DIMENSIONS15];
1512	mpz_t end[GFC_MAX_DIMENSIONS15];
1513	mpz_t stride[GFC_MAX_DIMENSIONS15];
1514	mpz_t delta[GFC_MAX_DIMENSIONS15];
1515	mpz_t ctr[GFC_MAX_DIMENSIONS15];
1516	mpz_t delta_mpz;
1517	mpz_t tmp_mpz;
1518	mpz_t nelts;
1519	mpz_t ptr;
1520	gfc_constructor_base base;
1521	gfc_constructor cons, vecsub[GFC_MAX_DIMENSIONS15];
1522	gfc_expr *begin;
1523	gfc_expr *finish;
1524	gfc_expr *step;
1525	gfc_expr *upper;
1526	gfc_expr *lower;
1527	bool t;
1528
1529	t = true;
1530
1531	base = expr->value.constructor;
1532	expr->value.constructor = NULL__null;
1533
1534	rank = ref->u.ar.as->rank;
1535
1536	if (expr->shape == NULL__null)
1537	expr->shape = gfc_get_shape (rank)(((mpz_t *) xcalloc (((rank)), sizeof (mpz_t))));
1538
1539	mpz_init_set_ui__gmpz_init_set_ui (delta_mpz, one);
1540	mpz_init_set_ui__gmpz_init_set_ui (nelts, one);
1541	mpz_init__gmpz_init (tmp_mpz);
1542
1543	/* Do the initialization now, so that we can cleanup without
1544	keeping track of where we were. */
1545	for (d = 0; d < rank; d++)
1546	{
1547	mpz_init__gmpz_init (delta[d]);
1548	mpz_init__gmpz_init (start[d]);
1549	mpz_init__gmpz_init (end[d]);
1550	mpz_init__gmpz_init (ctr[d]);
1551	mpz_init__gmpz_init (stride[d]);
1552	vecsub[d] = NULL__null;
1553	}
1554
1555	/* Build the counters to clock through the array reference. */
1556	shape_i = 0;
1557	for (d = 0; d < rank; d++)
1558	{
1559	/* Make this stretch of code easier on the eye! */
1560	begin = ref->u.ar.start[d];
1561	finish = ref->u.ar.end[d];
1562	step = ref->u.ar.stride[d];
1563	lower = ref->u.ar.as->lower[d];
1564	upper = ref->u.ar.as->upper[d];
1565
1566	if (!lower \|\| !upper
1567	\|\| lower->expr_type != EXPR_CONSTANT
1568	\|\| upper->expr_type != EXPR_CONSTANT
1569	\|\| lower->ts.type != BT_INTEGER
1570	\|\| upper->ts.type != BT_INTEGER)
1571	{
1572	t = false;
1573	goto cleanup;
1574	}
1575
1576	if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
1577	{
1578	gfc_constructor *ci;
1579	gcc_assert (begin)((void)(!(begin) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 1579, __FUNCTION__), 0 : 0));
1580
1581	if (begin->expr_type != EXPR_ARRAY \|\| !gfc_is_constant_expr (begin))
1582	{
1583	t = false;
1584	goto cleanup;
1585	}
1586
1587	gcc_assert (begin->rank == 1)((void)(!(begin->rank == 1) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 1587, __FUNCTION__), 0 : 0));
1588	/* Zero-sized arrays have no shape and no elements, stop early. */
1589	if (!begin->shape)
1590	{
1591	mpz_init_set_ui__gmpz_init_set_ui (nelts, 0);
1592	break;
1593	}
1594
1595	vecsub[d] = gfc_constructor_first (begin->value.constructor);
1596	mpz_set__gmpz_set (ctr[d], vecsub[d]->expr->value.integer);
1597	mpz_mul__gmpz_mul (nelts, nelts, begin->shape[0]);
1598	mpz_set__gmpz_set (expr->shape[shape_i++], begin->shape[0]);
1599
1600	/* Check bounds. */
1601	for (ci = vecsub[d]; ci; ci = gfc_constructor_next (ci))
1602	{
1603	if (mpz_cmp__gmpz_cmp (ci->expr->value.integer, upper->value.integer) > 0
1604	\|\| mpz_cmp__gmpz_cmp (ci->expr->value.integer,
1605	lower->value.integer) < 0)
1606	{
1607	gfc_error ("index in dimension %d is out of bounds "
1608	"at %L", d + 1, &ref->u.ar.c_where[d]);
1609	t = false;
1610	goto cleanup;
1611	}
1612	}
1613	}
1614	else
1615	{
1616	if ((begin && begin->expr_type != EXPR_CONSTANT)
1617	\|\| (finish && finish->expr_type != EXPR_CONSTANT)
1618	\|\| (step && step->expr_type != EXPR_CONSTANT))
1619	{
1620	t = false;
1621	goto cleanup;
1622	}
1623
1624	/* Obtain the stride. */
1625	if (step)
1626	mpz_set__gmpz_set (stride[d], step->value.integer);
1627	else
1628	mpz_set_ui__gmpz_set_ui (stride[d], one);
1629
1630	if (mpz_cmp_ui (stride[d], 0)(__builtin_constant_p (0) && (0) == 0 ? ((stride[d])-> _mp_size < 0 ? -1 : (stride[d])->_mp_size > 0) : __gmpz_cmp_ui (stride[d],0)) == 0)
1631	mpz_set_ui__gmpz_set_ui (stride[d], one);
1632
1633	/* Obtain the start value for the index. */
1634	if (begin)
1635	mpz_set__gmpz_set (start[d], begin->value.integer);
1636	else
1637	mpz_set__gmpz_set (start[d], lower->value.integer);
1638
1639	mpz_set__gmpz_set (ctr[d], start[d]);
1640
1641	/* Obtain the end value for the index. */
1642	if (finish)
1643	mpz_set__gmpz_set (end[d], finish->value.integer);
1644	else
1645	mpz_set__gmpz_set (end[d], upper->value.integer);
1646
1647	/* Separate 'if' because elements sometimes arrive with
1648	non-null end. */
1649	if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT)
1650	mpz_set__gmpz_set (end [d], begin->value.integer);
1651
1652	/* Check the bounds. */
1653	if (mpz_cmp__gmpz_cmp (ctr[d], upper->value.integer) > 0
1654	\|\| mpz_cmp__gmpz_cmp (end[d], upper->value.integer) > 0
1655	\|\| mpz_cmp__gmpz_cmp (ctr[d], lower->value.integer) < 0
1656	\|\| mpz_cmp__gmpz_cmp (end[d], lower->value.integer) < 0)
1657	{
1658	gfc_error ("index in dimension %d is out of bounds "
1659	"at %L", d + 1, &ref->u.ar.c_where[d]);
1660	t = false;
1661	goto cleanup;
1662	}
1663
1664	/* Calculate the number of elements and the shape. */
1665	mpz_set__gmpz_set (tmp_mpz, stride[d]);
1666	mpz_add__gmpz_add (tmp_mpz, end[d], tmp_mpz);
1667	mpz_sub__gmpz_sub (tmp_mpz, tmp_mpz, ctr[d]);
1668	mpz_div__gmpz_fdiv_q (tmp_mpz, tmp_mpz, stride[d]);
1669	mpz_mul__gmpz_mul (nelts, nelts, tmp_mpz);
1670
1671	/* An element reference reduces the rank of the expression; don't
1672	add anything to the shape array. */
1673	if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT)
1674	mpz_set__gmpz_set (expr->shape[shape_i++], tmp_mpz);
1675	}
1676
1677	/* Calculate the 'stride' (=delta) for conversion of the
1678	counter values into the index along the constructor. */
1679	mpz_set__gmpz_set (delta[d], delta_mpz);
1680	mpz_sub__gmpz_sub (tmp_mpz, upper->value.integer, lower->value.integer);
1681	mpz_add_ui__gmpz_add_ui (tmp_mpz, tmp_mpz, one);
1682	mpz_mul__gmpz_mul (delta_mpz, delta_mpz, tmp_mpz);
1683	}
1684
1685	mpz_init__gmpz_init (ptr);
1686	cons = gfc_constructor_first (base);
1687
1688	/* Now clock through the array reference, calculating the index in
1689	the source constructor and transferring the elements to the new
1690	constructor. */
1691	for (idx = 0; idx < (int) mpz_get_si__gmpz_get_si (nelts); idx++)
1692	{
1693	mpz_init_set_ui__gmpz_init_set_ui (ptr, 0);
1694
1695	incr_ctr = true;
1696	for (d = 0; d < rank; d++)
1697	{
1698	mpz_set__gmpz_set (tmp_mpz, ctr[d]);
1699	mpz_sub__gmpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer);
1700	mpz_mul__gmpz_mul (tmp_mpz, tmp_mpz, delta[d]);
1701	mpz_add__gmpz_add (ptr, ptr, tmp_mpz);
1702
1703	if (!incr_ctr) continue;
1704
1705	if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
1706	{
1707	gcc_assert(vecsub[d])((void)(!(vecsub[d]) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 1707, __FUNCTION__), 0 : 0));
1708
1709	if (!gfc_constructor_next (vecsub[d]))
1710	vecsub[d] = gfc_constructor_first (ref->u.ar.start[d]->value.constructor);
1711	else
1712	{
1713	vecsub[d] = gfc_constructor_next (vecsub[d]);
1714	incr_ctr = false;
1715	}
1716	mpz_set__gmpz_set (ctr[d], vecsub[d]->expr->value.integer);
1717	}
1718	else
1719	{
1720	mpz_add__gmpz_add (ctr[d], ctr[d], stride[d]);
1721
1722	if (mpz_cmp_ui (stride[d], 0)(__builtin_constant_p (0) && (0) == 0 ? ((stride[d])-> _mp_size < 0 ? -1 : (stride[d])->_mp_size > 0) : __gmpz_cmp_ui (stride[d],0)) > 0
1723	? mpz_cmp__gmpz_cmp (ctr[d], end[d]) > 0
1724	: mpz_cmp__gmpz_cmp (ctr[d], end[d]) < 0)
1725	mpz_set__gmpz_set (ctr[d], start[d]);
1726	else
1727	incr_ctr = false;
1728	}
1729	}
1730
1731	limit = mpz_get_ui__gmpz_get_ui (ptr);
1732	if (limit >= flag_max_array_constructorglobal_options.x_flag_max_array_constructor)
1733	{
1734	gfc_error ("The number of elements in the array constructor "
1735	"at %L requires an increase of the allowed %d "
1736	"upper limit. See %<-fmax-array-constructor%> "
1737	"option", &expr->where, flag_max_array_constructorglobal_options.x_flag_max_array_constructor);
1738	return false;
1739	}
1740
1741	cons = gfc_constructor_lookup (base, limit);
1742	if (cons == NULL__null)
1743	{
1744	gfc_error ("Error in array constructor referenced at %L",
1745	&ref->u.ar.where);
1746	t = false;
1747	goto cleanup;
1748	}
1749	gfc_constructor_append_expr (&expr->value.constructor,
1750	gfc_copy_expr (cons->expr), NULL__null);
1751	}
1752
1753	mpz_clear__gmpz_clear (ptr);
1754
1755	cleanup:
1756
1757	mpz_clear__gmpz_clear (delta_mpz);
1758	mpz_clear__gmpz_clear (tmp_mpz);
1759	mpz_clear__gmpz_clear (nelts);
1760	for (d = 0; d < rank; d++)
1761	{
1762	mpz_clear__gmpz_clear (delta[d]);
1763	mpz_clear__gmpz_clear (start[d]);
1764	mpz_clear__gmpz_clear (end[d]);
1765	mpz_clear__gmpz_clear (ctr[d]);
1766	mpz_clear__gmpz_clear (stride[d]);
1767	}
1768	gfc_constructor_free (base);
1769	return t;
1770	}
1771
1772	/* Pull a substring out of an expression. */
1773
1774	static bool
1775	find_substring_ref (gfc_expr p, gfc_expr *newp)
1776	{
1777	gfc_charlen_t end;
1778	gfc_charlen_t start;
1779	gfc_charlen_t length;
1780	gfc_char_t *chr;
1781
1782	if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
1783	\|\| p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
1784	return false;
1785
1786	*newp = gfc_copy_expr (p);
1787	free ((*newp)->value.character.string);
1788
1789	end = (gfc_charlen_t) mpz_get_si__gmpz_get_si (p->ref->u.ss.end->value.integer);
1790	start = (gfc_charlen_t) mpz_get_si__gmpz_get_si (p->ref->u.ss.start->value.integer);
1791	if (end >= start)
1792	length = end - start + 1;
1793	else
1794	length = 0;
1795
1796	chr = (newp)->value.character.string = gfc_get_wide_string (length + 1)((gfc_char_t ) xcalloc ((length + 1), sizeof (gfc_char_t)));
1797	(*newp)->value.character.length = length;
1798	memcpy (chr, &p->value.character.string[start - 1],
1799	length * sizeof (gfc_char_t));
1800	chr[length] = '\0';
1801	return true;
1802	}
1803
1804
1805	/* Pull an inquiry result out of an expression. */
1806
1807	static bool
1808	find_inquiry_ref (gfc_expr p, gfc_expr *newp)
1809	{
1810	gfc_ref *ref;
1811	gfc_ref *inquiry = NULL__null;
1812	gfc_expr *tmp;
1813
1814	tmp = gfc_copy_expr (p);
1815
1816	if (tmp->ref && tmp->ref->type == REF_INQUIRY)
1817	{
1818	inquiry = tmp->ref;
1819	tmp->ref = NULL__null;
1820	}
1821	else
1822	{
1823	for (ref = tmp->ref; ref; ref = ref->next)
1824	if (ref->next && ref->next->type == REF_INQUIRY)
1825	{
1826	inquiry = ref->next;
1827	ref->next = NULL__null;
1828	}
1829	}
1830
1831	if (!inquiry)
1832	{
1833	gfc_free_expr (tmp);
1834	return false;
1835	}
1836
1837	gfc_resolve_expr (tmp);
1838
1839	/* In principle there can be more than one inquiry reference. */
1840	for (; inquiry; inquiry = inquiry->next)
1841	{
1842	switch (inquiry->u.i)
1843	{
1844	case INQUIRY_LEN:
1845	if (tmp->ts.type != BT_CHARACTER)
1846	goto cleanup;
1847
1848	if (!gfc_notify_std (GFC_STD_F2003(1<<4), "LEN part_ref at %C"))
1849	goto cleanup;
1850
1851	if (tmp->ts.u.cl->length
1852	&& tmp->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1853	*newp = gfc_copy_expr (tmp->ts.u.cl->length);
1854	else if (tmp->expr_type == EXPR_CONSTANT)
1855	*newp = gfc_get_int_expr (gfc_default_integer_kind,
1856	NULL__null, tmp->value.character.length);
1857	else
1858	goto cleanup;
1859
1860	break;
1861
1862	case INQUIRY_KIND:
1863	if (tmp->ts.type == BT_DERIVED \|\| tmp->ts.type == BT_CLASS)
1864	goto cleanup;
1865
1866	if (!gfc_notify_std (GFC_STD_F2003(1<<4), "KIND part_ref at %C"))
1867	goto cleanup;
1868
1869	*newp = gfc_get_int_expr (gfc_default_integer_kind,
1870	NULL__null, tmp->ts.kind);
1871	break;
1872
1873	case INQUIRY_RE:
1874	if (tmp->ts.type != BT_COMPLEX \|\| tmp->expr_type != EXPR_CONSTANT)
1875	goto cleanup;
1876
1877	if (!gfc_notify_std (GFC_STD_F2008(1<<7), "RE part_ref at %C"))
1878	goto cleanup;
1879
1880	*newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where);
1881	mpfr_set ((newp)->value.real,__extension__ ({ mpfr_srcptr _p = (((tmp->value.complex)-> re)); mpfr_set4((newp)->value.real,_p,MPFR_RNDN,((_p)-> _mpfr_sign)); })
1882	mpc_realref (tmp->value.complex), GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (((tmp->value.complex)-> re)); mpfr_set4((*newp)->value.real,_p,MPFR_RNDN,((_p)-> _mpfr_sign)); });
1883	break;
1884
1885	case INQUIRY_IM:
1886	if (tmp->ts.type != BT_COMPLEX \|\| tmp->expr_type != EXPR_CONSTANT)
1887	goto cleanup;
1888
1889	if (!gfc_notify_std (GFC_STD_F2008(1<<7), "IM part_ref at %C"))
1890	goto cleanup;
1891
1892	*newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where);
1893	mpfr_set ((newp)->value.real,__extension__ ({ mpfr_srcptr _p = (((tmp->value.complex)-> im)); mpfr_set4((newp)->value.real,_p,MPFR_RNDN,((_p)-> _mpfr_sign)); })
1894	mpc_imagref (tmp->value.complex), GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (((tmp->value.complex)-> im)); mpfr_set4((*newp)->value.real,_p,MPFR_RNDN,((_p)-> _mpfr_sign)); });
1895	break;
1896	}
1897	tmp = gfc_copy_expr (*newp);
1898	}
1899
1900	if (!(*newp))
1901	goto cleanup;
1902	else if ((*newp)->expr_type != EXPR_CONSTANT)
1903	{
1904	gfc_free_expr (*newp);
1905	goto cleanup;
1906	}
1907
1908	gfc_free_expr (tmp);
1909	return true;
1910
1911	cleanup:
1912	gfc_free_expr (tmp);
1913	return false;
1914	}
1915
1916
1917
1918	/* Simplify a subobject reference of a constructor. This occurs when
1919	parameter variable values are substituted. */
1920
1921	static bool
1922	simplify_const_ref (gfc_expr *p)
1923	{
1924	gfc_constructor cons, c;
1925	gfc_expr *newp = NULL__null;
1926	gfc_ref *last_ref;
1927
1928	while (p->ref)
1929	{
1930	switch (p->ref->type)
1931	{
1932	case REF_ARRAY:
1933	switch (p->ref->u.ar.type)
1934	{
1935	case AR_ELEMENT:
1936	/* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1937	will generate this. */
1938	if (p->expr_type != EXPR_ARRAY)
1939	{
1940	remove_subobject_ref (p, NULL__null);
1941	break;
1942	}
1943	if (!find_array_element (p->value.constructor, &p->ref->u.ar, &cons))
1944	return false;
1945
1946	if (!cons)
1947	return true;
1948
1949	remove_subobject_ref (p, cons);
1950	break;
1951
1952	case AR_SECTION:
1953	if (!find_array_section (p, p->ref))
1954	return false;
1955	p->ref->u.ar.type = AR_FULL;
1956
1957	/* Fall through. */
1958
1959	case AR_FULL:
1960	if (p->ref->next != NULL__null
1961	&& (p->ts.type == BT_CHARACTER \|\| gfc_bt_struct (p->ts.type)((p->ts.type) == BT_DERIVED \|\| (p->ts.type) == BT_UNION )))
1962	{
1963	for (c = gfc_constructor_first (p->value.constructor);
1964	c; c = gfc_constructor_next (c))
1965	{
1966	c->expr->ref = gfc_copy_ref (p->ref->next);
1967	if (!simplify_const_ref (c->expr))
1968	return false;
1969	}
1970
1971	if (gfc_bt_struct (p->ts.type)((p->ts.type) == BT_DERIVED \|\| (p->ts.type) == BT_UNION )
1972	&& p->ref->next
1973	&& (c = gfc_constructor_first (p->value.constructor)))
1974	{
1975	/* There may have been component references. */
1976	p->ts = c->expr->ts;
1977	}
1978
1979	last_ref = p->ref;
1980	for (; last_ref->next; last_ref = last_ref->next) {};
1981
1982	if (p->ts.type == BT_CHARACTER
1983	&& last_ref->type == REF_SUBSTRING)
1984	{
1985	/* If this is a CHARACTER array and we possibly took
1986	a substring out of it, update the type-spec's
1987	character length according to the first element
1988	(as all should have the same length). */
1989	gfc_charlen_t string_len;
1990	if ((c = gfc_constructor_first (p->value.constructor)))
1991	{
1992	const gfc_expr* first = c->expr;
1993	gcc_assert (first->expr_type == EXPR_CONSTANT)((void)(!(first->expr_type == EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 1993, __FUNCTION__), 0 : 0));
1994	gcc_assert (first->ts.type == BT_CHARACTER)((void)(!(first->ts.type == BT_CHARACTER) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 1994, __FUNCTION__), 0 : 0));
1995	string_len = first->value.character.length;
1996	}
1997	else
1998	string_len = 0;
1999
2000	if (!p->ts.u.cl)
2001	{
2002	if (p->symtree)
2003	p->ts.u.cl = gfc_new_charlen (p->symtree->n.sym->ns,
2004	NULL__null);
2005	else
2006	p->ts.u.cl = gfc_new_charlen (gfc_current_ns,
2007	NULL__null);
2008	}
2009	else
2010	gfc_free_expr (p->ts.u.cl->length);
2011
2012	p->ts.u.cl->length
2013	= gfc_get_int_expr (gfc_charlen_int_kind,
2014	NULL__null, string_len);
2015	}
2016	}
2017	gfc_free_ref_list (p->ref);
2018	p->ref = NULL__null;
2019	break;
2020
2021	default:
2022	return true;
2023	}
2024
2025	break;
2026
2027	case REF_COMPONENT:
2028	cons = find_component_ref (p->value.constructor, p->ref);
2029	remove_subobject_ref (p, cons);
2030	break;
2031
2032	case REF_INQUIRY:
2033	if (!find_inquiry_ref (p, &newp))
2034	return false;
2035
2036	gfc_replace_expr (p, newp);
2037	gfc_free_ref_list (p->ref);
2038	p->ref = NULL__null;
2039	break;
2040
2041	case REF_SUBSTRING:
2042	if (!find_substring_ref (p, &newp))
2043	return false;
2044
2045	gfc_replace_expr (p, newp);
2046	gfc_free_ref_list (p->ref);
2047	p->ref = NULL__null;
2048	break;
2049	}
2050	}
2051
2052	return true;
2053	}
2054
2055
2056	/* Simplify a chain of references. */
2057
2058	static bool
2059	simplify_ref_chain (gfc_ref ref, int type, gfc_expr *p)
2060	{
2061	int n;
2062	gfc_expr *newp;
2063
2064	for (; ref; ref = ref->next)
2065	{
2066	switch (ref->type)
2067	{
2068	case REF_ARRAY:
2069	for (n = 0; n < ref->u.ar.dimen; n++)
2070	{
2071	if (!gfc_simplify_expr (ref->u.ar.start[n], type))
2072	return false;
2073	if (!gfc_simplify_expr (ref->u.ar.end[n], type))
2074	return false;
2075	if (!gfc_simplify_expr (ref->u.ar.stride[n], type))
2076	return false;
2077	}
2078	break;
2079
2080	case REF_SUBSTRING:
2081	if (!gfc_simplify_expr (ref->u.ss.start, type))
2082	return false;
2083	if (!gfc_simplify_expr (ref->u.ss.end, type))
2084	return false;
2085	break;
2086
2087	case REF_INQUIRY:
2088	if (!find_inquiry_ref (*p, &newp))
2089	return false;
2090
2091	gfc_replace_expr (*p, newp);
2092	gfc_free_ref_list ((*p)->ref);
2093	(*p)->ref = NULL__null;
2094	return true;
2095
2096	default:
2097	break;
2098	}
2099	}
2100	return true;
2101	}
2102
2103
2104	/* Try to substitute the value of a parameter variable. */
2105
2106	static bool
2107	simplify_parameter_variable (gfc_expr *p, int type)
2108	{
2109	gfc_expr *e;
2110	bool t;
2111
2112	/* Set rank and check array ref; as resolve_variable calls
2113	gfc_simplify_expr, call gfc_resolve_ref + gfc_expression_rank instead. */
2114	if (!gfc_resolve_ref (p))
2115	{
2116	gfc_error_check ();
2117	return false;
2118	}
2119	gfc_expression_rank (p);
2120
2121	/* Is this an inquiry? */
2122	bool inquiry = false;
2123	gfc_ref* ref = p->ref;
2124	while (ref)
2125	{
2126	if (ref->type == REF_INQUIRY)
2127	break;
2128	ref = ref->next;
2129	}
2130	if (ref && ref->type == REF_INQUIRY)
2131	inquiry = ref->u.i == INQUIRY_LEN \|\| ref->u.i == INQUIRY_KIND;
2132
2133	if (gfc_is_size_zero_array (p))
2134	{
2135	if (p->expr_type == EXPR_ARRAY)
2136	return true;
2137
2138	e = gfc_get_expr ();
2139	e->expr_type = EXPR_ARRAY;
2140	e->ts = p->ts;
2141	e->rank = p->rank;
2142	e->value.constructor = NULL__null;
2143	e->shape = gfc_copy_shape (p->shape, p->rank);
2144	e->where = p->where;
2145	/* If %kind and %len are not used then we're done, otherwise
2146	drop through for simplification. */
2147	if (!inquiry)
2148	{
2149	gfc_replace_expr (p, e);
2150	return true;
2151	}
2152	}
2153	else
2154	{
2155	e = gfc_copy_expr (p->symtree->n.sym->value);
2156	if (e == NULL__null)
2157	return false;
2158
2159	gfc_free_shape (&e->shape, e->rank);
2160	e->shape = gfc_copy_shape (p->shape, p->rank);
2161	e->rank = p->rank;
2162
2163	if (e->ts.type == BT_CHARACTER && p->ts.u.cl)
2164	e->ts = p->ts;
2165	}
2166
2167	if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL__null)
2168	e->ts.u.cl = gfc_new_charlen (gfc_current_ns, p->ts.u.cl);
2169
2170	/* Do not copy subobject refs for constant. */
2171	if (e->expr_type != EXPR_CONSTANT && p->ref != NULL__null)
2172	e->ref = gfc_copy_ref (p->ref);
2173	t = gfc_simplify_expr (e, type);
2174	e->where = p->where;
2175
2176	/* Only use the simplification if it eliminated all subobject references. */
2177	if (t && !e->ref)
2178	gfc_replace_expr (p, e);
2179	else
2180	gfc_free_expr (e);
2181
2182	return t;
2183	}
2184
2185
2186	static bool
2187	scalarize_intrinsic_call (gfc_expr *, bool init_flag);
2188
2189	/* Given an expression, simplify it by collapsing constant
2190	expressions. Most simplification takes place when the expression
2191	tree is being constructed. If an intrinsic function is simplified
2192	at some point, we get called again to collapse the result against
2193	other constants.
2194
2195	We work by recursively simplifying expression nodes, simplifying
2196	intrinsic functions where possible, which can lead to further
2197	constant collapsing. If an operator has constant operand(s), we
2198	rip the expression apart, and rebuild it, hoping that it becomes
2199	something simpler.
2200
2201	The expression type is defined for:
2202	0 Basic expression parsing
2203	1 Simplifying array constructors -- will substitute
2204	iterator values.
2205	Returns false on error, true otherwise.
2206	NOTE: Will return true even if the expression cannot be simplified. */
2207
2208	bool
2209	gfc_simplify_expr (gfc_expr *p, int type)
2210	{
2211	gfc_actual_arglist *ap;
2212	gfc_intrinsic_sym* isym = NULL__null;
2213
2214
2215	if (p == NULL__null)
2216	return true;
2217
2218	switch (p->expr_type)
2219	{
2220	case EXPR_CONSTANT:
2221	if (p->ref && p->ref->type == REF_INQUIRY)
2222	simplify_ref_chain (p->ref, type, &p);
2223	break;
2224	case EXPR_NULL:
2225	break;
2226
2227	case EXPR_FUNCTION:
2228	// For array-bound functions, we don't need to optimize
2229	// the 'array' argument. In particular, if the argument
2230	// is a PARAMETER, simplifying might convert an EXPR_VARIABLE
2231	// into an EXPR_ARRAY; the latter has lbound = 1, the former
2232	// can have any lbound.
2233	ap = p->value.function.actual;
2234	if (p->value.function.isym &&
2235	(p->value.function.isym->id == GFC_ISYM_LBOUND
2236	\|\| p->value.function.isym->id == GFC_ISYM_UBOUND
2237	\|\| p->value.function.isym->id == GFC_ISYM_LCOBOUND
2238	\|\| p->value.function.isym->id == GFC_ISYM_UCOBOUND
2239	\|\| p->value.function.isym->id == GFC_ISYM_SHAPE))
2240	ap = ap->next;
2241
2242	for ( ; ap; ap = ap->next)
2243	if (!gfc_simplify_expr (ap->expr, type))
2244	return false;
2245
2246	if (p->value.function.isym != NULL__null
2247	&& gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR)
2248	return false;
2249
2250	if (p->symtree && (p->value.function.isym \|\| p->ts.type == BT_UNKNOWN))
2251	{
2252	isym = gfc_find_function (p->symtree->n.sym->name);
2253	if (isym && isym->elemental)
2254	scalarize_intrinsic_call (p, false);
2255	}
2256
2257	break;
2258
2259	case EXPR_SUBSTRING:
2260	if (!simplify_ref_chain (p->ref, type, &p))
2261	return false;
2262
2263	if (gfc_is_constant_expr (p))
2264	{
2265	gfc_char_t *s;
2266	HOST_WIDE_INTlong start, end;
2267
2268	start = 0;
2269	if (p->ref && p->ref->u.ss.start)
2270	{
2271	gfc_extract_hwi (p->ref->u.ss.start, &start);
2272	start--; /* Convert from one-based to zero-based. */
2273	}
2274
2275	end = p->value.character.length;
2276	if (p->ref && p->ref->u.ss.end)
2277	gfc_extract_hwi (p->ref->u.ss.end, &end);
2278
2279	if (end < start)
2280	end = start;
2281
2282	s = gfc_get_wide_string (end - start + 2)((gfc_char_t *) xcalloc ((end - start + 2), sizeof (gfc_char_t )));
2283	memcpy (s, p->value.character.string + start,
2284	(end - start) * sizeof (gfc_char_t));
2285	s[end - start + 1] = '\0'; /* TODO: C-style string. */
2286	free (p->value.character.string);
2287	p->value.character.string = s;
2288	p->value.character.length = end - start;
2289	p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL__null);
2290	p->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
2291	NULL__null,
2292	p->value.character.length);
2293	gfc_free_ref_list (p->ref);
2294	p->ref = NULL__null;
2295	p->expr_type = EXPR_CONSTANT;
2296	}
2297	break;
2298
2299	case EXPR_OP:
2300	if (!simplify_intrinsic_op (p, type))
2301	return false;
2302	break;
2303
2304	case EXPR_VARIABLE:
2305	/* Only substitute array parameter variables if we are in an
2306	initialization expression, or we want a subsection. */
2307	if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
2308	&& (gfc_init_expr_flag \|\| p->ref
2309	\|\| (p->symtree->n.sym->value
2310	&& p->symtree->n.sym->value->expr_type != EXPR_ARRAY)))
2311	{
2312	if (!simplify_parameter_variable (p, type))
2313	return false;
2314	break;
2315	}
2316
2317	if (type == 1)
2318	{
2319	gfc_simplify_iterator_var (p);
2320	}
2321
2322	/* Simplify subcomponent references. */
2323	if (!simplify_ref_chain (p->ref, type, &p))
2324	return false;
2325
2326	break;
2327
2328	case EXPR_STRUCTURE:
2329	case EXPR_ARRAY:
2330	if (!simplify_ref_chain (p->ref, type, &p))
2331	return false;
2332
2333	/* If the following conditions hold, we found something like kind type
2334	inquiry of the form a(2)%kind while simplify the ref chain. */
2335	if (p->expr_type == EXPR_CONSTANT && !p->ref && !p->rank && !p->shape)
2336	return true;
2337
2338	if (!simplify_constructor (p->value.constructor, type))
2339	return false;
2340
2341	if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY
2342	&& p->ref->u.ar.type == AR_FULL)
2343	gfc_expand_constructor (p, false);
2344
2345	if (!simplify_const_ref (p))
2346	return false;
2347
2348	break;
2349
2350	case EXPR_COMPCALL:
2351	case EXPR_PPC:
2352	break;
2353
2354	case EXPR_UNKNOWN:
2355	gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 2355, __FUNCTION__));
2356	}
2357
2358	return true;
2359	}
2360
2361
2362	/* Try simplification of an expression via gfc_simplify_expr.
2363	When an error occurs (arithmetic or otherwise), roll back. */
2364
2365	bool
2366	gfc_try_simplify_expr (gfc_expr *e, int type)
2367	{
2368	gfc_expr *n;
2369	bool t, saved_div0;
2370
2371	if (e == NULL__null \|\| e->expr_type == EXPR_CONSTANT)
2372	return true;
2373
2374	saved_div0 = gfc_seen_div0;
2375	gfc_seen_div0 = false;
2376	n = gfc_copy_expr (e);
2377	t = gfc_simplify_expr (n, type) && !gfc_seen_div0;
2378	if (t)
2379	gfc_replace_expr (e, n);
2380	else
2381	gfc_free_expr (n);
2382	gfc_seen_div0 = saved_div0;
2383	return t;
2384	}
2385
2386
2387	/* Returns the type of an expression with the exception that iterator
2388	variables are automatically integers no matter what else they may
2389	be declared as. */
2390
2391	static bt
2392	et0 (gfc_expr *e)
2393	{
2394	if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e))
2395	return BT_INTEGER;
2396
2397	return e->ts.type;
2398	}
2399
2400
2401	/* Scalarize an expression for an elemental intrinsic call. */
2402
2403	static bool
2404	scalarize_intrinsic_call (gfc_expr *e, bool init_flag)
2405	{
2406	gfc_actual_arglist a, b;
2407	gfc_constructor_base ctor;
2408	gfc_constructor args[5] = {}; / Avoid uninitialized warnings. */
2409	gfc_constructor ci, new_ctor;
2410	gfc_expr expr, old, *p;
2411	int n, i, rank[5], array_arg;
2412
2413	if (e == NULL__null)
2414	return false;
2415
2416	a = e->value.function.actual;
2417	for (; a; a = a->next)
2418	if (a->expr && !gfc_is_constant_expr (a->expr))
2419	return false;
2420
2421	/* Find which, if any, arguments are arrays. Assume that the old
2422	expression carries the type information and that the first arg
2423	that is an array expression carries all the shape information.*/
2424	n = array_arg = 0;
2425	a = e->value.function.actual;
2426	for (; a; a = a->next)
2427	{
2428	n++;
2429	if (!a->expr \|\| a->expr->expr_type != EXPR_ARRAY)
2430	continue;
2431	array_arg = n;
2432	expr = gfc_copy_expr (a->expr);
2433	break;
2434	}
2435
2436	if (!array_arg)
2437	return false;
2438
2439	old = gfc_copy_expr (e);
2440
2441	gfc_constructor_free (expr->value.constructor);
2442	expr->value.constructor = NULL__null;
2443	expr->ts = old->ts;
2444	expr->where = old->where;
2445	expr->expr_type = EXPR_ARRAY;
2446
2447	/* Copy the array argument constructors into an array, with nulls
2448	for the scalars. */
2449	n = 0;
2450	a = old->value.function.actual;
2451	for (; a; a = a->next)
2452	{
2453	/* Check that this is OK for an initialization expression. */
2454	if (a->expr && init_flag && !gfc_check_init_expr (a->expr))
2455	goto cleanup;
2456
2457	rank[n] = 0;
2458	if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE)
2459	{
2460	rank[n] = a->expr->rank;
2461	ctor = a->expr->symtree->n.sym->value->value.constructor;
2462	args[n] = gfc_constructor_first (ctor);
2463	}
2464	else if (a->expr && a->expr->expr_type == EXPR_ARRAY)
2465	{
2466	if (a->expr->rank)
2467	rank[n] = a->expr->rank;
2468	else
2469	rank[n] = 1;
2470	ctor = gfc_constructor_copy (a->expr->value.constructor);
2471	args[n] = gfc_constructor_first (ctor);
2472	}
2473	else
2474	args[n] = NULL__null;
2475
2476	n++;
2477	}
2478
2479	/* Using the array argument as the master, step through the array
2480	calling the function for each element and advancing the array
2481	constructors together. */
2482	for (ci = args[array_arg - 1]; ci; ci = gfc_constructor_next (ci))
2483	{
2484	new_ctor = gfc_constructor_append_expr (&expr->value.constructor,
2485	gfc_copy_expr (old), NULL__null);
2486
2487	gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
2488	a = NULL__null;
2489	b = old->value.function.actual;
2490	for (i = 0; i < n; i++)
2491	{
2492	if (a == NULL__null)
2493	new_ctor->expr->value.function.actual
2494	= a = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist )));
2495	else
2496	{
2497	a->next = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist )));
2498	a = a->next;
2499	}
2500
2501	if (args[i])
2502	a->expr = gfc_copy_expr (args[i]->expr);
2503	else
2504	a->expr = gfc_copy_expr (b->expr);
2505
2506	b = b->next;
2507	}
2508
2509	/* Simplify the function calls. If the simplification fails, the
2510	error will be flagged up down-stream or the library will deal
2511	with it. */
2512	p = gfc_copy_expr (new_ctor->expr);
2513
2514	if (!gfc_simplify_expr (p, init_flag))
2515	gfc_free_expr (p);
2516	else
2517	gfc_replace_expr (new_ctor->expr, p);
2518
2519	for (i = 0; i < n; i++)
2520	if (args[i])
2521	args[i] = gfc_constructor_next (args[i]);
2522
2523	for (i = 1; i < n; i++)
2524	if (rank[i] && ((args[i] != NULL__null && args[array_arg - 1] == NULL__null)
2525	\|\| (args[i] == NULL__null && args[array_arg - 1] != NULL__null)))
2526	goto compliance;
2527	}
2528
2529	free_expr0 (e);
2530	e = expr;
2531	/* Free "expr" but not the pointers it contains. */
2532	free (expr);
2533	gfc_free_expr (old);
2534	return true;
2535
2536	compliance:
2537	gfc_error_now ("elemental function arguments at %C are not compliant");
2538
2539	cleanup:
2540	gfc_free_expr (expr);
2541	gfc_free_expr (old);
2542	return false;
2543	}
2544
2545
2546	static bool
2547	check_intrinsic_op (gfc_expr e, bool (check_function) (gfc_expr *))
2548	{
2549	gfc_expr *op1 = e->value.op.op1;
2550	gfc_expr *op2 = e->value.op.op2;
2551
2552	if (!(*check_function)(op1))
2553	return false;
2554
2555	switch (e->value.op.op)
2556	{
2557	case INTRINSIC_UPLUS:
2558	case INTRINSIC_UMINUS:
2559	if (!numeric_type (et0 (op1)))
2560	goto not_numeric;
2561	break;
2562
2563	case INTRINSIC_EQ:
2564	case INTRINSIC_EQ_OS:
2565	case INTRINSIC_NE:
2566	case INTRINSIC_NE_OS:
2567	case INTRINSIC_GT:
2568	case INTRINSIC_GT_OS:
2569	case INTRINSIC_GE:
2570	case INTRINSIC_GE_OS:
2571	case INTRINSIC_LT:
2572	case INTRINSIC_LT_OS:
2573	case INTRINSIC_LE:
2574	case INTRINSIC_LE_OS:
2575	if (!(*check_function)(op2))
2576	return false;
2577
2578	if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
2579	&& !(numeric_type (et0 (op1)) && numeric_type (et0 (op2))))
2580	{
2581	gfc_error ("Numeric or CHARACTER operands are required in "
2582	"expression at %L", &e->where);
2583	return false;
2584	}
2585	break;
2586
2587	case INTRINSIC_PLUS:
2588	case INTRINSIC_MINUS:
2589	case INTRINSIC_TIMES:
2590	case INTRINSIC_DIVIDE:
2591	case INTRINSIC_POWER:
2592	if (!(*check_function)(op2))
2593	return false;
2594
2595	if (!numeric_type (et0 (op1)) \|\| !numeric_type (et0 (op2)))
2596	goto not_numeric;
2597
2598	break;
2599
2600	case INTRINSIC_CONCAT:
2601	if (!(*check_function)(op2))
2602	return false;
2603
2604	if (et0 (op1) != BT_CHARACTER \|\| et0 (op2) != BT_CHARACTER)
2605	{
2606	gfc_error ("Concatenation operator in expression at %L "
2607	"must have two CHARACTER operands", &op1->where);
2608	return false;
2609	}
2610
2611	if (op1->ts.kind != op2->ts.kind)
2612	{
2613	gfc_error ("Concat operator at %L must concatenate strings of the "
2614	"same kind", &e->where);
2615	return false;
2616	}
2617
2618	break;
2619
2620	case INTRINSIC_NOT:
2621	if (et0 (op1) != BT_LOGICAL)
2622	{
2623	gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2624	"operand", &op1->where);
2625	return false;
2626	}
2627
2628	break;
2629
2630	case INTRINSIC_AND:
2631	case INTRINSIC_OR:
2632	case INTRINSIC_EQV:
2633	case INTRINSIC_NEQV:
2634	if (!(*check_function)(op2))
2635	return false;
2636
2637	if (et0 (op1) != BT_LOGICAL \|\| et0 (op2) != BT_LOGICAL)
2638	{
2639	gfc_error ("LOGICAL operands are required in expression at %L",
2640	&e->where);
2641	return false;
2642	}
2643
2644	break;
2645
2646	case INTRINSIC_PARENTHESES:
2647	break;
2648
2649	default:
2650	gfc_error ("Only intrinsic operators can be used in expression at %L",
2651	&e->where);
2652	return false;
2653	}
2654
2655	return true;
2656
2657	not_numeric:
2658	gfc_error ("Numeric operands are required in expression at %L", &e->where);
2659
2660	return false;
2661	}
2662
2663	/* F2003, 7.1.7 (3): In init expression, allocatable components
2664	must not be data-initialized. */
2665	static bool
2666	check_alloc_comp_init (gfc_expr *e)
2667	{
2668	gfc_component *comp;
2669	gfc_constructor *ctor;
2670
2671	gcc_assert (e->expr_type == EXPR_STRUCTURE)((void)(!(e->expr_type == EXPR_STRUCTURE) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 2671, __FUNCTION__), 0 : 0));
2672	gcc_assert (e->ts.type == BT_DERIVED \|\| e->ts.type == BT_CLASS)((void)(!(e->ts.type == BT_DERIVED \|\| e->ts.type == BT_CLASS ) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc" , 2672, __FUNCTION__), 0 : 0));
2673
2674	for (comp = e->ts.u.derived->components,
2675	ctor = gfc_constructor_first (e->value.constructor);
2676	comp; comp = comp->next, ctor = gfc_constructor_next (ctor))
2677	{
2678	if (comp->attr.allocatable && ctor->expr
2679	&& ctor->expr->expr_type != EXPR_NULL)
2680	{
2681	gfc_error ("Invalid initialization expression for ALLOCATABLE "
2682	"component %qs in structure constructor at %L",
2683	comp->name, &ctor->expr->where);
2684	return false;
2685	}
2686	}
2687
2688	return true;
2689	}
2690
2691	static match
2692	check_init_expr_arguments (gfc_expr *e)
2693	{
2694	gfc_actual_arglist *ap;
2695
2696	for (ap = e->value.function.actual; ap; ap = ap->next)
2697	if (!gfc_check_init_expr (ap->expr))
2698	return MATCH_ERROR;
2699
2700	return MATCH_YES;
2701	}
2702
2703	static bool check_restricted (gfc_expr *);
2704
2705	/* F95, 7.1.6.1, Initialization expressions, (7)
2706	F2003, 7.1.7 Initialization expression, (8)
2707	F2008, 7.1.12 Constant expression, (4) */
2708
2709	static match
2710	check_inquiry (gfc_expr *e, int not_restricted)
2711	{
2712	const char *name;
2713	const char const functions;
2714
2715	static const char *const inquiry_func_f95[] = {
2716	"lbound", "shape", "size", "ubound",
2717	"bit_size", "len", "kind",
2718	"digits", "epsilon", "huge", "maxexponent", "minexponent",
2719	"precision", "radix", "range", "tiny",
2720	NULL__null
2721	};
2722
2723	static const char *const inquiry_func_f2003[] = {
2724	"lbound", "shape", "size", "ubound",
2725	"bit_size", "len", "kind",
2726	"digits", "epsilon", "huge", "maxexponent", "minexponent",
2727	"precision", "radix", "range", "tiny",
2728	"new_line", NULL__null
2729	};
2730
2731	/* std=f2008+ or -std=gnu */
2732	static const char *const inquiry_func_gnu[] = {
2733	"lbound", "shape", "size", "ubound",
2734	"bit_size", "len", "kind",
2735	"digits", "epsilon", "huge", "maxexponent", "minexponent",
2736	"precision", "radix", "range", "tiny",
2737	"new_line", "storage_size", NULL__null
2738	};
2739
2740	int i = 0;
2741	gfc_actual_arglist *ap;
2742	gfc_symbol *sym;
2743	gfc_symbol *asym;
2744
2745	if (!e->value.function.isym

29.1	Field 'isym' is non-null

←

Taking false branch

→

2746 || !e->value.function.isym->inquiry)

←

Assuming field 'inquiry' is not equal to 0

→

2747 return MATCH_NO; 2748 2749 /* An undeclared parameter will get us here (PR25018). */ 2750 if (e->symtree == NULL__null)

←

Assuming field 'symtree' is not equal to NULL

→

←

Taking false branch

→

2751 return MATCH_NO; 2752 2753 sym = e->symtree->n.sym; 2754 2755 if (sym->from_intmod)

←

Assuming field 'from_intmod' is 0

→

←

Taking false branch

→

2756 { 2757 if (sym->from_intmod == INTMOD_ISO_FORTRAN_ENV 2758 && sym->intmod_sym_id != ISOFORTRAN_COMPILER_OPTIONS 2759 && sym->intmod_sym_id != ISOFORTRAN_COMPILER_VERSION) 2760 return MATCH_NO; 2761 2762 if (sym->from_intmod == INTMOD_ISO_C_BINDING 2763 && sym->intmod_sym_id != ISOCBINDING_C_SIZEOF) 2764 return MATCH_NO; 2765 } 2766 else 2767 { 2768 name = sym->name; 2769 2770 functions = inquiry_func_gnu; 2771 if (gfc_option.warn_std & GFC_STD_F2003(1<<4))

←

Assuming the condition is false

→

←

Taking false branch

→

2772 functions = inquiry_func_f2003; 2773 if (gfc_option.warn_std & GFC_STD_F95(1<<3))

←

Assuming the condition is false

→

←

Taking false branch

→

2774 functions = inquiry_func_f95; 2775 2776 for (i = 0; functions[i]; i++)

←

Loop condition is true. Entering loop body

→

2777 if (strcmp (functions[i], name) == 0)

←

Taking true branch

→

2778 break; 2779 2780 if (functions[i] == NULL__null)

←

Taking false branch

→

2781 return MATCH_ERROR; 2782 } 2783 2784 /* At this point we have an inquiry function with a variable argument. The 2785 type of the variable might be undefined, but we need it now, because the 2786 arguments of these functions are not allowed to be undefined. */ 2787 2788 for (ap = e->value.function.actual; ap; ap = ap->next)

←

Execution continues on line 2780

→

←

Loop condition is true. Entering loop body

→

2789 { 2790 if (!ap->expr)

←

Assuming field 'expr' is non-null

→

2791 continue; 2792 2793 asym = ap->expr->symtree ? ap->expr->symtree->n.sym : NULL__null;

←

Taking false branch

→

←

Assuming field 'symtree' is null

→

←

'?' condition is false

→

←

Null pointer value stored to 'asym'

→

2794 2795 if (ap->expr->ts.type == BT_UNKNOWN)

←

Assuming field 'type' is equal to BT_UNKNOWN

→

2796 { 2797 if (asym

50.1	'asym' is null

&& asym->ts.type == BT_UNKNOWN 2798 && !gfc_set_default_type (asym, 0, gfc_current_ns)) 2799 return MATCH_NO; 2800 2801 ap->expr->ts = asym->ts;

←

Forming reference to null pointer

2802 } 2803 2804 if (asym && asym->assoc && asym->assoc->target 2805 && asym->assoc->target->expr_type == EXPR_CONSTANT) 2806 { 2807 gfc_free_expr (ap->expr); 2808 ap->expr = gfc_copy_expr (asym->assoc->target); 2809 } 2810 2811 /* Assumed character length will not reduce to a constant expression 2812 with LEN, as required by the standard. */ 2813 if (i == 5 && not_restricted && asym 2814 && asym->ts.type == BT_CHARACTER 2815 && ((asym->ts.u.cl && asym->ts.u.cl->length == NULL__null) 2816 || asym->ts.deferred)) 2817 { 2818 gfc_error ("Assumed or deferred character length variable %qs " 2819 "in constant expression at %L", 2820 asym->name, &ap->expr->where); 2821 return MATCH_ERROR; 2822 } 2823 else if (not_restricted && !gfc_check_init_expr (ap->expr)) 2824 return MATCH_ERROR; 2825 2826 if (not_restricted == 0 2827 && ap->expr->expr_type != EXPR_VARIABLE 2828 && !check_restricted (ap->expr)) 2829 return MATCH_ERROR; 2830 2831 if (not_restricted == 0 2832 && ap->expr->expr_type == EXPR_VARIABLE 2833 && asym->attr.dummy && asym->attr.optional) 2834 return MATCH_NO; 2835 } 2836 2837 return MATCH_YES; 2838} 2839 2840 2841/* F95, 7.1.6.1, Initialization expressions, (5) 2842 F2003, 7.1.7 Initialization expression, (5) */ 2843 2844static match 2845check_transformational (gfc_expr *e) 2846{ 2847 static const char * const trans_func_f95[] = { 2848 "repeat", "reshape", "selected_int_kind", 2849 "selected_real_kind", "transfer", "trim", NULL__null 2850 }; 2851 2852 static const char * const trans_func_f2003[] = { 2853 "all", "any", "count", "dot_product", "matmul", "null", "pack", 2854 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind", 2855 "selected_real_kind", "spread", "sum", "transfer", "transpose", 2856 "trim", "unpack", NULL__null 2857 }; 2858 2859 static const char * const trans_func_f2008[] = { 2860 "all", "any", "count", "dot_product", "matmul", "null", "pack", 2861 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind", 2862 "selected_real_kind", "spread", "sum", "transfer", "transpose", 2863 "trim", "unpack", "findloc", NULL__null 2864 }; 2865 2866 int i; 2867 const char *name; 2868 const char *const *functions; 2869 2870 if (!e->value.function.isym 2871 || !e->value.function.isym->transformational) 2872 return MATCH_NO; 2873 2874 name = e->symtree->n.sym->name; 2875 2876 if (gfc_option.allow_std & GFC_STD_F2008(1<<7)) 2877 functions = trans_func_f2008; 2878 else if (gfc_option.allow_std & GFC_STD_F2003(1<<4)) 2879 functions = trans_func_f2003; 2880 else 2881 functions = trans_func_f95; 2882 2883 /* NULL() is dealt with below. */ 2884 if (strcmp ("null", name) == 0) 2885 return MATCH_NO; 2886 2887 for (i = 0; functions[i]; i++) 2888 if (strcmp (functions[i], name) == 0) 2889 break; 2890 2891 if (functions[i] == NULL__null) 2892 { 2893 gfc_error ("transformational intrinsic %qs at %L is not permitted " 2894 "in an initialization expression", name, &e->where); 2895 return MATCH_ERROR; 2896 } 2897 2898 return check_init_expr_arguments (e); 2899} 2900 2901 2902/* F95, 7.1.6.1, Initialization expressions, (6) 2903 F2003, 7.1.7 Initialization expression, (6) */ 2904 2905static match 2906check_null (gfc_expr *e) 2907{ 2908 if (strcmp ("null", e->symtree->n.sym->name) != 0) 2909 return MATCH_NO; 2910 2911 return check_init_expr_arguments (e); 2912} 2913 2914 2915static match 2916check_elemental (gfc_expr *e) 2917{ 2918 if (!e->value.function.isym 2919 || !e->value.function.isym->elemental) 2920 return MATCH_NO; 2921 2922 if (e->ts.type != BT_INTEGER 2923 && e->ts.type != BT_CHARACTER 2924 && !gfc_notify_std (GFC_STD_F2003(1<<4), "Evaluation of nonstandard " 2925 "initialization expression at %L", &e->where)) 2926 return MATCH_ERROR; 2927 2928 return check_init_expr_arguments (e); 2929} 2930 2931 2932static match 2933check_conversion (gfc_expr *e) 2934{ 2935 if (!e->value.function.isym

←

Assuming field 'isym' is non-null

→

←

Taking true branch

→

2936 || !e->value.function.isym->conversion)

←

Assuming field 'conversion' is 0

→

2937 return MATCH_NO;

←

Returning without writing to 'e->value.function.isym', which participates in a condition later

→

←

Returning without writing to 'e->value.function.actual', which participates in a condition later

→

2938 2939 return check_init_expr_arguments (e); 2940} 2941 2942 2943/* Verify that an expression is an initialization expression. A side 2944 effect is that the expression tree is reduced to a single constant 2945 node if all goes well. This would normally happen when the 2946 expression is constructed but function references are assumed to be 2947 intrinsics in the context of initialization expressions. If 2948 false is returned an error message has been generated. */ 2949 2950bool 2951gfc_check_init_expr (gfc_expr *e) 2952{ 2953 match m; 2954 bool t; 2955 2956 if (e

11.1	'e' is not equal to NULL

== NULL__null)

←

Taking false branch

→

2957 return true; 2958 2959 switch (e->expr_type)

←

Control jumps to 'case EXPR_FUNCTION:' at line 2968

→

2960 { 2961 case EXPR_OP: 2962 t = check_intrinsic_op (e, gfc_check_init_expr); 2963 if (t) 2964 t = gfc_simplify_expr (e, 0); 2965 2966 break; 2967 2968 case EXPR_FUNCTION: 2969 t = false; 2970 2971 { 2972 bool conversion; 2973 gfc_intrinsic_sym* isym = NULL__null; 2974 gfc_symbol* sym = e->symtree->n.sym; 2975 2976 /* Simplify here the intrinsics from the IEEE_ARITHMETIC and 2977 IEEE_EXCEPTIONS modules. */ 2978 int mod = sym->from_intmod; 2979 if (mod == INTMOD_NONE && sym->generic)

←

Assuming 'mod' is not equal to INTMOD_NONE

→

2980 mod = sym->generic->sym->from_intmod; 2981 if (mod == INTMOD_IEEE_ARITHMETIC || mod == INTMOD_IEEE_EXCEPTIONS)

←

Assuming 'mod' is not equal to INTMOD_IEEE_ARITHMETIC

→

←

Assuming 'mod' is equal to INTMOD_IEEE_EXCEPTIONS

→

←

Taking true branch

→

2982 { 2983 gfc_expr *new_expr = gfc_simplify_ieee_functions (e); 2984 if (new_expr)

←

Assuming 'new_expr' is null

→

2985 { 2986 gfc_replace_expr (e, new_expr); 2987 t = true; 2988 break; 2989 } 2990 } 2991 2992 /* If a conversion function, e.g., __convert_i8_i4, was inserted 2993 into an array constructor, we need to skip the error check here. 2994 Conversion errors are caught below in scalarize_intrinsic_call. */ 2995 conversion = e->value.function.isym

←

Assuming field 'isym' is null

→

2996 && (e->value.function.isym->conversion == 1); 2997 2998 if (!conversion

19.1	'conversion' is false

&& (!gfc_is_intrinsic (sym, 0, e->where)

←

Assuming the condition is false

→

2999 || (m = gfc_intrinsic_func_interface (e, 0)) == MATCH_NO))

←

Assuming the condition is false

→

3000 { 3001 gfc_error ("Function %qs in initialization expression at %L " 3002 "must be an intrinsic function", 3003 e->symtree->n.sym->name, &e->where); 3004 break; 3005 } 3006 3007 if ((m = check_conversion (e)) == MATCH_NO

←

Calling 'check_conversion'

→

←

Returning from 'check_conversion'

→

3008 && (m = check_inquiry (e, 1)) == MATCH_NO

←

Calling 'check_inquiry'

→

3009 && (m = check_null (e)) == MATCH_NO 3010 && (m = check_transformational (e)) == MATCH_NO 3011 && (m = check_elemental (e)) == MATCH_NO) 3012 { 3013 gfc_error ("Intrinsic function %qs at %L is not permitted " 3014 "in an initialization expression", 3015 e->symtree->n.sym->name, &e->where); 3016 m = MATCH_ERROR; 3017 } 3018 3019 if (m == MATCH_ERROR) 3020 return false; 3021 3022 /* Try to scalarize an elemental intrinsic function that has an 3023 array argument. */ 3024 isym = gfc_find_function (e->symtree->n.sym->name); 3025 if (isym && isym->elemental 3026 && (t = scalarize_intrinsic_call (e, true))) 3027 break; 3028 } 3029 3030 if (m == MATCH_YES) 3031 t = gfc_simplify_expr (e, 0); 3032 3033 break; 3034 3035 case EXPR_VARIABLE: 3036 t = true; 3037 3038 /* This occurs when parsing pdt templates. */ 3039 if (gfc_expr_attr (e).pdt_kind) 3040 break; 3041 3042 if (gfc_check_iter_variable (e)) 3043 break; 3044 3045 if (e->symtree->n.sym->attr.flavor == FL_PARAMETER) 3046 { 3047 /* A PARAMETER shall not be used to define itself, i.e. 3048 REAL, PARAMETER :: x = transfer(0, x) 3049 is invalid. */ 3050 if (!e->symtree->n.sym->value) 3051 { 3052 gfc_error ("PARAMETER %qs is used at %L before its definition " 3053 "is complete", e->symtree->n.sym->name, &e->where); 3054 t = false; 3055 } 3056 else 3057 t = simplify_parameter_variable (e, 0); 3058 3059 break; 3060 } 3061 3062 if (gfc_in_match_data ()) 3063 break; 3064 3065 t = false; 3066 3067 if (e->symtree->n.sym->as) 3068 { 3069 switch (e->symtree->n.sym->as->type) 3070 { 3071 case AS_ASSUMED_SIZE: 3072 gfc_error ("Assumed size array %qs at %L is not permitted " 3073 "in an initialization expression", 3074 e->symtree->n.sym->name, &e->where); 3075 break; 3076 3077 case AS_ASSUMED_SHAPE: 3078 gfc_error ("Assumed shape array %qs at %L is not permitted " 3079 "in an initialization expression", 3080 e->symtree->n.sym->name, &e->where); 3081 break; 3082 3083 case AS_DEFERRED: 3084 if (!e->symtree->n.sym->attr.allocatable 3085 && !e->symtree->n.sym->attr.pointer 3086 && e->symtree->n.sym->attr.dummy) 3087 gfc_error ("Assumed-shape array %qs at %L is not permitted " 3088 "in an initialization expression", 3089 e->symtree->n.sym->name, &e->where); 3090 else 3091 gfc_error ("Deferred array %qs at %L is not permitted " 3092 "in an initialization expression", 3093 e->symtree->n.sym->name, &e->where); 3094 break; 3095 3096 case AS_EXPLICIT: 3097 gfc_error ("Array %qs at %L is a variable, which does " 3098 "not reduce to a constant expression", 3099 e->symtree->n.sym->name, &e->where); 3100 break; 3101 3102 case AS_ASSUMED_RANK: 3103 gfc_error ("Assumed-rank array %qs at %L is not permitted " 3104 "in an initialization expression", 3105 e->symtree->n.sym->name, &e->where); 3106 break; 3107 3108 default: 3109 gcc_unreachable()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc"
, 3109, __FUNCTION__)); 3110 } 3111 } 3112 else 3113 gfc_error ("Parameter %qs at %L has not been declared or is " 3114 "a variable, which does not reduce to a constant " 3115 "expression", e->symtree->name, &e->where); 3116 3117 break; 3118 3119 case EXPR_CONSTANT: 3120 case EXPR_NULL: 3121 t = true; 3122 break; 3123 3124 case EXPR_SUBSTRING: 3125 if (e->ref) 3126 { 3127 t = gfc_check_init_expr (e->ref->u.ss.start); 3128 if (!t) 3129 break; 3130 3131 t = gfc_check_init_expr (e->ref->u.ss.end); 3132 if (t) 3133 t = gfc_simplify_expr (e, 0); 3134 } 3135 else 3136 t = false; 3137 break; 3138 3139 case EXPR_STRUCTURE: 3140 t = e->ts.is_iso_c ? true : false; 3141 if (t) 3142 break; 3143 3144 t = check_alloc_comp_init (e); 3145 if (!t) 3146 break; 3147 3148 t = gfc_check_constructor (e, gfc_check_init_expr); 3149 if (!t) 3150 break; 3151 3152 break; 3153 3154 case EXPR_ARRAY: 3155 t = gfc_check_constructor (e, gfc_check_init_expr); 3156 if (!t) 3157 break; 3158 3159 t = gfc_expand_constructor (e, true); 3160 if (!t) 3161 break; 3162 3163 t = gfc_check_constructor_type (e); 3164 break; 3165 3166 default: 3167 gfc_internal_error ("check_init_expr(): Unknown expression type"); 3168 } 3169 3170 return t; 3171} 3172 3173/* Reduces a general expression to an initialization expression (a constant). 3174 This used to be part of gfc_match_init_expr. 3175 Note that this function doesn't free the given expression on false. */ 3176 3177bool 3178gfc_reduce_init_expr (gfc_expr *expr) 3179{ 3180 bool t; 3181 3182 gfc_init_expr_flag = true; 3183 t = gfc_resolve_expr (expr); 3184 if (t) 3185 t = gfc_check_init_expr (expr); 3186 gfc_init_expr_flag = false; 3187 3188 if (!t || !expr) 3189 return false; 3190 3191 if (expr->expr_type == EXPR_ARRAY) 3192 { 3193 if (!gfc_check_constructor_type (expr)) 3194 return false; 3195 if (!gfc_expand_constructor (expr, true)) 3196 return false; 3197 } 3198 3199 return true; 3200} 3201 3202 3203/* Match an initialization expression. We work by first matching an 3204 expression, then reducing it to a constant. */ 3205 3206match 3207gfc_match_init_expr (gfc_expr **result) 3208{ 3209 gfc_expr *expr; 3210 match m; 3211 bool t; 3212 3213 expr = NULL__null; 3214 3215 gfc_init_expr_flag = true; 3216 3217 m = gfc_match_expr (&expr); 3218 if (m != MATCH_YES) 3219 { 3220 gfc_init_expr_flag = false; 3221 return m; 3222 } 3223 3224 if (gfc_derived_parameter_expr (expr)) 3225 { 3226 *result = expr; 3227 gfc_init_expr_flag = false; 3228 return m; 3229 } 3230 3231 t = gfc_reduce_init_expr (expr); 3232 if (!t) 3233 { 3234 gfc_free_expr (expr); 3235 gfc_init_expr_flag = false; 3236 return MATCH_ERROR; 3237 } 3238 3239 *result = expr; 3240 gfc_init_expr_flag = false; 3241 3242 return MATCH_YES; 3243} 3244 3245 3246/* Given an actual argument list, test to see that each argument is a 3247 restricted expression and optionally if the expression type is 3248 integer or character. */ 3249 3250static bool 3251restricted_args (gfc_actual_arglist *a) 3252{ 3253 for (; a; a = a->next) 3254 { 3255 if (!check_restricted (a->expr)) 3256 return false; 3257 } 3258 3259 return true; 3260} 3261 3262 3263/************* Restricted/specification expressions *************/ 3264 3265 3266/* Make sure a non-intrinsic function is a specification function, 3267 * see F08:7.1.11.5. */ 3268 3269static bool 3270external_spec_function (gfc_expr *e) 3271{ 3272 gfc_symbol *f; 3273 3274 f = e->value.function.esym; 3275 3276 /* IEEE functions allowed are "a reference to a transformational function 3277 from the intrinsic module IEEE_ARITHMETIC or IEEE_EXCEPTIONS", and 3278 "inquiry function from the intrinsic modules IEEE_ARITHMETIC and 3279 IEEE_EXCEPTIONS". */ 3280 if (f->from_intmod == INTMOD_IEEE_ARITHMETIC 3281 || f->from_intmod == INTMOD_IEEE_EXCEPTIONS) 3282 { 3283 if (!strcmp (f->name, "ieee_selected_real_kind") 3284 || !strcmp (f->name, "ieee_support_rounding") 3285 || !strcmp (f->name, "ieee_support_flag") 3286 || !strcmp (f->name, "ieee_support_halting") 3287 || !strcmp (f->name, "ieee_support_datatype") 3288 || !strcmp (f->name, "ieee_support_denormal") 3289 || !strcmp (f->name, "ieee_support_subnormal") 3290 || !strcmp (f->name, "ieee_support_divide") 3291 || !strcmp (f->name, "ieee_support_inf") 3292 || !strcmp (f->name, "ieee_support_io") 3293 || !strcmp (f->name, "ieee_support_nan") 3294 || !strcmp (f->name, "ieee_support_sqrt") 3295 || !strcmp (f->name, "ieee_support_standard") 3296 || !strcmp (f->name, "ieee_support_underflow_control")) 3297 goto function_allowed; 3298 } 3299 3300 if (f->attr.proc == PROC_ST_FUNCTION) 3301 { 3302 gfc_error ("Specification function %qs at %L cannot be a statement " 3303 "function", f->name, &e->where); 3304 return false; 3305 } 3306 3307 if (f->attr.proc == PROC_INTERNAL) 3308 { 3309 gfc_error ("Specification function %qs at %L cannot be an internal " 3310 "function", f->name, &e->where); 3311 return false; 3312 } 3313 3314 if (!f->attr.pure && !f->attr.elemental) 3315 { 3316 gfc_error ("Specification function %qs at %L must be PURE", f->name, 3317 &e->where); 3318 return false; 3319 } 3320 3321 /* F08:7.1.11.6. */ 3322 if (f->attr.recursive 3323 && !gfc_notify_std (GFC_STD_F2003(1<<4), 3324 "Specification function %qs " 3325 "at %L cannot be RECURSIVE", f->name, &e->where)) 3326 return false; 3327 3328function_allowed: 3329 return restricted_args (e->value.function.actual); 3330} 3331 3332 3333/* Check to see that a function reference to an intrinsic is a 3334 restricted expression. */ 3335 3336static bool 3337restricted_intrinsic (gfc_expr *e) 3338{ 3339 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */ 3340 if (check_inquiry (e, 0) == MATCH_YES) 3341 return true; 3342 3343 return restricted_args (e->value.function.actual); 3344} 3345 3346 3347/* Check the expressions of an actual arglist. Used by check_restricted. */ 3348 3349static bool 3350check_arglist (gfc_actual_arglist* arg, bool (*checker) (gfc_expr*)) 3351{ 3352 for (; arg; arg = arg->next) 3353 if (!checker (arg->expr)) 3354 return false; 3355 3356 return true; 3357} 3358 3359 3360/* Check the subscription expressions of a reference chain with a checking 3361 function; used by check_restricted. */ 3362 3363static bool 3364check_references (gfc_ref* ref, bool (*checker) (gfc_expr*)) 3365{ 3366 int dim; 3367 3368 if (!ref) 3369 return true; 3370 3371 switch (ref->type) 3372 { 3373 case REF_ARRAY: 3374 for (dim = 0; dim < ref->u.ar.dimen; ++dim) 3375 { 3376 if (!checker (ref->u.ar.start[dim])) 3377 return false; 3378 if (!checker (ref->u.ar.end[dim])) 3379 return false; 3380 if (!checker (ref->u.ar.stride[dim])) 3381 return false; 3382 } 3383 break; 3384 3385 case REF_COMPONENT: 3386 /* Nothing needed, just proceed to next reference. */ 3387 break; 3388 3389 case REF_SUBSTRING: 3390 if (!checker (ref->u.ss.start)) 3391 return false; 3392 if (!checker (ref->u.ss.end)) 3393 return false; 3394 break; 3395 3396 default: 3397 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc"
, 3397, __FUNCTION__)); 3398 break; 3399 } 3400 3401 return check_references (ref->next, checker); 3402} 3403 3404/* Return true if ns is a parent of the current ns. */ 3405 3406static bool 3407is_parent_of_current_ns (gfc_namespace *ns) 3408{ 3409 gfc_namespace *p; 3410 for (p = gfc_current_ns->parent; p; p = p->parent) 3411 if (ns == p) 3412 return true; 3413 3414 return false; 3415} 3416 3417/* Verify that an expression is a restricted expression. Like its 3418 cousin check_init_expr(), an error message is generated if we 3419 return false. */ 3420 3421static bool 3422check_restricted (gfc_expr *e) 3423{ 3424 gfc_symbol* sym; 3425 bool t; 3426 3427 if (e == NULL__null) 3428 return true; 3429 3430 switch (e->expr_type) 3431 { 3432 case EXPR_OP: 3433 t = check_intrinsic_op (e, check_restricted); 3434 if (t) 3435 t = gfc_simplify_expr (e, 0); 3436 3437 break; 3438 3439 case EXPR_FUNCTION: 3440 if (e->value.function.esym) 3441 { 3442 t = check_arglist (e->value.function.actual, &check_restricted); 3443 if (t) 3444 t = external_spec_function (e); 3445 } 3446 else 3447 { 3448 if (e->value.function.isym && e->value.function.isym->inquiry) 3449 t = true; 3450 else 3451 t = check_arglist (e->value.function.actual, &check_restricted); 3452 3453 if (t) 3454 t = restricted_intrinsic (e); 3455 } 3456 break; 3457 3458 case EXPR_VARIABLE: 3459 sym = e->symtree->n.sym; 3460 t = false; 3461 3462 /* If a dummy argument appears in a context that is valid for a 3463 restricted expression in an elemental procedure, it will have 3464 already been simplified away once we get here. Therefore we 3465 don't need to jump through hoops to distinguish valid from 3466 invalid cases. Allowed in F2008 and F2018. */ 3467 if (gfc_notification_std (GFC_STD_F2008(1<<7)) 3468 && sym->attr.dummy && sym->ns == gfc_current_ns 3469 && sym->ns->proc_name && sym->ns->proc_name->attr.elemental) 3470 { 3471 gfc_error_now ("Dummy argument %qs not " 3472 "allowed in expression at %L", 3473 sym->name, &e->where); 3474 break; 3475 } 3476 3477 if (sym->attr.optional) 3478 { 3479 gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL", 3480 sym->name, &e->where); 3481 break; 3482 } 3483 3484 if (sym->attr.intent == INTENT_OUT) 3485 { 3486 gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)", 3487 sym->name, &e->where); 3488 break; 3489 } 3490 3491 /* Check reference chain if any. */ 3492 if (!check_references (e->ref, &check_restricted)) 3493 break; 3494 3495 /* gfc_is_formal_arg broadcasts that a formal argument list is being 3496 processed in resolve.cc(resolve_formal_arglist). This is done so 3497 that host associated dummy array indices are accepted (PR23446). 3498 This mechanism also does the same for the specification expressions 3499 of array-valued functions. */ 3500 if (e->error 3501 || sym->attr.in_common 3502 || sym->attr.use_assoc 3503 || sym->attr.dummy 3504 || sym->attr.implied_index 3505 || sym->attr.flavor == FL_PARAMETER 3506 || is_parent_of_current_ns (sym->ns) 3507 || (sym->ns->proc_name != NULL__null 3508 && sym->ns->proc_name->attr.flavor == FL_MODULE) 3509 || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns))) 3510 { 3511 t = true; 3512 break; 3513 } 3514 3515 gfc_error ("Variable %qs cannot appear in the expression at %L", 3516 sym->name, &e->where); 3517 /* Prevent a repetition of the error. */ 3518 e->error = 1; 3519 break; 3520 3521 case EXPR_NULL: 3522 case EXPR_CONSTANT: 3523 t = true; 3524 break; 3525 3526 case EXPR_SUBSTRING: 3527 t = gfc_specification_expr (e->ref->u.ss.start); 3528 if (!t) 3529 break; 3530 3531 t = gfc_specification_expr (e->ref->u.ss.end); 3532 if (t) 3533 t = gfc_simplify_expr (e, 0); 3534 3535 break; 3536 3537 case EXPR_STRUCTURE: 3538 t = gfc_check_constructor (e, check_restricted); 3539 break; 3540 3541 case EXPR_ARRAY: 3542 t = gfc_check_constructor (e, check_restricted); 3543 break; 3544 3545 default: 3546 gfc_internal_error ("check_restricted(): Unknown expression type"); 3547 } 3548 3549 return t; 3550} 3551 3552 3553/* Check to see that an expression is a specification expression. If 3554 we return false, an error has been generated. */ 3555 3556bool 3557gfc_specification_expr (gfc_expr *e) 3558{ 3559 gfc_component *comp; 3560 3561 if (e == NULL__null) 3562 return true; 3563 3564 if (e->ts.type != BT_INTEGER) 3565 { 3566 gfc_error ("Expression at %L must be of INTEGER type, found %s", 3567 &e->where, gfc_basic_typename (e->ts.type)); 3568 return false; 3569 } 3570 3571 comp = gfc_get_proc_ptr_comp (e); 3572 if (e->expr_type == EXPR_FUNCTION 3573 && !e->value.function.isym 3574 && !e->value.function.esym 3575 && !gfc_pure (e->symtree->n.sym) 3576 && (!comp || !comp->attr.pure)) 3577 { 3578 gfc_error ("Function %qs at %L must be PURE", 3579 e->symtree->n.sym->name, &e->where); 3580 /* Prevent repeat error messages. */ 3581 e->symtree->n.sym->attr.pure = 1; 3582 return false; 3583 } 3584 3585 if (e->rank != 0) 3586 { 3587 gfc_error ("Expression at %L must be scalar", &e->where); 3588 return false; 3589 } 3590 3591 if (!gfc_simplify_expr (e, 0)) 3592 return false; 3593 3594 return check_restricted (e); 3595} 3596 3597 3598/************** Expression conformance checks. *************/ 3599 3600/* Given two expressions, make sure that the arrays are conformable. */ 3601 3602bool 3603gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, ...) 3604{ 3605 int op1_flag, op2_flag, d; 3606 mpz_t op1_size, op2_size; 3607 bool t; 3608 3609 va_list argp; 3610 char buffer[240]; 3611 3612 if (op1->rank == 0 || op2->rank == 0) 3613 return true; 3614 3615 va_start (argp, optype_msgid)__builtin_va_start(argp, optype_msgid); 3616 d = vsnprintf (buffer, sizeof (buffer), optype_msgid, argp); 3617 va_end (argp)__builtin_va_end(argp); 3618 if (d < 1 || d >= (int) sizeof (buffer)) /* Reject truncation. */ 3619 gfc_internal_error ("optype_msgid overflow: %d", d); 3620 3621 if (op1->rank != op2->rank) 3622 { 3623 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer)gettext (buffer), 3624 op1->rank, op2->rank, &op1->where); 3625 return false; 3626 } 3627 3628 t = true; 3629 3630 for (d = 0; d < op1->rank; d++) 3631 { 3632 op1_flag = gfc_array_dimen_size(op1, d, &op1_size); 3633 op2_flag = gfc_array_dimen_size(op2, d, &op2_size); 3634 3635 if (op1_flag && op2_flag && mpz_cmp__gmpz_cmp (op1_size, op2_size) != 0) 3636 { 3637 gfc_error ("Different shape for %s at %L on dimension %d " 3638 "(%d and %d)", _(buffer)gettext (buffer), &op1->where, d + 1, 3639 (int) mpz_get_si__gmpz_get_si (op1_size), 3640 (int) mpz_get_si__gmpz_get_si (op2_size)); 3641 3642 t = false; 3643 } 3644 3645 if (op1_flag) 3646 mpz_clear__gmpz_clear (op1_size); 3647 if (op2_flag) 3648 mpz_clear__gmpz_clear (op2_size); 3649 3650 if (!t) 3651 return false; 3652 } 3653 3654 return true; 3655} 3656 3657 3658/* Given an assignable expression and an arbitrary expression, make 3659 sure that the assignment can take place. Only add a call to the intrinsic 3660 conversion routines, when allow_convert is set. When this assign is a 3661 coarray call, then the convert is done by the coarray routine implictly and 3662 adding the intrinsic conversion would do harm in most cases. */ 3663 3664bool 3665gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform, 3666 bool allow_convert) 3667{ 3668 gfc_symbol *sym; 3669 gfc_ref *ref; 3670 int has_pointer; 3671 3672 sym = lvalue->symtree->n.sym; 3673 3674 /* See if this is the component or subcomponent of a pointer and guard 3675 against assignment to LEN or KIND part-refs. */ 3676 has_pointer = sym->attr.pointer; 3677 for (ref = lvalue->ref; ref; ref = ref->next) 3678 { 3679 if (!has_pointer && ref->type == REF_COMPONENT 3680 && ref->u.c.component->attr.pointer) 3681 has_pointer = 1; 3682 else if (ref->type == REF_INQUIRY 3683 && (ref->u.i == INQUIRY_LEN || ref->u.i == INQUIRY_KIND)) 3684 { 3685 gfc_error ("Assignment to a LEN or KIND part_ref at %L is not " 3686 "allowed", &lvalue->where); 3687 return false; 3688 } 3689 } 3690 3691 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other 3692 variable local to a function subprogram. Its existence begins when 3693 execution of the function is initiated and ends when execution of the 3694 function is terminated... 3695 Therefore, the left hand side is no longer a variable, when it is: */ 3696 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION 3697 && !sym->attr.external) 3698 { 3699 bool bad_proc; 3700 bad_proc = false; 3701 3702 /* (i) Use associated; */ 3703 if (sym->attr.use_assoc) 3704 bad_proc = true; 3705 3706 /* (ii) The assignment is in the main program; or */ 3707 if (gfc_current_ns->proc_name 3708 && gfc_current_ns->proc_name->attr.is_main_program) 3709 bad_proc = true; 3710 3711 /* (iii) A module or internal procedure... */ 3712 if (gfc_current_ns->proc_name 3713 && (gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL 3714 || gfc_current_ns->proc_name->attr.proc == PROC_MODULE) 3715 && gfc_current_ns->parent 3716 && (!(gfc_current_ns->parent->proc_name->attr.function 3717 || gfc_current_ns->parent->proc_name->attr.subroutine) 3718 || gfc_current_ns->parent->proc_name->attr.is_main_program)) 3719 { 3720 /* ... that is not a function... */ 3721 if (gfc_current_ns->proc_name 3722 && !gfc_current_ns->proc_name->attr.function) 3723 bad_proc = true; 3724 3725 /* ... or is not an entry and has a different name. */ 3726 if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name) 3727 bad_proc = true; 3728 } 3729 3730 /* (iv) Host associated and not the function symbol or the 3731 parent result. This picks up sibling references, which 3732 cannot be entries. */ 3733 if (!sym->attr.entry 3734 && sym->ns == gfc_current_ns->parent 3735 && sym != gfc_current_ns->proc_name 3736 && sym != gfc_current_ns->parent->proc_name->result) 3737 bad_proc = true; 3738 3739 if (bad_proc) 3740 { 3741 gfc_error ("%qs at %L is not a VALUE", sym->name, &lvalue->where); 3742 return false; 3743 } 3744 } 3745 else 3746 { 3747 /* Reject assigning to an external symbol. For initializers, this 3748 was already done before, in resolve_fl_procedure. */ 3749 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external 3750 && sym->attr.proc != PROC_MODULE && !rvalue->error) 3751 { 3752 gfc_error ("Illegal assignment to external procedure at %L", 3753 &lvalue->where); 3754 return false; 3755 } 3756 } 3757 3758 if (rvalue->rank != 0 && lvalue->rank != rvalue->rank) 3759 { 3760 gfc_error ("Incompatible ranks %d and %d in assignment at %L", 3761 lvalue->rank, rvalue->rank, &lvalue->where); 3762 return false; 3763 } 3764 3765 if (lvalue->ts.type == BT_UNKNOWN) 3766 { 3767 gfc_error ("Variable type is UNKNOWN in assignment at %L", 3768 &lvalue->where); 3769 return false; 3770 } 3771 3772 if (rvalue->expr_type == EXPR_NULL) 3773 { 3774 if (has_pointer && (ref == NULL__null || ref->next == NULL__null) 3775 && lvalue->symtree->n.sym->attr.data) 3776 return true; 3777 else 3778 { 3779 gfc_error ("NULL appears on right-hand side in assignment at %L", 3780 &rvalue->where); 3781 return false; 3782 } 3783 } 3784 3785 /* This is possibly a typo: x = f() instead of x => f(). */ 3786 if (warn_surprisingglobal_options.x_warn_surprising 3787 && rvalue->expr_type == EXPR_FUNCTION && gfc_expr_attr (rvalue).pointer) 3788 gfc_warning (OPT_Wsurprising, 3789 "POINTER-valued function appears on right-hand side of " 3790 "assignment at %L", &rvalue->where); 3791 3792 /* Check size of array assignments. */ 3793 if (lvalue->rank != 0 && rvalue->rank != 0 3794 && !gfc_check_conformance (lvalue, rvalue, _("array assignment")gettext ("array assignment"))) 3795 return false; 3796 3797 /* Handle the case of a BOZ literal on the RHS. */ 3798 if (rvalue->ts.type == BT_BOZ) 3799 { 3800 if (lvalue->symtree->n.sym->attr.data) 3801 { 3802 if (lvalue->ts.type == BT_INTEGER 3803 && gfc_boz2int (rvalue, lvalue->ts.kind)) 3804 return true; 3805 3806 if (lvalue->ts.type == BT_REAL 3807 && gfc_boz2real (rvalue, lvalue->ts.kind)) 3808 { 3809 if (gfc_invalid_boz ("BOZ literal constant near %L cannot " 3810 "be assigned to a REAL variable", 3811 &rvalue->where)) 3812 return false; 3813 return true; 3814 } 3815 } 3816 3817 if (!lvalue->symtree->n.sym->attr.data 3818 && gfc_invalid_boz ("BOZ literal constant at %L is neither a " 3819 "data-stmt-constant nor an actual argument to " 3820 "INT, REAL, DBLE, or CMPLX intrinsic function", 3821 &rvalue->where)) 3822 return false; 3823 3824 if (lvalue->ts.type == BT_INTEGER 3825 && gfc_boz2int (rvalue, lvalue->ts.kind)) 3826 return true; 3827 3828 if (lvalue->ts.type == BT_REAL 3829 && gfc_boz2real (rvalue, lvalue->ts.kind)) 3830 return true; 3831 3832 gfc_error ("BOZ literal constant near %L cannot be assigned to a " 3833 "%qs variable", &rvalue->where, gfc_typename (lvalue)); 3834 return false; 3835 } 3836 3837 if (gfc_expr_attr (lvalue).pdt_kind || gfc_expr_attr (lvalue).pdt_len) 3838 { 3839 gfc_error ("The assignment to a KIND or LEN component of a " 3840 "parameterized type at %L is not allowed", 3841 &lvalue->where); 3842 return false; 3843 } 3844 3845 if (gfc_compare_types (&lvalue->ts, &rvalue->ts)) 3846 return true; 3847 3848 /* Only DATA Statements come here. */ 3849 if (!conform) 3850 { 3851 locus *where; 3852 3853 /* Numeric can be converted to any other numeric. And Hollerith can be 3854 converted to any other type. */ 3855 if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts)) 3856 || rvalue->ts.type == BT_HOLLERITH) 3857 return true; 3858 3859 if (flag_dec_char_conversionsglobal_options.x_flag_dec_char_conversions && (gfc_numeric_ts (&lvalue->ts) 3860 || lvalue->ts.type == BT_LOGICAL) 3861 && rvalue->ts.type == BT_CHARACTER 3862 && rvalue->ts.kind == gfc_default_character_kind) 3863 return true; 3864 3865 if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL) 3866 return true; 3867 3868 where = lvalue->where.lb ? &lvalue->where : &rvalue->where; 3869 gfc_error ("Incompatible types in DATA statement at %L; attempted " 3870 "conversion of %s to %s", where, 3871 gfc_typename (rvalue), gfc_typename (lvalue)); 3872 3873 return false; 3874 } 3875 3876 /* Assignment is the only case where character variables of different 3877 kind values can be converted into one another. */ 3878 if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER) 3879 { 3880 if (lvalue->ts.kind != rvalue->ts.kind && allow_convert) 3881 return gfc_convert_chartype (rvalue, &lvalue->ts); 3882 else 3883 return true; 3884 } 3885 3886 if (!allow_convert) 3887 return true; 3888 3889 return gfc_convert_type (rvalue, &lvalue->ts, 1); 3890} 3891 3892 3893/* Check that a pointer assignment is OK. We first check lvalue, and 3894 we only check rvalue if it's not an assignment to NULL() or a 3895 NULLIFY statement. */ 3896 3897bool 3898gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue, 3899 bool suppress_type_test, bool is_init_expr) 3900{ 3901 symbol_attribute attr, lhs_attr; 3902 gfc_ref *ref; 3903 bool is_pure, is_implicit_pure, rank_remap; 3904 int proc_pointer; 3905 bool same_rank; 3906 3907 if (!lvalue->symtree) 3908 return false; 3909 3910 lhs_attr = gfc_expr_attr (lvalue); 3911 if (lvalue->ts.type == BT_UNKNOWN && !lhs_attr.proc_pointer) 3912 { 3913 gfc_error ("Pointer assignment target is not a POINTER at %L", 3914 &lvalue->where); 3915 return false; 3916 } 3917 3918 if (lhs_attr.flavor == FL_PROCEDURE && lhs_attr.use_assoc 3919 && !lhs_attr.proc_pointer) 3920 { 3921 gfc_error ("%qs in the pointer assignment at %L cannot be an " 3922 "l-value since it is a procedure", 3923 lvalue->symtree->n.sym->name, &lvalue->where); 3924 return false; 3925 } 3926 3927 proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer; 3928 3929 rank_remap = false; 3930 same_rank = lvalue->rank == rvalue->rank; 3931 for (ref = lvalue->ref; ref; ref = ref->next) 3932 { 3933 if (ref->type == REF_COMPONENT) 3934 proc_pointer = ref->u.c.component->attr.proc_pointer; 3935 3936 if (ref->type == REF_ARRAY && ref->next == NULL__null) 3937 { 3938 int dim; 3939 3940 if (ref->u.ar.type == AR_FULL) 3941 break; 3942 3943 if (ref->u.ar.type != AR_SECTION) 3944 { 3945 gfc_error ("Expected bounds specification for %qs at %L", 3946 lvalue->symtree->n.sym->name, &lvalue->where); 3947 return false; 3948 } 3949 3950 if (!gfc_notify_std (GFC_STD_F2003(1<<4), "Bounds specification " 3951 "for %qs in pointer assignment at %L", 3952 lvalue->symtree->n.sym->name, &lvalue->where)) 3953 return false; 3954 3955 /* Fortran standard (e.g. F2018, 10.2.2 Pointer assignment): 3956 * 3957 * (C1017) If bounds-spec-list is specified, the number of 3958 * bounds-specs shall equal the rank of data-pointer-object. 3959 * 3960 * If bounds-spec-list appears, it specifies the lower bounds. 3961 * 3962 * (C1018) If bounds-remapping-list is specified, the number of 3963 * bounds-remappings shall equal the rank of data-pointer-object. 3964 * 3965 * If bounds-remapping-list appears, it specifies the upper and 3966 * lower bounds of each dimension of the pointer; the pointer target 3967 * shall be simply contiguous or of rank one. 3968 * 3969 * (C1019) If bounds-remapping-list is not specified, the ranks of 3970 * data-pointer-object and data-target shall be the same. 3971 * 3972 * Thus when bounds are given, all lbounds are necessary and either 3973 * all or none of the upper bounds; no strides are allowed. If the 3974 * upper bounds are present, we may do rank remapping. */ 3975 for (dim = 0; dim < ref->u.ar.dimen; ++dim) 3976 { 3977 if (ref->u.ar.stride[dim]) 3978 { 3979 gfc_error ("Stride must not be present at %L", 3980 &lvalue->where); 3981 return false; 3982 } 3983 if (!same_rank && (!ref->u.ar.start[dim] ||!ref->u.ar.end[dim])) 3984 { 3985 gfc_error ("Rank remapping requires a " 3986 "list of %<lower-bound : upper-bound%> " 3987 "specifications at %L", &lvalue->where); 3988 return false; 3989 } 3990 if (!ref->u.ar.start[dim] 3991 || ref->u.ar.dimen_type[dim] != DIMEN_RANGE) 3992 { 3993 gfc_error ("Expected list of %<lower-bound :%> or " 3994 "list of %<lower-bound : upper-bound%> " 3995 "specifications at %L", &lvalue->where); 3996 return false; 3997 } 3998 3999 if (dim == 0) 4000 rank_remap = (ref->u.ar.end[dim] != NULL__null); 4001 else 4002 { 4003 if ((rank_remap && !ref->u.ar.end[dim])) 4004 { 4005 gfc_error ("Rank remapping requires a " 4006 "list of %<lower-bound : upper-bound%> " 4007 "specifications at %L", &lvalue->where); 4008 return false; 4009 } 4010 if (!rank_remap && ref->u.ar.end[dim]) 4011 { 4012 gfc_error ("Expected list of %<lower-bound :%> or " 4013 "list of %<lower-bound : upper-bound%> " 4014 "specifications at %L", &lvalue->where); 4015 return false; 4016 } 4017 } 4018 } 4019 } 4020 } 4021 4022 is_pure = gfc_pure (NULL__null); 4023 is_implicit_pure = gfc_implicit_pure (NULL__null); 4024 4025 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type, 4026 kind, etc for lvalue and rvalue must match, and rvalue must be a 4027 pure variable if we're in a pure function. */ 4028 if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN) 4029 return true; 4030 4031 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */ 4032 if (lvalue->expr_type == EXPR_VARIABLE 4033 && gfc_is_coindexed (lvalue)) 4034 { 4035 gfc_ref *ref; 4036 for (ref = lvalue->ref; ref; ref = ref->next) 4037 if (ref->type == REF_ARRAY && ref->u.ar.codimen) 4038 { 4039 gfc_error ("Pointer object at %L shall not have a coindex", 4040 &lvalue->where); 4041 return false; 4042 } 4043 } 4044 4045 /* Checks on rvalue for procedure pointer assignments. */ 4046 if (proc_pointer) 4047 { 4048 char err[200]; 4049 gfc_symbol *s1,*s2; 4050 gfc_component *comp1, *comp2; 4051 const char *name; 4052 4053 attr = gfc_expr_attr (rvalue); 4054 if (!((rvalue->expr_type == EXPR_NULL) 4055 || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer) 4056 || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer) 4057 || (rvalue->expr_type == EXPR_VARIABLE 4058 && attr.flavor == FL_PROCEDURE))) 4059 { 4060 gfc_error ("Invalid procedure pointer assignment at %L", 4061 &rvalue->where); 4062 return false; 4063 } 4064 4065 if (rvalue->expr_type == EXPR_VARIABLE && !attr.proc_pointer) 4066 { 4067 /* Check for intrinsics. */ 4068 gfc_symbol *sym = rvalue->symtree->n.sym; 4069 if (!sym->attr.intrinsic 4070 && (gfc_is_intrinsic (sym, 0, sym->declared_at) 4071 || gfc_is_intrinsic (sym, 1, sym->declared_at))) 4072 { 4073 sym->attr.intrinsic = 1; 4074 gfc_resolve_intrinsic (sym, &rvalue->where); 4075 attr = gfc_expr_attr (rvalue); 4076 } 4077 /* Check for result of embracing function. */ 4078 if (sym->attr.function && sym->result == sym) 4079 { 4080 gfc_namespace *ns; 4081 4082 for (ns = gfc_current_ns; ns; ns = ns->parent) 4083 if (sym == ns->proc_name) 4084 { 4085 gfc_error ("Function result %qs is invalid as proc-target " 4086 "in procedure pointer assignment at %L", 4087 sym->name, &rvalue->where); 4088 return false; 4089 } 4090 } 4091 } 4092 if (attr.abstract) 4093 { 4094 gfc_error ("Abstract interface %qs is invalid " 4095 "in procedure pointer assignment at %L", 4096 rvalue->symtree->name, &rvalue->where); 4097 return false; 4098 } 4099 /* Check for F08:C729. */ 4100 if (attr.flavor == FL_PROCEDURE) 4101 { 4102 if (attr.proc == PROC_ST_FUNCTION) 4103 { 4104 gfc_error ("Statement function %qs is invalid " 4105 "in procedure pointer assignment at %L", 4106 rvalue->symtree->name, &rvalue->where); 4107 return false; 4108 } 4109 if (attr.proc == PROC_INTERNAL && 4110 !gfc_notify_std(GFC_STD_F2008(1<<7), "Internal procedure %qs " 4111 "is invalid in procedure pointer assignment " 4112 "at %L", rvalue->symtree->name, &rvalue->where)) 4113 return false; 4114 if (attr.intrinsic && gfc_intrinsic_actual_ok (rvalue->symtree->name, 4115 attr.subroutine) == 0) 4116 { 4117 gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer " 4118 "assignment", rvalue->symtree->name, &rvalue->where); 4119 return false; 4120 } 4121 } 4122 /* Check for F08:C730. */ 4123 if (attr.elemental && !attr.intrinsic) 4124 { 4125 gfc_error ("Nonintrinsic elemental procedure %qs is invalid " 4126 "in procedure pointer assignment at %L", 4127 rvalue->symtree->name, &rvalue->where); 4128 return false; 4129 } 4130 4131 /* Ensure that the calling convention is the same. As other attributes 4132 such as DLLEXPORT may differ, one explicitly only tests for the 4133 calling conventions. */ 4134 if (rvalue->expr_type == EXPR_VARIABLE 4135 && lvalue->symtree->n.sym->attr.ext_attr 4136 != rvalue->symtree->n.sym->attr.ext_attr) 4137 { 4138 symbol_attribute calls; 4139 4140 calls.ext_attr = 0; 4141 gfc_add_ext_attribute (&calls, EXT_ATTR_CDECL, NULL__null); 4142 gfc_add_ext_attribute (&calls, EXT_ATTR_STDCALL, NULL__null); 4143 gfc_add_ext_attribute (&calls, EXT_ATTR_FASTCALL, NULL__null); 4144 4145 if ((calls.ext_attr & lvalue->symtree->n.sym->attr.ext_attr) 4146 != (calls.ext_attr & rvalue->symtree->n.sym->attr.ext_attr)) 4147 { 4148 gfc_error ("Mismatch in the procedure pointer assignment " 4149 "at %L: mismatch in the calling convention", 4150 &rvalue->where); 4151 return false; 4152 } 4153 } 4154 4155 comp1 = gfc_get_proc_ptr_comp (lvalue); 4156 if (comp1) 4157 s1 = comp1->ts.interface; 4158 else 4159 { 4160 s1 = lvalue->symtree->n.sym; 4161 if (s1->ts.interface) 4162 s1 = s1->ts.interface; 4163 } 4164 4165 comp2 = gfc_get_proc_ptr_comp (rvalue); 4166 if (comp2) 4167 { 4168 if (rvalue->expr_type == EXPR_FUNCTION) 4169 { 4170 s2 = comp2->ts.interface->result; 4171 name = s2->name; 4172 } 4173 else 4174 { 4175 s2 = comp2->ts.interface; 4176 name = comp2->name; 4177 } 4178 } 4179 else if (rvalue->expr_type == EXPR_FUNCTION) 4180 { 4181 if (rvalue->value.function.esym) 4182 s2 = rvalue->value.function.esym->result; 4183 else 4184 s2 = rvalue->symtree->n.sym->result; 4185 4186 name = s2->name; 4187 } 4188 else 4189 { 4190 s2 = rvalue->symtree->n.sym; 4191 name = s2->name; 4192 } 4193 4194 if (s2 && s2->attr.proc_pointer && s2->ts.interface) 4195 s2 = s2->ts.interface; 4196 4197 /* Special check for the case of absent interface on the lvalue. 4198 * All other interface checks are done below. */ 4199 if (!s1 && comp1 && comp1->attr.subroutine && s2 && s2->attr.function) 4200 { 4201 gfc_error ("Interface mismatch in procedure pointer assignment " 4202 "at %L: %qs is not a subroutine", &rvalue->where, name); 4203 return false; 4204 } 4205 4206 /* F08:7.2.2.4 (4) */ 4207 if (s2 && gfc_explicit_interface_required (s2, err, sizeof(err))) 4208 { 4209 if (comp1 && !s1) 4210 { 4211 gfc_error ("Explicit interface required for component %qs at %L: %s", 4212 comp1->name, &lvalue->where, err); 4213 return false; 4214 } 4215 else if (s1->attr.if_source == IFSRC_UNKNOWN) 4216 { 4217 gfc_error ("Explicit interface required for %qs at %L: %s", 4218 s1->name, &lvalue->where, err); 4219 return false; 4220 } 4221 } 4222 if (s1 && gfc_explicit_interface_required (s1, err, sizeof(err))) 4223 { 4224 if (comp2 && !s2) 4225 { 4226 gfc_error ("Explicit interface required for component %qs at %L: %s", 4227 comp2->name, &rvalue->where, err); 4228 return false; 4229 } 4230 else if (s2->attr.if_source == IFSRC_UNKNOWN) 4231 { 4232 gfc_error ("Explicit interface required for %qs at %L: %s", 4233 s2->name, &rvalue->where, err); 4234 return false; 4235 } 4236 } 4237 4238 if (s1 == s2 || !s1 || !s2) 4239 return true; 4240 4241 if (!gfc_compare_interfaces (s1, s2, name, 0, 1, 4242 err, sizeof(err), NULL__null, NULL__null)) 4243 { 4244 gfc_error ("Interface mismatch in procedure pointer assignment " 4245 "at %L: %s", &rvalue->where, err); 4246 return false; 4247 } 4248 4249 /* Check F2008Cor2, C729. */ 4250 if (!s2->attr.intrinsic && s2->attr.if_source == IFSRC_UNKNOWN 4251 && !s2->attr.external && !s2->attr.subroutine && !s2->attr.function) 4252 { 4253 gfc_error ("Procedure pointer target %qs at %L must be either an " 4254 "intrinsic, host or use associated, referenced or have " 4255 "the EXTERNAL attribute", s2->name, &rvalue->where); 4256 return false; 4257 } 4258 4259 return true; 4260 } 4261 else 4262 { 4263 /* A non-proc pointer cannot point to a constant. */ 4264 if (rvalue->expr_type == EXPR_CONSTANT) 4265 { 4266 gfc_error_now ("Pointer assignment target cannot be a constant at %L", 4267 &rvalue->where); 4268 return false; 4269 } 4270 } 4271 4272 if (!gfc_compare_types (&lvalue->ts, &rvalue->ts)) 4273 { 4274 /* Check for F03:C717. */ 4275 if (UNLIMITED_POLY (rvalue)(rvalue != __null && rvalue->ts.type == BT_CLASS &&
rvalue->ts.u.derived->components && rvalue->
ts.u.derived->components->ts.u.derived && rvalue
->ts.u.derived->components->ts.u.derived->attr.unlimited_polymorphic
) 4276 && !(UNLIMITED_POLY (lvalue)(lvalue != __null && lvalue->ts.type == BT_CLASS &&
lvalue->ts.u.derived->components && lvalue->
ts.u.derived->components->ts.u.derived && lvalue
->ts.u.derived->components->ts.u.derived->attr.unlimited_polymorphic
) 4277 || (lvalue->ts.type == BT_DERIVED 4278 && (lvalue->ts.u.derived->attr.is_bind_c 4279 || lvalue->ts.u.derived->attr.sequence)))) 4280 gfc_error ("Data-pointer-object at %L must be unlimited " 4281 "polymorphic, or of a type with the BIND or SEQUENCE " 4282 "attribute, to be compatible with an unlimited " 4283 "polymorphic target", &lvalue->where); 4284 else if (!suppress_type_test) 4285 gfc_error ("Different types in pointer assignment at %L; " 4286 "attempted assignment of %s to %s", &lvalue->where, 4287 gfc_typename (rvalue), gfc_typename (lvalue)); 4288 return false; 4289 } 4290 4291 if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind) 4292 { 4293 gfc_error ("Different kind type parameters in pointer " 4294 "assignment at %L", &lvalue->where); 4295 return false; 4296 } 4297 4298 if (lvalue->rank != rvalue->rank && !rank_remap) 4299 { 4300 gfc_error ("Different ranks in pointer assignment at %L", &lvalue->where); 4301 return false; 4302 } 4303 4304 /* Make sure the vtab is present. */ 4305 if (lvalue->ts.type == BT_CLASS && !UNLIMITED_POLY (rvalue)(rvalue != __null && rvalue->ts.type == BT_CLASS &&
rvalue->ts.u.derived->components && rvalue->
ts.u.derived->components->ts.u.derived && rvalue
->ts.u.derived->components->ts.u.derived->attr.unlimited_polymorphic
)) 4306 gfc_find_vtab (&rvalue->ts); 4307 4308 /* Check rank remapping. */ 4309 if (rank_remap) 4310 { 4311 mpz_t lsize, rsize; 4312 4313 /* If this can be determined, check that the target must be at least as 4314 large as the pointer assigned to it is. */ 4315 if (gfc_array_size (lvalue, &lsize) 4316 && gfc_array_size (rvalue, &rsize) 4317 && mpz_cmp__gmpz_cmp (rsize, lsize) < 0) 4318 { 4319 gfc_error ("Rank remapping target is smaller than size of the" 4320 " pointer (%ld < %ld) at %L", 4321 mpz_get_si__gmpz_get_si (rsize), mpz_get_si__gmpz_get_si (lsize), 4322 &lvalue->where); 4323 return false; 4324 } 4325 4326 /* The target must be either rank one or it must be simply contiguous 4327 and F2008 must be allowed. */ 4328 if (rvalue->rank != 1) 4329 { 4330 if (!gfc_is_simply_contiguous (rvalue, true, false)) 4331 { 4332 gfc_error ("Rank remapping target must be rank 1 or" 4333 " simply contiguous at %L", &rvalue->where); 4334 return false; 4335 } 4336 if (!gfc_notify_std (GFC_STD_F2008(1<<7), "Rank remapping target is not " 4337 "rank 1 at %L", &rvalue->where)) 4338 return false; 4339 } 4340 } 4341 4342 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */ 4343 if (rvalue->expr_type == EXPR_NULL) 4344 return true; 4345 4346 if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue)) 4347 lvalue->symtree->n.sym->attr.subref_array_pointer = 1; 4348 4349 attr = gfc_expr_attr (rvalue); 4350 4351 if (rvalue->expr_type == EXPR_FUNCTION && !attr.pointer) 4352 { 4353 /* F2008, C725. For PURE also C1283. Sometimes rvalue is a function call 4354 to caf_get. Map this to the same error message as below when it is 4355 still a variable expression. */ 4356 if (rvalue->value.function.isym 4357 && rvalue->value.function.isym->id == GFC_ISYM_CAF_GET) 4358 /* The test above might need to be extend when F08, Note 5.4 has to be 4359 interpreted in the way that target and pointer with the same coindex 4360 are allowed. */ 4361 gfc_error ("Data target at %L shall not have a coindex", 4362 &rvalue->where); 4363 else 4364 gfc_error ("Target expression in pointer assignment " 4365 "at %L must deliver a pointer result", 4366 &rvalue->where); 4367 return false; 4368 } 4369 4370 if (is_init_expr) 4371 { 4372 gfc_symbol *sym; 4373 bool target; 4374 gfc_ref *ref; 4375 4376 if (gfc_is_size_zero_array (rvalue)) 4377 { 4378 gfc_error ("Zero-sized array detected at %L where an entity with " 4379 "the TARGET attribute is expected", &rvalue->where); 4380 return false; 4381 } 4382 else if (!rvalue->symtree) 4383 { 4384 gfc_error ("Pointer assignment target in initialization expression " 4385 "does not have the TARGET attribute at %L", 4386 &rvalue->where); 4387 return false; 4388 } 4389 4390 sym = rvalue->symtree->n.sym; 4391 4392 if (sym->ts.type == BT_CLASS && sym->attr.class_ok) 4393 target = CLASS_DATA (sym)sym->ts.u.derived->components->attr.target; 4394 else 4395 target = sym->attr.target; 4396 4397 if (!target && !proc_pointer) 4398 { 4399 gfc_error ("Pointer assignment target in initialization expression " 4400 "does not have the TARGET attribute at %L", 4401 &rvalue->where); 4402 return false; 4403 } 4404 4405 for (ref = rvalue->ref; ref; ref = ref->next) 4406 { 4407 switch (ref->type) 4408 { 4409 case REF_ARRAY: 4410 for (int n = 0; n < ref->u.ar.dimen; n++) 4411 if (!gfc_is_constant_expr (ref->u.ar.start[n]) 4412 || !gfc_is_constant_expr (ref->u.ar.end[n]) 4413 || !gfc_is_constant_expr (ref->u.ar.stride[n])) 4414 { 4415 gfc_error ("Every subscript of target specification " 4416 "at %L must be a constant expression", 4417 &ref->u.ar.where); 4418 return false; 4419 } 4420 break; 4421 4422 case REF_SUBSTRING: 4423 if (!gfc_is_constant_expr (ref->u.ss.start) 4424 || !gfc_is_constant_expr (ref->u.ss.end)) 4425 { 4426 gfc_error ("Substring starting and ending points of target " 4427 "specification at %L must be constant expressions", 4428 &ref->u.ss.start->where); 4429 return false; 4430 } 4431 break; 4432 4433 default: 4434 break; 4435 } 4436 } 4437 } 4438 else 4439 { 4440 if (!attr.target && !attr.pointer) 4441 { 4442 gfc_error ("Pointer assignment target is neither TARGET " 4443 "nor POINTER at %L", &rvalue->where); 4444 return false; 4445 } 4446 } 4447 4448 if (lvalue->ts.type == BT_CHARACTER) 4449 { 4450 bool t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment"); 4451 if (!t) 4452 return false; 4453 } 4454 4455 if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym)) 4456 { 4457 gfc_error ("Bad target in pointer assignment in PURE " 4458 "procedure at %L", &rvalue->where); 4459 } 4460 4461 if (is_implicit_pure && gfc_impure_variable (rvalue->symtree->n.sym)) 4462 gfc_unset_implicit_pure (gfc_current_ns->proc_name); 4463 4464 if (gfc_has_vector_index (rvalue)) 4465 { 4466 gfc_error ("Pointer assignment with vector subscript " 4467 "on rhs at %L", &rvalue->where); 4468 return false; 4469 } 4470 4471 if (attr.is_protected && attr.use_assoc 4472 && !(attr.pointer || attr.proc_pointer)) 4473 { 4474 gfc_error ("Pointer assignment target has PROTECTED " 4475 "attribute at %L", &rvalue->where); 4476 return false; 4477 } 4478 4479 /* F2008, C725. For PURE also C1283. */ 4480 if (rvalue->expr_type == EXPR_VARIABLE 4481 && gfc_is_coindexed (rvalue)) 4482 { 4483 gfc_ref *ref; 4484 for (ref = rvalue->ref; ref; ref = ref->next) 4485 if (ref->type == REF_ARRAY && ref->u.ar.codimen) 4486 { 4487 gfc_error ("Data target at %L shall not have a coindex", 4488 &rvalue->where); 4489 return false; 4490 } 4491 } 4492 4493 /* Warn for assignments of contiguous pointers to targets which is not 4494 contiguous. Be lenient in the definition of what counts as 4495 contiguous. */ 4496 4497 if (lhs_attr.contiguous 4498 && lhs_attr.dimension > 0) 4499 { 4500 if (gfc_is_not_contiguous (rvalue)) 4501 { 4502 gfc_error ("Assignment to contiguous pointer from " 4503 "non-contiguous target at %L", &rvalue->where); 4504 return false; 4505 } 4506 if (!gfc_is_simply_contiguous (rvalue, false, true)) 4507 gfc_warning (OPT_Wextra, "Assignment to contiguous pointer from " 4508 "non-contiguous target at %L", &rvalue->where); 4509 } 4510 4511 /* Warn if it is the LHS pointer may lives longer than the RHS target. */ 4512 if (warn_target_lifetimeglobal_options.x_warn_target_lifetime 4513 && rvalue->expr_type == EXPR_VARIABLE 4514 && !rvalue->symtree->n.sym->attr.save 4515 && !rvalue->symtree->n.sym->attr.pointer && !attr.pointer 4516 && !rvalue->symtree->n.sym->attr.host_assoc 4517 && !rvalue->symtree->n.sym->attr.in_common 4518 && !rvalue->symtree->n.sym->attr.use_assoc 4519 && !rvalue->symtree->n.sym->attr.dummy) 4520 { 4521 bool warn; 4522 gfc_namespace *ns; 4523 4524 warn = lvalue->symtree->n.sym->attr.dummy 4525 || lvalue->symtree->n.sym->attr.result 4526 || lvalue->symtree->n.sym->attr.function 4527 || (lvalue->symtree->n.sym->attr.host_assoc 4528 && lvalue->symtree->n.sym->ns 4529 != rvalue->symtree->n.sym->ns) 4530 || lvalue->symtree->n.sym->attr.use_assoc 4531 || lvalue->symtree->n.sym->attr.in_common; 4532 4533 if (rvalue->symtree->n.sym->ns->proc_name 4534 && rvalue->symtree->n.sym->ns->proc_name->attr.flavor != FL_PROCEDURE 4535 && rvalue->symtree->n.sym->ns->proc_name->attr.flavor != FL_PROGRAM) 4536 for (ns = rvalue->symtree->n.sym->ns; 4537 ns && ns->proc_name && ns->proc_name->attr.flavor != FL_PROCEDURE; 4538 ns = ns->parent) 4539 if (ns->parent == lvalue->symtree->n.sym->ns) 4540 { 4541 warn = true; 4542 break; 4543 } 4544 4545 if (warn) 4546 gfc_warning (OPT_Wtarget_lifetime, 4547 "Pointer at %L in pointer assignment might outlive the " 4548 "pointer target", &lvalue->where); 4549 } 4550 4551 return true; 4552} 4553 4554 4555/* Relative of gfc_check_assign() except that the lvalue is a single 4556 symbol. Used for initialization assignments. */ 4557 4558bool 4559gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue) 4560{ 4561 gfc_expr lvalue; 4562 bool r; 4563 bool pointer, proc_pointer; 4564 4565 memset (&lvalue, '\0', sizeof (gfc_expr)); 4566 4567 lvalue.expr_type = EXPR_VARIABLE; 4568 lvalue.ts = sym->ts; 4569 if (sym->as)

Assuming field 'as' is null

→

←

Taking false branch

→

4570 lvalue.rank = sym->as->rank; 4571 lvalue.symtree = XCNEW (gfc_symtree)((gfc_symtree *) xcalloc (1, sizeof (gfc_symtree))); 4572 lvalue.symtree->n.sym = sym; 4573 lvalue.where = sym->declared_at; 4574 4575 if (comp)

←

Assuming 'comp' is null

→

4576 { 4577 lvalue.ref = gfc_get_ref ()((gfc_ref *) xcalloc (1, sizeof (gfc_ref))); 4578 lvalue.ref->type = REF_COMPONENT; 4579 lvalue.ref->u.c.component = comp; 4580 lvalue.ref->u.c.sym = sym; 4581 lvalue.ts = comp->ts; 4582 lvalue.rank = comp->as ? comp->as->rank : 0; 4583 lvalue.where = comp->loc; 4584 pointer = comp->ts.type == BT_CLASS && CLASS_DATA (comp)comp->ts.u.derived->components 4585 ? CLASS_DATA (comp)comp->ts.u.derived->components->attr.class_pointer : comp->attr.pointer; 4586 proc_pointer = comp->attr.proc_pointer; 4587 } 4588 else 4589 { 4590 pointer = sym->ts.type == BT_CLASS && CLASS_DATA (sym)sym->ts.u.derived->components

←

Assuming field 'type' is not equal to BT_CLASS

→

4591 ? CLASS_DATA (sym)sym->ts.u.derived->components->attr.class_pointer : sym->attr.pointer; 4592 proc_pointer = sym->attr.proc_pointer; 4593 } 4594 4595 if (pointer || proc_pointer)

←

Assuming 'pointer' is false

→

←

Assuming 'proc_pointer' is false

→

4596 r = gfc_check_pointer_assign (&lvalue, rvalue, false, true); 4597 else 4598 { 4599 /* If a conversion function, e.g., __convert_i8_i4, was inserted 4600 into an array constructor, we should check if it can be reduced 4601 as an initialization expression. */ 4602 if (rvalue->expr_type == EXPR_FUNCTION

←

Assuming field 'expr_type' is equal to EXPR_FUNCTION

→

←

Taking true branch

→

4603 && rvalue->value.function.isym

←

Assuming field 'isym' is non-null

→

4604 && (rvalue->value.function.isym->conversion == 1))

←

Assuming field 'conversion' is equal to 1

→

4605 gfc_check_init_expr (rvalue);

←

Calling 'gfc_check_init_expr'

→

4606 4607 r = gfc_check_assign (&lvalue, rvalue, 1); 4608 } 4609 4610 free (lvalue.symtree); 4611 free (lvalue.ref); 4612 4613 if (!r) 4614 return r; 4615 4616 if (pointer && rvalue->expr_type != EXPR_NULL && !proc_pointer) 4617 { 4618 /* F08:C461. Additional checks for pointer initialization. */ 4619 symbol_attribute attr; 4620 attr = gfc_expr_attr (rvalue); 4621 if (attr.allocatable) 4622 { 4623 gfc_error ("Pointer initialization target at %L " 4624 "must not be ALLOCATABLE", &rvalue->where); 4625 return false; 4626 } 4627 if (!attr.target || attr.pointer) 4628 { 4629 gfc_error ("Pointer initialization target at %L " 4630 "must have the TARGET attribute", &rvalue->where); 4631 return false; 4632 } 4633 4634 if (!attr.save && rvalue->expr_type == EXPR_VARIABLE 4635 && rvalue->symtree->n.sym->ns->proc_name 4636 && rvalue->symtree->n.sym->ns->proc_name->attr.is_main_program) 4637 { 4638 rvalue->symtree->n.sym->ns->proc_name->attr.save = SAVE_IMPLICIT; 4639 attr.save = SAVE_IMPLICIT; 4640 } 4641 4642 if (!attr.save) 4643 { 4644 gfc_error ("Pointer initialization target at %L " 4645 "must have the SAVE attribute", &rvalue->where); 4646 return false; 4647 } 4648 } 4649 4650 if (proc_pointer && rvalue->expr_type != EXPR_NULL) 4651 { 4652 /* F08:C1220. Additional checks for procedure pointer initialization. */ 4653 symbol_attribute attr = gfc_expr_attr (rvalue); 4654 if (attr.proc_pointer) 4655 { 4656 gfc_error ("Procedure pointer initialization target at %L " 4657 "may not be a procedure pointer", &rvalue->where); 4658 return false; 4659 } 4660 if (attr.proc == PROC_INTERNAL) 4661 { 4662 gfc_error ("Internal procedure %qs is invalid in " 4663 "procedure pointer initialization at %L", 4664 rvalue->symtree->name, &rvalue->where); 4665 return false; 4666 } 4667 if (attr.dummy) 4668 { 4669 gfc_error ("Dummy procedure %qs is invalid in " 4670 "procedure pointer initialization at %L", 4671 rvalue->symtree->name, &rvalue->where); 4672 return false; 4673 } 4674 } 4675 4676 return true; 4677} 4678 4679/* Build an initializer for a local integer, real, complex, logical, or 4680 character variable, based on the command line flags finit-local-zero, 4681 finit-integer=, finit-real=, finit-logical=, and finit-character=. 4682 With force, an initializer is ALWAYS generated. */ 4683 4684static gfc_expr * 4685gfc_build_init_expr (gfc_typespec *ts, locus *where, bool force) 4686{ 4687 gfc_expr *init_expr; 4688 4689 /* Try to build an initializer expression. */ 4690 init_expr = gfc_get_constant_expr (ts->type, ts->kind, where); 4691 4692 /* If we want to force generation, make sure we default to zero. */ 4693 gfc_init_local_real init_real = flag_init_realglobal_options.x_flag_init_real; 4694 int init_logical = gfc_option.flag_init_logical; 4695 if (force) 4696 { 4697 if (init_real == GFC_INIT_REAL_OFF) 4698 init_real = GFC_INIT_REAL_ZERO; 4699 if (init_logical == GFC_INIT_LOGICAL_OFF) 4700 init_logical = GFC_INIT_LOGICAL_FALSE; 4701 } 4702 4703 /* We will only initialize integers, reals, complex, logicals, and 4704 characters, and only if the corresponding command-line flags 4705 were set. Otherwise, we free init_expr and return null. */ 4706 switch (ts->type) 4707 { 4708 case BT_INTEGER: 4709 if (force || gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF) 4710 mpz_set_si__gmpz_set_si (init_expr->value.integer, 4711 gfc_option.flag_init_integer_value); 4712 else 4713 { 4714 gfc_free_expr (init_expr); 4715 init_expr = NULL__null; 4716 } 4717 break; 4718 4719 case BT_REAL: 4720 switch (init_real) 4721 { 4722 case GFC_INIT_REAL_SNAN: 4723 init_expr->is_snan = 1; 4724 /* Fall through. */ 4725 case GFC_INIT_REAL_NAN: 4726 mpfr_set_nan (init_expr->value.real); 4727 break; 4728 4729 case GFC_INIT_REAL_INF: 4730 mpfr_set_inf (init_expr->value.real, 1); 4731 break; 4732 4733 case GFC_INIT_REAL_NEG_INF: 4734 mpfr_set_inf (init_expr->value.real, -1); 4735 break; 4736 4737 case GFC_INIT_REAL_ZERO: 4738 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODEMPFR_RNDN); 4739 break; 4740 4741 default: 4742 gfc_free_expr (init_expr); 4743 init_expr = NULL__null; 4744 break; 4745 } 4746 break; 4747 4748 case BT_COMPLEX: 4749 switch (init_real) 4750 { 4751 case GFC_INIT_REAL_SNAN: 4752 init_expr->is_snan = 1; 4753 /* Fall through. */ 4754 case GFC_INIT_REAL_NAN: 4755 mpfr_set_nan (mpc_realref (init_expr->value.complex)((init_expr->value.complex)->re)); 4756 mpfr_set_nan (mpc_imagref (init_expr->value.complex)((init_expr->value.complex)->im)); 4757 break; 4758 4759 case GFC_INIT_REAL_INF: 4760 mpfr_set_inf (mpc_realref (init_expr->value.complex)((init_expr->value.complex)->re), 1); 4761 mpfr_set_inf (mpc_imagref (init_expr->value.complex)((init_expr->value.complex)->im), 1); 4762 break; 4763 4764 case GFC_INIT_REAL_NEG_INF: 4765 mpfr_set_inf (mpc_realref (init_expr->value.complex)((init_expr->value.complex)->re), -1); 4766 mpfr_set_inf (mpc_imagref (init_expr->value.complex)((init_expr->value.complex)->im), -1); 4767 break; 4768 4769 case GFC_INIT_REAL_ZERO: 4770 mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4))); 4771 break; 4772 4773 default: 4774 gfc_free_expr (init_expr); 4775 init_expr = NULL__null; 4776 break; 4777 } 4778 break; 4779 4780 case BT_LOGICAL: 4781 if (init_logical == GFC_INIT_LOGICAL_FALSE) 4782 init_expr->value.logical = 0; 4783 else if (init_logical == GFC_INIT_LOGICAL_TRUE) 4784 init_expr->value.logical = 1; 4785 else 4786 { 4787 gfc_free_expr (init_expr); 4788 init_expr = NULL__null; 4789 } 4790 break; 4791 4792 case BT_CHARACTER: 4793 /* For characters, the length must be constant in order to 4794 create a default initializer. */ 4795 if ((force || gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON) 4796 && ts->u.cl->length 4797 && ts->u.cl->length->expr_type == EXPR_CONSTANT) 4798 { 4799 HOST_WIDE_INTlong char_len = gfc_mpz_get_hwi (ts->u.cl->length->value.integer); 4800 init_expr->value.character.length = char_len; 4801 init_expr->value.character.string = gfc_get_wide_string (char_len+1)((gfc_char_t *) xcalloc ((char_len+1), sizeof (gfc_char_t))); 4802 for (size_t i = 0; i < (size_t) char_len; i++) 4803 init_expr->value.character.string[i] 4804 = (unsigned char) gfc_option.flag_init_character_value; 4805 } 4806 else 4807 { 4808 gfc_free_expr (init_expr); 4809 init_expr = NULL__null; 4810 } 4811 if (!init_expr 4812 && (force || gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON) 4813 && ts->u.cl->length && flag_max_stack_var_sizeglobal_options.x_flag_max_stack_var_size != 0) 4814 { 4815 gfc_actual_arglist *arg; 4816 init_expr = gfc_get_expr (); 4817 init_expr->where = *where; 4818 init_expr->ts = *ts; 4819 init_expr->expr_type = EXPR_FUNCTION; 4820 init_expr->value.function.isym = 4821 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT); 4822 init_expr->value.function.name = "repeat"; 4823 arg = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
))); 4824 arg->expr = gfc_get_character_expr (ts->kind, where, NULL__null, 1); 4825 arg->expr->value.character.string[0] = 4826 gfc_option.flag_init_character_value; 4827 arg->next = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
))); 4828 arg->next->expr = gfc_copy_expr (ts->u.cl->length); 4829 init_expr->value.function.actual = arg; 4830 } 4831 break; 4832 4833 default: 4834 gfc_free_expr (init_expr); 4835 init_expr = NULL__null; 4836 } 4837 4838 return init_expr; 4839} 4840 4841/* Invoke gfc_build_init_expr to create an initializer expression, but do not 4842 * require that an expression be built. */ 4843 4844gfc_expr * 4845gfc_build_default_init_expr (gfc_typespec *ts, locus *where) 4846{ 4847 return gfc_build_init_expr (ts, where, false); 4848} 4849 4850/* Apply an initialization expression to a typespec. Can be used for symbols or 4851 components. Similar to add_init_expr_to_sym in decl.cc; could probably be 4852 combined with some effort. */ 4853 4854void 4855gfc_apply_init (gfc_typespec *ts, symbol_attribute *attr, gfc_expr *init) 4856{ 4857 if (ts->type == BT_CHARACTER && !attr->pointer && init 4858 && ts->u.cl 4859 && ts->u.cl->length 4860 && ts->u.cl->length->expr_type == EXPR_CONSTANT 4861 && ts->u.cl->length->ts.type == BT_INTEGER) 4862 { 4863 HOST_WIDE_INTlong len = gfc_mpz_get_hwi (ts->u.cl->length->value.integer); 4864 4865 if (init->expr_type == EXPR_CONSTANT) 4866 gfc_set_constant_character_len (len, init, -1); 4867 else if (init 4868 && init->ts.type == BT_CHARACTER 4869 && init->ts.u.cl && init->ts.u.cl->length 4870 && mpz_cmp__gmpz_cmp (ts->u.cl->length->value.integer, 4871 init->ts.u.cl->length->value.integer)) 4872 { 4873 gfc_constructor *ctor; 4874 ctor = gfc_constructor_first (init->value.constructor); 4875 4876 if (ctor) 4877 { 4878 bool has_ts = (init->ts.u.cl 4879 && init->ts.u.cl->length_from_typespec); 4880 4881 /* Remember the length of the first element for checking 4882 that all elements *in the constructor* have the same 4883 length. This need not be the length of the LHS! */ 4884 gcc_assert (ctor->expr->expr_type == EXPR_CONSTANT)((void)(!(ctor->expr->expr_type == EXPR_CONSTANT) ? fancy_abort
("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc"
, 4884, __FUNCTION__), 0 : 0)); 4885 gcc_assert (ctor->expr->ts.type == BT_CHARACTER)((void)(!(ctor->expr->ts.type == BT_CHARACTER) ? fancy_abort
("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc"
, 4885, __FUNCTION__), 0 : 0)); 4886 gfc_charlen_t first_len = ctor->expr->value.character.length; 4887 4888 for ( ; ctor; ctor = gfc_constructor_next (ctor)) 4889 if (ctor->expr->expr_type == EXPR_CONSTANT) 4890 { 4891 gfc_set_constant_character_len (len, ctor->expr, 4892 has_ts ? -1 : first_len); 4893 if (!ctor->expr->ts.u.cl) 4894 ctor->expr->ts.u.cl 4895 = gfc_new_charlen (gfc_current_ns, ts->u.cl); 4896 else 4897 ctor->expr->ts.u.cl->length 4898 = gfc_copy_expr (ts->u.cl->length); 4899 } 4900 } 4901 } 4902 } 4903} 4904 4905 4906/* Check whether an expression is a structure constructor and whether it has 4907 other values than NULL. */ 4908 4909static bool 4910is_non_empty_structure_constructor (gfc_expr * e) 4911{ 4912 if (e->expr_type != EXPR_STRUCTURE) 4913 return false; 4914 4915 gfc_constructor *cons = gfc_constructor_first (e->value.constructor); 4916 while (cons) 4917 { 4918 if (!cons->expr || cons->expr->expr_type != EXPR_NULL) 4919 return true; 4920 cons = gfc_constructor_next (cons); 4921 } 4922 return false; 4923} 4924 4925 4926/* Check for default initializer; sym->value is not enough 4927 as it is also set for EXPR_NULL of allocatables. */ 4928 4929bool 4930gfc_has_default_initializer (gfc_symbol *der) 4931{ 4932 gfc_component *c; 4933 4934 gcc_assert (gfc_fl_struct (der->attr.flavor))((void)(!(((der->attr.flavor) == FL_DERIVED || (der->attr
.flavor) == FL_UNION || (der->attr.flavor) == FL_STRUCT)) ?
fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc"
, 4934, __FUNCTION__), 0 : 0)); 4935 for (c = der->components; c; c = c->next) 4936 if (gfc_bt_struct (c->ts.type)((c->ts.type) == BT_DERIVED || (c->ts.type) == BT_UNION
)) 4937 { 4938 if (!c->attr.pointer && !c->attr.proc_pointer 4939 && !(c->attr.allocatable && der == c->ts.u.derived) 4940 && ((c->initializer 4941 && is_non_empty_structure_constructor (c->initializer)) 4942 || gfc_has_default_initializer (c->ts.u.derived))) 4943 return true; 4944 if (c->attr.pointer && c->initializer) 4945 return true; 4946 } 4947 else 4948 { 4949 if (c->initializer) 4950 return true; 4951 } 4952 4953 return false; 4954} 4955 4956 4957/* 4958 Generate an initializer expression which initializes the entirety of a union. 4959 A normal structure constructor is insufficient without undue effort, because 4960 components of maps may be oddly aligned/overlapped. (For example if a 4961 character is initialized from one map overtop a real from the other, only one 4962 byte of the real is actually initialized.) Unfortunately we don't know the 4963 size of the union right now, so we can't generate a proper initializer, but 4964 we use a NULL expr as a placeholder and do the right thing later in 4965 gfc_trans_subcomponent_assign. 4966 */ 4967static gfc_expr * 4968generate_union_initializer (gfc_component *un) 4969{ 4970 if (un == NULL__null || un->ts.type != BT_UNION) 4971 return NULL__null; 4972 4973 gfc_expr *placeholder = gfc_get_null_expr (&un->loc); 4974 placeholder->ts = un->ts; 4975 return placeholder; 4976} 4977 4978 4979/* Get the user-specified initializer for a union, if any. This means the user 4980 has said to initialize component(s) of a map. For simplicity's sake we 4981 only allow the user to initialize the first map. We don't have to worry 4982 about overlapping initializers as they are released early in resolution (see 4983 resolve_fl_struct). */ 4984 4985static gfc_expr * 4986get_union_initializer (gfc_symbol *union_type, gfc_component **map_p) 4987{ 4988 gfc_component *map; 4989 gfc_expr *init=NULL__null; 4990 4991 if (!union_type || union_type->attr.flavor != FL_UNION) 4992 return NULL__null; 4993 4994 for (map = union_type->components; map; map = map->next) 4995 { 4996 if (gfc_has_default_initializer (map->ts.u.derived)) 4997 { 4998 init = gfc_default_initializer (&map->ts); 4999 if (map_p) 5000 *map_p = map; 5001 break; 5002 } 5003 } 5004 5005 if (map_p && !init) 5006 *map_p = NULL__null; 5007 5008 return init; 5009} 5010 5011static bool 5012class_allocatable (gfc_component *comp) 5013{ 5014 return comp->ts.type == BT_CLASS && comp->attr.class_ok && CLASS_DATA (comp)comp->ts.u.derived->components 5015 && CLASS_DATA (comp)comp->ts.u.derived->components->attr.allocatable; 5016} 5017 5018static bool 5019class_pointer (gfc_component *comp) 5020{ 5021 return comp->ts.type == BT_CLASS && comp->attr.class_ok && CLASS_DATA (comp)comp->ts.u.derived->components 5022 && CLASS_DATA (comp)comp->ts.u.derived->components->attr.pointer; 5023} 5024 5025static bool 5026comp_allocatable (gfc_component *comp) 5027{ 5028 return comp->attr.allocatable || class_allocatable (comp); 5029} 5030 5031static bool 5032comp_pointer (gfc_component *comp) 5033{ 5034 return comp->attr.pointer 5035 || comp->attr.proc_pointer 5036 || comp->attr.class_pointer 5037 || class_pointer (comp); 5038} 5039 5040/* Fetch or generate an initializer for the given component. 5041 Only generate an initializer if generate is true. */ 5042 5043static gfc_expr * 5044component_initializer (gfc_component *c, bool generate) 5045{ 5046 gfc_expr *init = NULL__null; 5047 5048 /* Allocatable components always get EXPR_NULL. 5049 Pointer components are only initialized when generating, and only if they 5050 do not already have an initializer. */ 5051 if (comp_allocatable (c) || (generate && comp_pointer (c) && !c->initializer)) 5052 { 5053 init = gfc_get_null_expr (&c->loc); 5054 init->ts = c->ts; 5055 return init; 5056 } 5057 5058 /* See if we can find the initializer immediately. */ 5059 if (c->initializer || !generate) 5060 return c->initializer; 5061 5062 /* Recursively handle derived type components. */ 5063 else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) 5064 init = gfc_generate_initializer (&c->ts, true); 5065 5066 else if (c->ts.type == BT_UNION && c->ts.u.derived->components) 5067 { 5068 gfc_component *map = NULL__null; 5069 gfc_constructor *ctor; 5070 gfc_expr *user_init; 5071 5072 /* If we don't have a user initializer and we aren't generating one, this 5073 union has no initializer. */ 5074 user_init = get_union_initializer (c->ts.u.derived, &map); 5075 if (!user_init && !generate) 5076 return NULL__null; 5077 5078 /* Otherwise use a structure constructor. */ 5079 init = gfc_get_structure_constructor_expr (c->ts.type, c->ts.kind, 5080 &c->loc); 5081 init->ts = c->ts; 5082 5083 /* If we are to generate an initializer for the union, add a constructor 5084 which initializes the whole union first. */ 5085 if (generate) 5086 { 5087 ctor = gfc_constructor_get (); 5088 ctor->expr = generate_union_initializer (c); 5089 gfc_constructor_append (&init->value.constructor, ctor); 5090 } 5091 5092 /* If we found an initializer in one of our maps, apply it. Note this 5093 is applied _after_ the entire-union initializer above if any. */ 5094 if (user_init) 5095 { 5096 ctor = gfc_constructor_get (); 5097 ctor->expr = user_init; 5098 ctor->n.component = map; 5099 gfc_constructor_append (&init->value.constructor, ctor); 5100 } 5101 } 5102 5103 /* Treat simple components like locals. */ 5104 else 5105 { 5106 /* We MUST give an initializer, so force generation. */ 5107 init = gfc_build_init_expr (&c->ts, &c->loc, true); 5108 gfc_apply_init (&c->ts, &c->attr, init); 5109 } 5110 5111 return init; 5112} 5113 5114 5115/* Get an expression for a default initializer of a derived type. */ 5116 5117gfc_expr * 5118gfc_default_initializer (gfc_typespec *ts) 5119{ 5120 return gfc_generate_initializer (ts, false); 5121} 5122 5123/* Generate an initializer expression for an iso_c_binding type 5124 such as c_[fun]ptr. The appropriate initializer is c_null_[fun]ptr. */ 5125 5126static gfc_expr * 5127generate_isocbinding_initializer (gfc_symbol *derived) 5128{ 5129 /* The initializers have already been built into the c_null_[fun]ptr symbols 5130 from gen_special_c_interop_ptr. */ 5131 gfc_symtree *npsym = NULL__null; 5132 if (0 == strcmp (derived->name, "c_ptr")) 5133 gfc_find_sym_tree ("c_null_ptr", gfc_current_ns, true, &npsym); 5134 else if (0 == strcmp (derived->name, "c_funptr")) 5135 gfc_find_sym_tree ("c_null_funptr", gfc_current_ns, true, &npsym); 5136 else 5137 gfc_internal_error ("generate_isocbinding_initializer(): bad iso_c_binding" 5138 " type, expected %<c_ptr%> or %<c_funptr%>"); 5139 if (npsym) 5140 { 5141 gfc_expr *init = gfc_copy_expr (npsym->n.sym->value); 5142 init->symtree = npsym; 5143 init->ts.is_iso_c = true; 5144 return init; 5145 } 5146 5147 return NULL__null; 5148} 5149 5150/* Get or generate an expression for a default initializer of a derived type. 5151 If -finit-derived is specified, generate default initialization expressions 5152 for components that lack them when generate is set. */ 5153 5154gfc_expr * 5155gfc_generate_initializer (gfc_typespec *ts, bool generate) 5156{ 5157 gfc_expr *init, *tmp; 5158 gfc_component *comp; 5159 5160 generate = flag_init_derivedglobal_options.x_flag_init_derived && generate; 5161 5162 if (ts->u.derived->ts.is_iso_c && generate) 5163 return generate_isocbinding_initializer (ts->u.derived); 5164 5165 /* See if we have a default initializer in this, but not in nested 5166 types (otherwise we could use gfc_has_default_initializer()). 5167 We don't need to check if we are going to generate them. */ 5168 comp = ts->u.derived->components; 5169 if (!generate) 5170 { 5171 for (; comp; comp = comp->next) 5172 if (comp->initializer || comp_allocatable (comp)) 5173 break; 5174 } 5175 5176 if (!comp) 5177 return NULL__null; 5178 5179 init = gfc_get_structure_constructor_expr (ts->type, ts->kind, 5180 &ts->u.derived->declared_at); 5181 init->ts = *ts; 5182 5183 for (comp = ts->u.derived->components; comp; comp = comp->next) 5184 { 5185 gfc_constructor *ctor = gfc_constructor_get(); 5186 5187 /* Fetch or generate an initializer for the component. */ 5188 tmp = component_initializer (comp, generate); 5189 if (tmp) 5190 { 5191 /* Save the component ref for STRUCTUREs and UNIONs. */ 5192 if (ts->u.derived->attr.flavor == FL_STRUCT 5193 || ts->u.derived->attr.flavor == FL_UNION) 5194 ctor->n.component = comp; 5195 5196 /* If the initializer was not generated, we need a copy. */ 5197 ctor->expr = comp->initializer ? gfc_copy_expr (tmp) : tmp; 5198 if ((comp->ts.type != tmp->ts.type || comp->ts.kind != tmp->ts.kind) 5199 && !comp->attr.pointer && !comp->attr.proc_pointer) 5200 { 5201 bool val; 5202 val = gfc_convert_type_warn (ctor->expr, &comp->ts, 1, false); 5203 if (val == false) 5204 return NULL__null; 5205 } 5206 } 5207 5208 gfc_constructor_append (&init->value.constructor, ctor); 5209 } 5210 5211 return init; 5212} 5213 5214 5215/* Given a symbol, create an expression node with that symbol as a 5216 variable. If the symbol is array valued, setup a reference of the 5217 whole array. */ 5218 5219gfc_expr * 5220gfc_get_variable_expr (gfc_symtree *var) 5221{ 5222 gfc_expr *e; 5223 5224 e = gfc_get_expr (); 5225 e->expr_type = EXPR_VARIABLE; 5226 e->symtree = var; 5227 e->ts = var->n.sym->ts; 5228 5229 if (var->n.sym->attr.flavor != FL_PROCEDURE 5230 && ((var->n.sym->as != NULL__null && var->n.sym->ts.type != BT_CLASS) 5231 || (var->n.sym->ts.type == BT_CLASS && var->n.sym->ts.u.derived 5232 && CLASS_DATA (var->n.sym)var->n.sym->ts.u.derived->components 5233 && CLASS_DATA (var->n.sym)var->n.sym->ts.u.derived->components->as))) 5234 { 5235 e->rank = var->n.sym->ts.type == BT_CLASS 5236 ? CLASS_DATA (var->n.sym)var->n.sym->ts.u.derived->components->as->rank : var->n.sym->as->rank; 5237 e->ref = gfc_get_ref ()((gfc_ref *) xcalloc (1, sizeof (gfc_ref))); 5238 e->ref->type = REF_ARRAY; 5239 e->ref->u.ar.type = AR_FULL; 5240 e->ref->u.ar.as = gfc_copy_array_spec (var->n.sym->ts.type == BT_CLASS 5241 ? CLASS_DATA (var->n.sym)var->n.sym->ts.u.derived->components->as 5242 : var->n.sym->as); 5243 } 5244 5245 return e; 5246} 5247 5248 5249/* Adds a full array reference to an expression, as needed. */ 5250 5251void 5252gfc_add_full_array_ref (gfc_expr *e, gfc_array_spec *as) 5253{ 5254 gfc_ref *ref; 5255 for (ref = e->ref; ref; ref = ref->next) 5256 if (!ref->next) 5257 break; 5258 if (ref) 5259 { 5260 ref->next = gfc_get_ref ()((gfc_ref *) xcalloc (1, sizeof (gfc_ref))); 5261 ref = ref->next; 5262 } 5263 else 5264 { 5265 e->ref = gfc_get_ref ()((gfc_ref *) xcalloc (1, sizeof (gfc_ref))); 5266 ref = e->ref; 5267 } 5268 ref->type = REF_ARRAY; 5269 ref->u.ar.type = AR_FULL; 5270 ref->u.ar.dimen = e->rank; 5271 ref->u.ar.where = e->where; 5272 ref->u.ar.as = as; 5273} 5274 5275 5276gfc_expr * 5277gfc_lval_expr_from_sym (gfc_symbol *sym) 5278{ 5279 gfc_expr *lval; 5280 gfc_array_spec *as; 5281 lval = gfc_get_expr (); 5282 lval->expr_type = EXPR_VARIABLE; 5283 lval->where = sym->declared_at; 5284 lval->ts = sym->ts; 5285 lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name); 5286 5287 /* It will always be a full array. */ 5288 as = IS_CLASS_ARRAY (sym)(sym->ts.type == BT_CLASS && sym->ts.u.derived->
components && sym->ts.u.derived->components->
attr.dimension && !sym->ts.u.derived->components
->attr.class_pointer) ? CLASS_DATA (sym)sym->ts.u.derived->components->as : sym->as; 5289 lval->rank = as ? as->rank : 0; 5290 if (lval->rank) 5291 gfc_add_full_array_ref (lval, as); 5292 return lval; 5293} 5294 5295 5296/* Returns the array_spec of a full array expression. A NULL is 5297 returned otherwise. */ 5298gfc_array_spec * 5299gfc_get_full_arrayspec_from_expr (gfc_expr *expr) 5300{ 5301 gfc_array_spec *as; 5302 gfc_ref *ref; 5303 5304 if (expr->rank == 0) 5305 return NULL__null; 5306 5307 /* Follow any component references. */ 5308 if (expr->expr_type == EXPR_VARIABLE 5309 || expr->expr_type == EXPR_CONSTANT) 5310 { 5311 if (expr->symtree) 5312 as = expr->symtree->n.sym->as; 5313 else 5314 as = NULL__null; 5315 5316 for (ref = expr->ref; ref; ref = ref->next) 5317 { 5318 switch (ref->type) 5319 { 5320 case REF_COMPONENT: 5321 as = ref->u.c.component->as; 5322 continue; 5323 5324 case REF_SUBSTRING: 5325 case REF_INQUIRY: 5326 continue; 5327 5328 case REF_ARRAY: 5329 { 5330 switch (ref->u.ar.type) 5331 { 5332 case AR_ELEMENT: 5333 case AR_SECTION: 5334 case AR_UNKNOWN: 5335 as = NULL__null; 5336 continue; 5337 5338 case AR_FULL: 5339 break; 5340 } 5341 break; 5342 } 5343 } 5344 } 5345 } 5346 else 5347 as = NULL__null; 5348 5349 return as; 5350} 5351 5352 5353/* General expression traversal function. */ 5354 5355bool 5356gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym, 5357 bool (*func)(gfc_expr *, gfc_symbol *, int*), 5358 int f) 5359{ 5360 gfc_array_ref ar; 5361 gfc_ref *ref; 5362 gfc_actual_arglist *args; 5363 gfc_constructor *c; 5364 int i; 5365 5366 if (!expr) 5367 return false; 5368 5369 if ((*func) (expr, sym, &f)) 5370 return true; 5371 5372 if (expr->ts.type == BT_CHARACTER 5373 && expr->ts.u.cl 5374 && expr->ts.u.cl->length 5375 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT 5376 && gfc_traverse_expr (expr->ts.u.cl->length, sym, func, f)) 5377 return true; 5378 5379 switch (expr->expr_type) 5380 { 5381 case EXPR_PPC: 5382 case EXPR_COMPCALL: 5383 case EXPR_FUNCTION: 5384 for (args = expr->value.function.actual; args; args = args->next) 5385 { 5386 if (gfc_traverse_expr (args->expr, sym, func, f)) 5387 return true; 5388 } 5389 break; 5390 5391 case EXPR_VARIABLE: 5392 case EXPR_CONSTANT: 5393 case EXPR_NULL: 5394 case EXPR_SUBSTRING: 5395 break; 5396 5397 case EXPR_STRUCTURE: 5398 case EXPR_ARRAY: 5399 for (c = gfc_constructor_first (expr->value.constructor); 5400 c; c = gfc_constructor_next (c)) 5401 { 5402 if (gfc_traverse_expr (c->expr, sym, func, f)) 5403 return true; 5404 if (c->iterator) 5405 { 5406 if (gfc_traverse_expr (c->iterator->var, sym, func, f)) 5407 return true; 5408 if (gfc_traverse_expr (c->iterator->start, sym, func, f)) 5409 return true; 5410 if (gfc_traverse_expr (c->iterator->end, sym, func, f)) 5411 return true; 5412 if (gfc_traverse_expr (c->iterator->step, sym, func, f)) 5413 return true; 5414 } 5415 } 5416 break; 5417 5418 case EXPR_OP: 5419 if (gfc_traverse_expr (expr->value.op.op1, sym, func, f)) 5420 return true; 5421 if (gfc_traverse_expr (expr->value.op.op2, sym, func, f)) 5422 return true; 5423 break; 5424 5425 default: 5426 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc"
, 5426, __FUNCTION__)); 5427 break; 5428 } 5429 5430 ref = expr->ref; 5431 while (ref != NULL__null) 5432 { 5433 switch (ref->type) 5434 { 5435 case REF_ARRAY: 5436 ar = ref->u.ar; 5437 for (i = 0; i < GFC_MAX_DIMENSIONS15; i++) 5438 { 5439 if (gfc_traverse_expr (ar.start[i], sym, func, f)) 5440 return true; 5441 if (gfc_traverse_expr (ar.end[i], sym, func, f)) 5442 return true; 5443 if (gfc_traverse_expr (ar.stride[i], sym, func, f)) 5444 return true; 5445 } 5446 break; 5447 5448 case REF_SUBSTRING: 5449 if (gfc_traverse_expr (ref->u.ss.start, sym, func, f)) 5450 return true; 5451 if (gfc_traverse_expr (ref->u.ss.end, sym, func, f)) 5452 return true; 5453 break; 5454 5455 case REF_COMPONENT: 5456 if (ref->u.c.component->ts.type == BT_CHARACTER 5457 && ref->u.c.component->ts.u.cl 5458 && ref->u.c.component->ts.u.cl->length 5459 && ref->u.c.component->ts.u.cl->length->expr_type 5460 != EXPR_CONSTANT 5461 && gfc_traverse_expr (ref->u.c.component->ts.u.cl->length, 5462 sym, func, f)) 5463 return true; 5464 5465 if (ref->u.c.component->as) 5466 for (i = 0; i < ref->u.c.component->as->rank 5467 + ref->u.c.component->as->corank; i++) 5468 { 5469 if (gfc_traverse_expr (ref->u.c.component->as->lower[i], 5470 sym, func, f)) 5471 return true; 5472 if (gfc_traverse_expr (ref->u.c.component->as->upper[i], 5473 sym, func, f)) 5474 return true; 5475 } 5476 break; 5477 5478 case REF_INQUIRY: 5479 return true; 5480 5481 default: 5482 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc"
, 5482, __FUNCTION__)); 5483 } 5484 ref = ref->next; 5485 } 5486 return false; 5487} 5488 5489/* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */ 5490 5491static bool 5492expr_set_symbols_referenced (gfc_expr *expr, 5493 gfc_symbol *sym ATTRIBUTE_UNUSED__attribute__ ((__unused__)), 5494 int *f ATTRIBUTE_UNUSED__attribute__ ((__unused__))) 5495{ 5496 if (expr->expr_type != EXPR_VARIABLE) 5497 return false; 5498 gfc_set_sym_referenced (expr->symtree->n.sym); 5499 return false; 5500} 5501 5502void 5503gfc_expr_set_symbols_referenced (gfc_expr *expr) 5504{ 5505 gfc_traverse_expr (expr, NULL__null, expr_set_symbols_referenced, 0); 5506} 5507 5508 5509/* Determine if an expression is a procedure pointer component and return 5510 the component in that case. Otherwise return NULL. */ 5511 5512gfc_component * 5513gfc_get_proc_ptr_comp (gfc_expr *expr) 5514{ 5515 gfc_ref *ref; 5516 5517 if (!expr || !expr->ref) 5518 return NULL__null; 5519 5520 ref = expr->ref; 5521 while (ref->next) 5522 ref = ref->next; 5523 5524 if (ref->type == REF_COMPONENT 5525 && ref->u.c.component->attr.proc_pointer) 5526 return ref->u.c.component; 5527 5528 return NULL__null; 5529} 5530 5531 5532/* Determine if an expression is a procedure pointer component. */ 5533 5534bool 5535gfc_is_proc_ptr_comp (gfc_expr *expr) 5536{ 5537 return (gfc_get_proc_ptr_comp (expr) != NULL__null); 5538} 5539 5540 5541/* Determine if an expression is a function with an allocatable class scalar 5542 result. */ 5543bool 5544gfc_is_alloc_class_scalar_function (gfc_expr *expr) 5545{ 5546 if (expr->expr_type == EXPR_FUNCTION 5547 && expr->value.function.esym 5548 && expr->value.function.esym->result 5549 && expr->value.function.esym->result->ts.type == BT_CLASS 5550 && !CLASS_DATA (expr->value.function.esym->result)expr->value.function.esym->result->ts.u.derived->
components->attr.dimension 5551 && CLASS_DATA (expr->value.function.esym->result)expr->value.function.esym->result->ts.u.derived->
components->attr.allocatable) 5552 return true; 5553 5554 return false; 5555} 5556 5557 5558/* Determine if an expression is a function with an allocatable class array 5559 result. */ 5560bool 5561gfc_is_class_array_function (gfc_expr *expr) 5562{ 5563 if (expr->expr_type == EXPR_FUNCTION 5564 && expr->value.function.esym 5565 && expr->value.function.esym->result 5566 && expr->value.function.esym->result->ts.type == BT_CLASS 5567 && CLASS_DATA (expr->value.function.esym->result)expr->value.function.esym->result->ts.u.derived->
components->attr.dimension 5568 && (CLASS_DATA (expr->value.function.esym->result)expr->value.function.esym->result->ts.u.derived->
components->attr.allocatable 5569 || CLASS_DATA (expr->value.function.esym->result)expr->value.function.esym->result->ts.u.derived->
components->attr.pointer)) 5570 return true; 5571 5572 return false; 5573} 5574 5575 5576/* Walk an expression tree and check each variable encountered for being typed. 5577 If strict is not set, a top-level variable is tolerated untyped in -std=gnu 5578 mode as is a basic arithmetic expression using those; this is for things in 5579 legacy-code like: 5580 5581 INTEGER :: arr(n), n 5582 INTEGER :: arr(n + 1), n 5583 5584 The namespace is needed for IMPLICIT typing. */ 5585 5586static gfc_namespace* check_typed_ns; 5587 5588static bool 5589expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED__attribute__ ((__unused__)), 5590 int* f ATTRIBUTE_UNUSED__attribute__ ((__unused__))) 5591{ 5592 bool t; 5593 5594 if (e->expr_type != EXPR_VARIABLE) 5595 return false; 5596 5597 gcc_assert (e->symtree)((void)(!(e->symtree) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc"
, 5597, __FUNCTION__), 0 : 0)); 5598 t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns, 5599 true, e->where); 5600 5601 return (!t); 5602} 5603 5604bool 5605gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict) 5606{ 5607 bool error_found; 5608 5609 /* If this is a top-level variable or EXPR_OP, do the check with strict given 5610 to us. */ 5611 if (!strict) 5612 { 5613 if (e->expr_type == EXPR_VARIABLE && !e->ref) 5614 return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where); 5615 5616 if (e->expr_type == EXPR_OP) 5617 { 5618 bool t = true; 5619 5620 gcc_assert (e->value.op.op1)((void)(!(e->value.op.op1) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc"
, 5620, __FUNCTION__), 0 : 0)); 5621 t = gfc_expr_check_typed (e->value.op.op1, ns, strict); 5622 5623 if (t && e->value.op.op2) 5624 t = gfc_expr_check_typed (e->value.op.op2, ns, strict); 5625 5626 return t; 5627 } 5628 } 5629 5630 /* Otherwise, walk the expression and do it strictly. */ 5631 check_typed_ns = ns; 5632 error_found = gfc_traverse_expr (e, NULL__null, &expr_check_typed_help, 0); 5633 5634 return error_found ? false : true; 5635} 5636 5637 5638/* This function returns true if it contains any references to PDT KIND 5639 or LEN parameters. */ 5640 5641static bool 5642derived_parameter_expr (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED__attribute__ ((__unused__)), 5643 int* f ATTRIBUTE_UNUSED__attribute__ ((__unused__))) 5644{ 5645 if (e->expr_type != EXPR_VARIABLE) 5646 return false; 5647 5648 gcc_assert (e->symtree)((void)(!(e->symtree) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc"
, 5648, __FUNCTION__), 0 : 0)); 5649 if (e->symtree->n.sym->attr.pdt_kind 5650 || e->symtree->n.sym->attr.pdt_len) 5651 return true; 5652 5653 return false; 5654} 5655 5656 5657bool 5658gfc_derived_parameter_expr (gfc_expr *e) 5659{ 5660 return gfc_traverse_expr (e, NULL__null, &derived_parameter_expr, 0); 5661} 5662 5663 5664/* This function returns the overall type of a type parameter spec list. 5665 If all the specs are explicit, SPEC_EXPLICIT is returned. If any of the 5666 parameters are assumed/deferred then SPEC_ASSUMED/DEFERRED is returned 5667 unless derived is not NULL. In this latter case, all the LEN parameters 5668 must be either assumed or deferred for the return argument to be set to 5669 anything other than SPEC_EXPLICIT. */ 5670 5671gfc_param_spec_type 5672gfc_spec_list_type (gfc_actual_arglist *param_list, gfc_symbol *derived) 5673{ 5674 gfc_param_spec_type res = SPEC_EXPLICIT; 5675 gfc_component *c; 5676 bool seen_assumed = false; 5677 bool seen_deferred = false; 5678 5679 if (derived == NULL__null) 5680 { 5681 for (; param_list; param_list = param_list->next) 5682 if (param_list->spec_type == SPEC_ASSUMED 5683 || param_list->spec_type == SPEC_DEFERRED) 5684 return param_list->spec_type; 5685 } 5686 else 5687 { 5688 for (; param_list; param_list = param_list->next) 5689 { 5690 c = gfc_find_component (derived, param_list->name, 5691 true, true, NULL__null); 5692 gcc_assert (c != NULL)((void)(!(c != __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc"
, 5692, __FUNCTION__), 0 : 0)); 5693 if (c->attr.pdt_kind) 5694 continue; 5695 else if (param_list->spec_type == SPEC_EXPLICIT) 5696 return SPEC_EXPLICIT; 5697 seen_assumed = param_list->spec_type == SPEC_ASSUMED; 5698 seen_deferred = param_list->spec_type == SPEC_DEFERRED; 5699 if (seen_assumed && seen_deferred) 5700 return SPEC_EXPLICIT; 5701 } 5702 res = seen_assumed ? SPEC_ASSUMED : SPEC_DEFERRED; 5703 } 5704 return res; 5705} 5706 5707 5708bool 5709gfc_ref_this_image (gfc_ref *ref) 5710{ 5711 int n; 5712 5713 gcc_assert (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)((void)(!(ref->type == REF_ARRAY && ref->u.ar.codimen
> 0) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc"
, 5713, __FUNCTION__), 0 : 0)); 5714 5715 for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++) 5716 if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE) 5717 return false; 5718 5719 return true; 5720} 5721 5722gfc_expr * 5723gfc_find_team_co (gfc_expr *e) 5724{ 5725 gfc_ref *ref; 5726 5727 for (ref = e->ref; ref; ref = ref->next) 5728 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) 5729 return ref->u.ar.team; 5730 5731 if (e->value.function.actual->expr) 5732 for (ref = e->value.function.actual->expr->ref; ref; 5733 ref = ref->next) 5734 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) 5735 return ref->u.ar.team; 5736 5737 return NULL__null; 5738} 5739 5740gfc_expr * 5741gfc_find_stat_co (gfc_expr *e) 5742{ 5743 gfc_ref *ref; 5744 5745 for (ref = e->ref; ref; ref = ref->next) 5746 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) 5747 return ref->u.ar.stat; 5748 5749 if (e->value.function.actual->expr) 5750 for (ref = e->value.function.actual->expr->ref; ref; 5751 ref = ref->next) 5752 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) 5753 return ref->u.ar.stat; 5754 5755 return NULL__null; 5756} 5757 5758bool 5759gfc_is_coindexed (gfc_expr *e) 5760{ 5761 gfc_ref *ref; 5762 5763 for (ref = e->ref; ref; ref = ref->next) 5764 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) 5765 return !gfc_ref_this_image (ref); 5766 5767 return false; 5768} 5769 5770 5771/* Coarrays are variables with a corank but not being coindexed. However, also 5772 the following is a coarray: A subobject of a coarray is a coarray if it does 5773 not have any cosubscripts, vector subscripts, allocatable component 5774 selection, or pointer component selection. (F2008, 2.4.7) */ 5775 5776bool 5777gfc_is_coarray (gfc_expr *e) 5778{ 5779 gfc_ref *ref; 5780 gfc_symbol *sym; 5781 gfc_component *comp; 5782 bool coindexed; 5783 bool coarray; 5784 int i; 5785 5786 if (e->expr_type != EXPR_VARIABLE) 5787 return false; 5788 5789 coindexed = false; 5790 sym = e->symtree->n.sym; 5791 5792 if (sym->ts.type == BT_CLASS && sym->attr.class_ok) 5793 coarray = CLASS_DATA (sym)sym->ts.u.derived->components->attr.codimension; 5794 else 5795 coarray = sym->attr.codimension; 5796 5797 for (ref = e->ref; ref; ref = ref->next) 5798 switch (ref->type) 5799 { 5800 case REF_COMPONENT: 5801 comp = ref->u.c.component; 5802 if (comp->ts.type == BT_CLASS && comp->attr.class_ok 5803 && (CLASS_DATA (comp)comp->ts.u.derived->components->attr.class_pointer 5804 || CLASS_DATA (comp)comp->ts.u.derived->components->attr.allocatable)) 5805 { 5806 coindexed = false; 5807 coarray = CLASS_DATA (comp)comp->ts.u.derived->components->attr.codimension; 5808 } 5809 else if (comp->attr.pointer || comp->attr.allocatable) 5810 { 5811 coindexed = false; 5812 coarray = comp->attr.codimension; 5813 } 5814 break; 5815 5816 case REF_ARRAY: 5817 if (!coarray) 5818 break; 5819 5820 if (ref->u.ar.codimen > 0 && !gfc_ref_this_image (ref)) 5821 { 5822 coindexed = true; 5823 break; 5824 } 5825 5826 for (i = 0; i < ref->u.ar.dimen; i++) 5827 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR) 5828 { 5829 coarray = false; 5830 break; 5831 } 5832 break; 5833 5834 case REF_SUBSTRING: 5835 case REF_INQUIRY: 5836 break; 5837 } 5838 5839 return coarray && !coindexed; 5840} 5841 5842 5843int 5844gfc_get_corank (gfc_expr *e) 5845{ 5846 int corank; 5847 gfc_ref *ref; 5848 5849 if (!gfc_is_coarray (e)) 5850 return 0; 5851 5852 if (e->ts.type == BT_CLASS && e->ts.u.derived->components) 5853 corank = e->ts.u.derived->components->as 5854 ? e->ts.u.derived->components->as->corank : 0; 5855 else 5856 corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0; 5857 5858 for (ref = e->ref; ref; ref = ref->next) 5859 { 5860 if (ref->type == REF_ARRAY) 5861 corank = ref->u.ar.as->corank; 5862 gcc_assert (ref->type != REF_SUBSTRING)((void)(!(ref->type != REF_SUBSTRING) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc"
, 5862, __FUNCTION__), 0 : 0)); 5863 } 5864 5865 return corank; 5866} 5867 5868 5869/* Check whether the expression has an ultimate allocatable component. 5870 Being itself allocatable does not count. */ 5871bool 5872gfc_has_ultimate_allocatable (gfc_expr *e) 5873{ 5874 gfc_ref *ref, *last = NULL__null; 5875 5876 if (e->expr_type != EXPR_VARIABLE) 5877 return false; 5878 5879 for (ref = e->ref; ref; ref = ref->next) 5880 if (ref->type == REF_COMPONENT) 5881 last = ref; 5882 5883 if (last && last->u.c.component->ts.type == BT_CLASS) 5884 return CLASS_DATA (last->u.c.component)last->u.c.component->ts.u.derived->components->attr.alloc_comp; 5885 else if (last && last->u.c.component->ts.type == BT_DERIVED) 5886 return last->u.c.component->ts.u.derived->attr.alloc_comp; 5887 else if (last) 5888 return false; 5889 5890 if (e->ts.type == BT_CLASS) 5891 return CLASS_DATA (e)e->ts.u.derived->components->attr.alloc_comp; 5892 else if (e->ts.type == BT_DERIVED) 5893 return e->ts.u.derived->attr.alloc_comp; 5894 else 5895 return false; 5896} 5897 5898 5899/* Check whether the expression has an pointer component. 5900 Being itself a pointer does not count. */ 5901bool 5902gfc_has_ultimate_pointer (gfc_expr *e) 5903{ 5904 gfc_ref *ref, *last = NULL__null; 5905 5906 if (e->expr_type != EXPR_VARIABLE) 5907 return false; 5908 5909 for (ref = e->ref; ref; ref = ref->next) 5910 if (ref->type == REF_COMPONENT) 5911 last = ref; 5912 5913 if (last && last->u.c.component->ts.type == BT_CLASS) 5914 return CLASS_DATA (last->u.c.component)last->u.c.component->ts.u.derived->components->attr.pointer_comp; 5915 else if (last && last->u.c.component->ts.type == BT_DERIVED) 5916 return last->u.c.component->ts.u.derived->attr.pointer_comp; 5917 else if (last) 5918 return false; 5919 5920 if (e->ts.type == BT_CLASS) 5921 return CLASS_DATA (e)e->ts.u.derived->components->attr.pointer_comp; 5922 else if (e->ts.type == BT_DERIVED) 5923 return e->ts.u.derived->attr.pointer_comp; 5924 else 5925 return false; 5926} 5927 5928 5929/* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4. 5930 Note: A scalar is not regarded as "simply contiguous" by the standard. 5931 if bool is not strict, some further checks are done - for instance, 5932 a "(::1)" is accepted. */ 5933 5934bool 5935gfc_is_simply_contiguous (gfc_expr *expr, bool strict, bool permit_element) 5936{ 5937 bool colon; 5938 int i; 5939 gfc_array_ref *ar = NULL__null; 5940 gfc_ref *ref, *part_ref = NULL__null; 5941 gfc_symbol *sym; 5942 5943 if (expr->expr_type == EXPR_ARRAY) 5944 return true; 5945 5946 if (expr->expr_type == EXPR_FUNCTION) 5947 { 5948 if (expr->value.function.isym) 5949 /* TRANSPOSE is the only intrinsic that may return a 5950 non-contiguous array. It's treated as a special case in 5951 gfc_conv_expr_descriptor too. */ 5952 return (expr->value.function.isym->id != GFC_ISYM_TRANSPOSE); 5953 else if (expr->value.function.esym) 5954 /* Only a pointer to an array without the contiguous attribute 5955 can be non-contiguous as a result value. */ 5956 return (expr->value.function.esym->result->attr.contiguous 5957 || !expr->value.function.esym->result->attr.pointer); 5958 else 5959 { 5960 /* Type-bound procedures. */ 5961 gfc_symbol *s = expr->symtree->n.sym; 5962 if (s->ts.type != BT_CLASS && s->ts.type != BT_DERIVED) 5963 return false; 5964 5965 gfc_ref *rc = NULL__null; 5966 for (gfc_ref *r = expr->ref; r; r = r->next) 5967 if (r->type == REF_COMPONENT) 5968 rc = r; 5969 5970 if (rc == NULL__null || rc->u.c.component == NULL__null 5971 || rc->u.c.component->ts.interface == NULL__null) 5972 return false; 5973 5974 return rc->u.c.component->ts.interface->attr.contiguous; 5975 } 5976 } 5977 else if (expr->expr_type != EXPR_VARIABLE) 5978 return false; 5979 5980 if (!permit_element && expr->rank == 0) 5981 return false; 5982 5983 for (ref = expr->ref; ref; ref = ref->next) 5984 { 5985 if (ar) 5986 return false; /* Array shall be last part-ref. */ 5987 5988 if (ref->type == REF_COMPONENT) 5989 part_ref = ref; 5990 else if (ref->type == REF_SUBSTRING) 5991 return false; 5992 else if (ref->type == REF_INQUIRY) 5993 return false; 5994 else if (ref->u.ar.type != AR_ELEMENT) 5995 ar = &ref->u.ar; 5996 } 5997 5998 sym = expr->symtree->n.sym; 5999 if (expr->ts.type != BT_CLASS 6000 && ((part_ref 6001 && !part_ref->u.c.component->attr.contiguous 6002 && part_ref->u.c.component->attr.pointer) 6003 || (!part_ref 6004 && !sym->attr.contiguous 6005 && (sym->attr.pointer 6006 || (sym->as && sym->as->type == AS_ASSUMED_RANK) 6007 || (sym->as && sym->as->type == AS_ASSUMED_SHAPE))))) 6008 return false; 6009 6010 if (!ar || ar->type == AR_FULL) 6011 return true; 6012 6013 gcc_assert (ar->type == AR_SECTION)((void)(!(ar->type == AR_SECTION) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc"
, 6013, __FUNCTION__), 0 : 0)); 6014 6015 /* Check for simply contiguous array */ 6016 colon = true; 6017 for (i = 0; i < ar->dimen; i++) 6018 { 6019 if (ar->dimen_type[i] == DIMEN_VECTOR) 6020 return false; 6021 6022 if (ar->dimen_type[i] == DIMEN_ELEMENT) 6023 { 6024 colon = false; 6025 continue; 6026 } 6027 6028 gcc_assert (ar->dimen_type[i] == DIMEN_RANGE)((void)(!(ar->dimen_type[i] == DIMEN_RANGE) ? fancy_abort (
"/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc"
, 6028, __FUNCTION__), 0 : 0)); 6029 6030 6031 /* If the previous section was not contiguous, that's an error, 6032 unless we have effective only one element and checking is not 6033 strict. */ 6034 if (!colon && (strict || !ar->start[i] || !ar->end[i] 6035 || ar->start[i]->expr_type != EXPR_CONSTANT 6036 || ar->end[i]->expr_type != EXPR_CONSTANT 6037 || mpz_cmp__gmpz_cmp (ar->start[i]->value.integer, 6038 ar->end[i]->value.integer) != 0)) 6039 return false; 6040 6041 /* Following the standard, "(::1)" or - if known at compile time - 6042 "(lbound:ubound)" are not simply contiguous; if strict 6043 is false, they are regarded as simply contiguous. */ 6044 if (ar->stride[i] && (strict || ar->stride[i]->expr_type != EXPR_CONSTANT 6045 || ar->stride[i]->ts.type != BT_INTEGER 6046 || mpz_cmp_si (ar->stride[i]->value.integer, 1)(__builtin_constant_p ((1) >= 0) && (1) >= 0 ? (
__builtin_constant_p ((static_cast<unsigned long> (1)))
&& ((static_cast<unsigned long> (1))) == 0 ? (
(ar->stride[i]->value.integer)->_mp_size < 0 ? -1
: (ar->stride[i]->value.integer)->_mp_size > 0) :
__gmpz_cmp_ui (ar->stride[i]->value.integer,(static_cast
<unsigned long> (1)))) : __gmpz_cmp_si (ar->stride[i
]->value.integer,1)) != 0)) 6047 return false; 6048 6049 if (ar->start[i] 6050 && (strict || ar->start[i]->expr_type != EXPR_CONSTANT 6051 || !ar->as->lower[i] 6052 || ar->as->lower[i]->expr_type != EXPR_CONSTANT 6053 || mpz_cmp__gmpz_cmp (ar->start[i]->value.integer, 6054 ar->as->lower[i]->value.integer) != 0)) 6055 colon = false; 6056 6057 if (ar->end[i] 6058 && (strict || ar->end[i]->expr_type != EXPR_CONSTANT 6059 || !ar->as->upper[i] 6060 || ar->as->upper[i]->expr_type != EXPR_CONSTANT 6061 || mpz_cmp__gmpz_cmp (ar->end[i]->value.integer, 6062 ar->as->upper[i]->value.integer) != 0)) 6063 colon = false; 6064 } 6065 6066 return true; 6067} 6068 6069/* Return true if the expression is guaranteed to be non-contiguous, 6070 false if we cannot prove anything. It is probably best to call 6071 this after gfc_is_simply_contiguous. If neither of them returns 6072 true, we cannot say (at compile-time). */ 6073 6074bool 6075gfc_is_not_contiguous (gfc_expr *array) 6076{ 6077 int i; 6078 gfc_array_ref *ar = NULL__null; 6079 gfc_ref *ref; 6080 bool previous_incomplete; 6081 6082 for (ref = array->ref; ref; ref = ref->next) 6083 { 6084 /* Array-ref shall be last ref. */ 6085 6086 if (ar && ar->type != AR_ELEMENT) 6087 return true; 6088 6089 if (ref->type == REF_ARRAY) 6090 ar = &ref->u.ar; 6091 } 6092 6093 if (ar == NULL__null || ar->type != AR_SECTION) 6094 return false; 6095 6096 previous_incomplete = false; 6097 6098 /* Check if we can prove that the array is not contiguous. */ 6099 6100 for (i = 0; i < ar->dimen; i++) 6101 { 6102 mpz_t arr_size, ref_size; 6103 6104 if (gfc_ref_dimen_size (ar, i, &ref_size, NULL__null)) 6105 { 6106 if (gfc_dep_difference (ar->as->upper[i], ar->as->lower[i], &arr_size)) 6107 { 6108 /* a(2:4,2:) is known to be non-contiguous, but 6109 a(2:4,i:i) can be contiguous. */ 6110 mpz_add_ui__gmpz_add_ui (arr_size, arr_size, 1L); 6111 if (previous_incomplete && mpz_cmp_si (ref_size, 1)(__builtin_constant_p ((1) >= 0) && (1) >= 0 ? (
__builtin_constant_p ((static_cast<unsigned long> (1)))
&& ((static_cast<unsigned long> (1))) == 0 ? (
(ref_size)->_mp_size < 0 ? -1 : (ref_size)->_mp_size
> 0) : __gmpz_cmp_ui (ref_size,(static_cast<unsigned long
> (1)))) : __gmpz_cmp_si (ref_size,1)) != 0) 6112 { 6113 mpz_clear__gmpz_clear (arr_size); 6114 mpz_clear__gmpz_clear (ref_size); 6115 return true; 6116 } 6117 else if (mpz_cmp__gmpz_cmp (arr_size, ref_size) != 0) 6118 previous_incomplete = true; 6119 6120 mpz_clear__gmpz_clear (arr_size); 6121 } 6122 6123 /* Check for a(::2), i.e. where the stride is not unity. 6124 This is only done if there is more than one element in 6125 the reference along this dimension. */ 6126 6127 if (mpz_cmp_ui (ref_size, 1)(__builtin_constant_p (1) && (1) == 0 ? ((ref_size)->
_mp_size < 0 ? -1 : (ref_size)->_mp_size > 0) : __gmpz_cmp_ui
(ref_size,1)) > 0 && ar->type == AR_SECTION 6128 && ar->dimen_type[i] == DIMEN_RANGE 6129 && ar->stride[i] && ar->stride[i]->expr_type == EXPR_CONSTANT 6130 && mpz_cmp_si (ar->stride[i]->value.integer, 1)(__builtin_constant_p ((1) >= 0) && (1) >= 0 ? (
__builtin_constant_p ((static_cast<unsigned long> (1)))
&& ((static_cast<unsigned long> (1))) == 0 ? (
(ar->stride[i]->value.integer)->_mp_size < 0 ? -1
: (ar->stride[i]->value.integer)->_mp_size > 0) :
__gmpz_cmp_ui (ar->stride[i]->value.integer,(static_cast
<unsigned long> (1)))) : __gmpz_cmp_si (ar->stride[i
]->value.integer,1)) != 0) 6131 { 6132 mpz_clear__gmpz_clear (ref_size); 6133 return true; 6134 } 6135 6136 mpz_clear__gmpz_clear (ref_size); 6137 } 6138 } 6139 /* We didn't find anything definitive. */ 6140 return false; 6141} 6142 6143/* Build call to an intrinsic procedure. The number of arguments has to be 6144 passed (rather than ending the list with a NULL value) because we may 6145 want to add arguments but with a NULL-expression. */ 6146 6147gfc_expr* 6148gfc_build_intrinsic_call (gfc_namespace *ns, gfc_isym_id id, const char* name, 6149 locus where, unsigned numarg, ...) 6150{ 6151 gfc_expr* result; 6152 gfc_actual_arglist* atail; 6153 gfc_intrinsic_sym* isym; 6154 va_list ap; 6155 unsigned i; 6156 const char *mangled_name = gfc_get_string (GFC_PREFIX ("%s")"_F." "%s", name); 6157 6158 isym = gfc_intrinsic_function_by_id (id); 6159 gcc_assert (isym)((void)(!(isym) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc"
, 6159, __FUNCTION__), 0 : 0)); 6160 6161 result = gfc_get_expr (); 6162 result->expr_type = EXPR_FUNCTION; 6163 result->ts = isym->ts; 6164 result->where = where; 6165 result->value.function.name = mangled_name; 6166 result->value.function.isym = isym; 6167 6168 gfc_get_sym_tree (mangled_name, ns, &result->symtree, false); 6169 gfc_commit_symbol (result->symtree->n.sym); 6170 gcc_assert (result->symtree((void)(!(result->symtree && (result->symtree->
n.sym->attr.flavor == FL_PROCEDURE || result->symtree->
n.sym->attr.flavor == FL_UNKNOWN)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc"
, 6172, __FUNCTION__), 0 : 0)) 6171 && (result->symtree->n.sym->attr.flavor == FL_PROCEDURE((void)(!(result->symtree && (result->symtree->
n.sym->attr.flavor == FL_PROCEDURE || result->symtree->
n.sym->attr.flavor == FL_UNKNOWN)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc"
, 6172, __FUNCTION__), 0 : 0)) 6172 || result->symtree->n.sym->attr.flavor == FL_UNKNOWN))((void)(!(result->symtree && (result->symtree->
n.sym->attr.flavor == FL_PROCEDURE || result->symtree->
n.sym->attr.flavor == FL_UNKNOWN)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc"
, 6172, __FUNCTION__), 0 : 0)); 6173 result->symtree->n.sym->intmod_sym_id = id; 6174 result->symtree->n.sym->attr.flavor = FL_PROCEDURE; 6175 result->symtree->n.sym->attr.intrinsic = 1; 6176 result->symtree->n.sym->attr.artificial = 1; 6177 6178 va_start (ap, numarg)__builtin_va_start(ap, numarg); 6179 atail = NULL__null; 6180 for (i = 0; i < numarg; ++i) 6181 { 6182 if (atail) 6183 { 6184 atail->next = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
))); 6185 atail = atail->next; 6186 } 6187 else 6188 atail = result->value.function.actual = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
))); 6189 6190 atail->expr = va_arg (ap, gfc_expr*)__builtin_va_arg(ap, gfc_expr*); 6191 } 6192 va_end (ap)__builtin_va_end(ap); 6193 6194 return result; 6195} 6196 6197 6198/* Check if an expression may appear in a variable definition context 6199 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8). 6200 This is called from the various places when resolving 6201 the pieces that make up such a context. 6202 If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do 6203 variables), some checks are not performed. 6204 6205 Optionally, a possible error message can be suppressed if context is NULL 6206 and just the return status (true / false) be requested. */ 6207 6208bool 6209gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, 6210 bool own_scope, const char* context) 6211{ 6212 gfc_symbol* sym = NULL__null; 6213 bool is_pointer; 6214 bool check_intentin; 6215 bool ptr_component; 6216 symbol_attribute attr; 6217 gfc_ref* ref; 6218 int i; 6219 6220 if (e->expr_type == EXPR_VARIABLE) 6221 { 6222 gcc_assert (e->symtree)((void)(!(e->symtree) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc"
, 6222, __FUNCTION__), 0 : 0)); 6223 sym = e->symtree->n.sym; 6224 } 6225 else if (e->expr_type == EXPR_FUNCTION) 6226 { 6227 gcc_assert (e->symtree)((void)(!(e->symtree) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.cc"
, 6227, __FUNCTION__), 0 : 0)); 6228 sym = e->value.function.esym ? e->value.function.esym : e->symtree->n.sym; 6229 } 6230 6231 attr = gfc_expr_attr (e); 6232 if (!pointer && e->expr_type == EXPR_FUNCTION && attr.pointer) 6233 { 6234 if (!(gfc_option.allow_std & GFC_STD_F2008(1<<7))) 6235 { 6236 if (context) 6237 gfc_error ("Fortran 2008: Pointer functions in variable definition" 6238 " context (%s) at %L", context, &e->where); 6239 return false; 6240 } 6241 } 6242 else if (e->expr_type != EXPR_VARIABLE) 6243 { 6244 if (context) 6245 gfc_error ("Non-variable expression in variable definition context (%s)" 6246 " at %L", context, &e->where); 6247 return false; 6248 } 6249 6250 if (!pointer && sym->attr.flavor == FL_PARAMETER) 6251 { 6252 if (context) 6253 gfc_error ("Named constant %qs in variable definition context (%s)" 6254 " at %L", sym->name, context, &e->where); 6255 return false; 6256 } 6257 if (!pointer && sym->attr.flavor != FL_VARIABLE 6258 && !(sym->attr.flavor == FL_PROCEDURE && sym == sym->result) 6259 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer) 6260 && !(sym->attr.flavor == FL_PROCEDURE 6261 && sym->attr.function && sym->attr.pointer)) 6262 { 6263 if (context) 6264 gfc_error ("%qs in variable definition context (%s) at %L is not" 6265 " a variable", sym->name, context, &e->where); 6266 return false; 6267 } 6268 6269 /* Find out whether the expr is a pointer; this also means following 6270 component references to the last one. */ 6271 is_pointer = (attr.pointer || attr.proc_pointer); 6272 if (pointer && !is_pointer) 6273 { 6274 if (context) 6275 gfc_error ("Non-POINTER in pointer association context (%s)" 6276 " at %L", context, &e->where); 6277 return false; 6278 } 6279 6280 if (e->ts.type == BT_DERIVED 6281 && e->ts.u.derived == NULL__null) 6282 { 6283 if (context) 6284 gfc_error ("Type inaccessible in variable definition context (%s) " 6285 "at %L", context, &e->where); 6286 return false; 6287 } 6288 6289 /* F2008, C1303. */ 6290 if (!alloc_obj 6291 && (attr.lock_comp 6292 || (e->ts.type == BT_DERIVED 6293 && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV 6294 && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE))) 6295 { 6296 if (context) 6297 gfc_error ("LOCK_TYPE in variable definition context (%s) at %L", 6298 context, &e->where); 6299 return false; 6300 } 6301