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)
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)
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) < 0)
156	{
157	/* Confirm that no bits above the signed range are unset if we
158	are doing range checking. */
159	if (flag_range_check != 0)
160	gcc_assert (mpz_scan0 (x, bitsize-1) == ULONG_MAX);
161
162	mpz_init_set_ui (mask, 1);
163	mpz_mul_2exp (mask, mask, bitsize);
164	mpz_sub_ui (mask, mask, 1);
165
166	mpz_and (x, x, mask);
167
168	mpz_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_check != 0)
175	gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX);
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_check != 0)
193	gcc_assert (mpz_scan1 (x, bitsize) == ULONG_MAX);
194
195	if (mpz_tstbit (x, bitsize - 1) == 1)
196	{
197	mpz_init_set_ui (mask, 1);
198	mpz_mul_2exp (mask, mask, bitsize);
199	mpz_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 (x, x);
206	mpz_add_ui (x, x, 1);
207	mpz_and (x, x, mask);
208
209	mpz_neg (gmp_w: x, gmp_u: x);
210
211	mpz_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)
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 && e->value.constructor == NULL)
238	{
239	mpz_init_set_ui (size, 1);
240	for (int j = 0; j < e->rank; j++)
241	mpz_mul (size, size, e->shape[j]);
242	bool not_size0 = (mpz_cmp_si (size, 0) != 0);
243	mpz_clear (size);
244	if (not_size0)
245	return false;
246	}
247
248	for (c = gfc_constructor_first (base: e->value.constructor);
249	c; c = gfc_constructor_next (ctor: 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. We do this when either
258	gfc_init_expr_flag is set or for not too large array constructors. */
259	bool expand;
260	expand = (e->rank == 1
261	&& e->shape
262	&& (mpz_cmp_ui (e->shape[0], flag_max_array_constructor) < 0));
263
264	if (!array_OK && (gfc_init_expr_flag || expand) && e->rank == 1)
265	{
266	bool saved_init_expr_flag = gfc_init_expr_flag;
267	array_OK = gfc_reduce_init_expr (expr: e);
268	/* gfc_reduce_init_expr resets the flag. */
269	gfc_init_expr_flag = saved_init_expr_flag;
270	}
271	else
272	return array_OK;
273
274	/* Recheck to make sure that any EXPR_ARRAYs have gone. */
275	for (c = gfc_constructor_first (base: e->value.constructor);
276	c; c = gfc_constructor_next (ctor: c))
277	if (c->expr->expr_type != EXPR_CONSTANT
278	&& c->expr->expr_type != EXPR_STRUCTURE)
279	return false;
280
281	/* Make sure that the array has a valid shape. */
282	if (e->shape == NULL && e->rank == 1)
283	{
284	if (!gfc_array_size(e, &size))
285	return false;
286	e->shape = gfc_get_shape (1);
287	mpz_init_set (e->shape[0], size);
288	mpz_clear (size);
289	}
290
291	return array_OK;
292	}
293
294	bool
295	gfc_is_constant_array_expr (gfc_expr *e)
296	{
297	return is_constant_array_expr (e);
298	}
299
300
301	/* Test for a size zero array. */
302	bool
303	gfc_is_size_zero_array (gfc_expr *array)
304	{
305
306	if (array->rank == 0)
307	return false;
308
309	if (array->expr_type == EXPR_VARIABLE && array->rank > 0
310	&& array->symtree->n.sym->attr.flavor == FL_PARAMETER
311	&& array->shape != NULL)
312	{
313	for (int i = 0; i < array->rank; i++)
314	if (mpz_cmp_si (array->shape[i], 0) <= 0)
315	return true;
316
317	return false;
318	}
319
320	if (array->expr_type == EXPR_ARRAY)
321	return array->value.constructor == NULL;
322
323	return false;
324	}
325
326
327	/* Initialize a transformational result expression with a given value. */
328
329	static void
330	init_result_expr (gfc_expr *e, int init, gfc_expr *array)
331	{
332	if (e && e->expr_type == EXPR_ARRAY)
333	{
334	gfc_constructor *ctor = gfc_constructor_first (base: e->value.constructor);
335	while (ctor)
336	{
337	init_result_expr (e: ctor->expr, init, array);
338	ctor = gfc_constructor_next (ctor);
339	}
340	}
341	else if (e && e->expr_type == EXPR_CONSTANT)
342	{
343	int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
344	HOST_WIDE_INT length;
345	gfc_char_t *string;
346
347	switch (e->ts.type)
348	{
349	case BT_LOGICAL:
350	e->value.logical = (init ? 1 : 0);
351	break;
352
353	case BT_INTEGER:
354	if (init == INT_MIN)
355	mpz_set (e->value.integer, gfc_integer_kinds[i].min_int);
356	else if (init == INT_MAX)
357	mpz_set (e->value.integer, gfc_integer_kinds[i].huge);
358	else
359	mpz_set_si (e->value.integer, init);
360	break;
361
362	case BT_REAL:
363	if (init == INT_MIN)
364	{
365	mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
366	mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
367	}
368	else if (init == INT_MAX)
369	mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
370	else
371	mpfr_set_si (e->value.real, init, GFC_RND_MODE);
372	break;
373
374	case BT_COMPLEX:
375	mpc_set_si (e->value.complex, init, GFC_MPC_RND_MODE);
376	break;
377
378	case BT_CHARACTER:
379	if (init == INT_MIN)
380	{
381	gfc_expr *len = gfc_simplify_len (array, NULL);
382	gfc_extract_hwi (len, &length);
383	string = gfc_get_wide_string (length + 1);
384	gfc_wide_memset (string, 0, length);
385	}
386	else if (init == INT_MAX)
387	{
388	gfc_expr *len = gfc_simplify_len (array, NULL);
389	gfc_extract_hwi (len, &length);
390	string = gfc_get_wide_string (length + 1);
391	gfc_wide_memset (string, 255, length);
392	}
393	else
394	{
395	length = 0;
396	string = gfc_get_wide_string (1);
397	}
398
399	string[length] = '\0';
400	e->value.character.length = length;
401	e->value.character.string = string;
402	break;
403
404	default:
405	gcc_unreachable();
406	}
407	}
408	else
409	gcc_unreachable();
410	}
411
412
413	/* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul;
414	if conj_a is true, the matrix_a is complex conjugated. */
415
416	static gfc_expr *
417	compute_dot_product (gfc_expr *matrix_a, int stride_a, int offset_a,
418	gfc_expr *matrix_b, int stride_b, int offset_b,
419	bool conj_a)
420	{
421	gfc_expr *result, *a, *b, *c;
422
423	/* Set result to an INTEGER(1) 0 for numeric types and .false. for
424	LOGICAL. Mixed-mode math in the loop will promote result to the
425	correct type and kind. */
426	if (matrix_a->ts.type == BT_LOGICAL)
427	result = gfc_get_logical_expr (gfc_default_logical_kind, NULL, false);
428	else
429	result = gfc_get_int_expr (1, NULL, 0);
430	result->where = matrix_a->where;
431
432	a = gfc_constructor_lookup_expr (base: matrix_a->value.constructor, n: offset_a);
433	b = gfc_constructor_lookup_expr (base: matrix_b->value.constructor, n: offset_b);
434	while (a && b)
435	{
436	/* Copying of expressions is required as operands are free'd
437	by the gfc_arith routines. */
438	switch (result->ts.type)
439	{
440	case BT_LOGICAL:
441	result = gfc_or (result,
442	gfc_and (gfc_copy_expr (a),
443	gfc_copy_expr (b)));
444	break;
445
446	case BT_INTEGER:
447	case BT_REAL:
448	case BT_COMPLEX:
449	if (conj_a && a->ts.type == BT_COMPLEX)
450	c = gfc_simplify_conjg (a);
451	else
452	c = gfc_copy_expr (a);
453	result = gfc_add (result, gfc_multiply (c, gfc_copy_expr (b)));
454	break;
455
456	default:
457	gcc_unreachable();
458	}
459
460	offset_a += stride_a;
461	a = gfc_constructor_lookup_expr (base: matrix_a->value.constructor, n: offset_a);
462
463	offset_b += stride_b;
464	b = gfc_constructor_lookup_expr (base: matrix_b->value.constructor, n: offset_b);
465	}
466
467	return result;
468	}
469
470
471	/* Build a result expression for transformational intrinsics,
472	depending on DIM. */
473
474	static gfc_expr *
475	transformational_result (gfc_expr *array, gfc_expr *dim, bt type,
476	int kind, locus* where)
477	{
478	gfc_expr *result;
479	int i, nelem;
480
481	if (!dim || array->rank == 1)
482	return gfc_get_constant_expr (type, kind, where);
483
484	result = gfc_get_array_expr (type, kind, where);
485	result->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
486	result->rank = array->rank - 1;
487
488	/* gfc_array_size() would count the number of elements in the constructor,
489	we have not built those yet. */
490	nelem = 1;
491	for (i = 0; i < result->rank; ++i)
492	nelem *= mpz_get_ui (gmp_z: result->shape[i]);
493
494	for (i = 0; i < nelem; ++i)
495	{
496	gfc_constructor_append_expr (base: &result->value.constructor,
497	e: gfc_get_constant_expr (type, kind, where),
498	NULL);
499	}
500
501	return result;
502	}
503
504
505	typedef gfc_expr* (*transformational_op)(gfc_expr*, gfc_expr*);
506
507	/* Wrapper function, implements 'op1 += 1'. Only called if MASK
508	of COUNT intrinsic is .TRUE..
509
510	Interface and implementation mimics arith functions as
511	gfc_add, gfc_multiply, etc. */
512
513	static gfc_expr *
514	gfc_count (gfc_expr *op1, gfc_expr *op2)
515	{
516	gfc_expr *result;
517
518	gcc_assert (op1->ts.type == BT_INTEGER);
519	gcc_assert (op2->ts.type == BT_LOGICAL);
520	gcc_assert (op2->value.logical);
521
522	result = gfc_copy_expr (op1);
523	mpz_add_ui (result->value.integer, result->value.integer, 1);
524
525	gfc_free_expr (op1);
526	gfc_free_expr (op2);
527	return result;
528	}
529
530
531	/* Transforms an ARRAY with operation OP, according to MASK, to a
532	scalar RESULT. E.g. called if
533
534	REAL, PARAMETER :: array(n, m) = ...
535	REAL, PARAMETER :: s = SUM(array)
536
537	where OP == gfc_add(). */
538
539	static gfc_expr *
540	simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask,
541	transformational_op op)
542	{
543	gfc_expr *a, *m;
544	gfc_constructor *array_ctor, *mask_ctor;
545
546	/* Shortcut for constant .FALSE. MASK. */
547	if (mask
548	&& mask->expr_type == EXPR_CONSTANT
549	&& !mask->value.logical)
550	return result;
551
552	array_ctor = gfc_constructor_first (base: array->value.constructor);
553	mask_ctor = NULL;
554	if (mask && mask->expr_type == EXPR_ARRAY)
555	mask_ctor = gfc_constructor_first (base: mask->value.constructor);
556
557	while (array_ctor)
558	{
559	a = array_ctor->expr;
560	array_ctor = gfc_constructor_next (ctor: array_ctor);
561
562	/* A constant MASK equals .TRUE. here and can be ignored. */
563	if (mask_ctor)
564	{
565	m = mask_ctor->expr;
566	mask_ctor = gfc_constructor_next (ctor: mask_ctor);
567	if (!m->value.logical)
568	continue;
569	}
570
571	result = op (result, gfc_copy_expr (a));
572	if (!result)
573	return result;
574	}
575
576	return result;
577	}
578
579	/* Transforms an ARRAY with operation OP, according to MASK, to an
580	array RESULT. E.g. called if
581
582	REAL, PARAMETER :: array(n, m) = ...
583	REAL, PARAMETER :: s(n) = PROD(array, DIM=1)
584
585	where OP == gfc_multiply().
586	The result might be post processed using post_op. */
587
588	static gfc_expr *
589	simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim,
590	gfc_expr *mask, transformational_op op,
591	transformational_op post_op)
592	{
593	mpz_t size;
594	int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
595	gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
596	gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
597
598	int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
599	sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
600	tmpstride[GFC_MAX_DIMENSIONS];
601
602	/* Shortcut for constant .FALSE. MASK. */
603	if (mask
604	&& mask->expr_type == EXPR_CONSTANT
605	&& !mask->value.logical)
606	return result;
607
608	/* Build an indexed table for array element expressions to minimize
609	linked-list traversal. Masked elements are set to NULL. */
610	gfc_array_size (array, &size);
611	arraysize = mpz_get_ui (gmp_z: size);
612	mpz_clear (size);
613
614	arrayvec = XCNEWVEC (gfc_expr*, arraysize);
615
616	array_ctor = gfc_constructor_first (base: array->value.constructor);
617	mask_ctor = NULL;
618	if (mask && mask->expr_type == EXPR_ARRAY)
619	mask_ctor = gfc_constructor_first (base: mask->value.constructor);
620
621	for (i = 0; i < arraysize; ++i)
622	{
623	arrayvec[i] = array_ctor->expr;
624	array_ctor = gfc_constructor_next (ctor: array_ctor);
625
626	if (mask_ctor)
627	{
628	if (!mask_ctor->expr->value.logical)
629	arrayvec[i] = NULL;
630
631	mask_ctor = gfc_constructor_next (ctor: mask_ctor);
632	}
633	}
634
635	/* Same for the result expression. */
636	gfc_array_size (result, &size);
637	resultsize = mpz_get_ui (gmp_z: size);
638	mpz_clear (size);
639
640	resultvec = XCNEWVEC (gfc_expr*, resultsize);
641	result_ctor = gfc_constructor_first (base: result->value.constructor);
642	for (i = 0; i < resultsize; ++i)
643	{
644	resultvec[i] = result_ctor->expr;
645	result_ctor = gfc_constructor_next (ctor: result_ctor);
646	}
647
648	gfc_extract_int (dim, &dim_index);
649	dim_index -= 1; /* zero-base index */
650	dim_extent = 0;
651	dim_stride = 0;
652
653	for (i = 0, n = 0; i < array->rank; ++i)
654	{
655	count[i] = 0;
656	tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
657	if (i == dim_index)
658	{
659	dim_extent = mpz_get_si (array->shape[i]);
660	dim_stride = tmpstride[i];
661	continue;
662	}
663
664	extent[n] = mpz_get_si (array->shape[i]);
665	sstride[n] = tmpstride[i];
666	dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
667	n += 1;
668	}
669
670	done = resultsize <= 0;
671	base = arrayvec;
672	dest = resultvec;
673	while (!done)
674	{
675	for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
676	if (*src)
677	*dest = op (*dest, gfc_copy_expr (*src));
678
679	if (post_op)
680	*dest = post_op (*dest, *dest);
681
682	count[0]++;
683	base += sstride[0];
684	dest += dstride[0];
685
686	n = 0;
687	while (!done && count[n] == extent[n])
688	{
689	count[n] = 0;
690	base -= sstride[n] * extent[n];
691	dest -= dstride[n] * extent[n];
692
693	n++;
694	if (n < result->rank)
695	{
696	/* If the nested loop is unrolled GFC_MAX_DIMENSIONS
697	times, we'd warn for the last iteration, because the
698	array index will have already been incremented to the
699	array sizes, and we can't tell that this must make
700	the test against result->rank false, because ranks
701	must not exceed GFC_MAX_DIMENSIONS. */
702	GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds)
703	count[n]++;
704	base += sstride[n];
705	dest += dstride[n];
706	GCC_DIAGNOSTIC_POP
707	}
708	else
709	done = true;
710	}
711	}
712
713	/* Place updated expression in result constructor. */
714	result_ctor = gfc_constructor_first (base: result->value.constructor);
715	for (i = 0; i < resultsize; ++i)
716	{
717	result_ctor->expr = resultvec[i];
718	result_ctor = gfc_constructor_next (ctor: result_ctor);
719	}
720
721	free (ptr: arrayvec);
722	free (ptr: resultvec);
723	return result;
724	}
725
726
727	static gfc_expr *
728	simplify_transformation (gfc_expr *array, gfc_expr *dim, gfc_expr *mask,
729	int init_val, transformational_op op)
730	{
731	gfc_expr *result;
732	bool size_zero;
733
734	size_zero = gfc_is_size_zero_array (array);
735
736	if (!(is_constant_array_expr (e: array) || size_zero)
737	|| array->shape == NULL
738	|| !gfc_is_constant_expr (dim))
739	return NULL;
740
741	if (mask
742	&& !is_constant_array_expr (e: mask)
743	&& mask->expr_type != EXPR_CONSTANT)
744	return NULL;
745
746	result = transformational_result (array, dim, type: array->ts.type,
747	kind: array->ts.kind, where: &array->where);
748	init_result_expr (e: result, init: init_val, array);
749
750	if (size_zero)
751	return result;
752
753	return !dim || array->rank == 1 ?
754	simplify_transformation_to_scalar (result, array, mask, op) :
755	simplify_transformation_to_array (result, array, dim, mask, op, NULL);
756	}
757
758
759	/********************** Simplification functions *****************************/
760
761	gfc_expr *
762	gfc_simplify_abs (gfc_expr *e)
763	{
764	gfc_expr *result;
765
766	if (e->expr_type != EXPR_CONSTANT)
767	return NULL;
768
769	switch (e->ts.type)
770	{
771	case BT_INTEGER:
772	result = gfc_get_constant_expr (BT_INTEGER, e->ts.kind, &e->where);
773	mpz_abs (gmp_w: result->value.integer, gmp_u: e->value.integer);
774	return range_check (result, name: "IABS");
775
776	case BT_REAL:
777	result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
778	mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE);
779	return range_check (result, name: "ABS");
780
781	case BT_COMPLEX:
782	gfc_set_model_kind (e->ts.kind);
783	result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
784	mpc_abs (result->value.real, e->value.complex, GFC_RND_MODE);
785	return range_check (result, name: "CABS");
786
787	default:
788	gfc_internal_error ("gfc_simplify_abs(): Bad type");
789	}
790	}
791
792
793	static gfc_expr *
794	simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii)
795	{
796	gfc_expr *result;
797	int kind;
798	bool too_large = false;
799
800	if (e->expr_type != EXPR_CONSTANT)
801	return NULL;
802
803	kind = get_kind (type: BT_CHARACTER, k, name, default_kind: gfc_default_character_kind);
804	if (kind == -1)
805	return &gfc_bad_expr;
806
807	if (mpz_cmp_si (e->value.integer, 0) < 0)
808	{
809	gfc_error ("Argument of %s function at %L is negative", name,
810	&e->where);
811	return &gfc_bad_expr;
812	}
813
814	if (ascii && warn_surprising && mpz_cmp_si (e->value.integer, 127) > 0)
815	gfc_warning (opt: OPT_Wsurprising,
816	"Argument of %s function at %L outside of range [0,127]",
817	name, &e->where);
818
819	if (kind == 1 && mpz_cmp_si (e->value.integer, 255) > 0)
820	too_large = true;
821	else if (kind == 4)
822	{
823	mpz_t t;
824	mpz_init_set_ui (t, 2);
825	mpz_pow_ui (t, t, 32);
826	mpz_sub_ui (t, t, 1);
827	if (mpz_cmp (e->value.integer, t) > 0)
828	too_large = true;
829	mpz_clear (t);
830	}
831
832	if (too_large)
833	{
834	gfc_error ("Argument of %s function at %L is too large for the "
835	"collating sequence of kind %d", name, &e->where, kind);
836	return &gfc_bad_expr;
837	}
838
839	result = gfc_get_character_expr (kind, &e->where, NULL, len: 1);
840	result->value.character.string[0] = mpz_get_ui (gmp_z: e->value.integer);
841
842	return result;
843	}
844
845
846
847	/* We use the processor's collating sequence, because all
848	systems that gfortran currently works on are ASCII. */
849
850	gfc_expr *
851	gfc_simplify_achar (gfc_expr *e, gfc_expr *k)
852	{
853	return simplify_achar_char (e, k, name: "ACHAR", ascii: true);
854	}
855
856
857	gfc_expr *
858	gfc_simplify_acos (gfc_expr *x)
859	{
860	gfc_expr *result;
861
862	if (x->expr_type != EXPR_CONSTANT)
863	return NULL;
864
865	switch (x->ts.type)
866	{
867	case BT_REAL:
868	if (mpfr_cmp_si (x->value.real, 1) > 0
869	|| mpfr_cmp_si (x->value.real, -1) < 0)
870	{
871	gfc_error ("Argument of ACOS at %L must be between -1 and 1",
872	&x->where);
873	return &gfc_bad_expr;
874	}
875	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
876	mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
877	break;
878
879	case BT_COMPLEX:
880	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
881	mpc_acos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
882	break;
883
884	default:
885	gfc_internal_error ("in gfc_simplify_acos(): Bad type");
886	}
887
888	return range_check (result, name: "ACOS");
889	}
890
891	gfc_expr *
892	gfc_simplify_acosh (gfc_expr *x)
893	{
894	gfc_expr *result;
895
896	if (x->expr_type != EXPR_CONSTANT)
897	return NULL;
898
899	switch (x->ts.type)
900	{
901	case BT_REAL:
902	if (mpfr_cmp_si (x->value.real, 1) < 0)
903	{
904	gfc_error ("Argument of ACOSH at %L must not be less than 1",
905	&x->where);
906	return &gfc_bad_expr;
907	}
908
909	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
910	mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE);
911	break;
912
913	case BT_COMPLEX:
914	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
915	mpc_acosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
916	break;
917
918	default:
919	gfc_internal_error ("in gfc_simplify_acosh(): Bad type");
920	}
921
922	return range_check (result, name: "ACOSH");
923	}
924
925	gfc_expr *
926	gfc_simplify_adjustl (gfc_expr *e)
927	{
928	gfc_expr *result;
929	int count, i, len;
930	gfc_char_t ch;
931
932	if (e->expr_type != EXPR_CONSTANT)
933	return NULL;
934
935	len = e->value.character.length;
936
937	for (count = 0, i = 0; i < len; ++i)
938	{
939	ch = e->value.character.string[i];
940	if (ch != ' ')
941	break;
942	++count;
943	}
944
945	result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len);
946	for (i = 0; i < len - count; ++i)
947	result->value.character.string[i] = e->value.character.string[count + i];
948
949	return result;
950	}
951
952
953	gfc_expr *
954	gfc_simplify_adjustr (gfc_expr *e)
955	{
956	gfc_expr *result;
957	int count, i, len;
958	gfc_char_t ch;
959
960	if (e->expr_type != EXPR_CONSTANT)
961	return NULL;
962
963	len = e->value.character.length;
964
965	for (count = 0, i = len - 1; i >= 0; --i)
966	{
967	ch = e->value.character.string[i];
968	if (ch != ' ')
969	break;
970	++count;
971	}
972
973	result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len);
974	for (i = 0; i < count; ++i)
975	result->value.character.string[i] = ' ';
976
977	for (i = count; i < len; ++i)
978	result->value.character.string[i] = e->value.character.string[i - count];
979
980	return result;
981	}
982
983
984	gfc_expr *
985	gfc_simplify_aimag (gfc_expr *e)
986	{
987	gfc_expr *result;
988
989	if (e->expr_type != EXPR_CONSTANT)
990	return NULL;
991
992	result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
993	mpfr_set (result->value.real, mpc_imagref (e->value.complex), GFC_RND_MODE);
994
995	return range_check (result, name: "AIMAG");
996	}
997
998
999	gfc_expr *
1000	gfc_simplify_aint (gfc_expr *e, gfc_expr *k)
1001	{
1002	gfc_expr *rtrunc, *result;
1003	int kind;
1004
1005	kind = get_kind (type: BT_REAL, k, name: "AINT", default_kind: e->ts.kind);
1006	if (kind == -1)
1007	return &gfc_bad_expr;
1008
1009	if (e->expr_type != EXPR_CONSTANT)
1010	return NULL;
1011
1012	rtrunc = gfc_copy_expr (e);
1013	mpfr_trunc (rtrunc->value.real, e->value.real);
1014
1015	result = gfc_real2real (rtrunc, kind);
1016
1017	gfc_free_expr (rtrunc);
1018
1019	return range_check (result, name: "AINT");
1020	}
1021
1022
1023	gfc_expr *
1024	gfc_simplify_all (gfc_expr *mask, gfc_expr *dim)
1025	{
1026	return simplify_transformation (array: mask, dim, NULL, init_val: true, op: gfc_and);
1027	}
1028
1029
1030	gfc_expr *
1031	gfc_simplify_dint (gfc_expr *e)
1032	{
1033	gfc_expr *rtrunc, *result;
1034
1035	if (e->expr_type != EXPR_CONSTANT)
1036	return NULL;
1037
1038	rtrunc = gfc_copy_expr (e);
1039	mpfr_trunc (rtrunc->value.real, e->value.real);
1040
1041	result = gfc_real2real (rtrunc, gfc_default_double_kind);
1042
1043	gfc_free_expr (rtrunc);
1044
1045	return range_check (result, name: "DINT");
1046	}
1047
1048
1049	gfc_expr *
1050	gfc_simplify_dreal (gfc_expr *e)
1051	{
1052	gfc_expr *result = NULL;
1053
1054	if (e->expr_type != EXPR_CONSTANT)
1055	return NULL;
1056
1057	result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
1058	mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
1059
1060	return range_check (result, name: "DREAL");
1061	}
1062
1063
1064	gfc_expr *
1065	gfc_simplify_anint (gfc_expr *e, gfc_expr *k)
1066	{
1067	gfc_expr *result;
1068	int kind;
1069
1070	kind = get_kind (type: BT_REAL, k, name: "ANINT", default_kind: e->ts.kind);
1071	if (kind == -1)
1072	return &gfc_bad_expr;
1073
1074	if (e->expr_type != EXPR_CONSTANT)
1075	return NULL;
1076
1077	result = gfc_get_constant_expr (e->ts.type, kind, &e->where);
1078	mpfr_round (result->value.real, e->value.real);
1079
1080	return range_check (result, name: "ANINT");
1081	}
1082
1083
1084	gfc_expr *
1085	gfc_simplify_and (gfc_expr *x, gfc_expr *y)
1086	{
1087	gfc_expr *result;
1088	int kind;
1089
1090	if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1091	return NULL;
1092
1093	kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
1094
1095	switch (x->ts.type)
1096	{
1097	case BT_INTEGER:
1098	result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
1099	mpz_and (result->value.integer, x->value.integer, y->value.integer);
1100	return range_check (result, name: "AND");
1101
1102	case BT_LOGICAL:
1103	return gfc_get_logical_expr (kind, &x->where,
1104	x->value.logical && y->value.logical);
1105
1106	default:
1107	gcc_unreachable ();
1108	}
1109	}
1110
1111
1112	gfc_expr *
1113	gfc_simplify_any (gfc_expr *mask, gfc_expr *dim)
1114	{
1115	return simplify_transformation (array: mask, dim, NULL, init_val: false, op: gfc_or);
1116	}
1117
1118
1119	gfc_expr *
1120	gfc_simplify_dnint (gfc_expr *e)
1121	{
1122	gfc_expr *result;
1123
1124	if (e->expr_type != EXPR_CONSTANT)
1125	return NULL;
1126
1127	result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &e->where);
1128	mpfr_round (result->value.real, e->value.real);
1129
1130	return range_check (result, name: "DNINT");
1131	}
1132
1133
1134	gfc_expr *
1135	gfc_simplify_asin (gfc_expr *x)
1136	{
1137	gfc_expr *result;
1138
1139	if (x->expr_type != EXPR_CONSTANT)
1140	return NULL;
1141
1142	switch (x->ts.type)
1143	{
1144	case BT_REAL:
1145	if (mpfr_cmp_si (x->value.real, 1) > 0
1146	|| mpfr_cmp_si (x->value.real, -1) < 0)
1147	{
1148	gfc_error ("Argument of ASIN at %L must be between -1 and 1",
1149	&x->where);
1150	return &gfc_bad_expr;
1151	}
1152	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1153	mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
1154	break;
1155
1156	case BT_COMPLEX:
1157	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1158	mpc_asin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1159	break;
1160
1161	default:
1162	gfc_internal_error ("in gfc_simplify_asin(): Bad type");
1163	}
1164
1165	return range_check (result, name: "ASIN");
1166	}
1167
1168
1169	/* Convert radians to degrees, i.e., x * 180 / pi. */
1170
1171	static void
1172	rad2deg (mpfr_t x)
1173	{
1174	mpfr_t tmp;
1175
1176	mpfr_init (tmp);
1177	mpfr_const_pi (tmp, GFC_RND_MODE);
1178	mpfr_mul_ui (x, x, 180, GFC_RND_MODE);
1179	mpfr_div (x, x, tmp, GFC_RND_MODE);
1180	mpfr_clear (tmp);
1181	}
1182
1183
1184	/* Simplify ACOSD(X) where the returned value has units of degree. */
1185
1186	gfc_expr *
1187	gfc_simplify_acosd (gfc_expr *x)
1188	{
1189	gfc_expr *result;
1190
1191	if (x->expr_type != EXPR_CONSTANT)
1192	return NULL;
1193
1194	if (mpfr_cmp_si (x->value.real, 1) > 0
1195	|| mpfr_cmp_si (x->value.real, -1) < 0)
1196	{
1197	gfc_error ("Argument of ACOSD at %L must be between -1 and 1",
1198	&x->where);
1199	return &gfc_bad_expr;
1200	}
1201
1202	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1203	mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
1204	rad2deg (x: result->value.real);
1205
1206	return range_check (result, name: "ACOSD");
1207	}
1208
1209
1210	/* Simplify asind (x) where the returned value has units of degree. */
1211
1212	gfc_expr *
1213	gfc_simplify_asind (gfc_expr *x)
1214	{
1215	gfc_expr *result;
1216
1217	if (x->expr_type != EXPR_CONSTANT)
1218	return NULL;
1219
1220	if (mpfr_cmp_si (x->value.real, 1) > 0
1221	|| mpfr_cmp_si (x->value.real, -1) < 0)
1222	{
1223	gfc_error ("Argument of ASIND at %L must be between -1 and 1",
1224	&x->where);
1225	return &gfc_bad_expr;
1226	}
1227
1228	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1229	mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
1230	rad2deg (x: result->value.real);
1231
1232	return range_check (result, name: "ASIND");
1233	}
1234
1235
1236	/* Simplify atand (x) where the returned value has units of degree. */
1237
1238	gfc_expr *
1239	gfc_simplify_atand (gfc_expr *x)
1240	{
1241	gfc_expr *result;
1242
1243	if (x->expr_type != EXPR_CONSTANT)
1244	return NULL;
1245
1246	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1247	mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
1248	rad2deg (x: result->value.real);
1249
1250	return range_check (result, name: "ATAND");
1251	}
1252
1253
1254	gfc_expr *
1255	gfc_simplify_asinh (gfc_expr *x)
1256	{
1257	gfc_expr *result;
1258
1259	if (x->expr_type != EXPR_CONSTANT)
1260	return NULL;
1261
1262	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1263
1264	switch (x->ts.type)
1265	{
1266	case BT_REAL:
1267	mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
1268	break;
1269
1270	case BT_COMPLEX:
1271	mpc_asinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1272	break;
1273
1274	default:
1275	gfc_internal_error ("in gfc_simplify_asinh(): Bad type");
1276	}
1277
1278	return range_check (result, name: "ASINH");
1279	}
1280
1281
1282	gfc_expr *
1283	gfc_simplify_atan (gfc_expr *x)
1284	{
1285	gfc_expr *result;
1286
1287	if (x->expr_type != EXPR_CONSTANT)
1288	return NULL;
1289
1290	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1291
1292	switch (x->ts.type)
1293	{
1294	case BT_REAL:
1295	mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
1296	break;
1297
1298	case BT_COMPLEX:
1299	mpc_atan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1300	break;
1301
1302	default:
1303	gfc_internal_error ("in gfc_simplify_atan(): Bad type");
1304	}
1305
1306	return range_check (result, name: "ATAN");
1307	}
1308
1309
1310	gfc_expr *
1311	gfc_simplify_atanh (gfc_expr *x)
1312	{
1313	gfc_expr *result;
1314
1315	if (x->expr_type != EXPR_CONSTANT)
1316	return NULL;
1317
1318	switch (x->ts.type)
1319	{
1320	case BT_REAL:
1321	if (mpfr_cmp_si (x->value.real, 1) >= 0
1322	|| mpfr_cmp_si (x->value.real, -1) <= 0)
1323	{
1324	gfc_error ("Argument of ATANH at %L must be inside the range -1 "
1325	"to 1", &x->where);
1326	return &gfc_bad_expr;
1327	}
1328	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1329	mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
1330	break;
1331
1332	case BT_COMPLEX:
1333	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1334	mpc_atanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1335	break;
1336
1337	default:
1338	gfc_internal_error ("in gfc_simplify_atanh(): Bad type");
1339	}
1340
1341	return range_check (result, name: "ATANH");
1342	}
1343
1344
1345	gfc_expr *
1346	gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
1347	{
1348	gfc_expr *result;
1349
1350	if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1351	return NULL;
1352
1353	if (mpfr_zero_p (y->value.real) && mpfr_zero_p (x->value.real))
1354	{
1355	gfc_error ("If first argument of ATAN2 at %L is zero, then the "
1356	"second argument must not be zero", &y->where);
1357	return &gfc_bad_expr;
1358	}
1359
1360	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1361	mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
1362
1363	return range_check (result, name: "ATAN2");
1364	}
1365
1366
1367	gfc_expr *
1368	gfc_simplify_bessel_j0 (gfc_expr *x)
1369	{
1370	gfc_expr *result;
1371
1372	if (x->expr_type != EXPR_CONSTANT)
1373	return NULL;
1374
1375	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1376	mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODE);
1377
1378	return range_check (result, name: "BESSEL_J0");
1379	}
1380
1381
1382	gfc_expr *
1383	gfc_simplify_bessel_j1 (gfc_expr *x)
1384	{
1385	gfc_expr *result;
1386
1387	if (x->expr_type != EXPR_CONSTANT)
1388	return NULL;
1389
1390	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1391	mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODE);
1392
1393	return range_check (result, name: "BESSEL_J1");
1394	}
1395
1396
1397	gfc_expr *
1398	gfc_simplify_bessel_jn (gfc_expr *order, gfc_expr *x)
1399	{
1400	gfc_expr *result;
1401	long n;
1402
1403	if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
1404	return NULL;
1405
1406	n = mpz_get_si (order->value.integer);
1407	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1408	mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODE);
1409
1410	return range_check (result, name: "BESSEL_JN");
1411	}
1412
1413
1414	/* Simplify transformational form of JN and YN. */
1415
1416	static gfc_expr *
1417	gfc_simplify_bessel_n2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x,
1418	bool jn)
1419	{
1420	gfc_expr *result;
1421	gfc_expr *e;
1422	long n1, n2;
1423	int i;
1424	mpfr_t x2rev, last1, last2;
1425
1426	if (x->expr_type != EXPR_CONSTANT || order1->expr_type != EXPR_CONSTANT
1427	|| order2->expr_type != EXPR_CONSTANT)
1428	return NULL;
1429
1430	n1 = mpz_get_si (order1->value.integer);
1431	n2 = mpz_get_si (order2->value.integer);
1432	result = gfc_get_array_expr (type: x->ts.type, kind: x->ts.kind, &x->where);
1433	result->rank = 1;
1434	result->shape = gfc_get_shape (1);
1435	mpz_init_set_ui (result->shape[0], MAX (n2-n1+1, 0));
1436
1437	if (n2 < n1)
1438	return result;
1439
1440	/* Special case: x == 0; it is J0(0.0) == 1, JN(N > 0, 0.0) == 0; and
1441	YN(N, 0.0) = -Inf. */
1442
1443	if (mpfr_cmp_ui (x->value.real, 0.0) == 0)
1444	{
1445	if (!jn && flag_range_check)
1446	{
1447	gfc_error ("Result of BESSEL_YN is -INF at %L", &result->where);
1448	gfc_free_expr (result);
1449	return &gfc_bad_expr;
1450	}
1451
1452	if (jn && n1 == 0)
1453	{
1454	e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1455	mpfr_set_ui (e->value.real, 1, GFC_RND_MODE);
1456	gfc_constructor_append_expr (base: &result->value.constructor, e,
1457	where: &x->where);
1458	n1++;
1459	}
1460
1461	for (i = n1; i <= n2; i++)
1462	{
1463	e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1464	if (jn)
1465	mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
1466	else
1467	mpfr_set_inf (e->value.real, -1);
1468	gfc_constructor_append_expr (base: &result->value.constructor, e,
1469	where: &x->where);
1470	}
1471
1472	return result;
1473	}
1474
1475	/* Use the faster but more verbose recurrence algorithm. Bessel functions
1476	are stable for downward recursion and Neumann functions are stable
1477	for upward recursion. It is
1478	x2rev = 2.0/x,
1479	J(N-1, x) = x2rev * N * J(N, x) - J(N+1, x),
1480	Y(N+1, x) = x2rev * N * Y(N, x) - Y(N-1, x).
1481	Cf. http://dlmf.nist.gov/10.74#iv and http://dlmf.nist.gov/10.6#E1 */
1482
1483	gfc_set_model_kind (x->ts.kind);
1484
1485	/* Get first recursion anchor. */
1486
1487	mpfr_init (last1);
1488	if (jn)
1489	mpfr_jn (last1, n2, x->value.real, GFC_RND_MODE);
1490	else
1491	mpfr_yn (last1, n1, x->value.real, GFC_RND_MODE);
1492
1493	e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1494	mpfr_set (e->value.real, last1, GFC_RND_MODE);
1495	if (range_check (result: e, name: jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
1496	{
1497	mpfr_clear (last1);
1498	gfc_free_expr (e);
1499	gfc_free_expr (result);
1500	return &gfc_bad_expr;
1501	}
1502	gfc_constructor_append_expr (base: &result->value.constructor, e, where: &x->where);
1503
1504	if (n1 == n2)
1505	{
1506	mpfr_clear (last1);
1507	return result;
1508	}
1509
1510	/* Get second recursion anchor. */
1511
1512	mpfr_init (last2);
1513	if (jn)
1514	mpfr_jn (last2, n2-1, x->value.real, GFC_RND_MODE);
1515	else
1516	mpfr_yn (last2, n1+1, x->value.real, GFC_RND_MODE);
1517
1518	e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1519	mpfr_set (e->value.real, last2, GFC_RND_MODE);
1520	if (range_check (result: e, name: jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
1521	{
1522	mpfr_clear (last1);
1523	mpfr_clear (last2);
1524	gfc_free_expr (e);
1525	gfc_free_expr (result);
1526	return &gfc_bad_expr;
1527	}
1528	if (jn)
1529	gfc_constructor_insert_expr (base: &result->value.constructor, e, where: &x->where, n: -2);
1530	else
1531	gfc_constructor_append_expr (base: &result->value.constructor, e, where: &x->where);
1532
1533	if (n1 + 1 == n2)
1534	{
1535	mpfr_clear (last1);
1536	mpfr_clear (last2);
1537	return result;
1538	}
1539
1540	/* Start actual recursion. */
1541
1542	mpfr_init (x2rev);
1543	mpfr_ui_div (x2rev, 2, x->value.real, GFC_RND_MODE);
1544
1545	for (i = 2; i <= n2-n1; i++)
1546	{
1547	e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1548
1549	/* Special case: For YN, if the previous N gave -INF, set
1550	also N+1 to -INF. */
1551	if (!jn && !flag_range_check && mpfr_inf_p (last2))
1552	{
1553	mpfr_set_inf (e->value.real, -1);
1554	gfc_constructor_append_expr (base: &result->value.constructor, e,
1555	where: &x->where);
1556	continue;
1557	}
1558
1559	mpfr_mul_si (e->value.real, x2rev, jn ? (n2-i+1) : (n1+i-1),
1560	GFC_RND_MODE);
1561	mpfr_mul (e->value.real, e->value.real, last2, GFC_RND_MODE);
1562	mpfr_sub (e->value.real, e->value.real, last1, GFC_RND_MODE);
1563
1564	if (range_check (result: e, name: jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
1565	{
1566	/* Range_check frees "e" in that case. */
1567	e = NULL;
1568	goto error;
1569	}
1570
1571	if (jn)
1572	gfc_constructor_insert_expr (base: &result->value.constructor, e, where: &x->where,
1573	n: -i-1);
1574	else
1575	gfc_constructor_append_expr (base: &result->value.constructor, e, where: &x->where);
1576
1577	mpfr_set (last1, last2, GFC_RND_MODE);
1578	mpfr_set (last2, e->value.real, GFC_RND_MODE);
1579	}
1580
1581	mpfr_clear (last1);
1582	mpfr_clear (last2);
1583	mpfr_clear (x2rev);
1584	return result;
1585
1586	error:
1587	mpfr_clear (last1);
1588	mpfr_clear (last2);
1589	mpfr_clear (x2rev);
1590	gfc_free_expr (e);
1591	gfc_free_expr (result);
1592	return &gfc_bad_expr;
1593	}
1594
1595
1596	gfc_expr *
1597	gfc_simplify_bessel_jn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x)
1598	{
1599	return gfc_simplify_bessel_n2 (order1, order2, x, jn: true);
1600	}
1601
1602
1603	gfc_expr *
1604	gfc_simplify_bessel_y0 (gfc_expr *x)
1605	{
1606	gfc_expr *result;
1607
1608	if (x->expr_type != EXPR_CONSTANT)
1609	return NULL;
1610
1611	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1612	mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODE);
1613
1614	return range_check (result, name: "BESSEL_Y0");
1615	}
1616
1617
1618	gfc_expr *
1619	gfc_simplify_bessel_y1 (gfc_expr *x)
1620	{
1621	gfc_expr *result;
1622
1623	if (x->expr_type != EXPR_CONSTANT)
1624	return NULL;
1625
1626	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1627	mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODE);
1628
1629	return range_check (result, name: "BESSEL_Y1");
1630	}
1631
1632
1633	gfc_expr *
1634	gfc_simplify_bessel_yn (gfc_expr *order, gfc_expr *x)
1635	{
1636	gfc_expr *result;
1637	long n;
1638
1639	if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
1640	return NULL;
1641
1642	n = mpz_get_si (order->value.integer);
1643	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1644	mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE);
1645
1646	return range_check (result, name: "BESSEL_YN");
1647	}
1648
1649
1650	gfc_expr *
1651	gfc_simplify_bessel_yn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x)
1652	{
1653	return gfc_simplify_bessel_n2 (order1, order2, x, jn: false);
1654	}
1655
1656
1657	gfc_expr *
1658	gfc_simplify_bit_size (gfc_expr *e)
1659	{
1660	int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1661	return gfc_get_int_expr (e->ts.kind, &e->where,
1662	gfc_integer_kinds[i].bit_size);
1663	}
1664
1665
1666	gfc_expr *
1667	gfc_simplify_btest (gfc_expr *e, gfc_expr *bit)
1668	{
1669	int b;
1670
1671	if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT)
1672	return NULL;
1673
1674	if (!gfc_check_bitfcn (e, bit))
1675	return &gfc_bad_expr;
1676
1677	if (gfc_extract_int (bit, &b) || b < 0)
1678	return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, false);
1679
1680	return gfc_get_logical_expr (gfc_default_logical_kind, &e->where,
1681	mpz_tstbit (e->value.integer, b));
1682	}
1683
1684
1685	static int
1686	compare_bitwise (gfc_expr *i, gfc_expr *j)
1687	{
1688	mpz_t x, y;
1689	int k, res;
1690
1691	gcc_assert (i->ts.type == BT_INTEGER);
1692	gcc_assert (j->ts.type == BT_INTEGER);
1693
1694	mpz_init_set (x, i->value.integer);
1695	k = gfc_validate_kind (i->ts.type, i->ts.kind, false);
1696	convert_mpz_to_unsigned (x, bitsize: gfc_integer_kinds[k].bit_size);
1697
1698	mpz_init_set (y, j->value.integer);
1699	k = gfc_validate_kind (j->ts.type, j->ts.kind, false);
1700	convert_mpz_to_unsigned (x: y, bitsize: gfc_integer_kinds[k].bit_size);
1701
1702	res = mpz_cmp (x, y);
1703	mpz_clear (x);
1704	mpz_clear (y);
1705	return res;
1706	}
1707
1708
1709	gfc_expr *
1710	gfc_simplify_bge (gfc_expr *i, gfc_expr *j)
1711	{
1712	if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
1713	return NULL;
1714
1715	return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
1716	compare_bitwise (i, j) >= 0);
1717	}
1718
1719
1720	gfc_expr *
1721	gfc_simplify_bgt (gfc_expr *i, gfc_expr *j)
1722	{
1723	if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
1724	return NULL;
1725
1726	return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
1727	compare_bitwise (i, j) > 0);
1728	}
1729
1730
1731	gfc_expr *
1732	gfc_simplify_ble (gfc_expr *i, gfc_expr *j)
1733	{
1734	if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
1735	return NULL;
1736
1737	return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
1738	compare_bitwise (i, j) <= 0);
1739	}
1740
1741
1742	gfc_expr *
1743	gfc_simplify_blt (gfc_expr *i, gfc_expr *j)
1744	{
1745	if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
1746	return NULL;
1747
1748	return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
1749	compare_bitwise (i, j) < 0);
1750	}
1751
1752
1753	gfc_expr *
1754	gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
1755	{
1756	gfc_expr *ceil, *result;
1757	int kind;
1758
1759	kind = get_kind (type: BT_INTEGER, k, name: "CEILING", default_kind: gfc_default_integer_kind);
1760	if (kind == -1)
1761	return &gfc_bad_expr;
1762
1763	if (e->expr_type != EXPR_CONSTANT)
1764	return NULL;
1765
1766	ceil = gfc_copy_expr (e);
1767	mpfr_ceil (ceil->value.real, e->value.real);
1768
1769	result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
1770	gfc_mpfr_to_mpz (result->value.integer, ceil->value.real, &e->where);
1771
1772	gfc_free_expr (ceil);
1773
1774	return range_check (result, name: "CEILING");
1775	}
1776
1777
1778	gfc_expr *
1779	gfc_simplify_char (gfc_expr *e, gfc_expr *k)
1780	{
1781	return simplify_achar_char (e, k, name: "CHAR", ascii: false);
1782	}
1783
1784
1785	/* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX. */
1786
1787	static gfc_expr *
1788	simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
1789	{
1790	gfc_expr *result;
1791
1792	if (x->expr_type != EXPR_CONSTANT
1793	|| (y != NULL && y->expr_type != EXPR_CONSTANT))
1794	return NULL;
1795
1796	result = gfc_get_constant_expr (BT_COMPLEX, kind, &x->where);
1797
1798	switch (x->ts.type)
1799	{
1800	case BT_INTEGER:
1801	mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE);
1802	break;
1803
1804	case BT_REAL:
1805	mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODE);
1806	break;
1807
1808	case BT_COMPLEX:
1809	mpc_set (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1810	break;
1811
1812	default:
1813	gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
1814	}
1815
1816	if (!y)
1817	return range_check (result, name);
1818
1819	switch (y->ts.type)
1820	{
1821	case BT_INTEGER:
1822	mpfr_set_z (mpc_imagref (result->value.complex),
1823	y->value.integer, GFC_RND_MODE);
1824	break;
1825
1826	case BT_REAL:
1827	mpfr_set (mpc_imagref (result->value.complex),
1828	y->value.real, GFC_RND_MODE);
1829	break;
1830
1831	default:
1832	gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
1833	}
1834
1835	return range_check (result, name);
1836	}
1837
1838
1839	gfc_expr *
1840	gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
1841	{
1842	int kind;
1843
1844	kind = get_kind (type: BT_REAL, k, name: "CMPLX", default_kind: gfc_default_complex_kind);
1845	if (kind == -1)
1846	return &gfc_bad_expr;
1847
1848	return simplify_cmplx (name: "CMPLX", x, y, kind);
1849	}
1850
1851
1852	gfc_expr *
1853	gfc_simplify_complex (gfc_expr *x, gfc_expr *y)
1854	{
1855	int kind;
1856
1857	if (x->ts.type == BT_INTEGER && y->ts.type == BT_INTEGER)
1858	kind = gfc_default_complex_kind;
1859	else if (x->ts.type == BT_REAL || y->ts.type == BT_INTEGER)
1860	kind = x->ts.kind;
1861	else if (x->ts.type == BT_INTEGER || y->ts.type == BT_REAL)
1862	kind = y->ts.kind;
1863	else if (x->ts.type == BT_REAL && y->ts.type == BT_REAL)
1864	kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
1865	else
1866	gcc_unreachable ();
1867
1868	return simplify_cmplx (name: "COMPLEX", x, y, kind);
1869	}
1870
1871
1872	gfc_expr *
1873	gfc_simplify_conjg (gfc_expr *e)
1874	{
1875	gfc_expr *result;
1876
1877	if (e->expr_type != EXPR_CONSTANT)
1878	return NULL;
1879
1880	result = gfc_copy_expr (e);
1881	mpc_conj (result->value.complex, result->value.complex, GFC_MPC_RND_MODE);
1882
1883	return range_check (result, name: "CONJG");
1884	}
1885
1886
1887	/* Simplify atan2d (x) where the unit is degree. */
1888
1889	gfc_expr *
1890	gfc_simplify_atan2d (gfc_expr *y, gfc_expr *x)
1891	{
1892	gfc_expr *result;
1893
1894	if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1895	return NULL;
1896
1897	if (mpfr_zero_p (y->value.real) && mpfr_zero_p (x->value.real))
1898	{
1899	gfc_error ("If first argument of ATAN2D at %L is zero, then the "
1900	"second argument must not be zero", &y->where);
1901	return &gfc_bad_expr;
1902	}
1903
1904	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1905	mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
1906	rad2deg (x: result->value.real);
1907
1908	return range_check (result, name: "ATAN2D");
1909	}
1910
1911
1912	gfc_expr *
1913	gfc_simplify_cos (gfc_expr *x)
1914	{
1915	gfc_expr *result;
1916
1917	if (x->expr_type != EXPR_CONSTANT)
1918	return NULL;
1919
1920	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1921
1922	switch (x->ts.type)
1923	{
1924	case BT_REAL:
1925	mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
1926	break;
1927
1928	case BT_COMPLEX:
1929	gfc_set_model_kind (x->ts.kind);
1930	mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1931	break;
1932
1933	default:
1934	gfc_internal_error ("in gfc_simplify_cos(): Bad type");
1935	}
1936
1937	return range_check (result, name: "COS");
1938	}
1939
1940
1941	static void
1942	deg2rad (mpfr_t x)
1943	{
1944	mpfr_t d2r;
1945
1946	mpfr_init (d2r);
1947	mpfr_const_pi (d2r, GFC_RND_MODE);
1948	mpfr_div_ui (d2r, d2r, 180, GFC_RND_MODE);
1949	mpfr_mul (x, x, d2r, GFC_RND_MODE);
1950	mpfr_clear (d2r);
1951	}
1952
1953
1954	/* Simplification routines for SIND, COSD, TAND. */
1955	#include "trigd_fe.inc"
1956
1957
1958	/* Simplify COSD(X) where X has the unit of degree. */
1959
1960	gfc_expr *
1961	gfc_simplify_cosd (gfc_expr *x)
1962	{
1963	gfc_expr *result;
1964
1965	if (x->expr_type != EXPR_CONSTANT)
1966	return NULL;
1967
1968	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1969	mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
1970	simplify_cosd (x: result->value.real);
1971
1972	return range_check (result, name: "COSD");
1973	}
1974
1975
1976	/* Simplify SIND(X) where X has the unit of degree. */
1977
1978	gfc_expr *
1979	gfc_simplify_sind (gfc_expr *x)
1980	{
1981	gfc_expr *result;
1982
1983	if (x->expr_type != EXPR_CONSTANT)
1984	return NULL;
1985
1986	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1987	mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
1988	simplify_sind (x: result->value.real);
1989
1990	return range_check (result, name: "SIND");
1991	}
1992
1993
1994	/* Simplify TAND(X) where X has the unit of degree. */
1995
1996	gfc_expr *
1997	gfc_simplify_tand (gfc_expr *x)
1998	{
1999	gfc_expr *result;
2000
2001	if (x->expr_type != EXPR_CONSTANT)
2002	return NULL;
2003
2004	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2005	mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
2006	simplify_tand (x: result->value.real);
2007
2008	return range_check (result, name: "TAND");
2009	}
2010
2011
2012	/* Simplify COTAND(X) where X has the unit of degree. */
2013
2014	gfc_expr *
2015	gfc_simplify_cotand (gfc_expr *x)
2016	{
2017	gfc_expr *result;
2018
2019	if (x->expr_type != EXPR_CONSTANT)
2020	return NULL;
2021
2022	/* Implement COTAND = -TAND(x+90).
2023	TAND offers correct exact values for multiples of 30 degrees.
2024	This implementation is also compatible with the behavior of some legacy
2025	compilers. Keep this consistent with gfc_conv_intrinsic_cotand. */
2026	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2027	mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
2028	mpfr_add_ui (result->value.real, result->value.real, 90, GFC_RND_MODE);
2029	simplify_tand (x: result->value.real);
2030	mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
2031
2032	return range_check (result, name: "COTAND");
2033	}
2034
2035
2036	gfc_expr *
2037	gfc_simplify_cosh (gfc_expr *x)
2038	{
2039	gfc_expr *result;
2040
2041	if (x->expr_type != EXPR_CONSTANT)
2042	return NULL;
2043
2044	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2045
2046	switch (x->ts.type)
2047	{
2048	case BT_REAL:
2049	mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
2050	break;
2051
2052	case BT_COMPLEX:
2053	mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
2054	break;
2055
2056	default:
2057	gcc_unreachable ();
2058	}
2059
2060	return range_check (result, name: "COSH");
2061	}
2062
2063
2064	gfc_expr *
2065	gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
2066	{
2067	gfc_expr *result;
2068	bool size_zero;
2069
2070	size_zero = gfc_is_size_zero_array (array: mask);
2071
2072	if (!(is_constant_array_expr (e: mask) || size_zero)
2073	|| !gfc_is_constant_expr (dim)
2074	|| !gfc_is_constant_expr (kind))
2075	return NULL;
2076
2077	result = transformational_result (array: mask, dim,
2078	type: BT_INTEGER,
2079	kind: get_kind (type: BT_INTEGER, k: kind, name: "COUNT",
2080	default_kind: gfc_default_integer_kind),
2081	where: &mask->where);
2082
2083	init_result_expr (e: result, init: 0, NULL);
2084
2085	if (size_zero)
2086	return result;
2087
2088	/* Passing MASK twice, once as data array, once as mask.
2089	Whenever gfc_count is called, '1' is added to the result. */
2090	return !dim || mask->rank == 1 ?
2091	simplify_transformation_to_scalar (result, array: mask, mask, op: gfc_count) :
2092	simplify_transformation_to_array (result, array: mask, dim, mask, op: gfc_count, NULL);
2093	}
2094
2095	/* Simplification routine for cshift. This works by copying the array
2096	expressions into a one-dimensional array, shuffling the values into another
2097	one-dimensional array and creating the new array expression from this. The
2098	shuffling part is basically taken from the library routine. */
2099
2100	gfc_expr *
2101	gfc_simplify_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
2102	{
2103	gfc_expr *result;
2104	int which;
2105	gfc_expr **arrayvec, **resultvec;
2106	gfc_expr **rptr, **sptr;
2107	mpz_t size;
2108	size_t arraysize, shiftsize, i;
2109	gfc_constructor *array_ctor, *shift_ctor;
2110	ssize_t *shiftvec, *hptr;
2111	ssize_t shift_val, len;
2112	ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
2113	hs_ex[GFC_MAX_DIMENSIONS + 1],
2114	hstride[GFC_MAX_DIMENSIONS], sstride[GFC_MAX_DIMENSIONS],
2115	a_extent[GFC_MAX_DIMENSIONS], a_stride[GFC_MAX_DIMENSIONS],
2116	h_extent[GFC_MAX_DIMENSIONS],
2117	ss_ex[GFC_MAX_DIMENSIONS + 1];
2118	ssize_t rsoffset;
2119	int d, n;
2120	bool continue_loop;
2121	gfc_expr **src, **dest;
2122
2123	if (!is_constant_array_expr (e: array))
2124	return NULL;
2125
2126	if (shift->rank > 0)
2127	gfc_simplify_expr (shift, 1);
2128
2129	if (!gfc_is_constant_expr (shift))
2130	return NULL;
2131
2132	/* Make dim zero-based. */
2133	if (dim)
2134	{
2135	if (!gfc_is_constant_expr (dim))
2136	return NULL;
2137	which = mpz_get_si (dim->value.integer) - 1;
2138	}
2139	else
2140	which = 0;
2141
2142	if (array->shape == NULL)
2143	return NULL;
2144
2145	gfc_array_size (array, &size);
2146	arraysize = mpz_get_ui (gmp_z: size);
2147	mpz_clear (size);
2148
2149	result = gfc_get_array_expr (type: array->ts.type, kind: array->ts.kind, &array->where);
2150	result->shape = gfc_copy_shape (array->shape, array->rank);
2151	result->rank = array->rank;
2152	result->ts.u.derived = array->ts.u.derived;
2153
2154	if (arraysize == 0)
2155	return result;
2156
2157	arrayvec = XCNEWVEC (gfc_expr *, arraysize);
2158	array_ctor = gfc_constructor_first (base: array->value.constructor);
2159	for (i = 0; i < arraysize; i++)
2160	{
2161	arrayvec[i] = array_ctor->expr;
2162	array_ctor = gfc_constructor_next (ctor: array_ctor);
2163	}
2164
2165	resultvec = XCNEWVEC (gfc_expr *, arraysize);
2166
2167	sstride[0] = 0;
2168	extent[0] = 1;
2169	count[0] = 0;
2170
2171	for (d=0; d < array->rank; d++)
2172	{
2173	a_extent[d] = mpz_get_si (array->shape[d]);
2174	a_stride[d] = d == 0 ? 1 : a_stride[d-1] * a_extent[d-1];
2175	}
2176
2177	if (shift->rank > 0)
2178	{
2179	gfc_array_size (shift, &size);
2180	shiftsize = mpz_get_ui (gmp_z: size);
2181	mpz_clear (size);
2182	shiftvec = XCNEWVEC (ssize_t, shiftsize);
2183	shift_ctor = gfc_constructor_first (base: shift->value.constructor);
2184	for (d = 0; d < shift->rank; d++)
2185	{
2186	h_extent[d] = mpz_get_si (shift->shape[d]);
2187	hstride[d] = d == 0 ? 1 : hstride[d-1] * h_extent[d-1];
2188	}
2189	}
2190	else
2191	shiftvec = NULL;
2192
2193	/* Shut up compiler */
2194	len = 1;
2195	rsoffset = 1;
2196
2197	n = 0;
2198	for (d=0; d < array->rank; d++)
2199	{
2200	if (d == which)
2201	{
2202	rsoffset = a_stride[d];
2203	len = a_extent[d];
2204	}
2205	else
2206	{
2207	count[n] = 0;
2208	extent[n] = a_extent[d];
2209	sstride[n] = a_stride[d];
2210	ss_ex[n] = sstride[n] * extent[n];
2211	if (shiftvec)
2212	hs_ex[n] = hstride[n] * extent[n];
2213	n++;
2214	}
2215	}
2216	ss_ex[n] = 0;
2217	hs_ex[n] = 0;
2218
2219	if (shiftvec)
2220	{
2221	for (i = 0; i < shiftsize; i++)
2222	{
2223	ssize_t val;
2224	val = mpz_get_si (shift_ctor->expr->value.integer);
2225	val = val % len;
2226	if (val < 0)
2227	val += len;
2228	shiftvec[i] = val;
2229	shift_ctor = gfc_constructor_next (ctor: shift_ctor);
2230	}
2231	shift_val = 0;
2232	}
2233	else
2234	{
2235	shift_val = mpz_get_si (shift->value.integer);
2236	shift_val = shift_val % len;
2237	if (shift_val < 0)
2238	shift_val += len;
2239	}
2240
2241	continue_loop = true;
2242	d = array->rank;
2243	rptr = resultvec;
2244	sptr = arrayvec;
2245	hptr = shiftvec;
2246
2247	while (continue_loop)
2248	{
2249	ssize_t sh;
2250	if (shiftvec)
2251	sh = *hptr;
2252	else
2253	sh = shift_val;
2254
2255	src = &sptr[sh * rsoffset];
2256	dest = rptr;
2257	for (n = 0; n < len - sh; n++)
2258	{
2259	*dest = *src;
2260	dest += rsoffset;
2261	src += rsoffset;
2262	}
2263	src = sptr;
2264	for ( n = 0; n < sh; n++)
2265	{
2266	*dest = *src;
2267	dest += rsoffset;
2268	src += rsoffset;
2269	}
2270	rptr += sstride[0];
2271	sptr += sstride[0];
2272	if (shiftvec)
2273	hptr += hstride[0];
2274	count[0]++;
2275	n = 0;
2276	while (count[n] == extent[n])
2277	{
2278	count[n] = 0;
2279	rptr -= ss_ex[n];
2280	sptr -= ss_ex[n];
2281	if (shiftvec)
2282	hptr -= hs_ex[n];
2283	n++;
2284	if (n >= d - 1)
2285	{
2286	continue_loop = false;
2287	break;
2288	}
2289	else
2290	{
2291	count[n]++;
2292	rptr += sstride[n];
2293	sptr += sstride[n];
2294	if (shiftvec)
2295	hptr += hstride[n];
2296	}
2297	}
2298	}
2299
2300	for (i = 0; i < arraysize; i++)
2301	{
2302	gfc_constructor_append_expr (base: &result->value.constructor,
2303	e: gfc_copy_expr (resultvec[i]),
2304	NULL);
2305	}
2306	return result;
2307	}
2308
2309
2310	gfc_expr *
2311	gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
2312	{
2313	return simplify_cmplx (name: "DCMPLX", x, y, kind: gfc_default_double_kind);
2314	}
2315
2316
2317	gfc_expr *
2318	gfc_simplify_dble (gfc_expr *e)
2319	{
2320	gfc_expr *result = NULL;
2321	int tmp1, tmp2;
2322
2323	if (e->expr_type != EXPR_CONSTANT)
2324	return NULL;
2325
2326	/* For explicit conversion, turn off -Wconversion and -Wconversion-extra
2327	warnings. */
2328	tmp1 = warn_conversion;
2329	tmp2 = warn_conversion_extra;
2330	warn_conversion = warn_conversion_extra = 0;
2331
2332	result = gfc_convert_constant (e, BT_REAL, gfc_default_double_kind);
2333
2334	warn_conversion = tmp1;
2335	warn_conversion_extra = tmp2;
2336
2337	if (result == &gfc_bad_expr)
2338	return &gfc_bad_expr;
2339
2340	return range_check (result, name: "DBLE");
2341	}
2342
2343
2344	gfc_expr *
2345	gfc_simplify_digits (gfc_expr *x)
2346	{
2347	int i, digits;
2348
2349	i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
2350
2351	switch (x->ts.type)
2352	{
2353	case BT_INTEGER:
2354	digits = gfc_integer_kinds[i].digits;
2355	break;
2356
2357	case BT_REAL:
2358	case BT_COMPLEX:
2359	digits = gfc_real_kinds[i].digits;
2360	break;
2361
2362	default:
2363	gcc_unreachable ();
2364	}
2365
2366	return gfc_get_int_expr (gfc_default_integer_kind, NULL, digits);
2367	}
2368
2369
2370	gfc_expr *
2371	gfc_simplify_dim (gfc_expr *x, gfc_expr *y)
2372	{
2373	gfc_expr *result;
2374	int kind;
2375
2376	if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2377	return NULL;
2378
2379	kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
2380	result = gfc_get_constant_expr (x->ts.type, kind, &x->where);
2381
2382	switch (x->ts.type)
2383	{
2384	case BT_INTEGER:
2385	if (mpz_cmp (x->value.integer, y->value.integer) > 0)
2386	mpz_sub (result->value.integer, x->value.integer, y->value.integer);
2387	else
2388	mpz_set_ui (result->value.integer, 0);
2389
2390	break;
2391
2392	case BT_REAL:
2393	if (mpfr_cmp (x->value.real, y->value.real) > 0)
2394	mpfr_sub (result->value.real, x->value.real, y->value.real,
2395	GFC_RND_MODE);
2396	else
2397	mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2398
2399	break;
2400
2401	default:
2402	gfc_internal_error ("gfc_simplify_dim(): Bad type");
2403	}
2404
2405	return range_check (result, name: "DIM");
2406	}
2407
2408
2409	gfc_expr*
2410	gfc_simplify_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
2411	{
2412	/* If vector_a is a zero-sized array, the result is 0 for INTEGER,
2413	REAL, and COMPLEX types and .false. for LOGICAL. */
2414	if (vector_a->shape && mpz_get_si (vector_a->shape[0]) == 0)
2415	{
2416	if (vector_a->ts.type == BT_LOGICAL)
2417	return gfc_get_logical_expr (gfc_default_logical_kind, NULL, false);
2418	else
2419	return gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2420	}
2421
2422	if (!is_constant_array_expr (e: vector_a)
2423	|| !is_constant_array_expr (e: vector_b))
2424	return NULL;
2425
2426	return compute_dot_product (matrix_a: vector_a, stride_a: 1, offset_a: 0, matrix_b: vector_b, stride_b: 1, offset_b: 0, conj_a: true);
2427	}
2428
2429
2430	gfc_expr *
2431	gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
2432	{
2433	gfc_expr *a1, *a2, *result;
2434
2435	if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2436	return NULL;
2437
2438	a1 = gfc_real2real (x, gfc_default_double_kind);
2439	a2 = gfc_real2real (y, gfc_default_double_kind);
2440
2441	result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &x->where);
2442	mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE);
2443
2444	gfc_free_expr (a2);
2445	gfc_free_expr (a1);
2446
2447	return range_check (result, name: "DPROD");
2448	}
2449
2450
2451	static gfc_expr *
2452	simplify_dshift (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg,
2453	bool right)
2454	{
2455	gfc_expr *result;
2456	int i, k, size, shift;
2457
2458	if (arg1->expr_type != EXPR_CONSTANT || arg2->expr_type != EXPR_CONSTANT
2459	|| shiftarg->expr_type != EXPR_CONSTANT)
2460	return NULL;
2461
2462	k = gfc_validate_kind (BT_INTEGER, arg1->ts.kind, false);
2463	size = gfc_integer_kinds[k].bit_size;
2464
2465	gfc_extract_int (shiftarg, &shift);
2466
2467	/* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT). */
2468	if (right)
2469	shift = size - shift;
2470
2471	result = gfc_get_constant_expr (BT_INTEGER, arg1->ts.kind, &arg1->where);
2472	mpz_set_ui (result->value.integer, 0);
2473
2474	for (i = 0; i < shift; i++)
2475	if (mpz_tstbit (arg2->value.integer, size - shift + i))
2476	mpz_setbit (result->value.integer, i);
2477
2478	for (i = 0; i < size - shift; i++)
2479	if (mpz_tstbit (arg1->value.integer, i))
2480	mpz_setbit (result->value.integer, shift + i);
2481
2482	/* Convert to a signed value. */
2483	gfc_convert_mpz_to_signed (x: result->value.integer, bitsize: size);
2484
2485	return result;
2486	}
2487
2488
2489	gfc_expr *
2490	gfc_simplify_dshiftr (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg)
2491	{
2492	return simplify_dshift (arg1, arg2, shiftarg, right: true);
2493	}
2494
2495
2496	gfc_expr *
2497	gfc_simplify_dshiftl (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg)
2498	{
2499	return simplify_dshift (arg1, arg2, shiftarg, right: false);
2500	}
2501
2502
2503	gfc_expr *
2504	gfc_simplify_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
2505	gfc_expr *dim)
2506	{
2507	bool temp_boundary;
2508	gfc_expr *bnd;
2509	gfc_expr *result;
2510	int which;
2511	gfc_expr **arrayvec, **resultvec;
2512	gfc_expr **rptr, **sptr;
2513	mpz_t size;
2514	size_t arraysize, i;
2515	gfc_constructor *array_ctor, *shift_ctor, *bnd_ctor;
2516	ssize_t shift_val, len;
2517	ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
2518	sstride[GFC_MAX_DIMENSIONS], a_extent[GFC_MAX_DIMENSIONS],
2519	a_stride[GFC_MAX_DIMENSIONS], ss_ex[GFC_MAX_DIMENSIONS + 1];
2520	ssize_t rsoffset;
2521	int d, n;
2522	bool continue_loop;
2523	gfc_expr **src, **dest;
2524	size_t s_len;
2525
2526	if (!is_constant_array_expr (e: array))
2527	return NULL;
2528
2529	if (shift->rank > 0)
2530	gfc_simplify_expr (shift, 1);
2531
2532	if (!gfc_is_constant_expr (shift))
2533	return NULL;
2534
2535	if (boundary)
2536	{
2537	if (boundary->rank > 0)
2538	gfc_simplify_expr (boundary, 1);
2539
2540	if (!gfc_is_constant_expr (boundary))
2541	return NULL;
2542	}
2543
2544	if (dim)
2545	{
2546	if (!gfc_is_constant_expr (dim))
2547	return NULL;
2548	which = mpz_get_si (dim->value.integer) - 1;
2549	}
2550	else
2551	which = 0;
2552
2553	s_len = 0;
2554	if (boundary == NULL)
2555	{
2556	temp_boundary = true;
2557	switch (array->ts.type)
2558	{
2559
2560	case BT_INTEGER:
2561	bnd = gfc_get_int_expr (array->ts.kind, NULL, 0);
2562	break;
2563
2564	case BT_LOGICAL:
2565	bnd = gfc_get_logical_expr (array->ts.kind, NULL, 0);
2566	break;
2567
2568	case BT_REAL:
2569	bnd = gfc_get_constant_expr (array->ts.type, array->ts.kind, &gfc_current_locus);
2570	mpfr_set_ui (bnd->value.real, 0, GFC_RND_MODE);
2571	break;
2572
2573	case BT_COMPLEX:
2574	bnd = gfc_get_constant_expr (array->ts.type, array->ts.kind, &gfc_current_locus);
2575	mpc_set_ui (bnd->value.complex, 0, GFC_RND_MODE);
2576	break;
2577
2578	case BT_CHARACTER:
2579	s_len = mpz_get_ui (gmp_z: array->ts.u.cl->length->value.integer);
2580	bnd = gfc_get_character_expr (array->ts.kind, &gfc_current_locus, NULL, len: s_len);
2581	break;
2582
2583	default:
2584	gcc_unreachable();
2585
2586	}
2587	}
2588	else
2589	{
2590	temp_boundary = false;
2591	bnd = boundary;
2592	}
2593
2594	gfc_array_size (array, &size);
2595	arraysize = mpz_get_ui (gmp_z: size);
2596	mpz_clear (size);
2597
2598	result = gfc_get_array_expr (type: array->ts.type, kind: array->ts.kind, &array->where);
2599	result->shape = gfc_copy_shape (array->shape, array->rank);
2600	result->rank = array->rank;
2601	result->ts = array->ts;
2602
2603	if (arraysize == 0)
2604	goto final;
2605
2606	if (array->shape == NULL)
2607	goto final;
2608
2609	arrayvec = XCNEWVEC (gfc_expr *, arraysize);
2610	array_ctor = gfc_constructor_first (base: array->value.constructor);
2611	for (i = 0; i < arraysize; i++)
2612	{
2613	arrayvec[i] = array_ctor->expr;
2614	array_ctor = gfc_constructor_next (ctor: array_ctor);
2615	}
2616
2617	resultvec = XCNEWVEC (gfc_expr *, arraysize);
2618
2619	extent[0] = 1;
2620	count[0] = 0;
2621
2622	for (d=0; d < array->rank; d++)
2623	{
2624	a_extent[d] = mpz_get_si (array->shape[d]);
2625	a_stride[d] = d == 0 ? 1 : a_stride[d-1] * a_extent[d-1];
2626	}
2627
2628	if (shift->rank > 0)
2629	{
2630	shift_ctor = gfc_constructor_first (base: shift->value.constructor);
2631	shift_val = 0;
2632	}
2633	else
2634	{
2635	shift_ctor = NULL;
2636	shift_val = mpz_get_si (shift->value.integer);
2637	}
2638
2639	if (bnd->rank > 0)
2640	bnd_ctor = gfc_constructor_first (base: bnd->value.constructor);
2641	else
2642	bnd_ctor = NULL;
2643
2644	/* Shut up compiler */
2645	len = 1;
2646	rsoffset = 1;
2647
2648	n = 0;
2649	for (d=0; d < array->rank; d++)
2650	{
2651	if (d == which)
2652	{
2653	rsoffset = a_stride[d];
2654	len = a_extent[d];
2655	}
2656	else
2657	{
2658	count[n] = 0;
2659	extent[n] = a_extent[d];
2660	sstride[n] = a_stride[d];
2661	ss_ex[n] = sstride[n] * extent[n];
2662	n++;
2663	}
2664	}
2665	ss_ex[n] = 0;
2666
2667	continue_loop = true;
2668	d = array->rank;
2669	rptr = resultvec;
2670	sptr = arrayvec;
2671
2672	while (continue_loop)
2673	{
2674	ssize_t sh, delta;
2675
2676	if (shift_ctor)
2677	sh = mpz_get_si (shift_ctor->expr->value.integer);
2678	else
2679	sh = shift_val;
2680
2681	if (( sh >= 0 ? sh : -sh ) > len)
2682	{
2683	delta = len;
2684	sh = len;
2685	}
2686	else
2687	delta = (sh >= 0) ? sh: -sh;
2688
2689	if (sh > 0)
2690	{
2691	src = &sptr[delta * rsoffset];
2692	dest = rptr;
2693	}
2694	else
2695	{
2696	src = sptr;
2697	dest = &rptr[delta * rsoffset];
2698	}
2699
2700	for (n = 0; n < len - delta; n++)
2701	{
2702	*dest = *src;
2703	dest += rsoffset;
2704	src += rsoffset;
2705	}
2706
2707	if (sh < 0)
2708	dest = rptr;
2709
2710	n = delta;
2711
2712	if (bnd_ctor)
2713	{
2714	while (n--)
2715	{
2716	*dest = gfc_copy_expr (bnd_ctor->expr);
2717	dest += rsoffset;
2718	}
2719	}
2720	else
2721	{
2722	while (n--)
2723	{
2724	*dest = gfc_copy_expr (bnd);
2725	dest += rsoffset;
2726	}
2727	}
2728	rptr += sstride[0];
2729	sptr += sstride[0];
2730	if (shift_ctor)
2731	shift_ctor = gfc_constructor_next (ctor: shift_ctor);
2732
2733	if (bnd_ctor)
2734	bnd_ctor = gfc_constructor_next (ctor: bnd_ctor);
2735
2736	count[0]++;
2737	n = 0;
2738	while (count[n] == extent[n])
2739	{
2740	count[n] = 0;
2741	rptr -= ss_ex[n];
2742	sptr -= ss_ex[n];
2743	n++;
2744	if (n >= d - 1)
2745	{
2746	continue_loop = false;
2747	break;
2748	}
2749	else
2750	{
2751	count[n]++;
2752	rptr += sstride[n];
2753	sptr += sstride[n];
2754	}
2755	}
2756	}
2757
2758	for (i = 0; i < arraysize; i++)
2759	{
2760	gfc_constructor_append_expr (base: &result->value.constructor,
2761	e: gfc_copy_expr (resultvec[i]),
2762	NULL);
2763	}
2764
2765	final:
2766	if (temp_boundary)
2767	gfc_free_expr (bnd);
2768
2769	return result;
2770	}
2771
2772	gfc_expr *
2773	gfc_simplify_erf (gfc_expr *x)
2774	{
2775	gfc_expr *result;
2776
2777	if (x->expr_type != EXPR_CONSTANT)
2778	return NULL;
2779
2780	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2781	mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE);
2782
2783	return range_check (result, name: "ERF");
2784	}
2785
2786
2787	gfc_expr *
2788	gfc_simplify_erfc (gfc_expr *x)
2789	{
2790	gfc_expr *result;
2791
2792	if (x->expr_type != EXPR_CONSTANT)
2793	return NULL;
2794
2795	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2796	mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE);
2797
2798	return range_check (result, name: "ERFC");
2799	}
2800
2801
2802	/* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2). */
2803
2804	#define MAX_ITER 200
2805	#define ARG_LIMIT 12
2806
2807	/* Calculate ERFC_SCALED directly by its definition:
2808
2809	ERFC_SCALED(x) = ERFC(x) * EXP(X**2)
2810
2811	using a large precision for intermediate results. This is used for all
2812	but large values of the argument. */
2813	static void
2814	fullprec_erfc_scaled (mpfr_t res, mpfr_t arg)
2815	{
2816	mpfr_prec_t prec;
2817	mpfr_t a, b;
2818
2819	prec = mpfr_get_default_prec ();
2820	mpfr_set_default_prec (10 * prec);
2821
2822	mpfr_init (a);
2823	mpfr_init (b);
2824
2825	mpfr_set (a, arg, GFC_RND_MODE);
2826	mpfr_sqr (b, a, GFC_RND_MODE);
2827	mpfr_exp (b, b, GFC_RND_MODE);
2828	mpfr_erfc (a, a, GFC_RND_MODE);
2829	mpfr_mul (a, a, b, GFC_RND_MODE);
2830
2831	mpfr_set (res, a, GFC_RND_MODE);
2832	mpfr_set_default_prec (prec);
2833
2834	mpfr_clear (a);
2835	mpfr_clear (b);
2836	}
2837
2838	/* Calculate ERFC_SCALED using a power series expansion in 1/arg:
2839
2840	ERFC_SCALED(x) = 1 / (x * sqrt(pi))
2841	* (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))
2842	/ (2 * x**2)**n)
2843
2844	This is used for large values of the argument. Intermediate calculations
2845	are performed with twice the precision. We don't do a fixed number of
2846	iterations of the sum, but stop when it has converged to the required
2847	precision. */
2848	static void
2849	asympt_erfc_scaled (mpfr_t res, mpfr_t arg)
2850	{
2851	mpfr_t sum, x, u, v, w, oldsum, sumtrunc;
2852	mpz_t num;
2853	mpfr_prec_t prec;
2854	unsigned i;
2855
2856	prec = mpfr_get_default_prec ();
2857	mpfr_set_default_prec (2 * prec);
2858
2859	mpfr_init (sum);
2860	mpfr_init (x);
2861	mpfr_init (u);
2862	mpfr_init (v);
2863	mpfr_init (w);
2864	mpz_init (num);
2865
2866	mpfr_init (oldsum);
2867	mpfr_init (sumtrunc);
2868	mpfr_set_prec (oldsum, prec);
2869	mpfr_set_prec (sumtrunc, prec);
2870
2871	mpfr_set (x, arg, GFC_RND_MODE);
2872	mpfr_set_ui (sum, 1, GFC_RND_MODE);
2873	mpz_set_ui (num, 1);
2874
2875	mpfr_set (u, x, GFC_RND_MODE);
2876	mpfr_sqr (u, u, GFC_RND_MODE);
2877	mpfr_mul_ui (u, u, 2, GFC_RND_MODE);
2878	mpfr_pow_si (u, u, -1, GFC_RND_MODE);
2879
2880	for (i = 1; i < MAX_ITER; i++)
2881	{
2882	mpfr_set (oldsum, sum, GFC_RND_MODE);
2883
2884	mpz_mul_ui (num, num, 2 * i - 1);
2885	mpz_neg (gmp_w: num, gmp_u: num);
2886
2887	mpfr_set (w, u, GFC_RND_MODE);
2888	mpfr_pow_ui (w, w, i, GFC_RND_MODE);
2889
2890	mpfr_set_z (v, num, GFC_RND_MODE);
2891	mpfr_mul (v, v, w, GFC_RND_MODE);
2892
2893	mpfr_add (sum, sum, v, GFC_RND_MODE);
2894
2895	mpfr_set (sumtrunc, sum, GFC_RND_MODE);
2896	if (mpfr_cmp (sumtrunc, oldsum) == 0)
2897	break;
2898	}
2899
2900	/* We should have converged by now; otherwise, ARG_LIMIT is probably
2901	set too low. */
2902	gcc_assert (i < MAX_ITER);
2903
2904	/* Divide by x * sqrt(Pi). */
2905	mpfr_const_pi (u, GFC_RND_MODE);
2906	mpfr_sqrt (u, u, GFC_RND_MODE);
2907	mpfr_mul (u, u, x, GFC_RND_MODE);
2908	mpfr_div (sum, sum, u, GFC_RND_MODE);
2909
2910	mpfr_set (res, sum, GFC_RND_MODE);
2911	mpfr_set_default_prec (prec);
2912
2913	mpfr_clears (sum, x, u, v, w, oldsum, sumtrunc, NULL);
2914	mpz_clear (num);
2915	}
2916
2917
2918	gfc_expr *
2919	gfc_simplify_erfc_scaled (gfc_expr *x)
2920	{
2921	gfc_expr *result;
2922
2923	if (x->expr_type != EXPR_CONSTANT)
2924	return NULL;
2925
2926	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2927	if (mpfr_cmp_d (x->value.real, ARG_LIMIT) >= 0)
2928	asympt_erfc_scaled (res: result->value.real, arg: x->value.real);
2929	else
2930	fullprec_erfc_scaled (res: result->value.real, arg: x->value.real);
2931
2932	return range_check (result, name: "ERFC_SCALED");
2933	}
2934
2935	#undef MAX_ITER
2936	#undef ARG_LIMIT
2937
2938
2939	gfc_expr *
2940	gfc_simplify_epsilon (gfc_expr *e)
2941	{
2942	gfc_expr *result;
2943	int i;
2944
2945	i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2946
2947	result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
2948	mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE);
2949
2950	return range_check (result, name: "EPSILON");
2951	}
2952
2953
2954	gfc_expr *
2955	gfc_simplify_exp (gfc_expr *x)
2956	{
2957	gfc_expr *result;
2958
2959	if (x->expr_type != EXPR_CONSTANT)
2960	return NULL;
2961
2962	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2963
2964	switch (x->ts.type)
2965	{
2966	case BT_REAL:
2967	mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE);
2968	break;
2969
2970	case BT_COMPLEX:
2971	gfc_set_model_kind (x->ts.kind);
2972	mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
2973	break;
2974
2975	default:
2976	gfc_internal_error ("in gfc_simplify_exp(): Bad type");
2977	}
2978
2979	return range_check (result, name: "EXP");
2980	}
2981
2982
2983	gfc_expr *
2984	gfc_simplify_exponent (gfc_expr *x)
2985	{
2986	long int val;
2987	gfc_expr *result;
2988
2989	if (x->expr_type != EXPR_CONSTANT)
2990	return NULL;
2991
2992	result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
2993	&x->where);
2994
2995	/* EXPONENT(inf) = EXPONENT(nan) = HUGE(0) */
2996	if (mpfr_inf_p (x->value.real) || mpfr_nan_p (x->value.real))
2997	{
2998	int i = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false);
2999	mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
3000	return result;
3001	}
3002
3003	/* EXPONENT(+/- 0.0) = 0 */
3004	if (mpfr_zero_p (x->value.real))
3005	{
3006	mpz_set_ui (result->value.integer, 0);
3007	return result;
3008	}
3009
3010	gfc_set_model (x->value.real);
3011
3012	val = (long int) mpfr_get_exp (x->value.real);
3013	mpz_set_si (result->value.integer, val);
3014
3015	return range_check (result, name: "EXPONENT");
3016	}
3017
3018
3019	gfc_expr *
3020	gfc_simplify_failed_or_stopped_images (gfc_expr *team ATTRIBUTE_UNUSED,
3021	gfc_expr *kind)
3022	{
3023	if (flag_coarray == GFC_FCOARRAY_NONE)
3024	{
3025	gfc_current_locus = *gfc_current_intrinsic_where;
3026	gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3027	return &gfc_bad_expr;
3028	}
3029
3030	if (flag_coarray == GFC_FCOARRAY_SINGLE)
3031	{
3032	gfc_expr *result;
3033	int actual_kind;
3034	if (kind)
3035	gfc_extract_int (kind, &actual_kind);
3036	else
3037	actual_kind = gfc_default_integer_kind;
3038
3039	result = gfc_get_array_expr (type: BT_INTEGER, kind: actual_kind, &gfc_current_locus);
3040	result->rank = 1;
3041	return result;
3042	}
3043
3044	/* For fcoarray = lib no simplification is possible, because it is not known
3045	what images failed or are stopped at compile time. */
3046	return NULL;
3047	}
3048
3049
3050	gfc_expr *
3051	gfc_simplify_get_team (gfc_expr *level ATTRIBUTE_UNUSED)
3052	{
3053	if (flag_coarray == GFC_FCOARRAY_NONE)
3054	{
3055	gfc_current_locus = *gfc_current_intrinsic_where;
3056	gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3057	return &gfc_bad_expr;
3058	}
3059
3060	if (flag_coarray == GFC_FCOARRAY_SINGLE)
3061	{
3062	gfc_expr *result;
3063	result = gfc_get_array_expr (type: BT_INTEGER, kind: gfc_default_integer_kind, &gfc_current_locus);
3064	result->rank = 0;
3065	return result;
3066	}
3067
3068	/* For fcoarray = lib no simplification is possible, because it is not known
3069	what images failed or are stopped at compile time. */
3070	return NULL;
3071	}
3072
3073
3074	gfc_expr *
3075	gfc_simplify_float (gfc_expr *a)
3076	{
3077	gfc_expr *result;
3078
3079	if (a->expr_type != EXPR_CONSTANT)
3080	return NULL;
3081
3082	result = gfc_int2real (a, gfc_default_real_kind);
3083
3084	return range_check (result, name: "FLOAT");
3085	}
3086
3087
3088	static bool
3089	is_last_ref_vtab (gfc_expr *e)
3090	{
3091	gfc_ref *ref;
3092	gfc_component *comp = NULL;
3093
3094	if (e->expr_type != EXPR_VARIABLE)
3095	return false;
3096
3097	for (ref = e->ref; ref; ref = ref->next)
3098	if (ref->type == REF_COMPONENT)
3099	comp = ref->u.c.component;
3100
3101	if (!e->ref || !comp)
3102	return e->symtree->n.sym->attr.vtab;
3103
3104	if (comp->name[0] == '_' && strcmp (s1: comp->name, s2: "_vptr") == 0)
3105	return true;
3106
3107	return false;
3108	}
3109
3110
3111	gfc_expr *
3112	gfc_simplify_extends_type_of (gfc_expr *a, gfc_expr *mold)
3113	{
3114	/* Avoid simplification of resolved symbols. */
3115	if (is_last_ref_vtab (e: a) || is_last_ref_vtab (e: mold))
3116	return NULL;
3117
3118	if (a->ts.type == BT_DERIVED && mold->ts.type == BT_DERIVED)
3119	return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3120	gfc_type_is_extension_of (mold->ts.u.derived,
3121	a->ts.u.derived));
3122
3123	if (UNLIMITED_POLY (a) || UNLIMITED_POLY (mold))
3124	return NULL;
3125
3126	if ((a->ts.type == BT_CLASS && !gfc_expr_attr (a).class_ok)
3127	|| (mold->ts.type == BT_CLASS && !gfc_expr_attr (mold).class_ok))
3128	return NULL;
3129
3130	/* Return .false. if the dynamic type can never be an extension. */
3131	if ((a->ts.type == BT_CLASS && mold->ts.type == BT_CLASS
3132	&& !gfc_type_is_extension_of
3133	(CLASS_DATA (mold)->ts.u.derived,
3134	CLASS_DATA (a)->ts.u.derived)
3135	&& !gfc_type_is_extension_of
3136	(CLASS_DATA (a)->ts.u.derived,
3137	CLASS_DATA (mold)->ts.u.derived))
3138	|| (a->ts.type == BT_DERIVED && mold->ts.type == BT_CLASS
3139	&& !gfc_type_is_extension_of
3140	(CLASS_DATA (mold)->ts.u.derived,
3141	a->ts.u.derived))
3142	|| (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED
3143	&& !gfc_type_is_extension_of
3144	(mold->ts.u.derived,
3145	CLASS_DATA (a)->ts.u.derived)
3146	&& !gfc_type_is_extension_of
3147	(CLASS_DATA (a)->ts.u.derived,
3148	mold->ts.u.derived)))
3149	return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
3150
3151	/* Return .true. if the dynamic type is guaranteed to be an extension. */
3152	if (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED
3153	&& gfc_type_is_extension_of (mold->ts.u.derived,
3154	CLASS_DATA (a)->ts.u.derived))
3155	return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, true);
3156
3157	return NULL;
3158	}
3159
3160
3161	gfc_expr *
3162	gfc_simplify_same_type_as (gfc_expr *a, gfc_expr *b)
3163	{
3164	/* Avoid simplification of resolved symbols. */
3165	if (is_last_ref_vtab (e: a) || is_last_ref_vtab (e: b))
3166	return NULL;
3167
3168	/* Return .false. if the dynamic type can never be the
3169	same. */
3170	if (((a->ts.type == BT_CLASS && gfc_expr_attr (a).class_ok)
3171	|| (b->ts.type == BT_CLASS && gfc_expr_attr (b).class_ok))
3172	&& !gfc_type_compatible (&a->ts, &b->ts)
3173	&& !gfc_type_compatible (&b->ts, &a->ts))
3174	return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
3175
3176	if (a->ts.type != BT_DERIVED || b->ts.type != BT_DERIVED)
3177	return NULL;
3178
3179	return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3180	gfc_compare_derived_types (a->ts.u.derived,
3181	b->ts.u.derived));
3182	}
3183
3184
3185	gfc_expr *
3186	gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
3187	{
3188	gfc_expr *result;
3189	mpfr_t floor;
3190	int kind;
3191
3192	kind = get_kind (type: BT_INTEGER, k, name: "FLOOR", default_kind: gfc_default_integer_kind);
3193	if (kind == -1)
3194	gfc_internal_error ("gfc_simplify_floor(): Bad kind");
3195
3196	if (e->expr_type != EXPR_CONSTANT)
3197	return NULL;
3198
3199	mpfr_init2 (floor, mpfr_get_prec (e->value.real));
3200	mpfr_floor (floor, e->value.real);
3201
3202	result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
3203	gfc_mpfr_to_mpz (result->value.integer, floor, &e->where);
3204
3205	mpfr_clear (floor);
3206
3207	return range_check (result, name: "FLOOR");
3208	}
3209
3210
3211	gfc_expr *
3212	gfc_simplify_fraction (gfc_expr *x)
3213	{
3214	gfc_expr *result;
3215	mpfr_exp_t e;
3216
3217	if (x->expr_type != EXPR_CONSTANT)
3218	return NULL;
3219
3220	result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
3221
3222	/* FRACTION(inf) = NaN. */
3223	if (mpfr_inf_p (x->value.real))
3224	{
3225	mpfr_set_nan (result->value.real);
3226	return result;
3227	}
3228
3229	/* mpfr_frexp() correctly handles zeros and NaNs. */
3230	mpfr_frexp (&e, result->value.real, x->value.real, GFC_RND_MODE);
3231
3232	return range_check (result, name: "FRACTION");
3233	}
3234
3235
3236	gfc_expr *
3237	gfc_simplify_gamma (gfc_expr *x)
3238	{
3239	gfc_expr *result;
3240
3241	if (x->expr_type != EXPR_CONSTANT)
3242	return NULL;
3243
3244	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3245	mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE);
3246
3247	return range_check (result, name: "GAMMA");
3248	}
3249
3250
3251	gfc_expr *
3252	gfc_simplify_huge (gfc_expr *e)
3253	{
3254	gfc_expr *result;
3255	int i;
3256
3257	i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3258	result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
3259
3260	switch (e->ts.type)
3261	{
3262	case BT_INTEGER:
3263	mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
3264	break;
3265
3266	case BT_REAL:
3267	mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
3268	break;
3269
3270	default:
3271	gcc_unreachable ();
3272	}
3273
3274	return result;
3275	}
3276
3277
3278	gfc_expr *
3279	gfc_simplify_hypot (gfc_expr *x, gfc_expr *y)
3280	{
3281	gfc_expr *result;
3282
3283	if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3284	return NULL;
3285
3286	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3287	mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE);
3288	return range_check (result, name: "HYPOT");
3289	}
3290
3291
3292	/* We use the processor's collating sequence, because all
3293	systems that gfortran currently works on are ASCII. */
3294
3295	gfc_expr *
3296	gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
3297	{
3298	gfc_expr *result;
3299	gfc_char_t index;
3300	int k;
3301
3302	if (e->expr_type != EXPR_CONSTANT)
3303	return NULL;
3304
3305	if (e->value.character.length != 1)
3306	{
3307	gfc_error ("Argument of IACHAR at %L must be of length one", &e->where);
3308	return &gfc_bad_expr;
3309	}
3310
3311	index = e->value.character.string[0];
3312
3313	if (warn_surprising && index > 127)
3314	gfc_warning (opt: OPT_Wsurprising,
3315	"Argument of IACHAR function at %L outside of range 0..127",
3316	&e->where);
3317
3318	k = get_kind (type: BT_INTEGER, k: kind, name: "IACHAR", default_kind: gfc_default_integer_kind);
3319	if (k == -1)
3320	return &gfc_bad_expr;
3321
3322	result = gfc_get_int_expr (k, &e->where, index);
3323
3324	return range_check (result, name: "IACHAR");
3325	}
3326
3327
3328	static gfc_expr *
3329	do_bit_and (gfc_expr *result, gfc_expr *e)
3330	{
3331	gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
3332	gcc_assert (result->ts.type == BT_INTEGER
3333	&& result->expr_type == EXPR_CONSTANT);
3334
3335	mpz_and (result->value.integer, result->value.integer, e->value.integer);
3336	return result;
3337	}
3338
3339
3340	gfc_expr *
3341	gfc_simplify_iall (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
3342	{
3343	return simplify_transformation (array, dim, mask, init_val: -1, op: do_bit_and);
3344	}
3345
3346
3347	static gfc_expr *
3348	do_bit_ior (gfc_expr *result, gfc_expr *e)
3349	{
3350	gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
3351	gcc_assert (result->ts.type == BT_INTEGER
3352	&& result->expr_type == EXPR_CONSTANT);
3353
3354	mpz_ior (result->value.integer, result->value.integer, e->value.integer);
3355	return result;
3356	}
3357
3358
3359	gfc_expr *
3360	gfc_simplify_iany (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
3361	{
3362	return simplify_transformation (array, dim, mask, init_val: 0, op: do_bit_ior);
3363	}
3364
3365
3366	gfc_expr *
3367	gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
3368	{
3369	gfc_expr *result;
3370
3371	if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3372	return NULL;
3373
3374	result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
3375	mpz_and (result->value.integer, x->value.integer, y->value.integer);
3376
3377	return range_check (result, name: "IAND");
3378	}
3379
3380
3381	gfc_expr *
3382	gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
3383	{
3384	gfc_expr *result;
3385	int k, pos;
3386
3387	if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3388	return NULL;
3389
3390	if (!gfc_check_bitfcn (x, y))
3391	return &gfc_bad_expr;
3392
3393	gfc_extract_int (y, &pos);
3394
3395	k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3396
3397	result = gfc_copy_expr (x);
3398	/* Drop any separate memory representation of x to avoid potential
3399	inconsistencies in result. */
3400	if (result->representation.string)
3401	{
3402	free (ptr: result->representation.string);
3403	result->representation.string = NULL;
3404	}
3405
3406	convert_mpz_to_unsigned (x: result->value.integer,
3407	bitsize: gfc_integer_kinds[k].bit_size);
3408
3409	mpz_clrbit (result->value.integer, pos);
3410
3411	gfc_convert_mpz_to_signed (x: result->value.integer,
3412	bitsize: gfc_integer_kinds[k].bit_size);
3413
3414	return result;
3415	}
3416
3417
3418	gfc_expr *
3419	gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
3420	{
3421	gfc_expr *result;
3422	int pos, len;
3423	int i, k, bitsize;
3424	int *bits;
3425
3426	if (x->expr_type != EXPR_CONSTANT
3427	|| y->expr_type != EXPR_CONSTANT
3428	|| z->expr_type != EXPR_CONSTANT)
3429	return NULL;
3430
3431	if (!gfc_check_ibits (x, y, z))
3432	return &gfc_bad_expr;
3433
3434	gfc_extract_int (y, &pos);
3435	gfc_extract_int (z, &len);
3436
3437	k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
3438
3439	bitsize = gfc_integer_kinds[k].bit_size;
3440
3441	if (pos + len > bitsize)
3442	{
3443	gfc_error ("Sum of second and third arguments of IBITS exceeds "
3444	"bit size at %L", &y->where);
3445	return &gfc_bad_expr;
3446	}
3447
3448	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3449	convert_mpz_to_unsigned (x: result->value.integer,
3450	bitsize: gfc_integer_kinds[k].bit_size);
3451
3452	bits = XCNEWVEC (int, bitsize);
3453
3454	for (i = 0; i < bitsize; i++)
3455	bits[i] = 0;
3456
3457	for (i = 0; i < len; i++)
3458	bits[i] = mpz_tstbit (x->value.integer, i + pos);
3459
3460	for (i = 0; i < bitsize; i++)
3461	{
3462	if (bits[i] == 0)
3463	mpz_clrbit (result->value.integer, i);
3464	else if (bits[i] == 1)
3465	mpz_setbit (result->value.integer, i);
3466	else
3467	gfc_internal_error ("IBITS: Bad bit");
3468	}
3469
3470	free (ptr: bits);
3471
3472	gfc_convert_mpz_to_signed (x: result->value.integer,
3473	bitsize: gfc_integer_kinds[k].bit_size);
3474
3475	return result;
3476	}
3477
3478
3479	gfc_expr *
3480	gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
3481	{
3482	gfc_expr *result;
3483	int k, pos;
3484
3485	if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3486	return NULL;
3487
3488	if (!gfc_check_bitfcn (x, y))
3489	return &gfc_bad_expr;
3490
3491	gfc_extract_int (y, &pos);
3492
3493	k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3494
3495	result = gfc_copy_expr (x);
3496	/* Drop any separate memory representation of x to avoid potential
3497	inconsistencies in result. */
3498	if (result->representation.string)
3499	{
3500	free (ptr: result->representation.string);
3501	result->representation.string = NULL;
3502	}
3503
3504	convert_mpz_to_unsigned (x: result->value.integer,
3505	bitsize: gfc_integer_kinds[k].bit_size);
3506
3507	mpz_setbit (result->value.integer, pos);
3508
3509	gfc_convert_mpz_to_signed (x: result->value.integer,
3510	bitsize: gfc_integer_kinds[k].bit_size);
3511
3512	return result;
3513	}
3514
3515
3516	gfc_expr *
3517	gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
3518	{
3519	gfc_expr *result;
3520	gfc_char_t index;
3521	int k;
3522
3523	if (e->expr_type != EXPR_CONSTANT)
3524	return NULL;
3525
3526	if (e->value.character.length != 1)
3527	{
3528	gfc_error ("Argument of ICHAR at %L must be of length one", &e->where);
3529	return &gfc_bad_expr;
3530	}
3531
3532	index = e->value.character.string[0];
3533
3534	k = get_kind (type: BT_INTEGER, k: kind, name: "ICHAR", default_kind: gfc_default_integer_kind);
3535	if (k == -1)
3536	return &gfc_bad_expr;
3537
3538	result = gfc_get_int_expr (k, &e->where, index);
3539
3540	return range_check (result, name: "ICHAR");
3541	}
3542
3543
3544	gfc_expr *
3545	gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
3546	{
3547	gfc_expr *result;
3548
3549	if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3550	return NULL;
3551
3552	result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
3553	mpz_xor (result->value.integer, x->value.integer, y->value.integer);
3554
3555	return range_check (result, name: "IEOR");
3556	}
3557
3558
3559	gfc_expr *
3560	gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind)
3561	{
3562	gfc_expr *result;
3563	bool back;
3564	HOST_WIDE_INT len, lensub, start, last, i, index = 0;
3565	int k, delta;
3566
3567	if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT
3568	|| ( b != NULL && b->expr_type != EXPR_CONSTANT))
3569	return NULL;
3570
3571	back = (b != NULL && b->value.logical != 0);
3572
3573	k = get_kind (type: BT_INTEGER, k: kind, name: "INDEX", default_kind: gfc_default_integer_kind);
3574	if (k == -1)
3575	return &gfc_bad_expr;
3576
3577	result = gfc_get_constant_expr (BT_INTEGER, k, &x->where);
3578
3579	len = x->value.character.length;
3580	lensub = y->value.character.length;
3581
3582	if (len < lensub)
3583	{
3584	mpz_set_si (result->value.integer, 0);
3585	return result;
3586	}
3587
3588	if (lensub == 0)
3589	{
3590	if (back)
3591	index = len + 1;
3592	else
3593	index = 1;
3594	goto done;
3595	}
3596
3597	if (!back)
3598	{
3599	last = len + 1 - lensub;
3600	start = 0;
3601	delta = 1;
3602	}
3603	else
3604	{
3605	last = -1;
3606	start = len - lensub;
3607	delta = -1;
3608	}
3609
3610	for (; start != last; start += delta)
3611	{
3612	for (i = 0; i < lensub; i++)
3613	{
3614	if (x->value.character.string[start + i]
3615	!= y->value.character.string[i])
3616	break;
3617	}
3618	if (i == lensub)
3619	{
3620	index = start + 1;
3621	goto done;
3622	}
3623	}
3624
3625	done:
3626	mpz_set_si (result->value.integer, index);
3627	return range_check (result, name: "INDEX");
3628	}
3629
3630
3631	static gfc_expr *
3632	simplify_intconv (gfc_expr *e, int kind, const char *name)
3633	{
3634	gfc_expr *result = NULL;
3635	int tmp1, tmp2;
3636
3637	/* Convert BOZ to integer, and return without range checking. */
3638	if (e->ts.type == BT_BOZ)
3639	{
3640	if (!gfc_boz2int (e, kind))
3641	return NULL;
3642	result = gfc_copy_expr (e);
3643	return result;
3644	}
3645
3646	if (e->expr_type != EXPR_CONSTANT)
3647	return NULL;
3648
3649	/* For explicit conversion, turn off -Wconversion and -Wconversion-extra
3650	warnings. */
3651	tmp1 = warn_conversion;
3652	tmp2 = warn_conversion_extra;
3653	warn_conversion = warn_conversion_extra = 0;
3654
3655	result = gfc_convert_constant (e, BT_INTEGER, kind);
3656
3657	warn_conversion = tmp1;
3658	warn_conversion_extra = tmp2;
3659
3660	if (result == &gfc_bad_expr)
3661	return &gfc_bad_expr;
3662
3663	return range_check (result, name);
3664	}
3665
3666
3667	gfc_expr *
3668	gfc_simplify_int (gfc_expr *e, gfc_expr *k)
3669	{
3670	int kind;
3671
3672	kind = get_kind (type: BT_INTEGER, k, name: "INT", default_kind: gfc_default_integer_kind);
3673	if (kind == -1)
3674	return &gfc_bad_expr;
3675
3676	return simplify_intconv (e, kind, name: "INT");
3677	}
3678
3679	gfc_expr *
3680	gfc_simplify_int2 (gfc_expr *e)
3681	{
3682	return simplify_intconv (e, kind: 2, name: "INT2");
3683	}
3684
3685
3686	gfc_expr *
3687	gfc_simplify_int8 (gfc_expr *e)
3688	{
3689	return simplify_intconv (e, kind: 8, name: "INT8");
3690	}
3691
3692
3693	gfc_expr *
3694	gfc_simplify_long (gfc_expr *e)
3695	{
3696	return simplify_intconv (e, kind: 4, name: "LONG");
3697	}
3698
3699
3700	gfc_expr *
3701	gfc_simplify_ifix (gfc_expr *e)
3702	{
3703	gfc_expr *rtrunc, *result;
3704
3705	if (e->expr_type != EXPR_CONSTANT)
3706	return NULL;
3707
3708	rtrunc = gfc_copy_expr (e);
3709	mpfr_trunc (rtrunc->value.real, e->value.real);
3710
3711	result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
3712	&e->where);
3713	gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
3714
3715	gfc_free_expr (rtrunc);
3716
3717	return range_check (result, name: "IFIX");
3718	}
3719
3720
3721	gfc_expr *
3722	gfc_simplify_idint (gfc_expr *e)
3723	{
3724	gfc_expr *rtrunc, *result;
3725
3726	if (e->expr_type != EXPR_CONSTANT)
3727	return NULL;
3728
3729	rtrunc = gfc_copy_expr (e);
3730	mpfr_trunc (rtrunc->value.real, e->value.real);
3731
3732	result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
3733	&e->where);
3734	gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
3735
3736	gfc_free_expr (rtrunc);
3737
3738	return range_check (result, name: "IDINT");
3739	}
3740
3741
3742	gfc_expr *
3743	gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
3744	{
3745	gfc_expr *result;
3746
3747	if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3748	return NULL;
3749
3750	result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
3751	mpz_ior (result->value.integer, x->value.integer, y->value.integer);
3752
3753	return range_check (result, name: "IOR");
3754	}
3755
3756
3757	static gfc_expr *
3758	do_bit_xor (gfc_expr *result, gfc_expr *e)
3759	{
3760	gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
3761	gcc_assert (result->ts.type == BT_INTEGER
3762	&& result->expr_type == EXPR_CONSTANT);
3763
3764	mpz_xor (result->value.integer, result->value.integer, e->value.integer);
3765	return result;
3766	}
3767
3768
3769	gfc_expr *
3770	gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
3771	{
3772	return simplify_transformation (array, dim, mask, init_val: 0, op: do_bit_xor);
3773	}
3774
3775
3776	gfc_expr *
3777	gfc_simplify_is_iostat_end (gfc_expr *x)
3778	{
3779	if (x->expr_type != EXPR_CONSTANT)
3780	return NULL;
3781
3782	return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
3783	mpz_cmp_si (x->value.integer,
3784	LIBERROR_END) == 0);
3785	}
3786
3787
3788	gfc_expr *
3789	gfc_simplify_is_iostat_eor (gfc_expr *x)
3790	{
3791	if (x->expr_type != EXPR_CONSTANT)
3792	return NULL;
3793
3794	return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
3795	mpz_cmp_si (x->value.integer,
3796	LIBERROR_EOR) == 0);
3797	}
3798
3799
3800	gfc_expr *
3801	gfc_simplify_isnan (gfc_expr *x)
3802	{
3803	if (x->expr_type != EXPR_CONSTANT)
3804	return NULL;
3805
3806	return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
3807	mpfr_nan_p (x->value.real));
3808	}
3809
3810
3811	/* Performs a shift on its first argument. Depending on the last
3812	argument, the shift can be arithmetic, i.e. with filling from the
3813	left like in the SHIFTA intrinsic. */
3814	static gfc_expr *
3815	simplify_shift (gfc_expr *e, gfc_expr *s, const char *name,
3816	bool arithmetic, int direction)
3817	{
3818	gfc_expr *result;
3819	int ashift, *bits, i, k, bitsize, shift;
3820
3821	if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
3822	return NULL;
3823
3824	gfc_extract_int (s, &shift);
3825
3826	k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
3827	bitsize = gfc_integer_kinds[k].bit_size;
3828
3829	result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
3830
3831	if (shift == 0)
3832	{
3833	mpz_set (result->value.integer, e->value.integer);
3834	return result;
3835	}
3836
3837	if (direction > 0 && shift < 0)
3838	{
3839	/* Left shift, as in SHIFTL. */
3840	gfc_error ("Second argument of %s is negative at %L", name, &e->where);
3841	return &gfc_bad_expr;
3842	}
3843	else if (direction < 0)
3844	{
3845	/* Right shift, as in SHIFTR or SHIFTA. */
3846	if (shift < 0)
3847	{
3848	gfc_error ("Second argument of %s is negative at %L",
3849	name, &e->where);
3850	return &gfc_bad_expr;
3851	}
3852
3853	shift = -shift;
3854	}
3855
3856	ashift = (shift >= 0 ? shift : -shift);
3857
3858	if (ashift > bitsize)
3859	{
3860	gfc_error ("Magnitude of second argument of %s exceeds bit size "
3861	"at %L", name, &e->where);
3862	return &gfc_bad_expr;
3863	}
3864
3865	bits = XCNEWVEC (int, bitsize);
3866
3867	for (i = 0; i < bitsize; i++)
3868	bits[i] = mpz_tstbit (e->value.integer, i);
3869
3870	if (shift > 0)
3871	{
3872	/* Left shift. */
3873	for (i = 0; i < shift; i++)
3874	mpz_clrbit (result->value.integer, i);
3875
3876	for (i = 0; i < bitsize - shift; i++)
3877	{
3878	if (bits[i] == 0)
3879	mpz_clrbit (result->value.integer, i + shift);
3880	else
3881	mpz_setbit (result->value.integer, i + shift);
3882	}
3883	}
3884	else
3885	{
3886	/* Right shift. */
3887	if (arithmetic && bits[bitsize - 1])
3888	for (i = bitsize - 1; i >= bitsize - ashift; i--)
3889	mpz_setbit (result->value.integer, i);
3890	else
3891	for (i = bitsize - 1; i >= bitsize - ashift; i--)
3892	mpz_clrbit (result->value.integer, i);
3893
3894	for (i = bitsize - 1; i >= ashift; i--)
3895	{
3896	if (bits[i] == 0)
3897	mpz_clrbit (result->value.integer, i - ashift);
3898	else
3899	mpz_setbit (result->value.integer, i - ashift);
3900	}
3901	}
3902
3903	gfc_convert_mpz_to_signed (x: result->value.integer, bitsize);
3904	free (ptr: bits);
3905
3906	return result;
3907	}
3908
3909
3910	gfc_expr *
3911	gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
3912	{
3913	return simplify_shift (e, s, name: "ISHFT", arithmetic: false, direction: 0);
3914	}
3915
3916
3917	gfc_expr *
3918	gfc_simplify_lshift (gfc_expr *e, gfc_expr *s)
3919	{
3920	return simplify_shift (e, s, name: "LSHIFT", arithmetic: false, direction: 1);
3921	}
3922
3923
3924	gfc_expr *
3925	gfc_simplify_rshift (gfc_expr *e, gfc_expr *s)
3926	{
3927	return simplify_shift (e, s, name: "RSHIFT", arithmetic: true, direction: -1);
3928	}
3929
3930
3931	gfc_expr *
3932	gfc_simplify_shifta (gfc_expr *e, gfc_expr *s)
3933	{
3934	return simplify_shift (e, s, name: "SHIFTA", arithmetic: true, direction: -1);
3935	}
3936
3937
3938	gfc_expr *
3939	gfc_simplify_shiftl (gfc_expr *e, gfc_expr *s)
3940	{
3941	return simplify_shift (e, s, name: "SHIFTL", arithmetic: false, direction: 1);
3942	}
3943
3944
3945	gfc_expr *
3946	gfc_simplify_shiftr (gfc_expr *e, gfc_expr *s)
3947	{
3948	return simplify_shift (e, s, name: "SHIFTR", arithmetic: false, direction: -1);
3949	}
3950
3951
3952	gfc_expr *
3953	gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
3954	{
3955	gfc_expr *result;
3956	int shift, ashift, isize, ssize, delta, k;
3957	int i, *bits;
3958
3959	if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
3960	return NULL;
3961
3962	gfc_extract_int (s, &shift);
3963
3964	k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3965	isize = gfc_integer_kinds[k].bit_size;
3966
3967	if (sz != NULL)
3968	{
3969	if (sz->expr_type != EXPR_CONSTANT)
3970	return NULL;
3971
3972	gfc_extract_int (sz, &ssize);
3973
3974	if (ssize > isize || ssize <= 0)
3975	return &gfc_bad_expr;
3976	}
3977	else
3978	ssize = isize;
3979
3980	if (shift >= 0)
3981	ashift = shift;
3982	else
3983	ashift = -shift;
3984
3985	if (ashift > ssize)
3986	{
3987	if (sz == NULL)
3988	gfc_error ("Magnitude of second argument of ISHFTC exceeds "
3989	"BIT_SIZE of first argument at %C");
3990	else
3991	gfc_error ("Absolute value of SHIFT shall be less than or equal "
3992	"to SIZE at %C");
3993	return &gfc_bad_expr;
3994	}
3995
3996	result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
3997
3998	mpz_set (result->value.integer, e->value.integer);
3999
4000	if (shift == 0)
4001	return result;
4002
4003	convert_mpz_to_unsigned (x: result->value.integer, bitsize: isize);
4004
4005	bits = XCNEWVEC (int, ssize);
4006
4007	for (i = 0; i < ssize; i++)
4008	bits[i] = mpz_tstbit (e->value.integer, i);
4009
4010	delta = ssize - ashift;
4011
4012	if (shift > 0)
4013	{
4014	for (i = 0; i < delta; i++)
4015	{
4016	if (bits[i] == 0)
4017	mpz_clrbit (result->value.integer, i + shift);
4018	else
4019	mpz_setbit (result->value.integer, i + shift);
4020	}
4021
4022	for (i = delta; i < ssize; i++)
4023	{
4024	if (bits[i] == 0)
4025	mpz_clrbit (result->value.integer, i - delta);
4026	else
4027	mpz_setbit (result->value.integer, i - delta);
4028	}
4029	}
4030	else
4031	{
4032	for (i = 0; i < ashift; i++)
4033	{
4034	if (bits[i] == 0)
4035	mpz_clrbit (result->value.integer, i + delta);
4036	else
4037	mpz_setbit (result->value.integer, i + delta);
4038	}
4039
4040	for (i = ashift; i < ssize; i++)
4041	{
4042	if (bits[i] == 0)
4043	mpz_clrbit (result->value.integer, i + shift);
4044	else
4045	mpz_setbit (result->value.integer, i + shift);
4046	}
4047	}
4048
4049	gfc_convert_mpz_to_signed (x: result->value.integer, bitsize: isize);
4050
4051	free (ptr: bits);
4052	return result;
4053	}
4054
4055
4056	gfc_expr *
4057	gfc_simplify_kind (gfc_expr *e)
4058	{
4059	return gfc_get_int_expr (gfc_default_integer_kind, NULL, e->ts.kind);
4060	}
4061
4062
4063	static gfc_expr *
4064	simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
4065	gfc_array_spec *as, gfc_ref *ref, bool coarray)
4066	{
4067	gfc_expr *l, *u, *result;
4068	int k;
4069
4070	k = get_kind (type: BT_INTEGER, k: kind, name: upper ? "UBOUND" : "LBOUND",
4071	default_kind: gfc_default_integer_kind);
4072	if (k == -1)
4073	return &gfc_bad_expr;
4074
4075	result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
4076
4077	/* For non-variables, LBOUND(expr, DIM=n) = 1 and
4078	UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */
4079	if (!coarray && array->expr_type != EXPR_VARIABLE)
4080	{
4081	if (upper)
4082	{
4083	gfc_expr* dim = result;
4084	mpz_set_si (dim->value.integer, d);
4085
4086	result = simplify_size (array, dim, k);
4087	gfc_free_expr (dim);
4088	if (!result)
4089	goto returnNull;
4090	}
4091	else
4092	mpz_set_si (result->value.integer, 1);
4093
4094	goto done;
4095	}
4096
4097	/* Otherwise, we have a variable expression. */
4098	gcc_assert (array->expr_type == EXPR_VARIABLE);
4099	gcc_assert (as);
4100
4101	if (!gfc_resolve_array_spec (as, 0))
4102	return NULL;
4103
4104	/* The last dimension of an assumed-size array is special. */
4105	if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
4106	|| (coarray && d == as->rank + as->corank
4107	&& (!upper || flag_coarray == GFC_FCOARRAY_SINGLE)))
4108	{
4109	if (as->lower[d-1] && as->lower[d-1]->expr_type == EXPR_CONSTANT)
4110	{
4111	gfc_free_expr (result);
4112	return gfc_copy_expr (as->lower[d-1]);
4113	}
4114
4115	goto returnNull;
4116	}
4117
4118	result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
4119
4120	/* Then, we need to know the extent of the given dimension. */
4121	if (coarray || (ref->u.ar.type == AR_FULL && !ref->next))
4122	{
4123	gfc_expr *declared_bound;
4124	int empty_bound;
4125	bool constant_lbound, constant_ubound;
4126
4127	l = as->lower[d-1];
4128	u = as->upper[d-1];
4129
4130	gcc_assert (l != NULL);
4131
4132	constant_lbound = l->expr_type == EXPR_CONSTANT;
4133	constant_ubound = u && u->expr_type == EXPR_CONSTANT;
4134
4135	empty_bound = upper ? 0 : 1;
4136	declared_bound = upper ? u : l;
4137
4138	if ((!upper && !constant_lbound)
4139	|| (upper && !constant_ubound))
4140	goto returnNull;
4141
4142	if (!coarray)
4143	{
4144	/* For {L,U}BOUND, the value depends on whether the array
4145	is empty. We can nevertheless simplify if the declared bound
4146	has the same value as that of an empty array, in which case
4147	the result isn't dependent on the array emptiness. */
4148	if (mpz_cmp_si (declared_bound->value.integer, empty_bound) == 0)
4149	mpz_set_si (result->value.integer, empty_bound);
4150	else if (!constant_lbound || !constant_ubound)
4151	/* Array emptiness can't be determined, we can't simplify. */
4152	goto returnNull;
4153	else if (mpz_cmp (l->value.integer, u->value.integer) > 0)
4154	mpz_set_si (result->value.integer, empty_bound);
4155	else
4156	mpz_set (result->value.integer, declared_bound->value.integer);
4157	}
4158	else
4159	mpz_set (result->value.integer, declared_bound->value.integer);
4160	}
4161	else
4162	{
4163	if (upper)
4164	{
4165	int d2 = 0, cnt = 0;
4166	for (int idx = 0; idx < ref->u.ar.dimen; ++idx)
4167	{
4168	if (ref->u.ar.dimen_type[idx] == DIMEN_ELEMENT)
4169	d2++;
4170	else if (cnt < d - 1)
4171	cnt++;
4172	else
4173	break;
4174	}
4175	if (!gfc_ref_dimen_size (&ref->u.ar, dimen: d2 + d - 1, &result->value.integer, NULL))
4176	goto returnNull;
4177	}
4178	else
4179	mpz_set_si (result->value.integer, (long int) 1);
4180	}
4181
4182	done:
4183	return range_check (result, name: upper ? "UBOUND" : "LBOUND");
4184
4185	returnNull:
4186	gfc_free_expr (result);
4187	return NULL;
4188	}
4189
4190
4191	static gfc_expr *
4192	simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
4193	{
4194	gfc_ref *ref;
4195	gfc_array_spec *as;
4196	ar_type type = AR_UNKNOWN;
4197	int d;
4198
4199	if (array->ts.type == BT_CLASS)
4200	return NULL;
4201
4202	if (array->expr_type != EXPR_VARIABLE)
4203	{
4204	as = NULL;
4205	ref = NULL;
4206	goto done;
4207	}
4208
4209	/* Do not attempt to resolve if error has already been issued. */
4210	if (array->symtree->n.sym->error)
4211	return NULL;
4212
4213	/* Follow any component references. */
4214	as = array->symtree->n.sym->as;
4215	for (ref = array->ref; ref; ref = ref->next)
4216	{
4217	switch (ref->type)
4218	{
4219	case REF_ARRAY:
4220	type = ref->u.ar.type;
4221	switch (ref->u.ar.type)
4222	{
4223	case AR_ELEMENT:
4224	as = NULL;
4225	continue;
4226
4227	case AR_FULL:
4228	/* We're done because 'as' has already been set in the
4229	previous iteration. */
4230	goto done;
4231
4232	case AR_UNKNOWN:
4233	return NULL;
4234
4235	case AR_SECTION:
4236	as = ref->u.ar.as;
4237	goto done;
4238	}
4239
4240	gcc_unreachable ();
4241
4242	case REF_COMPONENT:
4243	as = ref->u.c.component->as;
4244	continue;
4245
4246	case REF_SUBSTRING:
4247	case REF_INQUIRY:
4248	continue;
4249	}
4250	}
4251
4252	gcc_unreachable ();
4253
4254	done:
4255
4256	if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_RANK
4257	|| (as->type == AS_ASSUMED_SHAPE && upper)))
4258	return NULL;
4259
4260	/* 'array' shall not be an unallocated allocatable variable or a pointer that
4261	is not associated. */
4262	if (array->expr_type == EXPR_VARIABLE
4263	&& (gfc_expr_attr (array).allocatable || gfc_expr_attr (array).pointer))
4264	return NULL;
4265
4266	gcc_assert (!as
4267	|| (as->type != AS_DEFERRED
4268	&& array->expr_type == EXPR_VARIABLE
4269	&& !gfc_expr_attr (array).allocatable
4270	&& !gfc_expr_attr (array).pointer));
4271
4272	if (dim == NULL)
4273	{
4274	/* Multi-dimensional bounds. */
4275	gfc_expr *bounds[GFC_MAX_DIMENSIONS];
4276	gfc_expr *e;
4277	int k;
4278
4279	/* UBOUND(ARRAY) is not valid for an assumed-size array. */
4280	if (upper && type == AR_FULL && as && as->type == AS_ASSUMED_SIZE)
4281	{
4282	/* An error message will be emitted in
4283	check_assumed_size_reference (resolve.cc). */
4284	return &gfc_bad_expr;
4285	}
4286
4287	/* Simplify the bounds for each dimension. */
4288	for (d = 0; d < array->rank; d++)
4289	{
4290	bounds[d] = simplify_bound_dim (array, kind, d: d + 1, upper, as, ref,
4291	coarray: false);
4292	if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
4293	{
4294	int j;
4295
4296	for (j = 0; j < d; j++)
4297	gfc_free_expr (bounds[j]);
4298
4299	if (gfc_seen_div0)
4300	return &gfc_bad_expr;
4301	else
4302	return bounds[d];
4303	}
4304	}
4305
4306	/* Allocate the result expression. */
4307	k = get_kind (type: BT_INTEGER, k: kind, name: upper ? "UBOUND" : "LBOUND",
4308	default_kind: gfc_default_integer_kind);
4309	if (k == -1)
4310	return &gfc_bad_expr;
4311
4312	e = gfc_get_array_expr (type: BT_INTEGER, kind: k, &array->where);
4313
4314	/* The result is a rank 1 array; its size is the rank of the first
4315	argument to {L,U}BOUND. */
4316	e->rank = 1;
4317	e->shape = gfc_get_shape (1);
4318	mpz_init_set_ui (e->shape[0], array->rank);
4319
4320	/* Create the constructor for this array. */
4321	for (d = 0; d < array->rank; d++)
4322	gfc_constructor_append_expr (base: &e->value.constructor,
4323	e: bounds[d], where: &e->where);
4324
4325	return e;
4326	}
4327	else
4328	{
4329	/* A DIM argument is specified. */
4330	if (dim->expr_type != EXPR_CONSTANT)
4331	return NULL;
4332
4333	d = mpz_get_si (dim->value.integer);
4334
4335	if ((d < 1 || d > array->rank)
4336	|| (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper))
4337	{
4338	gfc_error ("DIM argument at %L is out of bounds", &dim->where);
4339	return &gfc_bad_expr;
4340	}
4341
4342	if (as && as->type == AS_ASSUMED_RANK)
4343	return NULL;
4344
4345	return simplify_bound_dim (array, kind, d, upper, as, ref, coarray: false);
4346	}
4347	}
4348
4349
4350	static gfc_expr *
4351	simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
4352	{
4353	gfc_ref *ref;
4354	gfc_array_spec *as;
4355	int d;
4356
4357	if (array->expr_type != EXPR_VARIABLE)
4358	return NULL;
4359
4360	/* Follow any component references. */
4361	as = (array->ts.type == BT_CLASS && CLASS_DATA (array))
4362	? CLASS_DATA (array)->as
4363	: array->symtree->n.sym->as;
4364	for (ref = array->ref; ref; ref = ref->next)
4365	{
4366	switch (ref->type)
4367	{
4368	case REF_ARRAY:
4369	switch (ref->u.ar.type)
4370	{
4371	case AR_ELEMENT:
4372	if (ref->u.ar.as->corank > 0)
4373	{
4374	gcc_assert (as == ref->u.ar.as);
4375	goto done;
4376	}
4377	as = NULL;
4378	continue;
4379
4380	case AR_FULL:
4381	/* We're done because 'as' has already been set in the
4382	previous iteration. */
4383	goto done;
4384
4385	case AR_UNKNOWN:
4386	return NULL;
4387
4388	case AR_SECTION:
4389	as = ref->u.ar.as;
4390	goto done;
4391	}
4392
4393	gcc_unreachable ();
4394
4395	case REF_COMPONENT:
4396	as = ref->u.c.component->as;
4397	continue;
4398
4399	case REF_SUBSTRING:
4400	case REF_INQUIRY:
4401	continue;
4402	}
4403	}
4404
4405	if (!as)
4406	gcc_unreachable ();
4407
4408	done:
4409
4410	if (as->cotype == AS_DEFERRED || as->cotype == AS_ASSUMED_SHAPE)
4411	return NULL;
4412
4413	if (dim == NULL)
4414	{
4415	/* Multi-dimensional cobounds. */
4416	gfc_expr *bounds[GFC_MAX_DIMENSIONS];
4417	gfc_expr *e;
4418	int k;
4419
4420	/* Simplify the cobounds for each dimension. */
4421	for (d = 0; d < as->corank; d++)
4422	{
4423	bounds[d] = simplify_bound_dim (array, kind, d: d + 1 + as->rank,
4424	upper, as, ref, coarray: true);
4425	if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
4426	{
4427	int j;
4428
4429	for (j = 0; j < d; j++)
4430	gfc_free_expr (bounds[j]);
4431	return bounds[d];
4432	}
4433	}
4434
4435	/* Allocate the result expression. */
4436	e = gfc_get_expr ();
4437	e->where = array->where;
4438	e->expr_type = EXPR_ARRAY;
4439	e->ts.type = BT_INTEGER;
4440	k = get_kind (type: BT_INTEGER, k: kind, name: upper ? "UCOBOUND" : "LCOBOUND",
4441	default_kind: gfc_default_integer_kind);
4442	if (k == -1)
4443	{
4444	gfc_free_expr (e);
4445	return &gfc_bad_expr;
4446	}
4447	e->ts.kind = k;
4448
4449	/* The result is a rank 1 array; its size is the rank of the first
4450	argument to {L,U}COBOUND. */
4451	e->rank = 1;
4452	e->shape = gfc_get_shape (1);
4453	mpz_init_set_ui (e->shape[0], as->corank);
4454
4455	/* Create the constructor for this array. */
4456	for (d = 0; d < as->corank; d++)
4457	gfc_constructor_append_expr (base: &e->value.constructor,
4458	e: bounds[d], where: &e->where);
4459	return e;
4460	}
4461	else
4462	{
4463	/* A DIM argument is specified. */
4464	if (dim->expr_type != EXPR_CONSTANT)
4465	return NULL;
4466
4467	d = mpz_get_si (dim->value.integer);
4468
4469	if (d < 1 || d > as->corank)
4470	{
4471	gfc_error ("DIM argument at %L is out of bounds", &dim->where);
4472	return &gfc_bad_expr;
4473	}
4474
4475	return simplify_bound_dim (array, kind, d: d+as->rank, upper, as, ref, coarray: true);
4476	}
4477	}
4478
4479
4480	gfc_expr *
4481	gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4482	{
4483	return simplify_bound (array, dim, kind, upper: 0);
4484	}
4485
4486
4487	gfc_expr *
4488	gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4489	{
4490	return simplify_cobound (array, dim, kind, upper: 0);
4491	}
4492
4493	gfc_expr *
4494	gfc_simplify_leadz (gfc_expr *e)
4495	{
4496	unsigned long lz, bs;
4497	int i;
4498
4499	if (e->expr_type != EXPR_CONSTANT)
4500	return NULL;
4501
4502	i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4503	bs = gfc_integer_kinds[i].bit_size;
4504	if (mpz_cmp_si (e->value.integer, 0) == 0)
4505	lz = bs;
4506	else if (mpz_cmp_si (e->value.integer, 0) < 0)
4507	lz = 0;
4508	else
4509	lz = bs - mpz_sizeinbase (e->value.integer, 2);
4510
4511	return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz);
4512	}
4513
4514
4515	/* Check for constant length of a substring. */
4516
4517	static bool
4518	substring_has_constant_len (gfc_expr *e)
4519	{
4520	gfc_ref *ref;
4521	HOST_WIDE_INT istart, iend, length;
4522	bool equal_length = false;
4523
4524	if (e->ts.type != BT_CHARACTER)
4525	return false;
4526
4527	for (ref = e->ref; ref; ref = ref->next)
4528	if (ref->type != REF_COMPONENT && ref->type != REF_ARRAY)
4529	break;
4530
4531	if (!ref
4532	|| ref->type != REF_SUBSTRING
4533	|| !ref->u.ss.start
4534	|| ref->u.ss.start->expr_type != EXPR_CONSTANT
4535	|| !ref->u.ss.end
4536	|| ref->u.ss.end->expr_type != EXPR_CONSTANT)
4537	return false;
4538
4539	/* Basic checks on substring starting and ending indices. */
4540	if (!gfc_resolve_substring (ref, &equal_length))
4541	return false;
4542
4543	istart = gfc_mpz_get_hwi (ref->u.ss.start->value.integer);
4544	iend = gfc_mpz_get_hwi (ref->u.ss.end->value.integer);
4545
4546	if (istart <= iend)
4547	length = iend - istart + 1;
4548	else
4549	length = 0;
4550
4551	/* Fix substring length. */
4552	e->value.character.length = length;
4553
4554	return true;
4555	}
4556
4557
4558	gfc_expr *
4559	gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
4560	{
4561	gfc_expr *result;
4562	int k = get_kind (type: BT_INTEGER, k: kind, name: "LEN", default_kind: gfc_default_integer_kind);
4563
4564	if (k == -1)
4565	return &gfc_bad_expr;
4566
4567	if (e->expr_type == EXPR_CONSTANT
4568	|| substring_has_constant_len (e))
4569	{
4570	result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
4571	mpz_set_si (result->value.integer, e->value.character.length);
4572	return range_check (result, name: "LEN");
4573	}
4574	else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
4575	&& e->ts.u.cl->length->expr_type == EXPR_CONSTANT
4576	&& e->ts.u.cl->length->ts.type == BT_INTEGER)
4577	{
4578	result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
4579	mpz_set (result->value.integer, e->ts.u.cl->length->value.integer);
4580	return range_check (result, name: "LEN");
4581	}
4582	else if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_CHARACTER
4583	&& e->symtree->n.sym)
4584	{
4585	if (e->symtree->n.sym->ts.type != BT_DERIVED
4586	&& e->symtree->n.sym->assoc && e->symtree->n.sym->assoc->target
4587	&& e->symtree->n.sym->assoc->target->ts.type == BT_DERIVED
4588	&& e->symtree->n.sym->assoc->target->symtree->n.sym
4589	&& UNLIMITED_POLY (e->symtree->n.sym->assoc->target->symtree->n.sym))
4590	/* The expression in assoc->target points to a ref to the _data
4591	component of the unlimited polymorphic entity. To get the _len
4592	component the last _data ref needs to be stripped and a ref to the
4593	_len component added. */
4594	return gfc_get_len_component (e: e->symtree->n.sym->assoc->target, k);
4595	else if (e->symtree->n.sym->ts.type == BT_DERIVED
4596	&& e->ref && e->ref->type == REF_COMPONENT
4597	&& e->ref->u.c.component->attr.pdt_string
4598	&& e->ref->u.c.component->ts.type == BT_CHARACTER
4599	&& e->ref->u.c.component->ts.u.cl->length)
4600	{
4601	if (gfc_init_expr_flag)
4602	{
4603	gfc_expr* tmp;
4604	tmp = gfc_pdt_find_component_copy_initializer (e->symtree->n.sym,
4605	e->ref->u.c
4606	.component->ts.u.cl
4607	->length->symtree
4608	->name);
4609	if (tmp)
4610	return tmp;
4611	}
4612	else
4613	{
4614	gfc_expr *len_expr = gfc_copy_expr (e);
4615	gfc_free_ref_list (len_expr->ref);
4616	len_expr->ref = NULL;
4617	gfc_find_component (len_expr->symtree->n.sym->ts.u.derived, e->ref
4618	->u.c.component->ts.u.cl->length->symtree
4619	->name,
4620	false, true, &len_expr->ref);
4621	len_expr->ts = len_expr->ref->u.c.component->ts;
4622	return len_expr;
4623	}
4624	}
4625	}
4626	return NULL;
4627	}
4628
4629
4630	gfc_expr *
4631	gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
4632	{
4633	gfc_expr *result;
4634	size_t count, len, i;
4635	int k = get_kind (type: BT_INTEGER, k: kind, name: "LEN_TRIM", default_kind: gfc_default_integer_kind);
4636
4637	if (k == -1)
4638	return &gfc_bad_expr;
4639
4640	if (e->expr_type != EXPR_CONSTANT)
4641	return NULL;
4642
4643	len = e->value.character.length;
4644	for (count = 0, i = 1; i <= len; i++)
4645	if (e->value.character.string[len - i] == ' ')
4646	count++;
4647	else
4648	break;
4649
4650	result = gfc_get_int_expr (k, &e->where, len - count);
4651	return range_check (result, name: "LEN_TRIM");
4652	}
4653
4654	gfc_expr *
4655	gfc_simplify_lgamma (gfc_expr *x)
4656	{
4657	gfc_expr *result;
4658	int sg;
4659
4660	if (x->expr_type != EXPR_CONSTANT)
4661	return NULL;
4662
4663	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4664	mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
4665
4666	return range_check (result, name: "LGAMMA");
4667	}
4668
4669
4670	gfc_expr *
4671	gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
4672	{
4673	if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
4674	return NULL;
4675
4676	return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
4677	gfc_compare_string (a, b) >= 0);
4678	}
4679
4680
4681	gfc_expr *
4682	gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
4683	{
4684	if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
4685	return NULL;
4686
4687	return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
4688	gfc_compare_string (a, b) > 0);
4689	}
4690
4691
4692	gfc_expr *
4693	gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
4694	{
4695	if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
4696	return NULL;
4697
4698	return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
4699	gfc_compare_string (a, b) <= 0);
4700	}
4701
4702
4703	gfc_expr *
4704	gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
4705	{
4706	if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
4707	return NULL;
4708
4709	return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
4710	gfc_compare_string (a, b) < 0);
4711	}
4712
4713
4714	gfc_expr *
4715	gfc_simplify_log (gfc_expr *x)
4716	{
4717	gfc_expr *result;
4718
4719	if (x->expr_type != EXPR_CONSTANT)
4720	return NULL;
4721
4722	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4723
4724	switch (x->ts.type)
4725	{
4726	case BT_REAL:
4727	if (mpfr_sgn (x->value.real) <= 0)
4728	{
4729	gfc_error ("Argument of LOG at %L cannot be less than or equal "
4730	"to zero", &x->where);
4731	gfc_free_expr (result);
4732	return &gfc_bad_expr;
4733	}
4734
4735	mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
4736	break;
4737
4738	case BT_COMPLEX:
4739	if (mpfr_zero_p (mpc_realref (x->value.complex))
4740	&& mpfr_zero_p (mpc_imagref (x->value.complex)))
4741	{
4742	gfc_error ("Complex argument of LOG at %L cannot be zero",
4743	&x->where);
4744	gfc_free_expr (result);
4745	return &gfc_bad_expr;
4746	}
4747
4748	gfc_set_model_kind (x->ts.kind);
4749	mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
4750	break;
4751
4752	default:
4753	gfc_internal_error ("gfc_simplify_log: bad type");
4754	}
4755
4756	return range_check (result, name: "LOG");
4757	}
4758
4759
4760	gfc_expr *
4761	gfc_simplify_log10 (gfc_expr *x)
4762	{
4763	gfc_expr *result;
4764
4765	if (x->expr_type != EXPR_CONSTANT)
4766	return NULL;
4767
4768	if (mpfr_sgn (x->value.real) <= 0)
4769	{
4770	gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
4771	"to zero", &x->where);
4772	return &gfc_bad_expr;
4773	}
4774
4775	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4776	mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
4777
4778	return range_check (result, name: "LOG10");
4779	}
4780
4781
4782	gfc_expr *
4783	gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
4784	{
4785	int kind;
4786
4787	kind = get_kind (type: BT_LOGICAL, k, name: "LOGICAL", default_kind: gfc_default_logical_kind);
4788	if (kind < 0)
4789	return &gfc_bad_expr;
4790
4791	if (e->expr_type != EXPR_CONSTANT)
4792	return NULL;
4793
4794	return gfc_get_logical_expr (kind, &e->where, e->value.logical);
4795	}
4796
4797
4798	gfc_expr*
4799	gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
4800	{
4801	gfc_expr *result;
4802	int row, result_rows, col, result_columns;
4803	int stride_a, offset_a, stride_b, offset_b;
4804
4805	if (!is_constant_array_expr (e: matrix_a)
4806	|| !is_constant_array_expr (e: matrix_b))
4807	return NULL;
4808
4809	/* MATMUL should do mixed-mode arithmetic. Set the result type. */
4810	if (matrix_a->ts.type != matrix_b->ts.type)
4811	{
4812	gfc_expr e;
4813	e.expr_type = EXPR_OP;
4814	gfc_clear_ts (&e.ts);
4815	e.value.op.op = INTRINSIC_NONE;
4816	e.value.op.op1 = matrix_a;
4817	e.value.op.op2 = matrix_b;
4818	gfc_type_convert_binary (&e, 1);
4819	result = gfc_get_array_expr (type: e.ts.type, kind: e.ts.kind, &matrix_a->where);
4820	}
4821	else
4822	{
4823	result = gfc_get_array_expr (type: matrix_a->ts.type, kind: matrix_a->ts.kind,
4824	&matrix_a->where);
4825	}
4826
4827	if (matrix_a->rank == 1 && matrix_b->rank == 2)
4828	{
4829	result_rows = 1;
4830	result_columns = mpz_get_si (matrix_b->shape[1]);
4831	stride_a = 1;
4832	stride_b = mpz_get_si (matrix_b->shape[0]);
4833
4834	result->rank = 1;
4835	result->shape = gfc_get_shape (result->rank);
4836	mpz_init_set_si (result->shape[0], result_columns);
4837	}
4838	else if (matrix_a->rank == 2 && matrix_b->rank == 1)
4839	{
4840	result_rows = mpz_get_si (matrix_a->shape[0]);
4841	result_columns = 1;
4842	stride_a = mpz_get_si (matrix_a->shape[0]);
4843	stride_b = 1;
4844
4845	result->rank = 1;
4846	result->shape = gfc_get_shape (result->rank);
4847	mpz_init_set_si (result->shape[0], result_rows);
4848	}
4849	else if (matrix_a->rank == 2 && matrix_b->rank == 2)
4850	{
4851	result_rows = mpz_get_si (matrix_a->shape[0]);
4852	result_columns = mpz_get_si (matrix_b->shape[1]);
4853	stride_a = mpz_get_si (matrix_a->shape[0]);
4854	stride_b = mpz_get_si (matrix_b->shape[0]);
4855
4856	result->rank = 2;
4857	result->shape = gfc_get_shape (result->rank);
4858	mpz_init_set_si (result->shape[0], result_rows);
4859	mpz_init_set_si (result->shape[1], result_columns);
4860	}
4861	else
4862	gcc_unreachable();
4863
4864	offset_b = 0;
4865	for (col = 0; col < result_columns; ++col)
4866	{
4867	offset_a = 0;
4868
4869	for (row = 0; row < result_rows; ++row)
4870	{
4871	gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a,
4872	matrix_b, stride_b: 1, offset_b, conj_a: false);
4873	gfc_constructor_append_expr (base: &result->value.constructor,
4874	e, NULL);
4875
4876	offset_a += 1;
4877	}
4878
4879	offset_b += stride_b;
4880	}
4881
4882	return result;
4883	}
4884
4885
4886	gfc_expr *
4887	gfc_simplify_maskr (gfc_expr *i, gfc_expr *kind_arg)
4888	{
4889	gfc_expr *result;
4890	int kind, arg, k;
4891
4892	if (i->expr_type != EXPR_CONSTANT)
4893	return NULL;
4894
4895	kind = get_kind (type: BT_INTEGER, k: kind_arg, name: "MASKR", default_kind: gfc_default_integer_kind);
4896	if (kind == -1)
4897	return &gfc_bad_expr;
4898	k = gfc_validate_kind (BT_INTEGER, kind, false);
4899
4900	bool fail = gfc_extract_int (i, &arg);
4901	gcc_assert (!fail);
4902
4903	if (!gfc_check_mask (i, kind_arg))
4904	return &gfc_bad_expr;
4905
4906	result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
4907
4908	/* MASKR(n) = 2^n - 1 */
4909	mpz_set_ui (result->value.integer, 1);
4910	mpz_mul_2exp (result->value.integer, result->value.integer, arg);
4911	mpz_sub_ui (result->value.integer, result->value.integer, 1);
4912
4913	gfc_convert_mpz_to_signed (x: result->value.integer, bitsize: gfc_integer_kinds[k].bit_size);
4914
4915	return result;
4916	}
4917
4918
4919	gfc_expr *
4920	gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg)
4921	{
4922	gfc_expr *result;
4923	int kind, arg, k;
4924	mpz_t z;
4925
4926	if (i->expr_type != EXPR_CONSTANT)
4927	return NULL;
4928
4929	kind = get_kind (type: BT_INTEGER, k: kind_arg, name: "MASKL", default_kind: gfc_default_integer_kind);
4930	if (kind == -1)
4931	return &gfc_bad_expr;
4932	k = gfc_validate_kind (BT_INTEGER, kind, false);
4933
4934	bool fail = gfc_extract_int (i, &arg);
4935	gcc_assert (!fail);
4936
4937	if (!gfc_check_mask (i, kind_arg))
4938	return &gfc_bad_expr;
4939
4940	result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
4941
4942	/* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
4943	mpz_init_set_ui (z, 1);
4944	mpz_mul_2exp (z, z, gfc_integer_kinds[k].bit_size);
4945	mpz_set_ui (result->value.integer, 1);
4946	mpz_mul_2exp (result->value.integer, result->value.integer,
4947	gfc_integer_kinds[k].bit_size - arg);
4948	mpz_sub (result->value.integer, z, result->value.integer);
4949	mpz_clear (z);
4950
4951	gfc_convert_mpz_to_signed (x: result->value.integer, bitsize: gfc_integer_kinds[k].bit_size);
4952
4953	return result;
4954	}
4955
4956
4957	gfc_expr *
4958	gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
4959	{
4960	gfc_expr * result;
4961	gfc_constructor *tsource_ctor, *fsource_ctor, *mask_ctor;
4962
4963	if (mask->expr_type == EXPR_CONSTANT)
4964	{
4965	/* The standard requires evaluation of all function arguments.
4966	Simplify only when the other dropped argument (FSOURCE or TSOURCE)
4967	is a constant expression. */
4968	if (mask->value.logical)
4969	{
4970	if (!gfc_is_constant_expr (fsource))
4971	return NULL;
4972	result = gfc_copy_expr (tsource);
4973	}
4974	else
4975	{
4976	if (!gfc_is_constant_expr (tsource))
4977	return NULL;
4978	result = gfc_copy_expr (fsource);
4979	}
4980
4981	/* Parenthesis is needed to get lower bounds of 1. */
4982	result = gfc_get_parentheses (result);
4983	gfc_simplify_expr (result, 1);
4984	return result;
4985	}
4986
4987	if (!mask->rank || !is_constant_array_expr (e: mask)
4988	|| !is_constant_array_expr (e: tsource) || !is_constant_array_expr (e: fsource))
4989	return NULL;
4990
4991	result = gfc_get_array_expr (type: tsource->ts.type, kind: tsource->ts.kind,
4992	&tsource->where);
4993	if (tsource->ts.type == BT_DERIVED)
4994	result->ts.u.derived = tsource->ts.u.derived;
4995	else if (tsource->ts.type == BT_CHARACTER)
4996	result->ts.u.cl = tsource->ts.u.cl;
4997
4998	tsource_ctor = gfc_constructor_first (base: tsource->value.constructor);
4999	fsource_ctor = gfc_constructor_first (base: fsource->value.constructor);
5000	mask_ctor = gfc_constructor_first (base: mask->value.constructor);
5001
5002	while (mask_ctor)
5003	{
5004	if (mask_ctor->expr->value.logical)
5005	gfc_constructor_append_expr (base: &result->value.constructor,
5006	e: gfc_copy_expr (tsource_ctor->expr),
5007	NULL);
5008	else
5009	gfc_constructor_append_expr (base: &result->value.constructor,
5010	e: gfc_copy_expr (fsource_ctor->expr),
5011	NULL);
5012	tsource_ctor = gfc_constructor_next (ctor: tsource_ctor);
5013	fsource_ctor = gfc_constructor_next (ctor: fsource_ctor);
5014	mask_ctor = gfc_constructor_next (ctor: mask_ctor);
5015	}
5016
5017	result->shape = gfc_get_shape (1);
5018	gfc_array_size (result, &result->shape[0]);
5019
5020	return result;
5021	}
5022
5023
5024	gfc_expr *
5025	gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask_expr)
5026	{
5027	mpz_t arg1, arg2, mask;
5028	gfc_expr *result;
5029
5030	if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT
5031	|| mask_expr->expr_type != EXPR_CONSTANT)
5032	return NULL;
5033
5034	result = gfc_get_constant_expr (BT_INTEGER, i->ts.kind, &i->where);
5035
5036	/* Convert all argument to unsigned. */
5037	mpz_init_set (arg1, i->value.integer);
5038	mpz_init_set (arg2, j->value.integer);
5039	mpz_init_set (mask, mask_expr->value.integer);
5040
5041	/* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */
5042	mpz_and (arg1, arg1, mask);
5043	mpz_com (mask, mask);
5044	mpz_and (arg2, arg2, mask);
5045	mpz_ior (result->value.integer, arg1, arg2);
5046
5047	mpz_clear (arg1);
5048	mpz_clear (arg2);
5049	mpz_clear (mask);
5050
5051	return result;
5052	}
5053
5054
5055	/* Selects between current value and extremum for simplify_min_max
5056	and simplify_minval_maxval. */
5057	static int
5058	min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign, bool back_val)
5059	{
5060	int ret;
5061
5062	switch (arg->ts.type)
5063	{
5064	case BT_INTEGER:
5065	if (extremum->ts.kind < arg->ts.kind)
5066	extremum->ts.kind = arg->ts.kind;
5067	ret = mpz_cmp (arg->value.integer,
5068	extremum->value.integer) * sign;
5069	if (ret > 0)
5070	mpz_set (extremum->value.integer, arg->value.integer);
5071	break;
5072
5073	case BT_REAL:
5074	if (extremum->ts.kind < arg->ts.kind)
5075	extremum->ts.kind = arg->ts.kind;
5076	if (mpfr_nan_p (extremum->value.real))
5077	{
5078	ret = 1;
5079	mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE);
5080	}
5081	else if (mpfr_nan_p (arg->value.real))
5082	ret = -1;
5083	else
5084	{
5085	ret = mpfr_cmp (arg->value.real, extremum->value.real) * sign;
5086	if (ret > 0)
5087	mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE);
5088	}
5089	break;
5090
5091	case BT_CHARACTER:
5092	#define LENGTH(x) ((x)->value.character.length)
5093	#define STRING(x) ((x)->value.character.string)
5094	if (LENGTH (extremum) < LENGTH(arg))
5095	{
5096	gfc_char_t *tmp = STRING(extremum);
5097
5098	STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
5099	memcpy (STRING(extremum), src: tmp,
5100	LENGTH(extremum) * sizeof (gfc_char_t));
5101	gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
5102	LENGTH(arg) - LENGTH(extremum));
5103	STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */
5104	LENGTH(extremum) = LENGTH(arg);
5105	free (ptr: tmp);
5106	}
5107	ret = gfc_compare_string (arg, extremum) * sign;
5108	if (ret > 0)
5109	{
5110	free (STRING(extremum));
5111	STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
5112	memcpy (STRING(extremum), STRING(arg),
5113	LENGTH(arg) * sizeof (gfc_char_t));
5114	gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
5115	LENGTH(extremum) - LENGTH(arg));
5116	STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */
5117	}
5118	#undef LENGTH
5119	#undef STRING
5120	break;
5121
5122	default:
5123	gfc_internal_error ("simplify_min_max(): Bad type in arglist");
5124	}
5125	if (back_val && ret == 0)
5126	ret = 1;
5127
5128	return ret;
5129	}
5130
5131
5132	/* This function is special since MAX() can take any number of
5133	arguments. The simplified expression is a rewritten version of the
5134	argument list containing at most one constant element. Other
5135	constant elements are deleted. Because the argument list has
5136	already been checked, this function always succeeds. sign is 1 for
5137	MAX(), -1 for MIN(). */
5138
5139	static gfc_expr *
5140	simplify_min_max (gfc_expr *expr, int sign)
5141	{
5142	int tmp1, tmp2;
5143	gfc_actual_arglist *arg, *last, *extremum;
5144	gfc_expr *tmp, *ret;
5145	const char *fname;
5146
5147	last = NULL;
5148	extremum = NULL;
5149
5150	arg = expr->value.function.actual;
5151
5152	for (; arg; last = arg, arg = arg->next)
5153	{
5154	if (arg->expr->expr_type != EXPR_CONSTANT)
5155	continue;
5156
5157	if (extremum == NULL)
5158	{
5159	extremum = arg;
5160	continue;
5161	}
5162
5163	min_max_choose (arg: arg->expr, extremum: extremum->expr, sign);
5164
5165	/* Delete the extra constant argument. */
5166	last->next = arg->next;
5167
5168	arg->next = NULL;
5169	gfc_free_actual_arglist (arg);
5170	arg = last;
5171	}
5172
5173	/* If there is one value left, replace the function call with the
5174	expression. */
5175	if (expr->value.function.actual->next != NULL)
5176	return NULL;
5177
5178	/* Handle special cases of specific functions (min|max)1 and
5179	a(min|max)0. */
5180
5181	tmp = expr->value.function.actual->expr;
5182	fname = expr->value.function.isym->name;
5183
5184	if ((tmp->ts.type != BT_INTEGER || tmp->ts.kind != gfc_integer_4_kind)
5185	&& (strcmp (s1: fname, s2: "min1") == 0 || strcmp (s1: fname, s2: "max1") == 0))
5186	{
5187	/* Explicit conversion, turn off -Wconversion and -Wconversion-extra
5188	warnings. */
5189	tmp1 = warn_conversion;
5190	tmp2 = warn_conversion_extra;
5191	warn_conversion = warn_conversion_extra = 0;
5192
5193	ret = gfc_convert_constant (tmp, BT_INTEGER, gfc_integer_4_kind);
5194
5195	warn_conversion = tmp1;
5196	warn_conversion_extra = tmp2;
5197	}
5198	else if ((tmp->ts.type != BT_REAL || tmp->ts.kind != gfc_real_4_kind)
5199	&& (strcmp (s1: fname, s2: "amin0") == 0 || strcmp (s1: fname, s2: "amax0") == 0))
5200	{
5201	ret = gfc_convert_constant (tmp, BT_REAL, gfc_real_4_kind);
5202	}
5203	else
5204	ret = gfc_copy_expr (tmp);
5205
5206	return ret;
5207
5208	}
5209
5210
5211	gfc_expr *
5212	gfc_simplify_min (gfc_expr *e)
5213	{
5214	return simplify_min_max (expr: e, sign: -1);
5215	}
5216
5217
5218	gfc_expr *
5219	gfc_simplify_max (gfc_expr *e)
5220	{
5221	return simplify_min_max (expr: e, sign: 1);
5222	}
5223
5224	/* Helper function for gfc_simplify_minval. */
5225
5226	static gfc_expr *
5227	gfc_min (gfc_expr *op1, gfc_expr *op2)
5228	{
5229	min_max_choose (arg: op1, extremum: op2, sign: -1);
5230	gfc_free_expr (op1);
5231	return op2;
5232	}
5233
5234	/* Simplify minval for constant arrays. */
5235
5236	gfc_expr *
5237	gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
5238	{
5239	return simplify_transformation (array, dim, mask, INT_MAX, op: gfc_min);
5240	}
5241
5242	/* Helper function for gfc_simplify_maxval. */
5243
5244	static gfc_expr *
5245	gfc_max (gfc_expr *op1, gfc_expr *op2)
5246	{
5247	min_max_choose (arg: op1, extremum: op2, sign: 1);
5248	gfc_free_expr (op1);
5249	return op2;
5250	}
5251
5252
5253	/* Simplify maxval for constant arrays. */
5254
5255	gfc_expr *
5256	gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
5257	{
5258	return simplify_transformation (array, dim, mask, INT_MIN, op: gfc_max);
5259	}
5260
5261
5262	/* Transform minloc or maxloc of an array, according to MASK,
5263	to the scalar result. This code is mostly identical to
5264	simplify_transformation_to_scalar. */
5265
5266	static gfc_expr *
5267	simplify_minmaxloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask,
5268	gfc_expr *extremum, int sign, bool back_val)
5269	{
5270	gfc_expr *a, *m;
5271	gfc_constructor *array_ctor, *mask_ctor;
5272	mpz_t count;
5273
5274	mpz_set_si (result->value.integer, 0);
5275
5276
5277	/* Shortcut for constant .FALSE. MASK. */
5278	if (mask
5279	&& mask->expr_type == EXPR_CONSTANT
5280	&& !mask->value.logical)
5281	return result;
5282
5283	array_ctor = gfc_constructor_first (base: array->value.constructor);
5284	if (mask && mask->expr_type == EXPR_ARRAY)
5285	mask_ctor = gfc_constructor_first (base: mask->value.constructor);
5286	else
5287	mask_ctor = NULL;
5288
5289	mpz_init_set_si (count, 0);
5290	while (array_ctor)
5291	{
5292	mpz_add_ui (count, count, 1);
5293	a = array_ctor->expr;
5294	array_ctor = gfc_constructor_next (ctor: array_ctor);
5295	/* A constant MASK equals .TRUE. here and can be ignored. */
5296	if (mask_ctor)
5297	{
5298	m = mask_ctor->expr;
5299	mask_ctor = gfc_constructor_next (ctor: mask_ctor);
5300	if (!m->value.logical)
5301	continue;
5302	}
5303	if (min_max_choose (arg: a, extremum, sign, back_val) > 0)
5304	mpz_set (result->value.integer, count);
5305	}
5306	mpz_clear (count);
5307	gfc_free_expr (extremum);
5308	return result;
5309	}
5310
5311	/* Simplify minloc / maxloc in the absence of a dim argument. */
5312
5313	static gfc_expr *
5314	simplify_minmaxloc_nodim (gfc_expr *result, gfc_expr *extremum,
5315	gfc_expr *array, gfc_expr *mask, int sign,
5316	bool back_val)
5317	{
5318	ssize_t res[GFC_MAX_DIMENSIONS];
5319	int i, n;
5320	gfc_constructor *result_ctor, *array_ctor, *mask_ctor;
5321	ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
5322	sstride[GFC_MAX_DIMENSIONS];
5323	gfc_expr *a, *m;
5324	bool continue_loop;
5325	bool ma;
5326
5327	for (i = 0; i<array->rank; i++)
5328	res[i] = -1;
5329
5330	/* Shortcut for constant .FALSE. MASK. */
5331	if (mask
5332	&& mask->expr_type == EXPR_CONSTANT
5333	&& !mask->value.logical)
5334	goto finish;
5335
5336	if (array->shape == NULL)
5337	goto finish;
5338
5339	for (i = 0; i < array->rank; i++)
5340	{
5341	count[i] = 0;
5342	sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si (array->shape[i-1]);
5343	extent[i] = mpz_get_si (array->shape[i]);
5344	if (extent[i] <= 0)
5345	goto finish;
5346	}
5347
5348	continue_loop = true;
5349	array_ctor = gfc_constructor_first (base: array->value.constructor);
5350	if (mask && mask->rank > 0)
5351	mask_ctor = gfc_constructor_first (base: mask->value.constructor);
5352	else
5353	mask_ctor = NULL;
5354
5355	/* Loop over the array elements (and mask), keeping track of
5356	the indices to return. */
5357	while (continue_loop)
5358	{
5359	do
5360	{
5361	a = array_ctor->expr;
5362	if (mask_ctor)
5363	{
5364	m = mask_ctor->expr;
5365	ma = m->value.logical;
5366	mask_ctor = gfc_constructor_next (ctor: mask_ctor);
5367	}
5368	else
5369	ma = true;
5370
5371	if (ma && min_max_choose (arg: a, extremum, sign, back_val) > 0)
5372	{
5373	for (i = 0; i<array->rank; i++)
5374	res[i] = count[i];
5375	}
5376	array_ctor = gfc_constructor_next (ctor: array_ctor);
5377	count[0] ++;
5378	} while (count[0] != extent[0]);
5379	n = 0;
5380	do
5381	{
5382	/* When we get to the end of a dimension, reset it and increment
5383	the next dimension. */
5384	count[n] = 0;
5385	n++;
5386	if (n >= array->rank)
5387	{
5388	continue_loop = false;
5389	break;
5390	}
5391	else
5392	count[n] ++;
5393	} while (count[n] == extent[n]);
5394	}
5395
5396	finish:
5397	gfc_free_expr (extremum);
5398	result_ctor = gfc_constructor_first (base: result->value.constructor);
5399	for (i = 0; i<array->rank; i++)
5400	{
5401	gfc_expr *r_expr;
5402	r_expr = result_ctor->expr;
5403	mpz_set_si (r_expr->value.integer, res[i] + 1);
5404	result_ctor = gfc_constructor_next (ctor: result_ctor);
5405	}
5406	return result;
5407	}
5408
5409	/* Helper function for gfc_simplify_minmaxloc - build an array
5410	expression with n elements. */
5411
5412	static gfc_expr *
5413	new_array (bt type, int kind, int n, locus *where)
5414	{
5415	gfc_expr *result;
5416	int i;
5417
5418	result = gfc_get_array_expr (type, kind, where);
5419	result->rank = 1;
5420	result->shape = gfc_get_shape(1);
5421	mpz_init_set_si (result->shape[0], n);
5422	for (i = 0; i < n; i++)
5423	{
5424	gfc_constructor_append_expr (base: &result->value.constructor,
5425	e: gfc_get_constant_expr (type, kind, where),
5426	NULL);
5427	}
5428
5429	return result;
5430	}
5431
5432	/* Simplify minloc and maxloc. This code is mostly identical to
5433	simplify_transformation_to_array. */
5434
5435	static gfc_expr *
5436	simplify_minmaxloc_to_array (gfc_expr *result, gfc_expr *array,
5437	gfc_expr *dim, gfc_expr *mask,
5438	gfc_expr *extremum, int sign, bool back_val)
5439	{
5440	mpz_t size;
5441	int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
5442	gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
5443	gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
5444
5445	int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
5446	sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
5447	tmpstride[GFC_MAX_DIMENSIONS];
5448
5449	/* Shortcut for constant .FALSE. MASK. */
5450	if (mask
5451	&& mask->expr_type == EXPR_CONSTANT
5452	&& !mask->value.logical)
5453	return result;
5454
5455	/* Build an indexed table for array element expressions to minimize
5456	linked-list traversal. Masked elements are set to NULL. */
5457	gfc_array_size (array, &size);
5458	arraysize = mpz_get_ui (gmp_z: size);
5459	mpz_clear (size);
5460
5461	arrayvec = XCNEWVEC (gfc_expr*, arraysize);
5462
5463	array_ctor = gfc_constructor_first (base: array->value.constructor);
5464	mask_ctor = NULL;
5465	if (mask && mask->expr_type == EXPR_ARRAY)
5466	mask_ctor = gfc_constructor_first (base: mask->value.constructor);
5467
5468	for (i = 0; i < arraysize; ++i)
5469	{
5470	arrayvec[i] = array_ctor->expr;
5471	array_ctor = gfc_constructor_next (ctor: array_ctor);
5472
5473	if (mask_ctor)
5474	{
5475	if (!mask_ctor->expr->value.logical)
5476	arrayvec[i] = NULL;
5477
5478	mask_ctor = gfc_constructor_next (ctor: mask_ctor);
5479	}
5480	}
5481
5482	/* Same for the result expression. */
5483	gfc_array_size (result, &size);
5484	resultsize = mpz_get_ui (gmp_z: size);
5485	mpz_clear (size);
5486
5487	resultvec = XCNEWVEC (gfc_expr*, resultsize);
5488	result_ctor = gfc_constructor_first (base: result->value.constructor);
5489	for (i = 0; i < resultsize; ++i)
5490	{
5491	resultvec[i] = result_ctor->expr;
5492	result_ctor = gfc_constructor_next (ctor: result_ctor);
5493	}
5494
5495	gfc_extract_int (dim, &dim_index);
5496	dim_index -= 1; /* zero-base index */
5497	dim_extent = 0;
5498	dim_stride = 0;
5499
5500	for (i = 0, n = 0; i < array->rank; ++i)
5501	{
5502	count[i] = 0;
5503	tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
5504	if (i == dim_index)
5505	{
5506	dim_extent = mpz_get_si (array->shape[i]);
5507	dim_stride = tmpstride[i];
5508	continue;
5509	}
5510
5511	extent[n] = mpz_get_si (array->shape[i]);
5512	sstride[n] = tmpstride[i];
5513	dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
5514	n += 1;
5515	}
5516
5517	done = resultsize <= 0;
5518	base = arrayvec;
5519	dest = resultvec;
5520	while (!done)
5521	{
5522	gfc_expr *ex;
5523	ex = gfc_copy_expr (extremum);
5524	for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
5525	{
5526	if (*src && min_max_choose (arg: *src, extremum: ex, sign, back_val) > 0)
5527	mpz_set_si ((*dest)->value.integer, n + 1);
5528	}
5529
5530	count[0]++;
5531	base += sstride[0];
5532	dest += dstride[0];
5533	gfc_free_expr (ex);
5534
5535	n = 0;
5536	while (!done && count[n] == extent[n])
5537	{
5538	count[n] = 0;
5539	base -= sstride[n] * extent[n];
5540	dest -= dstride[n] * extent[n];
5541
5542	n++;
5543	if (n < result->rank)
5544	{
5545	/* If the nested loop is unrolled GFC_MAX_DIMENSIONS
5546	times, we'd warn for the last iteration, because the
5547	array index will have already been incremented to the
5548	array sizes, and we can't tell that this must make
5549	the test against result->rank false, because ranks
5550	must not exceed GFC_MAX_DIMENSIONS. */
5551	GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds)
5552	count[n]++;
5553	base += sstride[n];
5554	dest += dstride[n];
5555	GCC_DIAGNOSTIC_POP
5556	}
5557	else
5558	done = true;
5559	}
5560	}
5561
5562	/* Place updated expression in result constructor. */
5563	result_ctor = gfc_constructor_first (base: result->value.constructor);
5564	for (i = 0; i < resultsize; ++i)
5565	{
5566	result_ctor->expr = resultvec[i];
5567	result_ctor = gfc_constructor_next (ctor: result_ctor);
5568	}
5569
5570	free (ptr: arrayvec);
5571	free (ptr: resultvec);
5572	free (ptr: extremum);
5573	return result;
5574	}
5575
5576	/* Simplify minloc and maxloc for constant arrays. */
5577
5578	static gfc_expr *
5579	gfc_simplify_minmaxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask,
5580	gfc_expr *kind, gfc_expr *back, int sign)
5581	{
5582	gfc_expr *result;
5583	gfc_expr *extremum;
5584	int ikind;
5585	int init_val;
5586	bool back_val = false;
5587
5588	if (!is_constant_array_expr (e: array)
5589	|| !gfc_is_constant_expr (dim))
5590	return NULL;
5591
5592	if (mask
5593	&& !is_constant_array_expr (e: mask)
5594	&& mask->expr_type != EXPR_CONSTANT)
5595	return NULL;
5596
5597	if (kind)
5598	{
5599	if (gfc_extract_int (kind, &ikind, -1))
5600	return NULL;
5601	}
5602	else
5603	ikind = gfc_default_integer_kind;
5604
5605	if (back)
5606	{
5607	if (back->expr_type != EXPR_CONSTANT)
5608	return NULL;
5609
5610	back_val = back->value.logical;
5611	}
5612
5613	if (sign < 0)
5614	init_val = INT_MAX;
5615	else if (sign > 0)
5616	init_val = INT_MIN;
5617	else
5618	gcc_unreachable();
5619
5620	extremum = gfc_get_constant_expr (array->ts.type, array->ts.kind, &array->where);
5621	init_result_expr (e: extremum, init: init_val, array);
5622
5623	if (dim)
5624	{
5625	result = transformational_result (array, dim, type: BT_INTEGER,
5626	kind: ikind, where: &array->where);
5627	init_result_expr (e: result, init: 0, array);
5628
5629	if (array->rank == 1)
5630	return simplify_minmaxloc_to_scalar (result, array, mask, extremum,
5631	sign, back_val);
5632	else
5633	return simplify_minmaxloc_to_array (result, array, dim, mask, extremum,
5634	sign, back_val);
5635	}
5636	else
5637	{
5638	result = new_array (type: BT_INTEGER, kind: ikind, n: array->rank, where: &array->where);
5639	return simplify_minmaxloc_nodim (result, extremum, array, mask,
5640	sign, back_val);
5641	}
5642	}
5643
5644	gfc_expr *
5645	gfc_simplify_minloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind,
5646	gfc_expr *back)
5647	{
5648	return gfc_simplify_minmaxloc (array, dim, mask, kind, back, sign: -1);
5649	}
5650
5651	gfc_expr *
5652	gfc_simplify_maxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind,
5653	gfc_expr *back)
5654	{
5655	return gfc_simplify_minmaxloc (array, dim, mask, kind, back, sign: 1);
5656	}
5657
5658	/* Simplify findloc to scalar. Similar to
5659	simplify_minmaxloc_to_scalar. */
5660
5661	static gfc_expr *
5662	simplify_findloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *value,
5663	gfc_expr *mask, int back_val)
5664	{
5665	gfc_expr *a, *m;
5666	gfc_constructor *array_ctor, *mask_ctor;
5667	mpz_t count;
5668
5669	mpz_set_si (result->value.integer, 0);
5670
5671	/* Shortcut for constant .FALSE. MASK. */
5672	if (mask
5673	&& mask->expr_type == EXPR_CONSTANT
5674	&& !mask->value.logical)
5675	return result;
5676
5677	array_ctor = gfc_constructor_first (base: array->value.constructor);
5678	if (mask && mask->expr_type == EXPR_ARRAY)
5679	mask_ctor = gfc_constructor_first (base: mask->value.constructor);
5680	else
5681	mask_ctor = NULL;
5682
5683	mpz_init_set_si (count, 0);
5684	while (array_ctor)
5685	{
5686	mpz_add_ui (count, count, 1);
5687	a = array_ctor->expr;
5688	array_ctor = gfc_constructor_next (ctor: array_ctor);
5689	/* A constant MASK equals .TRUE. here and can be ignored. */
5690	if (mask_ctor)
5691	{
5692	m = mask_ctor->expr;
5693	mask_ctor = gfc_constructor_next (ctor: mask_ctor);
5694	if (!m->value.logical)
5695	continue;
5696	}
5697	if (gfc_compare_expr (a, value, INTRINSIC_EQ) == 0)
5698	{
5699	/* We have a match. If BACK is true, continue so we find
5700	the last one. */
5701	mpz_set (result->value.integer, count);
5702	if (!back_val)
5703	break;
5704	}
5705	}
5706	mpz_clear (count);
5707	return result;
5708	}
5709
5710	/* Simplify findloc in the absence of a dim argument. Similar to
5711	simplify_minmaxloc_nodim. */
5712
5713	static gfc_expr *
5714	simplify_findloc_nodim (gfc_expr *result, gfc_expr *value, gfc_expr *array,
5715	gfc_expr *mask, bool back_val)
5716	{
5717	ssize_t res[GFC_MAX_DIMENSIONS];
5718	int i, n;
5719	gfc_constructor *result_ctor, *array_ctor, *mask_ctor;
5720	ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
5721	sstride[GFC_MAX_DIMENSIONS];
5722	gfc_expr *a, *m;
5723	bool continue_loop;
5724	bool ma;
5725
5726	for (i = 0; i < array->rank; i++)
5727	res[i] = -1;
5728
5729	/* Shortcut for constant .FALSE. MASK. */
5730	if (mask
5731	&& mask->expr_type == EXPR_CONSTANT
5732	&& !mask->value.logical)
5733	goto finish;
5734
5735	for (i = 0; i < array->rank; i++)
5736	{
5737	count[i] = 0;
5738	sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si (array->shape[i-1]);
5739	extent[i] = mpz_get_si (array->shape[i]);
5740	if (extent[i] <= 0)
5741	goto finish;
5742	}
5743
5744	continue_loop = true;
5745	array_ctor = gfc_constructor_first (base: array->value.constructor);
5746	if (mask && mask->rank > 0)
5747	mask_ctor = gfc_constructor_first (base: mask->value.constructor);
5748	else
5749	mask_ctor = NULL;
5750
5751	/* Loop over the array elements (and mask), keeping track of
5752	the indices to return. */
5753	while (continue_loop)
5754	{
5755	do
5756	{
5757	a = array_ctor->expr;
5758	if (mask_ctor)
5759	{
5760	m = mask_ctor->expr;
5761	ma = m->value.logical;
5762	mask_ctor = gfc_constructor_next (ctor: mask_ctor);
5763	}
5764	else
5765	ma = true;
5766
5767	if (ma && gfc_compare_expr (a, value, INTRINSIC_EQ) == 0)
5768	{
5769	for (i = 0; i < array->rank; i++)
5770	res[i] = count[i];
5771	if (!back_val)
5772	goto finish;
5773	}
5774	array_ctor = gfc_constructor_next (ctor: array_ctor);
5775	count[0] ++;
5776	} while (count[0] != extent[0]);
5777	n = 0;
5778	do
5779	{
5780	/* When we get to the end of a dimension, reset it and increment
5781	the next dimension. */
5782	count[n] = 0;
5783	n++;
5784	if (n >= array->rank)
5785	{
5786	continue_loop = false;
5787	break;
5788	}
5789	else
5790	count[n] ++;
5791	} while (count[n] == extent[n]);
5792	}
5793
5794	finish:
5795	result_ctor = gfc_constructor_first (base: result->value.constructor);
5796	for (i = 0; i < array->rank; i++)
5797	{
5798	gfc_expr *r_expr;
5799	r_expr = result_ctor->expr;
5800	mpz_set_si (r_expr->value.integer, res[i] + 1);
5801	result_ctor = gfc_constructor_next (ctor: result_ctor);
5802	}
5803	return result;
5804	}
5805
5806
5807	/* Simplify findloc to an array. Similar to
5808	simplify_minmaxloc_to_array. */
5809
5810	static gfc_expr *
5811	simplify_findloc_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *value,
5812	gfc_expr *dim, gfc_expr *mask, bool back_val)
5813	{
5814	mpz_t size;
5815	int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
5816	gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
5817	gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
5818
5819	int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
5820	sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
5821	tmpstride[GFC_MAX_DIMENSIONS];
5822
5823	/* Shortcut for constant .FALSE. MASK. */
5824	if (mask
5825	&& mask->expr_type == EXPR_CONSTANT
5826	&& !mask->value.logical)
5827	return result;
5828
5829	/* Build an indexed table for array element expressions to minimize
5830	linked-list traversal. Masked elements are set to NULL. */
5831	gfc_array_size (array, &size);
5832	arraysize = mpz_get_ui (gmp_z: size);
5833	mpz_clear (size);
5834
5835	arrayvec = XCNEWVEC (gfc_expr*, arraysize);
5836
5837	array_ctor = gfc_constructor_first (base: array->value.constructor);
5838	mask_ctor = NULL;
5839	if (mask && mask->expr_type == EXPR_ARRAY)
5840	mask_ctor = gfc_constructor_first (base: mask->value.constructor);
5841
5842	for (i = 0; i < arraysize; ++i)
5843	{
5844	arrayvec[i] = array_ctor->expr;
5845	array_ctor = gfc_constructor_next (ctor: array_ctor);
5846
5847	if (mask_ctor)
5848	{
5849	if (!mask_ctor->expr->value.logical)
5850	arrayvec[i] = NULL;
5851
5852	mask_ctor = gfc_constructor_next (ctor: mask_ctor);
5853	}
5854	}
5855
5856	/* Same for the result expression. */
5857	gfc_array_size (result, &size);
5858	resultsize = mpz_get_ui (gmp_z: size);
5859	mpz_clear (size);
5860
5861	resultvec = XCNEWVEC (gfc_expr*, resultsize);
5862	result_ctor = gfc_constructor_first (base: result->value.constructor);
5863	for (i = 0; i < resultsize; ++i)
5864	{
5865	resultvec[i] = result_ctor->expr;
5866	result_ctor = gfc_constructor_next (ctor: result_ctor);
5867	}
5868
5869	gfc_extract_int (dim, &dim_index);
5870
5871	dim_index -= 1; /* Zero-base index. */
5872	dim_extent = 0;
5873	dim_stride = 0;
5874
5875	for (i = 0, n = 0; i < array->rank; ++i)
5876	{
5877	count[i] = 0;
5878	tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
5879	if (i == dim_index)
5880	{
5881	dim_extent = mpz_get_si (array->shape[i]);
5882	dim_stride = tmpstride[i];
5883	continue;
5884	}
5885
5886	extent[n] = mpz_get_si (array->shape[i]);
5887	sstride[n] = tmpstride[i];
5888	dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
5889	n += 1;
5890	}
5891
5892	done = resultsize <= 0;
5893	base = arrayvec;
5894	dest = resultvec;
5895	while (!done)
5896	{
5897	for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
5898	{
5899	if (*src && gfc_compare_expr (*src, value, INTRINSIC_EQ) == 0)
5900	{
5901	mpz_set_si ((*dest)->value.integer, n + 1);
5902	if (!back_val)
5903	break;
5904	}
5905	}
5906
5907	count[0]++;
5908	base += sstride[0];
5909	dest += dstride[0];
5910
5911	n = 0;
5912	while (!done && count[n] == extent[n])
5913	{
5914	count[n] = 0;
5915	base -= sstride[n] * extent[n];
5916	dest -= dstride[n] * extent[n];
5917
5918	n++;
5919	if (n < result->rank)
5920	{
5921	/* If the nested loop is unrolled GFC_MAX_DIMENSIONS
5922	times, we'd warn for the last iteration, because the
5923	array index will have already been incremented to the
5924	array sizes, and we can't tell that this must make
5925	the test against result->rank false, because ranks
5926	must not exceed GFC_MAX_DIMENSIONS. */
5927	GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds)
5928	count[n]++;
5929	base += sstride[n];
5930	dest += dstride[n];
5931	GCC_DIAGNOSTIC_POP
5932	}
5933	else
5934	done = true;
5935	}
5936	}
5937
5938	/* Place updated expression in result constructor. */
5939	result_ctor = gfc_constructor_first (base: result->value.constructor);
5940	for (i = 0; i < resultsize; ++i)
5941	{
5942	result_ctor->expr = resultvec[i];
5943	result_ctor = gfc_constructor_next (ctor: result_ctor);
5944	}
5945
5946	free (ptr: arrayvec);
5947	free (ptr: resultvec);
5948	return result;
5949	}
5950
5951	/* Simplify findloc. */
5952
5953	gfc_expr *
5954	gfc_simplify_findloc (gfc_expr *array, gfc_expr *value, gfc_expr *dim,
5955	gfc_expr *mask, gfc_expr *kind, gfc_expr *back)
5956	{
5957	gfc_expr *result;
5958	int ikind;
5959	bool back_val = false;
5960
5961	if (!is_constant_array_expr (e: array)
5962	|| array->shape == NULL
5963	|| !gfc_is_constant_expr (dim))
5964	return NULL;
5965
5966	if (! gfc_is_constant_expr (value))
5967	return 0;
5968
5969	if (mask
5970	&& !is_constant_array_expr (e: mask)
5971	&& mask->expr_type != EXPR_CONSTANT)
5972	return NULL;
5973
5974	if (kind)
5975	{
5976	if (gfc_extract_int (kind, &ikind, -1))
5977	return NULL;
5978	}
5979	else
5980	ikind = gfc_default_integer_kind;
5981
5982	if (back)
5983	{
5984	if (back->expr_type != EXPR_CONSTANT)
5985	return NULL;
5986
5987	back_val = back->value.logical;
5988	}
5989
5990	if (dim)
5991	{
5992	result = transformational_result (array, dim, type: BT_INTEGER,
5993	kind: ikind, where: &array->where);
5994	init_result_expr (e: result, init: 0, array);
5995
5996	if (array->rank == 1)
5997	return simplify_findloc_to_scalar (result, array, value, mask,
5998	back_val);
5999	else
6000	return simplify_findloc_to_array (result, array, value, dim, mask,
6001	back_val);
6002	}
6003	else
6004	{
6005	result = new_array (type: BT_INTEGER, kind: ikind, n: array->rank, where: &array->where);
6006	return simplify_findloc_nodim (result, value, array, mask, back_val);
6007	}
6008	return NULL;
6009	}
6010
6011	gfc_expr *
6012	gfc_simplify_maxexponent (gfc_expr *x)
6013	{
6014	int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
6015	return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
6016	gfc_real_kinds[i].max_exponent);
6017	}
6018
6019
6020	gfc_expr *
6021	gfc_simplify_minexponent (gfc_expr *x)
6022	{
6023	int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
6024	return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
6025	gfc_real_kinds[i].min_exponent);
6026	}
6027
6028
6029	gfc_expr *
6030	gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
6031	{
6032	gfc_expr *result;
6033	int kind;
6034
6035	/* First check p. */
6036	if (p->expr_type != EXPR_CONSTANT)
6037	return NULL;
6038
6039	/* p shall not be 0. */
6040	switch (p->ts.type)
6041	{
6042	case BT_INTEGER:
6043	if (mpz_cmp_ui (p->value.integer, 0) == 0)
6044	{
6045	gfc_error ("Argument %qs of MOD at %L shall not be zero",
6046	"P", &p->where);
6047	return &gfc_bad_expr;
6048	}
6049	break;
6050	case BT_REAL:
6051	if (mpfr_cmp_ui (p->value.real, 0) == 0)
6052	{
6053	gfc_error ("Argument %qs of MOD at %L shall not be zero",
6054	"P", &p->where);
6055	return &gfc_bad_expr;
6056	}
6057	break;
6058	default:
6059	gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
6060	}
6061
6062	if (a->expr_type != EXPR_CONSTANT)
6063	return NULL;
6064
6065	kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
6066	result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
6067
6068	if (a->ts.type == BT_INTEGER)
6069	mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
6070	else
6071	{
6072	gfc_set_model_kind (kind);
6073	mpfr_fmod (result->value.real, a->value.real, p->value.real,
6074	GFC_RND_MODE);
6075	}
6076
6077	return range_check (result, name: "MOD");
6078	}
6079
6080
6081	gfc_expr *
6082	gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
6083	{
6084	gfc_expr *result;
6085	int kind;
6086
6087	/* First check p. */
6088	if (p->expr_type != EXPR_CONSTANT)
6089	return NULL;
6090
6091	/* p shall not be 0. */
6092	switch (p->ts.type)
6093	{
6094	case BT_INTEGER:
6095	if (mpz_cmp_ui (p->value.integer, 0) == 0)
6096	{
6097	gfc_error ("Argument %qs of MODULO at %L shall not be zero",
6098	"P", &p->where);
6099	return &gfc_bad_expr;
6100	}
6101	break;
6102	case BT_REAL:
6103	if (mpfr_cmp_ui (p->value.real, 0) == 0)
6104	{
6105	gfc_error ("Argument %qs of MODULO at %L shall not be zero",
6106	"P", &p->where);
6107	return &gfc_bad_expr;
6108	}
6109	break;
6110	default:
6111	gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
6112	}
6113
6114	if (a->expr_type != EXPR_CONSTANT)
6115	return NULL;
6116
6117	kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
6118	result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
6119
6120	if (a->ts.type == BT_INTEGER)
6121	mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
6122	else
6123	{
6124	gfc_set_model_kind (kind);
6125	mpfr_fmod (result->value.real, a->value.real, p->value.real,
6126	GFC_RND_MODE);
6127	if (mpfr_cmp_ui (result->value.real, 0) != 0)
6128	{
6129	if (mpfr_signbit (a->value.real) != mpfr_signbit (p->value.real))
6130	mpfr_add (result->value.real, result->value.real, p->value.real,
6131	GFC_RND_MODE);
6132	}
6133	else
6134	mpfr_copysign (result->value.real, result->value.real,
6135	p->value.real, GFC_RND_MODE);
6136	}
6137
6138	return range_check (result, name: "MODULO");
6139	}
6140
6141
6142	gfc_expr *
6143	gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
6144	{
6145	gfc_expr *result;
6146	mpfr_exp_t emin, emax;
6147	int kind;
6148
6149	if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
6150	return NULL;
6151
6152	result = gfc_copy_expr (x);
6153
6154	/* Save current values of emin and emax. */
6155	emin = mpfr_get_emin ();
6156	emax = mpfr_get_emax ();
6157
6158	/* Set emin and emax for the current model number. */
6159	kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
6160	mpfr_set_emin ((mpfr_exp_t) gfc_real_kinds[kind].min_exponent -
6161	mpfr_get_prec(result->value.real) + 1);
6162	mpfr_set_emax ((mpfr_exp_t) gfc_real_kinds[kind].max_exponent);
6163	mpfr_check_range (result->value.real, 0, MPFR_RNDU);
6164
6165	if (mpfr_sgn (s->value.real) > 0)
6166	{
6167	mpfr_nextabove (result->value.real);
6168	mpfr_subnormalize (result->value.real, 0, MPFR_RNDU);
6169	}
6170	else
6171	{
6172	mpfr_nextbelow (result->value.real);
6173	mpfr_subnormalize (result->value.real, 0, MPFR_RNDD);
6174	}
6175
6176	mpfr_set_emin (emin);
6177	mpfr_set_emax (emax);
6178
6179	/* Only NaN can occur. Do not use range check as it gives an
6180	error for denormal numbers. */
6181	if (mpfr_nan_p (result->value.real) && flag_range_check)
6182	{
6183	gfc_error ("Result of NEAREST is NaN at %L", &result->where);
6184	gfc_free_expr (result);
6185	return &gfc_bad_expr;
6186	}
6187
6188	return result;
6189	}
6190
6191
6192	static gfc_expr *
6193	simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
6194	{
6195	gfc_expr *itrunc, *result;
6196	int kind;
6197
6198	kind = get_kind (type: BT_INTEGER, k, name, default_kind: gfc_default_integer_kind);
6199	if (kind == -1)
6200	return &gfc_bad_expr;
6201
6202	if (e->expr_type != EXPR_CONSTANT)
6203	return NULL;
6204
6205	itrunc = gfc_copy_expr (e);
6206	mpfr_round (itrunc->value.real, e->value.real);
6207
6208	result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
6209	gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);
6210
6211	gfc_free_expr (itrunc);
6212
6213	return range_check (result, name);
6214	}
6215
6216
6217	gfc_expr *
6218	gfc_simplify_new_line (gfc_expr *e)
6219	{
6220	gfc_expr *result;
6221
6222	result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len: 1);
6223	result->value.character.string[0] = '\n';
6224
6225	return result;
6226	}
6227
6228
6229	gfc_expr *
6230	gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
6231	{
6232	return simplify_nint (name: "NINT", e, k);
6233	}
6234
6235
6236	gfc_expr *
6237	gfc_simplify_idnint (gfc_expr *e)
6238	{
6239	return simplify_nint (name: "IDNINT", e, NULL);
6240	}
6241
6242	static int norm2_scale;
6243
6244	static gfc_expr *
6245	norm2_add_squared (gfc_expr *result, gfc_expr *e)
6246	{
6247	mpfr_t tmp;
6248
6249	gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
6250	gcc_assert (result->ts.type == BT_REAL
6251	&& result->expr_type == EXPR_CONSTANT);
6252
6253	gfc_set_model_kind (result->ts.kind);
6254	int index = gfc_validate_kind (BT_REAL, result->ts.kind, false);
6255	mpfr_exp_t exp;
6256	if (mpfr_regular_p (result->value.real))
6257	{
6258	exp = mpfr_get_exp (result->value.real);
6259	/* If result is getting close to overflowing, scale down. */
6260	if (exp >= gfc_real_kinds[index].max_exponent - 4
6261	&& norm2_scale <= gfc_real_kinds[index].max_exponent - 2)
6262	{
6263	norm2_scale += 2;
6264	mpfr_div_ui (result->value.real, result->value.real, 16,
6265	GFC_RND_MODE);
6266	}
6267	}
6268
6269	mpfr_init (tmp);
6270	if (mpfr_regular_p (e->value.real))
6271	{
6272	exp = mpfr_get_exp (e->value.real);
6273	/* If e**2 would overflow or close to overflowing, scale down. */
6274	if (exp - norm2_scale >= gfc_real_kinds[index].max_exponent / 2 - 2)
6275	{
6276	int new_scale = gfc_real_kinds[index].max_exponent / 2 + 4;
6277	mpfr_set_ui (tmp, 1, GFC_RND_MODE);
6278	mpfr_set_exp (tmp, new_scale - norm2_scale);
6279	mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODE);
6280	mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODE);
6281	norm2_scale = new_scale;
6282	}
6283	}
6284	if (norm2_scale)
6285	{
6286	mpfr_set_ui (tmp, 1, GFC_RND_MODE);
6287	mpfr_set_exp (tmp, norm2_scale);
6288	mpfr_div (tmp, e->value.real, tmp, GFC_RND_MODE);
6289	}
6290	else
6291	mpfr_set (tmp, e->value.real, GFC_RND_MODE);
6292	mpfr_pow_ui (tmp, tmp, 2, GFC_RND_MODE);
6293	mpfr_add (result->value.real, result->value.real, tmp,
6294	GFC_RND_MODE);
6295	mpfr_clear (tmp);
6296
6297	return result;
6298	}
6299
6300
6301	static gfc_expr *
6302	norm2_do_sqrt (gfc_expr *result, gfc_expr *e)
6303	{
6304	gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
6305	gcc_assert (result->ts.type == BT_REAL
6306	&& result->expr_type == EXPR_CONSTANT);
6307
6308	if (result != e)
6309	mpfr_set (result->value.real, e->value.real, GFC_RND_MODE);
6310	mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
6311	if (norm2_scale && mpfr_regular_p (result->value.real))
6312	{
6313	mpfr_t tmp;
6314	mpfr_init (tmp);
6315	mpfr_set_ui (tmp, 1, GFC_RND_MODE);
6316	mpfr_set_exp (tmp, norm2_scale);
6317	mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODE);
6318	mpfr_clear (tmp);
6319	}
6320	norm2_scale = 0;
6321
6322	return result;
6323	}
6324
6325
6326	gfc_expr *
6327	gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim)
6328	{
6329	gfc_expr *result;
6330	bool size_zero;
6331
6332	size_zero = gfc_is_size_zero_array (array: e);
6333
6334	if (!(is_constant_array_expr (e) || size_zero)
6335	|| (dim != NULL && !gfc_is_constant_expr (dim)))
6336	return NULL;
6337
6338	result = transformational_result (array: e, dim, type: e->ts.type, kind: e->ts.kind, where: &e->where);
6339	init_result_expr (e: result, init: 0, NULL);
6340
6341	if (size_zero)
6342	return result;
6343
6344	norm2_scale = 0;
6345	if (!dim || e->rank == 1)
6346	{
6347	result = simplify_transformation_to_scalar (result, array: e, NULL,
6348	op: norm2_add_squared);
6349	mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
6350	if (norm2_scale && mpfr_regular_p (result->value.real))
6351	{
6352	mpfr_t tmp;
6353	mpfr_init (tmp);
6354	mpfr_set_ui (tmp, 1, GFC_RND_MODE);
6355	mpfr_set_exp (tmp, norm2_scale);
6356	mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODE);
6357	mpfr_clear (tmp);
6358	}
6359	norm2_scale = 0;
6360	}
6361	else
6362	result = simplify_transformation_to_array (result, array: e, dim, NULL,
6363	op: norm2_add_squared,
6364	post_op: norm2_do_sqrt);
6365
6366	return result;
6367	}
6368
6369
6370	gfc_expr *
6371	gfc_simplify_not (gfc_expr *e)
6372	{
6373	gfc_expr *result;
6374
6375	if (e->expr_type != EXPR_CONSTANT)
6376	return NULL;
6377
6378	result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
6379	mpz_com (result->value.integer, e->value.integer);
6380
6381	return range_check (result, name: "NOT");
6382	}
6383
6384
6385	gfc_expr *
6386	gfc_simplify_null (gfc_expr *mold)
6387	{
6388	gfc_expr *result;
6389
6390	if (mold)
6391	{
6392	result = gfc_copy_expr (mold);
6393	result->expr_type = EXPR_NULL;
6394	}
6395	else
6396	result = gfc_get_null_expr (NULL);
6397
6398	return result;
6399	}
6400
6401
6402	gfc_expr *
6403	gfc_simplify_num_images (gfc_expr *distance ATTRIBUTE_UNUSED, gfc_expr *failed)
6404	{
6405	gfc_expr *result;
6406
6407	if (flag_coarray == GFC_FCOARRAY_NONE)
6408	{
6409	gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6410	return &gfc_bad_expr;
6411	}
6412
6413	if (flag_coarray != GFC_FCOARRAY_SINGLE)
6414	return NULL;
6415
6416	if (failed && failed->expr_type != EXPR_CONSTANT)
6417	return NULL;
6418
6419	/* FIXME: gfc_current_locus is wrong. */
6420	result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
6421	&gfc_current_locus);
6422
6423	if (failed && failed->value.logical != 0)
6424	mpz_set_si (result->value.integer, 0);
6425	else
6426	mpz_set_si (result->value.integer, 1);
6427
6428	return result;
6429	}
6430
6431
6432	gfc_expr *
6433	gfc_simplify_or (gfc_expr *x, gfc_expr *y)
6434	{
6435	gfc_expr *result;
6436	int kind;
6437
6438	if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
6439	return NULL;
6440
6441	kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
6442
6443	switch (x->ts.type)
6444	{
6445	case BT_INTEGER:
6446	result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
6447	mpz_ior (result->value.integer, x->value.integer, y->value.integer);
6448	return range_check (result, name: "OR");
6449
6450	case BT_LOGICAL:
6451	return gfc_get_logical_expr (kind, &x->where,
6452	x->value.logical || y->value.logical);
6453	default:
6454	gcc_unreachable();
6455	}
6456	}
6457
6458
6459	gfc_expr *
6460	gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
6461	{
6462	gfc_expr *result;
6463	gfc_constructor *array_ctor, *mask_ctor, *vector_ctor;
6464
6465	if (!is_constant_array_expr (e: array)
6466	|| !is_constant_array_expr (e: vector)
6467	|| (!gfc_is_constant_expr (mask)
6468	&& !is_constant_array_expr (e: mask)))
6469	return NULL;
6470
6471	result = gfc_get_array_expr (type: array->ts.type, kind: array->ts.kind, &array->where);
6472	if (array->ts.type == BT_DERIVED)
6473	result->ts.u.derived = array->ts.u.derived;
6474
6475	array_ctor = gfc_constructor_first (base: array->value.constructor);
6476	vector_ctor = vector
6477	? gfc_constructor_first (base: vector->value.constructor)
6478	: NULL;
6479
6480	if (mask->expr_type == EXPR_CONSTANT
6481	&& mask->value.logical)
6482	{
6483	/* Copy all elements of ARRAY to RESULT. */
6484	while (array_ctor)
6485	{
6486	gfc_constructor_append_expr (base: &result->value.constructor,
6487	e: gfc_copy_expr (array_ctor->expr),
6488	NULL);
6489
6490	array_ctor = gfc_constructor_next (ctor: array_ctor);
6491	vector_ctor = gfc_constructor_next (ctor: vector_ctor);
6492	}
6493	}
6494	else if (mask->expr_type == EXPR_ARRAY)
6495	{
6496	/* Copy only those elements of ARRAY to RESULT whose
6497	MASK equals .TRUE.. */
6498	mask_ctor = gfc_constructor_first (base: mask->value.constructor);
6499	while (mask_ctor && array_ctor)
6500	{
6501	if (mask_ctor->expr->value.logical)
6502	{
6503	gfc_constructor_append_expr (base: &result->value.constructor,
6504	e: gfc_copy_expr (array_ctor->expr),
6505	NULL);
6506	vector_ctor = gfc_constructor_next (ctor: vector_ctor);
6507	}
6508
6509	array_ctor = gfc_constructor_next (ctor: array_ctor);
6510	mask_ctor = gfc_constructor_next (ctor: mask_ctor);
6511	}
6512	}
6513
6514	/* Append any left-over elements from VECTOR to RESULT. */
6515	while (vector_ctor)
6516	{
6517	gfc_constructor_append_expr (base: &result->value.constructor,
6518	e: gfc_copy_expr (vector_ctor->expr),
6519	NULL);
6520	vector_ctor = gfc_constructor_next (ctor: vector_ctor);
6521	}
6522
6523	result->shape = gfc_get_shape (1);
6524	gfc_array_size (result, &result->shape[0]);
6525
6526	if (array->ts.type == BT_CHARACTER)
6527	result->ts.u.cl = array->ts.u.cl;
6528
6529	return result;
6530	}
6531
6532
6533	static gfc_expr *
6534	do_xor (gfc_expr *result, gfc_expr *e)
6535	{
6536	gcc_assert (e->ts.type == BT_LOGICAL && e->expr_type == EXPR_CONSTANT);
6537	gcc_assert (result->ts.type == BT_LOGICAL
6538	&& result->expr_type == EXPR_CONSTANT);
6539
6540	result->value.logical = result->value.logical != e->value.logical;
6541	return result;
6542	}
6543
6544
6545	gfc_expr *
6546	gfc_simplify_is_contiguous (gfc_expr *array)
6547	{
6548	if (gfc_is_simply_contiguous (array, false, true))
6549	return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 1);
6550
6551	if (gfc_is_not_contiguous (array))
6552	return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 0);
6553
6554	return NULL;
6555	}
6556
6557
6558	gfc_expr *
6559	gfc_simplify_parity (gfc_expr *e, gfc_expr *dim)
6560	{
6561	return simplify_transformation (array: e, dim, NULL, init_val: 0, op: do_xor);
6562	}
6563
6564
6565	gfc_expr *
6566	gfc_simplify_popcnt (gfc_expr *e)
6567	{
6568	int res, k;
6569	mpz_t x;
6570
6571	if (e->expr_type != EXPR_CONSTANT)
6572	return NULL;
6573
6574	k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
6575
6576	/* Convert argument to unsigned, then count the '1' bits. */
6577	mpz_init_set (x, e->value.integer);
6578	convert_mpz_to_unsigned (x, bitsize: gfc_integer_kinds[k].bit_size);
6579	res = mpz_popcount (gmp_u: x);
6580	mpz_clear (x);
6581
6582	return gfc_get_int_expr (gfc_default_integer_kind, &e->where, res);
6583	}
6584
6585
6586	gfc_expr *
6587	gfc_simplify_poppar (gfc_expr *e)
6588	{
6589	gfc_expr *popcnt;
6590	int i;
6591
6592	if (e->expr_type != EXPR_CONSTANT)
6593	return NULL;
6594
6595	popcnt = gfc_simplify_popcnt (e);
6596	gcc_assert (popcnt);
6597
6598	bool fail = gfc_extract_int (popcnt, &i);
6599	gcc_assert (!fail);
6600
6601	return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i % 2);
6602	}
6603
6604
6605	gfc_expr *
6606	gfc_simplify_precision (gfc_expr *e)
6607	{
6608	int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
6609	return gfc_get_int_expr (gfc_default_integer_kind, &e->where,
6610	gfc_real_kinds[i].precision);
6611	}
6612
6613
6614	gfc_expr *
6615	gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
6616	{
6617	return simplify_transformation (array, dim, mask, init_val: 1, op: gfc_multiply);
6618	}
6619
6620
6621	gfc_expr *
6622	gfc_simplify_radix (gfc_expr *e)
6623	{
6624	int i;
6625	i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
6626
6627	switch (e->ts.type)
6628	{
6629	case BT_INTEGER:
6630	i = gfc_integer_kinds[i].radix;
6631	break;
6632
6633	case BT_REAL:
6634	i = gfc_real_kinds[i].radix;
6635	break;
6636
6637	default:
6638	gcc_unreachable ();
6639	}
6640
6641	return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
6642	}
6643
6644
6645	gfc_expr *
6646	gfc_simplify_range (gfc_expr *e)
6647	{
6648	int i;
6649	i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
6650
6651	switch (e->ts.type)
6652	{
6653	case BT_INTEGER:
6654	i = gfc_integer_kinds[i].range;
6655	break;
6656
6657	case BT_REAL:
6658	case BT_COMPLEX:
6659	i = gfc_real_kinds[i].range;
6660	break;
6661
6662	default:
6663	gcc_unreachable ();
6664	}
6665
6666	return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
6667	}
6668
6669
6670	gfc_expr *
6671	gfc_simplify_rank (gfc_expr *e)
6672	{
6673	/* Assumed rank. */
6674	if (e->rank == -1)
6675	return NULL;
6676
6677	return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank);
6678	}
6679
6680
6681	gfc_expr *
6682	gfc_simplify_real (gfc_expr *e, gfc_expr *k)
6683	{
6684	gfc_expr *result = NULL;
6685	int kind, tmp1, tmp2;
6686
6687	/* Convert BOZ to real, and return without range checking. */
6688	if (e->ts.type == BT_BOZ)
6689	{
6690	/* Determine kind for conversion of the BOZ. */
6691	if (k)
6692	gfc_extract_int (k, &kind);
6693	else
6694	kind = gfc_default_real_kind;
6695
6696	if (!gfc_boz2real (e, kind))
6697	return NULL;
6698	result = gfc_copy_expr (e);
6699	return result;
6700	}
6701
6702	if (e->ts.type == BT_COMPLEX)
6703	kind = get_kind (type: BT_REAL, k, name: "REAL", default_kind: e->ts.kind);
6704	else
6705	kind = get_kind (type: BT_REAL, k, name: "REAL", default_kind: gfc_default_real_kind);
6706
6707	if (kind == -1)
6708	return &gfc_bad_expr;
6709
6710	if (e->expr_type != EXPR_CONSTANT)
6711	return NULL;
6712
6713	/* For explicit conversion, turn off -Wconversion and -Wconversion-extra
6714	warnings. */
6715	tmp1 = warn_conversion;
6716	tmp2 = warn_conversion_extra;
6717	warn_conversion = warn_conversion_extra = 0;
6718
6719	result = gfc_convert_constant (e, BT_REAL, kind);
6720
6721	warn_conversion = tmp1;
6722	warn_conversion_extra = tmp2;
6723
6724	if (result == &gfc_bad_expr)
6725	return &gfc_bad_expr;
6726
6727	return range_check (result, name: "REAL");
6728	}
6729
6730
6731	gfc_expr *
6732	gfc_simplify_realpart (gfc_expr *e)
6733	{
6734	gfc_expr *result;
6735
6736	if (e->expr_type != EXPR_CONSTANT)
6737	return NULL;
6738
6739	result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
6740	mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
6741
6742	return range_check (result, name: "REALPART");
6743	}
6744
6745	gfc_expr *
6746	gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
6747	{
6748	gfc_expr *result;
6749	gfc_charlen_t len;
6750	mpz_t ncopies;
6751	bool have_length = false;
6752
6753	/* If NCOPIES isn't a constant, there's nothing we can do. */
6754	if (n->expr_type != EXPR_CONSTANT)
6755	return NULL;
6756
6757	/* If NCOPIES is negative, it's an error. */
6758	if (mpz_sgn (n->value.integer) < 0)
6759	{
6760	gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
6761	&n->where);
6762	return &gfc_bad_expr;
6763	}
6764
6765	/* If we don't know the character length, we can do no more. */
6766	if (e->ts.u.cl && e->ts.u.cl->length
6767	&& e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
6768	{
6769	len = gfc_mpz_get_hwi (e->ts.u.cl->length->value.integer);
6770	have_length = true;
6771	}
6772	else if (e->expr_type == EXPR_CONSTANT
6773	&& (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
6774	{
6775	len = e->value.character.length;
6776	}
6777	else
6778	return NULL;
6779
6780	/* If the source length is 0, any value of NCOPIES is valid
6781	and everything behaves as if NCOPIES == 0. */
6782	mpz_init (ncopies);
6783	if (len == 0)
6784	mpz_set_ui (ncopies, 0);
6785	else
6786	mpz_set (ncopies, n->value.integer);
6787
6788	/* Check that NCOPIES isn't too large. */
6789	if (len)
6790	{
6791	mpz_t max, mlen;
6792	int i;
6793
6794	/* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
6795	mpz_init (max);
6796	i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
6797
6798	if (have_length)
6799	{
6800	mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
6801	e->ts.u.cl->length->value.integer);
6802	}
6803	else
6804	{
6805	mpz_init (mlen);
6806	gfc_mpz_set_hwi (mlen, len);
6807	mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
6808	mpz_clear (mlen);
6809	}
6810
6811	/* The check itself. */
6812	if (mpz_cmp (ncopies, max) > 0)
6813	{
6814	mpz_clear (max);
6815	mpz_clear (ncopies);
6816	gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
6817	&n->where);
6818	return &gfc_bad_expr;
6819	}
6820
6821	mpz_clear (max);
6822	}
6823	mpz_clear (ncopies);
6824
6825	/* For further simplification, we need the character string to be
6826	constant. */
6827	if (e->expr_type != EXPR_CONSTANT)
6828	return NULL;
6829
6830	HOST_WIDE_INT ncop;
6831	if (len ||
6832	(e->ts.u.cl->length &&
6833	mpz_sgn (e->ts.u.cl->length->value.integer) != 0))
6834	{
6835	bool fail = gfc_extract_hwi (n, &ncop);
6836	gcc_assert (!fail);
6837	}
6838	else
6839	ncop = 0;
6840
6841	if (ncop == 0)
6842	return gfc_get_character_expr (e->ts.kind, &e->where, NULL, len: 0);
6843
6844	len = e->value.character.length;
6845	gfc_charlen_t nlen = ncop * len;
6846
6847	/* Here's a semi-arbitrary limit. If the string is longer than 1 GB
6848	(2**28 elements * 4 bytes (wide chars) per element) defer to
6849	runtime instead of consuming (unbounded) memory and CPU at
6850	compile time. */
6851	if (nlen > 268435456)
6852	{
6853	gfc_warning_now (opt: 0, "Evaluation of string longer than 2**28 at %L"
6854	" deferred to runtime, expect bugs", &e->where);
6855	return NULL;
6856	}
6857
6858	result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len: nlen);
6859	for (size_t i = 0; i < (size_t) ncop; i++)
6860	for (size_t j = 0; j < (size_t) len; j++)
6861	result->value.character.string[j+i*len]= e->value.character.string[j];
6862
6863	result->value.character.string[nlen] = '\0'; /* For debugger */
6864	return result;
6865	}
6866
6867
6868	/* This one is a bear, but mainly has to do with shuffling elements. */
6869
6870	gfc_expr *
6871	gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
6872	gfc_expr *pad, gfc_expr *order_exp)
6873	{
6874	int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
6875	int i, rank, npad, x[GFC_MAX_DIMENSIONS];
6876	mpz_t index, size;
6877	unsigned long j;
6878	size_t nsource;
6879	gfc_expr *e, *result;
6880	bool zerosize = false;
6881
6882	/* Check that argument expression types are OK. */
6883	if (!is_constant_array_expr (e: source)
6884	|| !is_constant_array_expr (e: shape_exp)
6885	|| !is_constant_array_expr (e: pad)
6886	|| !is_constant_array_expr (e: order_exp))
6887	return NULL;
6888
6889	if (source->shape == NULL)
6890	return NULL;
6891
6892	/* Proceed with simplification, unpacking the array. */
6893
6894	mpz_init (index);
6895	rank = 0;
6896
6897	for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
6898	x[i] = 0;
6899
6900	for (;;)
6901	{
6902	e = gfc_constructor_lookup_expr (base: shape_exp->value.constructor, n: rank);
6903	if (e == NULL)
6904	break;
6905
6906	gfc_extract_int (e, &shape[rank]);
6907
6908	gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS);
6909	if (shape[rank] < 0)
6910	{
6911	gfc_error ("The SHAPE array for the RESHAPE intrinsic at %L has a "
6912	"negative value %d for dimension %d",
6913	&shape_exp->where, shape[rank], rank+1);
6914	mpz_clear (index);
6915	return &gfc_bad_expr;
6916	}
6917
6918	rank++;
6919	}
6920
6921	gcc_assert (rank > 0);
6922
6923	/* Now unpack the order array if present. */
6924	if (order_exp == NULL)
6925	{
6926	for (i = 0; i < rank; i++)
6927	order[i] = i;
6928	}
6929	else
6930	{
6931	mpz_t size;
6932	int order_size, shape_size;
6933
6934	if (order_exp->rank != shape_exp->rank)
6935	{
6936	gfc_error ("Shapes of ORDER at %L and SHAPE at %L are different",
6937	&order_exp->where, &shape_exp->where);
6938	mpz_clear (index);
6939	return &gfc_bad_expr;
6940	}
6941
6942	gfc_array_size (shape_exp, &size);
6943	shape_size = mpz_get_ui (gmp_z: size);
6944	mpz_clear (size);
6945	gfc_array_size (order_exp, &size);
6946	order_size = mpz_get_ui (gmp_z: size);
6947	mpz_clear (size);
6948	if (order_size != shape_size)
6949	{
6950	gfc_error ("Sizes of ORDER at %L and SHAPE at %L are different",
6951	&order_exp->where, &shape_exp->where);
6952	mpz_clear (index);
6953	return &gfc_bad_expr;
6954	}
6955
6956	for (i = 0; i < rank; i++)
6957	{
6958	e = gfc_constructor_lookup_expr (base: order_exp->value.constructor, n: i);
6959	gcc_assert (e);
6960
6961	gfc_extract_int (e, &order[i]);
6962
6963	if (order[i] < 1 || order[i] > rank)
6964	{
6965	gfc_error ("Element with a value of %d in ORDER at %L must be "
6966	"in the range [1, ..., %d] for the RESHAPE intrinsic "
6967	"near %L", order[i], &order_exp->where, rank,
6968	&shape_exp->where);
6969	mpz_clear (index);
6970	return &gfc_bad_expr;
6971	}
6972
6973	order[i]--;
6974	if (x[order[i]] != 0)
6975	{
6976	gfc_error ("ORDER at %L is not a permutation of the size of "
6977	"SHAPE at %L", &order_exp->where, &shape_exp->where);
6978	mpz_clear (index);
6979	return &gfc_bad_expr;
6980	}
6981	x[order[i]] = 1;
6982	}
6983	}
6984
6985	/* Count the elements in the source and padding arrays. */
6986
6987	npad = 0;
6988	if (pad != NULL)
6989	{
6990	gfc_array_size (pad, &size);
6991	npad = mpz_get_ui (gmp_z: size);
6992	mpz_clear (size);
6993	}
6994
6995	gfc_array_size (source, &size);
6996	nsource = mpz_get_ui (gmp_z: size);
6997	mpz_clear (size);
6998
6999	/* If it weren't for that pesky permutation we could just loop
7000	through the source and round out any shortage with pad elements.
7001	But no, someone just had to have the compiler do something the
7002	user should be doing. */
7003
7004	for (i = 0; i < rank; i++)
7005	x[i] = 0;
7006
7007	result = gfc_get_array_expr (type: source->ts.type, kind: source->ts.kind,
7008	&source->where);
7009	if (source->ts.type == BT_DERIVED)
7010	result->ts.u.derived = source->ts.u.derived;
7011	if (source->ts.type == BT_CHARACTER && result->ts.u.cl == NULL)
7012	result->ts = source->ts;
7013	result->rank = rank;
7014	result->shape = gfc_get_shape (rank);
7015	for (i = 0; i < rank; i++)
7016	{
7017	mpz_init_set_ui (result->shape[i], shape[i]);
7018	if (shape[i] == 0)
7019	zerosize = true;
7020	}
7021
7022	if (zerosize)
7023	goto sizezero;
7024
7025	while (nsource > 0 || npad > 0)
7026	{
7027	/* Figure out which element to extract. */
7028	mpz_set_ui (index, 0);
7029
7030	for (i = rank - 1; i >= 0; i--)
7031	{
7032	mpz_add_ui (index, index, x[order[i]]);
7033	if (i != 0)
7034	mpz_mul_ui (index, index, shape[order[i - 1]]);
7035	}
7036
7037	if (mpz_cmp_ui (index, INT_MAX) > 0)
7038	gfc_internal_error ("Reshaped array too large at %C");
7039
7040	j = mpz_get_ui (gmp_z: index);
7041
7042	if (j < nsource)
7043	e = gfc_constructor_lookup_expr (base: source->value.constructor, n: j);
7044	else
7045	{
7046	if (npad <= 0)
7047	{
7048	mpz_clear (index);
7049	if (pad == NULL)
7050	gfc_error ("Without padding, there are not enough elements "
7051	"in the intrinsic RESHAPE source at %L to match "
7052	"the shape", &source->where);
7053	gfc_free_expr (result);
7054	return NULL;
7055	}
7056	j = j - nsource;
7057	j = j % npad;
7058	e = gfc_constructor_lookup_expr (base: pad->value.constructor, n: j);
7059	}
7060	gcc_assert (e);
7061
7062	gfc_constructor_append_expr (base: &result->value.constructor,
7063	e: gfc_copy_expr (e), where: &e->where);
7064
7065	/* Calculate the next element. */
7066	i = 0;
7067
7068	inc:
7069	if (++x[i] < shape[i])
7070	continue;
7071	x[i++] = 0;
7072	if (i < rank)
7073	goto inc;
7074
7075	break;
7076	}
7077
7078	sizezero:
7079
7080	mpz_clear (index);
7081
7082	return result;
7083	}
7084
7085
7086	gfc_expr *
7087	gfc_simplify_rrspacing (gfc_expr *x)
7088	{
7089	gfc_expr *result;
7090	int i;
7091	long int e, p;
7092
7093	if (x->expr_type != EXPR_CONSTANT)
7094	return NULL;
7095
7096	i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
7097
7098	result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
7099
7100	/* RRSPACING(+/- 0.0) = 0.0 */
7101	if (mpfr_zero_p (x->value.real))
7102	{
7103	mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
7104	return result;
7105	}
7106
7107	/* RRSPACING(inf) = NaN */
7108	if (mpfr_inf_p (x->value.real))
7109	{
7110	mpfr_set_nan (result->value.real);
7111	return result;
7112	}
7113
7114	/* RRSPACING(NaN) = same NaN */
7115	if (mpfr_nan_p (x->value.real))
7116	{
7117	mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
7118	return result;
7119	}
7120
7121	/* | x * 2**(-e) | * 2**p. */
7122	mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
7123	e = - (long int) mpfr_get_exp (x->value.real);
7124	mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
7125
7126	p = (long int) gfc_real_kinds[i].digits;
7127	mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
7128
7129	return range_check (result, name: "RRSPACING");
7130	}
7131
7132
7133	gfc_expr *
7134	gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
7135	{
7136	int k, neg_flag, power, exp_range;
7137	mpfr_t scale, radix;
7138	gfc_expr *result;
7139
7140	if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
7141	return NULL;
7142
7143	result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
7144
7145	if (mpfr_zero_p (x->value.real))
7146	{
7147	mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
7148	return result;
7149	}
7150
7151	k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
7152
7153	exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
7154
7155	/* This check filters out values of i that would overflow an int. */
7156	if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
7157	|| mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
7158	{
7159	gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
7160	gfc_free_expr (result);
7161	return &gfc_bad_expr;
7162	}
7163
7164	/* Compute scale = radix ** power. */
7165	power = mpz_get_si (i->value.integer);
7166
7167	if (power >= 0)
7168	neg_flag = 0;
7169	else
7170	{
7171	neg_flag = 1;
7172	power = -power;
7173	}
7174
7175	gfc_set_model_kind (x->ts.kind);
7176	mpfr_init (scale);
7177	mpfr_init (radix);
7178	mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
7179	mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
7180
7181	if (neg_flag)
7182	mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
7183	else
7184	mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
7185
7186	mpfr_clears (scale, radix, NULL);
7187
7188	return range_check (result, name: "SCALE");
7189	}
7190
7191
7192	/* Variants of strspn and strcspn that operate on wide characters. */
7193
7194	static size_t
7195	wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2)
7196	{
7197	size_t i = 0;
7198	const gfc_char_t *c;
7199
7200	while (s1[i])
7201	{
7202	for (c = s2; *c; c++)
7203	{
7204	if (s1[i] == *c)
7205	break;
7206	}
7207	if (*c == '\0')
7208	break;
7209	i++;
7210	}
7211
7212	return i;
7213	}
7214
7215	static size_t
7216	wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2)
7217	{
7218	size_t i = 0;
7219	const gfc_char_t *c;
7220
7221	while (s1[i])
7222	{
7223	for (c = s2; *c; c++)
7224	{
7225	if (s1[i] == *c)
7226	break;
7227	}
7228	if (*c)
7229	break;
7230	i++;
7231	}
7232
7233	return i;
7234	}
7235
7236
7237	gfc_expr *
7238	gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
7239	{
7240	gfc_expr *result;
7241	int back;
7242	size_t i;
7243	size_t indx, len, lenc;
7244	int k = get_kind (type: BT_INTEGER, k: kind, name: "SCAN", default_kind: gfc_default_integer_kind);
7245
7246	if (k == -1)
7247	return &gfc_bad_expr;
7248
7249	if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT
7250	|| ( b != NULL && b->expr_type != EXPR_CONSTANT))
7251	return NULL;
7252
7253	if (b != NULL && b->value.logical != 0)
7254	back = 1;
7255	else
7256	back = 0;
7257
7258	len = e->value.character.length;
7259	lenc = c->value.character.length;
7260
7261	if (len == 0 || lenc == 0)
7262	{
7263	indx = 0;
7264	}
7265	else
7266	{
7267	if (back == 0)
7268	{
7269	indx = wide_strcspn (s1: e->value.character.string,
7270	s2: c->value.character.string) + 1;
7271	if (indx > len)
7272	indx = 0;
7273	}
7274	else
7275	for (indx = len; indx > 0; indx--)
7276	{
7277	for (i = 0; i < lenc; i++)
7278	{
7279	if (c->value.character.string[i]
7280	== e->value.character.string[indx - 1])
7281	break;
7282	}
7283	if (i < lenc)
7284	break;
7285	}
7286	}
7287
7288	result = gfc_get_int_expr (k, &e->where, indx);
7289	return range_check (result, name: "SCAN");
7290	}
7291
7292
7293	gfc_expr *
7294	gfc_simplify_selected_char_kind (gfc_expr *e)
7295	{
7296	int kind;
7297
7298	if (e->expr_type != EXPR_CONSTANT)
7299	return NULL;
7300
7301	if (gfc_compare_with_Cstring (e, "ascii", false) == 0
7302	|| gfc_compare_with_Cstring (e, "default", false) == 0)
7303	kind = 1;
7304	else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0)
7305	kind = 4;
7306	else
7307	kind = -1;
7308
7309	return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
7310	}
7311
7312
7313	gfc_expr *
7314	gfc_simplify_selected_int_kind (gfc_expr *e)
7315	{
7316	int i, kind, range;
7317
7318	if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range))
7319	return NULL;
7320
7321	kind = INT_MAX;
7322
7323	for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
7324	if (gfc_integer_kinds[i].range >= range
7325	&& gfc_integer_kinds[i].kind < kind)
7326	kind = gfc_integer_kinds[i].kind;
7327
7328	if (kind == INT_MAX)
7329	kind = -1;
7330
7331	return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
7332	}
7333
7334
7335	gfc_expr *
7336	gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q, gfc_expr *rdx)
7337	{
7338	int range, precision, radix, i, kind, found_precision, found_range,
7339	found_radix;
7340	locus *loc = &gfc_current_locus;
7341
7342	if (p == NULL)
7343	precision = 0;
7344	else
7345	{
7346	if (p->expr_type != EXPR_CONSTANT
7347	|| gfc_extract_int (p, &precision))
7348	return NULL;
7349	loc = &p->where;
7350	}
7351
7352	if (q == NULL)
7353	range = 0;
7354	else
7355	{
7356	if (q->expr_type != EXPR_CONSTANT
7357	|| gfc_extract_int (q, &range))
7358	return NULL;
7359
7360	if (!loc)
7361	loc = &q->where;
7362	}
7363
7364	if (rdx == NULL)
7365	radix = 0;
7366	else
7367	{
7368	if (rdx->expr_type != EXPR_CONSTANT
7369	|| gfc_extract_int (rdx, &radix))
7370	return NULL;
7371
7372	if (!loc)
7373	loc = &rdx->where;
7374	}
7375
7376	kind = INT_MAX;
7377	found_precision = 0;
7378	found_range = 0;
7379	found_radix = 0;
7380
7381	for (i = 0; gfc_real_kinds[i].kind != 0; i++)
7382	{
7383	if (gfc_real_kinds[i].precision >= precision)
7384	found_precision = 1;
7385
7386	if (gfc_real_kinds[i].range >= range)
7387	found_range = 1;
7388
7389	if (radix == 0 || gfc_real_kinds[i].radix == radix)
7390	found_radix = 1;
7391
7392	if (gfc_real_kinds[i].precision >= precision
7393	&& gfc_real_kinds[i].range >= range
7394	&& (radix == 0 || gfc_real_kinds[i].radix == radix)
7395	&& gfc_real_kinds[i].kind < kind)
7396	kind = gfc_real_kinds[i].kind;
7397	}
7398
7399	if (kind == INT_MAX)
7400	{
7401	if (found_radix && found_range && !found_precision)
7402	kind = -1;
7403	else if (found_radix && found_precision && !found_range)
7404	kind = -2;
7405	else if (found_radix && !found_precision && !found_range)
7406	kind = -3;
7407	else if (found_radix)
7408	kind = -4;
7409	else
7410	kind = -5;
7411	}
7412
7413	return gfc_get_int_expr (gfc_default_integer_kind, loc, kind);
7414	}
7415
7416
7417	gfc_expr *
7418	gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
7419	{
7420	gfc_expr *result;
7421	mpfr_t exp, absv, log2, pow2, frac;
7422	long exp2;
7423
7424	if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
7425	return NULL;
7426
7427	result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
7428
7429	/* SET_EXPONENT (+/-0.0, I) = +/- 0.0
7430	SET_EXPONENT (NaN) = same NaN */
7431	if (mpfr_zero_p (x->value.real) || mpfr_nan_p (x->value.real))
7432	{
7433	mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
7434	return result;
7435	}
7436
7437	/* SET_EXPONENT (inf) = NaN */
7438	if (mpfr_inf_p (x->value.real))
7439	{
7440	mpfr_set_nan (result->value.real);
7441	return result;
7442	}
7443
7444	gfc_set_model_kind (x->ts.kind);
7445	mpfr_init (absv);
7446	mpfr_init (log2);
7447	mpfr_init (exp);
7448	mpfr_init (pow2);
7449	mpfr_init (frac);
7450
7451	mpfr_abs (absv, x->value.real, GFC_RND_MODE);
7452	mpfr_log2 (log2, absv, GFC_RND_MODE);
7453
7454	mpfr_floor (log2, log2);
7455	mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
7456
7457	/* Old exponent value, and fraction. */
7458	mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
7459
7460	mpfr_div (frac, x->value.real, pow2, GFC_RND_MODE);
7461
7462	/* New exponent. */
7463	exp2 = mpz_get_si (i->value.integer);
7464	mpfr_mul_2si (result->value.real, frac, exp2, GFC_RND_MODE);
7465
7466	mpfr_clears (absv, log2, exp, pow2, frac, NULL);
7467
7468	return range_check (result, name: "SET_EXPONENT");
7469	}
7470
7471
7472	gfc_expr *
7473	gfc_simplify_shape (gfc_expr *source, gfc_expr *kind)
7474	{
7475	mpz_t shape[GFC_MAX_DIMENSIONS];
7476	gfc_expr *result, *e, *f;
7477	gfc_array_ref *ar;
7478	int n;
7479	bool t;
7480	int k = get_kind (type: BT_INTEGER, k: kind, name: "SHAPE", default_kind: gfc_default_integer_kind);
7481
7482	if (source->rank == -1)
7483	return NULL;
7484
7485	result = gfc_get_array_expr (type: BT_INTEGER, kind: k, &source->where);
7486	result->shape = gfc_get_shape (1);
7487	mpz_init (result->shape[0]);
7488
7489	if (source->rank == 0)
7490	return result;
7491
7492	if (source->expr_type == EXPR_VARIABLE)
7493	{
7494	ar = gfc_find_array_ref (source);
7495	t = gfc_array_ref_shape (ar, shape);
7496	}
7497	else if (source->shape)
7498	{
7499	t = true;
7500	for (n = 0; n < source->rank; n++)
7501	{
7502	mpz_init (shape[n]);
7503	mpz_set (shape[n], source->shape[n]);
7504	}
7505	}
7506	else
7507	t = false;
7508
7509	for (n = 0; n < source->rank; n++)
7510	{
7511	e = gfc_get_constant_expr (BT_INTEGER, k, &source->where);
7512
7513	if (t)
7514	mpz_set (e->value.integer, shape[n]);
7515	else
7516	{
7517	mpz_set_ui (e->value.integer, n + 1);
7518
7519	f = simplify_size (source, e, k);
7520	gfc_free_expr (e);
7521	if (f == NULL)
7522	{
7523	gfc_free_expr (result);
7524	return NULL;
7525	}
7526	else
7527	e = f;
7528	}
7529
7530	if (e == &gfc_bad_expr || range_check (result: e, name: "SHAPE") == &gfc_bad_expr)
7531	{
7532	gfc_free_expr (result);
7533	if (t)
7534	gfc_clear_shape (shape, rank: source->rank);
7535	return &gfc_bad_expr;
7536	}
7537
7538	gfc_constructor_append_expr (base: &result->value.constructor, e, NULL);
7539	}
7540
7541	if (t)
7542	gfc_clear_shape (shape, rank: source->rank);
7543
7544	mpz_set_si (result->shape[0], source->rank);
7545
7546	return result;
7547	}
7548
7549
7550	static gfc_expr *
7551	simplify_size (gfc_expr *array, gfc_expr *dim, int k)
7552	{
7553	mpz_t size;
7554	gfc_expr *return_value;
7555	int d;
7556	gfc_ref *ref;
7557
7558	/* For unary operations, the size of the result is given by the size
7559	of the operand. For binary ones, it's the size of the first operand
7560	unless it is scalar, then it is the size of the second. */
7561	if (array->expr_type == EXPR_OP && !array->value.op.uop)
7562	{
7563	gfc_expr* replacement;
7564	gfc_expr* simplified;
7565
7566	switch (array->value.op.op)
7567	{
7568	/* Unary operations. */
7569	case INTRINSIC_NOT:
7570	case INTRINSIC_UPLUS:
7571	case INTRINSIC_UMINUS:
7572	case INTRINSIC_PARENTHESES:
7573	replacement = array->value.op.op1;
7574	break;
7575
7576	/* Binary operations. If any one of the operands is scalar, take
7577	the other one's size. If both of them are arrays, it does not
7578	matter -- try to find one with known shape, if possible. */
7579	default:
7580	if (array->value.op.op1->rank == 0)
7581	replacement = array->value.op.op2;
7582	else if (array->value.op.op2->rank == 0)
7583	replacement = array->value.op.op1;
7584	else
7585	{
7586	simplified = simplify_size (array: array->value.op.op1, dim, k);
7587	if (simplified)
7588	return simplified;
7589
7590	replacement = array->value.op.op2;
7591	}
7592	break;
7593	}
7594
7595	/* Try to reduce it directly if possible. */
7596	simplified = simplify_size (array: replacement, dim, k);
7597
7598	/* Otherwise, we build a new SIZE call. This is hopefully at least
7599	simpler than the original one. */
7600	if (!simplified)
7601	{
7602	gfc_expr *kind = gfc_get_int_expr (gfc_default_integer_kind, NULL, k);
7603	simplified = gfc_build_intrinsic_call (gfc_current_ns,
7604	GFC_ISYM_SIZE, "size",
7605	array->where, 3,
7606	gfc_copy_expr (replacement),
7607	gfc_copy_expr (dim),
7608	kind);
7609	}
7610	return simplified;
7611	}
7612
7613	for (ref = array->ref; ref; ref = ref->next)
7614	if (ref->type == REF_ARRAY && ref->u.ar.as
7615	&& !gfc_resolve_array_spec (ref->u.ar.as, 0))
7616	return NULL;
7617
7618	if (dim == NULL)
7619	{
7620	if (!gfc_array_size (array, &size))
7621	return NULL;
7622	}
7623	else
7624	{
7625	if (dim->expr_type != EXPR_CONSTANT)
7626	return NULL;
7627
7628	if (array->rank == -1)
7629	return NULL;
7630
7631	d = mpz_get_si (dim->value.integer) - 1;
7632	if (d < 0 || d > array->rank - 1)
7633	{
7634	gfc_error ("DIM argument (%d) to intrinsic SIZE at %L out of range "
7635	"(1:%d)", d+1, &array->where, array->rank);
7636	return &gfc_bad_expr;
7637	}
7638
7639	if (!gfc_array_dimen_size (array, d, &size))
7640	return NULL;
7641	}
7642
7643	return_value = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
7644	mpz_set (return_value->value.integer, size);
7645	mpz_clear (size);
7646
7647	return return_value;
7648	}
7649
7650
7651	gfc_expr *
7652	gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
7653	{
7654	gfc_expr *result;
7655	int k = get_kind (type: BT_INTEGER, k: kind, name: "SIZE", default_kind: gfc_default_integer_kind);
7656
7657	if (k == -1)
7658	return &gfc_bad_expr;
7659
7660	result = simplify_size (array, dim, k);
7661	if (result == NULL || result == &gfc_bad_expr)
7662	return result;
7663
7664	return range_check (result, name: "SIZE");
7665	}
7666
7667
7668	/* SIZEOF and C_SIZEOF return the size in bytes of an array element
7669	multiplied by the array size. */
7670
7671	gfc_expr *
7672	gfc_simplify_sizeof (gfc_expr *x)
7673	{
7674	gfc_expr *result = NULL;
7675	mpz_t array_size;
7676	size_t res_size;
7677
7678	if (x->ts.type == BT_CLASS || x->ts.deferred)
7679	return NULL;
7680
7681	if (x->ts.type == BT_CHARACTER
7682	&& (!x->ts.u.cl || !x->ts.u.cl->length
7683	|| x->ts.u.cl->length->expr_type != EXPR_CONSTANT))
7684	return NULL;
7685
7686	if (x->rank && x->expr_type != EXPR_ARRAY
7687	&& !gfc_array_size (x, &array_size))
7688	return NULL;
7689
7690	result = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
7691	&x->where);
7692	gfc_target_expr_size (x, &res_size);
7693	mpz_set_si (result->value.integer, res_size);
7694
7695	return result;
7696	}
7697
7698
7699	/* STORAGE_SIZE returns the size in bits of a single array element. */
7700
7701	gfc_expr *
7702	gfc_simplify_storage_size (gfc_expr *x,
7703	gfc_expr *kind)
7704	{
7705	gfc_expr *result = NULL;
7706	int k;
7707	size_t siz;
7708
7709	if (x->ts.type == BT_CLASS || x->ts.deferred)
7710	return NULL;
7711
7712	if (x->ts.type == BT_CHARACTER && x->expr_type != EXPR_CONSTANT
7713	&& (!x->ts.u.cl || !x->ts.u.cl->length
7714	|| x->ts.u.cl->length->expr_type != EXPR_CONSTANT))
7715	return NULL;
7716
7717	k = get_kind (type: BT_INTEGER, k: kind, name: "STORAGE_SIZE", default_kind: gfc_default_integer_kind);
7718	if (k == -1)
7719	return &gfc_bad_expr;
7720
7721	result = gfc_get_constant_expr (BT_INTEGER, k, &x->where);
7722
7723	gfc_element_size (x, &siz);
7724	mpz_set_si (result->value.integer, siz);
7725	mpz_mul_ui (result->value.integer, result->value.integer, BITS_PER_UNIT);
7726
7727	return range_check (result, name: "STORAGE_SIZE");
7728	}
7729
7730
7731	gfc_expr *
7732	gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
7733	{
7734	gfc_expr *result;
7735
7736	if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
7737	return NULL;
7738
7739	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
7740
7741	switch (x->ts.type)
7742	{
7743	case BT_INTEGER:
7744	mpz_abs (gmp_w: result->value.integer, gmp_u: x->value.integer);
7745	if (mpz_sgn (y->value.integer) < 0)
7746	mpz_neg (gmp_w: result->value.integer, gmp_u: result->value.integer);
7747	break;
7748
7749	case BT_REAL:
7750	if (flag_sign_zero)
7751	mpfr_copysign (result->value.real, x->value.real, y->value.real,
7752	GFC_RND_MODE);
7753	else
7754	mpfr_setsign (result->value.real, x->value.real,
7755	mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE);
7756	break;
7757
7758	default:
7759	gfc_internal_error ("Bad type in gfc_simplify_sign");
7760	}
7761
7762	return result;
7763	}
7764
7765
7766	gfc_expr *
7767	gfc_simplify_sin (gfc_expr *x)
7768	{
7769	gfc_expr *result;
7770
7771	if (x->expr_type != EXPR_CONSTANT)
7772	return NULL;
7773
7774	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
7775
7776	switch (x->ts.type)
7777	{
7778	case BT_REAL:
7779	mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
7780	break;
7781
7782	case BT_COMPLEX:
7783	gfc_set_model (x->value.real);
7784	mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
7785	break;
7786
7787	default:
7788	gfc_internal_error ("in gfc_simplify_sin(): Bad type");
7789	}
7790
7791	return range_check (result, name: "SIN");
7792	}
7793
7794
7795	gfc_expr *
7796	gfc_simplify_sinh (gfc_expr *x)
7797	{
7798	gfc_expr *result;
7799
7800	if (x->expr_type != EXPR_CONSTANT)
7801	return NULL;
7802
7803	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
7804
7805	switch (x->ts.type)
7806	{
7807	case BT_REAL:
7808	mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
7809	break;
7810
7811	case BT_COMPLEX:
7812	mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
7813	break;
7814
7815	default:
7816	gcc_unreachable ();
7817	}
7818
7819	return range_check (result, name: "SINH");
7820	}
7821
7822
7823	/* The argument is always a double precision real that is converted to
7824	single precision. TODO: Rounding! */
7825
7826	gfc_expr *
7827	gfc_simplify_sngl (gfc_expr *a)
7828	{
7829	gfc_expr *result;
7830	int tmp1, tmp2;
7831
7832	if (a->expr_type != EXPR_CONSTANT)
7833	return NULL;
7834
7835	/* For explicit conversion, turn off -Wconversion and -Wconversion-extra
7836	warnings. */
7837	tmp1 = warn_conversion;
7838	tmp2 = warn_conversion_extra;
7839	warn_conversion = warn_conversion_extra = 0;
7840
7841	result = gfc_real2real (a, gfc_default_real_kind);
7842
7843	warn_conversion = tmp1;
7844	warn_conversion_extra = tmp2;
7845
7846	return range_check (result, name: "SNGL");
7847	}
7848
7849
7850	gfc_expr *
7851	gfc_simplify_spacing (gfc_expr *x)
7852	{
7853	gfc_expr *result;
7854	int i;
7855	long int en, ep;
7856
7857	if (x->expr_type != EXPR_CONSTANT)
7858	return NULL;
7859
7860	i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
7861	result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
7862
7863	/* SPACING(+/- 0.0) = SPACING(TINY(0.0)) = TINY(0.0) */
7864	if (mpfr_zero_p (x->value.real))
7865	{
7866	mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
7867	return result;
7868	}
7869
7870	/* SPACING(inf) = NaN */
7871	if (mpfr_inf_p (x->value.real))
7872	{
7873	mpfr_set_nan (result->value.real);
7874	return result;
7875	}
7876
7877	/* SPACING(NaN) = same NaN */
7878	if (mpfr_nan_p (x->value.real))
7879	{
7880	mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
7881	return result;
7882	}
7883
7884	/* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
7885	are the radix, exponent of x, and precision. This excludes the
7886	possibility of subnormal numbers. Fortran 2003 states the result is
7887	b**max(e - p, emin - 1). */
7888
7889	ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
7890	en = (long int) gfc_real_kinds[i].min_exponent - 1;
7891	en = en > ep ? en : ep;
7892
7893	mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
7894	mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
7895
7896	return range_check (result, name: "SPACING");
7897	}
7898
7899
7900	gfc_expr *
7901	gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr)
7902	{
7903	gfc_expr *result = NULL;
7904	int nelem, i, j, dim, ncopies;
7905	mpz_t size;
7906
7907	if ((!gfc_is_constant_expr (source)
7908	&& !is_constant_array_expr (e: source))
7909	|| !gfc_is_constant_expr (dim_expr)
7910	|| !gfc_is_constant_expr (ncopies_expr))
7911	return NULL;
7912
7913	gcc_assert (dim_expr->ts.type == BT_INTEGER);
7914	gfc_extract_int (dim_expr, &dim);
7915	dim -= 1; /* zero-base DIM */
7916
7917	gcc_assert (ncopies_expr->ts.type == BT_INTEGER);
7918	gfc_extract_int (ncopies_expr, &ncopies);
7919	ncopies = MAX (ncopies, 0);
7920
7921	/* Do not allow the array size to exceed the limit for an array
7922	constructor. */
7923	if (source->expr_type == EXPR_ARRAY)
7924	{
7925	if (!gfc_array_size (source, &size))
7926	gfc_internal_error ("Failure getting length of a constant array.");
7927	}
7928	else
7929	mpz_init_set_ui (size, 1);
7930
7931	nelem = mpz_get_si (size) * ncopies;
7932	if (nelem > flag_max_array_constructor)
7933	{
7934	if (gfc_init_expr_flag)
7935	{
7936	gfc_error ("The number of elements (%d) in the array constructor "
7937	"at %L requires an increase of the allowed %d upper "
7938	"limit. See %<-fmax-array-constructor%> option.",
7939	nelem, &source->where, flag_max_array_constructor);
7940	return &gfc_bad_expr;
7941	}
7942	else
7943	return NULL;
7944	}
7945
7946	if (source->expr_type == EXPR_CONSTANT
7947	|| source->expr_type == EXPR_STRUCTURE)
7948	{
7949	gcc_assert (dim == 0);
7950
7951	result = gfc_get_array_expr (type: source->ts.type, kind: source->ts.kind,
7952	&source->where);
7953	if (source->ts.type == BT_DERIVED)
7954	result->ts.u.derived = source->ts.u.derived;
7955	result->rank = 1;
7956	result->shape = gfc_get_shape (result->rank);
7957	mpz_init_set_si (result->shape[0], ncopies);
7958
7959	for (i = 0; i < ncopies; ++i)
7960	gfc_constructor_append_expr (base: &result->value.constructor,
7961	e: gfc_copy_expr (source), NULL);
7962	}
7963	else if (source->expr_type == EXPR_ARRAY)
7964	{
7965	int offset, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS];
7966	gfc_constructor *source_ctor;
7967
7968	gcc_assert (source->rank < GFC_MAX_DIMENSIONS);
7969	gcc_assert (dim >= 0 && dim <= source->rank);
7970
7971	result = gfc_get_array_expr (type: source->ts.type, kind: source->ts.kind,
7972	&source->where);
7973	if (source->ts.type == BT_DERIVED)
7974	result->ts.u.derived = source->ts.u.derived;
7975	result->rank = source->rank + 1;
7976	result->shape = gfc_get_shape (result->rank);
7977
7978	for (i = 0, j = 0; i < result->rank; ++i)
7979	{
7980	if (i != dim)
7981	mpz_init_set (result->shape[i], source->shape[j++]);
7982	else
7983	mpz_init_set_si (result->shape[i], ncopies);
7984
7985	extent[i] = mpz_get_si (result->shape[i]);
7986	rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1];
7987	}
7988
7989	offset = 0;
7990	for (source_ctor = gfc_constructor_first (base: source->value.constructor);
7991	source_ctor; source_ctor = gfc_constructor_next (ctor: source_ctor))
7992	{
7993	for (i = 0; i < ncopies; ++i)
7994	gfc_constructor_insert_expr (base: &result->value.constructor,
7995	e: gfc_copy_expr (source_ctor->expr),
7996	NULL, n: offset + i * rstride[dim]);
7997
7998	offset += (dim == 0 ? ncopies : 1);
7999	}
8000	}
8001	else
8002	{
8003	gfc_error ("Simplification of SPREAD at %C not yet implemented");
8004	return &gfc_bad_expr;
8005	}
8006
8007	if (source->ts.type == BT_CHARACTER)
8008	result->ts.u.cl = source->ts.u.cl;
8009
8010	return result;
8011	}
8012
8013
8014	gfc_expr *
8015	gfc_simplify_sqrt (gfc_expr *e)
8016	{
8017	gfc_expr *result = NULL;
8018
8019	if (e->expr_type != EXPR_CONSTANT)
8020	return NULL;
8021
8022	switch (e->ts.type)
8023	{
8024	case BT_REAL:
8025	if (mpfr_cmp_si (e->value.real, 0) < 0)
8026	{
8027	gfc_error ("Argument of SQRT at %L has a negative value",
8028	&e->where);
8029	return &gfc_bad_expr;
8030	}
8031	result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
8032	mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
8033	break;
8034
8035	case BT_COMPLEX:
8036	gfc_set_model (e->value.real);
8037
8038	result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
8039	mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE);
8040	break;
8041
8042	default:
8043	gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
8044	}
8045
8046	return range_check (result, name: "SQRT");
8047	}
8048
8049
8050	gfc_expr *
8051	gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
8052	{
8053	return simplify_transformation (array, dim, mask, init_val: 0, op: gfc_add);
8054	}
8055
8056
8057	/* Simplify COTAN(X) where X has the unit of radian. */
8058
8059	gfc_expr *
8060	gfc_simplify_cotan (gfc_expr *x)
8061	{
8062	gfc_expr *result;
8063	mpc_t swp, *val;
8064
8065	if (x->expr_type != EXPR_CONSTANT)
8066	return NULL;
8067
8068	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
8069
8070	switch (x->ts.type)
8071	{
8072	case BT_REAL:
8073	mpfr_cot (result->value.real, x->value.real, GFC_RND_MODE);
8074	break;
8075
8076	case BT_COMPLEX:
8077	/* There is no builtin mpc_cot, so compute cot = cos / sin. */
8078	val = &result->value.complex;
8079	mpc_init2 (swp, mpfr_get_default_prec ());
8080	mpc_sin_cos (*val, swp, x->value.complex, GFC_MPC_RND_MODE,
8081	GFC_MPC_RND_MODE);
8082	mpc_div (*val, swp, *val, GFC_MPC_RND_MODE);
8083	mpc_clear (swp);
8084	break;
8085
8086	default:
8087	gcc_unreachable ();
8088	}
8089
8090	return range_check (result, name: "COTAN");
8091	}
8092
8093
8094	gfc_expr *
8095	gfc_simplify_tan (gfc_expr *x)
8096	{
8097	gfc_expr *result;
8098
8099	if (x->expr_type != EXPR_CONSTANT)
8100	return NULL;
8101
8102	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
8103
8104	switch (x->ts.type)
8105	{
8106	case BT_REAL:
8107	mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
8108	break;
8109
8110	case BT_COMPLEX:
8111	mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
8112	break;
8113
8114	default:
8115	gcc_unreachable ();
8116	}
8117
8118	return range_check (result, name: "TAN");
8119	}
8120
8121
8122	gfc_expr *
8123	gfc_simplify_tanh (gfc_expr *x)
8124	{
8125	gfc_expr *result;
8126
8127	if (x->expr_type != EXPR_CONSTANT)
8128	return NULL;
8129
8130	result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
8131
8132	switch (x->ts.type)
8133	{
8134	case BT_REAL:
8135	mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
8136	break;
8137
8138	case BT_COMPLEX:
8139	mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
8140	break;
8141
8142	default:
8143	gcc_unreachable ();
8144	}
8145
8146	return range_check (result, name: "TANH");
8147	}
8148
8149
8150	gfc_expr *
8151	gfc_simplify_tiny (gfc_expr *e)
8152	{
8153	gfc_expr *result;
8154	int i;
8155
8156	i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
8157
8158	result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
8159	mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
8160
8161	return result;
8162	}
8163
8164
8165	gfc_expr *
8166	gfc_simplify_trailz (gfc_expr *e)
8167	{
8168	unsigned long tz, bs;
8169	int i;
8170
8171	if (e->expr_type != EXPR_CONSTANT)
8172	return NULL;
8173
8174	i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
8175	bs = gfc_integer_kinds[i].bit_size;
8176	tz = mpz_scan1 (e->value.integer, 0);
8177
8178	return gfc_get_int_expr (gfc_default_integer_kind,
8179	&e->where, MIN (tz, bs));
8180	}
8181
8182
8183	gfc_expr *
8184	gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
8185	{
8186	gfc_expr *result;
8187	gfc_expr *mold_element;
8188	size_t source_size;
8189	size_t result_size;
8190	size_t buffer_size;
8191	mpz_t tmp;
8192	unsigned char *buffer;
8193	size_t result_length;
8194
8195	if (!gfc_is_constant_expr (source) || !gfc_is_constant_expr (size))
8196	return NULL;
8197
8198	if (!gfc_resolve_expr (mold))
8199	return NULL;
8200	if (gfc_init_expr_flag && !gfc_is_constant_expr (mold))
8201	return NULL;
8202
8203	if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size,
8204	&result_size, &result_length))
8205	return NULL;
8206
8207	/* Calculate the size of the source. */
8208	if (source->expr_type == EXPR_ARRAY && !gfc_array_size (source, &tmp))
8209	gfc_internal_error ("Failure getting length of a constant array.");
8210
8211	/* Create an empty new expression with the appropriate characteristics. */
8212	result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind,
8213	&source->where);
8214	result->ts = mold->ts;
8215
8216	mold_element = (mold->expr_type == EXPR_ARRAY && mold->value.constructor)
8217	? gfc_constructor_first (base: mold->value.constructor)->expr
8218	: mold;
8219
8220	/* Set result character length, if needed. Note that this needs to be
8221	set even for array expressions, in order to pass this information into
8222	gfc_target_interpret_expr. */
8223	if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
8224	{
8225	result->value.character.length = mold_element->value.character.length;
8226
8227	/* Let the typespec of the result inherit the string length.
8228	This is crucial if a resulting array has size zero. */
8229	if (mold_element->ts.u.cl->length)
8230	result->ts.u.cl->length = gfc_copy_expr (mold_element->ts.u.cl->length);
8231	else
8232	result->ts.u.cl->length =
8233	gfc_get_int_expr (gfc_charlen_int_kind, NULL,
8234	mold_element->value.character.length);
8235	}
8236
8237	/* Set the number of elements in the result, and determine its size. */
8238
8239	if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
8240	{
8241	result->expr_type = EXPR_ARRAY;
8242	result->rank = 1;
8243	result->shape = gfc_get_shape (1);
8244	mpz_init_set_ui (result->shape[0], result_length);
8245	}
8246	else
8247	result->rank = 0;
8248
8249	/* Allocate the buffer to store the binary version of the source. */
8250	buffer_size = MAX (source_size, result_size);
8251	buffer = (unsigned char*)alloca (buffer_size);
8252	memset (s: buffer, c: 0, n: buffer_size);
8253
8254	/* Now write source to the buffer. */
8255	gfc_target_encode_expr (source, buffer, buffer_size);
8256
8257	/* And read the buffer back into the new expression. */
8258	gfc_target_interpret_expr (buffer, buffer_size, result, false);
8259
8260	return result;
8261	}
8262
8263
8264	gfc_expr *
8265	gfc_simplify_transpose (gfc_expr *matrix)
8266	{
8267	int row, matrix_rows, col, matrix_cols;
8268	gfc_expr *result;
8269
8270	if (!is_constant_array_expr (e: matrix))
8271	return NULL;
8272
8273	gcc_assert (matrix->rank == 2);
8274
8275	if (matrix->shape == NULL)
8276	return NULL;
8277
8278	result = gfc_get_array_expr (type: matrix->ts.type, kind: matrix->ts.kind,
8279	&matrix->where);
8280	result->rank = 2;
8281	result->shape = gfc_get_shape (result->rank);
8282	mpz_init_set (result->shape[0], matrix->shape[1]);
8283	mpz_init_set (result->shape[1], matrix->shape[0]);
8284
8285	if (matrix->ts.type == BT_CHARACTER)
8286	result->ts.u.cl = matrix->ts.u.cl;
8287	else if (matrix->ts.type == BT_DERIVED)
8288	result->ts.u.derived = matrix->ts.u.derived;
8289
8290	matrix_rows = mpz_get_si (matrix->shape[0]);
8291	matrix_cols = mpz_get_si (matrix->shape[1]);
8292	for (row = 0; row < matrix_rows; ++row)
8293	for (col = 0; col < matrix_cols; ++col)
8294	{
8295	gfc_expr *e = gfc_constructor_lookup_expr (base: matrix->value.constructor,
8296	n: col * matrix_rows + row);
8297	gfc_constructor_insert_expr (base: &result->value.constructor,
8298	e: gfc_copy_expr (e), where: &matrix->where,
8299	n: row * matrix_cols + col);
8300	}
8301
8302	return result;
8303	}
8304
8305
8306	gfc_expr *
8307	gfc_simplify_trim (gfc_expr *e)
8308	{
8309	gfc_expr *result;
8310	int count, i, len, lentrim;
8311
8312	if (e->expr_type != EXPR_CONSTANT)
8313	return NULL;
8314
8315	len = e->value.character.length;
8316	for (count = 0, i = 1; i <= len; ++i)
8317	{
8318	if (e->value.character.string[len - i] == ' ')
8319	count++;
8320	else
8321	break;
8322	}
8323
8324	lentrim = len - count;
8325
8326	result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len: lentrim);
8327	for (i = 0; i < lentrim; i++)
8328	result->value.character.string[i] = e->value.character.string[i];
8329
8330	return result;
8331	}
8332
8333
8334	gfc_expr *
8335	gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
8336	{
8337	gfc_expr *result;
8338	gfc_ref *ref;
8339	gfc_array_spec *as;
8340	gfc_constructor *sub_cons;
8341	bool first_image;
8342	int d;
8343
8344	if (!is_constant_array_expr (e: sub))
8345	return NULL;
8346
8347	/* Follow any component references. */
8348	as = coarray->symtree->n.sym->as;
8349	for (ref = coarray->ref; ref; ref = ref->next)
8350	if (ref->type == REF_COMPONENT)
8351	as = ref->u.ar.as;
8352
8353	if (!as || as->type == AS_DEFERRED)
8354	return NULL;
8355
8356	/* "valid sequence of cosubscripts" are required; thus, return 0 unless
8357	the cosubscript addresses the first image. */
8358
8359	sub_cons = gfc_constructor_first (base: sub->value.constructor);
8360	first_image = true;
8361
8362	for (d = 1; d <= as->corank; d++)
8363	{
8364	gfc_expr *ca_bound;
8365	int cmp;
8366
8367	gcc_assert (sub_cons != NULL);
8368
8369	ca_bound = simplify_bound_dim (array: coarray, NULL, d: d + as->rank, upper: 0, as,
8370	NULL, coarray: true);
8371	if (ca_bound == NULL)
8372	return NULL;
8373
8374	if (ca_bound == &gfc_bad_expr)
8375	return ca_bound;
8376
8377	cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer);
8378
8379	if (cmp == 0)
8380	{
8381	gfc_free_expr (ca_bound);
8382	sub_cons = gfc_constructor_next (ctor: sub_cons);
8383	continue;
8384	}
8385
8386	first_image = false;
8387
8388	if (cmp > 0)
8389	{
8390	gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
8391	"SUB has %ld and COARRAY lower bound is %ld)",
8392	&coarray->where, d,
8393	mpz_get_si (sub_cons->expr->value.integer),
8394	mpz_get_si (ca_bound->value.integer));
8395	gfc_free_expr (ca_bound);
8396	return &gfc_bad_expr;
8397	}
8398
8399	gfc_free_expr (ca_bound);
8400
8401	/* Check whether upperbound is valid for the multi-images case. */
8402	if (d < as->corank)
8403	{
8404	ca_bound = simplify_bound_dim (array: coarray, NULL, d: d + as->rank, upper: 1, as,
8405	NULL, coarray: true);
8406	if (ca_bound == &gfc_bad_expr)
8407	return ca_bound;
8408
8409	if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT
8410	&& mpz_cmp (ca_bound->value.integer,
8411	sub_cons->expr->value.integer) < 0)
8412	{
8413	gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
8414	"SUB has %ld and COARRAY upper bound is %ld)",
8415	&coarray->where, d,
8416	mpz_get_si (sub_cons->expr->value.integer),
8417	mpz_get_si (ca_bound->value.integer));
8418	gfc_free_expr (ca_bound);
8419	return &gfc_bad_expr;
8420	}
8421
8422	if (ca_bound)
8423	gfc_free_expr (ca_bound);
8424	}
8425
8426	sub_cons = gfc_constructor_next (ctor: sub_cons);
8427	}
8428
8429	gcc_assert (sub_cons == NULL);
8430
8431	if (flag_coarray != GFC_FCOARRAY_SINGLE && !first_image)
8432	return NULL;
8433
8434	result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
8435	&gfc_current_locus);
8436	if (first_image)
8437	mpz_set_si (result->value.integer, 1);
8438	else
8439	mpz_set_si (result->value.integer, 0);
8440
8441	return result;
8442	}
8443
8444	gfc_expr *
8445	gfc_simplify_image_status (gfc_expr *image, gfc_expr *team ATTRIBUTE_UNUSED)
8446	{
8447	if (flag_coarray == GFC_FCOARRAY_NONE)
8448	{
8449	gfc_current_locus = *gfc_current_intrinsic_where;
8450	gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
8451	return &gfc_bad_expr;
8452	}
8453
8454	/* Simplification is possible for fcoarray = single only. For all other modes
8455	the result depends on runtime conditions. */
8456	if (flag_coarray != GFC_FCOARRAY_SINGLE)
8457	return NULL;
8458
8459	if (gfc_is_constant_expr (image))
8460	{
8461	gfc_expr *result;
8462	result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
8463	&image->where);
8464	if (mpz_get_si (image->value.integer) == 1)
8465	mpz_set_si (result->value.integer, 0);
8466	else
8467	mpz_set_si (result->value.integer, GFC_STAT_STOPPED_IMAGE);
8468	return result;
8469	}
8470	else
8471	return NULL;
8472	}
8473
8474
8475	gfc_expr *
8476	gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim,
8477	gfc_expr *distance ATTRIBUTE_UNUSED)
8478	{
8479	if (flag_coarray != GFC_FCOARRAY_SINGLE)
8480	return NULL;
8481
8482	/* If no coarray argument has been passed or when the first argument
8483	is actually a distance argument. */
8484	if (coarray == NULL || !gfc_is_coarray (coarray))
8485	{
8486	gfc_expr *result;
8487	/* FIXME: gfc_current_locus is wrong. */
8488	result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
8489	&gfc_current_locus);
8490	mpz_set_si (result->value.integer, 1);
8491	return result;
8492	}
8493
8494	/* For -fcoarray=single, this_image(A) is the same as lcobound(A). */
8495	return simplify_cobound (array: coarray, dim, NULL, upper: 0);
8496	}
8497
8498
8499	gfc_expr *
8500	gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
8501	{
8502	return simplify_bound (array, dim, kind, upper: 1);
8503	}
8504
8505	gfc_expr *
8506	gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
8507	{
8508	return simplify_cobound (array, dim, kind, upper: 1);
8509	}
8510
8511
8512	gfc_expr *
8513	gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
8514	{
8515	gfc_expr *result, *e;
8516	gfc_constructor *vector_ctor, *mask_ctor, *field_ctor;
8517
8518	if (!is_constant_array_expr (e: vector)
8519	|| !is_constant_array_expr (e: mask)
8520	|| (!gfc_is_constant_expr (field)
8521	&& !is_constant_array_expr (e: field)))
8522	return NULL;
8523
8524	result = gfc_get_array_expr (type: vector->ts.type, kind: vector->ts.kind,
8525	&vector->where);
8526	if (vector->ts.type == BT_DERIVED)
8527	result->ts.u.derived = vector->ts.u.derived;
8528	result->rank = mask->rank;
8529	result->shape = gfc_copy_shape (mask->shape, mask->rank);
8530
8531	if (vector->ts.type == BT_CHARACTER)
8532	result->ts.u.cl = vector->ts.u.cl;
8533
8534	vector_ctor = gfc_constructor_first (base: vector->value.constructor);
8535	mask_ctor = gfc_constructor_first (base: mask->value.constructor);
8536	field_ctor
8537	= field->expr_type == EXPR_ARRAY
8538	? gfc_constructor_first (base: field->value.constructor)
8539	: NULL;
8540
8541	while (mask_ctor)
8542	{
8543	if (mask_ctor->expr->value.logical)
8544	{
8545	if (vector_ctor)
8546	{
8547	e = gfc_copy_expr (vector_ctor->expr);
8548	vector_ctor = gfc_constructor_next (ctor: vector_ctor);
8549	}
8550	else
8551	{
8552	gfc_free_expr (result);
8553	return NULL;
8554	}
8555	}
8556	else if (field->expr_type == EXPR_ARRAY)
8557	{
8558	if (field_ctor)
8559	e = gfc_copy_expr (field_ctor->expr);
8560	else
8561	{
8562	/* Not enough elements in array FIELD. */
8563	gfc_free_expr (result);
8564	return &gfc_bad_expr;
8565	}
8566	}
8567	else
8568	e = gfc_copy_expr (field);
8569
8570	gfc_constructor_append_expr (base: &result->value.constructor, e, NULL);
8571
8572	mask_ctor = gfc_constructor_next (ctor: mask_ctor);
8573	field_ctor = gfc_constructor_next (ctor: field_ctor);
8574	}
8575
8576	return result;
8577	}
8578
8579
8580	gfc_expr *
8581	gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
8582	{
8583	gfc_expr *result;
8584	int back;
8585	size_t index, len, lenset;
8586	size_t i;
8587	int k = get_kind (type: BT_INTEGER, k: kind, name: "VERIFY", default_kind: gfc_default_integer_kind);
8588
8589	if (k == -1)
8590	return &gfc_bad_expr;
8591
8592	if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT
8593	|| ( b != NULL && b->expr_type != EXPR_CONSTANT))
8594	return NULL;
8595
8596	if (b != NULL && b->value.logical != 0)
8597	back = 1;
8598	else
8599	back = 0;
8600
8601	result = gfc_get_constant_expr (BT_INTEGER, k, &s->where);
8602
8603	len = s->value.character.length;
8604	lenset = set->value.character.length;
8605
8606	if (len == 0)
8607	{
8608	mpz_set_ui (result->value.integer, 0);
8609	return result;
8610	}
8611
8612	if (back == 0)
8613	{
8614	if (lenset == 0)
8615	{
8616	mpz_set_ui (result->value.integer, 1);
8617	return result;
8618	}
8619
8620	index = wide_strspn (s1: s->value.character.string,
8621	s2: set->value.character.string) + 1;
8622	if (index > len)
8623	index = 0;
8624
8625	}
8626	else
8627	{
8628	if (lenset == 0)
8629	{
8630	mpz_set_ui (result->value.integer, len);
8631	return result;
8632	}
8633	for (index = len; index > 0; index --)
8634	{
8635	for (i = 0; i < lenset; i++)
8636	{
8637	if (s->value.character.string[index - 1]
8638	== set->value.character.string[i])
8639	break;
8640	}
8641	if (i == lenset)
8642	break;
8643	}
8644	}
8645
8646	mpz_set_ui (result->value.integer, index);
8647	return result;
8648	}
8649
8650
8651	gfc_expr *
8652	gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
8653	{
8654	gfc_expr *result;
8655	int kind;
8656
8657	if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
8658	return NULL;
8659
8660	kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
8661
8662	switch (x->ts.type)
8663	{
8664	case BT_INTEGER:
8665	result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
8666	mpz_xor (result->value.integer, x->value.integer, y->value.integer);
8667	return range_check (result, name: "XOR");
8668
8669	case BT_LOGICAL:
8670	return gfc_get_logical_expr (kind, &x->where,
8671	(x->value.logical && !y->value.logical)
8672	|| (!x->value.logical && y->value.logical));
8673
8674	default:
8675	gcc_unreachable ();
8676	}
8677	}
8678
8679
8680	/****************** Constant simplification *****************/
8681
8682	/* Master function to convert one constant to another. While this is
8683	used as a simplification function, it requires the destination type
8684	and kind information which is supplied by a special case in
8685	do_simplify(). */
8686
8687	gfc_expr *
8688	gfc_convert_constant (gfc_expr *e, bt type, int kind)
8689	{
8690	gfc_expr *result, *(*f) (gfc_expr *, int);
8691	gfc_constructor *c, *t;
8692
8693	switch (e->ts.type)
8694	{
8695	case BT_INTEGER:
8696	switch (type)
8697	{
8698	case BT_INTEGER:
8699	f = gfc_int2int;
8700	break;
8701	case BT_REAL:
8702	f = gfc_int2real;
8703	break;
8704	case BT_COMPLEX:
8705	f = gfc_int2complex;
8706	break;
8707	case BT_LOGICAL:
8708	f = gfc_int2log;
8709	break;
8710	default:
8711	goto oops;
8712	}
8713	break;
8714
8715	case BT_REAL:
8716	switch (type)
8717	{
8718	case BT_INTEGER:
8719	f = gfc_real2int;
8720	break;
8721	case BT_REAL:
8722	f = gfc_real2real;
8723	break;
8724	case BT_COMPLEX:
8725	f = gfc_real2complex;
8726	break;
8727	default:
8728	goto oops;
8729	}
8730	break;
8731
8732	case BT_COMPLEX:
8733	switch (type)
8734	{
8735	case BT_INTEGER:
8736	f = gfc_complex2int;
8737	break;
8738	case BT_REAL:
8739	f = gfc_complex2real;
8740	break;
8741	case BT_COMPLEX:
8742	f = gfc_complex2complex;
8743	break;
8744
8745	default:
8746	goto oops;
8747	}
8748	break;
8749
8750	case BT_LOGICAL:
8751	switch (type)
8752	{
8753	case BT_INTEGER:
8754	f = gfc_log2int;
8755	break;
8756	case BT_LOGICAL:
8757	f = gfc_log2log;
8758	break;
8759	default:
8760	goto oops;
8761	}
8762	break;
8763
8764	case BT_HOLLERITH:
8765	switch (type)
8766	{
8767	case BT_INTEGER:
8768	f = gfc_hollerith2int;
8769	break;
8770
8771	case BT_REAL:
8772	f = gfc_hollerith2real;
8773	break;
8774
8775	case BT_COMPLEX:
8776	f = gfc_hollerith2complex;
8777	break;
8778
8779	case BT_CHARACTER:
8780	f = gfc_hollerith2character;
8781	break;
8782
8783	case BT_LOGICAL:
8784	f = gfc_hollerith2logical;
8785	break;
8786
8787	default:
8788	goto oops;
8789	}
8790	break;
8791
8792	case BT_CHARACTER:
8793	switch (type)
8794	{
8795	case BT_INTEGER:
8796	f = gfc_character2int;
8797	break;
8798
8799	case BT_REAL:
8800	f = gfc_character2real;
8801	break;
8802
8803	case BT_COMPLEX:
8804	f = gfc_character2complex;
8805	break;
8806
8807	case BT_CHARACTER:
8808	f = gfc_character2character;
8809	break;
8810
8811	case BT_LOGICAL:
8812	f = gfc_character2logical;
8813	break;
8814
8815	default:
8816	goto oops;
8817	}
8818	break;
8819
8820	default:
8821	oops:
8822	return &gfc_bad_expr;
8823	}
8824
8825	result = NULL;
8826
8827	switch (e->expr_type)
8828	{
8829	case EXPR_CONSTANT:
8830	result = f (e, kind);
8831	if (result == NULL)
8832	return &gfc_bad_expr;
8833	break;
8834
8835	case EXPR_ARRAY:
8836	if (!gfc_is_constant_expr (e))
8837	break;
8838
8839	result = gfc_get_array_expr (type, kind, &e->where);
8840	result->shape = gfc_copy_shape (e->shape, e->rank);
8841	result->rank = e->rank;
8842
8843	for (c = gfc_constructor_first (base: e->value.constructor);
8844	c; c = gfc_constructor_next (ctor: c))
8845	{
8846	gfc_expr *tmp;
8847	if (c->iterator == NULL)
8848	{
8849	if (c->expr->expr_type == EXPR_ARRAY)
8850	tmp = gfc_convert_constant (e: c->expr, type, kind);
8851	else if (c->expr->expr_type == EXPR_OP)
8852	{
8853	if (!gfc_simplify_expr (c->expr, 1))
8854	return &gfc_bad_expr;
8855	tmp = f (c->expr, kind);
8856	}
8857	else
8858	tmp = f (c->expr, kind);
8859	}
8860	else
8861	tmp = gfc_convert_constant (e: c->expr, type, kind);
8862
8863	if (tmp == NULL || tmp == &gfc_bad_expr)
8864	{
8865	gfc_free_expr (result);
8866	return NULL;
8867	}
8868
8869	t = gfc_constructor_append_expr (base: &result->value.constructor,
8870	e: tmp, where: &c->where);
8871	if (c->iterator)
8872	t->iterator = gfc_copy_iterator (c->iterator);
8873	}
8874
8875	break;
8876
8877	default:
8878	break;
8879	}
8880
8881	return result;
8882	}
8883
8884
8885	/* Function for converting character constants. */
8886	gfc_expr *
8887	gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
8888	{
8889	gfc_expr *result;
8890	int i;
8891
8892	if (!gfc_is_constant_expr (e))
8893	return NULL;
8894
8895	if (e->expr_type == EXPR_CONSTANT)
8896	{
8897	/* Simple case of a scalar. */
8898	result = gfc_get_constant_expr (BT_CHARACTER, kind, &e->where);
8899	if (result == NULL)
8900	return &gfc_bad_expr;
8901
8902	result->value.character.length = e->value.character.length;
8903	result->value.character.string
8904	= gfc_get_wide_string (e->value.character.length + 1);
8905	memcpy (dest: result->value.character.string, src: e->value.character.string,
8906	n: (e->value.character.length + 1) * sizeof (gfc_char_t));
8907
8908	/* Check we only have values representable in the destination kind. */
8909	for (i = 0; i < result->value.character.length; i++)
8910	if (!gfc_check_character_range (result->value.character.string[i],
8911	kind))
8912	{
8913	gfc_error ("Character %qs in string at %L cannot be converted "
8914	"into character kind %d",
8915	gfc_print_wide_char (result->value.character.string[i]),
8916	&e->where, kind);
8917	gfc_free_expr (result);
8918	return &gfc_bad_expr;
8919	}
8920
8921	return result;
8922	}
8923	else if (e->expr_type == EXPR_ARRAY)
8924	{
8925	/* For an array constructor, we convert each constructor element. */
8926	gfc_constructor *c;
8927
8928	result = gfc_get_array_expr (type, kind, &e->where);
8929	result->shape = gfc_copy_shape (e->shape, e->rank);
8930	result->rank = e->rank;
8931	result->ts.u.cl = e->ts.u.cl;
8932
8933	for (c = gfc_constructor_first (base: e->value.constructor);
8934	c; c = gfc_constructor_next (ctor: c))
8935	{
8936	gfc_expr *tmp = gfc_convert_char_constant (e: c->expr, type, kind);
8937	if (tmp == &gfc_bad_expr)
8938	{
8939	gfc_free_expr (result);
8940	return &gfc_bad_expr;
8941	}
8942
8943	if (tmp == NULL)
8944	{
8945	gfc_free_expr (result);
8946	return NULL;
8947	}
8948
8949	gfc_constructor_append_expr (base: &result->value.constructor,
8950	e: tmp, where: &c->where);
8951	}
8952
8953	return result;
8954	}
8955	else
8956	return NULL;
8957	}
8958
8959
8960	gfc_expr *
8961	gfc_simplify_compiler_options (void)
8962	{
8963	char *str;
8964	gfc_expr *result;
8965
8966	str = gfc_get_option_string ();
8967	result = gfc_get_character_expr (gfc_default_character_kind,
8968	&gfc_current_locus, str, len: strlen (s: str));
8969	free (ptr: str);
8970	return result;
8971	}
8972
8973
8974	gfc_expr *
8975	gfc_simplify_compiler_version (void)
8976	{
8977	char *buffer;
8978	size_t len;
8979
8980	len = strlen (s: "GCC version ") + strlen (version_string);
8981	buffer = XALLOCAVEC (char, len + 1);
8982	snprintf (s: buffer, maxlen: len + 1, format: "GCC version %s", version_string);
8983	return gfc_get_character_expr (gfc_default_character_kind,
8984	&gfc_current_locus, buffer, len);
8985	}
8986
8987	/* Simplification routines for intrinsics of IEEE modules. */
8988
8989	gfc_expr *
8990	simplify_ieee_selected_real_kind (gfc_expr *expr)
8991	{
8992	gfc_actual_arglist *arg;
8993	gfc_expr *p = NULL, *q = NULL, *rdx = NULL;
8994
8995	arg = expr->value.function.actual;
8996	p = arg->expr;
8997	if (arg->next)
8998	{
8999	q = arg->next->expr;
9000	if (arg->next->next)
9001	rdx = arg->next->next->expr;
9002	}
9003
9004	/* Currently, if IEEE is supported and this module is built, it means
9005	all our floating-point types conform to IEEE. Hence, we simply handle
9006	IEEE_SELECTED_REAL_KIND like SELECTED_REAL_KIND. */
9007	return gfc_simplify_selected_real_kind (p, q, rdx);
9008	}
9009
9010	gfc_expr *
9011	simplify_ieee_support (gfc_expr *expr)
9012	{
9013	/* We consider that if the IEEE modules are loaded, we have full support
9014	for flags, halting and rounding, which are the three functions
9015	(IEEE_SUPPORT_{FLAG,HALTING,ROUNDING}) allowed in constant
9016	expressions. One day, we will need libgfortran to detect support and
9017	communicate it back to us, allowing for partial support. */
9018
9019	return gfc_get_logical_expr (gfc_default_logical_kind, &expr->where,
9020	true);
9021	}
9022
9023	bool
9024	matches_ieee_function_name (gfc_symbol *sym, const char *name)
9025	{
9026	int n = strlen(s: name);
9027
9028	if (!strncmp(s1: sym->name, s2: name, n: n))
9029	return true;
9030
9031	/* If a generic was used and renamed, we need more work to find out.
9032	Compare the specific name. */
9033	if (sym->generic && !strncmp(s1: sym->generic->sym->name, s2: name, n: n))
9034	return true;
9035
9036	return false;
9037	}
9038
9039	gfc_expr *
9040	gfc_simplify_ieee_functions (gfc_expr *expr)
9041	{
9042	gfc_symbol* sym = expr->symtree->n.sym;
9043
9044	if (matches_ieee_function_name(sym, name: "ieee_selected_real_kind"))
9045	return simplify_ieee_selected_real_kind (expr);
9046	else if (matches_ieee_function_name(sym, name: "ieee_support_flag")
9047	|| matches_ieee_function_name(sym, name: "ieee_support_halting")
9048	|| matches_ieee_function_name(sym, name: "ieee_support_rounding"))
9049	return simplify_ieee_support (expr);
9050	else
9051	return NULL;
9052	}
9053