1	/* Compiler arithmetic
2	Copyright (C) 2000-2023 Free Software Foundation, Inc.
3	Contributed by Andy Vaught
4
5	This file is part of GCC.
6
7	GCC is free software; you can redistribute it and/or modify it under
8	the terms of the GNU General Public License as published by the Free
9	Software Foundation; either version 3, or (at your option) any later
10	version.
11
12	GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13	WARRANTY; without even the implied warranty of MERCHANTABILITY or
14	FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15	for more details.
16
17	You should have received a copy of the GNU General Public License
18	along with GCC; see the file COPYING3. If not see
19	<http://www.gnu.org/licenses/>. */
20
21	/* Since target arithmetic must be done on the host, there has to
22	be some way of evaluating arithmetic expressions as the host
23	would evaluate them. We use the GNU MP library and the MPFR
24	library to do arithmetic, and this file provides the interface. */
25
26	#include "config.h"
27	#include "system.h"
28	#include "coretypes.h"
29	#include "options.h"
30	#include "gfortran.h"
31	#include "arith.h"
32	#include "target-memory.h"
33	#include "constructor.h"
34
35	bool gfc_seen_div0;
36
37	/* MPFR does not have a direct replacement for mpz_set_f() from GMP.
38	It's easily implemented with a few calls though. */
39
40	void
41	gfc_mpfr_to_mpz (mpz_t z, mpfr_t x, locus *where)
42	{
43	mpfr_exp_t e;
44
45	if (mpfr_inf_p (x) || mpfr_nan_p (x))
46	{
47	gfc_error ("Conversion of an Infinity or Not-a-Number at %L "
48	"to INTEGER", where);
49	mpz_set_ui (z, 0);
50	return;
51	}
52
53	e = mpfr_get_z_exp (z, x);
54
55	if (e > 0)
56	mpz_mul_2exp (z, z, e);
57	else
58	mpz_tdiv_q_2exp (z, z, -e);
59	}
60
61
62	/* Set the model number precision by the requested KIND. */
63
64	void
65	gfc_set_model_kind (int kind)
66	{
67	int index = gfc_validate_kind (BT_REAL, kind, false);
68	int base2prec;
69
70	base2prec = gfc_real_kinds[index].digits;
71	if (gfc_real_kinds[index].radix != 2)
72	base2prec *= gfc_real_kinds[index].radix / 2;
73	mpfr_set_default_prec (base2prec);
74	}
75
76
77	/* Set the model number precision from mpfr_t x. */
78
79	void
80	gfc_set_model (mpfr_t x)
81	{
82	mpfr_set_default_prec (mpfr_get_prec (x));
83	}
84
85
86	/* Given an arithmetic error code, return a pointer to a string that
87	explains the error. */
88
89	static const char *
90	gfc_arith_error (arith code)
91	{
92	const char *p;
93
94	switch (code)
95	{
96	case ARITH_OK:
97	p = G_("Arithmetic OK at %L");
98	break;
99	case ARITH_OVERFLOW:
100	p = G_("Arithmetic overflow at %L");
101	break;
102	case ARITH_UNDERFLOW:
103	p = G_("Arithmetic underflow at %L");
104	break;
105	case ARITH_NAN:
106	p = G_("Arithmetic NaN at %L");
107	break;
108	case ARITH_DIV0:
109	p = G_("Division by zero at %L");
110	break;
111	case ARITH_INCOMMENSURATE:
112	p = G_("Array operands are incommensurate at %L");
113	break;
114	case ARITH_ASYMMETRIC:
115	p = G_("Integer outside symmetric range implied by Standard Fortran"
116	" at %L");
117	break;
118	case ARITH_WRONGCONCAT:
119	p = G_("Illegal type in character concatenation at %L");
120	break;
121	case ARITH_INVALID_TYPE:
122	p = G_("Invalid type in arithmetic operation at %L");
123	break;
124
125	default:
126	gfc_internal_error ("gfc_arith_error(): Bad error code");
127	}
128
129	return p;
130	}
131
132
133	/* Get things ready to do math. */
134
135	void
136	gfc_arith_init_1 (void)
137	{
138	gfc_integer_info *int_info;
139	gfc_real_info *real_info;
140	mpfr_t a, b;
141	int i;
142
143	mpfr_set_default_prec (128);
144	mpfr_init (a);
145
146	/* Convert the minimum and maximum values for each kind into their
147	GNU MP representation. */
148	for (int_info = gfc_integer_kinds; int_info->kind != 0; int_info++)
149	{
150	/* Huge */
151	mpz_init (int_info->huge);
152	mpz_set_ui (int_info->huge, int_info->radix);
153	mpz_pow_ui (int_info->huge, int_info->huge, int_info->digits);
154	mpz_sub_ui (int_info->huge, int_info->huge, 1);
155
156	/* These are the numbers that are actually representable by the
157	target. For bases other than two, this needs to be changed. */
158	if (int_info->radix != 2)
159	gfc_internal_error ("Fix min_int calculation");
160
161	/* See PRs 13490 and 17912, related to integer ranges.
162	The pedantic_min_int exists for range checking when a program
163	is compiled with -pedantic, and reflects the belief that
164	Standard Fortran requires integers to be symmetrical, i.e.
165	every negative integer must have a representable positive
166	absolute value, and vice versa. */
167
168	mpz_init (int_info->pedantic_min_int);
169	mpz_neg (gmp_w: int_info->pedantic_min_int, gmp_u: int_info->huge);
170
171	mpz_init (int_info->min_int);
172	mpz_sub_ui (int_info->min_int, int_info->pedantic_min_int, 1);
173
174	/* Range */
175	mpfr_set_z (a, int_info->huge, GFC_RND_MODE);
176	mpfr_log10 (a, a, GFC_RND_MODE);
177	mpfr_trunc (a, a);
178	int_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
179	}
180
181	mpfr_clear (a);
182
183	for (real_info = gfc_real_kinds; real_info->kind != 0; real_info++)
184	{
185	gfc_set_model_kind (kind: real_info->kind);
186
187	mpfr_init (a);
188	mpfr_init (b);
189
190	/* huge(x) = (1 - b**(-p)) * b**(emax-1) * b */
191	/* 1 - b**(-p) */
192	mpfr_init (real_info->huge);
193	mpfr_set_ui (real_info->huge, 1, GFC_RND_MODE);
194	mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
195	mpfr_pow_si (a, a, -real_info->digits, GFC_RND_MODE);
196	mpfr_sub (real_info->huge, real_info->huge, a, GFC_RND_MODE);
197
198	/* b**(emax-1) */
199	mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
200	mpfr_pow_ui (a, a, real_info->max_exponent - 1, GFC_RND_MODE);
201
202	/* (1 - b**(-p)) * b**(emax-1) */
203	mpfr_mul (real_info->huge, real_info->huge, a, GFC_RND_MODE);
204
205	/* (1 - b**(-p)) * b**(emax-1) * b */
206	mpfr_mul_ui (real_info->huge, real_info->huge, real_info->radix,
207	GFC_RND_MODE);
208
209	/* tiny(x) = b**(emin-1) */
210	mpfr_init (real_info->tiny);
211	mpfr_set_ui (real_info->tiny, real_info->radix, GFC_RND_MODE);
212	mpfr_pow_si (real_info->tiny, real_info->tiny,
213	real_info->min_exponent - 1, GFC_RND_MODE);
214
215	/* subnormal (x) = b**(emin - digit) */
216	mpfr_init (real_info->subnormal);
217	mpfr_set_ui (real_info->subnormal, real_info->radix, GFC_RND_MODE);
218	mpfr_pow_si (real_info->subnormal, real_info->subnormal,
219	real_info->min_exponent - real_info->digits, GFC_RND_MODE);
220
221	/* epsilon(x) = b**(1-p) */
222	mpfr_init (real_info->epsilon);
223	mpfr_set_ui (real_info->epsilon, real_info->radix, GFC_RND_MODE);
224	mpfr_pow_si (real_info->epsilon, real_info->epsilon,
225	1 - real_info->digits, GFC_RND_MODE);
226
227	/* range(x) = int(min(log10(huge(x)), -log10(tiny)) */
228	mpfr_log10 (a, real_info->huge, GFC_RND_MODE);
229	mpfr_log10 (b, real_info->tiny, GFC_RND_MODE);
230	mpfr_neg (b, b, GFC_RND_MODE);
231
232	/* a = min(a, b) */
233	mpfr_min (a, a, b, GFC_RND_MODE);
234	mpfr_trunc (a, a);
235	real_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
236
237	/* precision(x) = int((p - 1) * log10(b)) + k */
238	mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
239	mpfr_log10 (a, a, GFC_RND_MODE);
240	mpfr_mul_ui (a, a, real_info->digits - 1, GFC_RND_MODE);
241	mpfr_trunc (a, a);
242	real_info->precision = (int) mpfr_get_si (a, GFC_RND_MODE);
243
244	/* If the radix is an integral power of 10, add one to the precision. */
245	for (i = 10; i <= real_info->radix; i *= 10)
246	if (i == real_info->radix)
247	real_info->precision++;
248
249	mpfr_clears (a, b, NULL);
250	}
251	}
252
253
254	/* Clean up, get rid of numeric constants. */
255
256	void
257	gfc_arith_done_1 (void)
258	{
259	gfc_integer_info *ip;
260	gfc_real_info *rp;
261
262	for (ip = gfc_integer_kinds; ip->kind; ip++)
263	{
264	mpz_clear (ip->min_int);
265	mpz_clear (ip->pedantic_min_int);
266	mpz_clear (ip->huge);
267	}
268
269	for (rp = gfc_real_kinds; rp->kind; rp++)
270	mpfr_clears (rp->epsilon, rp->huge, rp->tiny, rp->subnormal, NULL);
271
272	mpfr_free_cache ();
273	}
274
275
276	/* Given a wide character value and a character kind, determine whether
277	the character is representable for that kind. */
278	bool
279	gfc_check_character_range (gfc_char_t c, int kind)
280	{
281	/* As wide characters are stored as 32-bit values, they're all
282	representable in UCS=4. */
283	if (kind == 4)
284	return true;
285
286	if (kind == 1)
287	return c <= 255 ? true : false;
288
289	gcc_unreachable ();
290	}
291
292
293	/* Given an integer and a kind, make sure that the integer lies within
294	the range of the kind. Returns ARITH_OK, ARITH_ASYMMETRIC or
295	ARITH_OVERFLOW. */
296
297	arith
298	gfc_check_integer_range (mpz_t p, int kind)
299	{
300	arith result;
301	int i;
302
303	i = gfc_validate_kind (BT_INTEGER, kind, false);
304	result = ARITH_OK;
305
306	if (pedantic)
307	{
308	if (mpz_cmp (p, gfc_integer_kinds[i].pedantic_min_int) < 0)
309	result = ARITH_ASYMMETRIC;
310	}
311
312
313	if (flag_range_check == 0)
314	return result;
315
316	if (mpz_cmp (p, gfc_integer_kinds[i].min_int) < 0
317	|| mpz_cmp (p, gfc_integer_kinds[i].huge) > 0)
318	result = ARITH_OVERFLOW;
319
320	return result;
321	}
322
323
324	/* Given a real and a kind, make sure that the real lies within the
325	range of the kind. Returns ARITH_OK, ARITH_OVERFLOW or
326	ARITH_UNDERFLOW. */
327
328	static arith
329	gfc_check_real_range (mpfr_t p, int kind)
330	{
331	arith retval;
332	mpfr_t q;
333	int i;
334
335	i = gfc_validate_kind (BT_REAL, kind, false);
336
337	gfc_set_model (x: p);
338	mpfr_init (q);
339	mpfr_abs (q, p, GFC_RND_MODE);
340
341	retval = ARITH_OK;
342
343	if (mpfr_inf_p (p))
344	{
345	if (flag_range_check != 0)
346	retval = ARITH_OVERFLOW;
347	}
348	else if (mpfr_nan_p (p))
349	{
350	if (flag_range_check != 0)
351	retval = ARITH_NAN;
352	}
353	else if (mpfr_sgn (q) == 0)
354	{
355	mpfr_clear (q);
356	return retval;
357	}
358	else if (mpfr_cmp (q, gfc_real_kinds[i].huge) > 0)
359	{
360	if (flag_range_check == 0)
361	mpfr_set_inf (p, mpfr_sgn (p));
362	else
363	retval = ARITH_OVERFLOW;
364	}
365	else if (mpfr_cmp (q, gfc_real_kinds[i].subnormal) < 0)
366	{
367	if (flag_range_check == 0)
368	{
369	if (mpfr_sgn (p) < 0)
370	{
371	mpfr_set_ui (p, 0, GFC_RND_MODE);
372	mpfr_set_si (q, -1, GFC_RND_MODE);
373	mpfr_copysign (p, p, q, GFC_RND_MODE);
374	}
375	else
376	mpfr_set_ui (p, 0, GFC_RND_MODE);
377	}
378	else
379	retval = ARITH_UNDERFLOW;
380	}
381	else if (mpfr_cmp (q, gfc_real_kinds[i].tiny) < 0)
382	{
383	mpfr_exp_t emin, emax;
384	int en;
385
386	/* Save current values of emin and emax. */
387	emin = mpfr_get_emin ();
388	emax = mpfr_get_emax ();
389
390	/* Set emin and emax for the current model number. */
391	en = gfc_real_kinds[i].min_exponent - gfc_real_kinds[i].digits + 1;
392	mpfr_set_emin ((mpfr_exp_t) en);
393	mpfr_set_emax ((mpfr_exp_t) gfc_real_kinds[i].max_exponent);
394	mpfr_check_range (q, 0, GFC_RND_MODE);
395	mpfr_subnormalize (q, 0, GFC_RND_MODE);
396
397	/* Reset emin and emax. */
398	mpfr_set_emin (emin);
399	mpfr_set_emax (emax);
400
401	/* Copy sign if needed. */
402	if (mpfr_sgn (p) < 0)
403	mpfr_neg (p, q, MPFR_RNDN);
404	else
405	mpfr_set (p, q, MPFR_RNDN);
406	}
407
408	mpfr_clear (q);
409
410	return retval;
411	}
412
413
414	/* Low-level arithmetic functions. All of these subroutines assume
415	that all operands are of the same type and return an operand of the
416	same type. The other thing about these subroutines is that they
417	can fail in various ways -- overflow, underflow, division by zero,
418	zero raised to the zero, etc. */
419
420	static arith
421	gfc_arith_not (gfc_expr *op1, gfc_expr **resultp)
422	{
423	gfc_expr *result;
424
425	if (op1->ts.type != BT_LOGICAL)
426	return ARITH_INVALID_TYPE;
427
428	result = gfc_get_constant_expr (BT_LOGICAL, op1->ts.kind, &op1->where);
429	result->value.logical = !op1->value.logical;
430	*resultp = result;
431
432	return ARITH_OK;
433	}
434
435
436	static arith
437	gfc_arith_and (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
438	{
439	gfc_expr *result;
440
441	if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
442	return ARITH_INVALID_TYPE;
443
444	result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
445	&op1->where);
446	result->value.logical = op1->value.logical && op2->value.logical;
447	*resultp = result;
448
449	return ARITH_OK;
450	}
451
452
453	static arith
454	gfc_arith_or (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
455	{
456	gfc_expr *result;
457
458	if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
459	return ARITH_INVALID_TYPE;
460
461	result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
462	&op1->where);
463	result->value.logical = op1->value.logical || op2->value.logical;
464	*resultp = result;
465
466	return ARITH_OK;
467	}
468
469
470	static arith
471	gfc_arith_eqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
472	{
473	gfc_expr *result;
474
475	if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
476	return ARITH_INVALID_TYPE;
477
478	result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
479	&op1->where);
480	result->value.logical = op1->value.logical == op2->value.logical;
481	*resultp = result;
482
483	return ARITH_OK;
484	}
485
486
487	static arith
488	gfc_arith_neqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
489	{
490	gfc_expr *result;
491
492	if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
493	return ARITH_INVALID_TYPE;
494
495	result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
496	&op1->where);
497	result->value.logical = op1->value.logical != op2->value.logical;
498	*resultp = result;
499
500	return ARITH_OK;
501	}
502
503
504	/* Make sure a constant numeric expression is within the range for
505	its type and kind. Note that there's also a gfc_check_range(),
506	but that one deals with the intrinsic RANGE function. */
507
508	arith
509	gfc_range_check (gfc_expr *e)
510	{
511	arith rc;
512	arith rc2;
513
514	switch (e->ts.type)
515	{
516	case BT_INTEGER:
517	rc = gfc_check_integer_range (p: e->value.integer, kind: e->ts.kind);
518	break;
519
520	case BT_REAL:
521	rc = gfc_check_real_range (p: e->value.real, kind: e->ts.kind);
522	if (rc == ARITH_UNDERFLOW)
523	mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
524	if (rc == ARITH_OVERFLOW)
525	mpfr_set_inf (e->value.real, mpfr_sgn (e->value.real));
526	if (rc == ARITH_NAN)
527	mpfr_set_nan (e->value.real);
528	break;
529
530	case BT_COMPLEX:
531	rc = gfc_check_real_range (mpc_realref (e->value.complex), kind: e->ts.kind);
532	if (rc == ARITH_UNDERFLOW)
533	mpfr_set_ui (mpc_realref (e->value.complex), 0, GFC_RND_MODE);
534	if (rc == ARITH_OVERFLOW)
535	mpfr_set_inf (mpc_realref (e->value.complex),
536	mpfr_sgn (mpc_realref (e->value.complex)));
537	if (rc == ARITH_NAN)
538	mpfr_set_nan (mpc_realref (e->value.complex));
539
540	rc2 = gfc_check_real_range (mpc_imagref (e->value.complex), kind: e->ts.kind);
541	if (rc == ARITH_UNDERFLOW)
542	mpfr_set_ui (mpc_imagref (e->value.complex), 0, GFC_RND_MODE);
543	if (rc == ARITH_OVERFLOW)
544	mpfr_set_inf (mpc_imagref (e->value.complex),
545	mpfr_sgn (mpc_imagref (e->value.complex)));
546	if (rc == ARITH_NAN)
547	mpfr_set_nan (mpc_imagref (e->value.complex));
548
549	if (rc == ARITH_OK)
550	rc = rc2;
551	break;
552
553	default:
554	gfc_internal_error ("gfc_range_check(): Bad type");
555	}
556
557	return rc;
558	}
559
560
561	/* Several of the following routines use the same set of statements to
562	check the validity of the result. Encapsulate the checking here. */
563
564	static arith
565	check_result (arith rc, gfc_expr *x, gfc_expr *r, gfc_expr **rp)
566	{
567	arith val = rc;
568
569	if (val == ARITH_UNDERFLOW)
570	{
571	if (warn_underflow)
572	gfc_warning (opt: OPT_Wunderflow, gfc_arith_error (code: val), &x->where);
573	val = ARITH_OK;
574	}
575
576	if (val == ARITH_ASYMMETRIC)
577	{
578	gfc_warning (opt: 0, gfc_arith_error (code: val), &x->where);
579	val = ARITH_OK;
580	}
581
582	if (val == ARITH_OK || val == ARITH_OVERFLOW)
583	*rp = r;
584	else
585	gfc_free_expr (r);
586
587	return val;
588	}
589
590
591	/* It may seem silly to have a subroutine that actually computes the
592	unary plus of a constant, but it prevents us from making exceptions
593	in the code elsewhere. Used for unary plus and parenthesized
594	expressions. */
595
596	static arith
597	gfc_arith_identity (gfc_expr *op1, gfc_expr **resultp)
598	{
599	*resultp = gfc_copy_expr (op1);
600	return ARITH_OK;
601	}
602
603
604	static arith
605	gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp)
606	{
607	gfc_expr *result;
608	arith rc;
609
610	result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
611
612	switch (op1->ts.type)
613	{
614	case BT_INTEGER:
615	mpz_neg (gmp_w: result->value.integer, gmp_u: op1->value.integer);
616	break;
617
618	case BT_REAL:
619	mpfr_neg (result->value.real, op1->value.real, GFC_RND_MODE);
620	break;
621
622	case BT_COMPLEX:
623	mpc_neg (result->value.complex, op1->value.complex, GFC_MPC_RND_MODE);
624	break;
625
626	default:
627	gfc_internal_error ("gfc_arith_uminus(): Bad basic type");
628	}
629
630	rc = gfc_range_check (e: result);
631
632	return check_result (rc, x: op1, r: result, rp: resultp);
633	}
634
635
636	static arith
637	gfc_arith_plus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
638	{
639	gfc_expr *result;
640	arith rc;
641
642	if (op1->ts.type != op2->ts.type)
643	return ARITH_INVALID_TYPE;
644
645	result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
646
647	switch (op1->ts.type)
648	{
649	case BT_INTEGER:
650	mpz_add (result->value.integer, op1->value.integer, op2->value.integer);
651	break;
652
653	case BT_REAL:
654	mpfr_add (result->value.real, op1->value.real, op2->value.real,
655	GFC_RND_MODE);
656	break;
657
658	case BT_COMPLEX:
659	mpc_add (result->value.complex, op1->value.complex, op2->value.complex,
660	GFC_MPC_RND_MODE);
661	break;
662
663	default:
664	gfc_internal_error ("gfc_arith_plus(): Bad basic type");
665	}
666
667	rc = gfc_range_check (e: result);
668
669	return check_result (rc, x: op1, r: result, rp: resultp);
670	}
671
672
673	static arith
674	gfc_arith_minus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
675	{
676	gfc_expr *result;
677	arith rc;
678
679	if (op1->ts.type != op2->ts.type)
680	return ARITH_INVALID_TYPE;
681
682	result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
683
684	switch (op1->ts.type)
685	{
686	case BT_INTEGER:
687	mpz_sub (result->value.integer, op1->value.integer, op2->value.integer);
688	break;
689
690	case BT_REAL:
691	mpfr_sub (result->value.real, op1->value.real, op2->value.real,
692	GFC_RND_MODE);
693	break;
694
695	case BT_COMPLEX:
696	mpc_sub (result->value.complex, op1->value.complex,
697	op2->value.complex, GFC_MPC_RND_MODE);
698	break;
699
700	default:
701	gfc_internal_error ("gfc_arith_minus(): Bad basic type");
702	}
703
704	rc = gfc_range_check (e: result);
705
706	return check_result (rc, x: op1, r: result, rp: resultp);
707	}
708
709
710	static arith
711	gfc_arith_times (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
712	{
713	gfc_expr *result;
714	arith rc;
715
716	if (op1->ts.type != op2->ts.type)
717	return ARITH_INVALID_TYPE;
718
719	result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
720
721	switch (op1->ts.type)
722	{
723	case BT_INTEGER:
724	mpz_mul (result->value.integer, op1->value.integer, op2->value.integer);
725	break;
726
727	case BT_REAL:
728	mpfr_mul (result->value.real, op1->value.real, op2->value.real,
729	GFC_RND_MODE);
730	break;
731
732	case BT_COMPLEX:
733	gfc_set_model (mpc_realref (op1->value.complex));
734	mpc_mul (result->value.complex, op1->value.complex, op2->value.complex,
735	GFC_MPC_RND_MODE);
736	break;
737
738	default:
739	gfc_internal_error ("gfc_arith_times(): Bad basic type");
740	}
741
742	rc = gfc_range_check (e: result);
743
744	return check_result (rc, x: op1, r: result, rp: resultp);
745	}
746
747
748	static arith
749	gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
750	{
751	gfc_expr *result;
752	arith rc;
753
754	if (op1->ts.type != op2->ts.type)
755	return ARITH_INVALID_TYPE;
756
757	rc = ARITH_OK;
758
759	result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
760
761	switch (op1->ts.type)
762	{
763	case BT_INTEGER:
764	if (mpz_sgn (op2->value.integer) == 0)
765	{
766	rc = ARITH_DIV0;
767	break;
768	}
769
770	if (warn_integer_division)
771	{
772	mpz_t r;
773	mpz_init (r);
774	mpz_tdiv_qr (result->value.integer, r, op1->value.integer,
775	op2->value.integer);
776
777	if (mpz_cmp_si (r, 0) != 0)
778	{
779	char *p;
780	p = mpz_get_str (NULL, 10, result->value.integer);
781	gfc_warning (opt: OPT_Winteger_division, "Integer division "
782	"truncated to constant %qs at %L", p,
783	&op1->where);
784	free (ptr: p);
785	}
786	mpz_clear (r);
787	}
788	else
789	mpz_tdiv_q (result->value.integer, op1->value.integer,
790	op2->value.integer);
791
792	break;
793
794	case BT_REAL:
795	if (mpfr_sgn (op2->value.real) == 0 && flag_range_check == 1)
796	{
797	rc = ARITH_DIV0;
798	break;
799	}
800
801	mpfr_div (result->value.real, op1->value.real, op2->value.real,
802	GFC_RND_MODE);
803	break;
804
805	case BT_COMPLEX:
806	if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0
807	&& flag_range_check == 1)
808	{
809	rc = ARITH_DIV0;
810	break;
811	}
812
813	gfc_set_model (mpc_realref (op1->value.complex));
814	if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0)
815	{
816	/* In Fortran, return (NaN + NaN I) for any zero divisor. See
817	PR 40318. */
818	mpfr_set_nan (mpc_realref (result->value.complex));
819	mpfr_set_nan (mpc_imagref (result->value.complex));
820	}
821	else
822	mpc_div (result->value.complex, op1->value.complex, op2->value.complex,
823	GFC_MPC_RND_MODE);
824	break;
825
826	default:
827	gfc_internal_error ("gfc_arith_divide(): Bad basic type");
828	}
829
830	if (rc == ARITH_OK)
831	rc = gfc_range_check (e: result);
832
833	return check_result (rc, x: op1, r: result, rp: resultp);
834	}
835
836	/* Raise a number to a power. */
837
838	static arith
839	arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
840	{
841	int power_sign;
842	gfc_expr *result;
843	arith rc;
844
845	if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts))
846	return ARITH_INVALID_TYPE;
847
848	/* The result type is derived from op1 and must be compatible with the
849	result of the simplification. Otherwise postpone simplification until
850	after operand conversions usually done by gfc_type_convert_binary. */
851	if ((op1->ts.type == BT_INTEGER && op2->ts.type != BT_INTEGER)
852	|| (op1->ts.type == BT_REAL && op2->ts.type == BT_COMPLEX))
853	return ARITH_NOT_REDUCED;
854
855	rc = ARITH_OK;
856	result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
857
858	switch (op2->ts.type)
859	{
860	case BT_INTEGER:
861	power_sign = mpz_sgn (op2->value.integer);
862
863	if (power_sign == 0)
864	{
865	/* Handle something to the zeroth power. Since we're dealing
866	with integral exponents, there is no ambiguity in the
867	limiting procedure used to determine the value of 0**0. */
868	switch (op1->ts.type)
869	{
870	case BT_INTEGER:
871	mpz_set_ui (result->value.integer, 1);
872	break;
873
874	case BT_REAL:
875	mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
876	break;
877
878	case BT_COMPLEX:
879	mpc_set_ui (result->value.complex, 1, GFC_MPC_RND_MODE);
880	break;
881
882	default:
883	gfc_internal_error ("arith_power(): Bad base");
884	}
885	}
886	else
887	{
888	switch (op1->ts.type)
889	{
890	case BT_INTEGER:
891	{
892	/* First, we simplify the cases of op1 == 1, 0 or -1. */
893	if (mpz_cmp_si (op1->value.integer, 1) == 0)
894	{
895	/* 1**op2 == 1 */
896	mpz_set_si (result->value.integer, 1);
897	}
898	else if (mpz_cmp_si (op1->value.integer, 0) == 0)
899	{
900	/* 0**op2 == 0, if op2 > 0
901	0**op2 overflow, if op2 < 0 ; in that case, we
902	set the result to 0 and return ARITH_DIV0. */
903	mpz_set_si (result->value.integer, 0);
904	if (mpz_cmp_si (op2->value.integer, 0) < 0)
905	rc = ARITH_DIV0;
906	}
907	else if (mpz_cmp_si (op1->value.integer, -1) == 0)
908	{
909	/* (-1)**op2 == (-1)**(mod(op2,2)) */
910	unsigned int odd = mpz_fdiv_ui (op2->value.integer, 2);
911	if (odd)
912	mpz_set_si (result->value.integer, -1);
913	else
914	mpz_set_si (result->value.integer, 1);
915	}
916	/* Then, we take care of op2 < 0. */
917	else if (mpz_cmp_si (op2->value.integer, 0) < 0)
918	{
919	/* if op2 < 0, op1**op2 == 0 because abs(op1) > 1. */
920	mpz_set_si (result->value.integer, 0);
921	if (warn_integer_division)
922	gfc_warning_now (opt: OPT_Winteger_division, "Negative "
923	"exponent of integer has zero "
924	"result at %L", &result->where);
925	}
926	else
927	{
928	/* We have abs(op1) > 1 and op2 > 1.
929	If op2 > bit_size(op1), we'll have an out-of-range
930	result. */
931	int k, power;
932
933	k = gfc_validate_kind (BT_INTEGER, op1->ts.kind, false);
934	power = gfc_integer_kinds[k].bit_size;
935	if (mpz_cmp_si (op2->value.integer, power) < 0)
936	{
937	gfc_extract_int (op2, &power);
938	mpz_pow_ui (result->value.integer, op1->value.integer,
939	power);
940	rc = gfc_range_check (e: result);
941	if (rc == ARITH_OVERFLOW)
942	gfc_error_now ("Result of exponentiation at %L "
943	"exceeds the range of %s", &op1->where,
944	gfc_typename (&(op1->ts)));
945	}
946	else
947	{
948	/* Provide a nonsense value to propagate up. */
949	mpz_set (result->value.integer,
950	gfc_integer_kinds[k].huge);
951	mpz_add_ui (result->value.integer,
952	result->value.integer, 1);
953	rc = ARITH_OVERFLOW;
954	}
955	}
956	}
957	break;
958
959	case BT_REAL:
960	mpfr_pow_z (result->value.real, op1->value.real,
961	op2->value.integer, GFC_RND_MODE);
962	break;
963
964	case BT_COMPLEX:
965	mpc_pow_z (result->value.complex, op1->value.complex,
966	op2->value.integer, GFC_MPC_RND_MODE);
967	break;
968
969	default:
970	break;
971	}
972	}
973	break;
974
975	case BT_REAL:
976
977	if (gfc_init_expr_flag)
978	{
979	if (!gfc_notify_std (GFC_STD_F2003, "Noninteger "
980	"exponent in an initialization "
981	"expression at %L", &op2->where))
982	{
983	gfc_free_expr (result);
984	return ARITH_PROHIBIT;
985	}
986	}
987
988	if (mpfr_cmp_si (op1->value.real, 0) < 0)
989	{
990	gfc_error ("Raising a negative REAL at %L to "
991	"a REAL power is prohibited", &op1->where);
992	gfc_free_expr (result);
993	return ARITH_PROHIBIT;
994	}
995
996	mpfr_pow (result->value.real, op1->value.real, op2->value.real,
997	GFC_RND_MODE);
998	break;
999
1000	case BT_COMPLEX:
1001	{
1002	if (gfc_init_expr_flag)
1003	{
1004	if (!gfc_notify_std (GFC_STD_F2003, "Noninteger "
1005	"exponent in an initialization "
1006	"expression at %L", &op2->where))
1007	{
1008	gfc_free_expr (result);
1009	return ARITH_PROHIBIT;
1010	}
1011	}
1012
1013	mpc_pow (result->value.complex, op1->value.complex,
1014	op2->value.complex, GFC_MPC_RND_MODE);
1015	}
1016	break;
1017	default:
1018	gfc_internal_error ("arith_power(): unknown type");
1019	}
1020
1021	if (rc == ARITH_OK)
1022	rc = gfc_range_check (e: result);
1023
1024	return check_result (rc, x: op1, r: result, rp: resultp);
1025	}
1026
1027
1028	/* Concatenate two string constants. */
1029
1030	static arith
1031	gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1032	{
1033	gfc_expr *result;
1034	size_t len;
1035
1036	/* By cleverly playing around with constructors, it is possible
1037	to get mismatching types here. */
1038	if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER
1039	|| op1->ts.kind != op2->ts.kind)
1040	return ARITH_WRONGCONCAT;
1041
1042	result = gfc_get_constant_expr (BT_CHARACTER, op1->ts.kind,
1043	&op1->where);
1044
1045	len = op1->value.character.length + op2->value.character.length;
1046
1047	result->value.character.string = gfc_get_wide_string (len + 1);
1048	result->value.character.length = len;
1049
1050	memcpy (dest: result->value.character.string, src: op1->value.character.string,
1051	n: op1->value.character.length * sizeof (gfc_char_t));
1052
1053	memcpy (dest: &result->value.character.string[op1->value.character.length],
1054	src: op2->value.character.string,
1055	n: op2->value.character.length * sizeof (gfc_char_t));
1056
1057	result->value.character.string[len] = '\0';
1058
1059	*resultp = result;
1060
1061	return ARITH_OK;
1062	}
1063
1064	/* Comparison between real values; returns 0 if (op1 .op. op2) is true.
1065	This function mimics mpfr_cmp but takes NaN into account. */
1066
1067	static int
1068	compare_real (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1069	{
1070	int rc;
1071	switch (op)
1072	{
1073	case INTRINSIC_EQ:
1074	rc = mpfr_equal_p (op1->value.real, op2->value.real) ? 0 : 1;
1075	break;
1076	case INTRINSIC_GT:
1077	rc = mpfr_greater_p (op1->value.real, op2->value.real) ? 1 : -1;
1078	break;
1079	case INTRINSIC_GE:
1080	rc = mpfr_greaterequal_p (op1->value.real, op2->value.real) ? 1 : -1;
1081	break;
1082	case INTRINSIC_LT:
1083	rc = mpfr_less_p (op1->value.real, op2->value.real) ? -1 : 1;
1084	break;
1085	case INTRINSIC_LE:
1086	rc = mpfr_lessequal_p (op1->value.real, op2->value.real) ? -1 : 1;
1087	break;
1088	default:
1089	gfc_internal_error ("compare_real(): Bad operator");
1090	}
1091
1092	return rc;
1093	}
1094
1095	/* Comparison operators. Assumes that the two expression nodes
1096	contain two constants of the same type. The op argument is
1097	needed to handle NaN correctly. */
1098
1099	int
1100	gfc_compare_expr (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1101	{
1102	int rc;
1103
1104	switch (op1->ts.type)
1105	{
1106	case BT_INTEGER:
1107	rc = mpz_cmp (op1->value.integer, op2->value.integer);
1108	break;
1109
1110	case BT_REAL:
1111	rc = compare_real (op1, op2, op);
1112	break;
1113
1114	case BT_CHARACTER:
1115	rc = gfc_compare_string (op1, op2);
1116	break;
1117
1118	case BT_LOGICAL:
1119	rc = ((!op1->value.logical && op2->value.logical)
1120	|| (op1->value.logical && !op2->value.logical));
1121	break;
1122
1123	case BT_COMPLEX:
1124	gcc_assert (op == INTRINSIC_EQ);
1125	rc = mpc_cmp (op1->value.complex, op2->value.complex);
1126	break;
1127
1128	default:
1129	gfc_internal_error ("gfc_compare_expr(): Bad basic type");
1130	}
1131
1132	return rc;
1133	}
1134
1135
1136	/* Compare a pair of complex numbers. Naturally, this is only for
1137	equality and inequality. */
1138
1139	static int
1140	compare_complex (gfc_expr *op1, gfc_expr *op2)
1141	{
1142	return mpc_cmp (op1->value.complex, op2->value.complex) == 0;
1143	}
1144
1145
1146	/* Given two constant strings and the inverse collating sequence, compare the
1147	strings. We return -1 for a < b, 0 for a == b and 1 for a > b.
1148	We use the processor's default collating sequence. */
1149
1150	int
1151	gfc_compare_string (gfc_expr *a, gfc_expr *b)
1152	{
1153	size_t len, alen, blen, i;
1154	gfc_char_t ac, bc;
1155
1156	alen = a->value.character.length;
1157	blen = b->value.character.length;
1158
1159	len = MAX(alen, blen);
1160
1161	for (i = 0; i < len; i++)
1162	{
1163	ac = ((i < alen) ? a->value.character.string[i] : ' ');
1164	bc = ((i < blen) ? b->value.character.string[i] : ' ');
1165
1166	if (ac < bc)
1167	return -1;
1168	if (ac > bc)
1169	return 1;
1170	}
1171
1172	/* Strings are equal */
1173	return 0;
1174	}
1175
1176
1177	int
1178	gfc_compare_with_Cstring (gfc_expr *a, const char *b, bool case_sensitive)
1179	{
1180	size_t len, alen, blen, i;
1181	gfc_char_t ac, bc;
1182
1183	alen = a->value.character.length;
1184	blen = strlen (s: b);
1185
1186	len = MAX(alen, blen);
1187
1188	for (i = 0; i < len; i++)
1189	{
1190	ac = ((i < alen) ? a->value.character.string[i] : ' ');
1191	bc = ((i < blen) ? b[i] : ' ');
1192
1193	if (!case_sensitive)
1194	{
1195	ac = TOLOWER (ac);
1196	bc = TOLOWER (bc);
1197	}
1198
1199	if (ac < bc)
1200	return -1;
1201	if (ac > bc)
1202	return 1;
1203	}
1204
1205	/* Strings are equal */
1206	return 0;
1207	}
1208
1209
1210	/* Specific comparison subroutines. */
1211
1212	static arith
1213	gfc_arith_eq (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1214	{
1215	gfc_expr *result;
1216
1217	if (op1->ts.type != op2->ts.type)
1218	return ARITH_INVALID_TYPE;
1219
1220	result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1221	&op1->where);
1222	result->value.logical = (op1->ts.type == BT_COMPLEX)
1223	? compare_complex (op1, op2)
1224	: (gfc_compare_expr (op1, op2, op: INTRINSIC_EQ) == 0);
1225
1226	*resultp = result;
1227	return ARITH_OK;
1228	}
1229
1230
1231	static arith
1232	gfc_arith_ne (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1233	{
1234	gfc_expr *result;
1235
1236	if (op1->ts.type != op2->ts.type)
1237	return ARITH_INVALID_TYPE;
1238
1239	result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1240	&op1->where);
1241	result->value.logical = (op1->ts.type == BT_COMPLEX)
1242	? !compare_complex (op1, op2)
1243	: (gfc_compare_expr (op1, op2, op: INTRINSIC_EQ) != 0);
1244
1245	*resultp = result;
1246	return ARITH_OK;
1247	}
1248
1249
1250	static arith
1251	gfc_arith_gt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1252	{
1253	gfc_expr *result;
1254
1255	if (op1->ts.type != op2->ts.type)
1256	return ARITH_INVALID_TYPE;
1257
1258	result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1259	&op1->where);
1260	result->value.logical = (gfc_compare_expr (op1, op2, op: INTRINSIC_GT) > 0);
1261	*resultp = result;
1262
1263	return ARITH_OK;
1264	}
1265
1266
1267	static arith
1268	gfc_arith_ge (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1269	{
1270	gfc_expr *result;
1271
1272	if (op1->ts.type != op2->ts.type)
1273	return ARITH_INVALID_TYPE;
1274
1275	result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1276	&op1->where);
1277	result->value.logical = (gfc_compare_expr (op1, op2, op: INTRINSIC_GE) >= 0);
1278	*resultp = result;
1279
1280	return ARITH_OK;
1281	}
1282
1283
1284	static arith
1285	gfc_arith_lt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1286	{
1287	gfc_expr *result;
1288
1289	if (op1->ts.type != op2->ts.type)
1290	return ARITH_INVALID_TYPE;
1291
1292	result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1293	&op1->where);
1294	result->value.logical = (gfc_compare_expr (op1, op2, op: INTRINSIC_LT) < 0);
1295	*resultp = result;
1296
1297	return ARITH_OK;
1298	}
1299
1300
1301	static arith
1302	gfc_arith_le (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1303	{
1304	gfc_expr *result;
1305
1306	if (op1->ts.type != op2->ts.type)
1307	return ARITH_INVALID_TYPE;
1308
1309	result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
1310	&op1->where);
1311	result->value.logical = (gfc_compare_expr (op1, op2, op: INTRINSIC_LE) <= 0);
1312	*resultp = result;
1313
1314	return ARITH_OK;
1315	}
1316
1317
1318	static arith
1319	reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op,
1320	gfc_expr **result)
1321	{
1322	gfc_constructor_base head;
1323	gfc_constructor *c;
1324	gfc_expr *r;
1325	arith rc;
1326
1327	if (op->expr_type == EXPR_CONSTANT)
1328	return eval (op, result);
1329
1330	if (op->expr_type != EXPR_ARRAY)
1331	return ARITH_NOT_REDUCED;
1332
1333	rc = ARITH_OK;
1334	head = gfc_constructor_copy (base: op->value.constructor);
1335	for (c = gfc_constructor_first (base: head); c; c = gfc_constructor_next (ctor: c))
1336	{
1337	rc = reduce_unary (eval, op: c->expr, result: &r);
1338
1339	if (rc != ARITH_OK)
1340	break;
1341
1342	gfc_replace_expr (c->expr, r);
1343	}
1344
1345	if (rc != ARITH_OK)
1346	gfc_constructor_free (base: head);
1347	else
1348	{
1349	gfc_constructor *c = gfc_constructor_first (base: head);
1350	if (c == NULL)
1351	{
1352	/* Handle zero-sized arrays. */
1353	r = gfc_get_array_expr (type: op->ts.type, kind: op->ts.kind, &op->where);
1354	}
1355	else
1356	{
1357	r = gfc_get_array_expr (type: c->expr->ts.type, kind: c->expr->ts.kind,
1358	&op->where);
1359	}
1360	r->shape = gfc_copy_shape (op->shape, op->rank);
1361	r->rank = op->rank;
1362	r->value.constructor = head;
1363	*result = r;
1364	}
1365
1366	return rc;
1367	}
1368
1369
1370	static arith
1371	reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1372	gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1373	{
1374	gfc_constructor_base head;
1375	gfc_constructor *c;
1376	gfc_expr *r;
1377	arith rc = ARITH_OK;
1378
1379	head = gfc_constructor_copy (base: op1->value.constructor);
1380	for (c = gfc_constructor_first (base: head); c; c = gfc_constructor_next (ctor: c))
1381	{
1382	gfc_simplify_expr (c->expr, 0);
1383
1384	if (c->expr->expr_type == EXPR_CONSTANT)
1385	rc = eval (c->expr, op2, &r);
1386	else if (c->expr->expr_type != EXPR_ARRAY)
1387	rc = ARITH_NOT_REDUCED;
1388	else
1389	rc = reduce_binary_ac (eval, op1: c->expr, op2, result: &r);
1390
1391	if (rc != ARITH_OK)
1392	break;
1393
1394	gfc_replace_expr (c->expr, r);
1395	}
1396
1397	if (rc != ARITH_OK)
1398	gfc_constructor_free (base: head);
1399	else
1400	{
1401	gfc_constructor *c = gfc_constructor_first (base: head);
1402	if (c)
1403	{
1404	r = gfc_get_array_expr (type: c->expr->ts.type, kind: c->expr->ts.kind,
1405	&op1->where);
1406	r->shape = gfc_copy_shape (op1->shape, op1->rank);
1407	}
1408	else
1409	{
1410	gcc_assert (op1->ts.type != BT_UNKNOWN);
1411	r = gfc_get_array_expr (type: op1->ts.type, kind: op1->ts.kind,
1412	&op1->where);
1413	r->shape = gfc_get_shape (op1->rank);
1414	}
1415	r->rank = op1->rank;
1416	r->value.constructor = head;
1417	*result = r;
1418	}
1419
1420	return rc;
1421	}
1422
1423
1424	static arith
1425	reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1426	gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1427	{
1428	gfc_constructor_base head;
1429	gfc_constructor *c;
1430	gfc_expr *r;
1431	arith rc = ARITH_OK;
1432
1433	head = gfc_constructor_copy (base: op2->value.constructor);
1434	for (c = gfc_constructor_first (base: head); c; c = gfc_constructor_next (ctor: c))
1435	{
1436	gfc_simplify_expr (c->expr, 0);
1437
1438	if (c->expr->expr_type == EXPR_CONSTANT)
1439	rc = eval (op1, c->expr, &r);
1440	else if (c->expr->expr_type != EXPR_ARRAY)
1441	rc = ARITH_NOT_REDUCED;
1442	else
1443	rc = reduce_binary_ca (eval, op1, op2: c->expr, result: &r);
1444
1445	if (rc != ARITH_OK)
1446	break;
1447
1448	gfc_replace_expr (c->expr, r);
1449	}
1450
1451	if (rc != ARITH_OK)
1452	gfc_constructor_free (base: head);
1453	else
1454	{
1455	gfc_constructor *c = gfc_constructor_first (base: head);
1456	if (c)
1457	{
1458	r = gfc_get_array_expr (type: c->expr->ts.type, kind: c->expr->ts.kind,
1459	&op2->where);
1460	r->shape = gfc_copy_shape (op2->shape, op2->rank);
1461	}
1462	else
1463	{
1464	gcc_assert (op2->ts.type != BT_UNKNOWN);
1465	r = gfc_get_array_expr (type: op2->ts.type, kind: op2->ts.kind,
1466	&op2->where);
1467	r->shape = gfc_get_shape (op2->rank);
1468	}
1469	r->rank = op2->rank;
1470	r->value.constructor = head;
1471	*result = r;
1472	}
1473
1474	return rc;
1475	}
1476
1477
1478	/* We need a forward declaration of reduce_binary. */
1479	static arith reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1480	gfc_expr *op1, gfc_expr *op2, gfc_expr **result);
1481
1482
1483	static arith
1484	reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1485	gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1486	{
1487	gfc_constructor_base head;
1488	gfc_constructor *c, *d;
1489	gfc_expr *r;
1490	arith rc = ARITH_OK;
1491
1492	if (!gfc_check_conformance (op1, op2, _("elemental binary operation")))
1493	return ARITH_INCOMMENSURATE;
1494
1495	head = gfc_constructor_copy (base: op1->value.constructor);
1496	for (c = gfc_constructor_first (base: head),
1497	d = gfc_constructor_first (base: op2->value.constructor);
1498	c && d;
1499	c = gfc_constructor_next (ctor: c), d = gfc_constructor_next (ctor: d))
1500	{
1501	rc = reduce_binary (eval, op1: c->expr, op2: d->expr, result: &r);
1502
1503	if (rc != ARITH_OK)
1504	break;
1505
1506	gfc_replace_expr (c->expr, r);
1507	}
1508
1509	if (rc == ARITH_OK && (c || d))
1510	rc = ARITH_INCOMMENSURATE;
1511
1512	if (rc != ARITH_OK)
1513	gfc_constructor_free (base: head);
1514	else
1515	{
1516	gfc_constructor *c = gfc_constructor_first (base: head);
1517	if (c == NULL)
1518	{
1519	/* Handle zero-sized arrays. */
1520	r = gfc_get_array_expr (type: op1->ts.type, kind: op1->ts.kind, &op1->where);
1521	}
1522	else
1523	{
1524	r = gfc_get_array_expr (type: c->expr->ts.type, kind: c->expr->ts.kind,
1525	&op1->where);
1526	}
1527	r->shape = gfc_copy_shape (op1->shape, op1->rank);
1528	r->rank = op1->rank;
1529	r->value.constructor = head;
1530	*result = r;
1531	}
1532
1533	return rc;
1534	}
1535
1536
1537	static arith
1538	reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1539	gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1540	{
1541	if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_CONSTANT)
1542	return eval (op1, op2, result);
1543
1544	if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_ARRAY)
1545	return reduce_binary_ca (eval, op1, op2, result);
1546
1547	if (op1->expr_type == EXPR_ARRAY && op2->expr_type == EXPR_CONSTANT)
1548	return reduce_binary_ac (eval, op1, op2, result);
1549
1550	if (op1->expr_type != EXPR_ARRAY || op2->expr_type != EXPR_ARRAY)
1551	return ARITH_NOT_REDUCED;
1552
1553	return reduce_binary_aa (eval, op1, op2, result);
1554	}
1555
1556
1557	typedef union
1558	{
1559	arith (*f2)(gfc_expr *, gfc_expr **);
1560	arith (*f3)(gfc_expr *, gfc_expr *, gfc_expr **);
1561	}
1562	eval_f;
1563
1564	/* High level arithmetic subroutines. These subroutines go into
1565	eval_intrinsic(), which can do one of several things to its
1566	operands. If the operands are incompatible with the intrinsic
1567	operation, we return a node pointing to the operands and hope that
1568	an operator interface is found during resolution.
1569
1570	If the operands are compatible and are constants, then we try doing
1571	the arithmetic. We also handle the cases where either or both
1572	operands are array constructors. */
1573
1574	static gfc_expr *
1575	eval_intrinsic (gfc_intrinsic_op op,
1576	eval_f eval, gfc_expr *op1, gfc_expr *op2)
1577	{
1578	gfc_expr temp, *result;
1579	int unary;
1580	arith rc;
1581
1582	if (!op1)
1583	return NULL;
1584
1585	gfc_clear_ts (&temp.ts);
1586
1587	switch (op)
1588	{
1589	/* Logical unary */
1590	case INTRINSIC_NOT:
1591	if (op1->ts.type != BT_LOGICAL)
1592	goto runtime;
1593
1594	temp.ts.type = BT_LOGICAL;
1595	temp.ts.kind = gfc_default_logical_kind;
1596	unary = 1;
1597	break;
1598
1599	/* Logical binary operators */
1600	case INTRINSIC_OR:
1601	case INTRINSIC_AND:
1602	case INTRINSIC_NEQV:
1603	case INTRINSIC_EQV:
1604	if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
1605	goto runtime;
1606
1607	temp.ts.type = BT_LOGICAL;
1608	temp.ts.kind = gfc_default_logical_kind;
1609	unary = 0;
1610	break;
1611
1612	/* Numeric unary */
1613	case INTRINSIC_UPLUS:
1614	case INTRINSIC_UMINUS:
1615	if (!gfc_numeric_ts (&op1->ts))
1616	goto runtime;
1617
1618	temp.ts = op1->ts;
1619	unary = 1;
1620	break;
1621
1622	case INTRINSIC_PARENTHESES:
1623	temp.ts = op1->ts;
1624	unary = 1;
1625	break;
1626
1627	/* Additional restrictions for ordering relations. */
1628	case INTRINSIC_GE:
1629	case INTRINSIC_GE_OS:
1630	case INTRINSIC_LT:
1631	case INTRINSIC_LT_OS:
1632	case INTRINSIC_LE:
1633	case INTRINSIC_LE_OS:
1634	case INTRINSIC_GT:
1635	case INTRINSIC_GT_OS:
1636	if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1637	{
1638	temp.ts.type = BT_LOGICAL;
1639	temp.ts.kind = gfc_default_logical_kind;
1640	goto runtime;
1641	}
1642
1643	/* Fall through */
1644	case INTRINSIC_EQ:
1645	case INTRINSIC_EQ_OS:
1646	case INTRINSIC_NE:
1647	case INTRINSIC_NE_OS:
1648	if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1649	{
1650	unary = 0;
1651	temp.ts.type = BT_LOGICAL;
1652	temp.ts.kind = gfc_default_logical_kind;
1653
1654	/* If kind mismatch, exit and we'll error out later. */
1655	if (op1->ts.kind != op2->ts.kind)
1656	goto runtime;
1657
1658	break;
1659	}
1660
1661	gcc_fallthrough ();
1662	/* Numeric binary */
1663	case INTRINSIC_PLUS:
1664	case INTRINSIC_MINUS:
1665	case INTRINSIC_TIMES:
1666	case INTRINSIC_DIVIDE:
1667	case INTRINSIC_POWER:
1668	if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts))
1669	goto runtime;
1670
1671	/* Do not perform conversions if operands are not conformable as
1672	required for the binary intrinsic operators (F2018:10.1.5).
1673	Defer to a possibly overloading user-defined operator. */
1674	if (!gfc_op_rank_conformable (op1, op2))
1675	goto runtime;
1676
1677	/* Insert any necessary type conversions to make the operands
1678	compatible. */
1679
1680	temp.expr_type = EXPR_OP;
1681	gfc_clear_ts (&temp.ts);
1682	temp.value.op.op = op;
1683
1684	temp.value.op.op1 = op1;
1685	temp.value.op.op2 = op2;
1686
1687	gfc_type_convert_binary (&temp, warn_conversion || warn_conversion_extra);
1688
1689	if (op == INTRINSIC_EQ || op == INTRINSIC_NE
1690	|| op == INTRINSIC_GE || op == INTRINSIC_GT
1691	|| op == INTRINSIC_LE || op == INTRINSIC_LT
1692	|| op == INTRINSIC_EQ_OS || op == INTRINSIC_NE_OS
1693	|| op == INTRINSIC_GE_OS || op == INTRINSIC_GT_OS
1694	|| op == INTRINSIC_LE_OS || op == INTRINSIC_LT_OS)
1695	{
1696	temp.ts.type = BT_LOGICAL;
1697	temp.ts.kind = gfc_default_logical_kind;
1698	}
1699
1700	unary = 0;
1701	break;
1702
1703	/* Character binary */
1704	case INTRINSIC_CONCAT:
1705	if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER
1706	|| op1->ts.kind != op2->ts.kind)
1707	goto runtime;
1708
1709	temp.ts.type = BT_CHARACTER;
1710	temp.ts.kind = op1->ts.kind;
1711	unary = 0;
1712	break;
1713
1714	case INTRINSIC_USER:
1715	goto runtime;
1716
1717	default:
1718	gfc_internal_error ("eval_intrinsic(): Bad operator");
1719	}
1720
1721	if (op1->expr_type != EXPR_CONSTANT
1722	&& (op1->expr_type != EXPR_ARRAY
1723	|| !gfc_is_constant_expr (op1) || !gfc_expanded_ac (op1)))
1724	goto runtime;
1725
1726	if (op2 != NULL
1727	&& op2->expr_type != EXPR_CONSTANT
1728	&& (op2->expr_type != EXPR_ARRAY
1729	|| !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2)))
1730	goto runtime;
1731
1732	if (unary)
1733	rc = reduce_unary (eval: eval.f2, op: op1, result: &result);
1734	else
1735	rc = reduce_binary (eval: eval.f3, op1, op2, result: &result);
1736
1737	if (rc == ARITH_INVALID_TYPE || rc == ARITH_NOT_REDUCED)
1738	goto runtime;
1739
1740	/* Something went wrong. */
1741	if (op == INTRINSIC_POWER && rc == ARITH_PROHIBIT)
1742	return NULL;
1743
1744	if (rc != ARITH_OK)
1745	{
1746	gfc_error (gfc_arith_error (code: rc), &op1->where);
1747	if (rc == ARITH_OVERFLOW)
1748	goto done;
1749
1750	if (rc == ARITH_DIV0 && op2->ts.type == BT_INTEGER)
1751	gfc_seen_div0 = true;
1752
1753	return NULL;
1754	}
1755
1756	done:
1757
1758	gfc_free_expr (op1);
1759	gfc_free_expr (op2);
1760	return result;
1761
1762	runtime:
1763	/* Create a run-time expression. */
1764	result = gfc_get_operator_expr (&op1->where, op, op1, op2);
1765	result->ts = temp.ts;
1766
1767	return result;
1768	}
1769
1770
1771	/* Modify type of expression for zero size array. */
1772
1773	static gfc_expr *
1774	eval_type_intrinsic0 (gfc_intrinsic_op iop, gfc_expr *op)
1775	{
1776	if (op == NULL)
1777	gfc_internal_error ("eval_type_intrinsic0(): op NULL");
1778
1779	switch (iop)
1780	{
1781	case INTRINSIC_GE:
1782	case INTRINSIC_GE_OS:
1783	case INTRINSIC_LT:
1784	case INTRINSIC_LT_OS:
1785	case INTRINSIC_LE:
1786	case INTRINSIC_LE_OS:
1787	case INTRINSIC_GT:
1788	case INTRINSIC_GT_OS:
1789	case INTRINSIC_EQ:
1790	case INTRINSIC_EQ_OS:
1791	case INTRINSIC_NE:
1792	case INTRINSIC_NE_OS:
1793	op->ts.type = BT_LOGICAL;
1794	op->ts.kind = gfc_default_logical_kind;
1795	break;
1796
1797	default:
1798	break;
1799	}
1800
1801	return op;
1802	}
1803
1804
1805	/* Return nonzero if the expression is a zero size array. */
1806
1807	static bool
1808	gfc_zero_size_array (gfc_expr *e)
1809	{
1810	if (e == NULL || e->expr_type != EXPR_ARRAY)
1811	return false;
1812
1813	return e->value.constructor == NULL;
1814	}
1815
1816
1817	/* Reduce a binary expression where at least one of the operands
1818	involves a zero-length array. Returns NULL if neither of the
1819	operands is a zero-length array. */
1820
1821	static gfc_expr *
1822	reduce_binary0 (gfc_expr *op1, gfc_expr *op2)
1823	{
1824	if (gfc_zero_size_array (e: op1))
1825	{
1826	gfc_free_expr (op2);
1827	return op1;
1828	}
1829
1830	if (gfc_zero_size_array (e: op2))
1831	{
1832	gfc_free_expr (op1);
1833	return op2;
1834	}
1835
1836	return NULL;
1837	}
1838
1839
1840	static gfc_expr *
1841	eval_intrinsic_f2 (gfc_intrinsic_op op,
1842	arith (*eval) (gfc_expr *, gfc_expr **),
1843	gfc_expr *op1, gfc_expr *op2)
1844	{
1845	gfc_expr *result;
1846	eval_f f;
1847
1848	if (op2 == NULL)
1849	{
1850	if (gfc_zero_size_array (e: op1))
1851	return eval_type_intrinsic0 (iop: op, op: op1);
1852	}
1853	else
1854	{
1855	result = reduce_binary0 (op1, op2);
1856	if (result != NULL)
1857	return eval_type_intrinsic0 (iop: op, op: result);
1858	}
1859
1860	f.f2 = eval;
1861	return eval_intrinsic (op, eval: f, op1, op2);
1862	}
1863
1864
1865	static gfc_expr *
1866	eval_intrinsic_f3 (gfc_intrinsic_op op,
1867	arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1868	gfc_expr *op1, gfc_expr *op2)
1869	{
1870	gfc_expr *result;
1871	eval_f f;
1872
1873	if (!op1 && !op2)
1874	return NULL;
1875
1876	result = reduce_binary0 (op1, op2);
1877	if (result != NULL)
1878	return eval_type_intrinsic0(iop: op, op: result);
1879
1880	f.f3 = eval;
1881	return eval_intrinsic (op, eval: f, op1, op2);
1882	}
1883
1884
1885	gfc_expr *
1886	gfc_parentheses (gfc_expr *op)
1887	{
1888	if (gfc_is_constant_expr (op))
1889	return op;
1890
1891	return eval_intrinsic_f2 (op: INTRINSIC_PARENTHESES, eval: gfc_arith_identity,
1892	op1: op, NULL);
1893	}
1894
1895	gfc_expr *
1896	gfc_uplus (gfc_expr *op)
1897	{
1898	return eval_intrinsic_f2 (op: INTRINSIC_UPLUS, eval: gfc_arith_identity, op1: op, NULL);
1899	}
1900
1901
1902	gfc_expr *
1903	gfc_uminus (gfc_expr *op)
1904	{
1905	return eval_intrinsic_f2 (op: INTRINSIC_UMINUS, eval: gfc_arith_uminus, op1: op, NULL);
1906	}
1907
1908
1909	gfc_expr *
1910	gfc_add (gfc_expr *op1, gfc_expr *op2)
1911	{
1912	return eval_intrinsic_f3 (op: INTRINSIC_PLUS, eval: gfc_arith_plus, op1, op2);
1913	}
1914
1915
1916	gfc_expr *
1917	gfc_subtract (gfc_expr *op1, gfc_expr *op2)
1918	{
1919	return eval_intrinsic_f3 (op: INTRINSIC_MINUS, eval: gfc_arith_minus, op1, op2);
1920	}
1921
1922
1923	gfc_expr *
1924	gfc_multiply (gfc_expr *op1, gfc_expr *op2)
1925	{
1926	return eval_intrinsic_f3 (op: INTRINSIC_TIMES, eval: gfc_arith_times, op1, op2);
1927	}
1928
1929
1930	gfc_expr *
1931	gfc_divide (gfc_expr *op1, gfc_expr *op2)
1932	{
1933	return eval_intrinsic_f3 (op: INTRINSIC_DIVIDE, eval: gfc_arith_divide, op1, op2);
1934	}
1935
1936
1937	gfc_expr *
1938	gfc_power (gfc_expr *op1, gfc_expr *op2)
1939	{
1940	return eval_intrinsic_f3 (op: INTRINSIC_POWER, eval: arith_power, op1, op2);
1941	}
1942
1943
1944	gfc_expr *
1945	gfc_concat (gfc_expr *op1, gfc_expr *op2)
1946	{
1947	return eval_intrinsic_f3 (op: INTRINSIC_CONCAT, eval: gfc_arith_concat, op1, op2);
1948	}
1949
1950
1951	gfc_expr *
1952	gfc_and (gfc_expr *op1, gfc_expr *op2)
1953	{
1954	return eval_intrinsic_f3 (op: INTRINSIC_AND, eval: gfc_arith_and, op1, op2);
1955	}
1956
1957
1958	gfc_expr *
1959	gfc_or (gfc_expr *op1, gfc_expr *op2)
1960	{
1961	return eval_intrinsic_f3 (op: INTRINSIC_OR, eval: gfc_arith_or, op1, op2);
1962	}
1963
1964
1965	gfc_expr *
1966	gfc_not (gfc_expr *op1)
1967	{
1968	return eval_intrinsic_f2 (op: INTRINSIC_NOT, eval: gfc_arith_not, op1, NULL);
1969	}
1970
1971
1972	gfc_expr *
1973	gfc_eqv (gfc_expr *op1, gfc_expr *op2)
1974	{
1975	return eval_intrinsic_f3 (op: INTRINSIC_EQV, eval: gfc_arith_eqv, op1, op2);
1976	}
1977
1978
1979	gfc_expr *
1980	gfc_neqv (gfc_expr *op1, gfc_expr *op2)
1981	{
1982	return eval_intrinsic_f3 (op: INTRINSIC_NEQV, eval: gfc_arith_neqv, op1, op2);
1983	}
1984
1985
1986	gfc_expr *
1987	gfc_eq (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1988	{
1989	return eval_intrinsic_f3 (op, eval: gfc_arith_eq, op1, op2);
1990	}
1991
1992
1993	gfc_expr *
1994	gfc_ne (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1995	{
1996	return eval_intrinsic_f3 (op, eval: gfc_arith_ne, op1, op2);
1997	}
1998
1999
2000	gfc_expr *
2001	gfc_gt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2002	{
2003	return eval_intrinsic_f3 (op, eval: gfc_arith_gt, op1, op2);
2004	}
2005
2006
2007	gfc_expr *
2008	gfc_ge (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2009	{
2010	return eval_intrinsic_f3 (op, eval: gfc_arith_ge, op1, op2);
2011	}
2012
2013
2014	gfc_expr *
2015	gfc_lt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2016	{
2017	return eval_intrinsic_f3 (op, eval: gfc_arith_lt, op1, op2);
2018	}
2019
2020
2021	gfc_expr *
2022	gfc_le (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2023	{
2024	return eval_intrinsic_f3 (op, eval: gfc_arith_le, op1, op2);
2025	}
2026
2027
2028	/******* Simplification of intrinsic functions with constant arguments *****/
2029
2030
2031	/* Deal with an arithmetic error. */
2032
2033	static void
2034	arith_error (arith rc, gfc_typespec *from, gfc_typespec *to, locus *where)
2035	{
2036	switch (rc)
2037	{
2038	case ARITH_OK:
2039	gfc_error ("Arithmetic OK converting %s to %s at %L",
2040	gfc_typename (from), gfc_typename (to), where);
2041	break;
2042	case ARITH_OVERFLOW:
2043	gfc_error ("Arithmetic overflow converting %s to %s at %L. This check "
2044	"can be disabled with the option %<-fno-range-check%>",
2045	gfc_typename (from), gfc_typename (to), where);
2046	break;
2047	case ARITH_UNDERFLOW:
2048	gfc_error ("Arithmetic underflow converting %s to %s at %L. This check "
2049	"can be disabled with the option %<-fno-range-check%>",
2050	gfc_typename (from), gfc_typename (to), where);
2051	break;
2052	case ARITH_NAN:
2053	gfc_error ("Arithmetic NaN converting %s to %s at %L. This check "
2054	"can be disabled with the option %<-fno-range-check%>",
2055	gfc_typename (from), gfc_typename (to), where);
2056	break;
2057	case ARITH_DIV0:
2058	gfc_error ("Division by zero converting %s to %s at %L",
2059	gfc_typename (from), gfc_typename (to), where);
2060	break;
2061	case ARITH_INCOMMENSURATE:
2062	gfc_error ("Array operands are incommensurate converting %s to %s at %L",
2063	gfc_typename (from), gfc_typename (to), where);
2064	break;
2065	case ARITH_ASYMMETRIC:
2066	gfc_error ("Integer outside symmetric range implied by Standard Fortran"
2067	" converting %s to %s at %L",
2068	gfc_typename (from), gfc_typename (to), where);
2069	break;
2070	default:
2071	gfc_internal_error ("gfc_arith_error(): Bad error code");
2072	}
2073
2074	/* TODO: Do something about the error, i.e., throw exception, return
2075	NaN, etc. */
2076	}
2077
2078	/* Returns true if significant bits were lost when converting real
2079	constant r from from_kind to to_kind. */
2080
2081	static bool
2082	wprecision_real_real (mpfr_t r, int from_kind, int to_kind)
2083	{
2084	mpfr_t rv, diff;
2085	bool ret;
2086
2087	gfc_set_model_kind (kind: to_kind);
2088	mpfr_init (rv);
2089	gfc_set_model_kind (kind: from_kind);
2090	mpfr_init (diff);
2091
2092	mpfr_set (rv, r, GFC_RND_MODE);
2093	mpfr_sub (diff, rv, r, GFC_RND_MODE);
2094
2095	ret = ! mpfr_zero_p (diff);
2096	mpfr_clear (rv);
2097	mpfr_clear (diff);
2098	return ret;
2099	}
2100
2101	/* Return true if conversion from an integer to a real loses precision. */
2102
2103	static bool
2104	wprecision_int_real (mpz_t n, mpfr_t r)
2105	{
2106	bool ret;
2107	mpz_t i;
2108	mpz_init (i);
2109	mpfr_get_z (z: i, f: r, GFC_RND_MODE);
2110	mpz_sub (i, i, n);
2111	ret = mpz_cmp_si (i, 0) != 0;
2112	mpz_clear (i);
2113	return ret;
2114	}
2115
2116	/* Convert integers to integers. */
2117
2118	gfc_expr *
2119	gfc_int2int (gfc_expr *src, int kind)
2120	{
2121	gfc_expr *result;
2122	arith rc;
2123
2124	if (src->ts.type != BT_INTEGER)
2125	return NULL;
2126
2127	result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2128
2129	mpz_set (result->value.integer, src->value.integer);
2130
2131	if ((rc = gfc_check_integer_range (p: result->value.integer, kind)) != ARITH_OK)
2132	{
2133	if (rc == ARITH_ASYMMETRIC)
2134	{
2135	gfc_warning (opt: 0, gfc_arith_error (code: rc), &src->where);
2136	}
2137	else
2138	{
2139	arith_error (rc, from: &src->ts, to: &result->ts, where: &src->where);
2140	gfc_free_expr (result);
2141	return NULL;
2142	}
2143	}
2144
2145	/* If we do not trap numeric overflow, we need to convert the number to
2146	signed, throwing away high-order bits if necessary. */
2147	if (flag_range_check == 0)
2148	{
2149	int k;
2150
2151	k = gfc_validate_kind (BT_INTEGER, kind, false);
2152	gfc_convert_mpz_to_signed (result->value.integer,
2153	gfc_integer_kinds[k].bit_size);
2154
2155	if (warn_conversion && !src->do_not_warn && kind < src->ts.kind)
2156	gfc_warning_now (opt: OPT_Wconversion, "Conversion from %qs to %qs at %L",
2157	gfc_typename (&src->ts), gfc_typename (&result->ts),
2158	&src->where);
2159	}
2160	return result;
2161	}
2162
2163
2164	/* Convert integers to reals. */
2165
2166	gfc_expr *
2167	gfc_int2real (gfc_expr *src, int kind)
2168	{
2169	gfc_expr *result;
2170	arith rc;
2171
2172	if (src->ts.type != BT_INTEGER)
2173	return NULL;
2174
2175	result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2176
2177	mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE);
2178
2179	if ((rc = gfc_check_real_range (p: result->value.real, kind)) != ARITH_OK)
2180	{
2181	arith_error (rc, from: &src->ts, to: &result->ts, where: &src->where);
2182	gfc_free_expr (result);
2183	return NULL;
2184	}
2185
2186	if (warn_conversion
2187	&& wprecision_int_real (n: src->value.integer, r: result->value.real))
2188	gfc_warning (opt: OPT_Wconversion, "Change of value in conversion "
2189	"from %qs to %qs at %L",
2190	gfc_typename (&src->ts),
2191	gfc_typename (&result->ts),
2192	&src->where);
2193
2194	return result;
2195	}
2196
2197
2198	/* Convert default integer to default complex. */
2199
2200	gfc_expr *
2201	gfc_int2complex (gfc_expr *src, int kind)
2202	{
2203	gfc_expr *result;
2204	arith rc;
2205
2206	if (src->ts.type != BT_INTEGER)
2207	return NULL;
2208
2209	result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2210
2211	mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE);
2212
2213	if ((rc = gfc_check_real_range (mpc_realref (result->value.complex), kind))
2214	!= ARITH_OK)
2215	{
2216	arith_error (rc, from: &src->ts, to: &result->ts, where: &src->where);
2217	gfc_free_expr (result);
2218	return NULL;
2219	}
2220
2221	if (warn_conversion
2222	&& wprecision_int_real (n: src->value.integer,
2223	mpc_realref (result->value.complex)))
2224	gfc_warning_now (opt: OPT_Wconversion, "Change of value in conversion "
2225	"from %qs to %qs at %L",
2226	gfc_typename (&src->ts),
2227	gfc_typename (&result->ts),
2228	&src->where);
2229
2230	return result;
2231	}
2232
2233
2234	/* Convert default real to default integer. */
2235
2236	gfc_expr *
2237	gfc_real2int (gfc_expr *src, int kind)
2238	{
2239	gfc_expr *result;
2240	arith rc;
2241	bool did_warn = false;
2242
2243	if (src->ts.type != BT_REAL)
2244	return NULL;
2245
2246	result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2247
2248	gfc_mpfr_to_mpz (z: result->value.integer, x: src->value.real, where: &src->where);
2249
2250	if ((rc = gfc_check_integer_range (p: result->value.integer, kind)) != ARITH_OK)
2251	{
2252	arith_error (rc, from: &src->ts, to: &result->ts, where: &src->where);
2253	gfc_free_expr (result);
2254	return NULL;
2255	}
2256
2257	/* If there was a fractional part, warn about this. */
2258
2259	if (warn_conversion)
2260	{
2261	mpfr_t f;
2262	mpfr_init (f);
2263	mpfr_frac (f, src->value.real, GFC_RND_MODE);
2264	if (mpfr_cmp_si (f, 0) != 0)
2265	{
2266	gfc_warning_now (opt: OPT_Wconversion, "Change of value in conversion "
2267	"from %qs to %qs at %L", gfc_typename (&src->ts),
2268	gfc_typename (&result->ts), &src->where);
2269	did_warn = true;
2270	}
2271	mpfr_clear (f);
2272	}
2273	if (!did_warn && warn_conversion_extra)
2274	{
2275	gfc_warning_now (opt: OPT_Wconversion_extra, "Conversion from %qs to %qs "
2276	"at %L", gfc_typename (&src->ts),
2277	gfc_typename (&result->ts), &src->where);
2278	}
2279
2280	return result;
2281	}
2282
2283
2284	/* Convert real to real. */
2285
2286	gfc_expr *
2287	gfc_real2real (gfc_expr *src, int kind)
2288	{
2289	gfc_expr *result;
2290	arith rc;
2291	bool did_warn = false;
2292
2293	if (src->ts.type != BT_REAL)
2294	return NULL;
2295
2296	result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2297
2298	mpfr_set (result->value.real, src->value.real, GFC_RND_MODE);
2299
2300	rc = gfc_check_real_range (p: result->value.real, kind);
2301
2302	if (rc == ARITH_UNDERFLOW)
2303	{
2304	if (warn_underflow)
2305	gfc_warning (opt: OPT_Woverflow, gfc_arith_error (code: rc), &src->where);
2306	mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2307	}
2308	else if (rc != ARITH_OK)
2309	{
2310	arith_error (rc, from: &src->ts, to: &result->ts, where: &src->where);
2311	gfc_free_expr (result);
2312	return NULL;
2313	}
2314
2315	/* As a special bonus, don't warn about REAL values which are not changed by
2316	the conversion if -Wconversion is specified and -Wconversion-extra is
2317	not. */
2318
2319	if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind)
2320	{
2321	int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2322
2323	/* Calculate the difference between the constant and the rounded
2324	value and check it against zero. */
2325
2326	if (wprecision_real_real (r: src->value.real, from_kind: src->ts.kind, to_kind: kind))
2327	{
2328	gfc_warning_now (opt: w, "Change of value in conversion from "
2329	"%qs to %qs at %L",
2330	gfc_typename (&src->ts), gfc_typename (&result->ts),
2331	&src->where);
2332	/* Make sure the conversion warning is not emitted again. */
2333	did_warn = true;
2334	}
2335	}
2336
2337	if (!did_warn && warn_conversion_extra)
2338	gfc_warning_now (opt: OPT_Wconversion_extra, "Conversion from %qs to %qs "
2339	"at %L", gfc_typename(&src->ts),
2340	gfc_typename(&result->ts), &src->where);
2341
2342	return result;
2343	}
2344
2345
2346	/* Convert real to complex. */
2347
2348	gfc_expr *
2349	gfc_real2complex (gfc_expr *src, int kind)
2350	{
2351	gfc_expr *result;
2352	arith rc;
2353	bool did_warn = false;
2354
2355	if (src->ts.type != BT_REAL)
2356	return NULL;
2357
2358	result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2359
2360	mpc_set_fr (result->value.complex, src->value.real, GFC_MPC_RND_MODE);
2361
2362	rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
2363
2364	if (rc == ARITH_UNDERFLOW)
2365	{
2366	if (warn_underflow)
2367	gfc_warning (opt: OPT_Woverflow, gfc_arith_error (code: rc), &src->where);
2368	mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
2369	}
2370	else if (rc != ARITH_OK)
2371	{
2372	arith_error (rc, from: &src->ts, to: &result->ts, where: &src->where);
2373	gfc_free_expr (result);
2374	return NULL;
2375	}
2376
2377	if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind)
2378	{
2379	int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2380
2381	if (wprecision_real_real (r: src->value.real, from_kind: src->ts.kind, to_kind: kind))
2382	{
2383	gfc_warning_now (opt: w, "Change of value in conversion from "
2384	"%qs to %qs at %L",
2385	gfc_typename (&src->ts), gfc_typename (&result->ts),
2386	&src->where);
2387	/* Make sure the conversion warning is not emitted again. */
2388	did_warn = true;
2389	}
2390	}
2391
2392	if (!did_warn && warn_conversion_extra)
2393	gfc_warning_now (opt: OPT_Wconversion_extra, "Conversion from %qs to %qs "
2394	"at %L", gfc_typename(&src->ts),
2395	gfc_typename(&result->ts), &src->where);
2396
2397	return result;
2398	}
2399
2400
2401	/* Convert complex to integer. */
2402
2403	gfc_expr *
2404	gfc_complex2int (gfc_expr *src, int kind)
2405	{
2406	gfc_expr *result;
2407	arith rc;
2408	bool did_warn = false;
2409
2410	if (src->ts.type != BT_COMPLEX)
2411	return NULL;
2412
2413	result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2414
2415	gfc_mpfr_to_mpz (z: result->value.integer, mpc_realref (src->value.complex),
2416	where: &src->where);
2417
2418	if ((rc = gfc_check_integer_range (p: result->value.integer, kind)) != ARITH_OK)
2419	{
2420	arith_error (rc, from: &src->ts, to: &result->ts, where: &src->where);
2421	gfc_free_expr (result);
2422	return NULL;
2423	}
2424
2425	if (warn_conversion || warn_conversion_extra)
2426	{
2427	int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2428
2429	/* See if we discarded an imaginary part. */
2430	if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0) != 0)
2431	{
2432	gfc_warning_now (opt: w, "Non-zero imaginary part discarded "
2433	"in conversion from %qs to %qs at %L",
2434	gfc_typename(&src->ts), gfc_typename (&result->ts),
2435	&src->where);
2436	did_warn = true;
2437	}
2438
2439	else {
2440	mpfr_t f;
2441
2442	mpfr_init (f);
2443	mpfr_frac (f, src->value.real, GFC_RND_MODE);
2444	if (mpfr_cmp_si (f, 0) != 0)
2445	{
2446	gfc_warning_now (opt: w, "Change of value in conversion from "
2447	"%qs to %qs at %L", gfc_typename (&src->ts),
2448	gfc_typename (&result->ts), &src->where);
2449	did_warn = true;
2450	}
2451	mpfr_clear (f);
2452	}
2453
2454	if (!did_warn && warn_conversion_extra)
2455	{
2456	gfc_warning_now (opt: OPT_Wconversion_extra, "Conversion from %qs to %qs "
2457	"at %L", gfc_typename (&src->ts),
2458	gfc_typename (&result->ts), &src->where);
2459	}
2460	}
2461
2462	return result;
2463	}
2464
2465
2466	/* Convert complex to real. */
2467
2468	gfc_expr *
2469	gfc_complex2real (gfc_expr *src, int kind)
2470	{
2471	gfc_expr *result;
2472	arith rc;
2473	bool did_warn = false;
2474
2475	if (src->ts.type != BT_COMPLEX)
2476	return NULL;
2477
2478	result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2479
2480	mpc_real (result->value.real, src->value.complex, GFC_RND_MODE);
2481
2482	rc = gfc_check_real_range (p: result->value.real, kind);
2483
2484	if (rc == ARITH_UNDERFLOW)
2485	{
2486	if (warn_underflow)
2487	gfc_warning (opt: OPT_Woverflow, gfc_arith_error (code: rc), &src->where);
2488	mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2489	}
2490	if (rc != ARITH_OK)
2491	{
2492	arith_error (rc, from: &src->ts, to: &result->ts, where: &src->where);
2493	gfc_free_expr (result);
2494	return NULL;
2495	}
2496
2497	if (warn_conversion || warn_conversion_extra)
2498	{
2499	int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2500
2501	/* See if we discarded an imaginary part. */
2502	if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0) != 0)
2503	{
2504	gfc_warning (opt: w, "Non-zero imaginary part discarded "
2505	"in conversion from %qs to %qs at %L",
2506	gfc_typename(&src->ts), gfc_typename (&result->ts),
2507	&src->where);
2508	did_warn = true;
2509	}
2510
2511	/* Calculate the difference between the real constant and the rounded
2512	value and check it against zero. */
2513
2514	if (kind > src->ts.kind
2515	&& wprecision_real_real (mpc_realref (src->value.complex),
2516	from_kind: src->ts.kind, to_kind: kind))
2517	{
2518	gfc_warning_now (opt: w, "Change of value in conversion from "
2519	"%qs to %qs at %L",
2520	gfc_typename (&src->ts), gfc_typename (&result->ts),
2521	&src->where);
2522	/* Make sure the conversion warning is not emitted again. */
2523	did_warn = true;
2524	}
2525	}
2526
2527	if (!did_warn && warn_conversion_extra)
2528	gfc_warning_now (opt: OPT_Wconversion, "Conversion from %qs to %qs at %L",
2529	gfc_typename(&src->ts), gfc_typename (&result->ts),
2530	&src->where);
2531
2532	return result;
2533	}
2534
2535
2536	/* Convert complex to complex. */
2537
2538	gfc_expr *
2539	gfc_complex2complex (gfc_expr *src, int kind)
2540	{
2541	gfc_expr *result;
2542	arith rc;
2543	bool did_warn = false;
2544
2545	if (src->ts.type != BT_COMPLEX)
2546	return NULL;
2547
2548	result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2549
2550	mpc_set (result->value.complex, src->value.complex, GFC_MPC_RND_MODE);
2551
2552	rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
2553
2554	if (rc == ARITH_UNDERFLOW)
2555	{
2556	if (warn_underflow)
2557	gfc_warning (opt: OPT_Woverflow, gfc_arith_error (code: rc), &src->where);
2558	mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
2559	}
2560	else if (rc != ARITH_OK)
2561	{
2562	arith_error (rc, from: &src->ts, to: &result->ts, where: &src->where);
2563	gfc_free_expr (result);
2564	return NULL;
2565	}
2566
2567	rc = gfc_check_real_range (mpc_imagref (result->value.complex), kind);
2568
2569	if (rc == ARITH_UNDERFLOW)
2570	{
2571	if (warn_underflow)
2572	gfc_warning (opt: OPT_Woverflow, gfc_arith_error (code: rc), &src->where);
2573	mpfr_set_ui (mpc_imagref (result->value.complex), 0, GFC_RND_MODE);
2574	}
2575	else if (rc != ARITH_OK)
2576	{
2577	arith_error (rc, from: &src->ts, to: &result->ts, where: &src->where);
2578	gfc_free_expr (result);
2579	return NULL;
2580	}
2581
2582	if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind
2583	&& (wprecision_real_real (mpc_realref (src->value.complex),
2584	from_kind: src->ts.kind, to_kind: kind)
2585	|| wprecision_real_real (mpc_imagref (src->value.complex),
2586	from_kind: src->ts.kind, to_kind: kind)))
2587	{
2588	int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
2589
2590	gfc_warning_now (opt: w, "Change of value in conversion from "
2591	"%qs to %qs at %L",
2592	gfc_typename (&src->ts), gfc_typename (&result->ts),
2593	&src->where);
2594	did_warn = true;
2595	}
2596
2597	if (!did_warn && warn_conversion_extra && src->ts.kind != kind)
2598	gfc_warning_now (opt: OPT_Wconversion_extra, "Conversion from %qs to %qs "
2599	"at %L", gfc_typename(&src->ts),
2600	gfc_typename (&result->ts), &src->where);
2601
2602	return result;
2603	}
2604
2605
2606	/* Logical kind conversion. */
2607
2608	gfc_expr *
2609	gfc_log2log (gfc_expr *src, int kind)
2610	{
2611	gfc_expr *result;
2612
2613	if (src->ts.type != BT_LOGICAL)
2614	return NULL;
2615
2616	result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
2617	result->value.logical = src->value.logical;
2618
2619	return result;
2620	}
2621
2622
2623	/* Convert logical to integer. */
2624
2625	gfc_expr *
2626	gfc_log2int (gfc_expr *src, int kind)
2627	{
2628	gfc_expr *result;
2629
2630	if (src->ts.type != BT_LOGICAL)
2631	return NULL;
2632
2633	result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2634	mpz_set_si (result->value.integer, src->value.logical);
2635
2636	return result;
2637	}
2638
2639
2640	/* Convert integer to logical. */
2641
2642	gfc_expr *
2643	gfc_int2log (gfc_expr *src, int kind)
2644	{
2645	gfc_expr *result;
2646
2647	if (src->ts.type != BT_INTEGER)
2648	return NULL;
2649
2650	result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
2651	result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
2652
2653	return result;
2654	}
2655
2656	/* Convert character to character. We only use wide strings internally,
2657	so we only set the kind. */
2658
2659	gfc_expr *
2660	gfc_character2character (gfc_expr *src, int kind)
2661	{
2662	gfc_expr *result;
2663	result = gfc_copy_expr (src);
2664	result->ts.kind = kind;
2665
2666	return result;
2667	}
2668
2669	/* Helper function to set the representation in a Hollerith conversion.
2670	This assumes that the ts.type and ts.kind of the result have already
2671	been set. */
2672
2673	static void
2674	hollerith2representation (gfc_expr *result, gfc_expr *src)
2675	{
2676	size_t src_len, result_len;
2677
2678	src_len = src->representation.length - src->ts.u.pad;
2679	gfc_target_expr_size (result, &result_len);
2680
2681	if (src_len > result_len)
2682	{
2683	gfc_warning (opt: OPT_Wcharacter_truncation, "The Hollerith constant at %L "
2684	"is truncated in conversion to %qs", &src->where,
2685	gfc_typename(&result->ts));
2686	}
2687
2688	result->representation.string = XCNEWVEC (char, result_len + 1);
2689	memcpy (dest: result->representation.string, src: src->representation.string,
2690	MIN (result_len, src_len));
2691
2692	if (src_len < result_len)
2693	memset (s: &result->representation.string[src_len], c: ' ', n: result_len - src_len);
2694
2695	result->representation.string[result_len] = '\0'; /* For debugger */
2696	result->representation.length = result_len;
2697	}
2698
2699
2700	/* Helper function to set the representation in a character conversion.
2701	This assumes that the ts.type and ts.kind of the result have already
2702	been set. */
2703
2704	static void
2705	character2representation (gfc_expr *result, gfc_expr *src)
2706	{
2707	size_t src_len, result_len, i;
2708	src_len = src->value.character.length;
2709	gfc_target_expr_size (result, &result_len);
2710
2711	if (src_len > result_len)
2712	gfc_warning (opt: OPT_Wcharacter_truncation, "The character constant at %L is "
2713	"truncated in conversion to %s", &src->where,
2714	gfc_typename(&result->ts));
2715
2716	result->representation.string = XCNEWVEC (char, result_len + 1);
2717
2718	for (i = 0; i < MIN (result_len, src_len); i++)
2719	result->representation.string[i] = (char) src->value.character.string[i];
2720
2721	if (src_len < result_len)
2722	memset (s: &result->representation.string[src_len], c: ' ',
2723	n: result_len - src_len);
2724
2725	result->representation.string[result_len] = '\0'; /* For debugger. */
2726	result->representation.length = result_len;
2727	}
2728
2729	/* Convert Hollerith to integer. The constant will be padded or truncated. */
2730
2731	gfc_expr *
2732	gfc_hollerith2int (gfc_expr *src, int kind)
2733	{
2734	gfc_expr *result;
2735	result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2736
2737	hollerith2representation (result, src);
2738	gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
2739	result->representation.length, result->value.integer);
2740
2741	return result;
2742	}
2743
2744	/* Convert character to integer. The constant will be padded or truncated. */
2745
2746	gfc_expr *
2747	gfc_character2int (gfc_expr *src, int kind)
2748	{
2749	gfc_expr *result;
2750	result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
2751
2752	character2representation (result, src);
2753	gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
2754	result->representation.length, result->value.integer);
2755	return result;
2756	}
2757
2758	/* Convert Hollerith to real. The constant will be padded or truncated. */
2759
2760	gfc_expr *
2761	gfc_hollerith2real (gfc_expr *src, int kind)
2762	{
2763	gfc_expr *result;
2764	result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2765
2766	hollerith2representation (result, src);
2767	if (gfc_interpret_float (kind,
2768	(unsigned char *) result->representation.string,
2769	result->representation.length, result->value.real))
2770	return result;
2771	else
2772	return NULL;
2773	}
2774
2775	/* Convert character to real. The constant will be padded or truncated. */
2776
2777	gfc_expr *
2778	gfc_character2real (gfc_expr *src, int kind)
2779	{
2780	gfc_expr *result;
2781	result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
2782
2783	character2representation (result, src);
2784	gfc_interpret_float (kind, (unsigned char *) result->representation.string,
2785	result->representation.length, result->value.real);
2786
2787	return result;
2788	}
2789
2790
2791	/* Convert Hollerith to complex. The constant will be padded or truncated. */
2792
2793	gfc_expr *
2794	gfc_hollerith2complex (gfc_expr *src, int kind)
2795	{
2796	gfc_expr *result;
2797	result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2798
2799	hollerith2representation (result, src);
2800	gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
2801	result->representation.length, result->value.complex);
2802
2803	return result;
2804	}
2805
2806	/* Convert character to complex. The constant will be padded or truncated. */
2807
2808	gfc_expr *
2809	gfc_character2complex (gfc_expr *src, int kind)
2810	{
2811	gfc_expr *result;
2812	result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
2813
2814	character2representation (result, src);
2815	gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
2816	result->representation.length, result->value.complex);
2817
2818	return result;
2819	}
2820
2821
2822	/* Convert Hollerith to character. */
2823
2824	gfc_expr *
2825	gfc_hollerith2character (gfc_expr *src, int kind)
2826	{
2827	gfc_expr *result;
2828
2829	result = gfc_copy_expr (src);
2830	result->ts.type = BT_CHARACTER;
2831	result->ts.kind = kind;
2832	result->ts.u.pad = 0;
2833
2834	result->value.character.length = result->representation.length;
2835	result->value.character.string
2836	= gfc_char_to_widechar (result->representation.string);
2837
2838	return result;
2839	}
2840
2841
2842	/* Convert Hollerith to logical. The constant will be padded or truncated. */
2843
2844	gfc_expr *
2845	gfc_hollerith2logical (gfc_expr *src, int kind)
2846	{
2847	gfc_expr *result;
2848	result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
2849
2850	hollerith2representation (result, src);
2851	gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
2852	result->representation.length, &result->value.logical);
2853
2854	return result;
2855	}
2856
2857	/* Convert character to logical. The constant will be padded or truncated. */
2858
2859	gfc_expr *
2860	gfc_character2logical (gfc_expr *src, int kind)
2861	{
2862	gfc_expr *result;
2863	result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
2864
2865	character2representation (result, src);
2866	gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
2867	result->representation.length, &result->value.logical);
2868
2869	return result;
2870	}
2871