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

Bug Summary

File:	build/gcc/fortran/simplify.cc
Warning:	line 2539, column 3 Value stored to 's_len' is never read

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 simplify.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-ocCgmK.plist -x c++ /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc

1	/* Simplify intrinsic functions at compile-time.
2	Copyright (C) 2000-2023 Free Software Foundation, Inc.
3	Contributed by Andy Vaught & Katherine Holcomb
4
5	This file is part of GCC.
6
7	GCC is free software; you can redistribute it and/or modify it under
8	the terms of the GNU General Public License as published by the Free
9	Software Foundation; either version 3, or (at your option) any later
10	version.
11
12	GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13	WARRANTY; without even the implied warranty of MERCHANTABILITY or
14	FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15	for more details.
16
17	You should have received a copy of the GNU General Public License
18	along with GCC; see the file COPYING3. If not see
19	<http://www.gnu.org/licenses/>. */
20
21	#include "config.h"
22	#include "system.h"
23	#include "coretypes.h"
24	#include "tm.h" /* For BITS_PER_UNIT. */
25	#include "gfortran.h"
26	#include "arith.h"
27	#include "intrinsic.h"
28	#include "match.h"
29	#include "target-memory.h"
30	#include "constructor.h"
31	#include "version.h" /* For version_string. */
32
33	/* Prototypes. */
34
35	static int min_max_choose (gfc_expr , gfc_expr , int, bool back_val = false);
36
37	gfc_expr gfc_bad_expr;
38
39	static gfc_expr simplify_size (gfc_expr , gfc_expr *, int);
40
41
42	/* Note that 'simplification' is not just transforming expressions.
43	For functions that are not simplified at compile time, range
44	checking is done if possible.
45
46	The return convention is that each simplification function returns:
47
48	A new expression node corresponding to the simplified arguments.
49	The original arguments are destroyed by the caller, and must not
50	be a part of the new expression.
51
52	NULL pointer indicating that no simplification was possible and
53	the original expression should remain intact.
54
55	An expression pointer to gfc_bad_expr (a static placeholder)
56	indicating that some error has prevented simplification. The
57	error is generated within the function and should be propagated
58	upwards
59
60	By the time a simplification function gets control, it has been
61	decided that the function call is really supposed to be the
62	intrinsic. No type checking is strictly necessary, since only
63	valid types will be passed on. On the other hand, a simplification
64	subroutine may have to look at the type of an argument as part of
65	its processing.
66
67	Array arguments are only passed to these subroutines that implement
68	the simplification of transformational intrinsics.
69
70	The functions in this file don't have much comment with them, but
71	everything is reasonably straight-forward. The Standard, chapter 13
72	is the best comment you'll find for this file anyway. */
73
74	/* Range checks an expression node. If all goes well, returns the
75	node, otherwise returns &gfc_bad_expr and frees the node. */
76
77	static gfc_expr *
78	range_check (gfc_expr result, const char name)
79	{
80	if (result == NULL__null)
81	return &gfc_bad_expr;
82
83	if (result->expr_type != EXPR_CONSTANT)
84	return result;
85
86	switch (gfc_range_check (result))
87	{
88	case ARITH_OK:
89	return result;
90
91	case ARITH_OVERFLOW:
92	gfc_error ("Result of %s overflows its kind at %L", name,
93	&result->where);
94	break;
95
96	case ARITH_UNDERFLOW:
97	gfc_error ("Result of %s underflows its kind at %L", name,
98	&result->where);
99	break;
100
101	case ARITH_NAN:
102	gfc_error ("Result of %s is NaN at %L", name, &result->where);
103	break;
104
105	default:
106	gfc_error ("Result of %s gives range error for its kind at %L", name,
107	&result->where);
108	break;
109	}
110
111	gfc_free_expr (result);
112	return &gfc_bad_expr;
113	}
114
115
116	/* A helper function that gets an optional and possibly missing
117	kind parameter. Returns the kind, -1 if something went wrong. */
118
119	static int
120	get_kind (bt type, gfc_expr k, const char name, int default_kind)
121	{
122	int kind;
123
124	if (k == NULL__null)
125	return default_kind;
126
127	if (k->expr_type != EXPR_CONSTANT)
128	{
129	gfc_error ("KIND parameter of %s at %L must be an initialization "
130	"expression", name, &k->where);
131	return -1;
132	}
133
134	if (gfc_extract_int (k, &kind)
135	\|\| gfc_validate_kind (type, kind, true) < 0)
136	{
137	gfc_error ("Invalid KIND parameter of %s at %L", name, &k->where);
138	return -1;
139	}
140
141	return kind;
142	}
143
144
145	/* Converts an mpz_t signed variable into an unsigned one, assuming
146	two's complement representations and a binary width of bitsize.
147	The conversion is a no-op unless x is negative; otherwise, it can
148	be accomplished by masking out the high bits. */
149
150	static void
151	convert_mpz_to_unsigned (mpz_t x, int bitsize)
152	{
153	mpz_t mask;
154
155	if (mpz_sgn (x)((x)->_mp_size < 0 ? -1 : (x)->_mp_size > 0) < 0)
156	{
157	/* Confirm that no bits above the signed range are unset if we
158	are doing range checking. */
159	if (flag_range_checkglobal_options.x_flag_range_check != 0)
160	gcc_assert (mpz_scan0 (x, bitsize-1) == ULONG_MAX)((void)(!(__gmpz_scan0 (x, bitsize-1) == (9223372036854775807L *2UL+1UL)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 160, __FUNCTION__), 0 : 0));
161
162	mpz_init_set_ui__gmpz_init_set_ui (mask, 1);
163	mpz_mul_2exp__gmpz_mul_2exp (mask, mask, bitsize);
164	mpz_sub_ui__gmpz_sub_ui (mask, mask, 1);
165
166	mpz_and__gmpz_and (x, x, mask);
167
168	mpz_clear__gmpz_clear (mask);
169	}
170	else
171	{
172	/* Confirm that no bits above the signed range are set if we
173	are doing range checking. */
174	if (flag_range_checkglobal_options.x_flag_range_check != 0)
175	gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX)((void)(!(__gmpz_scan1 (x, bitsize-1) == (9223372036854775807L *2UL+1UL)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 175, __FUNCTION__), 0 : 0));
176	}
177	}
178
179
180	/* Converts an mpz_t unsigned variable into a signed one, assuming
181	two's complement representations and a binary width of bitsize.
182	If the bitsize-1 bit is set, this is taken as a sign bit and
183	the number is converted to the corresponding negative number. */
184
185	void
186	gfc_convert_mpz_to_signed (mpz_t x, int bitsize)
187	{
188	mpz_t mask;
189
190	/* Confirm that no bits above the unsigned range are set if we are
191	doing range checking. */
192	if (flag_range_checkglobal_options.x_flag_range_check != 0)
193	gcc_assert (mpz_scan1 (x, bitsize) == ULONG_MAX)((void)(!(__gmpz_scan1 (x, bitsize) == (9223372036854775807L * 2UL+1UL)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 193, __FUNCTION__), 0 : 0));
194
195	if (mpz_tstbit__gmpz_tstbit (x, bitsize - 1) == 1)
196	{
197	mpz_init_set_ui__gmpz_init_set_ui (mask, 1);
198	mpz_mul_2exp__gmpz_mul_2exp (mask, mask, bitsize);
199	mpz_sub_ui__gmpz_sub_ui (mask, mask, 1);
200
201	/* We negate the number by hand, zeroing the high bits, that is
202	make it the corresponding positive number, and then have it
203	negated by GMP, giving the correct representation of the
204	negative number. */
205	mpz_com__gmpz_com (x, x);
206	mpz_add_ui__gmpz_add_ui (x, x, 1);
207	mpz_and__gmpz_and (x, x, mask);
208
209	mpz_neg__gmpz_neg (x, x);
210
211	mpz_clear__gmpz_clear (mask);
212	}
213	}
214
215
216	/* Test that the expression is a constant array, simplifying if
217	we are dealing with a parameter array. */
218
219	static bool
220	is_constant_array_expr (gfc_expr *e)
221	{
222	gfc_constructor *c;
223	bool array_OK = true;
224	mpz_t size;
225
226	if (e == NULL__null)
227	return true;
228
229	if (e->expr_type == EXPR_VARIABLE && e->rank > 0
230	&& e->symtree->n.sym->attr.flavor == FL_PARAMETER)
231	gfc_simplify_expr (e, 1);
232
233	if (e->expr_type != EXPR_ARRAY \|\| !gfc_is_constant_expr (e))
234	return false;
235
236	/* A non-zero-sized constant array shall have a non-empty constructor. */
237	if (e->rank > 0 && e->shape != NULL__null && e->value.constructor == NULL__null)
238	{
239	mpz_init_set_ui__gmpz_init_set_ui (size, 1);
240	for (int j = 0; j < e->rank; j++)
241	mpz_mul__gmpz_mul (size, size, e->shape[j]);
242	bool not_size0 = (mpz_cmp_si (size, 0)(__builtin_constant_p ((0) >= 0) && (0) >= 0 ? ( __builtin_constant_p ((static_cast<unsigned long> (0))) && ((static_cast<unsigned long> (0))) == 0 ? ( (size)->_mp_size < 0 ? -1 : (size)->_mp_size > 0) : __gmpz_cmp_ui (size,(static_cast<unsigned long> (0)) )) : __gmpz_cmp_si (size,0)) != 0);
243	mpz_clear__gmpz_clear (size);
244	if (not_size0)
245	return false;
246	}
247
248	for (c = gfc_constructor_first (e->value.constructor);
249	c; c = gfc_constructor_next (c))
250	if (c->expr->expr_type != EXPR_CONSTANT
251	&& c->expr->expr_type != EXPR_STRUCTURE)
252	{
253	array_OK = false;
254	break;
255	}
256
257	/* Check and expand the constructor. */
258	if (!array_OK && gfc_init_expr_flag && e->rank == 1)
259	{
260	array_OK = gfc_reduce_init_expr (e);
261	/* gfc_reduce_init_expr resets the flag. */
262	gfc_init_expr_flag = true;
263	}
264	else
265	return array_OK;
266
267	/* Recheck to make sure that any EXPR_ARRAYs have gone. */
268	for (c = gfc_constructor_first (e->value.constructor);
269	c; c = gfc_constructor_next (c))
270	if (c->expr->expr_type != EXPR_CONSTANT
271	&& c->expr->expr_type != EXPR_STRUCTURE)
272	return false;
273
274	/* Make sure that the array has a valid shape. */
275	if (e->shape == NULL__null && e->rank == 1)
276	{
277	if (!gfc_array_size(e, &size))
278	return false;
279	e->shape = gfc_get_shape (1)(((mpz_t *) xcalloc (((1)), sizeof (mpz_t))));
280	mpz_init_set__gmpz_init_set (e->shape[0], size);
281	mpz_clear__gmpz_clear (size);
282	}
283
284	return array_OK;
285	}
286
287	/* Test for a size zero array. */
288	bool
289	gfc_is_size_zero_array (gfc_expr *array)
290	{
291
292	if (array->rank == 0)
293	return false;
294
295	if (array->expr_type == EXPR_VARIABLE && array->rank > 0
296	&& array->symtree->n.sym->attr.flavor == FL_PARAMETER
297	&& array->shape != NULL__null)
298	{
299	for (int i = 0; i < array->rank; i++)
300	if (mpz_cmp_si (array->shape[i], 0)(__builtin_constant_p ((0) >= 0) && (0) >= 0 ? ( __builtin_constant_p ((static_cast<unsigned long> (0))) && ((static_cast<unsigned long> (0))) == 0 ? ( (array->shape[i])->_mp_size < 0 ? -1 : (array->shape [i])->_mp_size > 0) : __gmpz_cmp_ui (array->shape[i] ,(static_cast<unsigned long> (0)))) : __gmpz_cmp_si (array ->shape[i],0)) <= 0)
301	return true;
302
303	return false;
304	}
305
306	if (array->expr_type == EXPR_ARRAY)
307	return array->value.constructor == NULL__null;
308
309	return false;
310	}
311
312
313	/* Initialize a transformational result expression with a given value. */
314
315	static void
316	init_result_expr (gfc_expr e, int init, gfc_expr array)
317	{
318	if (e && e->expr_type == EXPR_ARRAY)
319	{
320	gfc_constructor *ctor = gfc_constructor_first (e->value.constructor);
321	while (ctor)
322	{
323	init_result_expr (ctor->expr, init, array);
324	ctor = gfc_constructor_next (ctor);
325	}
326	}
327	else if (e && e->expr_type == EXPR_CONSTANT)
328	{
329	int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
330	HOST_WIDE_INTlong length;
331	gfc_char_t *string;
332
333	switch (e->ts.type)
334	{
335	case BT_LOGICAL:
336	e->value.logical = (init ? 1 : 0);
337	break;
338
339	case BT_INTEGER:
340	if (init == INT_MIN(-2147483647 -1))
341	mpz_set__gmpz_set (e->value.integer, gfc_integer_kinds[i].min_int);
342	else if (init == INT_MAX2147483647)
343	mpz_set__gmpz_set (e->value.integer, gfc_integer_kinds[i].huge);
344	else
345	mpz_set_si__gmpz_set_si (e->value.integer, init);
346	break;
347
348	case BT_REAL:
349	if (init == INT_MIN(-2147483647 -1))
350	{
351	mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (gfc_real_kinds[i].huge); mpfr_set4 (e->value.real,_p,MPFR_RNDN,((_p)->_mpfr_sign)); });
352	mpfr_neg (e->value.real, e->value.real, GFC_RND_MODEMPFR_RNDN);
353	}
354	else if (init == INT_MAX2147483647)
355	mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (gfc_real_kinds[i].huge); mpfr_set4 (e->value.real,_p,MPFR_RNDN,((_p)->_mpfr_sign)); });
356	else
357	mpfr_set_si (e->value.real, init, GFC_RND_MODEMPFR_RNDN);
358	break;
359
360	case BT_COMPLEX:
361	mpc_set_si (e->value.complex, init, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
362	break;
363
364	case BT_CHARACTER:
365	if (init == INT_MIN(-2147483647 -1))
366	{
367	gfc_expr *len = gfc_simplify_len (array, NULL__null);
368	gfc_extract_hwi (len, &length);
369	string = gfc_get_wide_string (length + 1)((gfc_char_t *) xcalloc ((length + 1), sizeof (gfc_char_t)));
370	gfc_wide_memset (string, 0, length);
371	}
372	else if (init == INT_MAX2147483647)
373	{
374	gfc_expr *len = gfc_simplify_len (array, NULL__null);
375	gfc_extract_hwi (len, &length);
376	string = gfc_get_wide_string (length + 1)((gfc_char_t *) xcalloc ((length + 1), sizeof (gfc_char_t)));
377	gfc_wide_memset (string, 255, length);
378	}
379	else
380	{
381	length = 0;
382	string = gfc_get_wide_string (1)((gfc_char_t *) xcalloc ((1), sizeof (gfc_char_t)));
383	}
384
385	string[length] = '\0';
386	e->value.character.length = length;
387	e->value.character.string = string;
388	break;
389
390	default:
391	gcc_unreachable()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 391, __FUNCTION__));
392	}
393	}
394	else
395	gcc_unreachable()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 395, __FUNCTION__));
396	}
397
398
399	/* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul;
400	if conj_a is true, the matrix_a is complex conjugated. */
401
402	static gfc_expr *
403	compute_dot_product (gfc_expr *matrix_a, int stride_a, int offset_a,
404	gfc_expr *matrix_b, int stride_b, int offset_b,
405	bool conj_a)
406	{
407	gfc_expr result, a, b, c;
408
409	/* Set result to an INTEGER(1) 0 for numeric types and .false. for
410	LOGICAL. Mixed-mode math in the loop will promote result to the
411	correct type and kind. */
412	if (matrix_a->ts.type == BT_LOGICAL)
413	result = gfc_get_logical_expr (gfc_default_logical_kind, NULL__null, false);
414	else
415	result = gfc_get_int_expr (1, NULL__null, 0);
416	result->where = matrix_a->where;
417
418	a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a);
419	b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b);
420	while (a && b)
421	{
422	/* Copying of expressions is required as operands are free'd
423	by the gfc_arith routines. */
424	switch (result->ts.type)
425	{
426	case BT_LOGICAL:
427	result = gfc_or (result,
428	gfc_and (gfc_copy_expr (a),
429	gfc_copy_expr (b)));
430	break;
431
432	case BT_INTEGER:
433	case BT_REAL:
434	case BT_COMPLEX:
435	if (conj_a && a->ts.type == BT_COMPLEX)
436	c = gfc_simplify_conjg (a);
437	else
438	c = gfc_copy_expr (a);
439	result = gfc_add (result, gfc_multiply (c, gfc_copy_expr (b)));
440	break;
441
442	default:
443	gcc_unreachable()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 443, __FUNCTION__));
444	}
445
446	offset_a += stride_a;
447	a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a);
448
449	offset_b += stride_b;
450	b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b);
451	}
452
453	return result;
454	}
455
456
457	/* Build a result expression for transformational intrinsics,
458	depending on DIM. */
459
460	static gfc_expr *
461	transformational_result (gfc_expr array, gfc_expr dim, bt type,
462	int kind, locus* where)
463	{
464	gfc_expr *result;
465	int i, nelem;
466
467	if (!dim \|\| array->rank == 1)
468	return gfc_get_constant_expr (type, kind, where);
469
470	result = gfc_get_array_expr (type, kind, where);
471	result->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
472	result->rank = array->rank - 1;
473
474	/* gfc_array_size() would count the number of elements in the constructor,
475	we have not built those yet. */
476	nelem = 1;
477	for (i = 0; i < result->rank; ++i)
478	nelem *= mpz_get_ui__gmpz_get_ui (result->shape[i]);
479
480	for (i = 0; i < nelem; ++i)
481	{
482	gfc_constructor_append_expr (&result->value.constructor,
483	gfc_get_constant_expr (type, kind, where),
484	NULL__null);
485	}
486
487	return result;
488	}
489
490
491	typedef gfc_expr* (transformational_op)(gfc_expr, gfc_expr*);
492
493	/* Wrapper function, implements 'op1 += 1'. Only called if MASK
494	of COUNT intrinsic is .TRUE..
495
496	Interface and implementation mimics arith functions as
497	gfc_add, gfc_multiply, etc. */
498
499	static gfc_expr *
500	gfc_count (gfc_expr op1, gfc_expr op2)
501	{
502	gfc_expr *result;
503
504	gcc_assert (op1->ts.type == BT_INTEGER)((void)(!(op1->ts.type == BT_INTEGER) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 504, __FUNCTION__), 0 : 0));
505	gcc_assert (op2->ts.type == BT_LOGICAL)((void)(!(op2->ts.type == BT_LOGICAL) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 505, __FUNCTION__), 0 : 0));
506	gcc_assert (op2->value.logical)((void)(!(op2->value.logical) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 506, __FUNCTION__), 0 : 0));
507
508	result = gfc_copy_expr (op1);
509	mpz_add_ui__gmpz_add_ui (result->value.integer, result->value.integer, 1);
510
511	gfc_free_expr (op1);
512	gfc_free_expr (op2);
513	return result;
514	}
515
516
517	/* Transforms an ARRAY with operation OP, according to MASK, to a
518	scalar RESULT. E.g. called if
519
520	REAL, PARAMETER :: array(n, m) = ...
521	REAL, PARAMETER :: s = SUM(array)
522
523	where OP == gfc_add(). */
524
525	static gfc_expr *
526	simplify_transformation_to_scalar (gfc_expr result, gfc_expr array, gfc_expr *mask,
527	transformational_op op)
528	{
529	gfc_expr a, m;
530	gfc_constructor array_ctor, mask_ctor;
531
532	/* Shortcut for constant .FALSE. MASK. */
533	if (mask
534	&& mask->expr_type == EXPR_CONSTANT
535	&& !mask->value.logical)
536	return result;
537
538	array_ctor = gfc_constructor_first (array->value.constructor);
539	mask_ctor = NULL__null;
540	if (mask && mask->expr_type == EXPR_ARRAY)
541	mask_ctor = gfc_constructor_first (mask->value.constructor);
542
543	while (array_ctor)
544	{
545	a = array_ctor->expr;
546	array_ctor = gfc_constructor_next (array_ctor);
547
548	/* A constant MASK equals .TRUE. here and can be ignored. */
549	if (mask_ctor)
550	{
551	m = mask_ctor->expr;
552	mask_ctor = gfc_constructor_next (mask_ctor);
553	if (!m->value.logical)
554	continue;
555	}
556
557	result = op (result, gfc_copy_expr (a));
558	if (!result)
559	return result;
560	}
561
562	return result;
563	}
564
565	/* Transforms an ARRAY with operation OP, according to MASK, to an
566	array RESULT. E.g. called if
567
568	REAL, PARAMETER :: array(n, m) = ...
569	REAL, PARAMETER :: s(n) = PROD(array, DIM=1)
570
571	where OP == gfc_multiply().
572	The result might be post processed using post_op. */
573
574	static gfc_expr *
575	simplify_transformation_to_array (gfc_expr result, gfc_expr array, gfc_expr *dim,
576	gfc_expr *mask, transformational_op op,
577	transformational_op post_op)
578	{
579	mpz_t size;
580	int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
581	gfc_expr arrayvec, resultvec, base, src, **dest;
582	gfc_constructor array_ctor, mask_ctor, *result_ctor;
583
584	int count[GFC_MAX_DIMENSIONS15], extent[GFC_MAX_DIMENSIONS15],
585	sstride[GFC_MAX_DIMENSIONS15], dstride[GFC_MAX_DIMENSIONS15],
586	tmpstride[GFC_MAX_DIMENSIONS15];
587
588	/* Shortcut for constant .FALSE. MASK. */
589	if (mask
590	&& mask->expr_type == EXPR_CONSTANT
591	&& !mask->value.logical)
592	return result;
593
594	/* Build an indexed table for array element expressions to minimize
595	linked-list traversal. Masked elements are set to NULL. */
596	gfc_array_size (array, &size);
597	arraysize = mpz_get_ui__gmpz_get_ui (size);
598	mpz_clear__gmpz_clear (size);
599
600	arrayvec = XCNEWVEC (gfc_expr, arraysize)((gfc_expr ) xcalloc ((arraysize), sizeof (gfc_expr)));
601
602	array_ctor = gfc_constructor_first (array->value.constructor);
603	mask_ctor = NULL__null;
604	if (mask && mask->expr_type == EXPR_ARRAY)
605	mask_ctor = gfc_constructor_first (mask->value.constructor);
606
607	for (i = 0; i < arraysize; ++i)
608	{
609	arrayvec[i] = array_ctor->expr;
610	array_ctor = gfc_constructor_next (array_ctor);
611
612	if (mask_ctor)
613	{
614	if (!mask_ctor->expr->value.logical)
615	arrayvec[i] = NULL__null;
616
617	mask_ctor = gfc_constructor_next (mask_ctor);
618	}
619	}
620
621	/* Same for the result expression. */
622	gfc_array_size (result, &size);
623	resultsize = mpz_get_ui__gmpz_get_ui (size);
624	mpz_clear__gmpz_clear (size);
625
626	resultvec = XCNEWVEC (gfc_expr, resultsize)((gfc_expr ) xcalloc ((resultsize), sizeof (gfc_expr)));
627	result_ctor = gfc_constructor_first (result->value.constructor);
628	for (i = 0; i < resultsize; ++i)
629	{
630	resultvec[i] = result_ctor->expr;
631	result_ctor = gfc_constructor_next (result_ctor);
632	}
633
634	gfc_extract_int (dim, &dim_index);
635	dim_index -= 1; /* zero-base index */
636	dim_extent = 0;
637	dim_stride = 0;
638
639	for (i = 0, n = 0; i < array->rank; ++i)
640	{
641	count[i] = 0;
642	tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si__gmpz_get_si (array->shape[i-1]);
643	if (i == dim_index)
644	{
645	dim_extent = mpz_get_si__gmpz_get_si (array->shape[i]);
646	dim_stride = tmpstride[i];
647	continue;
648	}
649
650	extent[n] = mpz_get_si__gmpz_get_si (array->shape[i]);
651	sstride[n] = tmpstride[i];
652	dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
653	n += 1;
654	}
655
656	done = resultsize <= 0;
657	base = arrayvec;
658	dest = resultvec;
659	while (!done)
660	{
661	for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
662	if (*src)
663	dest = op (dest, gfc_copy_expr (*src));
664
665	if (post_op)
666	dest = post_op (dest, *dest);
667
668	count[0]++;
669	base += sstride[0];
670	dest += dstride[0];
671
672	n = 0;
673	while (!done && count[n] == extent[n])
674	{
675	count[n] = 0;
676	base -= sstride[n] * extent[n];
677	dest -= dstride[n] * extent[n];
678
679	n++;
680	if (n < result->rank)
681	{
682	/* If the nested loop is unrolled GFC_MAX_DIMENSIONS
683	times, we'd warn for the last iteration, because the
684	array index will have already been incremented to the
685	array sizes, and we can't tell that this must make
686	the test against result->rank false, because ranks
687	must not exceed GFC_MAX_DIMENSIONS. */
688	GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds)
689	count[n]++;
690	base += sstride[n];
691	dest += dstride[n];
692	GCC_DIAGNOSTIC_POP
693	}
694	else
695	done = true;
696	}
697	}
698
699	/* Place updated expression in result constructor. */
700	result_ctor = gfc_constructor_first (result->value.constructor);
701	for (i = 0; i < resultsize; ++i)
702	{
703	result_ctor->expr = resultvec[i];
704	result_ctor = gfc_constructor_next (result_ctor);
705	}
706
707	free (arrayvec);
708	free (resultvec);
709	return result;
710	}
711
712
713	static gfc_expr *
714	simplify_transformation (gfc_expr array, gfc_expr dim, gfc_expr *mask,
715	int init_val, transformational_op op)
716	{
717	gfc_expr *result;
718	bool size_zero;
719
720	size_zero = gfc_is_size_zero_array (array);
721
722	if (!(is_constant_array_expr (array) \|\| size_zero)
723	\|\| array->shape == NULL__null
724	\|\| !gfc_is_constant_expr (dim))
725	return NULL__null;
726
727	if (mask
728	&& !is_constant_array_expr (mask)
729	&& mask->expr_type != EXPR_CONSTANT)
730	return NULL__null;
731
732	result = transformational_result (array, dim, array->ts.type,
733	array->ts.kind, &array->where);
734	init_result_expr (result, init_val, array);
735
736	if (size_zero)
737	return result;
738
739	return !dim \|\| array->rank == 1 ?
740	simplify_transformation_to_scalar (result, array, mask, op) :
741	simplify_transformation_to_array (result, array, dim, mask, op, NULL__null);
742	}
743
744
745	/******************** Simplification functions ***************************/
746
747	gfc_expr *
748	gfc_simplify_abs (gfc_expr *e)
749	{
750	gfc_expr *result;
751
752	if (e->expr_type != EXPR_CONSTANT)
753	return NULL__null;
754
755	switch (e->ts.type)
756	{
757	case BT_INTEGER:
758	result = gfc_get_constant_expr (BT_INTEGER, e->ts.kind, &e->where);
759	mpz_abs__gmpz_abs (result->value.integer, e->value.integer);
760	return range_check (result, "IABS");
761
762	case BT_REAL:
763	result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
764	mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE)mpfr_set4(result->value.real,e->value.real,MPFR_RNDN,1);
765	return range_check (result, "ABS");
766
767	case BT_COMPLEX:
768	gfc_set_model_kind (e->ts.kind);
769	result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
770	mpc_abs (result->value.real, e->value.complex, GFC_RND_MODEMPFR_RNDN);
771	return range_check (result, "CABS");
772
773	default:
774	gfc_internal_error ("gfc_simplify_abs(): Bad type");
775	}
776	}
777
778
779	static gfc_expr *
780	simplify_achar_char (gfc_expr e, gfc_expr k, const char *name, bool ascii)
781	{
782	gfc_expr *result;
783	int kind;
784	bool too_large = false;
785
786	if (e->expr_type != EXPR_CONSTANT)
787	return NULL__null;
788
789	kind = get_kind (BT_CHARACTER, k, name, gfc_default_character_kind);
790	if (kind == -1)
791	return &gfc_bad_expr;
792
793	if (mpz_cmp_si (e->value.integer, 0)(__builtin_constant_p ((0) >= 0) && (0) >= 0 ? ( __builtin_constant_p ((static_cast<unsigned long> (0))) && ((static_cast<unsigned long> (0))) == 0 ? ( (e->value.integer)->_mp_size < 0 ? -1 : (e->value .integer)->_mp_size > 0) : __gmpz_cmp_ui (e->value.integer ,(static_cast<unsigned long> (0)))) : __gmpz_cmp_si (e-> value.integer,0)) < 0)
794	{
795	gfc_error ("Argument of %s function at %L is negative", name,
796	&e->where);
797	return &gfc_bad_expr;
798	}
799
800	if (ascii && warn_surprisingglobal_options.x_warn_surprising && mpz_cmp_si (e->value.integer, 127)(__builtin_constant_p ((127) >= 0) && (127) >= 0 ? (__builtin_constant_p ((static_cast<unsigned long> ( 127))) && ((static_cast<unsigned long> (127))) == 0 ? ((e->value.integer)->_mp_size < 0 ? -1 : (e-> value.integer)->_mp_size > 0) : __gmpz_cmp_ui (e->value .integer,(static_cast<unsigned long> (127)))) : __gmpz_cmp_si (e->value.integer,127)) > 0)
801	gfc_warning (OPT_Wsurprising,
802	"Argument of %s function at %L outside of range [0,127]",
803	name, &e->where);
804
805	if (kind == 1 && mpz_cmp_si (e->value.integer, 255)(__builtin_constant_p ((255) >= 0) && (255) >= 0 ? (__builtin_constant_p ((static_cast<unsigned long> ( 255))) && ((static_cast<unsigned long> (255))) == 0 ? ((e->value.integer)->_mp_size < 0 ? -1 : (e-> value.integer)->_mp_size > 0) : __gmpz_cmp_ui (e->value .integer,(static_cast<unsigned long> (255)))) : __gmpz_cmp_si (e->value.integer,255)) > 0)
806	too_large = true;
807	else if (kind == 4)
808	{
809	mpz_t t;
810	mpz_init_set_ui__gmpz_init_set_ui (t, 2);
811	mpz_pow_ui__gmpz_pow_ui (t, t, 32);
812	mpz_sub_ui__gmpz_sub_ui (t, t, 1);
813	if (mpz_cmp__gmpz_cmp (e->value.integer, t) > 0)
814	too_large = true;
815	mpz_clear__gmpz_clear (t);
816	}
817
818	if (too_large)
819	{
820	gfc_error ("Argument of %s function at %L is too large for the "
821	"collating sequence of kind %d", name, &e->where, kind);
822	return &gfc_bad_expr;
823	}
824
825	result = gfc_get_character_expr (kind, &e->where, NULL__null, 1);
826	result->value.character.string[0] = mpz_get_ui__gmpz_get_ui (e->value.integer);
827
828	return result;
829	}
830
831
832
833	/* We use the processor's collating sequence, because all
834	systems that gfortran currently works on are ASCII. */
835
836	gfc_expr *
837	gfc_simplify_achar (gfc_expr e, gfc_expr k)
838	{
839	return simplify_achar_char (e, k, "ACHAR", true);
840	}
841
842
843	gfc_expr *
844	gfc_simplify_acos (gfc_expr *x)
845	{
846	gfc_expr *result;
847
848	if (x->expr_type != EXPR_CONSTANT)
849	return NULL__null;
850
851	switch (x->ts.type)
852	{
853	case BT_REAL:
854	if (mpfr_cmp_si (x->value.real, 1)mpfr_cmp_si_2exp((x->value.real),(1),0) > 0
855	\|\| mpfr_cmp_si (x->value.real, -1)mpfr_cmp_si_2exp((x->value.real),(-1),0) < 0)
856	{
857	gfc_error ("Argument of ACOS at %L must be between -1 and 1",
858	&x->where);
859	return &gfc_bad_expr;
860	}
861	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
862	mpfr_acos (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);
863	break;
864
865	case BT_COMPLEX:
866	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
867	mpc_acos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
868	break;
869
870	default:
871	gfc_internal_error ("in gfc_simplify_acos(): Bad type");
872	}
873
874	return range_check (result, "ACOS");
875	}
876
877	gfc_expr *
878	gfc_simplify_acosh (gfc_expr *x)
879	{
880	gfc_expr *result;
881
882	if (x->expr_type != EXPR_CONSTANT)
883	return NULL__null;
884
885	switch (x->ts.type)
886	{
887	case BT_REAL:
888	if (mpfr_cmp_si (x->value.real, 1)mpfr_cmp_si_2exp((x->value.real),(1),0) < 0)
889	{
890	gfc_error ("Argument of ACOSH at %L must not be less than 1",
891	&x->where);
892	return &gfc_bad_expr;
893	}
894
895	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
896	mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);
897	break;
898
899	case BT_COMPLEX:
900	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
901	mpc_acosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
902	break;
903
904	default:
905	gfc_internal_error ("in gfc_simplify_acosh(): Bad type");
906	}
907
908	return range_check (result, "ACOSH");
909	}
910
911	gfc_expr *
912	gfc_simplify_adjustl (gfc_expr *e)
913	{
914	gfc_expr *result;
915	int count, i, len;
916	gfc_char_t ch;
917
918	if (e->expr_type != EXPR_CONSTANT)
919	return NULL__null;
920
921	len = e->value.character.length;
922
923	for (count = 0, i = 0; i < len; ++i)
924	{
925	ch = e->value.character.string[i];
926	if (ch != ' ')
927	break;
928	++count;
929	}
930
931	result = gfc_get_character_expr (e->ts.kind, &e->where, NULL__null, len);
932	for (i = 0; i < len - count; ++i)
933	result->value.character.string[i] = e->value.character.string[count + i];
934
935	return result;
936	}
937
938
939	gfc_expr *
940	gfc_simplify_adjustr (gfc_expr *e)
941	{
942	gfc_expr *result;
943	int count, i, len;
944	gfc_char_t ch;
945
946	if (e->expr_type != EXPR_CONSTANT)
947	return NULL__null;
948
949	len = e->value.character.length;
950
951	for (count = 0, i = len - 1; i >= 0; --i)
952	{
953	ch = e->value.character.string[i];
954	if (ch != ' ')
955	break;
956	++count;
957	}
958
959	result = gfc_get_character_expr (e->ts.kind, &e->where, NULL__null, len);
960	for (i = 0; i < count; ++i)
961	result->value.character.string[i] = ' ';
962
963	for (i = count; i < len; ++i)
964	result->value.character.string[i] = e->value.character.string[i - count];
965
966	return result;
967	}
968
969
970	gfc_expr *
971	gfc_simplify_aimag (gfc_expr *e)
972	{
973	gfc_expr *result;
974
975	if (e->expr_type != EXPR_CONSTANT)
976	return NULL__null;
977
978	result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
979	mpfr_set (result->value.real, mpc_imagref (e->value.complex), GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (((e->value.complex)-> im)); mpfr_set4(result->value.real,_p,MPFR_RNDN,((_p)-> _mpfr_sign)); });
980
981	return range_check (result, "AIMAG");
982	}
983
984
985	gfc_expr *
986	gfc_simplify_aint (gfc_expr e, gfc_expr k)
987	{
988	gfc_expr rtrunc, result;
989	int kind;
990
991	kind = get_kind (BT_REAL, k, "AINT", e->ts.kind);
992	if (kind == -1)
993	return &gfc_bad_expr;
994
995	if (e->expr_type != EXPR_CONSTANT)
996	return NULL__null;
997
998	rtrunc = gfc_copy_expr (e);
999	mpfr_trunc (rtrunc->value.real, e->value.real)mpfr_rint((rtrunc->value.real), (e->value.real), MPFR_RNDZ );
1000
1001	result = gfc_real2real (rtrunc, kind);
1002
1003	gfc_free_expr (rtrunc);
1004
1005	return range_check (result, "AINT");
1006	}
1007
1008
1009	gfc_expr *
1010	gfc_simplify_all (gfc_expr mask, gfc_expr dim)
1011	{
1012	return simplify_transformation (mask, dim, NULL__null, true, gfc_and);
1013	}
1014
1015
1016	gfc_expr *
1017	gfc_simplify_dint (gfc_expr *e)
1018	{
1019	gfc_expr rtrunc, result;
1020
1021	if (e->expr_type != EXPR_CONSTANT)
1022	return NULL__null;
1023
1024	rtrunc = gfc_copy_expr (e);
1025	mpfr_trunc (rtrunc->value.real, e->value.real)mpfr_rint((rtrunc->value.real), (e->value.real), MPFR_RNDZ );
1026
1027	result = gfc_real2real (rtrunc, gfc_default_double_kind);
1028
1029	gfc_free_expr (rtrunc);
1030
1031	return range_check (result, "DINT");
1032	}
1033
1034
1035	gfc_expr *
1036	gfc_simplify_dreal (gfc_expr *e)
1037	{
1038	gfc_expr *result = NULL__null;
1039
1040	if (e->expr_type != EXPR_CONSTANT)
1041	return NULL__null;
1042
1043	result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
1044	mpc_real (result->value.real, e->value.complex, GFC_RND_MODEMPFR_RNDN);
1045
1046	return range_check (result, "DREAL");
1047	}
1048
1049
1050	gfc_expr *
1051	gfc_simplify_anint (gfc_expr e, gfc_expr k)
1052	{
1053	gfc_expr *result;
1054	int kind;
1055
1056	kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind);
1057	if (kind == -1)
1058	return &gfc_bad_expr;
1059
1060	if (e->expr_type != EXPR_CONSTANT)
1061	return NULL__null;
1062
1063	result = gfc_get_constant_expr (e->ts.type, kind, &e->where);
1064	mpfr_round (result->value.real, e->value.real)mpfr_rint((result->value.real), (e->value.real), MPFR_RNDNA );
1065
1066	return range_check (result, "ANINT");
1067	}
1068
1069
1070	gfc_expr *
1071	gfc_simplify_and (gfc_expr x, gfc_expr y)
1072	{
1073	gfc_expr *result;
1074	int kind;
1075
1076	if (x->expr_type != EXPR_CONSTANT \|\| y->expr_type != EXPR_CONSTANT)
1077	return NULL__null;
1078
1079	kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
1080
1081	switch (x->ts.type)
1082	{
1083	case BT_INTEGER:
1084	result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
1085	mpz_and__gmpz_and (result->value.integer, x->value.integer, y->value.integer);
1086	return range_check (result, "AND");
1087
1088	case BT_LOGICAL:
1089	return gfc_get_logical_expr (kind, &x->where,
1090	x->value.logical && y->value.logical);
1091
1092	default:
1093	gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 1093, __FUNCTION__));
1094	}
1095	}
1096
1097
1098	gfc_expr *
1099	gfc_simplify_any (gfc_expr mask, gfc_expr dim)
1100	{
1101	return simplify_transformation (mask, dim, NULL__null, false, gfc_or);
1102	}
1103
1104
1105	gfc_expr *
1106	gfc_simplify_dnint (gfc_expr *e)
1107	{
1108	gfc_expr *result;
1109
1110	if (e->expr_type != EXPR_CONSTANT)
1111	return NULL__null;
1112
1113	result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &e->where);
1114	mpfr_round (result->value.real, e->value.real)mpfr_rint((result->value.real), (e->value.real), MPFR_RNDNA );
1115
1116	return range_check (result, "DNINT");
1117	}
1118
1119
1120	gfc_expr *
1121	gfc_simplify_asin (gfc_expr *x)
1122	{
1123	gfc_expr *result;
1124
1125	if (x->expr_type != EXPR_CONSTANT)
1126	return NULL__null;
1127
1128	switch (x->ts.type)
1129	{
1130	case BT_REAL:
1131	if (mpfr_cmp_si (x->value.real, 1)mpfr_cmp_si_2exp((x->value.real),(1),0) > 0
1132	\|\| mpfr_cmp_si (x->value.real, -1)mpfr_cmp_si_2exp((x->value.real),(-1),0) < 0)
1133	{
1134	gfc_error ("Argument of ASIN at %L must be between -1 and 1",
1135	&x->where);
1136	return &gfc_bad_expr;
1137	}
1138	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1139	mpfr_asin (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);
1140	break;
1141
1142	case BT_COMPLEX:
1143	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1144	mpc_asin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
1145	break;
1146
1147	default:
1148	gfc_internal_error ("in gfc_simplify_asin(): Bad type");
1149	}
1150
1151	return range_check (result, "ASIN");
1152	}
1153
1154
1155	/* Convert radians to degrees, i.e., x * 180 / pi. */
1156
1157	static void
1158	rad2deg (mpfr_t x)
1159	{
1160	mpfr_t tmp;
1161
1162	mpfr_init (tmp);
1163	mpfr_const_pi (tmp, GFC_RND_MODEMPFR_RNDN);
1164	mpfr_mul_ui (x, x, 180, GFC_RND_MODEMPFR_RNDN);
1165	mpfr_div (x, x, tmp, GFC_RND_MODEMPFR_RNDN);
1166	mpfr_clear (tmp);
1167	}
1168
1169
1170	/* Simplify ACOSD(X) where the returned value has units of degree. */
1171
1172	gfc_expr *
1173	gfc_simplify_acosd (gfc_expr *x)
1174	{
1175	gfc_expr *result;
1176
1177	if (x->expr_type != EXPR_CONSTANT)
1178	return NULL__null;
1179
1180	if (mpfr_cmp_si (x->value.real, 1)mpfr_cmp_si_2exp((x->value.real),(1),0) > 0
1181	\|\| mpfr_cmp_si (x->value.real, -1)mpfr_cmp_si_2exp((x->value.real),(-1),0) < 0)
1182	{
1183	gfc_error ("Argument of ACOSD at %L must be between -1 and 1",
1184	&x->where);
1185	return &gfc_bad_expr;
1186	}
1187
1188	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1189	mpfr_acos (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);
1190	rad2deg (result->value.real);
1191
1192	return range_check (result, "ACOSD");
1193	}
1194
1195
1196	/* Simplify asind (x) where the returned value has units of degree. */
1197
1198	gfc_expr *
1199	gfc_simplify_asind (gfc_expr *x)
1200	{
1201	gfc_expr *result;
1202
1203	if (x->expr_type != EXPR_CONSTANT)
1204	return NULL__null;
1205
1206	if (mpfr_cmp_si (x->value.real, 1)mpfr_cmp_si_2exp((x->value.real),(1),0) > 0
1207	\|\| mpfr_cmp_si (x->value.real, -1)mpfr_cmp_si_2exp((x->value.real),(-1),0) < 0)
1208	{
1209	gfc_error ("Argument of ASIND at %L must be between -1 and 1",
1210	&x->where);
1211	return &gfc_bad_expr;
1212	}
1213
1214	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1215	mpfr_asin (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);
1216	rad2deg (result->value.real);
1217
1218	return range_check (result, "ASIND");
1219	}
1220
1221
1222	/* Simplify atand (x) where the returned value has units of degree. */
1223
1224	gfc_expr *
1225	gfc_simplify_atand (gfc_expr *x)
1226	{
1227	gfc_expr *result;
1228
1229	if (x->expr_type != EXPR_CONSTANT)
1230	return NULL__null;
1231
1232	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1233	mpfr_atan (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);
1234	rad2deg (result->value.real);
1235
1236	return range_check (result, "ATAND");
1237	}
1238
1239
1240	gfc_expr *
1241	gfc_simplify_asinh (gfc_expr *x)
1242	{
1243	gfc_expr *result;
1244
1245	if (x->expr_type != EXPR_CONSTANT)
1246	return NULL__null;
1247
1248	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1249
1250	switch (x->ts.type)
1251	{
1252	case BT_REAL:
1253	mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);
1254	break;
1255
1256	case BT_COMPLEX:
1257	mpc_asinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
1258	break;
1259
1260	default:
1261	gfc_internal_error ("in gfc_simplify_asinh(): Bad type");
1262	}
1263
1264	return range_check (result, "ASINH");
1265	}
1266
1267
1268	gfc_expr *
1269	gfc_simplify_atan (gfc_expr *x)
1270	{
1271	gfc_expr *result;
1272
1273	if (x->expr_type != EXPR_CONSTANT)
1274	return NULL__null;
1275
1276	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1277
1278	switch (x->ts.type)
1279	{
1280	case BT_REAL:
1281	mpfr_atan (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);
1282	break;
1283
1284	case BT_COMPLEX:
1285	mpc_atan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
1286	break;
1287
1288	default:
1289	gfc_internal_error ("in gfc_simplify_atan(): Bad type");
1290	}
1291
1292	return range_check (result, "ATAN");
1293	}
1294
1295
1296	gfc_expr *
1297	gfc_simplify_atanh (gfc_expr *x)
1298	{
1299	gfc_expr *result;
1300
1301	if (x->expr_type != EXPR_CONSTANT)
1302	return NULL__null;
1303
1304	switch (x->ts.type)
1305	{
1306	case BT_REAL:
1307	if (mpfr_cmp_si (x->value.real, 1)mpfr_cmp_si_2exp((x->value.real),(1),0) >= 0
1308	\|\| mpfr_cmp_si (x->value.real, -1)mpfr_cmp_si_2exp((x->value.real),(-1),0) <= 0)
1309	{
1310	gfc_error ("Argument of ATANH at %L must be inside the range -1 "
1311	"to 1", &x->where);
1312	return &gfc_bad_expr;
1313	}
1314	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1315	mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);
1316	break;
1317
1318	case BT_COMPLEX:
1319	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1320	mpc_atanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
1321	break;
1322
1323	default:
1324	gfc_internal_error ("in gfc_simplify_atanh(): Bad type");
1325	}
1326
1327	return range_check (result, "ATANH");
1328	}
1329
1330
1331	gfc_expr *
1332	gfc_simplify_atan2 (gfc_expr y, gfc_expr x)
1333	{
1334	gfc_expr *result;
1335
1336	if (x->expr_type != EXPR_CONSTANT \|\| y->expr_type != EXPR_CONSTANT)
1337	return NULL__null;
1338
1339	if (mpfr_zero_p (y->value.real)(((mpfr_srcptr) (0 ? (y->value.real) : (mpfr_srcptr) (y-> value.real)))->_mpfr_exp == (0 - ((mpfr_exp_t) (((mpfr_uexp_t ) -1) >> 1)))) && mpfr_zero_p (x->value.real)(((mpfr_srcptr) (0 ? (x->value.real) : (mpfr_srcptr) (x-> value.real)))->_mpfr_exp == (0 - ((mpfr_exp_t) (((mpfr_uexp_t ) -1) >> 1)))))
1340	{
1341	gfc_error ("If first argument of ATAN2 at %L is zero, then the "
1342	"second argument must not be zero", &y->where);
1343	return &gfc_bad_expr;
1344	}
1345
1346	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1347	mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);
1348
1349	return range_check (result, "ATAN2");
1350	}
1351
1352
1353	gfc_expr *
1354	gfc_simplify_bessel_j0 (gfc_expr *x)
1355	{
1356	gfc_expr *result;
1357
1358	if (x->expr_type != EXPR_CONSTANT)
1359	return NULL__null;
1360
1361	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1362	mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);
1363
1364	return range_check (result, "BESSEL_J0");
1365	}
1366
1367
1368	gfc_expr *
1369	gfc_simplify_bessel_j1 (gfc_expr *x)
1370	{
1371	gfc_expr *result;
1372
1373	if (x->expr_type != EXPR_CONSTANT)
1374	return NULL__null;
1375
1376	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1377	mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);
1378
1379	return range_check (result, "BESSEL_J1");
1380	}
1381
1382
1383	gfc_expr *
1384	gfc_simplify_bessel_jn (gfc_expr order, gfc_expr x)
1385	{
1386	gfc_expr *result;
1387	long n;
1388
1389	if (x->expr_type != EXPR_CONSTANT \|\| order->expr_type != EXPR_CONSTANT)
1390	return NULL__null;
1391
1392	n = mpz_get_si__gmpz_get_si (order->value.integer);
1393	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1394	mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODEMPFR_RNDN);
1395
1396	return range_check (result, "BESSEL_JN");
1397	}
1398
1399
1400	/* Simplify transformational form of JN and YN. */
1401
1402	static gfc_expr *
1403	gfc_simplify_bessel_n2 (gfc_expr order1, gfc_expr order2, gfc_expr *x,
1404	bool jn)
1405	{
1406	gfc_expr *result;
1407	gfc_expr *e;
1408	long n1, n2;
1409	int i;
1410	mpfr_t x2rev, last1, last2;
1411
1412	if (x->expr_type != EXPR_CONSTANT \|\| order1->expr_type != EXPR_CONSTANT
1413	\|\| order2->expr_type != EXPR_CONSTANT)
1414	return NULL__null;
1415
1416	n1 = mpz_get_si__gmpz_get_si (order1->value.integer);
1417	n2 = mpz_get_si__gmpz_get_si (order2->value.integer);
1418	result = gfc_get_array_expr (x->ts.type, x->ts.kind, &x->where);
1419	result->rank = 1;
1420	result->shape = gfc_get_shape (1)(((mpz_t *) xcalloc (((1)), sizeof (mpz_t))));
1421	mpz_init_set_ui__gmpz_init_set_ui (result->shape[0], MAX (n2-n1+1, 0)((n2-n1+1) > (0) ? (n2-n1+1) : (0)));
1422
1423	if (n2 < n1)
1424	return result;
1425
1426	/* Special case: x == 0; it is J0(0.0) == 1, JN(N > 0, 0.0) == 0; and
1427	YN(N, 0.0) = -Inf. */
1428
1429	if (mpfr_cmp_ui (x->value.real, 0.0)mpfr_cmp_ui_2exp((x->value.real),(0.0),0) == 0)
1430	{
1431	if (!jn && flag_range_checkglobal_options.x_flag_range_check)
1432	{
1433	gfc_error ("Result of BESSEL_YN is -INF at %L", &result->where);
1434	gfc_free_expr (result);
1435	return &gfc_bad_expr;
1436	}
1437
1438	if (jn && n1 == 0)
1439	{
1440	e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1441	mpfr_set_ui (e->value.real, 1, GFC_RND_MODEMPFR_RNDN);
1442	gfc_constructor_append_expr (&result->value.constructor, e,
1443	&x->where);
1444	n1++;
1445	}
1446
1447	for (i = n1; i <= n2; i++)
1448	{
1449	e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1450	if (jn)
1451	mpfr_set_ui (e->value.real, 0, GFC_RND_MODEMPFR_RNDN);
1452	else
1453	mpfr_set_inf (e->value.real, -1);
1454	gfc_constructor_append_expr (&result->value.constructor, e,
1455	&x->where);
1456	}
1457
1458	return result;
1459	}
1460
1461	/* Use the faster but more verbose recurrence algorithm. Bessel functions
1462	are stable for downward recursion and Neumann functions are stable
1463	for upward recursion. It is
1464	x2rev = 2.0/x,
1465	J(N-1, x) = x2rev * N * J(N, x) - J(N+1, x),
1466	Y(N+1, x) = x2rev * N * Y(N, x) - Y(N-1, x).
1467	Cf. http://dlmf.nist.gov/10.74#iv and http://dlmf.nist.gov/10.6#E1 */
1468
1469	gfc_set_model_kind (x->ts.kind);
1470
1471	/* Get first recursion anchor. */
1472
1473	mpfr_init (last1);
1474	if (jn)
1475	mpfr_jn (last1, n2, x->value.real, GFC_RND_MODEMPFR_RNDN);
1476	else
1477	mpfr_yn (last1, n1, x->value.real, GFC_RND_MODEMPFR_RNDN);
1478
1479	e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1480	mpfr_set (e->value.real, last1, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (last1); mpfr_set4(e->value .real,_p,MPFR_RNDN,((_p)->_mpfr_sign)); });
1481	if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
1482	{
1483	mpfr_clear (last1);
1484	gfc_free_expr (e);
1485	gfc_free_expr (result);
1486	return &gfc_bad_expr;
1487	}
1488	gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
1489
1490	if (n1 == n2)
1491	{
1492	mpfr_clear (last1);
1493	return result;
1494	}
1495
1496	/* Get second recursion anchor. */
1497
1498	mpfr_init (last2);
1499	if (jn)
1500	mpfr_jn (last2, n2-1, x->value.real, GFC_RND_MODEMPFR_RNDN);
1501	else
1502	mpfr_yn (last2, n1+1, x->value.real, GFC_RND_MODEMPFR_RNDN);
1503
1504	e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1505	mpfr_set (e->value.real, last2, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (last2); mpfr_set4(e->value .real,_p,MPFR_RNDN,((_p)->_mpfr_sign)); });
1506	if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
1507	{
1508	mpfr_clear (last1);
1509	mpfr_clear (last2);
1510	gfc_free_expr (e);
1511	gfc_free_expr (result);
1512	return &gfc_bad_expr;
1513	}
1514	if (jn)
1515	gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, -2);
1516	else
1517	gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
1518
1519	if (n1 + 1 == n2)
1520	{
1521	mpfr_clear (last1);
1522	mpfr_clear (last2);
1523	return result;
1524	}
1525
1526	/* Start actual recursion. */
1527
1528	mpfr_init (x2rev);
1529	mpfr_ui_div (x2rev, 2, x->value.real, GFC_RND_MODEMPFR_RNDN);
1530
1531	for (i = 2; i <= n2-n1; i++)
1532	{
1533	e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1534
1535	/* Special case: For YN, if the previous N gave -INF, set
1536	also N+1 to -INF. */
1537	if (!jn && !flag_range_checkglobal_options.x_flag_range_check && mpfr_inf_p (last2)(((mpfr_srcptr) (0 ? (last2) : (mpfr_srcptr) (last2)))->_mpfr_exp == (2 - ((mpfr_exp_t) (((mpfr_uexp_t) -1) >> 1)))))
1538	{
1539	mpfr_set_inf (e->value.real, -1);
1540	gfc_constructor_append_expr (&result->value.constructor, e,
1541	&x->where);
1542	continue;
1543	}
1544
1545	mpfr_mul_si (e->value.real, x2rev, jn ? (n2-i+1) : (n1+i-1),
1546	GFC_RND_MODEMPFR_RNDN);
1547	mpfr_mul (e->value.real, e->value.real, last2, GFC_RND_MODEMPFR_RNDN);
1548	mpfr_sub (e->value.real, e->value.real, last1, GFC_RND_MODEMPFR_RNDN);
1549
1550	if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
1551	{
1552	/* Range_check frees "e" in that case. */
1553	e = NULL__null;
1554	goto error;
1555	}
1556
1557	if (jn)
1558	gfc_constructor_insert_expr (&result->value.constructor, e, &x->where,
1559	-i-1);
1560	else
1561	gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
1562
1563	mpfr_set (last1, last2, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (last2); mpfr_set4(last1,_p ,MPFR_RNDN,((_p)->_mpfr_sign)); });
1564	mpfr_set (last2, e->value.real, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (e->value.real); mpfr_set4 (last2,_p,MPFR_RNDN,((_p)->_mpfr_sign)); });
1565	}
1566
1567	mpfr_clear (last1);
1568	mpfr_clear (last2);
1569	mpfr_clear (x2rev);
1570	return result;
1571
1572	error:
1573	mpfr_clear (last1);
1574	mpfr_clear (last2);
1575	mpfr_clear (x2rev);
1576	gfc_free_expr (e);
1577	gfc_free_expr (result);
1578	return &gfc_bad_expr;
1579	}
1580
1581
1582	gfc_expr *
1583	gfc_simplify_bessel_jn2 (gfc_expr order1, gfc_expr order2, gfc_expr *x)
1584	{
1585	return gfc_simplify_bessel_n2 (order1, order2, x, true);
1586	}
1587
1588
1589	gfc_expr *
1590	gfc_simplify_bessel_y0 (gfc_expr *x)
1591	{
1592	gfc_expr *result;
1593
1594	if (x->expr_type != EXPR_CONSTANT)
1595	return NULL__null;
1596
1597	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1598	mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);
1599
1600	return range_check (result, "BESSEL_Y0");
1601	}
1602
1603
1604	gfc_expr *
1605	gfc_simplify_bessel_y1 (gfc_expr *x)
1606	{
1607	gfc_expr *result;
1608
1609	if (x->expr_type != EXPR_CONSTANT)
1610	return NULL__null;
1611
1612	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1613	mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);
1614
1615	return range_check (result, "BESSEL_Y1");
1616	}
1617
1618
1619	gfc_expr *
1620	gfc_simplify_bessel_yn (gfc_expr order, gfc_expr x)
1621	{
1622	gfc_expr *result;
1623	long n;
1624
1625	if (x->expr_type != EXPR_CONSTANT \|\| order->expr_type != EXPR_CONSTANT)
1626	return NULL__null;
1627
1628	n = mpz_get_si__gmpz_get_si (order->value.integer);
1629	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1630	mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODEMPFR_RNDN);
1631
1632	return range_check (result, "BESSEL_YN");
1633	}
1634
1635
1636	gfc_expr *
1637	gfc_simplify_bessel_yn2 (gfc_expr order1, gfc_expr order2, gfc_expr *x)
1638	{
1639	return gfc_simplify_bessel_n2 (order1, order2, x, false);
1640	}
1641
1642
1643	gfc_expr *
1644	gfc_simplify_bit_size (gfc_expr *e)
1645	{
1646	int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1647	return gfc_get_int_expr (e->ts.kind, &e->where,
1648	gfc_integer_kinds[i].bit_size);
1649	}
1650
1651
1652	gfc_expr *
1653	gfc_simplify_btest (gfc_expr e, gfc_expr bit)
1654	{
1655	int b;
1656
1657	if (e->expr_type != EXPR_CONSTANT \|\| bit->expr_type != EXPR_CONSTANT)
1658	return NULL__null;
1659
1660	if (!gfc_check_bitfcn (e, bit))
1661	return &gfc_bad_expr;
1662
1663	if (gfc_extract_int (bit, &b) \|\| b < 0)
1664	return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, false);
1665
1666	return gfc_get_logical_expr (gfc_default_logical_kind, &e->where,
1667	mpz_tstbit__gmpz_tstbit (e->value.integer, b));
1668	}
1669
1670
1671	static int
1672	compare_bitwise (gfc_expr i, gfc_expr j)
1673	{
1674	mpz_t x, y;
1675	int k, res;
1676
1677	gcc_assert (i->ts.type == BT_INTEGER)((void)(!(i->ts.type == BT_INTEGER) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 1677, __FUNCTION__), 0 : 0));
1678	gcc_assert (j->ts.type == BT_INTEGER)((void)(!(j->ts.type == BT_INTEGER) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 1678, __FUNCTION__), 0 : 0));
1679
1680	mpz_init_set__gmpz_init_set (x, i->value.integer);
1681	k = gfc_validate_kind (i->ts.type, i->ts.kind, false);
1682	convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
1683
1684	mpz_init_set__gmpz_init_set (y, j->value.integer);
1685	k = gfc_validate_kind (j->ts.type, j->ts.kind, false);
1686	convert_mpz_to_unsigned (y, gfc_integer_kinds[k].bit_size);
1687
1688	res = mpz_cmp__gmpz_cmp (x, y);
1689	mpz_clear__gmpz_clear (x);
1690	mpz_clear__gmpz_clear (y);
1691	return res;
1692	}
1693
1694
1695	gfc_expr *
1696	gfc_simplify_bge (gfc_expr i, gfc_expr j)
1697	{
1698	if (i->expr_type != EXPR_CONSTANT \|\| j->expr_type != EXPR_CONSTANT)
1699	return NULL__null;
1700
1701	return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
1702	compare_bitwise (i, j) >= 0);
1703	}
1704
1705
1706	gfc_expr *
1707	gfc_simplify_bgt (gfc_expr i, gfc_expr j)
1708	{
1709	if (i->expr_type != EXPR_CONSTANT \|\| j->expr_type != EXPR_CONSTANT)
1710	return NULL__null;
1711
1712	return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
1713	compare_bitwise (i, j) > 0);
1714	}
1715
1716
1717	gfc_expr *
1718	gfc_simplify_ble (gfc_expr i, gfc_expr j)
1719	{
1720	if (i->expr_type != EXPR_CONSTANT \|\| j->expr_type != EXPR_CONSTANT)
1721	return NULL__null;
1722
1723	return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
1724	compare_bitwise (i, j) <= 0);
1725	}
1726
1727
1728	gfc_expr *
1729	gfc_simplify_blt (gfc_expr i, gfc_expr j)
1730	{
1731	if (i->expr_type != EXPR_CONSTANT \|\| j->expr_type != EXPR_CONSTANT)
1732	return NULL__null;
1733
1734	return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
1735	compare_bitwise (i, j) < 0);
1736	}
1737
1738
1739	gfc_expr *
1740	gfc_simplify_ceiling (gfc_expr e, gfc_expr k)
1741	{
1742	gfc_expr ceil, result;
1743	int kind;
1744
1745	kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind);
1746	if (kind == -1)
1747	return &gfc_bad_expr;
1748
1749	if (e->expr_type != EXPR_CONSTANT)
1750	return NULL__null;
1751
1752	ceil = gfc_copy_expr (e);
1753	mpfr_ceil (ceil->value.real, e->value.real)mpfr_rint((ceil->value.real), (e->value.real), MPFR_RNDU );
1754
1755	result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
1756	gfc_mpfr_to_mpz (result->value.integer, ceil->value.real, &e->where);
1757
1758	gfc_free_expr (ceil);
1759
1760	return range_check (result, "CEILING");
1761	}
1762
1763
1764	gfc_expr *
1765	gfc_simplify_char (gfc_expr e, gfc_expr k)
1766	{
1767	return simplify_achar_char (e, k, "CHAR", false);
1768	}
1769
1770
1771	/* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX. */
1772
1773	static gfc_expr *
1774	simplify_cmplx (const char name, gfc_expr x, gfc_expr *y, int kind)
1775	{
1776	gfc_expr *result;
1777
1778	if (x->expr_type != EXPR_CONSTANT
1779	\|\| (y != NULL__null && y->expr_type != EXPR_CONSTANT))
1780	return NULL__null;
1781
1782	result = gfc_get_constant_expr (BT_COMPLEX, kind, &x->where);
1783
1784	switch (x->ts.type)
1785	{
1786	case BT_INTEGER:
1787	mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
1788	break;
1789
1790	case BT_REAL:
1791	mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODEMPFR_RNDN);
1792	break;
1793
1794	case BT_COMPLEX:
1795	mpc_set (result->value.complex, x->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
1796	break;
1797
1798	default:
1799	gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
1800	}
1801
1802	if (!y)
1803	return range_check (result, name);
1804
1805	switch (y->ts.type)
1806	{
1807	case BT_INTEGER:
1808	mpfr_set_z (mpc_imagref (result->value.complex)((result->value.complex)->im),
1809	y->value.integer, GFC_RND_MODEMPFR_RNDN);
1810	break;
1811
1812	case BT_REAL:
1813	mpfr_set (mpc_imagref (result->value.complex),__extension__ ({ mpfr_srcptr _p = (y->value.real); mpfr_set4 (((result->value.complex)->im),_p,MPFR_RNDN,((_p)->_mpfr_sign )); })
1814	y->value.real, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (y->value.real); mpfr_set4 (((result->value.complex)->im),_p,MPFR_RNDN,((_p)->_mpfr_sign )); });
1815	break;
1816
1817	default:
1818	gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
1819	}
1820
1821	return range_check (result, name);
1822	}
1823
1824
1825	gfc_expr *
1826	gfc_simplify_cmplx (gfc_expr x, gfc_expr y, gfc_expr *k)
1827	{
1828	int kind;
1829
1830	kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_complex_kind);
1831	if (kind == -1)
1832	return &gfc_bad_expr;
1833
1834	return simplify_cmplx ("CMPLX", x, y, kind);
1835	}
1836
1837
1838	gfc_expr *
1839	gfc_simplify_complex (gfc_expr x, gfc_expr y)
1840	{
1841	int kind;
1842
1843	if (x->ts.type == BT_INTEGER && y->ts.type == BT_INTEGER)
1844	kind = gfc_default_complex_kind;
1845	else if (x->ts.type == BT_REAL \|\| y->ts.type == BT_INTEGER)
1846	kind = x->ts.kind;
1847	else if (x->ts.type == BT_INTEGER \|\| y->ts.type == BT_REAL)
1848	kind = y->ts.kind;
1849	else if (x->ts.type == BT_REAL && y->ts.type == BT_REAL)
1850	kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
1851	else
1852	gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 1852, __FUNCTION__));
1853
1854	return simplify_cmplx ("COMPLEX", x, y, kind);
1855	}
1856
1857
1858	gfc_expr *
1859	gfc_simplify_conjg (gfc_expr *e)
1860	{
1861	gfc_expr *result;
1862
1863	if (e->expr_type != EXPR_CONSTANT)
1864	return NULL__null;
1865
1866	result = gfc_copy_expr (e);
1867	mpc_conj (result->value.complex, result->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
1868
1869	return range_check (result, "CONJG");
1870	}
1871
1872
1873	/* Simplify atan2d (x) where the unit is degree. */
1874
1875	gfc_expr *
1876	gfc_simplify_atan2d (gfc_expr y, gfc_expr x)
1877	{
1878	gfc_expr *result;
1879
1880	if (x->expr_type != EXPR_CONSTANT \|\| y->expr_type != EXPR_CONSTANT)
1881	return NULL__null;
1882
1883	if (mpfr_zero_p (y->value.real)(((mpfr_srcptr) (0 ? (y->value.real) : (mpfr_srcptr) (y-> value.real)))->_mpfr_exp == (0 - ((mpfr_exp_t) (((mpfr_uexp_t ) -1) >> 1)))) && mpfr_zero_p (x->value.real)(((mpfr_srcptr) (0 ? (x->value.real) : (mpfr_srcptr) (x-> value.real)))->_mpfr_exp == (0 - ((mpfr_exp_t) (((mpfr_uexp_t ) -1) >> 1)))))
1884	{
1885	gfc_error ("If first argument of ATAN2D at %L is zero, then the "
1886	"second argument must not be zero", &y->where);
1887	return &gfc_bad_expr;
1888	}
1889
1890	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1891	mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);
1892	rad2deg (result->value.real);
1893
1894	return range_check (result, "ATAN2D");
1895	}
1896
1897
1898	gfc_expr *
1899	gfc_simplify_cos (gfc_expr *x)
1900	{
1901	gfc_expr *result;
1902
1903	if (x->expr_type != EXPR_CONSTANT)
1904	return NULL__null;
1905
1906	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1907
1908	switch (x->ts.type)
1909	{
1910	case BT_REAL:
1911	mpfr_cos (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);
1912	break;
1913
1914	case BT_COMPLEX:
1915	gfc_set_model_kind (x->ts.kind);
1916	mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
1917	break;
1918
1919	default:
1920	gfc_internal_error ("in gfc_simplify_cos(): Bad type");
1921	}
1922
1923	return range_check (result, "COS");
1924	}
1925
1926
1927	static void
1928	deg2rad (mpfr_t x)
1929	{
1930	mpfr_t d2r;
1931
1932	mpfr_init (d2r);
1933	mpfr_const_pi (d2r, GFC_RND_MODEMPFR_RNDN);
1934	mpfr_div_ui (d2r, d2r, 180, GFC_RND_MODEMPFR_RNDN);
1935	mpfr_mul (x, x, d2r, GFC_RND_MODEMPFR_RNDN);
1936	mpfr_clear (d2r);
1937	}
1938
1939
1940	/* Simplification routines for SIND, COSD, TAND. */
1941	#include "trigd_fe.inc"
1942
1943
1944	/* Simplify COSD(X) where X has the unit of degree. */
1945
1946	gfc_expr *
1947	gfc_simplify_cosd (gfc_expr *x)
1948	{
1949	gfc_expr *result;
1950
1951	if (x->expr_type != EXPR_CONSTANT)
1952	return NULL__null;
1953
1954	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1955	mpfr_set (result->value.real, x->value.real, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (x->value.real); mpfr_set4 (result->value.real,_p,MPFR_RNDN,((_p)->_mpfr_sign)); } );
1956	simplify_cosd (result->value.real);
1957
1958	return range_check (result, "COSD");
1959	}
1960
1961
1962	/* Simplify SIND(X) where X has the unit of degree. */
1963
1964	gfc_expr *
1965	gfc_simplify_sind (gfc_expr *x)
1966	{
1967	gfc_expr *result;
1968
1969	if (x->expr_type != EXPR_CONSTANT)
1970	return NULL__null;
1971
1972	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1973	mpfr_set (result->value.real, x->value.real, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (x->value.real); mpfr_set4 (result->value.real,_p,MPFR_RNDN,((_p)->_mpfr_sign)); } );
1974	simplify_sind (result->value.real);
1975
1976	return range_check (result, "SIND");
1977	}
1978
1979
1980	/* Simplify TAND(X) where X has the unit of degree. */
1981
1982	gfc_expr *
1983	gfc_simplify_tand (gfc_expr *x)
1984	{
1985	gfc_expr *result;
1986
1987	if (x->expr_type != EXPR_CONSTANT)
1988	return NULL__null;
1989
1990	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1991	mpfr_set (result->value.real, x->value.real, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (x->value.real); mpfr_set4 (result->value.real,_p,MPFR_RNDN,((_p)->_mpfr_sign)); } );
1992	simplify_tand (result->value.real);
1993
1994	return range_check (result, "TAND");
1995	}
1996
1997
1998	/* Simplify COTAND(X) where X has the unit of degree. */
1999
2000	gfc_expr *
2001	gfc_simplify_cotand (gfc_expr *x)
2002	{
2003	gfc_expr *result;
2004
2005	if (x->expr_type != EXPR_CONSTANT)
2006	return NULL__null;
2007
2008	/* Implement COTAND = -TAND(x+90).
2009	TAND offers correct exact values for multiples of 30 degrees.
2010	This implementation is also compatible with the behavior of some legacy
2011	compilers. Keep this consistent with gfc_conv_intrinsic_cotand. */
2012	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2013	mpfr_set (result->value.real, x->value.real, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (x->value.real); mpfr_set4 (result->value.real,_p,MPFR_RNDN,((_p)->_mpfr_sign)); } );
2014	mpfr_add_ui (result->value.real, result->value.real, 90, GFC_RND_MODEMPFR_RNDN);
2015	simplify_tand (result->value.real);
2016	mpfr_neg (result->value.real, result->value.real, GFC_RND_MODEMPFR_RNDN);
2017
2018	return range_check (result, "COTAND");
2019	}
2020
2021
2022	gfc_expr *
2023	gfc_simplify_cosh (gfc_expr *x)
2024	{
2025	gfc_expr *result;
2026
2027	if (x->expr_type != EXPR_CONSTANT)
2028	return NULL__null;
2029
2030	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2031
2032	switch (x->ts.type)
2033	{
2034	case BT_REAL:
2035	mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);
2036	break;
2037
2038	case BT_COMPLEX:
2039	mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
2040	break;
2041
2042	default:
2043	gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 2043, __FUNCTION__));
2044	}
2045
2046	return range_check (result, "COSH");
2047	}
2048
2049
2050	gfc_expr *
2051	gfc_simplify_count (gfc_expr mask, gfc_expr dim, gfc_expr *kind)
2052	{
2053	gfc_expr *result;
2054	bool size_zero;
2055
2056	size_zero = gfc_is_size_zero_array (mask);
2057
2058	if (!(is_constant_array_expr (mask) \|\| size_zero)
2059	\|\| !gfc_is_constant_expr (dim)
2060	\|\| !gfc_is_constant_expr (kind))
2061	return NULL__null;
2062
2063	result = transformational_result (mask, dim,
2064	BT_INTEGER,
2065	get_kind (BT_INTEGER, kind, "COUNT",
2066	gfc_default_integer_kind),
2067	&mask->where);
2068
2069	init_result_expr (result, 0, NULL__null);
2070
2071	if (size_zero)
2072	return result;
2073
2074	/* Passing MASK twice, once as data array, once as mask.
2075	Whenever gfc_count is called, '1' is added to the result. */
2076	return !dim \|\| mask->rank == 1 ?
2077	simplify_transformation_to_scalar (result, mask, mask, gfc_count) :
2078	simplify_transformation_to_array (result, mask, dim, mask, gfc_count, NULL__null);
2079	}
2080
2081	/* Simplification routine for cshift. This works by copying the array
2082	expressions into a one-dimensional array, shuffling the values into another
2083	one-dimensional array and creating the new array expression from this. The
2084	shuffling part is basically taken from the library routine. */
2085
2086	gfc_expr *
2087	gfc_simplify_cshift (gfc_expr array, gfc_expr shift, gfc_expr *dim)
2088	{
2089	gfc_expr *result;
2090	int which;
2091	gfc_expr arrayvec, resultvec;
2092	gfc_expr rptr, sptr;
2093	mpz_t size;
2094	size_t arraysize, shiftsize, i;
2095	gfc_constructor array_ctor, shift_ctor;
2096	ssize_t shiftvec, hptr;
2097	ssize_t shift_val, len;
2098	ssize_t count[GFC_MAX_DIMENSIONS15], extent[GFC_MAX_DIMENSIONS15],
2099	hs_ex[GFC_MAX_DIMENSIONS15 + 1],
2100	hstride[GFC_MAX_DIMENSIONS15], sstride[GFC_MAX_DIMENSIONS15],
2101	a_extent[GFC_MAX_DIMENSIONS15], a_stride[GFC_MAX_DIMENSIONS15],
2102	h_extent[GFC_MAX_DIMENSIONS15],
2103	ss_ex[GFC_MAX_DIMENSIONS15 + 1];
2104	ssize_t rsoffset;
2105	int d, n;
2106	bool continue_loop;
2107	gfc_expr src, dest;
2108
2109	if (!is_constant_array_expr (array))
2110	return NULL__null;
2111
2112	if (shift->rank > 0)
2113	gfc_simplify_expr (shift, 1);
2114
2115	if (!gfc_is_constant_expr (shift))
2116	return NULL__null;
2117
2118	/* Make dim zero-based. */
2119	if (dim)
2120	{
2121	if (!gfc_is_constant_expr (dim))
2122	return NULL__null;
2123	which = mpz_get_si__gmpz_get_si (dim->value.integer) - 1;
2124	}
2125	else
2126	which = 0;
2127
2128	if (array->shape == NULL__null)
2129	return NULL__null;
2130
2131	gfc_array_size (array, &size);
2132	arraysize = mpz_get_ui__gmpz_get_ui (size);
2133	mpz_clear__gmpz_clear (size);
2134
2135	result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
2136	result->shape = gfc_copy_shape (array->shape, array->rank);
2137	result->rank = array->rank;
2138	result->ts.u.derived = array->ts.u.derived;
2139
2140	if (arraysize == 0)
2141	return result;
2142
2143	arrayvec = XCNEWVEC (gfc_expr , arraysize)((gfc_expr ) xcalloc ((arraysize), sizeof (gfc_expr )));
2144	array_ctor = gfc_constructor_first (array->value.constructor);
2145	for (i = 0; i < arraysize; i++)
2146	{
2147	arrayvec[i] = array_ctor->expr;
2148	array_ctor = gfc_constructor_next (array_ctor);
2149	}
2150
2151	resultvec = XCNEWVEC (gfc_expr , arraysize)((gfc_expr ) xcalloc ((arraysize), sizeof (gfc_expr )));
2152
2153	sstride[0] = 0;
2154	extent[0] = 1;
2155	count[0] = 0;
2156
2157	for (d=0; d < array->rank; d++)
2158	{
2159	a_extent[d] = mpz_get_si__gmpz_get_si (array->shape[d]);
2160	a_stride[d] = d == 0 ? 1 : a_stride[d-1] * a_extent[d-1];
2161	}
2162
2163	if (shift->rank > 0)
2164	{
2165	gfc_array_size (shift, &size);
2166	shiftsize = mpz_get_ui__gmpz_get_ui (size);
2167	mpz_clear__gmpz_clear (size);
2168	shiftvec = XCNEWVEC (ssize_t, shiftsize)((ssize_t *) xcalloc ((shiftsize), sizeof (ssize_t)));
2169	shift_ctor = gfc_constructor_first (shift->value.constructor);
2170	for (d = 0; d < shift->rank; d++)
2171	{
2172	h_extent[d] = mpz_get_si__gmpz_get_si (shift->shape[d]);
2173	hstride[d] = d == 0 ? 1 : hstride[d-1] * h_extent[d-1];
2174	}
2175	}
2176	else
2177	shiftvec = NULL__null;
2178
2179	/* Shut up compiler */
2180	len = 1;
2181	rsoffset = 1;
2182
2183	n = 0;
2184	for (d=0; d < array->rank; d++)
2185	{
2186	if (d == which)
2187	{
2188	rsoffset = a_stride[d];
2189	len = a_extent[d];
2190	}
2191	else
2192	{
2193	count[n] = 0;
2194	extent[n] = a_extent[d];
2195	sstride[n] = a_stride[d];
2196	ss_ex[n] = sstride[n] * extent[n];
2197	if (shiftvec)
2198	hs_ex[n] = hstride[n] * extent[n];
2199	n++;
2200	}
2201	}
2202	ss_ex[n] = 0;
2203	hs_ex[n] = 0;
2204
2205	if (shiftvec)
2206	{
2207	for (i = 0; i < shiftsize; i++)
2208	{
2209	ssize_t val;
2210	val = mpz_get_si__gmpz_get_si (shift_ctor->expr->value.integer);
2211	val = val % len;
2212	if (val < 0)
2213	val += len;
2214	shiftvec[i] = val;
2215	shift_ctor = gfc_constructor_next (shift_ctor);
2216	}
2217	shift_val = 0;
2218	}
2219	else
2220	{
2221	shift_val = mpz_get_si__gmpz_get_si (shift->value.integer);
2222	shift_val = shift_val % len;
2223	if (shift_val < 0)
2224	shift_val += len;
2225	}
2226
2227	continue_loop = true;
2228	d = array->rank;
2229	rptr = resultvec;
2230	sptr = arrayvec;
2231	hptr = shiftvec;
2232
2233	while (continue_loop)
2234	{
2235	ssize_t sh;
2236	if (shiftvec)
2237	sh = *hptr;
2238	else
2239	sh = shift_val;
2240
2241	src = &sptr[sh * rsoffset];
2242	dest = rptr;
2243	for (n = 0; n < len - sh; n++)
2244	{
2245	dest = src;
2246	dest += rsoffset;
2247	src += rsoffset;
2248	}
2249	src = sptr;
2250	for ( n = 0; n < sh; n++)
2251	{
2252	dest = src;
2253	dest += rsoffset;
2254	src += rsoffset;
2255	}
2256	rptr += sstride[0];
2257	sptr += sstride[0];
2258	if (shiftvec)
2259	hptr += hstride[0];
2260	count[0]++;
2261	n = 0;
2262	while (count[n] == extent[n])
2263	{
2264	count[n] = 0;
2265	rptr -= ss_ex[n];
2266	sptr -= ss_ex[n];
2267	if (shiftvec)
2268	hptr -= hs_ex[n];
2269	n++;
2270	if (n >= d - 1)
2271	{
2272	continue_loop = false;
2273	break;
2274	}
2275	else
2276	{
2277	count[n]++;
2278	rptr += sstride[n];
2279	sptr += sstride[n];
2280	if (shiftvec)
2281	hptr += hstride[n];
2282	}
2283	}
2284	}
2285
2286	for (i = 0; i < arraysize; i++)
2287	{
2288	gfc_constructor_append_expr (&result->value.constructor,
2289	gfc_copy_expr (resultvec[i]),
2290	NULL__null);
2291	}
2292	return result;
2293	}
2294
2295
2296	gfc_expr *
2297	gfc_simplify_dcmplx (gfc_expr x, gfc_expr y)
2298	{
2299	return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
2300	}
2301
2302
2303	gfc_expr *
2304	gfc_simplify_dble (gfc_expr *e)
2305	{
2306	gfc_expr *result = NULL__null;
2307	int tmp1, tmp2;
2308
2309	if (e->expr_type != EXPR_CONSTANT)
2310	return NULL__null;
2311
2312	/* For explicit conversion, turn off -Wconversion and -Wconversion-extra
2313	warnings. */
2314	tmp1 = warn_conversionglobal_options.x_warn_conversion;
2315	tmp2 = warn_conversion_extraglobal_options.x_warn_conversion_extra;
2316	warn_conversionglobal_options.x_warn_conversion = warn_conversion_extraglobal_options.x_warn_conversion_extra = 0;
2317
2318	result = gfc_convert_constant (e, BT_REAL, gfc_default_double_kind);
2319
2320	warn_conversionglobal_options.x_warn_conversion = tmp1;
2321	warn_conversion_extraglobal_options.x_warn_conversion_extra = tmp2;
2322
2323	if (result == &gfc_bad_expr)
2324	return &gfc_bad_expr;
2325
2326	return range_check (result, "DBLE");
2327	}
2328
2329
2330	gfc_expr *
2331	gfc_simplify_digits (gfc_expr *x)
2332	{
2333	int i, digits;
2334
2335	i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
2336
2337	switch (x->ts.type)
2338	{
2339	case BT_INTEGER:
2340	digits = gfc_integer_kinds[i].digits;
2341	break;
2342
2343	case BT_REAL:
2344	case BT_COMPLEX:
2345	digits = gfc_real_kinds[i].digits;
2346	break;
2347
2348	default:
2349	gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 2349, __FUNCTION__));
2350	}
2351
2352	return gfc_get_int_expr (gfc_default_integer_kind, NULL__null, digits);
2353	}
2354
2355
2356	gfc_expr *
2357	gfc_simplify_dim (gfc_expr x, gfc_expr y)
2358	{
2359	gfc_expr *result;
2360	int kind;
2361
2362	if (x->expr_type != EXPR_CONSTANT \|\| y->expr_type != EXPR_CONSTANT)
2363	return NULL__null;
2364
2365	kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
2366	result = gfc_get_constant_expr (x->ts.type, kind, &x->where);
2367
2368	switch (x->ts.type)
2369	{
2370	case BT_INTEGER:
2371	if (mpz_cmp__gmpz_cmp (x->value.integer, y->value.integer) > 0)
2372	mpz_sub__gmpz_sub (result->value.integer, x->value.integer, y->value.integer);
2373	else
2374	mpz_set_ui__gmpz_set_ui (result->value.integer, 0);
2375
2376	break;
2377
2378	case BT_REAL:
2379	if (mpfr_cmp (x->value.real, y->value.real)mpfr_cmp3(x->value.real, y->value.real, 1) > 0)
2380	mpfr_sub (result->value.real, x->value.real, y->value.real,
2381	GFC_RND_MODEMPFR_RNDN);
2382	else
2383	mpfr_set_ui (result->value.real, 0, GFC_RND_MODEMPFR_RNDN);
2384
2385	break;
2386
2387	default:
2388	gfc_internal_error ("gfc_simplify_dim(): Bad type");
2389	}
2390
2391	return range_check (result, "DIM");
2392	}
2393
2394
2395	gfc_expr*
2396	gfc_simplify_dot_product (gfc_expr vector_a, gfc_expr vector_b)
2397	{
2398	/* If vector_a is a zero-sized array, the result is 0 for INTEGER,
2399	REAL, and COMPLEX types and .false. for LOGICAL. */
2400	if (vector_a->shape && mpz_get_si__gmpz_get_si (vector_a->shape[0]) == 0)
2401	{
2402	if (vector_a->ts.type == BT_LOGICAL)
2403	return gfc_get_logical_expr (gfc_default_logical_kind, NULL__null, false);
2404	else
2405	return gfc_get_int_expr (gfc_default_integer_kind, NULL__null, 0);
2406	}
2407
2408	if (!is_constant_array_expr (vector_a)
2409	\|\| !is_constant_array_expr (vector_b))
2410	return NULL__null;
2411
2412	return compute_dot_product (vector_a, 1, 0, vector_b, 1, 0, true);
2413	}
2414
2415
2416	gfc_expr *
2417	gfc_simplify_dprod (gfc_expr x, gfc_expr y)
2418	{
2419	gfc_expr a1, a2, *result;
2420
2421	if (x->expr_type != EXPR_CONSTANT \|\| y->expr_type != EXPR_CONSTANT)
2422	return NULL__null;
2423
2424	a1 = gfc_real2real (x, gfc_default_double_kind);
2425	a2 = gfc_real2real (y, gfc_default_double_kind);
2426
2427	result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &x->where);
2428	mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODEMPFR_RNDN);
2429
2430	gfc_free_expr (a2);
2431	gfc_free_expr (a1);
2432
2433	return range_check (result, "DPROD");
2434	}
2435
2436
2437	static gfc_expr *
2438	simplify_dshift (gfc_expr arg1, gfc_expr arg2, gfc_expr *shiftarg,
2439	bool right)
2440	{
2441	gfc_expr *result;
2442	int i, k, size, shift;
2443
2444	if (arg1->expr_type != EXPR_CONSTANT \|\| arg2->expr_type != EXPR_CONSTANT
2445	\|\| shiftarg->expr_type != EXPR_CONSTANT)
2446	return NULL__null;
2447
2448	k = gfc_validate_kind (BT_INTEGER, arg1->ts.kind, false);
2449	size = gfc_integer_kinds[k].bit_size;
2450
2451	gfc_extract_int (shiftarg, &shift);
2452
2453	/* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT). */
2454	if (right)
2455	shift = size - shift;
2456
2457	result = gfc_get_constant_expr (BT_INTEGER, arg1->ts.kind, &arg1->where);
2458	mpz_set_ui__gmpz_set_ui (result->value.integer, 0);
2459
2460	for (i = 0; i < shift; i++)
2461	if (mpz_tstbit__gmpz_tstbit (arg2->value.integer, size - shift + i))
2462	mpz_setbit__gmpz_setbit (result->value.integer, i);
2463
2464	for (i = 0; i < size - shift; i++)
2465	if (mpz_tstbit__gmpz_tstbit (arg1->value.integer, i))
2466	mpz_setbit__gmpz_setbit (result->value.integer, shift + i);
2467
2468	/* Convert to a signed value. */
2469	gfc_convert_mpz_to_signed (result->value.integer, size);
2470
2471	return result;
2472	}
2473
2474
2475	gfc_expr *
2476	gfc_simplify_dshiftr (gfc_expr arg1, gfc_expr arg2, gfc_expr *shiftarg)
2477	{
2478	return simplify_dshift (arg1, arg2, shiftarg, true);
2479	}
2480
2481
2482	gfc_expr *
2483	gfc_simplify_dshiftl (gfc_expr arg1, gfc_expr arg2, gfc_expr *shiftarg)
2484	{
2485	return simplify_dshift (arg1, arg2, shiftarg, false);
2486	}
2487
2488
2489	gfc_expr *
2490	gfc_simplify_eoshift (gfc_expr array, gfc_expr shift, gfc_expr *boundary,
2491	gfc_expr *dim)
2492	{
2493	bool temp_boundary;
2494	gfc_expr *bnd;
2495	gfc_expr *result;
2496	int which;
2497	gfc_expr arrayvec, resultvec;
2498	gfc_expr rptr, sptr;
2499	mpz_t size;
2500	size_t arraysize, i;
2501	gfc_constructor array_ctor, shift_ctor, *bnd_ctor;
2502	ssize_t shift_val, len;
2503	ssize_t count[GFC_MAX_DIMENSIONS15], extent[GFC_MAX_DIMENSIONS15],
2504	sstride[GFC_MAX_DIMENSIONS15], a_extent[GFC_MAX_DIMENSIONS15],
2505	a_stride[GFC_MAX_DIMENSIONS15], ss_ex[GFC_MAX_DIMENSIONS15 + 1];
2506	ssize_t rsoffset;
2507	int d, n;
2508	bool continue_loop;
2509	gfc_expr src, dest;
2510	size_t s_len;
2511
2512	if (!is_constant_array_expr (array))
2513	return NULL__null;
2514
2515	if (shift->rank > 0)
2516	gfc_simplify_expr (shift, 1);
2517
2518	if (!gfc_is_constant_expr (shift))
2519	return NULL__null;
2520
2521	if (boundary)
2522	{
2523	if (boundary->rank > 0)
2524	gfc_simplify_expr (boundary, 1);
2525
2526	if (!gfc_is_constant_expr (boundary))
2527	return NULL__null;
2528	}
2529
2530	if (dim)
2531	{
2532	if (!gfc_is_constant_expr (dim))
2533	return NULL__null;
2534	which = mpz_get_si__gmpz_get_si (dim->value.integer) - 1;
2535	}
2536	else
2537	which = 0;
2538
2539	s_len = 0;
	Value stored to 's_len' is never read
2540	if (boundary == NULL__null)
2541	{
2542	temp_boundary = true;
2543	switch (array->ts.type)
2544	{
2545
2546	case BT_INTEGER:
2547	bnd = gfc_get_int_expr (array->ts.kind, NULL__null, 0);
2548	break;
2549
2550	case BT_LOGICAL:
2551	bnd = gfc_get_logical_expr (array->ts.kind, NULL__null, 0);
2552	break;
2553
2554	case BT_REAL:
2555	bnd = gfc_get_constant_expr (array->ts.type, array->ts.kind, &gfc_current_locus);
2556	mpfr_set_ui (bnd->value.real, 0, GFC_RND_MODEMPFR_RNDN);
2557	break;
2558
2559	case BT_COMPLEX:
2560	bnd = gfc_get_constant_expr (array->ts.type, array->ts.kind, &gfc_current_locus);
2561	mpc_set_ui (bnd->value.complex, 0, GFC_RND_MODEMPFR_RNDN);
2562	break;
2563
2564	case BT_CHARACTER:
2565	s_len = mpz_get_ui__gmpz_get_ui (array->ts.u.cl->length->value.integer);
2566	bnd = gfc_get_character_expr (array->ts.kind, &gfc_current_locus, NULL__null, s_len);
2567	break;
2568
2569	default:
2570	gcc_unreachable()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 2570, __FUNCTION__));
2571
2572	}
2573	}
2574	else
2575	{
2576	temp_boundary = false;
2577	bnd = boundary;
2578	}
2579
2580	gfc_array_size (array, &size);
2581	arraysize = mpz_get_ui__gmpz_get_ui (size);
2582	mpz_clear__gmpz_clear (size);
2583
2584	result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
2585	result->shape = gfc_copy_shape (array->shape, array->rank);
2586	result->rank = array->rank;
2587	result->ts = array->ts;
2588
2589	if (arraysize == 0)
2590	goto final;
2591
2592	if (array->shape == NULL__null)
2593	goto final;
2594
2595	arrayvec = XCNEWVEC (gfc_expr , arraysize)((gfc_expr ) xcalloc ((arraysize), sizeof (gfc_expr )));
2596	array_ctor = gfc_constructor_first (array->value.constructor);
2597	for (i = 0; i < arraysize; i++)
2598	{
2599	arrayvec[i] = array_ctor->expr;
2600	array_ctor = gfc_constructor_next (array_ctor);
2601	}
2602
2603	resultvec = XCNEWVEC (gfc_expr , arraysize)((gfc_expr ) xcalloc ((arraysize), sizeof (gfc_expr )));
2604
2605	extent[0] = 1;
2606	count[0] = 0;
2607
2608	for (d=0; d < array->rank; d++)
2609	{
2610	a_extent[d] = mpz_get_si__gmpz_get_si (array->shape[d]);
2611	a_stride[d] = d == 0 ? 1 : a_stride[d-1] * a_extent[d-1];
2612	}
2613
2614	if (shift->rank > 0)
2615	{
2616	shift_ctor = gfc_constructor_first (shift->value.constructor);
2617	shift_val = 0;
2618	}
2619	else
2620	{
2621	shift_ctor = NULL__null;
2622	shift_val = mpz_get_si__gmpz_get_si (shift->value.integer);
2623	}
2624
2625	if (bnd->rank > 0)
2626	bnd_ctor = gfc_constructor_first (bnd->value.constructor);
2627	else
2628	bnd_ctor = NULL__null;
2629
2630	/* Shut up compiler */
2631	len = 1;
2632	rsoffset = 1;
2633
2634	n = 0;
2635	for (d=0; d < array->rank; d++)
2636	{
2637	if (d == which)
2638	{
2639	rsoffset = a_stride[d];
2640	len = a_extent[d];
2641	}
2642	else
2643	{
2644	count[n] = 0;
2645	extent[n] = a_extent[d];
2646	sstride[n] = a_stride[d];
2647	ss_ex[n] = sstride[n] * extent[n];
2648	n++;
2649	}
2650	}
2651	ss_ex[n] = 0;
2652
2653	continue_loop = true;
2654	d = array->rank;
2655	rptr = resultvec;
2656	sptr = arrayvec;
2657
2658	while (continue_loop)
2659	{
2660	ssize_t sh, delta;
2661
2662	if (shift_ctor)
2663	sh = mpz_get_si__gmpz_get_si (shift_ctor->expr->value.integer);
2664	else
2665	sh = shift_val;
2666
2667	if (( sh >= 0 ? sh : -sh ) > len)
2668	{
2669	delta = len;
2670	sh = len;
2671	}
2672	else
2673	delta = (sh >= 0) ? sh: -sh;
2674
2675	if (sh > 0)
2676	{
2677	src = &sptr[delta * rsoffset];
2678	dest = rptr;
2679	}
2680	else
2681	{
2682	src = sptr;
2683	dest = &rptr[delta * rsoffset];
2684	}
2685
2686	for (n = 0; n < len - delta; n++)
2687	{
2688	dest = src;
2689	dest += rsoffset;
2690	src += rsoffset;
2691	}
2692
2693	if (sh < 0)
2694	dest = rptr;
2695
2696	n = delta;
2697
2698	if (bnd_ctor)
2699	{
2700	while (n--)
2701	{
2702	*dest = gfc_copy_expr (bnd_ctor->expr);
2703	dest += rsoffset;
2704	}
2705	}
2706	else
2707	{
2708	while (n--)
2709	{
2710	*dest = gfc_copy_expr (bnd);
2711	dest += rsoffset;
2712	}
2713	}
2714	rptr += sstride[0];
2715	sptr += sstride[0];
2716	if (shift_ctor)
2717	shift_ctor = gfc_constructor_next (shift_ctor);
2718
2719	if (bnd_ctor)
2720	bnd_ctor = gfc_constructor_next (bnd_ctor);
2721
2722	count[0]++;
2723	n = 0;
2724	while (count[n] == extent[n])
2725	{
2726	count[n] = 0;
2727	rptr -= ss_ex[n];
2728	sptr -= ss_ex[n];
2729	n++;
2730	if (n >= d - 1)
2731	{
2732	continue_loop = false;
2733	break;
2734	}
2735	else
2736	{
2737	count[n]++;
2738	rptr += sstride[n];
2739	sptr += sstride[n];
2740	}
2741	}
2742	}
2743
2744	for (i = 0; i < arraysize; i++)
2745	{
2746	gfc_constructor_append_expr (&result->value.constructor,
2747	gfc_copy_expr (resultvec[i]),
2748	NULL__null);
2749	}
2750
2751	final:
2752	if (temp_boundary)
2753	gfc_free_expr (bnd);
2754
2755	return result;
2756	}
2757
2758	gfc_expr *
2759	gfc_simplify_erf (gfc_expr *x)
2760	{
2761	gfc_expr *result;
2762
2763	if (x->expr_type != EXPR_CONSTANT)
2764	return NULL__null;
2765
2766	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2767	mpfr_erf (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);
2768
2769	return range_check (result, "ERF");
2770	}
2771
2772
2773	gfc_expr *
2774	gfc_simplify_erfc (gfc_expr *x)
2775	{
2776	gfc_expr *result;
2777
2778	if (x->expr_type != EXPR_CONSTANT)
2779	return NULL__null;
2780
2781	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2782	mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);
2783
2784	return range_check (result, "ERFC");
2785	}
2786
2787
2788	/* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X*2). /
2789
2790	#define MAX_ITER 200
2791	#define ARG_LIMIT 12
2792
2793	/* Calculate ERFC_SCALED directly by its definition:
2794
2795	ERFC_SCALED(x) = ERFC(x) * EXP(X**2)
2796
2797	using a large precision for intermediate results. This is used for all
2798	but large values of the argument. */
2799	static void
2800	fullprec_erfc_scaled (mpfr_t res, mpfr_t arg)
2801	{
2802	mpfr_prec_t prec;
2803	mpfr_t a, b;
2804
2805	prec = mpfr_get_default_prec ();
2806	mpfr_set_default_prec (10 * prec);
2807
2808	mpfr_init (a);
2809	mpfr_init (b);
2810
2811	mpfr_set (a, arg, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (arg); mpfr_set4(a,_p,MPFR_RNDN ,((_p)->_mpfr_sign)); });
2812	mpfr_sqr (b, a, GFC_RND_MODEMPFR_RNDN);
2813	mpfr_exp (b, b, GFC_RND_MODEMPFR_RNDN);
2814	mpfr_erfc (a, a, GFC_RND_MODEMPFR_RNDN);
2815	mpfr_mul (a, a, b, GFC_RND_MODEMPFR_RNDN);
2816
2817	mpfr_set (res, a, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (a); mpfr_set4(res,_p,MPFR_RNDN ,((_p)->_mpfr_sign)); });
2818	mpfr_set_default_prec (prec);
2819
2820	mpfr_clear (a);
2821	mpfr_clear (b);
2822	}
2823
2824	/* Calculate ERFC_SCALED using a power series expansion in 1/arg:
2825
2826	ERFC_SCALED(x) = 1 / (x * sqrt(pi))
2827	* (1 + Sum_n (-1)*n (1 * 3 * 5 * ... * (2n-1))
2828	/ (2 * x2)n)
2829
2830	This is used for large values of the argument. Intermediate calculations
2831	are performed with twice the precision. We don't do a fixed number of
2832	iterations of the sum, but stop when it has converged to the required
2833	precision. */
2834	static void
2835	asympt_erfc_scaled (mpfr_t res, mpfr_t arg)
2836	{
2837	mpfr_t sum, x, u, v, w, oldsum, sumtrunc;
2838	mpz_t num;
2839	mpfr_prec_t prec;
2840	unsigned i;
2841
2842	prec = mpfr_get_default_prec ();
2843	mpfr_set_default_prec (2 * prec);
2844
2845	mpfr_init (sum);
2846	mpfr_init (x);
2847	mpfr_init (u);
2848	mpfr_init (v);
2849	mpfr_init (w);
2850	mpz_init__gmpz_init (num);
2851
2852	mpfr_init (oldsum);
2853	mpfr_init (sumtrunc);
2854	mpfr_set_prec (oldsum, prec);
2855	mpfr_set_prec (sumtrunc, prec);
2856
2857	mpfr_set (x, arg, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (arg); mpfr_set4(x,_p,MPFR_RNDN ,((_p)->_mpfr_sign)); });
2858	mpfr_set_ui (sum, 1, GFC_RND_MODEMPFR_RNDN);
2859	mpz_set_ui__gmpz_set_ui (num, 1);
2860
2861	mpfr_set (u, x, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (x); mpfr_set4(u,_p,MPFR_RNDN ,((_p)->_mpfr_sign)); });
2862	mpfr_sqr (u, u, GFC_RND_MODEMPFR_RNDN);
2863	mpfr_mul_ui (u, u, 2, GFC_RND_MODEMPFR_RNDN);
2864	mpfr_pow_si (u, u, -1, GFC_RND_MODEMPFR_RNDN);
2865
2866	for (i = 1; i < MAX_ITER; i++)
2867	{
2868	mpfr_set (oldsum, sum, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (sum); mpfr_set4(oldsum,_p, MPFR_RNDN,((_p)->_mpfr_sign)); });
2869
2870	mpz_mul_ui__gmpz_mul_ui (num, num, 2 * i - 1);
2871	mpz_neg__gmpz_neg (num, num);
2872
2873	mpfr_set (w, u, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (u); mpfr_set4(w,_p,MPFR_RNDN ,((_p)->_mpfr_sign)); });
2874	mpfr_pow_ui (w, w, i, GFC_RND_MODEMPFR_RNDN);
2875
2876	mpfr_set_z (v, num, GFC_RND_MODEMPFR_RNDN);
2877	mpfr_mul (v, v, w, GFC_RND_MODEMPFR_RNDN);
2878
2879	mpfr_add (sum, sum, v, GFC_RND_MODEMPFR_RNDN);
2880
2881	mpfr_set (sumtrunc, sum, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (sum); mpfr_set4(sumtrunc,_p ,MPFR_RNDN,((_p)->_mpfr_sign)); });
2882	if (mpfr_cmp (sumtrunc, oldsum)mpfr_cmp3(sumtrunc, oldsum, 1) == 0)
2883	break;
2884	}
2885
2886	/* We should have converged by now; otherwise, ARG_LIMIT is probably
2887	set too low. */
2888	gcc_assert (i < MAX_ITER)((void)(!(i < MAX_ITER) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 2888, __FUNCTION__), 0 : 0));
2889
2890	/* Divide by x * sqrt(Pi). */
2891	mpfr_const_pi (u, GFC_RND_MODEMPFR_RNDN);
2892	mpfr_sqrt (u, u, GFC_RND_MODEMPFR_RNDN);
2893	mpfr_mul (u, u, x, GFC_RND_MODEMPFR_RNDN);
2894	mpfr_div (sum, sum, u, GFC_RND_MODEMPFR_RNDN);
2895
2896	mpfr_set (res, sum, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (sum); mpfr_set4(res,_p,MPFR_RNDN ,((_p)->_mpfr_sign)); });
2897	mpfr_set_default_prec (prec);
2898
2899	mpfr_clears (sum, x, u, v, w, oldsum, sumtrunc, NULL__null);
2900	mpz_clear__gmpz_clear (num);
2901	}
2902
2903
2904	gfc_expr *
2905	gfc_simplify_erfc_scaled (gfc_expr *x)
2906	{
2907	gfc_expr *result;
2908
2909	if (x->expr_type != EXPR_CONSTANT)
2910	return NULL__null;
2911
2912	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2913	if (mpfr_cmp_d (x->value.real, ARG_LIMIT) >= 0)
2914	asympt_erfc_scaled (result->value.real, x->value.real);
2915	else
2916	fullprec_erfc_scaled (result->value.real, x->value.real);
2917
2918	return range_check (result, "ERFC_SCALED");
2919	}
2920
2921	#undef MAX_ITER
2922	#undef ARG_LIMIT
2923
2924
2925	gfc_expr *
2926	gfc_simplify_epsilon (gfc_expr *e)
2927	{
2928	gfc_expr *result;
2929	int i;
2930
2931	i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2932
2933	result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
2934	mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (gfc_real_kinds[i].epsilon) ; mpfr_set4(result->value.real,_p,MPFR_RNDN,((_p)->_mpfr_sign )); });
2935
2936	return range_check (result, "EPSILON");
2937	}
2938
2939
2940	gfc_expr *
2941	gfc_simplify_exp (gfc_expr *x)
2942	{
2943	gfc_expr *result;
2944
2945	if (x->expr_type != EXPR_CONSTANT)
2946	return NULL__null;
2947
2948	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2949
2950	switch (x->ts.type)
2951	{
2952	case BT_REAL:
2953	mpfr_exp (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);
2954	break;
2955
2956	case BT_COMPLEX:
2957	gfc_set_model_kind (x->ts.kind);
2958	mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
2959	break;
2960
2961	default:
2962	gfc_internal_error ("in gfc_simplify_exp(): Bad type");
2963	}
2964
2965	return range_check (result, "EXP");
2966	}
2967
2968
2969	gfc_expr *
2970	gfc_simplify_exponent (gfc_expr *x)
2971	{
2972	long int val;
2973	gfc_expr *result;
2974
2975	if (x->expr_type != EXPR_CONSTANT)
2976	return NULL__null;
2977
2978	result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
2979	&x->where);
2980
2981	/* EXPONENT(inf) = EXPONENT(nan) = HUGE(0) */
2982	if (mpfr_inf_p (x->value.real)(((mpfr_srcptr) (0 ? (x->value.real) : (mpfr_srcptr) (x-> value.real)))->_mpfr_exp == (2 - ((mpfr_exp_t) (((mpfr_uexp_t ) -1) >> 1)))) \|\| mpfr_nan_p (x->value.real)(((mpfr_srcptr) (0 ? (x->value.real) : (mpfr_srcptr) (x-> value.real)))->_mpfr_exp == (1 - ((mpfr_exp_t) (((mpfr_uexp_t ) -1) >> 1)))))
2983	{
2984	int i = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false);
2985	mpz_set__gmpz_set (result->value.integer, gfc_integer_kinds[i].huge);
2986	return result;
2987	}
2988
2989	/* EXPONENT(+/- 0.0) = 0 */
2990	if (mpfr_zero_p (x->value.real)(((mpfr_srcptr) (0 ? (x->value.real) : (mpfr_srcptr) (x-> value.real)))->_mpfr_exp == (0 - ((mpfr_exp_t) (((mpfr_uexp_t ) -1) >> 1)))))
2991	{
2992	mpz_set_ui__gmpz_set_ui (result->value.integer, 0);
2993	return result;
2994	}
2995
2996	gfc_set_model (x->value.real);
2997
2998	val = (long int) mpfr_get_exp (x->value.real)(0 ? (((mpfr_srcptr) (0 ? (x->value.real) : (mpfr_srcptr) ( x->value.real)))->_mpfr_exp) : (((mpfr_srcptr) (0 ? (x-> value.real) : (mpfr_srcptr) (x->value.real)))->_mpfr_exp ));
2999	mpz_set_si__gmpz_set_si (result->value.integer, val);
3000
3001	return range_check (result, "EXPONENT");
3002	}
3003
3004
3005	gfc_expr *
3006	gfc_simplify_failed_or_stopped_images (gfc_expr *team ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
3007	gfc_expr *kind)
3008	{
3009	if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_NONE)
3010	{
3011	gfc_current_locus = *gfc_current_intrinsic_where;
3012	gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3013	return &gfc_bad_expr;
3014	}
3015
3016	if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_SINGLE)
3017	{
3018	gfc_expr *result;
3019	int actual_kind;
3020	if (kind)
3021	gfc_extract_int (kind, &actual_kind);
3022	else
3023	actual_kind = gfc_default_integer_kind;
3024
3025	result = gfc_get_array_expr (BT_INTEGER, actual_kind, &gfc_current_locus);
3026	result->rank = 1;
3027	return result;
3028	}
3029
3030	/* For fcoarray = lib no simplification is possible, because it is not known
3031	what images failed or are stopped at compile time. */
3032	return NULL__null;
3033	}
3034
3035
3036	gfc_expr *
3037	gfc_simplify_get_team (gfc_expr *level ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
3038	{
3039	if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_NONE)
3040	{
3041	gfc_current_locus = *gfc_current_intrinsic_where;
3042	gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3043	return &gfc_bad_expr;
3044	}
3045
3046	if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_SINGLE)
3047	{
3048	gfc_expr *result;
3049	result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus);
3050	result->rank = 0;
3051	return result;
3052	}
3053
3054	/* For fcoarray = lib no simplification is possible, because it is not known
3055	what images failed or are stopped at compile time. */
3056	return NULL__null;
3057	}
3058
3059
3060	gfc_expr *
3061	gfc_simplify_float (gfc_expr *a)
3062	{
3063	gfc_expr *result;
3064
3065	if (a->expr_type != EXPR_CONSTANT)
3066	return NULL__null;
3067
3068	result = gfc_int2real (a, gfc_default_real_kind);
3069
3070	return range_check (result, "FLOAT");
3071	}
3072
3073
3074	static bool
3075	is_last_ref_vtab (gfc_expr *e)
3076	{
3077	gfc_ref *ref;
3078	gfc_component *comp = NULL__null;
3079
3080	if (e->expr_type != EXPR_VARIABLE)
3081	return false;
3082
3083	for (ref = e->ref; ref; ref = ref->next)
3084	if (ref->type == REF_COMPONENT)
3085	comp = ref->u.c.component;
3086
3087	if (!e->ref \|\| !comp)
3088	return e->symtree->n.sym->attr.vtab;
3089
3090	if (comp->name[0] == '_' && strcmp (comp->name, "_vptr") == 0)
3091	return true;
3092
3093	return false;
3094	}
3095
3096
3097	gfc_expr *
3098	gfc_simplify_extends_type_of (gfc_expr a, gfc_expr mold)
3099	{
3100	/* Avoid simplification of resolved symbols. */
3101	if (is_last_ref_vtab (a) \|\| is_last_ref_vtab (mold))
3102	return NULL__null;
3103
3104	if (a->ts.type == BT_DERIVED && mold->ts.type == BT_DERIVED)
3105	return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3106	gfc_type_is_extension_of (mold->ts.u.derived,
3107	a->ts.u.derived));
3108
3109	if (UNLIMITED_POLY (a)(a != __null && a->ts.type == BT_CLASS && a ->ts.u.derived->components && a->ts.u.derived ->components->ts.u.derived && a->ts.u.derived ->components->ts.u.derived->attr.unlimited_polymorphic ) \|\| UNLIMITED_POLY (mold)(mold != __null && mold->ts.type == BT_CLASS && mold->ts.u.derived->components && mold->ts. u.derived->components->ts.u.derived && mold-> ts.u.derived->components->ts.u.derived->attr.unlimited_polymorphic ))
3110	return NULL__null;
3111
3112	if ((a->ts.type == BT_CLASS && !gfc_expr_attr (a).class_ok)
3113	\|\| (mold->ts.type == BT_CLASS && !gfc_expr_attr (mold).class_ok))
3114	return NULL__null;
3115
3116	/* Return .false. if the dynamic type can never be an extension. */
3117	if ((a->ts.type == BT_CLASS && mold->ts.type == BT_CLASS
3118	&& !gfc_type_is_extension_of
3119	(mold->ts.u.derived->components->ts.u.derived,
3120	a->ts.u.derived->components->ts.u.derived)
3121	&& !gfc_type_is_extension_of
3122	(a->ts.u.derived->components->ts.u.derived,
3123	mold->ts.u.derived->components->ts.u.derived))
3124	\|\| (a->ts.type == BT_DERIVED && mold->ts.type == BT_CLASS
3125	&& !gfc_type_is_extension_of
3126	(mold->ts.u.derived->components->ts.u.derived,
3127	a->ts.u.derived))
3128	\|\| (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED
3129	&& !gfc_type_is_extension_of
3130	(mold->ts.u.derived,
3131	a->ts.u.derived->components->ts.u.derived)
3132	&& !gfc_type_is_extension_of
3133	(a->ts.u.derived->components->ts.u.derived,
3134	mold->ts.u.derived)))
3135	return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
3136
3137	/* Return .true. if the dynamic type is guaranteed to be an extension. */
3138	if (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED
3139	&& gfc_type_is_extension_of (mold->ts.u.derived,
3140	a->ts.u.derived->components->ts.u.derived))
3141	return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, true);
3142
3143	return NULL__null;
3144	}
3145
3146
3147	gfc_expr *
3148	gfc_simplify_same_type_as (gfc_expr a, gfc_expr b)
3149	{
3150	/* Avoid simplification of resolved symbols. */
3151	if (is_last_ref_vtab (a) \|\| is_last_ref_vtab (b))
3152	return NULL__null;
3153
3154	/* Return .false. if the dynamic type can never be the
3155	same. */
3156	if (((a->ts.type == BT_CLASS && gfc_expr_attr (a).class_ok)
3157	\|\| (b->ts.type == BT_CLASS && gfc_expr_attr (b).class_ok))
3158	&& !gfc_type_compatible (&a->ts, &b->ts)
3159	&& !gfc_type_compatible (&b->ts, &a->ts))
3160	return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
3161
3162	if (a->ts.type != BT_DERIVED \|\| b->ts.type != BT_DERIVED)
3163	return NULL__null;
3164
3165	return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3166	gfc_compare_derived_types (a->ts.u.derived,
3167	b->ts.u.derived));
3168	}
3169
3170
3171	gfc_expr *
3172	gfc_simplify_floor (gfc_expr e, gfc_expr k)
3173	{
3174	gfc_expr *result;
3175	mpfr_t floor;
3176	int kind;
3177
3178	kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind);
3179	if (kind == -1)
3180	gfc_internal_error ("gfc_simplify_floor(): Bad kind");
3181
3182	if (e->expr_type != EXPR_CONSTANT)
3183	return NULL__null;
3184
3185	mpfr_init2 (floor, mpfr_get_prec (e->value.real)(0 ? (((mpfr_srcptr) (0 ? (e->value.real) : (mpfr_srcptr) ( e->value.real)))->_mpfr_prec) : (((mpfr_srcptr) (0 ? (e ->value.real) : (mpfr_srcptr) (e->value.real)))->_mpfr_prec )));
3186	mpfr_floor (floor, e->value.real)mpfr_rint((floor), (e->value.real), MPFR_RNDD);
3187
3188	result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
3189	gfc_mpfr_to_mpz (result->value.integer, floor, &e->where);
3190
3191	mpfr_clear (floor);
3192
3193	return range_check (result, "FLOOR");
3194	}
3195
3196
3197	gfc_expr *
3198	gfc_simplify_fraction (gfc_expr *x)
3199	{
3200	gfc_expr *result;
3201	mpfr_exp_t e;
3202
3203	if (x->expr_type != EXPR_CONSTANT)
3204	return NULL__null;
3205
3206	result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
3207
3208	/* FRACTION(inf) = NaN. */
3209	if (mpfr_inf_p (x->value.real)(((mpfr_srcptr) (0 ? (x->value.real) : (mpfr_srcptr) (x-> value.real)))->_mpfr_exp == (2 - ((mpfr_exp_t) (((mpfr_uexp_t ) -1) >> 1)))))
3210	{
3211	mpfr_set_nan (result->value.real);
3212	return result;
3213	}
3214
3215	/* mpfr_frexp() correctly handles zeros and NaNs. */
3216	mpfr_frexp (&e, result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);
3217
3218	return range_check (result, "FRACTION");
3219	}
3220
3221
3222	gfc_expr *
3223	gfc_simplify_gamma (gfc_expr *x)
3224	{
3225	gfc_expr *result;
3226
3227	if (x->expr_type != EXPR_CONSTANT)
3228	return NULL__null;
3229
3230	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3231	mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);
3232
3233	return range_check (result, "GAMMA");
3234	}
3235
3236
3237	gfc_expr *
3238	gfc_simplify_huge (gfc_expr *e)
3239	{
3240	gfc_expr *result;
3241	int i;
3242
3243	i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3244	result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
3245
3246	switch (e->ts.type)
3247	{
3248	case BT_INTEGER:
3249	mpz_set__gmpz_set (result->value.integer, gfc_integer_kinds[i].huge);
3250	break;
3251
3252	case BT_REAL:
3253	mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (gfc_real_kinds[i].huge); mpfr_set4 (result->value.real,_p,MPFR_RNDN,((_p)->_mpfr_sign)); } );
3254	break;
3255
3256	default:
3257	gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 3257, __FUNCTION__));
3258	}
3259
3260	return result;
3261	}
3262
3263
3264	gfc_expr *
3265	gfc_simplify_hypot (gfc_expr x, gfc_expr y)
3266	{
3267	gfc_expr *result;
3268
3269	if (x->expr_type != EXPR_CONSTANT \|\| y->expr_type != EXPR_CONSTANT)
3270	return NULL__null;
3271
3272	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3273	mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODEMPFR_RNDN);
3274	return range_check (result, "HYPOT");
3275	}
3276
3277
3278	/* We use the processor's collating sequence, because all
3279	systems that gfortran currently works on are ASCII. */
3280
3281	gfc_expr *
3282	gfc_simplify_iachar (gfc_expr e, gfc_expr kind)
3283	{
3284	gfc_expr *result;
3285	gfc_char_t index;
3286	int k;
3287
3288	if (e->expr_type != EXPR_CONSTANT)
3289	return NULL__null;
3290
3291	if (e->value.character.length != 1)
3292	{
3293	gfc_error ("Argument of IACHAR at %L must be of length one", &e->where);
3294	return &gfc_bad_expr;
3295	}
3296
3297	index = e->value.character.string[0];
3298
3299	if (warn_surprisingglobal_options.x_warn_surprising && index > 127)
3300	gfc_warning (OPT_Wsurprising,
3301	"Argument of IACHAR function at %L outside of range 0..127",
3302	&e->where);
3303
3304	k = get_kind (BT_INTEGER, kind, "IACHAR", gfc_default_integer_kind);
3305	if (k == -1)
3306	return &gfc_bad_expr;
3307
3308	result = gfc_get_int_expr (k, &e->where, index);
3309
3310	return range_check (result, "IACHAR");
3311	}
3312
3313
3314	static gfc_expr *
3315	do_bit_and (gfc_expr result, gfc_expr e)
3316	{
3317	gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT)((void)(!(e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 3317, __FUNCTION__), 0 : 0));
3318	gcc_assert (result->ts.type == BT_INTEGER((void)(!(result->ts.type == BT_INTEGER && result-> expr_type == EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 3319, __FUNCTION__), 0 : 0))
3319	&& result->expr_type == EXPR_CONSTANT)((void)(!(result->ts.type == BT_INTEGER && result-> expr_type == EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 3319, __FUNCTION__), 0 : 0));
3320
3321	mpz_and__gmpz_and (result->value.integer, result->value.integer, e->value.integer);
3322	return result;
3323	}
3324
3325
3326	gfc_expr *
3327	gfc_simplify_iall (gfc_expr array, gfc_expr dim, gfc_expr *mask)
3328	{
3329	return simplify_transformation (array, dim, mask, -1, do_bit_and);
3330	}
3331
3332
3333	static gfc_expr *
3334	do_bit_ior (gfc_expr result, gfc_expr e)
3335	{
3336	gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT)((void)(!(e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 3336, __FUNCTION__), 0 : 0));
3337	gcc_assert (result->ts.type == BT_INTEGER((void)(!(result->ts.type == BT_INTEGER && result-> expr_type == EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 3338, __FUNCTION__), 0 : 0))
3338	&& result->expr_type == EXPR_CONSTANT)((void)(!(result->ts.type == BT_INTEGER && result-> expr_type == EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 3338, __FUNCTION__), 0 : 0));
3339
3340	mpz_ior__gmpz_ior (result->value.integer, result->value.integer, e->value.integer);
3341	return result;
3342	}
3343
3344
3345	gfc_expr *
3346	gfc_simplify_iany (gfc_expr array, gfc_expr dim, gfc_expr *mask)
3347	{
3348	return simplify_transformation (array, dim, mask, 0, do_bit_ior);
3349	}
3350
3351
3352	gfc_expr *
3353	gfc_simplify_iand (gfc_expr x, gfc_expr y)
3354	{
3355	gfc_expr *result;
3356
3357	if (x->expr_type != EXPR_CONSTANT \|\| y->expr_type != EXPR_CONSTANT)
3358	return NULL__null;
3359
3360	result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
3361	mpz_and__gmpz_and (result->value.integer, x->value.integer, y->value.integer);
3362
3363	return range_check (result, "IAND");
3364	}
3365
3366
3367	gfc_expr *
3368	gfc_simplify_ibclr (gfc_expr x, gfc_expr y)
3369	{
3370	gfc_expr *result;
3371	int k, pos;
3372
3373	if (x->expr_type != EXPR_CONSTANT \|\| y->expr_type != EXPR_CONSTANT)
3374	return NULL__null;
3375
3376	if (!gfc_check_bitfcn (x, y))
3377	return &gfc_bad_expr;
3378
3379	gfc_extract_int (y, &pos);
3380
3381	k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3382
3383	result = gfc_copy_expr (x);
3384	/* Drop any separate memory representation of x to avoid potential
3385	inconsistencies in result. */
3386	if (result->representation.string)
3387	{
3388	free (result->representation.string);
3389	result->representation.string = NULL__null;
3390	}
3391
3392	convert_mpz_to_unsigned (result->value.integer,
3393	gfc_integer_kinds[k].bit_size);
3394
3395	mpz_clrbit__gmpz_clrbit (result->value.integer, pos);
3396
3397	gfc_convert_mpz_to_signed (result->value.integer,
3398	gfc_integer_kinds[k].bit_size);
3399
3400	return result;
3401	}
3402
3403
3404	gfc_expr *
3405	gfc_simplify_ibits (gfc_expr x, gfc_expr y, gfc_expr *z)
3406	{
3407	gfc_expr *result;
3408	int pos, len;
3409	int i, k, bitsize;
3410	int *bits;
3411
3412	if (x->expr_type != EXPR_CONSTANT
3413	\|\| y->expr_type != EXPR_CONSTANT
3414	\|\| z->expr_type != EXPR_CONSTANT)
3415	return NULL__null;
3416
3417	if (!gfc_check_ibits (x, y, z))
3418	return &gfc_bad_expr;
3419
3420	gfc_extract_int (y, &pos);
3421	gfc_extract_int (z, &len);
3422
3423	k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
3424
3425	bitsize = gfc_integer_kinds[k].bit_size;
3426
3427	if (pos + len > bitsize)
3428	{
3429	gfc_error ("Sum of second and third arguments of IBITS exceeds "
3430	"bit size at %L", &y->where);
3431	return &gfc_bad_expr;
3432	}
3433
3434	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3435	convert_mpz_to_unsigned (result->value.integer,
3436	gfc_integer_kinds[k].bit_size);
3437
3438	bits = XCNEWVEC (int, bitsize)((int *) xcalloc ((bitsize), sizeof (int)));
3439
3440	for (i = 0; i < bitsize; i++)
3441	bits[i] = 0;
3442
3443	for (i = 0; i < len; i++)
3444	bits[i] = mpz_tstbit__gmpz_tstbit (x->value.integer, i + pos);
3445
3446	for (i = 0; i < bitsize; i++)
3447	{
3448	if (bits[i] == 0)
3449	mpz_clrbit__gmpz_clrbit (result->value.integer, i);
3450	else if (bits[i] == 1)
3451	mpz_setbit__gmpz_setbit (result->value.integer, i);
3452	else
3453	gfc_internal_error ("IBITS: Bad bit");
3454	}
3455
3456	free (bits);
3457
3458	gfc_convert_mpz_to_signed (result->value.integer,
3459	gfc_integer_kinds[k].bit_size);
3460
3461	return result;
3462	}
3463
3464
3465	gfc_expr *
3466	gfc_simplify_ibset (gfc_expr x, gfc_expr y)
3467	{
3468	gfc_expr *result;
3469	int k, pos;
3470
3471	if (x->expr_type != EXPR_CONSTANT \|\| y->expr_type != EXPR_CONSTANT)
3472	return NULL__null;
3473
3474	if (!gfc_check_bitfcn (x, y))
3475	return &gfc_bad_expr;
3476
3477	gfc_extract_int (y, &pos);
3478
3479	k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3480
3481	result = gfc_copy_expr (x);
3482	/* Drop any separate memory representation of x to avoid potential
3483	inconsistencies in result. */
3484	if (result->representation.string)
3485	{
3486	free (result->representation.string);
3487	result->representation.string = NULL__null;
3488	}
3489
3490	convert_mpz_to_unsigned (result->value.integer,
3491	gfc_integer_kinds[k].bit_size);
3492
3493	mpz_setbit__gmpz_setbit (result->value.integer, pos);
3494
3495	gfc_convert_mpz_to_signed (result->value.integer,
3496	gfc_integer_kinds[k].bit_size);
3497
3498	return result;
3499	}
3500
3501
3502	gfc_expr *
3503	gfc_simplify_ichar (gfc_expr e, gfc_expr kind)
3504	{
3505	gfc_expr *result;
3506	gfc_char_t index;
3507	int k;
3508
3509	if (e->expr_type != EXPR_CONSTANT)
3510	return NULL__null;
3511
3512	if (e->value.character.length != 1)
3513	{
3514	gfc_error ("Argument of ICHAR at %L must be of length one", &e->where);
3515	return &gfc_bad_expr;
3516	}
3517
3518	index = e->value.character.string[0];
3519
3520	k = get_kind (BT_INTEGER, kind, "ICHAR", gfc_default_integer_kind);
3521	if (k == -1)
3522	return &gfc_bad_expr;
3523
3524	result = gfc_get_int_expr (k, &e->where, index);
3525
3526	return range_check (result, "ICHAR");
3527	}
3528
3529
3530	gfc_expr *
3531	gfc_simplify_ieor (gfc_expr x, gfc_expr y)
3532	{
3533	gfc_expr *result;
3534
3535	if (x->expr_type != EXPR_CONSTANT \|\| y->expr_type != EXPR_CONSTANT)
3536	return NULL__null;
3537
3538	result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
3539	mpz_xor__gmpz_xor (result->value.integer, x->value.integer, y->value.integer);
3540
3541	return range_check (result, "IEOR");
3542	}
3543
3544
3545	gfc_expr *
3546	gfc_simplify_index (gfc_expr x, gfc_expr y, gfc_expr b, gfc_expr kind)
3547	{
3548	gfc_expr *result;
3549	bool back;
3550	HOST_WIDE_INTlong len, lensub, start, last, i, index = 0;
3551	int k, delta;
3552
3553	if (x->expr_type != EXPR_CONSTANT \|\| y->expr_type != EXPR_CONSTANT
3554	\|\| ( b != NULL__null && b->expr_type != EXPR_CONSTANT))
3555	return NULL__null;
3556
3557	back = (b != NULL__null && b->value.logical != 0);
3558
3559	k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind);
3560	if (k == -1)
3561	return &gfc_bad_expr;
3562
3563	result = gfc_get_constant_expr (BT_INTEGER, k, &x->where);
3564
3565	len = x->value.character.length;
3566	lensub = y->value.character.length;
3567
3568	if (len < lensub)
3569	{
3570	mpz_set_si__gmpz_set_si (result->value.integer, 0);
3571	return result;
3572	}
3573
3574	if (lensub == 0)
3575	{
3576	if (back)
3577	index = len + 1;
3578	else
3579	index = 1;
3580	goto done;
3581	}
3582
3583	if (!back)
3584	{
3585	last = len + 1 - lensub;
3586	start = 0;
3587	delta = 1;
3588	}
3589	else
3590	{
3591	last = -1;
3592	start = len - lensub;
3593	delta = -1;
3594	}
3595
3596	for (; start != last; start += delta)
3597	{
3598	for (i = 0; i < lensub; i++)
3599	{
3600	if (x->value.character.string[start + i]
3601	!= y->value.character.string[i])
3602	break;
3603	}
3604	if (i == lensub)
3605	{
3606	index = start + 1;
3607	goto done;
3608	}
3609	}
3610
3611	done:
3612	mpz_set_si__gmpz_set_si (result->value.integer, index);
3613	return range_check (result, "INDEX");
3614	}
3615
3616
3617	static gfc_expr *
3618	simplify_intconv (gfc_expr e, int kind, const char name)
3619	{
3620	gfc_expr *result = NULL__null;
3621	int tmp1, tmp2;
3622
3623	/* Convert BOZ to integer, and return without range checking. */
3624	if (e->ts.type == BT_BOZ)
3625	{
3626	if (!gfc_boz2int (e, kind))
3627	return NULL__null;
3628	result = gfc_copy_expr (e);
3629	return result;
3630	}
3631
3632	if (e->expr_type != EXPR_CONSTANT)
3633	return NULL__null;
3634
3635	/* For explicit conversion, turn off -Wconversion and -Wconversion-extra
3636	warnings. */
3637	tmp1 = warn_conversionglobal_options.x_warn_conversion;
3638	tmp2 = warn_conversion_extraglobal_options.x_warn_conversion_extra;
3639	warn_conversionglobal_options.x_warn_conversion = warn_conversion_extraglobal_options.x_warn_conversion_extra = 0;
3640
3641	result = gfc_convert_constant (e, BT_INTEGER, kind);
3642
3643	warn_conversionglobal_options.x_warn_conversion = tmp1;
3644	warn_conversion_extraglobal_options.x_warn_conversion_extra = tmp2;
3645
3646	if (result == &gfc_bad_expr)
3647	return &gfc_bad_expr;
3648
3649	return range_check (result, name);
3650	}
3651
3652
3653	gfc_expr *
3654	gfc_simplify_int (gfc_expr e, gfc_expr k)
3655	{
3656	int kind;
3657
3658	kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
3659	if (kind == -1)
3660	return &gfc_bad_expr;
3661
3662	return simplify_intconv (e, kind, "INT");
3663	}
3664
3665	gfc_expr *
3666	gfc_simplify_int2 (gfc_expr *e)
3667	{
3668	return simplify_intconv (e, 2, "INT2");
3669	}
3670
3671
3672	gfc_expr *
3673	gfc_simplify_int8 (gfc_expr *e)
3674	{
3675	return simplify_intconv (e, 8, "INT8");
3676	}
3677
3678
3679	gfc_expr *
3680	gfc_simplify_long (gfc_expr *e)
3681	{
3682	return simplify_intconv (e, 4, "LONG");
3683	}
3684
3685
3686	gfc_expr *
3687	gfc_simplify_ifix (gfc_expr *e)
3688	{
3689	gfc_expr rtrunc, result;
3690
3691	if (e->expr_type != EXPR_CONSTANT)
3692	return NULL__null;
3693
3694	rtrunc = gfc_copy_expr (e);
3695	mpfr_trunc (rtrunc->value.real, e->value.real)mpfr_rint((rtrunc->value.real), (e->value.real), MPFR_RNDZ );
3696
3697	result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
3698	&e->where);
3699	gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
3700
3701	gfc_free_expr (rtrunc);
3702
3703	return range_check (result, "IFIX");
3704	}
3705
3706
3707	gfc_expr *
3708	gfc_simplify_idint (gfc_expr *e)
3709	{
3710	gfc_expr rtrunc, result;
3711
3712	if (e->expr_type != EXPR_CONSTANT)
3713	return NULL__null;
3714
3715	rtrunc = gfc_copy_expr (e);
3716	mpfr_trunc (rtrunc->value.real, e->value.real)mpfr_rint((rtrunc->value.real), (e->value.real), MPFR_RNDZ );
3717
3718	result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
3719	&e->where);
3720	gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
3721
3722	gfc_free_expr (rtrunc);
3723
3724	return range_check (result, "IDINT");
3725	}
3726
3727
3728	gfc_expr *
3729	gfc_simplify_ior (gfc_expr x, gfc_expr y)
3730	{
3731	gfc_expr *result;
3732
3733	if (x->expr_type != EXPR_CONSTANT \|\| y->expr_type != EXPR_CONSTANT)
3734	return NULL__null;
3735
3736	result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
3737	mpz_ior__gmpz_ior (result->value.integer, x->value.integer, y->value.integer);
3738
3739	return range_check (result, "IOR");
3740	}
3741
3742
3743	static gfc_expr *
3744	do_bit_xor (gfc_expr result, gfc_expr e)
3745	{
3746	gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT)((void)(!(e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 3746, __FUNCTION__), 0 : 0));
3747	gcc_assert (result->ts.type == BT_INTEGER((void)(!(result->ts.type == BT_INTEGER && result-> expr_type == EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 3748, __FUNCTION__), 0 : 0))
3748	&& result->expr_type == EXPR_CONSTANT)((void)(!(result->ts.type == BT_INTEGER && result-> expr_type == EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 3748, __FUNCTION__), 0 : 0));
3749
3750	mpz_xor__gmpz_xor (result->value.integer, result->value.integer, e->value.integer);
3751	return result;
3752	}
3753
3754
3755	gfc_expr *
3756	gfc_simplify_iparity (gfc_expr array, gfc_expr dim, gfc_expr *mask)
3757	{
3758	return simplify_transformation (array, dim, mask, 0, do_bit_xor);
3759	}
3760
3761
3762	gfc_expr *
3763	gfc_simplify_is_iostat_end (gfc_expr *x)
3764	{
3765	if (x->expr_type != EXPR_CONSTANT)
3766	return NULL__null;
3767
3768	return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
3769	mpz_cmp_si (x->value.integer,(__builtin_constant_p ((LIBERROR_END) >= 0) && (LIBERROR_END ) >= 0 ? (__builtin_constant_p ((static_cast<unsigned long > (LIBERROR_END))) && ((static_cast<unsigned long > (LIBERROR_END))) == 0 ? ((x->value.integer)->_mp_size < 0 ? -1 : (x->value.integer)->_mp_size > 0) : __gmpz_cmp_ui (x->value.integer,(static_cast<unsigned long> (LIBERROR_END )))) : __gmpz_cmp_si (x->value.integer,LIBERROR_END))
3770	LIBERROR_END)(__builtin_constant_p ((LIBERROR_END) >= 0) && (LIBERROR_END ) >= 0 ? (__builtin_constant_p ((static_cast<unsigned long > (LIBERROR_END))) && ((static_cast<unsigned long > (LIBERROR_END))) == 0 ? ((x->value.integer)->_mp_size < 0 ? -1 : (x->value.integer)->_mp_size > 0) : __gmpz_cmp_ui (x->value.integer,(static_cast<unsigned long> (LIBERROR_END )))) : __gmpz_cmp_si (x->value.integer,LIBERROR_END)) == 0);
3771	}
3772
3773
3774	gfc_expr *
3775	gfc_simplify_is_iostat_eor (gfc_expr *x)
3776	{
3777	if (x->expr_type != EXPR_CONSTANT)
3778	return NULL__null;
3779
3780	return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
3781	mpz_cmp_si (x->value.integer,(__builtin_constant_p ((LIBERROR_EOR) >= 0) && (LIBERROR_EOR ) >= 0 ? (__builtin_constant_p ((static_cast<unsigned long > (LIBERROR_EOR))) && ((static_cast<unsigned long > (LIBERROR_EOR))) == 0 ? ((x->value.integer)->_mp_size < 0 ? -1 : (x->value.integer)->_mp_size > 0) : __gmpz_cmp_ui (x->value.integer,(static_cast<unsigned long> (LIBERROR_EOR )))) : __gmpz_cmp_si (x->value.integer,LIBERROR_EOR))
3782	LIBERROR_EOR)(__builtin_constant_p ((LIBERROR_EOR) >= 0) && (LIBERROR_EOR ) >= 0 ? (__builtin_constant_p ((static_cast<unsigned long > (LIBERROR_EOR))) && ((static_cast<unsigned long > (LIBERROR_EOR))) == 0 ? ((x->value.integer)->_mp_size < 0 ? -1 : (x->value.integer)->_mp_size > 0) : __gmpz_cmp_ui (x->value.integer,(static_cast<unsigned long> (LIBERROR_EOR )))) : __gmpz_cmp_si (x->value.integer,LIBERROR_EOR)) == 0);
3783	}
3784
3785
3786	gfc_expr *
3787	gfc_simplify_isnan (gfc_expr *x)
3788	{
3789	if (x->expr_type != EXPR_CONSTANT)
3790	return NULL__null;
3791
3792	return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
3793	mpfr_nan_p (x->value.real)(((mpfr_srcptr) (0 ? (x->value.real) : (mpfr_srcptr) (x-> value.real)))->_mpfr_exp == (1 - ((mpfr_exp_t) (((mpfr_uexp_t ) -1) >> 1)))));
3794	}
3795
3796
3797	/* Performs a shift on its first argument. Depending on the last
3798	argument, the shift can be arithmetic, i.e. with filling from the
3799	left like in the SHIFTA intrinsic. */
3800	static gfc_expr *
3801	simplify_shift (gfc_expr e, gfc_expr s, const char *name,
3802	bool arithmetic, int direction)
3803	{
3804	gfc_expr *result;
3805	int ashift, *bits, i, k, bitsize, shift;
3806
3807	if (e->expr_type != EXPR_CONSTANT \|\| s->expr_type != EXPR_CONSTANT)
3808	return NULL__null;
3809
3810	gfc_extract_int (s, &shift);
3811
3812	k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
3813	bitsize = gfc_integer_kinds[k].bit_size;
3814
3815	result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
3816
3817	if (shift == 0)
3818	{
3819	mpz_set__gmpz_set (result->value.integer, e->value.integer);
3820	return result;
3821	}
3822
3823	if (direction > 0 && shift < 0)
3824	{
3825	/* Left shift, as in SHIFTL. */
3826	gfc_error ("Second argument of %s is negative at %L", name, &e->where);
3827	return &gfc_bad_expr;
3828	}
3829	else if (direction < 0)
3830	{
3831	/* Right shift, as in SHIFTR or SHIFTA. */
3832	if (shift < 0)
3833	{
3834	gfc_error ("Second argument of %s is negative at %L",
3835	name, &e->where);
3836	return &gfc_bad_expr;
3837	}
3838
3839	shift = -shift;
3840	}
3841
3842	ashift = (shift >= 0 ? shift : -shift);
3843
3844	if (ashift > bitsize)
3845	{
3846	gfc_error ("Magnitude of second argument of %s exceeds bit size "
3847	"at %L", name, &e->where);
3848	return &gfc_bad_expr;
3849	}
3850
3851	bits = XCNEWVEC (int, bitsize)((int *) xcalloc ((bitsize), sizeof (int)));
3852
3853	for (i = 0; i < bitsize; i++)
3854	bits[i] = mpz_tstbit__gmpz_tstbit (e->value.integer, i);
3855
3856	if (shift > 0)
3857	{
3858	/* Left shift. */
3859	for (i = 0; i < shift; i++)
3860	mpz_clrbit__gmpz_clrbit (result->value.integer, i);
3861
3862	for (i = 0; i < bitsize - shift; i++)
3863	{
3864	if (bits[i] == 0)
3865	mpz_clrbit__gmpz_clrbit (result->value.integer, i + shift);
3866	else
3867	mpz_setbit__gmpz_setbit (result->value.integer, i + shift);
3868	}
3869	}
3870	else
3871	{
3872	/* Right shift. */
3873	if (arithmetic && bits[bitsize - 1])
3874	for (i = bitsize - 1; i >= bitsize - ashift; i--)
3875	mpz_setbit__gmpz_setbit (result->value.integer, i);
3876	else
3877	for (i = bitsize - 1; i >= bitsize - ashift; i--)
3878	mpz_clrbit__gmpz_clrbit (result->value.integer, i);
3879
3880	for (i = bitsize - 1; i >= ashift; i--)
3881	{
3882	if (bits[i] == 0)
3883	mpz_clrbit__gmpz_clrbit (result->value.integer, i - ashift);
3884	else
3885	mpz_setbit__gmpz_setbit (result->value.integer, i - ashift);
3886	}
3887	}
3888
3889	gfc_convert_mpz_to_signed (result->value.integer, bitsize);
3890	free (bits);
3891
3892	return result;
3893	}
3894
3895
3896	gfc_expr *
3897	gfc_simplify_ishft (gfc_expr e, gfc_expr s)
3898	{
3899	return simplify_shift (e, s, "ISHFT", false, 0);
3900	}
3901
3902
3903	gfc_expr *
3904	gfc_simplify_lshift (gfc_expr e, gfc_expr s)
3905	{
3906	return simplify_shift (e, s, "LSHIFT", false, 1);
3907	}
3908
3909
3910	gfc_expr *
3911	gfc_simplify_rshift (gfc_expr e, gfc_expr s)
3912	{
3913	return simplify_shift (e, s, "RSHIFT", true, -1);
3914	}
3915
3916
3917	gfc_expr *
3918	gfc_simplify_shifta (gfc_expr e, gfc_expr s)
3919	{
3920	return simplify_shift (e, s, "SHIFTA", true, -1);
3921	}
3922
3923
3924	gfc_expr *
3925	gfc_simplify_shiftl (gfc_expr e, gfc_expr s)
3926	{
3927	return simplify_shift (e, s, "SHIFTL", false, 1);
3928	}
3929
3930
3931	gfc_expr *
3932	gfc_simplify_shiftr (gfc_expr e, gfc_expr s)
3933	{
3934	return simplify_shift (e, s, "SHIFTR", false, -1);
3935	}
3936
3937
3938	gfc_expr *
3939	gfc_simplify_ishftc (gfc_expr e, gfc_expr s, gfc_expr *sz)
3940	{
3941	gfc_expr *result;
3942	int shift, ashift, isize, ssize, delta, k;
3943	int i, *bits;
3944
3945	if (e->expr_type != EXPR_CONSTANT \|\| s->expr_type != EXPR_CONSTANT)
3946	return NULL__null;
3947
3948	gfc_extract_int (s, &shift);
3949
3950	k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3951	isize = gfc_integer_kinds[k].bit_size;
3952
3953	if (sz != NULL__null)
3954	{
3955	if (sz->expr_type != EXPR_CONSTANT)
3956	return NULL__null;
3957
3958	gfc_extract_int (sz, &ssize);
3959
3960	if (ssize > isize \|\| ssize <= 0)
3961	return &gfc_bad_expr;
3962	}
3963	else
3964	ssize = isize;
3965
3966	if (shift >= 0)
3967	ashift = shift;
3968	else
3969	ashift = -shift;
3970
3971	if (ashift > ssize)
3972	{
3973	if (sz == NULL__null)
3974	gfc_error ("Magnitude of second argument of ISHFTC exceeds "
3975	"BIT_SIZE of first argument at %C");
3976	else
3977	gfc_error ("Absolute value of SHIFT shall be less than or equal "
3978	"to SIZE at %C");
3979	return &gfc_bad_expr;
3980	}
3981
3982	result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
3983
3984	mpz_set__gmpz_set (result->value.integer, e->value.integer);
3985
3986	if (shift == 0)
3987	return result;
3988
3989	convert_mpz_to_unsigned (result->value.integer, isize);
3990
3991	bits = XCNEWVEC (int, ssize)((int *) xcalloc ((ssize), sizeof (int)));
3992
3993	for (i = 0; i < ssize; i++)
3994	bits[i] = mpz_tstbit__gmpz_tstbit (e->value.integer, i);
3995
3996	delta = ssize - ashift;
3997
3998	if (shift > 0)
3999	{
4000	for (i = 0; i < delta; i++)
4001	{
4002	if (bits[i] == 0)
4003	mpz_clrbit__gmpz_clrbit (result->value.integer, i + shift);
4004	else
4005	mpz_setbit__gmpz_setbit (result->value.integer, i + shift);
4006	}
4007
4008	for (i = delta; i < ssize; i++)
4009	{
4010	if (bits[i] == 0)
4011	mpz_clrbit__gmpz_clrbit (result->value.integer, i - delta);
4012	else
4013	mpz_setbit__gmpz_setbit (result->value.integer, i - delta);
4014	}
4015	}
4016	else
4017	{
4018	for (i = 0; i < ashift; i++)
4019	{
4020	if (bits[i] == 0)
4021	mpz_clrbit__gmpz_clrbit (result->value.integer, i + delta);
4022	else
4023	mpz_setbit__gmpz_setbit (result->value.integer, i + delta);
4024	}
4025
4026	for (i = ashift; i < ssize; i++)
4027	{
4028	if (bits[i] == 0)
4029	mpz_clrbit__gmpz_clrbit (result->value.integer, i + shift);
4030	else
4031	mpz_setbit__gmpz_setbit (result->value.integer, i + shift);
4032	}
4033	}
4034
4035	gfc_convert_mpz_to_signed (result->value.integer, isize);
4036
4037	free (bits);
4038	return result;
4039	}
4040
4041
4042	gfc_expr *
4043	gfc_simplify_kind (gfc_expr *e)
4044	{
4045	return gfc_get_int_expr (gfc_default_integer_kind, NULL__null, e->ts.kind);
4046	}
4047
4048
4049	static gfc_expr *
4050	simplify_bound_dim (gfc_expr array, gfc_expr kind, int d, int upper,
4051	gfc_array_spec as, gfc_ref ref, bool coarray)
4052	{
4053	gfc_expr l, u, *result;
4054	int k;
4055
4056	k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
4057	gfc_default_integer_kind);
4058	if (k == -1)
4059	return &gfc_bad_expr;
4060
4061	result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
4062
4063	/* For non-variables, LBOUND(expr, DIM=n) = 1 and
4064	UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */
4065	if (!coarray && array->expr_type != EXPR_VARIABLE)
4066	{
4067	if (upper)
4068	{
4069	gfc_expr* dim = result;
4070	mpz_set_si__gmpz_set_si (dim->value.integer, d);
4071
4072	result = simplify_size (array, dim, k);
4073	gfc_free_expr (dim);
4074	if (!result)
4075	goto returnNull;
4076	}
4077	else
4078	mpz_set_si__gmpz_set_si (result->value.integer, 1);
4079
4080	goto done;
4081	}
4082
4083	/* Otherwise, we have a variable expression. */
4084	gcc_assert (array->expr_type == EXPR_VARIABLE)((void)(!(array->expr_type == EXPR_VARIABLE) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 4084, __FUNCTION__), 0 : 0));
4085	gcc_assert (as)((void)(!(as) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 4085, __FUNCTION__), 0 : 0));
4086
4087	if (!gfc_resolve_array_spec (as, 0))
4088	return NULL__null;
4089
4090	/* The last dimension of an assumed-size array is special. */
4091	if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
4092	\|\| (coarray && d == as->rank + as->corank
4093	&& (!upper \|\| flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_SINGLE)))
4094	{
4095	if (as->lower[d-1] && as->lower[d-1]->expr_type == EXPR_CONSTANT)
4096	{
4097	gfc_free_expr (result);
4098	return gfc_copy_expr (as->lower[d-1]);
4099	}
4100
4101	goto returnNull;
4102	}
4103
4104	result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
4105
4106	/* Then, we need to know the extent of the given dimension. */
4107	if (coarray \|\| (ref->u.ar.type == AR_FULL && !ref->next))
4108	{
4109	gfc_expr *declared_bound;
4110	int empty_bound;
4111	bool constant_lbound, constant_ubound;
4112
4113	l = as->lower[d-1];
4114	u = as->upper[d-1];
4115
4116	gcc_assert (l != NULL)((void)(!(l != __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 4116, __FUNCTION__), 0 : 0));
4117
4118	constant_lbound = l->expr_type == EXPR_CONSTANT;
4119	constant_ubound = u && u->expr_type == EXPR_CONSTANT;
4120
4121	empty_bound = upper ? 0 : 1;
4122	declared_bound = upper ? u : l;
4123
4124	if ((!upper && !constant_lbound)
4125	\|\| (upper && !constant_ubound))
4126	goto returnNull;
4127
4128	if (!coarray)
4129	{
4130	/* For {L,U}BOUND, the value depends on whether the array
4131	is empty. We can nevertheless simplify if the declared bound
4132	has the same value as that of an empty array, in which case
4133	the result isn't dependent on the array emptyness. */
4134	if (mpz_cmp_si (declared_bound->value.integer, empty_bound)(__builtin_constant_p ((empty_bound) >= 0) && (empty_bound ) >= 0 ? (__builtin_constant_p ((static_cast<unsigned long > (empty_bound))) && ((static_cast<unsigned long > (empty_bound))) == 0 ? ((declared_bound->value.integer )->_mp_size < 0 ? -1 : (declared_bound->value.integer )->_mp_size > 0) : __gmpz_cmp_ui (declared_bound->value .integer,(static_cast<unsigned long> (empty_bound)))) : __gmpz_cmp_si (declared_bound->value.integer,empty_bound) ) == 0)
4135	mpz_set_si__gmpz_set_si (result->value.integer, empty_bound);
4136	else if (!constant_lbound \|\| !constant_ubound)
4137	/* Array emptyness can't be determined, we can't simplify. */
4138	goto returnNull;
4139	else if (mpz_cmp__gmpz_cmp (l->value.integer, u->value.integer) > 0)
4140	mpz_set_si__gmpz_set_si (result->value.integer, empty_bound);
4141	else
4142	mpz_set__gmpz_set (result->value.integer, declared_bound->value.integer);
4143	}
4144	else
4145	mpz_set__gmpz_set (result->value.integer, declared_bound->value.integer);
4146	}
4147	else
4148	{
4149	if (upper)
4150	{
4151	int d2 = 0, cnt = 0;
4152	for (int idx = 0; idx < ref->u.ar.dimen; ++idx)
4153	{
4154	if (ref->u.ar.dimen_type[idx] == DIMEN_ELEMENT)
4155	d2++;
4156	else if (cnt < d - 1)
4157	cnt++;
4158	else
4159	break;
4160	}
4161	if (!gfc_ref_dimen_size (&ref->u.ar, d2 + d - 1, &result->value.integer, NULL__null))
4162	goto returnNull;
4163	}
4164	else
4165	mpz_set_si__gmpz_set_si (result->value.integer, (long int) 1);
4166	}
4167
4168	done:
4169	return range_check (result, upper ? "UBOUND" : "LBOUND");
4170
4171	returnNull:
4172	gfc_free_expr (result);
4173	return NULL__null;
4174	}
4175
4176
4177	static gfc_expr *
4178	simplify_bound (gfc_expr array, gfc_expr dim, gfc_expr *kind, int upper)
4179	{
4180	gfc_ref *ref;
4181	gfc_array_spec *as;
4182	ar_type type = AR_UNKNOWN;
4183	int d;
4184
4185	if (array->ts.type == BT_CLASS)
4186	return NULL__null;
4187
4188	if (array->expr_type != EXPR_VARIABLE)
4189	{
4190	as = NULL__null;
4191	ref = NULL__null;
4192	goto done;
4193	}
4194
4195	/* Do not attempt to resolve if error has already been issued. */
4196	if (array->symtree->n.sym->error)
4197	return NULL__null;
4198
4199	/* Follow any component references. */
4200	as = array->symtree->n.sym->as;
4201	for (ref = array->ref; ref; ref = ref->next)
4202	{
4203	switch (ref->type)
4204	{
4205	case REF_ARRAY:
4206	type = ref->u.ar.type;
4207	switch (ref->u.ar.type)
4208	{
4209	case AR_ELEMENT:
4210	as = NULL__null;
4211	continue;
4212
4213	case AR_FULL:
4214	/* We're done because 'as' has already been set in the
4215	previous iteration. */
4216	goto done;
4217
4218	case AR_UNKNOWN:
4219	return NULL__null;
4220
4221	case AR_SECTION:
4222	as = ref->u.ar.as;
4223	goto done;
4224	}
4225
4226	gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 4226, __FUNCTION__));
4227
4228	case REF_COMPONENT:
4229	as = ref->u.c.component->as;
4230	continue;
4231
4232	case REF_SUBSTRING:
4233	case REF_INQUIRY:
4234	continue;
4235	}
4236	}
4237
4238	gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 4238, __FUNCTION__));
4239
4240	done:
4241
4242	if (as && (as->type == AS_DEFERRED \|\| as->type == AS_ASSUMED_RANK
4243	\|\| (as->type == AS_ASSUMED_SHAPE && upper)))
4244	return NULL__null;
4245
4246	/* 'array' shall not be an unallocated allocatable variable or a pointer that
4247	is not associated. */
4248	if (array->expr_type == EXPR_VARIABLE
4249	&& (gfc_expr_attr (array).allocatable \|\| gfc_expr_attr (array).pointer))
4250	return NULL__null;
4251
4252	gcc_assert (!as((void)(!(!as \|\| (as->type != AS_DEFERRED && array ->expr_type == EXPR_VARIABLE && !gfc_expr_attr (array ).allocatable && !gfc_expr_attr (array).pointer)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 4256, __FUNCTION__), 0 : 0))
4253	\|\| (as->type != AS_DEFERRED((void)(!(!as \|\| (as->type != AS_DEFERRED && array ->expr_type == EXPR_VARIABLE && !gfc_expr_attr (array ).allocatable && !gfc_expr_attr (array).pointer)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 4256, __FUNCTION__), 0 : 0))
4254	&& array->expr_type == EXPR_VARIABLE((void)(!(!as \|\| (as->type != AS_DEFERRED && array ->expr_type == EXPR_VARIABLE && !gfc_expr_attr (array ).allocatable && !gfc_expr_attr (array).pointer)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 4256, __FUNCTION__), 0 : 0))
4255	&& !gfc_expr_attr (array).allocatable((void)(!(!as \|\| (as->type != AS_DEFERRED && array ->expr_type == EXPR_VARIABLE && !gfc_expr_attr (array ).allocatable && !gfc_expr_attr (array).pointer)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 4256, __FUNCTION__), 0 : 0))
4256	&& !gfc_expr_attr (array).pointer))((void)(!(!as \|\| (as->type != AS_DEFERRED && array ->expr_type == EXPR_VARIABLE && !gfc_expr_attr (array ).allocatable && !gfc_expr_attr (array).pointer)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 4256, __FUNCTION__), 0 : 0));
4257
4258	if (dim == NULL__null)
4259	{
4260	/* Multi-dimensional bounds. */
4261	gfc_expr *bounds[GFC_MAX_DIMENSIONS15];
4262	gfc_expr *e;
4263	int k;
4264
4265	/* UBOUND(ARRAY) is not valid for an assumed-size array. */
4266	if (upper && type == AR_FULL && as && as->type == AS_ASSUMED_SIZE)
4267	{
4268	/* An error message will be emitted in
4269	check_assumed_size_reference (resolve.cc). */
4270	return &gfc_bad_expr;
4271	}
4272
4273	/* Simplify the bounds for each dimension. */
4274	for (d = 0; d < array->rank; d++)
4275	{
4276	bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref,
4277	false);
4278	if (bounds[d] == NULL__null \|\| bounds[d] == &gfc_bad_expr)
4279	{
4280	int j;
4281
4282	for (j = 0; j < d; j++)
4283	gfc_free_expr (bounds[j]);
4284
4285	if (gfc_seen_div0)
4286	return &gfc_bad_expr;
4287	else
4288	return bounds[d];
4289	}
4290	}
4291
4292	/* Allocate the result expression. */
4293	k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
4294	gfc_default_integer_kind);
4295	if (k == -1)
4296	return &gfc_bad_expr;
4297
4298	e = gfc_get_array_expr (BT_INTEGER, k, &array->where);
4299
4300	/* The result is a rank 1 array; its size is the rank of the first
4301	argument to {L,U}BOUND. */
4302	e->rank = 1;
4303	e->shape = gfc_get_shape (1)(((mpz_t *) xcalloc (((1)), sizeof (mpz_t))));
4304	mpz_init_set_ui__gmpz_init_set_ui (e->shape[0], array->rank);
4305
4306	/* Create the constructor for this array. */
4307	for (d = 0; d < array->rank; d++)
4308	gfc_constructor_append_expr (&e->value.constructor,
4309	bounds[d], &e->where);
4310
4311	return e;
4312	}
4313	else
4314	{
4315	/* A DIM argument is specified. */
4316	if (dim->expr_type != EXPR_CONSTANT)
4317	return NULL__null;
4318
4319	d = mpz_get_si__gmpz_get_si (dim->value.integer);
4320
4321	if ((d < 1 \|\| d > array->rank)
4322	\|\| (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper))
4323	{
4324	gfc_error ("DIM argument at %L is out of bounds", &dim->where);
4325	return &gfc_bad_expr;
4326	}
4327
4328	if (as && as->type == AS_ASSUMED_RANK)
4329	return NULL__null;
4330
4331	return simplify_bound_dim (array, kind, d, upper, as, ref, false);
4332	}
4333	}
4334
4335
4336	static gfc_expr *
4337	simplify_cobound (gfc_expr array, gfc_expr dim, gfc_expr *kind, int upper)
4338	{
4339	gfc_ref *ref;
4340	gfc_array_spec *as;
4341	int d;
4342
4343	if (array->expr_type != EXPR_VARIABLE)
4344	return NULL__null;
4345
4346	/* Follow any component references. */
4347	as = (array->ts.type == BT_CLASS && array->ts.u.derived->components)
4348	? array->ts.u.derived->components->as
4349	: array->symtree->n.sym->as;
4350	for (ref = array->ref; ref; ref = ref->next)
4351	{
4352	switch (ref->type)
4353	{
4354	case REF_ARRAY:
4355	switch (ref->u.ar.type)
4356	{
4357	case AR_ELEMENT:
4358	if (ref->u.ar.as->corank > 0)
4359	{
4360	gcc_assert (as == ref->u.ar.as)((void)(!(as == ref->u.ar.as) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 4360, __FUNCTION__), 0 : 0));
4361	goto done;
4362	}
4363	as = NULL__null;
4364	continue;
4365
4366	case AR_FULL:
4367	/* We're done because 'as' has already been set in the
4368	previous iteration. */
4369	goto done;
4370
4371	case AR_UNKNOWN:
4372	return NULL__null;
4373
4374	case AR_SECTION:
4375	as = ref->u.ar.as;
4376	goto done;
4377	}
4378
4379	gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 4379, __FUNCTION__));
4380
4381	case REF_COMPONENT:
4382	as = ref->u.c.component->as;
4383	continue;
4384
4385	case REF_SUBSTRING:
4386	case REF_INQUIRY:
4387	continue;
4388	}
4389	}
4390
4391	if (!as)
4392	gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 4392, __FUNCTION__));
4393
4394	done:
4395
4396	if (as->cotype == AS_DEFERRED \|\| as->cotype == AS_ASSUMED_SHAPE)
4397	return NULL__null;
4398
4399	if (dim == NULL__null)
4400	{
4401	/* Multi-dimensional cobounds. */
4402	gfc_expr *bounds[GFC_MAX_DIMENSIONS15];
4403	gfc_expr *e;
4404	int k;
4405
4406	/* Simplify the cobounds for each dimension. */
4407	for (d = 0; d < as->corank; d++)
4408	{
4409	bounds[d] = simplify_bound_dim (array, kind, d + 1 + as->rank,
4410	upper, as, ref, true);
4411	if (bounds[d] == NULL__null \|\| bounds[d] == &gfc_bad_expr)
4412	{
4413	int j;
4414
4415	for (j = 0; j < d; j++)
4416	gfc_free_expr (bounds[j]);
4417	return bounds[d];
4418	}
4419	}
4420
4421	/* Allocate the result expression. */
4422	e = gfc_get_expr ();
4423	e->where = array->where;
4424	e->expr_type = EXPR_ARRAY;
4425	e->ts.type = BT_INTEGER;
4426	k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND",
4427	gfc_default_integer_kind);
4428	if (k == -1)
4429	{
4430	gfc_free_expr (e);
4431	return &gfc_bad_expr;
4432	}
4433	e->ts.kind = k;
4434
4435	/* The result is a rank 1 array; its size is the rank of the first
4436	argument to {L,U}COBOUND. */
4437	e->rank = 1;
4438	e->shape = gfc_get_shape (1)(((mpz_t *) xcalloc (((1)), sizeof (mpz_t))));
4439	mpz_init_set_ui__gmpz_init_set_ui (e->shape[0], as->corank);
4440
4441	/* Create the constructor for this array. */
4442	for (d = 0; d < as->corank; d++)
4443	gfc_constructor_append_expr (&e->value.constructor,
4444	bounds[d], &e->where);
4445	return e;
4446	}
4447	else
4448	{
4449	/* A DIM argument is specified. */
4450	if (dim->expr_type != EXPR_CONSTANT)
4451	return NULL__null;
4452
4453	d = mpz_get_si__gmpz_get_si (dim->value.integer);
4454
4455	if (d < 1 \|\| d > as->corank)
4456	{
4457	gfc_error ("DIM argument at %L is out of bounds", &dim->where);
4458	return &gfc_bad_expr;
4459	}
4460
4461	return simplify_bound_dim (array, kind, d+as->rank, upper, as, ref, true);
4462	}
4463	}
4464
4465
4466	gfc_expr *
4467	gfc_simplify_lbound (gfc_expr array, gfc_expr dim, gfc_expr *kind)
4468	{
4469	return simplify_bound (array, dim, kind, 0);
4470	}
4471
4472
4473	gfc_expr *
4474	gfc_simplify_lcobound (gfc_expr array, gfc_expr dim, gfc_expr *kind)
4475	{
4476	return simplify_cobound (array, dim, kind, 0);
4477	}
4478
4479	gfc_expr *
4480	gfc_simplify_leadz (gfc_expr *e)
4481	{
4482	unsigned long lz, bs;
4483	int i;
4484
4485	if (e->expr_type != EXPR_CONSTANT)
4486	return NULL__null;
4487
4488	i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4489	bs = gfc_integer_kinds[i].bit_size;
4490	if (mpz_cmp_si (e->value.integer, 0)(__builtin_constant_p ((0) >= 0) && (0) >= 0 ? ( __builtin_constant_p ((static_cast<unsigned long> (0))) && ((static_cast<unsigned long> (0))) == 0 ? ( (e->value.integer)->_mp_size < 0 ? -1 : (e->value .integer)->_mp_size > 0) : __gmpz_cmp_ui (e->value.integer ,(static_cast<unsigned long> (0)))) : __gmpz_cmp_si (e-> value.integer,0)) == 0)
4491	lz = bs;
4492	else if (mpz_cmp_si (e->value.integer, 0)(__builtin_constant_p ((0) >= 0) && (0) >= 0 ? ( __builtin_constant_p ((static_cast<unsigned long> (0))) && ((static_cast<unsigned long> (0))) == 0 ? ( (e->value.integer)->_mp_size < 0 ? -1 : (e->value .integer)->_mp_size > 0) : __gmpz_cmp_ui (e->value.integer ,(static_cast<unsigned long> (0)))) : __gmpz_cmp_si (e-> value.integer,0)) < 0)
4493	lz = 0;
4494	else
4495	lz = bs - mpz_sizeinbase__gmpz_sizeinbase (e->value.integer, 2);
4496
4497	return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz);
4498	}
4499
4500
4501	/* Check for constant length of a substring. */
4502
4503	static bool
4504	substring_has_constant_len (gfc_expr *e)
4505	{
4506	gfc_ref *ref;
4507	HOST_WIDE_INTlong istart, iend, length;
4508	bool equal_length = false;
4509
4510	if (e->ts.type != BT_CHARACTER)
4511	return false;
4512
4513	for (ref = e->ref; ref; ref = ref->next)
4514	if (ref->type != REF_COMPONENT && ref->type != REF_ARRAY)
4515	break;
4516
4517	if (!ref
4518	\|\| ref->type != REF_SUBSTRING
4519	\|\| !ref->u.ss.start
4520	\|\| ref->u.ss.start->expr_type != EXPR_CONSTANT
4521	\|\| !ref->u.ss.end
4522	\|\| ref->u.ss.end->expr_type != EXPR_CONSTANT)
4523	return false;
4524
4525	/* Basic checks on substring starting and ending indices. */
4526	if (!gfc_resolve_substring (ref, &equal_length))
4527	return false;
4528
4529	istart = gfc_mpz_get_hwi (ref->u.ss.start->value.integer);
4530	iend = gfc_mpz_get_hwi (ref->u.ss.end->value.integer);
4531
4532	if (istart <= iend)
4533	length = iend - istart + 1;
4534	else
4535	length = 0;
4536
4537	/* Fix substring length. */
4538	e->value.character.length = length;
4539
4540	return true;
4541	}
4542
4543
4544	gfc_expr *
4545	gfc_simplify_len (gfc_expr e, gfc_expr kind)
4546	{
4547	gfc_expr *result;
4548	int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
4549
4550	if (k == -1)
4551	return &gfc_bad_expr;
4552
4553	if (e->expr_type == EXPR_CONSTANT
4554	\|\| substring_has_constant_len (e))
4555	{
4556	result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
4557	mpz_set_si__gmpz_set_si (result->value.integer, e->value.character.length);
4558	return range_check (result, "LEN");
4559	}
4560	else if (e->ts.u.cl != NULL__null && e->ts.u.cl->length != NULL__null
4561	&& e->ts.u.cl->length->expr_type == EXPR_CONSTANT
4562	&& e->ts.u.cl->length->ts.type == BT_INTEGER)
4563	{
4564	result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
4565	mpz_set__gmpz_set (result->value.integer, e->ts.u.cl->length->value.integer);
4566	return range_check (result, "LEN");
4567	}
4568	else if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_CHARACTER
4569	&& e->symtree->n.sym
4570	&& e->symtree->n.sym->ts.type != BT_DERIVED
4571	&& e->symtree->n.sym->assoc && e->symtree->n.sym->assoc->target
4572	&& e->symtree->n.sym->assoc->target->ts.type == BT_DERIVED
4573	&& e->symtree->n.sym->assoc->target->symtree->n.sym
4574	&& UNLIMITED_POLY (e->symtree->n.sym->assoc->target->symtree->n.sym)(e->symtree->n.sym->assoc->target->symtree-> n.sym != __null && e->symtree->n.sym->assoc-> target->symtree->n.sym->ts.type == BT_CLASS && e->symtree->n.sym->assoc->target->symtree-> n.sym->ts.u.derived->components && e->symtree ->n.sym->assoc->target->symtree->n.sym->ts. u.derived->components->ts.u.derived && e->symtree ->n.sym->assoc->target->symtree->n.sym->ts. u.derived->components->ts.u.derived->attr.unlimited_polymorphic ))
4575
4576	/* The expression in assoc->target points to a ref to the _data component
4577	of the unlimited polymorphic entity. To get the _len component the last
4578	_data ref needs to be stripped and a ref to the _len component added. */
4579	return gfc_get_len_component (e->symtree->n.sym->assoc->target, k);
4580	else
4581	return NULL__null;
4582	}
4583
4584
4585	gfc_expr *
4586	gfc_simplify_len_trim (gfc_expr e, gfc_expr kind)
4587	{
4588	gfc_expr *result;
4589	size_t count, len, i;
4590	int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
4591
4592	if (k == -1)
4593	return &gfc_bad_expr;
4594
4595	if (e->expr_type != EXPR_CONSTANT)
4596	return NULL__null;
4597
4598	len = e->value.character.length;
4599	for (count = 0, i = 1; i <= len; i++)
4600	if (e->value.character.string[len - i] == ' ')
4601	count++;
4602	else
4603	break;
4604
4605	result = gfc_get_int_expr (k, &e->where, len - count);
4606	return range_check (result, "LEN_TRIM");
4607	}
4608
4609	gfc_expr *
4610	gfc_simplify_lgamma (gfc_expr *x)
4611	{
4612	gfc_expr *result;
4613	int sg;
4614
4615	if (x->expr_type != EXPR_CONSTANT)
4616	return NULL__null;
4617
4618	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4619	mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODEMPFR_RNDN);
4620
4621	return range_check (result, "LGAMMA");
4622	}
4623
4624
4625	gfc_expr *
4626	gfc_simplify_lge (gfc_expr a, gfc_expr b)
4627	{
4628	if (a->expr_type != EXPR_CONSTANT \|\| b->expr_type != EXPR_CONSTANT)
4629	return NULL__null;
4630
4631	return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
4632	gfc_compare_string (a, b) >= 0);
4633	}
4634
4635
4636	gfc_expr *
4637	gfc_simplify_lgt (gfc_expr a, gfc_expr b)
4638	{
4639	if (a->expr_type != EXPR_CONSTANT \|\| b->expr_type != EXPR_CONSTANT)
4640	return NULL__null;
4641
4642	return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
4643	gfc_compare_string (a, b) > 0);
4644	}
4645
4646
4647	gfc_expr *
4648	gfc_simplify_lle (gfc_expr a, gfc_expr b)
4649	{
4650	if (a->expr_type != EXPR_CONSTANT \|\| b->expr_type != EXPR_CONSTANT)
4651	return NULL__null;
4652
4653	return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
4654	gfc_compare_string (a, b) <= 0);
4655	}
4656
4657
4658	gfc_expr *
4659	gfc_simplify_llt (gfc_expr a, gfc_expr b)
4660	{
4661	if (a->expr_type != EXPR_CONSTANT \|\| b->expr_type != EXPR_CONSTANT)
4662	return NULL__null;
4663
4664	return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
4665	gfc_compare_string (a, b) < 0);
4666	}
4667
4668
4669	gfc_expr *
4670	gfc_simplify_log (gfc_expr *x)
4671	{
4672	gfc_expr *result;
4673
4674	if (x->expr_type != EXPR_CONSTANT)
4675	return NULL__null;
4676
4677	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4678
4679	switch (x->ts.type)
4680	{
4681	case BT_REAL:
4682	if (mpfr_sgn (x->value.real)((x->value.real)->_mpfr_exp < (2 - ((mpfr_exp_t) ((( mpfr_uexp_t) -1) >> 1))) ? ((((mpfr_srcptr) (0 ? (x-> value.real) : (mpfr_srcptr) (x->value.real)))->_mpfr_exp == (1 - ((mpfr_exp_t) (((mpfr_uexp_t) -1) >> 1)))) ? mpfr_set_erangeflag () : (mpfr_void) 0), 0 : ((x->value.real)->_mpfr_sign) ) <= 0)
4683	{
4684	gfc_error ("Argument of LOG at %L cannot be less than or equal "
4685	"to zero", &x->where);
4686	gfc_free_expr (result);
4687	return &gfc_bad_expr;
4688	}
4689
4690	mpfr_log (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);
4691	break;
4692
4693	case BT_COMPLEX:
4694	if (mpfr_zero_p (mpc_realref (x->value.complex))(((mpfr_srcptr) (0 ? (((x->value.complex)->re)) : (mpfr_srcptr ) (((x->value.complex)->re))))->_mpfr_exp == (0 - (( mpfr_exp_t) (((mpfr_uexp_t) -1) >> 1))))
4695	&& mpfr_zero_p (mpc_imagref (x->value.complex))(((mpfr_srcptr) (0 ? (((x->value.complex)->im)) : (mpfr_srcptr ) (((x->value.complex)->im))))->_mpfr_exp == (0 - (( mpfr_exp_t) (((mpfr_uexp_t) -1) >> 1)))))
4696	{
4697	gfc_error ("Complex argument of LOG at %L cannot be zero",
4698	&x->where);
4699	gfc_free_expr (result);
4700	return &gfc_bad_expr;
4701	}
4702
4703	gfc_set_model_kind (x->ts.kind);
4704	mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
4705	break;
4706
4707	default:
4708	gfc_internal_error ("gfc_simplify_log: bad type");
4709	}
4710
4711	return range_check (result, "LOG");
4712	}
4713
4714
4715	gfc_expr *
4716	gfc_simplify_log10 (gfc_expr *x)
4717	{
4718	gfc_expr *result;
4719
4720	if (x->expr_type != EXPR_CONSTANT)
4721	return NULL__null;
4722
4723	if (mpfr_sgn (x->value.real)((x->value.real)->_mpfr_exp < (2 - ((mpfr_exp_t) ((( mpfr_uexp_t) -1) >> 1))) ? ((((mpfr_srcptr) (0 ? (x-> value.real) : (mpfr_srcptr) (x->value.real)))->_mpfr_exp == (1 - ((mpfr_exp_t) (((mpfr_uexp_t) -1) >> 1)))) ? mpfr_set_erangeflag () : (mpfr_void) 0), 0 : ((x->value.real)->_mpfr_sign) ) <= 0)
4724	{
4725	gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
4726	"to zero", &x->where);
4727	return &gfc_bad_expr;
4728	}
4729
4730	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4731	mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);
4732
4733	return range_check (result, "LOG10");
4734	}
4735
4736
4737	gfc_expr *
4738	gfc_simplify_logical (gfc_expr e, gfc_expr k)
4739	{
4740	int kind;
4741
4742	kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
4743	if (kind < 0)
4744	return &gfc_bad_expr;
4745
4746	if (e->expr_type != EXPR_CONSTANT)
4747	return NULL__null;
4748
4749	return gfc_get_logical_expr (kind, &e->where, e->value.logical);
4750	}
4751
4752
4753	gfc_expr*
4754	gfc_simplify_matmul (gfc_expr matrix_a, gfc_expr matrix_b)
4755	{
4756	gfc_expr *result;
4757	int row, result_rows, col, result_columns;
4758	int stride_a, offset_a, stride_b, offset_b;
4759
4760	if (!is_constant_array_expr (matrix_a)
4761	\|\| !is_constant_array_expr (matrix_b))
4762	return NULL__null;
4763
4764	/* MATMUL should do mixed-mode arithmetic. Set the result type. */
4765	if (matrix_a->ts.type != matrix_b->ts.type)
4766	{
4767	gfc_expr e;
4768	e.expr_type = EXPR_OP;
4769	gfc_clear_ts (&e.ts);
4770	e.value.op.op = INTRINSIC_NONE;
4771	e.value.op.op1 = matrix_a;
4772	e.value.op.op2 = matrix_b;
4773	gfc_type_convert_binary (&e, 1);
4774	result = gfc_get_array_expr (e.ts.type, e.ts.kind, &matrix_a->where);
4775	}
4776	else
4777	{
4778	result = gfc_get_array_expr (matrix_a->ts.type, matrix_a->ts.kind,
4779	&matrix_a->where);
4780	}
4781
4782	if (matrix_a->rank == 1 && matrix_b->rank == 2)
4783	{
4784	result_rows = 1;
4785	result_columns = mpz_get_si__gmpz_get_si (matrix_b->shape[1]);
4786	stride_a = 1;
4787	stride_b = mpz_get_si__gmpz_get_si (matrix_b->shape[0]);
4788
4789	result->rank = 1;
4790	result->shape = gfc_get_shape (result->rank)(((mpz_t *) xcalloc (((result->rank)), sizeof (mpz_t))));
4791	mpz_init_set_si__gmpz_init_set_si (result->shape[0], result_columns);
4792	}
4793	else if (matrix_a->rank == 2 && matrix_b->rank == 1)
4794	{
4795	result_rows = mpz_get_si__gmpz_get_si (matrix_a->shape[0]);
4796	result_columns = 1;
4797	stride_a = mpz_get_si__gmpz_get_si (matrix_a->shape[0]);
4798	stride_b = 1;
4799
4800	result->rank = 1;
4801	result->shape = gfc_get_shape (result->rank)(((mpz_t *) xcalloc (((result->rank)), sizeof (mpz_t))));
4802	mpz_init_set_si__gmpz_init_set_si (result->shape[0], result_rows);
4803	}
4804	else if (matrix_a->rank == 2 && matrix_b->rank == 2)
4805	{
4806	result_rows = mpz_get_si__gmpz_get_si (matrix_a->shape[0]);
4807	result_columns = mpz_get_si__gmpz_get_si (matrix_b->shape[1]);
4808	stride_a = mpz_get_si__gmpz_get_si (matrix_a->shape[0]);
4809	stride_b = mpz_get_si__gmpz_get_si (matrix_b->shape[0]);
4810
4811	result->rank = 2;
4812	result->shape = gfc_get_shape (result->rank)(((mpz_t *) xcalloc (((result->rank)), sizeof (mpz_t))));
4813	mpz_init_set_si__gmpz_init_set_si (result->shape[0], result_rows);
4814	mpz_init_set_si__gmpz_init_set_si (result->shape[1], result_columns);
4815	}
4816	else
4817	gcc_unreachable()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 4817, __FUNCTION__));
4818
4819	offset_b = 0;
4820	for (col = 0; col < result_columns; ++col)
4821	{
4822	offset_a = 0;
4823
4824	for (row = 0; row < result_rows; ++row)
4825	{
4826	gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a,
4827	matrix_b, 1, offset_b, false);
4828	gfc_constructor_append_expr (&result->value.constructor,
4829	e, NULL__null);
4830
4831	offset_a += 1;
4832	}
4833
4834	offset_b += stride_b;
4835	}
4836
4837	return result;
4838	}
4839
4840
4841	gfc_expr *
4842	gfc_simplify_maskr (gfc_expr i, gfc_expr kind_arg)
4843	{
4844	gfc_expr *result;
4845	int kind, arg, k;
4846
4847	if (i->expr_type != EXPR_CONSTANT)
4848	return NULL__null;
4849
4850	kind = get_kind (BT_INTEGER, kind_arg, "MASKR", gfc_default_integer_kind);
4851	if (kind == -1)
4852	return &gfc_bad_expr;
4853	k = gfc_validate_kind (BT_INTEGER, kind, false);
4854
4855	bool fail = gfc_extract_int (i, &arg);
4856	gcc_assert (!fail)((void)(!(!fail) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 4856, __FUNCTION__), 0 : 0));
4857
4858	if (!gfc_check_mask (i, kind_arg))
4859	return &gfc_bad_expr;
4860
4861	result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
4862
4863	/* MASKR(n) = 2^n - 1 */
4864	mpz_set_ui__gmpz_set_ui (result->value.integer, 1);
4865	mpz_mul_2exp__gmpz_mul_2exp (result->value.integer, result->value.integer, arg);
4866	mpz_sub_ui__gmpz_sub_ui (result->value.integer, result->value.integer, 1);
4867
4868	gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
4869
4870	return result;
4871	}
4872
4873
4874	gfc_expr *
4875	gfc_simplify_maskl (gfc_expr i, gfc_expr kind_arg)
4876	{
4877	gfc_expr *result;
4878	int kind, arg, k;
4879	mpz_t z;
4880
4881	if (i->expr_type != EXPR_CONSTANT)
4882	return NULL__null;
4883
4884	kind = get_kind (BT_INTEGER, kind_arg, "MASKL", gfc_default_integer_kind);
4885	if (kind == -1)
4886	return &gfc_bad_expr;
4887	k = gfc_validate_kind (BT_INTEGER, kind, false);
4888
4889	bool fail = gfc_extract_int (i, &arg);
4890	gcc_assert (!fail)((void)(!(!fail) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 4890, __FUNCTION__), 0 : 0));
4891
4892	if (!gfc_check_mask (i, kind_arg))
4893	return &gfc_bad_expr;
4894
4895	result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
4896
4897	/* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
4898	mpz_init_set_ui__gmpz_init_set_ui (z, 1);
4899	mpz_mul_2exp__gmpz_mul_2exp (z, z, gfc_integer_kinds[k].bit_size);
4900	mpz_set_ui__gmpz_set_ui (result->value.integer, 1);
4901	mpz_mul_2exp__gmpz_mul_2exp (result->value.integer, result->value.integer,
4902	gfc_integer_kinds[k].bit_size - arg);
4903	mpz_sub__gmpz_sub (result->value.integer, z, result->value.integer);
4904	mpz_clear__gmpz_clear (z);
4905
4906	gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
4907
4908	return result;
4909	}
4910
4911
4912	gfc_expr *
4913	gfc_simplify_merge (gfc_expr tsource, gfc_expr fsource, gfc_expr *mask)
4914	{
4915	gfc_expr * result;
4916	gfc_constructor tsource_ctor, fsource_ctor, *mask_ctor;
4917
4918	if (mask->expr_type == EXPR_CONSTANT)
4919	{
4920	/* The standard requires evaluation of all function arguments.
4921	Simplify only when the other dropped argument (FSOURCE or TSOURCE)
4922	is a constant expression. */
4923	if (mask->value.logical)
4924	{
4925	if (!gfc_is_constant_expr (fsource))
4926	return NULL__null;
4927	result = gfc_copy_expr (tsource);
4928	}
4929	else
4930	{
4931	if (!gfc_is_constant_expr (tsource))
4932	return NULL__null;
4933	result = gfc_copy_expr (fsource);
4934	}
4935
4936	/* Parenthesis is needed to get lower bounds of 1. */
4937	result = gfc_get_parentheses (result);
4938	gfc_simplify_expr (result, 1);
4939	return result;
4940	}
4941
4942	if (!mask->rank \|\| !is_constant_array_expr (mask)
4943	\|\| !is_constant_array_expr (tsource) \|\| !is_constant_array_expr (fsource))
4944	return NULL__null;
4945
4946	result = gfc_get_array_expr (tsource->ts.type, tsource->ts.kind,
4947	&tsource->where);
4948	if (tsource->ts.type == BT_DERIVED)
4949	result->ts.u.derived = tsource->ts.u.derived;
4950	else if (tsource->ts.type == BT_CHARACTER)
4951	result->ts.u.cl = tsource->ts.u.cl;
4952
4953	tsource_ctor = gfc_constructor_first (tsource->value.constructor);
4954	fsource_ctor = gfc_constructor_first (fsource->value.constructor);
4955	mask_ctor = gfc_constructor_first (mask->value.constructor);
4956
4957	while (mask_ctor)
4958	{
4959	if (mask_ctor->expr->value.logical)
4960	gfc_constructor_append_expr (&result->value.constructor,
4961	gfc_copy_expr (tsource_ctor->expr),
4962	NULL__null);
4963	else
4964	gfc_constructor_append_expr (&result->value.constructor,
4965	gfc_copy_expr (fsource_ctor->expr),
4966	NULL__null);
4967	tsource_ctor = gfc_constructor_next (tsource_ctor);
4968	fsource_ctor = gfc_constructor_next (fsource_ctor);
4969	mask_ctor = gfc_constructor_next (mask_ctor);
4970	}
4971
4972	result->shape = gfc_get_shape (1)(((mpz_t *) xcalloc (((1)), sizeof (mpz_t))));
4973	gfc_array_size (result, &result->shape[0]);
4974
4975	return result;
4976	}
4977
4978
4979	gfc_expr *
4980	gfc_simplify_merge_bits (gfc_expr i, gfc_expr j, gfc_expr *mask_expr)
4981	{
4982	mpz_t arg1, arg2, mask;
4983	gfc_expr *result;
4984
4985	if (i->expr_type != EXPR_CONSTANT \|\| j->expr_type != EXPR_CONSTANT
4986	\|\| mask_expr->expr_type != EXPR_CONSTANT)
4987	return NULL__null;
4988
4989	result = gfc_get_constant_expr (BT_INTEGER, i->ts.kind, &i->where);
4990
4991	/* Convert all argument to unsigned. */
4992	mpz_init_set__gmpz_init_set (arg1, i->value.integer);
4993	mpz_init_set__gmpz_init_set (arg2, j->value.integer);
4994	mpz_init_set__gmpz_init_set (mask, mask_expr->value.integer);
4995
4996	/* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */
4997	mpz_and__gmpz_and (arg1, arg1, mask);
4998	mpz_com__gmpz_com (mask, mask);
4999	mpz_and__gmpz_and (arg2, arg2, mask);
5000	mpz_ior__gmpz_ior (result->value.integer, arg1, arg2);
5001
5002	mpz_clear__gmpz_clear (arg1);
5003	mpz_clear__gmpz_clear (arg2);
5004	mpz_clear__gmpz_clear (mask);
5005
5006	return result;
5007	}
5008
5009
5010	/* Selects between current value and extremum for simplify_min_max
5011	and simplify_minval_maxval. */
5012	static int
5013	min_max_choose (gfc_expr arg, gfc_expr extremum, int sign, bool back_val)
5014	{
5015	int ret;
5016
5017	switch (arg->ts.type)
5018	{
5019	case BT_INTEGER:
5020	if (extremum->ts.kind < arg->ts.kind)
5021	extremum->ts.kind = arg->ts.kind;
5022	ret = mpz_cmp__gmpz_cmp (arg->value.integer,
5023	extremum->value.integer) * sign;
5024	if (ret > 0)
5025	mpz_set__gmpz_set (extremum->value.integer, arg->value.integer);
5026	break;
5027
5028	case BT_REAL:
5029	if (extremum->ts.kind < arg->ts.kind)
5030	extremum->ts.kind = arg->ts.kind;
5031	if (mpfr_nan_p (extremum->value.real)(((mpfr_srcptr) (0 ? (extremum->value.real) : (mpfr_srcptr ) (extremum->value.real)))->_mpfr_exp == (1 - ((mpfr_exp_t ) (((mpfr_uexp_t) -1) >> 1)))))
5032	{
5033	ret = 1;
5034	mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (arg->value.real); mpfr_set4 (extremum->value.real,_p,MPFR_RNDN,((_p)->_mpfr_sign)); });
5035	}
5036	else if (mpfr_nan_p (arg->value.real)(((mpfr_srcptr) (0 ? (arg->value.real) : (mpfr_srcptr) (arg ->value.real)))->_mpfr_exp == (1 - ((mpfr_exp_t) (((mpfr_uexp_t ) -1) >> 1)))))
5037	ret = -1;
5038	else
5039	{
5040	ret = mpfr_cmp (arg->value.real, extremum->value.real)mpfr_cmp3(arg->value.real, extremum->value.real, 1) * sign;
5041	if (ret > 0)
5042	mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (arg->value.real); mpfr_set4 (extremum->value.real,_p,MPFR_RNDN,((_p)->_mpfr_sign)); });
5043	}
5044	break;
5045
5046	case BT_CHARACTER:
5047	#define LENGTH(x) ((x)->value.character.length)
5048	#define STRING(x) ((x)->value.character.string)
5049	if (LENGTH (extremum) < LENGTH(arg))
5050	{
5051	gfc_char_t *tmp = STRING(extremum);
5052
5053	STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1)((gfc_char_t *) xcalloc ((LENGTH(arg) + 1), sizeof (gfc_char_t )));
5054	memcpy (STRING(extremum), tmp,
5055	LENGTH(extremum) * sizeof (gfc_char_t));
5056	gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
5057	LENGTH(arg) - LENGTH(extremum));
5058	STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */
5059	LENGTH(extremum) = LENGTH(arg);
5060	free (tmp);
5061	}
5062	ret = gfc_compare_string (arg, extremum) * sign;
5063	if (ret > 0)
5064	{
5065	free (STRING(extremum));
5066	STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1)((gfc_char_t *) xcalloc ((LENGTH(extremum) + 1), sizeof (gfc_char_t )));
5067	memcpy (STRING(extremum), STRING(arg),
5068	LENGTH(arg) * sizeof (gfc_char_t));
5069	gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
5070	LENGTH(extremum) - LENGTH(arg));
5071	STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */
5072	}
5073	#undef LENGTH
5074	#undef STRING
5075	break;
5076
5077	default:
5078	gfc_internal_error ("simplify_min_max(): Bad type in arglist");
5079	}
5080	if (back_val && ret == 0)
5081	ret = 1;
5082
5083	return ret;
5084	}
5085
5086
5087	/* This function is special since MAX() can take any number of
5088	arguments. The simplified expression is a rewritten version of the
5089	argument list containing at most one constant element. Other
5090	constant elements are deleted. Because the argument list has
5091	already been checked, this function always succeeds. sign is 1 for
5092	MAX(), -1 for MIN(). */
5093
5094	static gfc_expr *
5095	simplify_min_max (gfc_expr *expr, int sign)
5096	{
5097	int tmp1, tmp2;
5098	gfc_actual_arglist arg, last, *extremum;
5099	gfc_expr tmp, ret;
5100	const char *fname;
5101
5102	last = NULL__null;
5103	extremum = NULL__null;
5104
5105	arg = expr->value.function.actual;
5106
5107	for (; arg; last = arg, arg = arg->next)
5108	{
5109	if (arg->expr->expr_type != EXPR_CONSTANT)
5110	continue;
5111
5112	if (extremum == NULL__null)
5113	{
5114	extremum = arg;
5115	continue;
5116	}
5117
5118	min_max_choose (arg->expr, extremum->expr, sign);
5119
5120	/* Delete the extra constant argument. */
5121	last->next = arg->next;
5122
5123	arg->next = NULL__null;
5124	gfc_free_actual_arglist (arg);
5125	arg = last;
5126	}
5127
5128	/* If there is one value left, replace the function call with the
5129	expression. */
5130	if (expr->value.function.actual->next != NULL__null)
5131	return NULL__null;
5132
5133	/* Handle special cases of specific functions (min\|max)1 and
5134	a(min\|max)0. */
5135
5136	tmp = expr->value.function.actual->expr;
5137	fname = expr->value.function.isym->name;
5138
5139	if ((tmp->ts.type != BT_INTEGER \|\| tmp->ts.kind != gfc_integer_4_kind4)
5140	&& (strcmp (fname, "min1") == 0 \|\| strcmp (fname, "max1") == 0))
5141	{
5142	/* Explicit conversion, turn off -Wconversion and -Wconversion-extra
5143	warnings. */
5144	tmp1 = warn_conversionglobal_options.x_warn_conversion;
5145	tmp2 = warn_conversion_extraglobal_options.x_warn_conversion_extra;
5146	warn_conversionglobal_options.x_warn_conversion = warn_conversion_extraglobal_options.x_warn_conversion_extra = 0;
5147
5148	ret = gfc_convert_constant (tmp, BT_INTEGER, gfc_integer_4_kind4);
5149
5150	warn_conversionglobal_options.x_warn_conversion = tmp1;
5151	warn_conversion_extraglobal_options.x_warn_conversion_extra = tmp2;
5152	}
5153	else if ((tmp->ts.type != BT_REAL \|\| tmp->ts.kind != gfc_real_4_kind4)
5154	&& (strcmp (fname, "amin0") == 0 \|\| strcmp (fname, "amax0") == 0))
5155	{
5156	ret = gfc_convert_constant (tmp, BT_REAL, gfc_real_4_kind4);
5157	}
5158	else
5159	ret = gfc_copy_expr (tmp);
5160
5161	return ret;
5162
5163	}
5164
5165
5166	gfc_expr *
5167	gfc_simplify_min (gfc_expr *e)
5168	{
5169	return simplify_min_max (e, -1);
5170	}
5171
5172
5173	gfc_expr *
5174	gfc_simplify_max (gfc_expr *e)
5175	{
5176	return simplify_min_max (e, 1);
5177	}
5178
5179	/* Helper function for gfc_simplify_minval. */
5180
5181	static gfc_expr *
5182	gfc_min (gfc_expr op1, gfc_expr op2)
5183	{
5184	min_max_choose (op1, op2, -1);
5185	gfc_free_expr (op1);
5186	return op2;
5187	}
5188
5189	/* Simplify minval for constant arrays. */
5190
5191	gfc_expr *
5192	gfc_simplify_minval (gfc_expr array, gfc_expr dim, gfc_expr *mask)
5193	{
5194	return simplify_transformation (array, dim, mask, INT_MAX2147483647, gfc_min);
5195	}
5196
5197	/* Helper function for gfc_simplify_maxval. */
5198
5199	static gfc_expr *
5200	gfc_max (gfc_expr op1, gfc_expr op2)
5201	{
5202	min_max_choose (op1, op2, 1);
5203	gfc_free_expr (op1);
5204	return op2;
5205	}
5206
5207
5208	/* Simplify maxval for constant arrays. */
5209
5210	gfc_expr *
5211	gfc_simplify_maxval (gfc_expr array, gfc_expr dim, gfc_expr *mask)
5212	{
5213	return simplify_transformation (array, dim, mask, INT_MIN(-2147483647 -1), gfc_max);
5214	}
5215
5216
5217	/* Transform minloc or maxloc of an array, according to MASK,
5218	to the scalar result. This code is mostly identical to
5219	simplify_transformation_to_scalar. */
5220
5221	static gfc_expr *
5222	simplify_minmaxloc_to_scalar (gfc_expr result, gfc_expr array, gfc_expr *mask,
5223	gfc_expr *extremum, int sign, bool back_val)
5224	{
5225	gfc_expr a, m;
5226	gfc_constructor array_ctor, mask_ctor;
5227	mpz_t count;
5228
5229	mpz_set_si__gmpz_set_si (result->value.integer, 0);
5230
5231
5232	/* Shortcut for constant .FALSE. MASK. */
5233	if (mask
5234	&& mask->expr_type == EXPR_CONSTANT
5235	&& !mask->value.logical)
5236	return result;
5237
5238	array_ctor = gfc_constructor_first (array->value.constructor);
5239	if (mask && mask->expr_type == EXPR_ARRAY)
5240	mask_ctor = gfc_constructor_first (mask->value.constructor);
5241	else
5242	mask_ctor = NULL__null;
5243
5244	mpz_init_set_si__gmpz_init_set_si (count, 0);
5245	while (array_ctor)
5246	{
5247	mpz_add_ui__gmpz_add_ui (count, count, 1);
5248	a = array_ctor->expr;
5249	array_ctor = gfc_constructor_next (array_ctor);
5250	/* A constant MASK equals .TRUE. here and can be ignored. */
5251	if (mask_ctor)
5252	{
5253	m = mask_ctor->expr;
5254	mask_ctor = gfc_constructor_next (mask_ctor);
5255	if (!m->value.logical)
5256	continue;
5257	}
5258	if (min_max_choose (a, extremum, sign, back_val) > 0)
5259	mpz_set__gmpz_set (result->value.integer, count);
5260	}
5261	mpz_clear__gmpz_clear (count);
5262	gfc_free_expr (extremum);
5263	return result;
5264	}
5265
5266	/* Simplify minloc / maxloc in the absence of a dim argument. */
5267
5268	static gfc_expr *
5269	simplify_minmaxloc_nodim (gfc_expr result, gfc_expr extremum,
5270	gfc_expr array, gfc_expr mask, int sign,
5271	bool back_val)
5272	{
5273	ssize_t res[GFC_MAX_DIMENSIONS15];
5274	int i, n;
5275	gfc_constructor result_ctor, array_ctor, *mask_ctor;
5276	ssize_t count[GFC_MAX_DIMENSIONS15], extent[GFC_MAX_DIMENSIONS15],
5277	sstride[GFC_MAX_DIMENSIONS15];
5278	gfc_expr a, m;
5279	bool continue_loop;
5280	bool ma;
5281
5282	for (i = 0; i<array->rank; i++)
5283	res[i] = -1;
5284
5285	/* Shortcut for constant .FALSE. MASK. */
5286	if (mask
5287	&& mask->expr_type == EXPR_CONSTANT
5288	&& !mask->value.logical)
5289	goto finish;
5290
5291	if (array->shape == NULL__null)
5292	goto finish;
5293
5294	for (i = 0; i < array->rank; i++)
5295	{
5296	count[i] = 0;
5297	sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si__gmpz_get_si (array->shape[i-1]);
5298	extent[i] = mpz_get_si__gmpz_get_si (array->shape[i]);
5299	if (extent[i] <= 0)
5300	goto finish;
5301	}
5302
5303	continue_loop = true;
5304	array_ctor = gfc_constructor_first (array->value.constructor);
5305	if (mask && mask->rank > 0)
5306	mask_ctor = gfc_constructor_first (mask->value.constructor);
5307	else
5308	mask_ctor = NULL__null;
5309
5310	/* Loop over the array elements (and mask), keeping track of
5311	the indices to return. */
5312	while (continue_loop)
5313	{
5314	do
5315	{
5316	a = array_ctor->expr;
5317	if (mask_ctor)
5318	{
5319	m = mask_ctor->expr;
5320	ma = m->value.logical;
5321	mask_ctor = gfc_constructor_next (mask_ctor);
5322	}
5323	else
5324	ma = true;
5325
5326	if (ma && min_max_choose (a, extremum, sign, back_val) > 0)
5327	{
5328	for (i = 0; i<array->rank; i++)
5329	res[i] = count[i];
5330	}
5331	array_ctor = gfc_constructor_next (array_ctor);
5332	count[0] ++;
5333	} while (count[0] != extent[0]);
5334	n = 0;
5335	do
5336	{
5337	/* When we get to the end of a dimension, reset it and increment
5338	the next dimension. */
5339	count[n] = 0;
5340	n++;
5341	if (n >= array->rank)
5342	{
5343	continue_loop = false;
5344	break;
5345	}
5346	else
5347	count[n] ++;
5348	} while (count[n] == extent[n]);
5349	}
5350
5351	finish:
5352	gfc_free_expr (extremum);
5353	result_ctor = gfc_constructor_first (result->value.constructor);
5354	for (i = 0; i<array->rank; i++)
5355	{
5356	gfc_expr *r_expr;
5357	r_expr = result_ctor->expr;
5358	mpz_set_si__gmpz_set_si (r_expr->value.integer, res[i] + 1);
5359	result_ctor = gfc_constructor_next (result_ctor);
5360	}
5361	return result;
5362	}
5363
5364	/* Helper function for gfc_simplify_minmaxloc - build an array
5365	expression with n elements. */
5366
5367	static gfc_expr *
5368	new_array (bt type, int kind, int n, locus *where)
5369	{
5370	gfc_expr *result;
5371	int i;
5372
5373	result = gfc_get_array_expr (type, kind, where);
5374	result->rank = 1;
5375	result->shape = gfc_get_shape(1)(((mpz_t *) xcalloc (((1)), sizeof (mpz_t))));
5376	mpz_init_set_si__gmpz_init_set_si (result->shape[0], n);
5377	for (i = 0; i < n; i++)
5378	{
5379	gfc_constructor_append_expr (&result->value.constructor,
5380	gfc_get_constant_expr (type, kind, where),
5381	NULL__null);
5382	}
5383
5384	return result;
5385	}
5386
5387	/* Simplify minloc and maxloc. This code is mostly identical to
5388	simplify_transformation_to_array. */
5389
5390	static gfc_expr *
5391	simplify_minmaxloc_to_array (gfc_expr result, gfc_expr array,
5392	gfc_expr dim, gfc_expr mask,
5393	gfc_expr *extremum, int sign, bool back_val)
5394	{
5395	mpz_t size;
5396	int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
5397	gfc_expr arrayvec, resultvec, base, src, **dest;
5398	gfc_constructor array_ctor, mask_ctor, *result_ctor;
5399
5400	int count[GFC_MAX_DIMENSIONS15], extent[GFC_MAX_DIMENSIONS15],
5401	sstride[GFC_MAX_DIMENSIONS15], dstride[GFC_MAX_DIMENSIONS15],
5402	tmpstride[GFC_MAX_DIMENSIONS15];
5403
5404	/* Shortcut for constant .FALSE. MASK. */
5405	if (mask
5406	&& mask->expr_type == EXPR_CONSTANT
5407	&& !mask->value.logical)
5408	return result;
5409
5410	/* Build an indexed table for array element expressions to minimize
5411	linked-list traversal. Masked elements are set to NULL. */
5412	gfc_array_size (array, &size);
5413	arraysize = mpz_get_ui__gmpz_get_ui (size);
5414	mpz_clear__gmpz_clear (size);
5415
5416	arrayvec = XCNEWVEC (gfc_expr, arraysize)((gfc_expr ) xcalloc ((arraysize), sizeof (gfc_expr)));
5417
5418	array_ctor = gfc_constructor_first (array->value.constructor);
5419	mask_ctor = NULL__null;
5420	if (mask && mask->expr_type == EXPR_ARRAY)
5421	mask_ctor = gfc_constructor_first (mask->value.constructor);
5422
5423	for (i = 0; i < arraysize; ++i)
5424	{
5425	arrayvec[i] = array_ctor->expr;
5426	array_ctor = gfc_constructor_next (array_ctor);
5427
5428	if (mask_ctor)
5429	{
5430	if (!mask_ctor->expr->value.logical)
5431	arrayvec[i] = NULL__null;
5432
5433	mask_ctor = gfc_constructor_next (mask_ctor);
5434	}
5435	}
5436
5437	/* Same for the result expression. */
5438	gfc_array_size (result, &size);
5439	resultsize = mpz_get_ui__gmpz_get_ui (size);
5440	mpz_clear__gmpz_clear (size);
5441
5442	resultvec = XCNEWVEC (gfc_expr, resultsize)((gfc_expr ) xcalloc ((resultsize), sizeof (gfc_expr)));
5443	result_ctor = gfc_constructor_first (result->value.constructor);
5444	for (i = 0; i < resultsize; ++i)
5445	{
5446	resultvec[i] = result_ctor->expr;
5447	result_ctor = gfc_constructor_next (result_ctor);
5448	}
5449
5450	gfc_extract_int (dim, &dim_index);
5451	dim_index -= 1; /* zero-base index */
5452	dim_extent = 0;
5453	dim_stride = 0;
5454
5455	for (i = 0, n = 0; i < array->rank; ++i)
5456	{
5457	count[i] = 0;
5458	tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si__gmpz_get_si (array->shape[i-1]);
5459	if (i == dim_index)
5460	{
5461	dim_extent = mpz_get_si__gmpz_get_si (array->shape[i]);
5462	dim_stride = tmpstride[i];
5463	continue;
5464	}
5465
5466	extent[n] = mpz_get_si__gmpz_get_si (array->shape[i]);
5467	sstride[n] = tmpstride[i];
5468	dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
5469	n += 1;
5470	}
5471
5472	done = resultsize <= 0;
5473	base = arrayvec;
5474	dest = resultvec;
5475	while (!done)
5476	{
5477	gfc_expr *ex;
5478	ex = gfc_copy_expr (extremum);
5479	for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
5480	{
5481	if (src && min_max_choose (src, ex, sign, back_val) > 0)
5482	mpz_set_si__gmpz_set_si ((*dest)->value.integer, n + 1);
5483	}
5484
5485	count[0]++;
5486	base += sstride[0];
5487	dest += dstride[0];
5488	gfc_free_expr (ex);
5489
5490	n = 0;
5491	while (!done && count[n] == extent[n])
5492	{
5493	count[n] = 0;
5494	base -= sstride[n] * extent[n];
5495	dest -= dstride[n] * extent[n];
5496
5497	n++;
5498	if (n < result->rank)
5499	{
5500	/* If the nested loop is unrolled GFC_MAX_DIMENSIONS
5501	times, we'd warn for the last iteration, because the
5502	array index will have already been incremented to the
5503	array sizes, and we can't tell that this must make
5504	the test against result->rank false, because ranks
5505	must not exceed GFC_MAX_DIMENSIONS. */
5506	GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds)
5507	count[n]++;
5508	base += sstride[n];
5509	dest += dstride[n];
5510	GCC_DIAGNOSTIC_POP
5511	}
5512	else
5513	done = true;
5514	}
5515	}
5516
5517	/* Place updated expression in result constructor. */
5518	result_ctor = gfc_constructor_first (result->value.constructor);
5519	for (i = 0; i < resultsize; ++i)
5520	{
5521	result_ctor->expr = resultvec[i];
5522	result_ctor = gfc_constructor_next (result_ctor);
5523	}
5524
5525	free (arrayvec);
5526	free (resultvec);
5527	free (extremum);
5528	return result;
5529	}
5530
5531	/* Simplify minloc and maxloc for constant arrays. */
5532
5533	static gfc_expr *
5534	gfc_simplify_minmaxloc (gfc_expr array, gfc_expr dim, gfc_expr *mask,
5535	gfc_expr kind, gfc_expr back, int sign)
5536	{
5537	gfc_expr *result;
5538	gfc_expr *extremum;
5539	int ikind;
5540	int init_val;
5541	bool back_val = false;
5542
5543	if (!is_constant_array_expr (array)
5544	\|\| !gfc_is_constant_expr (dim))
5545	return NULL__null;
5546
5547	if (mask
5548	&& !is_constant_array_expr (mask)
5549	&& mask->expr_type != EXPR_CONSTANT)
5550	return NULL__null;
5551
5552	if (kind)
5553	{
5554	if (gfc_extract_int (kind, &ikind, -1))
5555	return NULL__null;
5556	}
5557	else
5558	ikind = gfc_default_integer_kind;
5559
5560	if (back)
5561	{
5562	if (back->expr_type != EXPR_CONSTANT)
5563	return NULL__null;
5564
5565	back_val = back->value.logical;
5566	}
5567
5568	if (sign < 0)
5569	init_val = INT_MAX2147483647;
5570	else if (sign > 0)
5571	init_val = INT_MIN(-2147483647 -1);
5572	else
5573	gcc_unreachable()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 5573, __FUNCTION__));
5574
5575	extremum = gfc_get_constant_expr (array->ts.type, array->ts.kind, &array->where);
5576	init_result_expr (extremum, init_val, array);
5577
5578	if (dim)
5579	{
5580	result = transformational_result (array, dim, BT_INTEGER,
5581	ikind, &array->where);
5582	init_result_expr (result, 0, array);
5583
5584	if (array->rank == 1)
5585	return simplify_minmaxloc_to_scalar (result, array, mask, extremum,
5586	sign, back_val);
5587	else
5588	return simplify_minmaxloc_to_array (result, array, dim, mask, extremum,
5589	sign, back_val);
5590	}
5591	else
5592	{
5593	result = new_array (BT_INTEGER, ikind, array->rank, &array->where);
5594	return simplify_minmaxloc_nodim (result, extremum, array, mask,
5595	sign, back_val);
5596	}
5597	}
5598
5599	gfc_expr *
5600	gfc_simplify_minloc (gfc_expr array, gfc_expr dim, gfc_expr mask, gfc_expr kind,
5601	gfc_expr *back)
5602	{
5603	return gfc_simplify_minmaxloc (array, dim, mask, kind, back, -1);
5604	}
5605
5606	gfc_expr *
5607	gfc_simplify_maxloc (gfc_expr array, gfc_expr dim, gfc_expr mask, gfc_expr kind,
5608	gfc_expr *back)
5609	{
5610	return gfc_simplify_minmaxloc (array, dim, mask, kind, back, 1);
5611	}
5612
5613	/* Simplify findloc to scalar. Similar to
5614	simplify_minmaxloc_to_scalar. */
5615
5616	static gfc_expr *
5617	simplify_findloc_to_scalar (gfc_expr result, gfc_expr array, gfc_expr *value,
5618	gfc_expr *mask, int back_val)
5619	{
5620	gfc_expr a, m;
5621	gfc_constructor array_ctor, mask_ctor;
5622	mpz_t count;
5623
5624	mpz_set_si__gmpz_set_si (result->value.integer, 0);
5625
5626	/* Shortcut for constant .FALSE. MASK. */
5627	if (mask
5628	&& mask->expr_type == EXPR_CONSTANT
5629	&& !mask->value.logical)
5630	return result;
5631
5632	array_ctor = gfc_constructor_first (array->value.constructor);
5633	if (mask && mask->expr_type == EXPR_ARRAY)
5634	mask_ctor = gfc_constructor_first (mask->value.constructor);
5635	else
5636	mask_ctor = NULL__null;
5637
5638	mpz_init_set_si__gmpz_init_set_si (count, 0);
5639	while (array_ctor)
5640	{
5641	mpz_add_ui__gmpz_add_ui (count, count, 1);
5642	a = array_ctor->expr;
5643	array_ctor = gfc_constructor_next (array_ctor);
5644	/* A constant MASK equals .TRUE. here and can be ignored. */
5645	if (mask_ctor)
5646	{
5647	m = mask_ctor->expr;
5648	mask_ctor = gfc_constructor_next (mask_ctor);
5649	if (!m->value.logical)
5650	continue;
5651	}
5652	if (gfc_compare_expr (a, value, INTRINSIC_EQ) == 0)
5653	{
5654	/* We have a match. If BACK is true, continue so we find
5655	the last one. */
5656	mpz_set__gmpz_set (result->value.integer, count);
5657	if (!back_val)
5658	break;
5659	}
5660	}
5661	mpz_clear__gmpz_clear (count);
5662	return result;
5663	}
5664
5665	/* Simplify findloc in the absence of a dim argument. Similar to
5666	simplify_minmaxloc_nodim. */
5667
5668	static gfc_expr *
5669	simplify_findloc_nodim (gfc_expr result, gfc_expr value, gfc_expr *array,
5670	gfc_expr *mask, bool back_val)
5671	{
5672	ssize_t res[GFC_MAX_DIMENSIONS15];
5673	int i, n;
5674	gfc_constructor result_ctor, array_ctor, *mask_ctor;
5675	ssize_t count[GFC_MAX_DIMENSIONS15], extent[GFC_MAX_DIMENSIONS15],
5676	sstride[GFC_MAX_DIMENSIONS15];
5677	gfc_expr a, m;
5678	bool continue_loop;
5679	bool ma;
5680
5681	for (i = 0; i < array->rank; i++)
5682	res[i] = -1;
5683
5684	/* Shortcut for constant .FALSE. MASK. */
5685	if (mask
5686	&& mask->expr_type == EXPR_CONSTANT
5687	&& !mask->value.logical)
5688	goto finish;
5689
5690	for (i = 0; i < array->rank; i++)
5691	{
5692	count[i] = 0;
5693	sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si__gmpz_get_si (array->shape[i-1]);
5694	extent[i] = mpz_get_si__gmpz_get_si (array->shape[i]);
5695	if (extent[i] <= 0)
5696	goto finish;
5697	}
5698
5699	continue_loop = true;
5700	array_ctor = gfc_constructor_first (array->value.constructor);
5701	if (mask && mask->rank > 0)
5702	mask_ctor = gfc_constructor_first (mask->value.constructor);
5703	else
5704	mask_ctor = NULL__null;
5705
5706	/* Loop over the array elements (and mask), keeping track of
5707	the indices to return. */
5708	while (continue_loop)
5709	{
5710	do
5711	{
5712	a = array_ctor->expr;
5713	if (mask_ctor)
5714	{
5715	m = mask_ctor->expr;
5716	ma = m->value.logical;
5717	mask_ctor = gfc_constructor_next (mask_ctor);
5718	}
5719	else
5720	ma = true;
5721
5722	if (ma && gfc_compare_expr (a, value, INTRINSIC_EQ) == 0)
5723	{
5724	for (i = 0; i < array->rank; i++)
5725	res[i] = count[i];
5726	if (!back_val)
5727	goto finish;
5728	}
5729	array_ctor = gfc_constructor_next (array_ctor);
5730	count[0] ++;
5731	} while (count[0] != extent[0]);
5732	n = 0;
5733	do
5734	{
5735	/* When we get to the end of a dimension, reset it and increment
5736	the next dimension. */
5737	count[n] = 0;
5738	n++;
5739	if (n >= array->rank)
5740	{
5741	continue_loop = false;
5742	break;
5743	}
5744	else
5745	count[n] ++;
5746	} while (count[n] == extent[n]);
5747	}
5748
5749	finish:
5750	result_ctor = gfc_constructor_first (result->value.constructor);
5751	for (i = 0; i < array->rank; i++)
5752	{
5753	gfc_expr *r_expr;
5754	r_expr = result_ctor->expr;
5755	mpz_set_si__gmpz_set_si (r_expr->value.integer, res[i] + 1);
5756	result_ctor = gfc_constructor_next (result_ctor);
5757	}
5758	return result;
5759	}
5760
5761
5762	/* Simplify findloc to an array. Similar to
5763	simplify_minmaxloc_to_array. */
5764
5765	static gfc_expr *
5766	simplify_findloc_to_array (gfc_expr result, gfc_expr array, gfc_expr *value,
5767	gfc_expr dim, gfc_expr mask, bool back_val)
5768	{
5769	mpz_t size;
5770	int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
5771	gfc_expr arrayvec, resultvec, base, src, **dest;
5772	gfc_constructor array_ctor, mask_ctor, *result_ctor;
5773
5774	int count[GFC_MAX_DIMENSIONS15], extent[GFC_MAX_DIMENSIONS15],
5775	sstride[GFC_MAX_DIMENSIONS15], dstride[GFC_MAX_DIMENSIONS15],
5776	tmpstride[GFC_MAX_DIMENSIONS15];
5777
5778	/* Shortcut for constant .FALSE. MASK. */
5779	if (mask
5780	&& mask->expr_type == EXPR_CONSTANT
5781	&& !mask->value.logical)
5782	return result;
5783
5784	/* Build an indexed table for array element expressions to minimize
5785	linked-list traversal. Masked elements are set to NULL. */
5786	gfc_array_size (array, &size);
5787	arraysize = mpz_get_ui__gmpz_get_ui (size);
5788	mpz_clear__gmpz_clear (size);
5789
5790	arrayvec = XCNEWVEC (gfc_expr, arraysize)((gfc_expr ) xcalloc ((arraysize), sizeof (gfc_expr)));
5791
5792	array_ctor = gfc_constructor_first (array->value.constructor);
5793	mask_ctor = NULL__null;
5794	if (mask && mask->expr_type == EXPR_ARRAY)
5795	mask_ctor = gfc_constructor_first (mask->value.constructor);
5796
5797	for (i = 0; i < arraysize; ++i)
5798	{
5799	arrayvec[i] = array_ctor->expr;
5800	array_ctor = gfc_constructor_next (array_ctor);
5801
5802	if (mask_ctor)
5803	{
5804	if (!mask_ctor->expr->value.logical)
5805	arrayvec[i] = NULL__null;
5806
5807	mask_ctor = gfc_constructor_next (mask_ctor);
5808	}
5809	}
5810
5811	/* Same for the result expression. */
5812	gfc_array_size (result, &size);
5813	resultsize = mpz_get_ui__gmpz_get_ui (size);
5814	mpz_clear__gmpz_clear (size);
5815
5816	resultvec = XCNEWVEC (gfc_expr, resultsize)((gfc_expr ) xcalloc ((resultsize), sizeof (gfc_expr)));
5817	result_ctor = gfc_constructor_first (result->value.constructor);
5818	for (i = 0; i < resultsize; ++i)
5819	{
5820	resultvec[i] = result_ctor->expr;
5821	result_ctor = gfc_constructor_next (result_ctor);
5822	}
5823
5824	gfc_extract_int (dim, &dim_index);
5825
5826	dim_index -= 1; /* Zero-base index. */
5827	dim_extent = 0;
5828	dim_stride = 0;
5829
5830	for (i = 0, n = 0; i < array->rank; ++i)
5831	{
5832	count[i] = 0;
5833	tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si__gmpz_get_si (array->shape[i-1]);
5834	if (i == dim_index)
5835	{
5836	dim_extent = mpz_get_si__gmpz_get_si (array->shape[i]);
5837	dim_stride = tmpstride[i];
5838	continue;
5839	}
5840
5841	extent[n] = mpz_get_si__gmpz_get_si (array->shape[i]);
5842	sstride[n] = tmpstride[i];
5843	dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
5844	n += 1;
5845	}
5846
5847	done = resultsize <= 0;
5848	base = arrayvec;
5849	dest = resultvec;
5850	while (!done)
5851	{
5852	for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
5853	{
5854	if (src && gfc_compare_expr (src, value, INTRINSIC_EQ) == 0)
5855	{
5856	mpz_set_si__gmpz_set_si ((*dest)->value.integer, n + 1);
5857	if (!back_val)
5858	break;
5859	}
5860	}
5861
5862	count[0]++;
5863	base += sstride[0];
5864	dest += dstride[0];
5865
5866	n = 0;
5867	while (!done && count[n] == extent[n])
5868	{
5869	count[n] = 0;
5870	base -= sstride[n] * extent[n];
5871	dest -= dstride[n] * extent[n];
5872
5873	n++;
5874	if (n < result->rank)
5875	{
5876	/* If the nested loop is unrolled GFC_MAX_DIMENSIONS
5877	times, we'd warn for the last iteration, because the
5878	array index will have already been incremented to the
5879	array sizes, and we can't tell that this must make
5880	the test against result->rank false, because ranks
5881	must not exceed GFC_MAX_DIMENSIONS. */
5882	GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds)
5883	count[n]++;
5884	base += sstride[n];
5885	dest += dstride[n];
5886	GCC_DIAGNOSTIC_POP
5887	}
5888	else
5889	done = true;
5890	}
5891	}
5892
5893	/* Place updated expression in result constructor. */
5894	result_ctor = gfc_constructor_first (result->value.constructor);
5895	for (i = 0; i < resultsize; ++i)
5896	{
5897	result_ctor->expr = resultvec[i];
5898	result_ctor = gfc_constructor_next (result_ctor);
5899	}
5900
5901	free (arrayvec);
5902	free (resultvec);
5903	return result;
5904	}
5905
5906	/* Simplify findloc. */
5907
5908	gfc_expr *
5909	gfc_simplify_findloc (gfc_expr array, gfc_expr value, gfc_expr *dim,
5910	gfc_expr mask, gfc_expr kind, gfc_expr *back)
5911	{
5912	gfc_expr *result;
5913	int ikind;
5914	bool back_val = false;
5915
5916	if (!is_constant_array_expr (array)
5917	\|\| array->shape == NULL__null
5918	\|\| !gfc_is_constant_expr (dim))
5919	return NULL__null;
5920
5921	if (! gfc_is_constant_expr (value))
5922	return 0;
5923
5924	if (mask
5925	&& !is_constant_array_expr (mask)
5926	&& mask->expr_type != EXPR_CONSTANT)
5927	return NULL__null;
5928
5929	if (kind)
5930	{
5931	if (gfc_extract_int (kind, &ikind, -1))
5932	return NULL__null;
5933	}
5934	else
5935	ikind = gfc_default_integer_kind;
5936
5937	if (back)
5938	{
5939	if (back->expr_type != EXPR_CONSTANT)
5940	return NULL__null;
5941
5942	back_val = back->value.logical;
5943	}
5944
5945	if (dim)
5946	{
5947	result = transformational_result (array, dim, BT_INTEGER,
5948	ikind, &array->where);
5949	init_result_expr (result, 0, array);
5950
5951	if (array->rank == 1)
5952	return simplify_findloc_to_scalar (result, array, value, mask,
5953	back_val);
5954	else
5955	return simplify_findloc_to_array (result, array, value, dim, mask,
5956	back_val);
5957	}
5958	else
5959	{
5960	result = new_array (BT_INTEGER, ikind, array->rank, &array->where);
5961	return simplify_findloc_nodim (result, value, array, mask, back_val);
5962	}
5963	return NULL__null;
5964	}
5965
5966	gfc_expr *
5967	gfc_simplify_maxexponent (gfc_expr *x)
5968	{
5969	int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
5970	return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
5971	gfc_real_kinds[i].max_exponent);
5972	}
5973
5974
5975	gfc_expr *
5976	gfc_simplify_minexponent (gfc_expr *x)
5977	{
5978	int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
5979	return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
5980	gfc_real_kinds[i].min_exponent);
5981	}
5982
5983
5984	gfc_expr *
5985	gfc_simplify_mod (gfc_expr a, gfc_expr p)
5986	{
5987	gfc_expr *result;
5988	int kind;
5989
5990	/* First check p. */
5991	if (p->expr_type != EXPR_CONSTANT)
5992	return NULL__null;
5993
5994	/* p shall not be 0. */
5995	switch (p->ts.type)
5996	{
5997	case BT_INTEGER:
5998	if (mpz_cmp_ui (p->value.integer, 0)(__builtin_constant_p (0) && (0) == 0 ? ((p->value .integer)->_mp_size < 0 ? -1 : (p->value.integer)-> _mp_size > 0) : __gmpz_cmp_ui (p->value.integer,0)) == 0)
5999	{
6000	gfc_error ("Argument %qs of MOD at %L shall not be zero",
6001	"P", &p->where);
6002	return &gfc_bad_expr;
6003	}
6004	break;
6005	case BT_REAL:
6006	if (mpfr_cmp_ui (p->value.real, 0)mpfr_cmp_ui_2exp((p->value.real),(0),0) == 0)
6007	{
6008	gfc_error ("Argument %qs of MOD at %L shall not be zero",
6009	"P", &p->where);
6010	return &gfc_bad_expr;
6011	}
6012	break;
6013	default:
6014	gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
6015	}
6016
6017	if (a->expr_type != EXPR_CONSTANT)
6018	return NULL__null;
6019
6020	kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
6021	result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
6022
6023	if (a->ts.type == BT_INTEGER)
6024	mpz_tdiv_r__gmpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
6025	else
6026	{
6027	gfc_set_model_kind (kind);
6028	mpfr_fmod (result->value.real, a->value.real, p->value.real,
6029	GFC_RND_MODEMPFR_RNDN);
6030	}
6031
6032	return range_check (result, "MOD");
6033	}
6034
6035
6036	gfc_expr *
6037	gfc_simplify_modulo (gfc_expr a, gfc_expr p)
6038	{
6039	gfc_expr *result;
6040	int kind;
6041
6042	/* First check p. */
6043	if (p->expr_type != EXPR_CONSTANT)
6044	return NULL__null;
6045
6046	/* p shall not be 0. */
6047	switch (p->ts.type)
6048	{
6049	case BT_INTEGER:
6050	if (mpz_cmp_ui (p->value.integer, 0)(__builtin_constant_p (0) && (0) == 0 ? ((p->value .integer)->_mp_size < 0 ? -1 : (p->value.integer)-> _mp_size > 0) : __gmpz_cmp_ui (p->value.integer,0)) == 0)
6051	{
6052	gfc_error ("Argument %qs of MODULO at %L shall not be zero",
6053	"P", &p->where);
6054	return &gfc_bad_expr;
6055	}
6056	break;
6057	case BT_REAL:
6058	if (mpfr_cmp_ui (p->value.real, 0)mpfr_cmp_ui_2exp((p->value.real),(0),0) == 0)
6059	{
6060	gfc_error ("Argument %qs of MODULO at %L shall not be zero",
6061	"P", &p->where);
6062	return &gfc_bad_expr;
6063	}
6064	break;
6065	default:
6066	gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
6067	}
6068
6069	if (a->expr_type != EXPR_CONSTANT)
6070	return NULL__null;
6071
6072	kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
6073	result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
6074
6075	if (a->ts.type == BT_INTEGER)
6076	mpz_fdiv_r__gmpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
6077	else
6078	{
6079	gfc_set_model_kind (kind);
6080	mpfr_fmod (result->value.real, a->value.real, p->value.real,
6081	GFC_RND_MODEMPFR_RNDN);
6082	if (mpfr_cmp_ui (result->value.real, 0)mpfr_cmp_ui_2exp((result->value.real),(0),0) != 0)
6083	{
6084	if (mpfr_signbit (a->value.real)((0 ? (((((mpfr_srcptr) (0 ? (a->value.real) : (mpfr_srcptr ) (a->value.real))))->_mpfr_sign)) : (((((mpfr_srcptr) ( 0 ? (a->value.real) : (mpfr_srcptr) (a->value.real))))-> _mpfr_sign))) < 0) != mpfr_signbit (p->value.real)((0 ? (((((mpfr_srcptr) (0 ? (p->value.real) : (mpfr_srcptr ) (p->value.real))))->_mpfr_sign)) : (((((mpfr_srcptr) ( 0 ? (p->value.real) : (mpfr_srcptr) (p->value.real))))-> _mpfr_sign))) < 0))
6085	mpfr_add (result->value.real, result->value.real, p->value.real,
6086	GFC_RND_MODEMPFR_RNDN);
6087	}
6088	else
6089	mpfr_copysign (result->value.real, result->value.real,mpfr_set4(result->value.real,result->value.real,MPFR_RNDN ,(0 ? (((((mpfr_srcptr) (0 ? (p->value.real) : (mpfr_srcptr ) (p->value.real))))->_mpfr_sign)) : (((((mpfr_srcptr) ( 0 ? (p->value.real) : (mpfr_srcptr) (p->value.real))))-> _mpfr_sign))))
6090	p->value.real, GFC_RND_MODE)mpfr_set4(result->value.real,result->value.real,MPFR_RNDN ,(0 ? (((((mpfr_srcptr) (0 ? (p->value.real) : (mpfr_srcptr ) (p->value.real))))->_mpfr_sign)) : (((((mpfr_srcptr) ( 0 ? (p->value.real) : (mpfr_srcptr) (p->value.real))))-> _mpfr_sign))));
6091	}
6092
6093	return range_check (result, "MODULO");
6094	}
6095
6096
6097	gfc_expr *
6098	gfc_simplify_nearest (gfc_expr x, gfc_expr s)
6099	{
6100	gfc_expr *result;
6101	mpfr_exp_t emin, emax;
6102	int kind;
6103
6104	if (x->expr_type != EXPR_CONSTANT \|\| s->expr_type != EXPR_CONSTANT)
6105	return NULL__null;
6106
6107	result = gfc_copy_expr (x);
6108
6109	/* Save current values of emin and emax. */
6110	emin = mpfr_get_emin ();
6111	emax = mpfr_get_emax ();
6112
6113	/* Set emin and emax for the current model number. */
6114	kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
6115	mpfr_set_emin ((mpfr_exp_t) gfc_real_kinds[kind].min_exponent -
6116	mpfr_get_prec(result->value.real)(0 ? (((mpfr_srcptr) (0 ? (result->value.real) : (mpfr_srcptr ) (result->value.real)))->_mpfr_prec) : (((mpfr_srcptr) (0 ? (result->value.real) : (mpfr_srcptr) (result->value .real)))->_mpfr_prec)) + 1);
6117	mpfr_set_emax ((mpfr_exp_t) gfc_real_kinds[kind].max_exponent);
6118	mpfr_check_range (result->value.real, 0, MPFR_RNDU);
6119
6120	if (mpfr_sgn (s->value.real)((s->value.real)->_mpfr_exp < (2 - ((mpfr_exp_t) ((( mpfr_uexp_t) -1) >> 1))) ? ((((mpfr_srcptr) (0 ? (s-> value.real) : (mpfr_srcptr) (s->value.real)))->_mpfr_exp == (1 - ((mpfr_exp_t) (((mpfr_uexp_t) -1) >> 1)))) ? mpfr_set_erangeflag () : (mpfr_void) 0), 0 : ((s->value.real)->_mpfr_sign) ) > 0)
6121	{
6122	mpfr_nextabove (result->value.real);
6123	mpfr_subnormalize (result->value.real, 0, MPFR_RNDU);
6124	}
6125	else
6126	{
6127	mpfr_nextbelow (result->value.real);
6128	mpfr_subnormalize (result->value.real, 0, MPFR_RNDD);
6129	}
6130
6131	mpfr_set_emin (emin);
6132	mpfr_set_emax (emax);
6133
6134	/* Only NaN can occur. Do not use range check as it gives an
6135	error for denormal numbers. */
6136	if (mpfr_nan_p (result->value.real)(((mpfr_srcptr) (0 ? (result->value.real) : (mpfr_srcptr) ( result->value.real)))->_mpfr_exp == (1 - ((mpfr_exp_t) ( ((mpfr_uexp_t) -1) >> 1)))) && flag_range_checkglobal_options.x_flag_range_check)
6137	{
6138	gfc_error ("Result of NEAREST is NaN at %L", &result->where);
6139	gfc_free_expr (result);
6140	return &gfc_bad_expr;
6141	}
6142
6143	return result;
6144	}
6145
6146
6147	static gfc_expr *
6148	simplify_nint (const char name, gfc_expr e, gfc_expr *k)
6149	{
6150	gfc_expr itrunc, result;
6151	int kind;
6152
6153	kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
6154	if (kind == -1)
6155	return &gfc_bad_expr;
6156
6157	if (e->expr_type != EXPR_CONSTANT)
6158	return NULL__null;
6159
6160	itrunc = gfc_copy_expr (e);
6161	mpfr_round (itrunc->value.real, e->value.real)mpfr_rint((itrunc->value.real), (e->value.real), MPFR_RNDNA );
6162
6163	result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
6164	gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);
6165
6166	gfc_free_expr (itrunc);
6167
6168	return range_check (result, name);
6169	}
6170
6171
6172	gfc_expr *
6173	gfc_simplify_new_line (gfc_expr *e)
6174	{
6175	gfc_expr *result;
6176
6177	result = gfc_get_character_expr (e->ts.kind, &e->where, NULL__null, 1);
6178	result->value.character.string[0] = '\n';
6179
6180	return result;
6181	}
6182
6183
6184	gfc_expr *
6185	gfc_simplify_nint (gfc_expr e, gfc_expr k)
6186	{
6187	return simplify_nint ("NINT", e, k);
6188	}
6189
6190
6191	gfc_expr *
6192	gfc_simplify_idnint (gfc_expr *e)
6193	{
6194	return simplify_nint ("IDNINT", e, NULL__null);
6195	}
6196
6197	static int norm2_scale;
6198
6199	static gfc_expr *
6200	norm2_add_squared (gfc_expr result, gfc_expr e)
6201	{
6202	mpfr_t tmp;
6203
6204	gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT)((void)(!(e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 6204, __FUNCTION__), 0 : 0));
6205	gcc_assert (result->ts.type == BT_REAL((void)(!(result->ts.type == BT_REAL && result-> expr_type == EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 6206, __FUNCTION__), 0 : 0))
6206	&& result->expr_type == EXPR_CONSTANT)((void)(!(result->ts.type == BT_REAL && result-> expr_type == EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 6206, __FUNCTION__), 0 : 0));
6207
6208	gfc_set_model_kind (result->ts.kind);
6209	int index = gfc_validate_kind (BT_REAL, result->ts.kind, false);
6210	mpfr_exp_t exp;
6211	if (mpfr_regular_p (result->value.real)(((mpfr_srcptr) (0 ? (result->value.real) : (mpfr_srcptr) ( result->value.real)))->_mpfr_exp > (2 - ((mpfr_exp_t ) (((mpfr_uexp_t) -1) >> 1)))))
6212	{
6213	exp = mpfr_get_exp (result->value.real)(0 ? (((mpfr_srcptr) (0 ? (result->value.real) : (mpfr_srcptr ) (result->value.real)))->_mpfr_exp) : (((mpfr_srcptr) ( 0 ? (result->value.real) : (mpfr_srcptr) (result->value .real)))->_mpfr_exp));
6214	/* If result is getting close to overflowing, scale down. */
6215	if (exp >= gfc_real_kinds[index].max_exponent - 4
6216	&& norm2_scale <= gfc_real_kinds[index].max_exponent - 2)
6217	{
6218	norm2_scale += 2;
6219	mpfr_div_ui (result->value.real, result->value.real, 16,
6220	GFC_RND_MODEMPFR_RNDN);
6221	}
6222	}
6223
6224	mpfr_init (tmp);
6225	if (mpfr_regular_p (e->value.real)(((mpfr_srcptr) (0 ? (e->value.real) : (mpfr_srcptr) (e-> value.real)))->_mpfr_exp > (2 - ((mpfr_exp_t) (((mpfr_uexp_t ) -1) >> 1)))))
6226	{
6227	exp = mpfr_get_exp (e->value.real)(0 ? (((mpfr_srcptr) (0 ? (e->value.real) : (mpfr_srcptr) ( e->value.real)))->_mpfr_exp) : (((mpfr_srcptr) (0 ? (e-> value.real) : (mpfr_srcptr) (e->value.real)))->_mpfr_exp ));
6228	/* If e*2 would overflow or close to overflowing, scale down. /
6229	if (exp - norm2_scale >= gfc_real_kinds[index].max_exponent / 2 - 2)
6230	{
6231	int new_scale = gfc_real_kinds[index].max_exponent / 2 + 4;
6232	mpfr_set_ui (tmp, 1, GFC_RND_MODEMPFR_RNDN);
6233	mpfr_set_exp (tmp, new_scale - norm2_scale);
6234	mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODEMPFR_RNDN);
6235	mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODEMPFR_RNDN);
6236	norm2_scale = new_scale;
6237	}
6238	}
6239	if (norm2_scale)
6240	{
6241	mpfr_set_ui (tmp, 1, GFC_RND_MODEMPFR_RNDN);
6242	mpfr_set_exp (tmp, norm2_scale);
6243	mpfr_div (tmp, e->value.real, tmp, GFC_RND_MODEMPFR_RNDN);
6244	}
6245	else
6246	mpfr_set (tmp, e->value.real, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (e->value.real); mpfr_set4 (tmp,_p,MPFR_RNDN,((_p)->_mpfr_sign)); });
6247	mpfr_pow_ui (tmp, tmp, 2, GFC_RND_MODEMPFR_RNDN);
6248	mpfr_add (result->value.real, result->value.real, tmp,
6249	GFC_RND_MODEMPFR_RNDN);
6250	mpfr_clear (tmp);
6251
6252	return result;
6253	}
6254
6255
6256	static gfc_expr *
6257	norm2_do_sqrt (gfc_expr result, gfc_expr e)
6258	{
6259	gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT)((void)(!(e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 6259, __FUNCTION__), 0 : 0));
6260	gcc_assert (result->ts.type == BT_REAL((void)(!(result->ts.type == BT_REAL && result-> expr_type == EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 6261, __FUNCTION__), 0 : 0))
6261	&& result->expr_type == EXPR_CONSTANT)((void)(!(result->ts.type == BT_REAL && result-> expr_type == EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 6261, __FUNCTION__), 0 : 0));
6262
6263	if (result != e)
6264	mpfr_set (result->value.real, e->value.real, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (e->value.real); mpfr_set4 (result->value.real,_p,MPFR_RNDN,((_p)->_mpfr_sign)); } );
6265	mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODEMPFR_RNDN);
6266	if (norm2_scale && mpfr_regular_p (result->value.real)(((mpfr_srcptr) (0 ? (result->value.real) : (mpfr_srcptr) ( result->value.real)))->_mpfr_exp > (2 - ((mpfr_exp_t ) (((mpfr_uexp_t) -1) >> 1)))))
6267	{
6268	mpfr_t tmp;
6269	mpfr_init (tmp);
6270	mpfr_set_ui (tmp, 1, GFC_RND_MODEMPFR_RNDN);
6271	mpfr_set_exp (tmp, norm2_scale);
6272	mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODEMPFR_RNDN);
6273	mpfr_clear (tmp);
6274	}
6275	norm2_scale = 0;
6276
6277	return result;
6278	}
6279
6280
6281	gfc_expr *
6282	gfc_simplify_norm2 (gfc_expr e, gfc_expr dim)
6283	{
6284	gfc_expr *result;
6285	bool size_zero;
6286
6287	size_zero = gfc_is_size_zero_array (e);
6288
6289	if (!(is_constant_array_expr (e) \|\| size_zero)
6290	\|\| (dim != NULL__null && !gfc_is_constant_expr (dim)))
6291	return NULL__null;
6292
6293	result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where);
6294	init_result_expr (result, 0, NULL__null);
6295
6296	if (size_zero)
6297	return result;
6298
6299	norm2_scale = 0;
6300	if (!dim \|\| e->rank == 1)
6301	{
6302	result = simplify_transformation_to_scalar (result, e, NULL__null,
6303	norm2_add_squared);
6304	mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODEMPFR_RNDN);
6305	if (norm2_scale && mpfr_regular_p (result->value.real)(((mpfr_srcptr) (0 ? (result->value.real) : (mpfr_srcptr) ( result->value.real)))->_mpfr_exp > (2 - ((mpfr_exp_t ) (((mpfr_uexp_t) -1) >> 1)))))
6306	{
6307	mpfr_t tmp;
6308	mpfr_init (tmp);
6309	mpfr_set_ui (tmp, 1, GFC_RND_MODEMPFR_RNDN);
6310	mpfr_set_exp (tmp, norm2_scale);
6311	mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODEMPFR_RNDN);
6312	mpfr_clear (tmp);
6313	}
6314	norm2_scale = 0;
6315	}
6316	else
6317	result = simplify_transformation_to_array (result, e, dim, NULL__null,
6318	norm2_add_squared,
6319	norm2_do_sqrt);
6320
6321	return result;
6322	}
6323
6324
6325	gfc_expr *
6326	gfc_simplify_not (gfc_expr *e)
6327	{
6328	gfc_expr *result;
6329
6330	if (e->expr_type != EXPR_CONSTANT)
6331	return NULL__null;
6332
6333	result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
6334	mpz_com__gmpz_com (result->value.integer, e->value.integer);
6335
6336	return range_check (result, "NOT");
6337	}
6338
6339
6340	gfc_expr *
6341	gfc_simplify_null (gfc_expr *mold)
6342	{
6343	gfc_expr *result;
6344
6345	if (mold)
6346	{
6347	result = gfc_copy_expr (mold);
6348	result->expr_type = EXPR_NULL;
6349	}
6350	else
6351	result = gfc_get_null_expr (NULL__null);
6352
6353	return result;
6354	}
6355
6356
6357	gfc_expr *
6358	gfc_simplify_num_images (gfc_expr distance ATTRIBUTE_UNUSED__attribute__ ((__unused__)), gfc_expr failed)
6359	{
6360	gfc_expr *result;
6361
6362	if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_NONE)
6363	{
6364	gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6365	return &gfc_bad_expr;
6366	}
6367
6368	if (flag_coarrayglobal_options.x_flag_coarray != GFC_FCOARRAY_SINGLE)
6369	return NULL__null;
6370
6371	if (failed && failed->expr_type != EXPR_CONSTANT)
6372	return NULL__null;
6373
6374	/* FIXME: gfc_current_locus is wrong. */
6375	result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
6376	&gfc_current_locus);
6377
6378	if (failed && failed->value.logical != 0)
6379	mpz_set_si__gmpz_set_si (result->value.integer, 0);
6380	else
6381	mpz_set_si__gmpz_set_si (result->value.integer, 1);
6382
6383	return result;
6384	}
6385
6386
6387	gfc_expr *
6388	gfc_simplify_or (gfc_expr x, gfc_expr y)
6389	{
6390	gfc_expr *result;
6391	int kind;
6392
6393	if (x->expr_type != EXPR_CONSTANT \|\| y->expr_type != EXPR_CONSTANT)
6394	return NULL__null;
6395
6396	kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
6397
6398	switch (x->ts.type)
6399	{
6400	case BT_INTEGER:
6401	result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
6402	mpz_ior__gmpz_ior (result->value.integer, x->value.integer, y->value.integer);
6403	return range_check (result, "OR");
6404
6405	case BT_LOGICAL:
6406	return gfc_get_logical_expr (kind, &x->where,
6407	x->value.logical \|\| y->value.logical);
6408	default:
6409	gcc_unreachable()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 6409, __FUNCTION__));
6410	}
6411	}
6412
6413
6414	gfc_expr *
6415	gfc_simplify_pack (gfc_expr array, gfc_expr mask, gfc_expr *vector)
6416	{
6417	gfc_expr *result;
6418	gfc_constructor array_ctor, mask_ctor, *vector_ctor;
6419
6420	if (!is_constant_array_expr (array)
6421	\|\| !is_constant_array_expr (vector)
6422	\|\| (!gfc_is_constant_expr (mask)
6423	&& !is_constant_array_expr (mask)))
6424	return NULL__null;
6425
6426	result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
6427	if (array->ts.type == BT_DERIVED)
6428	result->ts.u.derived = array->ts.u.derived;
6429
6430	array_ctor = gfc_constructor_first (array->value.constructor);
6431	vector_ctor = vector
6432	? gfc_constructor_first (vector->value.constructor)
6433	: NULL__null;
6434
6435	if (mask->expr_type == EXPR_CONSTANT
6436	&& mask->value.logical)
6437	{
6438	/* Copy all elements of ARRAY to RESULT. */
6439	while (array_ctor)
6440	{
6441	gfc_constructor_append_expr (&result->value.constructor,
6442	gfc_copy_expr (array_ctor->expr),
6443	NULL__null);
6444
6445	array_ctor = gfc_constructor_next (array_ctor);
6446	vector_ctor = gfc_constructor_next (vector_ctor);
6447	}
6448	}
6449	else if (mask->expr_type == EXPR_ARRAY)
6450	{
6451	/* Copy only those elements of ARRAY to RESULT whose
6452	MASK equals .TRUE.. */
6453	mask_ctor = gfc_constructor_first (mask->value.constructor);
6454	while (mask_ctor && array_ctor)
6455	{
6456	if (mask_ctor->expr->value.logical)
6457	{
6458	gfc_constructor_append_expr (&result->value.constructor,
6459	gfc_copy_expr (array_ctor->expr),
6460	NULL__null);
6461	vector_ctor = gfc_constructor_next (vector_ctor);
6462	}
6463
6464	array_ctor = gfc_constructor_next (array_ctor);
6465	mask_ctor = gfc_constructor_next (mask_ctor);
6466	}
6467	}
6468
6469	/* Append any left-over elements from VECTOR to RESULT. */
6470	while (vector_ctor)
6471	{
6472	gfc_constructor_append_expr (&result->value.constructor,
6473	gfc_copy_expr (vector_ctor->expr),
6474	NULL__null);
6475	vector_ctor = gfc_constructor_next (vector_ctor);
6476	}
6477
6478	result->shape = gfc_get_shape (1)(((mpz_t *) xcalloc (((1)), sizeof (mpz_t))));
6479	gfc_array_size (result, &result->shape[0]);
6480
6481	if (array->ts.type == BT_CHARACTER)
6482	result->ts.u.cl = array->ts.u.cl;
6483
6484	return result;
6485	}
6486
6487
6488	static gfc_expr *
6489	do_xor (gfc_expr result, gfc_expr e)
6490	{
6491	gcc_assert (e->ts.type == BT_LOGICAL && e->expr_type == EXPR_CONSTANT)((void)(!(e->ts.type == BT_LOGICAL && e->expr_type == EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 6491, __FUNCTION__), 0 : 0));
6492	gcc_assert (result->ts.type == BT_LOGICAL((void)(!(result->ts.type == BT_LOGICAL && result-> expr_type == EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 6493, __FUNCTION__), 0 : 0))
6493	&& result->expr_type == EXPR_CONSTANT)((void)(!(result->ts.type == BT_LOGICAL && result-> expr_type == EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc" , 6493, __FUNCTION__), 0 : 0));
6494
6495	result->value.logical = result->value.logical != e->value.logical;
6496	return result;
6497	}
6498
6499
6500	gfc_expr *
6501	gfc_simplify_is_contiguous (gfc_expr *array)
6502	{
6503	if (gfc_is_simply_contiguous (array, false, true))
6504	return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 1);
6505
6506	if (gfc_is_not_contiguous (array))
6507	return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 0);
6508
6509	return NULL__null;
6510	}
6511
6512
6513	gfc_expr *
6514	gfc_simplify_parity (gfc_expr e, gfc_expr dim)
6515	{
6516	return simplify_transformation (e, dim, NULL__null, 0, do_xor);
6517	}
6518
6519
6520	gfc_expr *
6521	gfc_simplify_popcnt (gfc_expr *e)
6522	{
6523	int res, k;
6524	mpz_t x;
6525
6526	if (e->expr_type != EXPR_CONSTANT)
6527	return NULL__null;
6528
6529	k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
6530
6531	/* Convert argument to unsigned, then count the '1' bits. */
6532	mpz_init_set__gmpz_init_set (x, e->value.integer);
6533	convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
6534	res = mpz_popcount__gmpz_popcount (x);
6535	mpz_clear__gmpz_clear (x);
6536
6537	return gfc_get_int_expr (gfc_default_integer_kind, &e->where, res);
6538	}
6539
6540