1	/* Intrinsic function resolution.
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
22	/* Assign name and types to intrinsic procedures. For functions, the
23	first argument to a resolution function is an expression pointer to
24	the original function node and the rest are pointers to the
25	arguments of the function call. For subroutines, a pointer to the
26	code node is passed. The result type and library subroutine name
27	are generally set according to the function arguments. */
28
29	#include "config.h"
30	#include "system.h"
31	#include "coretypes.h"
32	#include "tree.h"
33	#include "gfortran.h"
34	#include "stringpool.h"
35	#include "intrinsic.h"
36	#include "constructor.h"
37	#include "arith.h"
38	#include "trans.h"
39
40	/* Given printf-like arguments, return a stable version of the result string.
41
42	We already have a working, optimized string hashing table in the form of
43	the identifier table. Reusing this table is likely not to be wasted,
44	since if the function name makes it to the gimple output of the frontend,
45	we'll have to create the identifier anyway. */
46
47	const char *
48	gfc_get_string (const char *format, ...)
49	{
50	/* Provide sufficient space for "_F.caf_token__symbol.symbol_MOD_symbol". */
51	char temp_name[15 + 2*GFC_MAX_SYMBOL_LEN + 5 + GFC_MAX_SYMBOL_LEN + 1];
52	const char *str;
53	va_list ap;
54	tree ident;
55
56	/* Handle common case without vsnprintf and temporary buffer. */
57	if (format[0] == '%' && format[1] == 's' && format[2] == '\0')
58	{
59	va_start (ap, format);
60	str = va_arg (ap, const char *);
61	va_end (ap);
62	}
63	else
64	{
65	int ret;
66	va_start (ap, format);
67	ret = vsnprintf (s: temp_name, maxlen: sizeof (temp_name), format: format, arg: ap);
68	va_end (ap);
69	if (ret < 1 || ret >= (int) sizeof (temp_name)) /* Reject truncation. */
70	gfc_internal_error ("identifier overflow: %d", ret);
71	temp_name[sizeof (temp_name) - 1] = 0;
72	str = temp_name;
73	}
74
75	ident = get_identifier (str);
76	return IDENTIFIER_POINTER (ident);
77	}
78
79	/* MERGE and SPREAD need to have source charlen's present for passing
80	to the result expression. */
81	static void
82	check_charlen_present (gfc_expr *source)
83	{
84	if (source->ts.u.cl == NULL)
85	source->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
86
87	if (source->expr_type == EXPR_CONSTANT)
88	{
89	source->ts.u.cl->length
90	= gfc_get_int_expr (gfc_charlen_int_kind, NULL,
91	source->value.character.length);
92	source->rank = 0;
93	}
94	else if (source->expr_type == EXPR_ARRAY)
95	{
96	gfc_constructor *c = gfc_constructor_first (base: source->value.constructor);
97	if (c)
98	source->ts.u.cl->length
99	= gfc_get_int_expr (gfc_charlen_int_kind, NULL,
100	c->expr->value.character.length);
101	if (source->ts.u.cl->length == NULL)
102	gfc_internal_error ("check_charlen_present(): length not set");
103	}
104	}
105
106	/* Helper function for resolving the "mask" argument. */
107
108	static void
109	resolve_mask_arg (gfc_expr *mask)
110	{
111
112	gfc_typespec ts;
113	gfc_clear_ts (&ts);
114
115	if (mask->rank == 0)
116	{
117	/* For the scalar case, coerce the mask to kind=4 unconditionally
118	(because this is the only kind we have a library function
119	for). */
120
121	if (mask->ts.kind != 4)
122	{
123	ts.type = BT_LOGICAL;
124	ts.kind = 4;
125	gfc_convert_type (mask, &ts, 2);
126	}
127	}
128	else
129	{
130	/* In the library, we access the mask with a GFC_LOGICAL_1
131	argument. No need to waste memory if we are about to create
132	a temporary array. */
133	if (mask->expr_type == EXPR_OP && mask->ts.kind != 1)
134	{
135	ts.type = BT_LOGICAL;
136	ts.kind = 1;
137	gfc_convert_type_warn (mask, &ts, 2, 0);
138	}
139	}
140	}
141
142
143	static void
144	resolve_bound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind,
145	const char *name, bool coarray)
146	{
147	f->ts.type = BT_INTEGER;
148	if (kind)
149	f->ts.kind = mpz_get_si (kind->value.integer);
150	else
151	f->ts.kind = gfc_default_integer_kind;
152
153	if (dim == NULL)
154	{
155	f->rank = 1;
156	if (array->rank != -1)
157	{
158	f->shape = gfc_get_shape (1);
159	mpz_init_set_ui (f->shape[0], coarray ? gfc_get_corank (array)
160	: array->rank);
161	}
162	}
163
164	f->value.function.name = gfc_get_string (format: "%s", name);
165	}
166
167
168	static void
169	resolve_transformational (const char *name, gfc_expr *f, gfc_expr *array,
170	gfc_expr *dim, gfc_expr *mask)
171	{
172	const char *prefix;
173
174	f->ts = array->ts;
175
176	if (mask)
177	{
178	if (mask->rank == 0)
179	prefix = "s";
180	else
181	prefix = "m";
182
183	resolve_mask_arg (mask);
184	}
185	else
186	prefix = "";
187
188	if (dim != NULL)
189	{
190	f->rank = array->rank - 1;
191	f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
192	gfc_resolve_dim_arg (dim);
193	}
194
195	f->value.function.name
196	= gfc_get_string (PREFIX ("%s%s_%c%d"), prefix, name,
197	gfc_type_letter (array->ts.type),
198	gfc_type_abi_kind (ts: &array->ts));
199	}
200
201
202	/********************** Resolution functions **********************/
203
204
205	void
206	gfc_resolve_abs (gfc_expr *f, gfc_expr *a)
207	{
208	f->ts = a->ts;
209	if (f->ts.type == BT_COMPLEX)
210	f->ts.type = BT_REAL;
211
212	f->value.function.name
213	= gfc_get_string (format: "__abs_%c%d", gfc_type_letter (a->ts.type),
214	gfc_type_abi_kind (ts: &a->ts));
215	}
216
217
218	void
219	gfc_resolve_access (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
220	gfc_expr *mode ATTRIBUTE_UNUSED)
221	{
222	f->ts.type = BT_INTEGER;
223	f->ts.kind = gfc_c_int_kind;
224	f->value.function.name = PREFIX ("access_func");
225	}
226
227
228	void
229	gfc_resolve_adjustl (gfc_expr *f, gfc_expr *string)
230	{
231	f->ts.type = BT_CHARACTER;
232	f->ts.kind = string->ts.kind;
233	if (string->ts.deferred)
234	f->ts = string->ts;
235	else if (string->ts.u.cl)
236	f->ts.u.cl = gfc_new_charlen (gfc_current_ns, string->ts.u.cl);
237
238	f->value.function.name = gfc_get_string (format: "__adjustl_s%d", f->ts.kind);
239	}
240
241
242	void
243	gfc_resolve_adjustr (gfc_expr *f, gfc_expr *string)
244	{
245	f->ts.type = BT_CHARACTER;
246	f->ts.kind = string->ts.kind;
247	if (string->ts.deferred)
248	f->ts = string->ts;
249	else if (string->ts.u.cl)
250	f->ts.u.cl = gfc_new_charlen (gfc_current_ns, string->ts.u.cl);
251
252	f->value.function.name = gfc_get_string (format: "__adjustr_s%d", f->ts.kind);
253	}
254
255
256	static void
257	gfc_resolve_char_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind,
258	bool is_achar)
259	{
260	f->ts.type = BT_CHARACTER;
261	f->ts.kind = (kind == NULL)
262	? gfc_default_character_kind : mpz_get_si (kind->value.integer);
263	f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
264	f->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
265
266	f->value.function.name
267	= gfc_get_string (format: "__%schar_%d_%c%d", is_achar ? "a" : "", f->ts.kind,
268	gfc_type_letter (x->ts.type),
269	gfc_type_abi_kind (ts: &x->ts));
270	}
271
272
273	void
274	gfc_resolve_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind)
275	{
276	gfc_resolve_char_achar (f, x, kind, is_achar: true);
277	}
278
279
280	void
281	gfc_resolve_acos (gfc_expr *f, gfc_expr *x)
282	{
283	f->ts = x->ts;
284	f->value.function.name
285	= gfc_get_string (format: "__acos_%c%d", gfc_type_letter (x->ts.type),
286	gfc_type_abi_kind (ts: &x->ts));
287	}
288
289
290	void
291	gfc_resolve_acosh (gfc_expr *f, gfc_expr *x)
292	{
293	f->ts = x->ts;
294	f->value.function.name
295	= gfc_get_string (format: "__acosh_%c%d", gfc_type_letter (x->ts.type),
296	gfc_type_abi_kind (ts: &x->ts));
297	}
298
299
300	void
301	gfc_resolve_aimag (gfc_expr *f, gfc_expr *x)
302	{
303	f->ts.type = BT_REAL;
304	f->ts.kind = x->ts.kind;
305	f->value.function.name
306	= gfc_get_string (format: "__aimag_%c%d", gfc_type_letter (x->ts.type),
307	gfc_type_abi_kind (ts: &x->ts));
308	}
309
310
311	void
312	gfc_resolve_and (gfc_expr *f, gfc_expr *i, gfc_expr *j)
313	{
314	f->ts.type = i->ts.type;
315	f->ts.kind = gfc_kind_max (i, j);
316
317	if (i->ts.kind != j->ts.kind)
318	{
319	if (i->ts.kind == gfc_kind_max (i, j))
320	gfc_convert_type (j, &i->ts, 2);
321	else
322	gfc_convert_type (i, &j->ts, 2);
323	}
324
325	f->value.function.name
326	= gfc_get_string (format: "__and_%c%d", gfc_type_letter (i->ts.type),
327	gfc_type_abi_kind (ts: &f->ts));
328	}
329
330
331	void
332	gfc_resolve_aint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
333	{
334	gfc_typespec ts;
335	gfc_clear_ts (&ts);
336
337	f->ts.type = a->ts.type;
338	f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
339
340	if (a->ts.kind != f->ts.kind)
341	{
342	ts.type = f->ts.type;
343	ts.kind = f->ts.kind;
344	gfc_convert_type (a, &ts, 2);
345	}
346	/* The resolved name is only used for specific intrinsics where
347	the return kind is the same as the arg kind. */
348	f->value.function.name
349	= gfc_get_string (format: "__aint_%c%d", gfc_type_letter (a->ts.type),
350	gfc_type_abi_kind (ts: &a->ts));
351	}
352
353
354	void
355	gfc_resolve_dint (gfc_expr *f, gfc_expr *a)
356	{
357	gfc_resolve_aint (f, a, NULL);
358	}
359
360
361	void
362	gfc_resolve_all (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
363	{
364	f->ts = mask->ts;
365
366	if (dim != NULL)
367	{
368	gfc_resolve_dim_arg (dim);
369	f->rank = mask->rank - 1;
370	f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
371	}
372
373	f->value.function.name
374	= gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask->ts.type),
375	gfc_type_abi_kind (ts: &mask->ts));
376	}
377
378
379	void
380	gfc_resolve_anint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
381	{
382	gfc_typespec ts;
383	gfc_clear_ts (&ts);
384
385	f->ts.type = a->ts.type;
386	f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
387
388	if (a->ts.kind != f->ts.kind)
389	{
390	ts.type = f->ts.type;
391	ts.kind = f->ts.kind;
392	gfc_convert_type (a, &ts, 2);
393	}
394
395	/* The resolved name is only used for specific intrinsics where
396	the return kind is the same as the arg kind. */
397	f->value.function.name
398	= gfc_get_string (format: "__anint_%c%d", gfc_type_letter (a->ts.type),
399	gfc_type_abi_kind (ts: &a->ts));
400	}
401
402
403	void
404	gfc_resolve_dnint (gfc_expr *f, gfc_expr *a)
405	{
406	gfc_resolve_anint (f, a, NULL);
407	}
408
409
410	void
411	gfc_resolve_any (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
412	{
413	f->ts = mask->ts;
414
415	if (dim != NULL)
416	{
417	gfc_resolve_dim_arg (dim);
418	f->rank = mask->rank - 1;
419	f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
420	}
421
422	f->value.function.name
423	= gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask->ts.type),
424	gfc_type_abi_kind (ts: &mask->ts));
425	}
426
427
428	void
429	gfc_resolve_asin (gfc_expr *f, gfc_expr *x)
430	{
431	f->ts = x->ts;
432	f->value.function.name
433	= gfc_get_string (format: "__asin_%c%d", gfc_type_letter (x->ts.type),
434	gfc_type_abi_kind (ts: &x->ts));
435	}
436
437	void
438	gfc_resolve_asinh (gfc_expr *f, gfc_expr *x)
439	{
440	f->ts = x->ts;
441	f->value.function.name
442	= gfc_get_string (format: "__asinh_%c%d", gfc_type_letter (x->ts.type),
443	gfc_type_abi_kind (ts: &x->ts));
444	}
445
446	void
447	gfc_resolve_atan (gfc_expr *f, gfc_expr *x)
448	{
449	f->ts = x->ts;
450	f->value.function.name
451	= gfc_get_string (format: "__atan_%c%d", gfc_type_letter (x->ts.type),
452	gfc_type_abi_kind (ts: &x->ts));
453	}
454
455	void
456	gfc_resolve_atanh (gfc_expr *f, gfc_expr *x)
457	{
458	f->ts = x->ts;
459	f->value.function.name
460	= gfc_get_string (format: "__atanh_%c%d", gfc_type_letter (x->ts.type),
461	gfc_type_abi_kind (ts: &x->ts));
462	}
463
464	void
465	gfc_resolve_atan2 (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
466	{
467	f->ts = x->ts;
468	f->value.function.name
469	= gfc_get_string (format: "__atan2_%c%d", gfc_type_letter (x->ts.type),
470	gfc_type_abi_kind (ts: &x->ts));
471	}
472
473
474	/* Resolve the BESYN and BESJN intrinsics. */
475
476	void
477	gfc_resolve_besn (gfc_expr *f, gfc_expr *n, gfc_expr *x)
478	{
479	gfc_typespec ts;
480	gfc_clear_ts (&ts);
481
482	f->ts = x->ts;
483	if (n->ts.kind != gfc_c_int_kind)
484	{
485	ts.type = BT_INTEGER;
486	ts.kind = gfc_c_int_kind;
487	gfc_convert_type (n, &ts, 2);
488	}
489	f->value.function.name = gfc_get_string (format: "<intrinsic>");
490	}
491
492
493	void
494	gfc_resolve_bessel_n2 (gfc_expr *f, gfc_expr *n1, gfc_expr *n2, gfc_expr *x)
495	{
496	gfc_typespec ts;
497	gfc_clear_ts (&ts);
498
499	f->ts = x->ts;
500	f->rank = 1;
501	if (n1->expr_type == EXPR_CONSTANT && n2->expr_type == EXPR_CONSTANT)
502	{
503	f->shape = gfc_get_shape (1);
504	mpz_init (f->shape[0]);
505	mpz_sub (f->shape[0], n2->value.integer, n1->value.integer);
506	mpz_add_ui (f->shape[0], f->shape[0], 1);
507	}
508
509	if (n1->ts.kind != gfc_c_int_kind)
510	{
511	ts.type = BT_INTEGER;
512	ts.kind = gfc_c_int_kind;
513	gfc_convert_type (n1, &ts, 2);
514	}
515
516	if (n2->ts.kind != gfc_c_int_kind)
517	{
518	ts.type = BT_INTEGER;
519	ts.kind = gfc_c_int_kind;
520	gfc_convert_type (n2, &ts, 2);
521	}
522
523	if (f->value.function.isym->id == GFC_ISYM_JN2)
524	f->value.function.name = gfc_get_string (PREFIX ("bessel_jn_r%d"),
525	gfc_type_abi_kind (ts: &f->ts));
526	else
527	f->value.function.name = gfc_get_string (PREFIX ("bessel_yn_r%d"),
528	gfc_type_abi_kind (ts: &f->ts));
529	}
530
531
532	void
533	gfc_resolve_btest (gfc_expr *f, gfc_expr *i, gfc_expr *pos)
534	{
535	f->ts.type = BT_LOGICAL;
536	f->ts.kind = gfc_default_logical_kind;
537	f->value.function.name
538	= gfc_get_string (format: "__btest_%d_%d", i->ts.kind, pos->ts.kind);
539	}
540
541
542	void
543	gfc_resolve_c_loc (gfc_expr *f, gfc_expr *x ATTRIBUTE_UNUSED)
544	{
545	f->ts = f->value.function.isym->ts;
546	}
547
548
549	void
550	gfc_resolve_c_funloc (gfc_expr *f, gfc_expr *x ATTRIBUTE_UNUSED)
551	{
552	f->ts = f->value.function.isym->ts;
553	}
554
555
556	void
557	gfc_resolve_ceiling (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
558	{
559	f->ts.type = BT_INTEGER;
560	f->ts.kind = (kind == NULL)
561	? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
562	f->value.function.name
563	= gfc_get_string (format: "__ceiling_%d_%c%d", f->ts.kind,
564	gfc_type_letter (a->ts.type),
565	gfc_type_abi_kind (ts: &a->ts));
566	}
567
568
569	void
570	gfc_resolve_char (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
571	{
572	gfc_resolve_char_achar (f, x: a, kind, is_achar: false);
573	}
574
575
576	void
577	gfc_resolve_chdir (gfc_expr *f, gfc_expr *d ATTRIBUTE_UNUSED)
578	{
579	f->ts.type = BT_INTEGER;
580	f->ts.kind = gfc_default_integer_kind;
581	f->value.function.name = gfc_get_string (PREFIX ("chdir_i%d"), f->ts.kind);
582	}
583
584
585	void
586	gfc_resolve_chdir_sub (gfc_code *c)
587	{
588	const char *name;
589	int kind;
590
591	if (c->ext.actual->next->expr != NULL)
592	kind = c->ext.actual->next->expr->ts.kind;
593	else
594	kind = gfc_default_integer_kind;
595
596	name = gfc_get_string (PREFIX ("chdir_i%d_sub"), kind);
597	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
598	}
599
600
601	void
602	gfc_resolve_chmod (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
603	gfc_expr *mode ATTRIBUTE_UNUSED)
604	{
605	f->ts.type = BT_INTEGER;
606	f->ts.kind = gfc_c_int_kind;
607	f->value.function.name = PREFIX ("chmod_func");
608	}
609
610
611	void
612	gfc_resolve_chmod_sub (gfc_code *c)
613	{
614	const char *name;
615	int kind;
616
617	if (c->ext.actual->next->next->expr != NULL)
618	kind = c->ext.actual->next->next->expr->ts.kind;
619	else
620	kind = gfc_default_integer_kind;
621
622	name = gfc_get_string (PREFIX ("chmod_i%d_sub"), kind);
623	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
624	}
625
626
627	void
628	gfc_resolve_cmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y, gfc_expr *kind)
629	{
630	f->ts.type = BT_COMPLEX;
631	f->ts.kind = (kind == NULL)
632	? gfc_default_real_kind : mpz_get_si (kind->value.integer);
633
634	if (y == NULL)
635	f->value.function.name
636	= gfc_get_string (format: "__cmplx0_%d_%c%d", f->ts.kind,
637	gfc_type_letter (x->ts.type),
638	gfc_type_abi_kind (ts: &x->ts));
639	else
640	f->value.function.name
641	= gfc_get_string (format: "__cmplx1_%d_%c%d_%c%d", f->ts.kind,
642	gfc_type_letter (x->ts.type),
643	gfc_type_abi_kind (ts: &x->ts),
644	gfc_type_letter (y->ts.type),
645	gfc_type_abi_kind (ts: &y->ts));
646	}
647
648
649	void
650	gfc_resolve_dcmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y)
651	{
652	gfc_resolve_cmplx (f, x, y, kind: gfc_get_int_expr (gfc_default_integer_kind, NULL,
653	gfc_default_double_kind));
654	}
655
656
657	void
658	gfc_resolve_complex (gfc_expr *f, gfc_expr *x, gfc_expr *y)
659	{
660	int kind;
661
662	if (x->ts.type == BT_INTEGER)
663	{
664	if (y->ts.type == BT_INTEGER)
665	kind = gfc_default_real_kind;
666	else
667	kind = y->ts.kind;
668	}
669	else
670	{
671	if (y->ts.type == BT_REAL)
672	kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
673	else
674	kind = x->ts.kind;
675	}
676
677	f->ts.type = BT_COMPLEX;
678	f->ts.kind = kind;
679	f->value.function.name
680	= gfc_get_string (format: "__cmplx1_%d_%c%d_%c%d", f->ts.kind,
681	gfc_type_letter (x->ts.type),
682	gfc_type_abi_kind (ts: &x->ts),
683	gfc_type_letter (y->ts.type),
684	gfc_type_abi_kind (ts: &y->ts));
685	}
686
687
688	void
689	gfc_resolve_conjg (gfc_expr *f, gfc_expr *x)
690	{
691	f->ts = x->ts;
692	f->value.function.name = gfc_get_string (format: "__conjg_%d", x->ts.kind);
693	}
694
695
696	void
697	gfc_resolve_cos (gfc_expr *f, gfc_expr *x)
698	{
699	f->ts = x->ts;
700	f->value.function.name
701	= gfc_get_string (format: "__cos_%c%d", gfc_type_letter (x->ts.type),
702	gfc_type_abi_kind (ts: &x->ts));
703	}
704
705
706	void
707	gfc_resolve_cosh (gfc_expr *f, gfc_expr *x)
708	{
709	f->ts = x->ts;
710	f->value.function.name
711	= gfc_get_string (format: "__cosh_%c%d", gfc_type_letter (x->ts.type),
712	gfc_type_abi_kind (ts: &x->ts));
713	}
714
715
716	void
717	gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
718	{
719	f->ts.type = BT_INTEGER;
720	if (kind)
721	f->ts.kind = mpz_get_si (kind->value.integer);
722	else
723	f->ts.kind = gfc_default_integer_kind;
724
725	if (dim != NULL)
726	{
727	f->rank = mask->rank - 1;
728	gfc_resolve_dim_arg (dim);
729	f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
730	}
731
732	resolve_mask_arg (mask);
733
734	f->value.function.name
735	= gfc_get_string (PREFIX ("count_%d_%c"), gfc_type_abi_kind (ts: &f->ts),
736	gfc_type_letter (mask->ts.type));
737	}
738
739
740	void
741	gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
742	gfc_expr *dim)
743	{
744	int n, m;
745
746	if (array->ts.type == BT_CHARACTER && array->ref)
747	gfc_resolve_substring_charlen (array);
748
749	f->ts = array->ts;
750	f->rank = array->rank;
751	f->shape = gfc_copy_shape (array->shape, array->rank);
752
753	if (shift->rank > 0)
754	n = 1;
755	else
756	n = 0;
757
758	/* If dim kind is greater than default integer we need to use the larger. */
759	m = gfc_default_integer_kind;
760	if (dim != NULL)
761	m = m < dim->ts.kind ? dim->ts.kind : m;
762
763	/* Convert shift to at least m, so we don't need
764	kind=1 and kind=2 versions of the library functions. */
765	if (shift->ts.kind < m)
766	{
767	gfc_typespec ts;
768	gfc_clear_ts (&ts);
769	ts.type = BT_INTEGER;
770	ts.kind = m;
771	gfc_convert_type_warn (shift, &ts, 2, 0);
772	}
773
774	if (dim != NULL)
775	{
776	if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL
777	&& dim->symtree->n.sym->attr.optional)
778	{
779	/* Mark this for later setting the type in gfc_conv_missing_dummy. */
780	dim->representation.length = shift->ts.kind;
781	}
782	else
783	{
784	gfc_resolve_dim_arg (dim);
785	/* Convert dim to shift's kind to reduce variations. */
786	if (dim->ts.kind != shift->ts.kind)
787	gfc_convert_type_warn (dim, &shift->ts, 2, 0);
788	}
789	}
790
791	if (array->ts.type == BT_CHARACTER)
792	{
793	if (array->ts.kind == gfc_default_character_kind)
794	f->value.function.name
795	= gfc_get_string (PREFIX ("cshift%d_%d_char"), n, shift->ts.kind);
796	else
797	f->value.function.name
798	= gfc_get_string (PREFIX ("cshift%d_%d_char%d"), n, shift->ts.kind,
799	array->ts.kind);
800	}
801	else
802	f->value.function.name
803	= gfc_get_string (PREFIX ("cshift%d_%d"), n, shift->ts.kind);
804	}
805
806
807	void
808	gfc_resolve_ctime (gfc_expr *f, gfc_expr *time)
809	{
810	gfc_typespec ts;
811	gfc_clear_ts (&ts);
812
813	f->ts.type = BT_CHARACTER;
814	f->ts.kind = gfc_default_character_kind;
815
816	/* ctime TIME argument is a INTEGER(KIND=8), says the doc */
817	if (time->ts.kind != 8)
818	{
819	ts.type = BT_INTEGER;
820	ts.kind = 8;
821	ts.u.derived = NULL;
822	ts.u.cl = NULL;
823	gfc_convert_type (time, &ts, 2);
824	}
825
826	f->value.function.name = gfc_get_string (PREFIX ("ctime"));
827	}
828
829
830	void
831	gfc_resolve_dble (gfc_expr *f, gfc_expr *a)
832	{
833	f->ts.type = BT_REAL;
834	f->ts.kind = gfc_default_double_kind;
835	f->value.function.name
836	= gfc_get_string (format: "__dble_%c%d", gfc_type_letter (a->ts.type),
837	gfc_type_abi_kind (ts: &a->ts));
838	}
839
840
841	void
842	gfc_resolve_dim (gfc_expr *f, gfc_expr *a, gfc_expr *p)
843	{
844	f->ts.type = a->ts.type;
845	if (p != NULL)
846	f->ts.kind = gfc_kind_max (a,p);
847	else
848	f->ts.kind = a->ts.kind;
849
850	if (p != NULL && a->ts.kind != p->ts.kind)
851	{
852	if (a->ts.kind == gfc_kind_max (a,p))
853	gfc_convert_type (p, &a->ts, 2);
854	else
855	gfc_convert_type (a, &p->ts, 2);
856	}
857
858	f->value.function.name
859	= gfc_get_string (format: "__dim_%c%d", gfc_type_letter (f->ts.type),
860	gfc_type_abi_kind (ts: &f->ts));
861	}
862
863
864	void
865	gfc_resolve_dot_product (gfc_expr *f, gfc_expr *a, gfc_expr *b)
866	{
867	gfc_expr temp;
868
869	temp.expr_type = EXPR_OP;
870	gfc_clear_ts (&temp.ts);
871	temp.value.op.op = INTRINSIC_NONE;
872	temp.value.op.op1 = a;
873	temp.value.op.op2 = b;
874	gfc_type_convert_binary (&temp, 1);
875	f->ts = temp.ts;
876	f->value.function.name
877	= gfc_get_string (PREFIX ("dot_product_%c%d"),
878	gfc_type_letter (f->ts.type),
879	gfc_type_abi_kind (ts: &f->ts));
880	}
881
882
883	void
884	gfc_resolve_dprod (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
885	gfc_expr *b ATTRIBUTE_UNUSED)
886	{
887	f->ts.kind = gfc_default_double_kind;
888	f->ts.type = BT_REAL;
889	f->value.function.name = gfc_get_string (format: "__dprod_r%d",
890	gfc_type_abi_kind (ts: &f->ts));
891	}
892
893
894	void
895	gfc_resolve_dshift (gfc_expr *f, gfc_expr *i, gfc_expr *j ATTRIBUTE_UNUSED,
896	gfc_expr *shift ATTRIBUTE_UNUSED)
897	{
898	f->ts = i->ts;
899	if (f->value.function.isym->id == GFC_ISYM_DSHIFTL)
900	f->value.function.name = gfc_get_string (format: "dshiftl_i%d", f->ts.kind);
901	else if (f->value.function.isym->id == GFC_ISYM_DSHIFTR)
902	f->value.function.name = gfc_get_string (format: "dshiftr_i%d", f->ts.kind);
903	else
904	gcc_unreachable ();
905	}
906
907
908	void
909	gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
910	gfc_expr *boundary, gfc_expr *dim)
911	{
912	int n, m;
913
914	if (array->ts.type == BT_CHARACTER && array->ref)
915	gfc_resolve_substring_charlen (array);
916
917	f->ts = array->ts;
918	f->rank = array->rank;
919	f->shape = gfc_copy_shape (array->shape, array->rank);
920
921	n = 0;
922	if (shift->rank > 0)
923	n = n | 1;
924	if (boundary && boundary->rank > 0)
925	n = n | 2;
926
927	/* If dim kind is greater than default integer we need to use the larger. */
928	m = gfc_default_integer_kind;
929	if (dim != NULL)
930	m = m < dim->ts.kind ? dim->ts.kind : m;
931
932	/* Convert shift to at least m, so we don't need
933	kind=1 and kind=2 versions of the library functions. */
934	if (shift->ts.kind < m)
935	{
936	gfc_typespec ts;
937	gfc_clear_ts (&ts);
938	ts.type = BT_INTEGER;
939	ts.kind = m;
940	gfc_convert_type_warn (shift, &ts, 2, 0);
941	}
942
943	if (dim != NULL)
944	{
945	if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL
946	&& dim->symtree->n.sym->attr.optional)
947	{
948	/* Mark this for later setting the type in gfc_conv_missing_dummy. */
949	dim->representation.length = shift->ts.kind;
950	}
951	else
952	{
953	gfc_resolve_dim_arg (dim);
954	/* Convert dim to shift's kind to reduce variations. */
955	if (dim->ts.kind != shift->ts.kind)
956	gfc_convert_type_warn (dim, &shift->ts, 2, 0);
957	}
958	}
959
960	if (array->ts.type == BT_CHARACTER)
961	{
962	if (array->ts.kind == gfc_default_character_kind)
963	f->value.function.name
964	= gfc_get_string (PREFIX ("eoshift%d_%d_char"), n, shift->ts.kind);
965	else
966	f->value.function.name
967	= gfc_get_string (PREFIX ("eoshift%d_%d_char%d"), n, shift->ts.kind,
968	array->ts.kind);
969	}
970	else
971	f->value.function.name
972	= gfc_get_string (PREFIX ("eoshift%d_%d"), n, shift->ts.kind);
973	}
974
975
976	void
977	gfc_resolve_exp (gfc_expr *f, gfc_expr *x)
978	{
979	f->ts = x->ts;
980	f->value.function.name
981	= gfc_get_string (format: "__exp_%c%d", gfc_type_letter (x->ts.type),
982	gfc_type_abi_kind (ts: &x->ts));
983	}
984
985
986	void
987	gfc_resolve_exponent (gfc_expr *f, gfc_expr *x)
988	{
989	f->ts.type = BT_INTEGER;
990	f->ts.kind = gfc_default_integer_kind;
991	f->value.function.name = gfc_get_string (format: "__exponent_%d", x->ts.kind);
992	}
993
994
995	/* Resolve the EXTENDS_TYPE_OF intrinsic function. */
996
997	void
998	gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
999	{
1000	gfc_symbol *vtab;
1001	gfc_symtree *st;
1002
1003	/* Prevent double resolution. */
1004	if (f->ts.type == BT_LOGICAL)
1005	return;
1006
1007	/* Replace the first argument with the corresponding vtab. */
1008	if (a->ts.type == BT_CLASS)
1009	gfc_add_vptr_component (a);
1010	else if (a->ts.type == BT_DERIVED)
1011	{
1012	locus where;
1013
1014	vtab = gfc_find_derived_vtab (a->ts.u.derived);
1015	/* Clear the old expr. */
1016	gfc_free_ref_list (a->ref);
1017	where = a->where;
1018	memset (s: a, c: '\0', n: sizeof (gfc_expr));
1019	/* Construct a new one. */
1020	a->expr_type = EXPR_VARIABLE;
1021	st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
1022	a->symtree = st;
1023	a->ts = vtab->ts;
1024	a->where = where;
1025	}
1026
1027	/* Replace the second argument with the corresponding vtab. */
1028	if (mo->ts.type == BT_CLASS)
1029	gfc_add_vptr_component (mo);
1030	else if (mo->ts.type == BT_DERIVED)
1031	{
1032	locus where;
1033
1034	vtab = gfc_find_derived_vtab (mo->ts.u.derived);
1035	/* Clear the old expr. */
1036	where = mo->where;
1037	gfc_free_ref_list (mo->ref);
1038	memset (s: mo, c: '\0', n: sizeof (gfc_expr));
1039	/* Construct a new one. */
1040	mo->expr_type = EXPR_VARIABLE;
1041	st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
1042	mo->symtree = st;
1043	mo->ts = vtab->ts;
1044	mo->where = where;
1045	}
1046
1047	f->ts.type = BT_LOGICAL;
1048	f->ts.kind = 4;
1049
1050	f->value.function.isym->formal->ts = a->ts;
1051	f->value.function.isym->formal->next->ts = mo->ts;
1052
1053	/* Call library function. */
1054	f->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
1055	}
1056
1057
1058	void
1059	gfc_resolve_fdate (gfc_expr *f)
1060	{
1061	f->ts.type = BT_CHARACTER;
1062	f->ts.kind = gfc_default_character_kind;
1063	f->value.function.name = gfc_get_string (PREFIX ("fdate"));
1064	}
1065
1066
1067	void
1068	gfc_resolve_floor (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1069	{
1070	f->ts.type = BT_INTEGER;
1071	f->ts.kind = (kind == NULL)
1072	? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
1073	f->value.function.name
1074	= gfc_get_string (format: "__floor%d_%c%d", f->ts.kind,
1075	gfc_type_letter (a->ts.type),
1076	gfc_type_abi_kind (ts: &a->ts));
1077	}
1078
1079
1080	void
1081	gfc_resolve_fnum (gfc_expr *f, gfc_expr *n)
1082	{
1083	f->ts.type = BT_INTEGER;
1084	f->ts.kind = gfc_default_integer_kind;
1085	if (n->ts.kind != f->ts.kind)
1086	gfc_convert_type (n, &f->ts, 2);
1087	f->value.function.name = gfc_get_string (PREFIX ("fnum_i%d"), f->ts.kind);
1088	}
1089
1090
1091	void
1092	gfc_resolve_fraction (gfc_expr *f, gfc_expr *x)
1093	{
1094	f->ts = x->ts;
1095	f->value.function.name = gfc_get_string (format: "__fraction_%d", x->ts.kind);
1096	}
1097
1098
1099	/* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
1100
1101	void
1102	gfc_resolve_g77_math1 (gfc_expr *f, gfc_expr *x)
1103	{
1104	f->ts = x->ts;
1105	f->value.function.name = gfc_get_string (format: "<intrinsic>");
1106	}
1107
1108
1109	void
1110	gfc_resolve_gamma (gfc_expr *f, gfc_expr *x)
1111	{
1112	f->ts = x->ts;
1113	f->value.function.name
1114	= gfc_get_string (format: "__tgamma_%d", x->ts.kind);
1115	}
1116
1117
1118	void
1119	gfc_resolve_getcwd (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
1120	{
1121	f->ts.type = BT_INTEGER;
1122	f->ts.kind = 4;
1123	f->value.function.name = gfc_get_string (PREFIX ("getcwd"));
1124	}
1125
1126
1127	void
1128	gfc_resolve_getgid (gfc_expr *f)
1129	{
1130	f->ts.type = BT_INTEGER;
1131	f->ts.kind = 4;
1132	f->value.function.name = gfc_get_string (PREFIX ("getgid"));
1133	}
1134
1135
1136	void
1137	gfc_resolve_getpid (gfc_expr *f)
1138	{
1139	f->ts.type = BT_INTEGER;
1140	f->ts.kind = 4;
1141	f->value.function.name = gfc_get_string (PREFIX ("getpid"));
1142	}
1143
1144
1145	void
1146	gfc_resolve_getuid (gfc_expr *f)
1147	{
1148	f->ts.type = BT_INTEGER;
1149	f->ts.kind = 4;
1150	f->value.function.name = gfc_get_string (PREFIX ("getuid"));
1151	}
1152
1153
1154	void
1155	gfc_resolve_hostnm (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
1156	{
1157	f->ts.type = BT_INTEGER;
1158	f->ts.kind = 4;
1159	f->value.function.name = gfc_get_string (PREFIX ("hostnm"));
1160	}
1161
1162
1163	void
1164	gfc_resolve_hypot (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
1165	{
1166	f->ts = x->ts;
1167	f->value.function.name = gfc_get_string (format: "__hypot_r%d",
1168	gfc_type_abi_kind (ts: &x->ts));
1169	}
1170
1171
1172	void
1173	gfc_resolve_iall (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
1174	{
1175	resolve_transformational (name: "iall", f, array, dim, mask);
1176	}
1177
1178
1179	void
1180	gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1181	{
1182	/* If the kind of i and j are different, then g77 cross-promoted the
1183	kinds to the largest value. The Fortran 95 standard requires the
1184	kinds to match. */
1185	if (i->ts.kind != j->ts.kind)
1186	{
1187	if (i->ts.kind == gfc_kind_max (i, j))
1188	gfc_convert_type (j, &i->ts, 2);
1189	else
1190	gfc_convert_type (i, &j->ts, 2);
1191	}
1192
1193	f->ts = i->ts;
1194	f->value.function.name = gfc_get_string (format: "__iand_%d", i->ts.kind);
1195	}
1196
1197
1198	void
1199	gfc_resolve_iany (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
1200	{
1201	resolve_transformational (name: "iany", f, array, dim, mask);
1202	}
1203
1204
1205	void
1206	gfc_resolve_ibclr (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
1207	{
1208	f->ts = i->ts;
1209	f->value.function.name = gfc_get_string (format: "__ibclr_%d", i->ts.kind);
1210	}
1211
1212
1213	void
1214	gfc_resolve_ibits (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED,
1215	gfc_expr *len ATTRIBUTE_UNUSED)
1216	{
1217	f->ts = i->ts;
1218	f->value.function.name = gfc_get_string (format: "__ibits_%d", i->ts.kind);
1219	}
1220
1221
1222	void
1223	gfc_resolve_ibset (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
1224	{
1225	f->ts = i->ts;
1226	f->value.function.name = gfc_get_string (format: "__ibset_%d", i->ts.kind);
1227	}
1228
1229
1230	void
1231	gfc_resolve_iachar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
1232	{
1233	f->ts.type = BT_INTEGER;
1234	if (kind)
1235	f->ts.kind = mpz_get_si (kind->value.integer);
1236	else
1237	f->ts.kind = gfc_default_integer_kind;
1238	f->value.function.name = gfc_get_string (format: "__ichar_%d", c->ts.kind);
1239	}
1240
1241
1242	void
1243	gfc_resolve_ichar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
1244	{
1245	f->ts.type = BT_INTEGER;
1246	if (kind)
1247	f->ts.kind = mpz_get_si (kind->value.integer);
1248	else
1249	f->ts.kind = gfc_default_integer_kind;
1250	f->value.function.name = gfc_get_string (format: "__ichar_%d", c->ts.kind);
1251	}
1252
1253
1254	void
1255	gfc_resolve_idnint (gfc_expr *f, gfc_expr *a)
1256	{
1257	gfc_resolve_nint (f, a, NULL);
1258	}
1259
1260
1261	void
1262	gfc_resolve_ierrno (gfc_expr *f)
1263	{
1264	f->ts.type = BT_INTEGER;
1265	f->ts.kind = gfc_default_integer_kind;
1266	f->value.function.name = gfc_get_string (PREFIX ("ierrno_i%d"), f->ts.kind);
1267	}
1268
1269
1270	void
1271	gfc_resolve_ieor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1272	{
1273	/* If the kind of i and j are different, then g77 cross-promoted the
1274	kinds to the largest value. The Fortran 95 standard requires the
1275	kinds to match. */
1276	if (i->ts.kind != j->ts.kind)
1277	{
1278	if (i->ts.kind == gfc_kind_max (i, j))
1279	gfc_convert_type (j, &i->ts, 2);
1280	else
1281	gfc_convert_type (i, &j->ts, 2);
1282	}
1283
1284	f->ts = i->ts;
1285	f->value.function.name = gfc_get_string (format: "__ieor_%d", i->ts.kind);
1286	}
1287
1288
1289	void
1290	gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1291	{
1292	/* If the kind of i and j are different, then g77 cross-promoted the
1293	kinds to the largest value. The Fortran 95 standard requires the
1294	kinds to match. */
1295	if (i->ts.kind != j->ts.kind)
1296	{
1297	if (i->ts.kind == gfc_kind_max (i, j))
1298	gfc_convert_type (j, &i->ts, 2);
1299	else
1300	gfc_convert_type (i, &j->ts, 2);
1301	}
1302
1303	f->ts = i->ts;
1304	f->value.function.name = gfc_get_string (format: "__ior_%d", i->ts.kind);
1305	}
1306
1307
1308	void
1309	gfc_resolve_index_func (gfc_expr *f, gfc_expr *str,
1310	gfc_expr *sub_str ATTRIBUTE_UNUSED, gfc_expr *back,
1311	gfc_expr *kind)
1312	{
1313	gfc_typespec ts;
1314	gfc_clear_ts (&ts);
1315
1316	f->ts.type = BT_INTEGER;
1317	if (kind)
1318	f->ts.kind = mpz_get_si (kind->value.integer);
1319	else
1320	f->ts.kind = gfc_default_integer_kind;
1321
1322	if (back && back->ts.kind != gfc_default_integer_kind)
1323	{
1324	ts.type = BT_LOGICAL;
1325	ts.kind = gfc_default_integer_kind;
1326	ts.u.derived = NULL;
1327	ts.u.cl = NULL;
1328	gfc_convert_type (back, &ts, 2);
1329	}
1330
1331	f->value.function.name
1332	= gfc_get_string (format: "__index_%d_i%d", str->ts.kind, f->ts.kind);
1333	}
1334
1335
1336	void
1337	gfc_resolve_int (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1338	{
1339	f->ts.type = BT_INTEGER;
1340	f->ts.kind = (kind == NULL)
1341	? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
1342	f->value.function.name
1343	= gfc_get_string (format: "__int_%d_%c%d", f->ts.kind,
1344	gfc_type_letter (a->ts.type),
1345	gfc_type_abi_kind (ts: &a->ts));
1346	}
1347
1348
1349	void
1350	gfc_resolve_int2 (gfc_expr *f, gfc_expr *a)
1351	{
1352	f->ts.type = BT_INTEGER;
1353	f->ts.kind = 2;
1354	f->value.function.name
1355	= gfc_get_string (format: "__int_%d_%c%d", f->ts.kind,
1356	gfc_type_letter (a->ts.type),
1357	gfc_type_abi_kind (ts: &a->ts));
1358	}
1359
1360
1361	void
1362	gfc_resolve_int8 (gfc_expr *f, gfc_expr *a)
1363	{
1364	f->ts.type = BT_INTEGER;
1365	f->ts.kind = 8;
1366	f->value.function.name
1367	= gfc_get_string (format: "__int_%d_%c%d", f->ts.kind,
1368	gfc_type_letter (a->ts.type),
1369	gfc_type_abi_kind (ts: &a->ts));
1370	}
1371
1372
1373	void
1374	gfc_resolve_long (gfc_expr *f, gfc_expr *a)
1375	{
1376	f->ts.type = BT_INTEGER;
1377	f->ts.kind = 4;
1378	f->value.function.name
1379	= gfc_get_string (format: "__int_%d_%c%d", f->ts.kind,
1380	gfc_type_letter (a->ts.type),
1381	gfc_type_abi_kind (ts: &a->ts));
1382	}
1383
1384
1385	void
1386	gfc_resolve_iparity (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
1387	{
1388	resolve_transformational (name: "iparity", f, array, dim, mask);
1389	}
1390
1391
1392	void
1393	gfc_resolve_isatty (gfc_expr *f, gfc_expr *u)
1394	{
1395	gfc_typespec ts;
1396	gfc_clear_ts (&ts);
1397
1398	f->ts.type = BT_LOGICAL;
1399	f->ts.kind = gfc_default_integer_kind;
1400	if (u->ts.kind != gfc_c_int_kind)
1401	{
1402	ts.type = BT_INTEGER;
1403	ts.kind = gfc_c_int_kind;
1404	ts.u.derived = NULL;
1405	ts.u.cl = NULL;
1406	gfc_convert_type (u, &ts, 2);
1407	}
1408
1409	f->value.function.name = gfc_get_string (PREFIX ("isatty_l%d"), f->ts.kind);
1410	}
1411
1412
1413	void
1414	gfc_resolve_is_contiguous (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED)
1415	{
1416	f->ts.type = BT_LOGICAL;
1417	f->ts.kind = gfc_default_logical_kind;
1418	f->value.function.name = gfc_get_string (format: "__is_contiguous");
1419	}
1420
1421
1422	void
1423	gfc_resolve_ishft (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1424	{
1425	f->ts = i->ts;
1426	f->value.function.name
1427	= gfc_get_string (format: "__ishft_%d_%d", i->ts.kind, shift->ts.kind);
1428	}
1429
1430
1431	void
1432	gfc_resolve_rshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1433	{
1434	f->ts = i->ts;
1435	f->value.function.name
1436	= gfc_get_string (format: "__rshift_%d_%d", i->ts.kind, shift->ts.kind);
1437	}
1438
1439
1440	void
1441	gfc_resolve_lshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1442	{
1443	f->ts = i->ts;
1444	f->value.function.name
1445	= gfc_get_string (format: "__lshift_%d_%d", i->ts.kind, shift->ts.kind);
1446	}
1447
1448
1449	void
1450	gfc_resolve_ishftc (gfc_expr *f, gfc_expr *i, gfc_expr *shift, gfc_expr *size)
1451	{
1452	int s_kind;
1453
1454	s_kind = (size == NULL) ? gfc_default_integer_kind : size->ts.kind;
1455
1456	f->ts = i->ts;
1457	f->value.function.name
1458	= gfc_get_string (format: "__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
1459	}
1460
1461
1462	void
1463	gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
1464	{
1465	resolve_bound (f, array, dim, kind, name: "__lbound", coarray: false);
1466	}
1467
1468
1469	void
1470	gfc_resolve_lcobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
1471	{
1472	resolve_bound (f, array, dim, kind, name: "__lcobound", coarray: true);
1473	}
1474
1475
1476	void
1477	gfc_resolve_len (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
1478	{
1479	f->ts.type = BT_INTEGER;
1480	if (kind)
1481	f->ts.kind = mpz_get_si (kind->value.integer);
1482	else
1483	f->ts.kind = gfc_default_integer_kind;
1484	f->value.function.name
1485	= gfc_get_string (format: "__len_%d_i%d", string->ts.kind,
1486	gfc_default_integer_kind);
1487	}
1488
1489
1490	void
1491	gfc_resolve_len_trim (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
1492	{
1493	f->ts.type = BT_INTEGER;
1494	if (kind)
1495	f->ts.kind = mpz_get_si (kind->value.integer);
1496	else
1497	f->ts.kind = gfc_default_integer_kind;
1498	f->value.function.name = gfc_get_string (format: "__len_trim%d", string->ts.kind);
1499	}
1500
1501
1502	void
1503	gfc_resolve_lgamma (gfc_expr *f, gfc_expr *x)
1504	{
1505	f->ts = x->ts;
1506	f->value.function.name
1507	= gfc_get_string (format: "__lgamma_%d", x->ts.kind);
1508	}
1509
1510
1511	void
1512	gfc_resolve_link (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
1513	gfc_expr *p2 ATTRIBUTE_UNUSED)
1514	{
1515	f->ts.type = BT_INTEGER;
1516	f->ts.kind = gfc_default_integer_kind;
1517	f->value.function.name = gfc_get_string (PREFIX ("link_i%d"), f->ts.kind);
1518	}
1519
1520
1521	void
1522	gfc_resolve_loc (gfc_expr *f, gfc_expr *x)
1523	{
1524	f->ts.type= BT_INTEGER;
1525	f->ts.kind = gfc_index_integer_kind;
1526	f->value.function.name = gfc_get_string (format: "__loc_%d", x->ts.kind);
1527	}
1528
1529
1530	void
1531	gfc_resolve_log (gfc_expr *f, gfc_expr *x)
1532	{
1533	f->ts = x->ts;
1534	f->value.function.name
1535	= gfc_get_string (format: "__log_%c%d", gfc_type_letter (x->ts.type),
1536	gfc_type_abi_kind (ts: &x->ts));
1537	}
1538
1539
1540	void
1541	gfc_resolve_log10 (gfc_expr *f, gfc_expr *x)
1542	{
1543	f->ts = x->ts;
1544	f->value.function.name
1545	= gfc_get_string (format: "__log10_%c%d", gfc_type_letter (x->ts.type),
1546	gfc_type_abi_kind (ts: &x->ts));
1547	}
1548
1549
1550	void
1551	gfc_resolve_logical (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1552	{
1553	f->ts.type = BT_LOGICAL;
1554	f->ts.kind = (kind == NULL)
1555	? gfc_default_logical_kind : mpz_get_si (kind->value.integer);
1556	f->rank = a->rank;
1557
1558	f->value.function.name
1559	= gfc_get_string (format: "__logical_%d_%c%d", f->ts.kind,
1560	gfc_type_letter (a->ts.type),
1561	gfc_type_abi_kind (ts: &a->ts));
1562	}
1563
1564
1565	void
1566	gfc_resolve_matmul (gfc_expr *f, gfc_expr *a, gfc_expr *b)
1567	{
1568	gfc_expr temp;
1569
1570	if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
1571	{
1572	f->ts.type = BT_LOGICAL;
1573	f->ts.kind = gfc_default_logical_kind;
1574	}
1575	else
1576	{
1577	temp.expr_type = EXPR_OP;
1578	gfc_clear_ts (&temp.ts);
1579	temp.value.op.op = INTRINSIC_NONE;
1580	temp.value.op.op1 = a;
1581	temp.value.op.op2 = b;
1582	gfc_type_convert_binary (&temp, 1);
1583	f->ts = temp.ts;
1584	}
1585
1586	f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
1587
1588	if (a->rank == 2 && b->rank == 2)
1589	{
1590	if (a->shape && b->shape)
1591	{
1592	f->shape = gfc_get_shape (f->rank);
1593	mpz_init_set (f->shape[0], a->shape[0]);
1594	mpz_init_set (f->shape[1], b->shape[1]);
1595	}
1596	}
1597	else if (a->rank == 1)
1598	{
1599	if (b->shape)
1600	{
1601	f->shape = gfc_get_shape (f->rank);
1602	mpz_init_set (f->shape[0], b->shape[1]);
1603	}
1604	}
1605	else
1606	{
1607	/* b->rank == 1 and a->rank == 2 here, all other cases have
1608	been caught in check.cc. */
1609	if (a->shape)
1610	{
1611	f->shape = gfc_get_shape (f->rank);
1612	mpz_init_set (f->shape[0], a->shape[0]);
1613	}
1614	}
1615
1616	f->value.function.name
1617	= gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f->ts.type),
1618	gfc_type_abi_kind (ts: &f->ts));
1619	}
1620
1621
1622	static void
1623	gfc_resolve_minmax (const char *name, gfc_expr *f, gfc_actual_arglist *args)
1624	{
1625	gfc_actual_arglist *a;
1626
1627	f->ts.type = args->expr->ts.type;
1628	f->ts.kind = args->expr->ts.kind;
1629	/* Find the largest type kind. */
1630	for (a = args->next; a; a = a->next)
1631	{
1632	if (a->expr->ts.kind > f->ts.kind)
1633	f->ts.kind = a->expr->ts.kind;
1634	}
1635
1636	/* Convert all parameters to the required kind. */
1637	for (a = args; a; a = a->next)
1638	{
1639	if (a->expr->ts.kind != f->ts.kind)
1640	gfc_convert_type (a->expr, &f->ts, 2);
1641	}
1642
1643	f->value.function.name
1644	= gfc_get_string (format: name, gfc_type_letter (f->ts.type),
1645	gfc_type_abi_kind (ts: &f->ts));
1646	}
1647
1648
1649	void
1650	gfc_resolve_max (gfc_expr *f, gfc_actual_arglist *args)
1651	{
1652	gfc_resolve_minmax (name: "__max_%c%d", f, args);
1653	}
1654
1655	/* The smallest kind for which a minloc and maxloc implementation exists. */
1656
1657	#define MINMAXLOC_MIN_KIND 4
1658
1659	void
1660	gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1661	gfc_expr *mask, gfc_expr *kind, gfc_expr *back)
1662	{
1663	const char *name;
1664	int i, j, idim;
1665	int fkind;
1666	int d_num;
1667
1668	f->ts.type = BT_INTEGER;
1669
1670	/* The library versions only exist for kinds 4, 8 and 16. For smaller kinds,
1671	we do a type conversion further down. */
1672	if (kind)
1673	fkind = mpz_get_si (kind->value.integer);
1674	else
1675	fkind = gfc_default_integer_kind;
1676
1677	if (fkind < MINMAXLOC_MIN_KIND)
1678	f->ts.kind = MINMAXLOC_MIN_KIND;
1679	else
1680	f->ts.kind = fkind;
1681
1682	if (dim == NULL)
1683	{
1684	f->rank = 1;
1685	f->shape = gfc_get_shape (1);
1686	mpz_init_set_si (f->shape[0], array->rank);
1687	}
1688	else
1689	{
1690	f->rank = array->rank - 1;
1691	gfc_resolve_dim_arg (dim);
1692	if (array->shape && dim->expr_type == EXPR_CONSTANT)
1693	{
1694	idim = (int) mpz_get_si (dim->value.integer);
1695	f->shape = gfc_get_shape (f->rank);
1696	for (i = 0, j = 0; i < f->rank; i++, j++)
1697	{
1698	if (i == (idim - 1))
1699	j++;
1700	mpz_init_set (f->shape[i], array->shape[j]);
1701	}
1702	}
1703	}
1704
1705	if (mask)
1706	{
1707	if (mask->rank == 0)
1708	name = "smaxloc";
1709	else
1710	name = "mmaxloc";
1711
1712	resolve_mask_arg (mask);
1713	}
1714	else
1715	name = "maxloc";
1716
1717	if (dim)
1718	{
1719	if (array->ts.type != BT_CHARACTER || f->rank != 0)
1720	d_num = 1;
1721	else
1722	d_num = 2;
1723	}
1724	else
1725	d_num = 0;
1726
1727	f->value.function.name
1728	= gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, d_num, f->ts.kind,
1729	gfc_type_letter (array->ts.type),
1730	gfc_type_abi_kind (ts: &array->ts));
1731
1732	if (kind)
1733	fkind = mpz_get_si (kind->value.integer);
1734	else
1735	fkind = gfc_default_integer_kind;
1736
1737	if (fkind != f->ts.kind)
1738	{
1739	gfc_typespec ts;
1740	gfc_clear_ts (&ts);
1741
1742	ts.type = BT_INTEGER;
1743	ts.kind = fkind;
1744	gfc_convert_type_warn (f, &ts, 2, 0);
1745	}
1746
1747	if (back->ts.kind != gfc_logical_4_kind)
1748	{
1749	gfc_typespec ts;
1750	gfc_clear_ts (&ts);
1751	ts.type = BT_LOGICAL;
1752	ts.kind = gfc_logical_4_kind;
1753	gfc_convert_type_warn (back, &ts, 2, 0);
1754	}
1755	}
1756
1757
1758	void
1759	gfc_resolve_findloc (gfc_expr *f, gfc_expr *array, gfc_expr *value,
1760	gfc_expr *dim, gfc_expr *mask, gfc_expr *kind,
1761	gfc_expr *back)
1762	{
1763	const char *name;
1764	int i, j, idim;
1765	int fkind;
1766	int d_num;
1767
1768	/* See at the end of the function for why this is necessary. */
1769
1770	if (f->do_not_resolve_again)
1771	return;
1772
1773	f->ts.type = BT_INTEGER;
1774
1775	/* We have a single library version, which uses index_type. */
1776
1777	if (kind)
1778	fkind = mpz_get_si (kind->value.integer);
1779	else
1780	fkind = gfc_default_integer_kind;
1781
1782	f->ts.kind = gfc_index_integer_kind;
1783
1784	/* Convert value. If array is not LOGICAL and value is, we already
1785	issued an error earlier. */
1786
1787	if ((array->ts.type != value->ts.type && value->ts.type != BT_LOGICAL)
1788	|| array->ts.kind != value->ts.kind)
1789	gfc_convert_type_warn (value, &array->ts, 2, 0);
1790
1791	if (dim == NULL)
1792	{
1793	f->rank = 1;
1794	f->shape = gfc_get_shape (1);
1795	mpz_init_set_si (f->shape[0], array->rank);
1796	}
1797	else
1798	{
1799	f->rank = array->rank - 1;
1800	gfc_resolve_dim_arg (dim);
1801	if (array->shape && dim->expr_type == EXPR_CONSTANT)
1802	{
1803	idim = (int) mpz_get_si (dim->value.integer);
1804	f->shape = gfc_get_shape (f->rank);
1805	for (i = 0, j = 0; i < f->rank; i++, j++)
1806	{
1807	if (i == (idim - 1))
1808	j++;
1809	mpz_init_set (f->shape[i], array->shape[j]);
1810	}
1811	}
1812	}
1813
1814	if (mask)
1815	{
1816	if (mask->rank == 0)
1817	name = "sfindloc";
1818	else
1819	name = "mfindloc";
1820
1821	resolve_mask_arg (mask);
1822	}
1823	else
1824	name = "findloc";
1825
1826	if (dim)
1827	{
1828	if (f->rank > 0)
1829	d_num = 1;
1830	else
1831	d_num = 2;
1832	}
1833	else
1834	d_num = 0;
1835
1836	if (back->ts.kind != gfc_logical_4_kind)
1837	{
1838	gfc_typespec ts;
1839	gfc_clear_ts (&ts);
1840	ts.type = BT_LOGICAL;
1841	ts.kind = gfc_logical_4_kind;
1842	gfc_convert_type_warn (back, &ts, 2, 0);
1843	}
1844
1845	f->value.function.name
1846	= gfc_get_string (PREFIX ("%s%d_%c%d"), name, d_num,
1847	gfc_type_letter (array->ts.type, logical_equals_int: true),
1848	gfc_type_abi_kind (ts: &array->ts));
1849
1850	/* We only have a single library function, so we need to convert
1851	here. If the function is resolved from within a convert
1852	function generated on a previous round of resolution, endless
1853	recursion could occur. Guard against that here. */
1854
1855	if (f->ts.kind != fkind)
1856	{
1857	f->do_not_resolve_again = 1;
1858	gfc_typespec ts;
1859	gfc_clear_ts (&ts);
1860
1861	ts.type = BT_INTEGER;
1862	ts.kind = fkind;
1863	gfc_convert_type_warn (f, &ts, 2, 0);
1864	}
1865
1866	}
1867
1868	void
1869	gfc_resolve_maxval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1870	gfc_expr *mask)
1871	{
1872	const char *name;
1873	int i, j, idim;
1874
1875	f->ts = array->ts;
1876
1877	if (dim != NULL)
1878	{
1879	f->rank = array->rank - 1;
1880	gfc_resolve_dim_arg (dim);
1881
1882	if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
1883	{
1884	idim = (int) mpz_get_si (dim->value.integer);
1885	f->shape = gfc_get_shape (f->rank);
1886	for (i = 0, j = 0; i < f->rank; i++, j++)
1887	{
1888	if (i == (idim - 1))
1889	j++;
1890	mpz_init_set (f->shape[i], array->shape[j]);
1891	}
1892	}
1893	}
1894
1895	if (mask)
1896	{
1897	if (mask->rank == 0)
1898	name = "smaxval";
1899	else
1900	name = "mmaxval";
1901
1902	resolve_mask_arg (mask);
1903	}
1904	else
1905	name = "maxval";
1906
1907	if (array->ts.type != BT_CHARACTER)
1908	f->value.function.name
1909	= gfc_get_string (PREFIX ("%s_%c%d"), name,
1910	gfc_type_letter (array->ts.type),
1911	gfc_type_abi_kind (ts: &array->ts));
1912	else
1913	f->value.function.name
1914	= gfc_get_string (PREFIX ("%s%d_%c%d"), name, f->rank != 0,
1915	gfc_type_letter (array->ts.type),
1916	gfc_type_abi_kind (ts: &array->ts));
1917	}
1918
1919
1920	void
1921	gfc_resolve_mclock (gfc_expr *f)
1922	{
1923	f->ts.type = BT_INTEGER;
1924	f->ts.kind = 4;
1925	f->value.function.name = PREFIX ("mclock");
1926	}
1927
1928
1929	void
1930	gfc_resolve_mclock8 (gfc_expr *f)
1931	{
1932	f->ts.type = BT_INTEGER;
1933	f->ts.kind = 8;
1934	f->value.function.name = PREFIX ("mclock8");
1935	}
1936
1937
1938	void
1939	gfc_resolve_mask (gfc_expr *f, gfc_expr *i ATTRIBUTE_UNUSED,
1940	gfc_expr *kind)
1941	{
1942	f->ts.type = BT_INTEGER;
1943	f->ts.kind = kind ? mpz_get_si (kind->value.integer)
1944	: gfc_default_integer_kind;
1945
1946	if (f->value.function.isym->id == GFC_ISYM_MASKL)
1947	f->value.function.name = gfc_get_string (format: "__maskl_i%d", f->ts.kind);
1948	else
1949	f->value.function.name = gfc_get_string (format: "__maskr_i%d", f->ts.kind);
1950	}
1951
1952
1953	void
1954	gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource,
1955	gfc_expr *fsource ATTRIBUTE_UNUSED,
1956	gfc_expr *mask ATTRIBUTE_UNUSED)
1957	{
1958	if (tsource->ts.type == BT_CHARACTER && tsource->ref)
1959	gfc_resolve_substring_charlen (tsource);
1960
1961	if (fsource->ts.type == BT_CHARACTER && fsource->ref)
1962	gfc_resolve_substring_charlen (fsource);
1963
1964	if (tsource->ts.type == BT_CHARACTER)
1965	check_charlen_present (source: tsource);
1966
1967	f->ts = tsource->ts;
1968	f->value.function.name
1969	= gfc_get_string (format: "__merge_%c%d", gfc_type_letter (tsource->ts.type),
1970	gfc_type_abi_kind (ts: &tsource->ts));
1971	}
1972
1973
1974	void
1975	gfc_resolve_merge_bits (gfc_expr *f, gfc_expr *i,
1976	gfc_expr *j ATTRIBUTE_UNUSED,
1977	gfc_expr *mask ATTRIBUTE_UNUSED)
1978	{
1979	f->ts = i->ts;
1980	f->value.function.name = gfc_get_string (format: "__merge_bits_i%d", i->ts.kind);
1981	}
1982
1983
1984	void
1985	gfc_resolve_min (gfc_expr *f, gfc_actual_arglist *args)
1986	{
1987	gfc_resolve_minmax (name: "__min_%c%d", f, args);
1988	}
1989
1990
1991	void
1992	gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1993	gfc_expr *mask, gfc_expr *kind, gfc_expr *back)
1994	{
1995	const char *name;
1996	int i, j, idim;
1997	int fkind;
1998	int d_num;
1999
2000	f->ts.type = BT_INTEGER;
2001
2002	/* The library versions only exist for kinds 4, 8 and 16. For smaller kinds,
2003	we do a type conversion further down. */
2004	if (kind)
2005	fkind = mpz_get_si (kind->value.integer);
2006	else
2007	fkind = gfc_default_integer_kind;
2008
2009	if (fkind < MINMAXLOC_MIN_KIND)
2010	f->ts.kind = MINMAXLOC_MIN_KIND;
2011	else
2012	f->ts.kind = fkind;
2013
2014	if (dim == NULL)
2015	{
2016	f->rank = 1;
2017	f->shape = gfc_get_shape (1);
2018	mpz_init_set_si (f->shape[0], array->rank);
2019	}
2020	else
2021	{
2022	f->rank = array->rank - 1;
2023	gfc_resolve_dim_arg (dim);
2024	if (array->shape && dim->expr_type == EXPR_CONSTANT)
2025	{
2026	idim = (int) mpz_get_si (dim->value.integer);
2027	f->shape = gfc_get_shape (f->rank);
2028	for (i = 0, j = 0; i < f->rank; i++, j++)
2029	{
2030	if (i == (idim - 1))
2031	j++;
2032	mpz_init_set (f->shape[i], array->shape[j]);
2033	}
2034	}
2035	}
2036
2037	if (mask)
2038	{
2039	if (mask->rank == 0)
2040	name = "sminloc";
2041	else
2042	name = "mminloc";
2043
2044	resolve_mask_arg (mask);
2045	}
2046	else
2047	name = "minloc";
2048
2049	if (dim)
2050	{
2051	if (array->ts.type != BT_CHARACTER || f->rank != 0)
2052	d_num = 1;
2053	else
2054	d_num = 2;
2055	}
2056	else
2057	d_num = 0;
2058
2059	f->value.function.name
2060	= gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, d_num, f->ts.kind,
2061	gfc_type_letter (array->ts.type),
2062	gfc_type_abi_kind (ts: &array->ts));
2063
2064	if (fkind != f->ts.kind)
2065	{
2066	gfc_typespec ts;
2067	gfc_clear_ts (&ts);
2068
2069	ts.type = BT_INTEGER;
2070	ts.kind = fkind;
2071	gfc_convert_type_warn (f, &ts, 2, 0);
2072	}
2073
2074	if (back->ts.kind != gfc_logical_4_kind)
2075	{
2076	gfc_typespec ts;
2077	gfc_clear_ts (&ts);
2078	ts.type = BT_LOGICAL;
2079	ts.kind = gfc_logical_4_kind;
2080	gfc_convert_type_warn (back, &ts, 2, 0);
2081	}
2082	}
2083
2084
2085	void
2086	gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
2087	gfc_expr *mask)
2088	{
2089	const char *name;
2090	int i, j, idim;
2091
2092	f->ts = array->ts;
2093
2094	if (dim != NULL)
2095	{
2096	f->rank = array->rank - 1;
2097	gfc_resolve_dim_arg (dim);
2098
2099	if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
2100	{
2101	idim = (int) mpz_get_si (dim->value.integer);
2102	f->shape = gfc_get_shape (f->rank);
2103	for (i = 0, j = 0; i < f->rank; i++, j++)
2104	{
2105	if (i == (idim - 1))
2106	j++;
2107	mpz_init_set (f->shape[i], array->shape[j]);
2108	}
2109	}
2110	}
2111
2112	if (mask)
2113	{
2114	if (mask->rank == 0)
2115	name = "sminval";
2116	else
2117	name = "mminval";
2118
2119	resolve_mask_arg (mask);
2120	}
2121	else
2122	name = "minval";
2123
2124	if (array->ts.type != BT_CHARACTER)
2125	f->value.function.name
2126	= gfc_get_string (PREFIX ("%s_%c%d"), name,
2127	gfc_type_letter (array->ts.type),
2128	gfc_type_abi_kind (ts: &array->ts));
2129	else
2130	f->value.function.name
2131	= gfc_get_string (PREFIX ("%s%d_%c%d"), name, f->rank != 0,
2132	gfc_type_letter (array->ts.type),
2133	gfc_type_abi_kind (ts: &array->ts));
2134	}
2135
2136
2137	void
2138	gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p)
2139	{
2140	f->ts.type = a->ts.type;
2141	if (p != NULL)
2142	f->ts.kind = gfc_kind_max (a,p);
2143	else
2144	f->ts.kind = a->ts.kind;
2145
2146	if (p != NULL && a->ts.kind != p->ts.kind)
2147	{
2148	if (a->ts.kind == gfc_kind_max (a,p))
2149	gfc_convert_type (p, &a->ts, 2);
2150	else
2151	gfc_convert_type (a, &p->ts, 2);
2152	}
2153
2154	f->value.function.name
2155	= gfc_get_string (format: "__mod_%c%d", gfc_type_letter (f->ts.type),
2156	gfc_type_abi_kind (ts: &f->ts));
2157	}
2158
2159
2160	void
2161	gfc_resolve_modulo (gfc_expr *f, gfc_expr *a, gfc_expr *p)
2162	{
2163	f->ts.type = a->ts.type;
2164	if (p != NULL)
2165	f->ts.kind = gfc_kind_max (a,p);
2166	else
2167	f->ts.kind = a->ts.kind;
2168
2169	if (p != NULL && a->ts.kind != p->ts.kind)
2170	{
2171	if (a->ts.kind == gfc_kind_max (a,p))
2172	gfc_convert_type (p, &a->ts, 2);
2173	else
2174	gfc_convert_type (a, &p->ts, 2);
2175	}
2176
2177	f->value.function.name
2178	= gfc_get_string (format: "__modulo_%c%d", gfc_type_letter (f->ts.type),
2179	gfc_type_abi_kind (ts: &f->ts));
2180	}
2181
2182	void
2183	gfc_resolve_nearest (gfc_expr *f, gfc_expr *a, gfc_expr *p)
2184	{
2185	if (p->ts.kind != a->ts.kind)
2186	gfc_convert_type (p, &a->ts, 2);
2187
2188	f->ts = a->ts;
2189	f->value.function.name
2190	= gfc_get_string (format: "__nearest_%c%d", gfc_type_letter (a->ts.type),
2191	gfc_type_abi_kind (ts: &a->ts));
2192	}
2193
2194	void
2195	gfc_resolve_nint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
2196	{
2197	f->ts.type = BT_INTEGER;
2198	f->ts.kind = (kind == NULL)
2199	? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
2200	f->value.function.name
2201	= gfc_get_string (format: "__nint_%d_%d", f->ts.kind, a->ts.kind);
2202	}
2203
2204
2205	void
2206	gfc_resolve_norm2 (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
2207	{
2208	resolve_transformational (name: "norm2", f, array, dim, NULL);
2209	}
2210
2211
2212	void
2213	gfc_resolve_not (gfc_expr *f, gfc_expr *i)
2214	{
2215	f->ts = i->ts;
2216	f->value.function.name = gfc_get_string (format: "__not_%d", i->ts.kind);
2217	}
2218
2219
2220	void
2221	gfc_resolve_or (gfc_expr *f, gfc_expr *i, gfc_expr *j)
2222	{
2223	f->ts.type = i->ts.type;
2224	f->ts.kind = gfc_kind_max (i, j);
2225
2226	if (i->ts.kind != j->ts.kind)
2227	{
2228	if (i->ts.kind == gfc_kind_max (i, j))
2229	gfc_convert_type (j, &i->ts, 2);
2230	else
2231	gfc_convert_type (i, &j->ts, 2);
2232	}
2233
2234	f->value.function.name
2235	= gfc_get_string (format: "__or_%c%d", gfc_type_letter (i->ts.type),
2236	gfc_type_abi_kind (ts: &f->ts));
2237	}
2238
2239
2240	void
2241	gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
2242	gfc_expr *vector ATTRIBUTE_UNUSED)
2243	{
2244	if (array->ts.type == BT_CHARACTER && array->ref)
2245	gfc_resolve_substring_charlen (array);
2246
2247	f->ts = array->ts;
2248	f->rank = 1;
2249
2250	resolve_mask_arg (mask);
2251
2252	if (mask->rank != 0)
2253	{
2254	if (array->ts.type == BT_CHARACTER)
2255	f->value.function.name
2256	= array->ts.kind == 1 ? PREFIX ("pack_char")
2257	: gfc_get_string
2258	(PREFIX ("pack_char%d"),
2259	array->ts.kind);
2260	else
2261	f->value.function.name = PREFIX ("pack");
2262	}
2263	else
2264	{
2265	if (array->ts.type == BT_CHARACTER)
2266	f->value.function.name
2267	= array->ts.kind == 1 ? PREFIX ("pack_s_char")
2268	: gfc_get_string
2269	(PREFIX ("pack_s_char%d"),
2270	array->ts.kind);
2271	else
2272	f->value.function.name = PREFIX ("pack_s");
2273	}
2274	}
2275
2276
2277	void
2278	gfc_resolve_parity (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
2279	{
2280	resolve_transformational (name: "parity", f, array, dim, NULL);
2281	}
2282
2283
2284	void
2285	gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
2286	gfc_expr *mask)
2287	{
2288	resolve_transformational (name: "product", f, array, dim, mask);
2289	}
2290
2291
2292	void
2293	gfc_resolve_rank (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED)
2294	{
2295	f->ts.type = BT_INTEGER;
2296	f->ts.kind = gfc_default_integer_kind;
2297	f->value.function.name = gfc_get_string (format: "__rank");
2298	}
2299
2300
2301	void
2302	gfc_resolve_real (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
2303	{
2304	f->ts.type = BT_REAL;
2305
2306	if (kind != NULL)
2307	f->ts.kind = mpz_get_si (kind->value.integer);
2308	else
2309	f->ts.kind = (a->ts.type == BT_COMPLEX)
2310	? a->ts.kind : gfc_default_real_kind;
2311
2312	f->value.function.name
2313	= gfc_get_string (format: "__real_%d_%c%d", f->ts.kind,
2314	gfc_type_letter (a->ts.type),
2315	gfc_type_abi_kind (ts: &a->ts));
2316	}
2317
2318
2319	void
2320	gfc_resolve_realpart (gfc_expr *f, gfc_expr *a)
2321	{
2322	f->ts.type = BT_REAL;
2323	f->ts.kind = a->ts.kind;
2324	f->value.function.name
2325	= gfc_get_string (format: "__real_%d_%c%d", f->ts.kind,
2326	gfc_type_letter (a->ts.type),
2327	gfc_type_abi_kind (ts: &a->ts));
2328	}
2329
2330
2331	void
2332	gfc_resolve_rename (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
2333	gfc_expr *p2 ATTRIBUTE_UNUSED)
2334	{
2335	f->ts.type = BT_INTEGER;
2336	f->ts.kind = gfc_default_integer_kind;
2337	f->value.function.name = gfc_get_string (PREFIX ("rename_i%d"), f->ts.kind);
2338	}
2339
2340
2341	void
2342	gfc_resolve_repeat (gfc_expr *f, gfc_expr *string,
2343	gfc_expr *ncopies)
2344	{
2345	gfc_expr *tmp;
2346	f->ts.type = BT_CHARACTER;
2347	f->ts.kind = string->ts.kind;
2348	f->value.function.name = gfc_get_string (format: "__repeat_%d", string->ts.kind);
2349
2350	/* If possible, generate a character length. */
2351	if (f->ts.u.cl == NULL)
2352	f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2353
2354	tmp = NULL;
2355	if (string->expr_type == EXPR_CONSTANT)
2356	{
2357	tmp = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
2358	string->value.character.length);
2359	}
2360	else if (string->ts.u.cl && string->ts.u.cl->length)
2361	{
2362	tmp = gfc_copy_expr (string->ts.u.cl->length);
2363	}
2364
2365	if (tmp)
2366	f->ts.u.cl->length = gfc_multiply (tmp, gfc_copy_expr (ncopies));
2367	}
2368
2369
2370	void
2371	gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
2372	gfc_expr *pad ATTRIBUTE_UNUSED,
2373	gfc_expr *order ATTRIBUTE_UNUSED)
2374	{
2375	mpz_t rank;
2376	int kind;
2377	int i;
2378
2379	if (source->ts.type == BT_CHARACTER && source->ref)
2380	gfc_resolve_substring_charlen (source);
2381
2382	f->ts = source->ts;
2383
2384	gfc_array_size (shape, &rank);
2385	f->rank = mpz_get_si (rank);
2386	mpz_clear (rank);
2387	switch (source->ts.type)
2388	{
2389	case BT_COMPLEX:
2390	case BT_REAL:
2391	case BT_INTEGER:
2392	case BT_LOGICAL:
2393	case BT_CHARACTER:
2394	kind = source->ts.kind;
2395	break;
2396
2397	default:
2398	kind = 0;
2399	break;
2400	}
2401
2402	switch (kind)
2403	{
2404	case 4:
2405	case 8:
2406	case 10:
2407	case 16:
2408	if (source->ts.type == BT_COMPLEX || source->ts.type == BT_REAL)
2409	f->value.function.name
2410	= gfc_get_string (PREFIX ("reshape_%c%d"),
2411	gfc_type_letter (source->ts.type),
2412	gfc_type_abi_kind (ts: &source->ts));
2413	else if (source->ts.type == BT_CHARACTER)
2414	f->value.function.name = gfc_get_string (PREFIX ("reshape_char%d"),
2415	kind);
2416	else
2417	f->value.function.name
2418	= gfc_get_string (PREFIX ("reshape_%d"), source->ts.kind);
2419	break;
2420
2421	default:
2422	f->value.function.name = (source->ts.type == BT_CHARACTER
2423	? PREFIX ("reshape_char") : PREFIX ("reshape"));
2424	break;
2425	}
2426
2427	if (shape->expr_type == EXPR_ARRAY && gfc_is_constant_array_expr (shape))
2428	{
2429	gfc_constructor *c;
2430	f->shape = gfc_get_shape (f->rank);
2431	c = gfc_constructor_first (base: shape->value.constructor);
2432	for (i = 0; i < f->rank; i++)
2433	{
2434	mpz_init_set (f->shape[i], c->expr->value.integer);
2435	c = gfc_constructor_next (ctor: c);
2436	}
2437	}
2438
2439	/* Force-convert both SHAPE and ORDER to index_kind so that we don't need
2440	so many runtime variations. */
2441	if (shape->ts.kind != gfc_index_integer_kind)
2442	{
2443	gfc_typespec ts = shape->ts;
2444	ts.kind = gfc_index_integer_kind;
2445	gfc_convert_type_warn (shape, &ts, 2, 0);
2446	}
2447	if (order && order->ts.kind != gfc_index_integer_kind)
2448	gfc_convert_type_warn (order, &shape->ts, 2, 0);
2449	}
2450
2451
2452	void
2453	gfc_resolve_rrspacing (gfc_expr *f, gfc_expr *x)
2454	{
2455	f->ts = x->ts;
2456	f->value.function.name = gfc_get_string (format: "__rrspacing_%d", x->ts.kind);
2457	}
2458
2459	void
2460	gfc_resolve_fe_runtime_error (gfc_code *c)
2461	{
2462	const char *name;
2463	gfc_actual_arglist *a;
2464
2465	name = gfc_get_string (PREFIX ("runtime_error"));
2466
2467	for (a = c->ext.actual->next; a; a = a->next)
2468	a->name = "%VAL";
2469
2470	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2471	/* We set the backend_decl here because runtime_error is a
2472	variadic function and we would use the wrong calling
2473	convention otherwise. */
2474	c->resolved_sym->backend_decl = gfor_fndecl_runtime_error;
2475	}
2476
2477	void
2478	gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i ATTRIBUTE_UNUSED)
2479	{
2480	f->ts = x->ts;
2481	f->value.function.name = gfc_get_string (format: "__scale_%d", x->ts.kind);
2482	}
2483
2484
2485	void
2486	gfc_resolve_scan (gfc_expr *f, gfc_expr *string,
2487	gfc_expr *set ATTRIBUTE_UNUSED,
2488	gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
2489	{
2490	f->ts.type = BT_INTEGER;
2491	if (kind)
2492	f->ts.kind = mpz_get_si (kind->value.integer);
2493	else
2494	f->ts.kind = gfc_default_integer_kind;
2495	f->value.function.name = gfc_get_string (format: "__scan_%d", string->ts.kind);
2496	}
2497
2498
2499	void
2500	gfc_resolve_secnds (gfc_expr *t1, gfc_expr *t0)
2501	{
2502	t1->ts = t0->ts;
2503	t1->value.function.name = gfc_get_string (PREFIX ("secnds"));
2504	}
2505
2506
2507	void
2508	gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x,
2509	gfc_expr *i ATTRIBUTE_UNUSED)
2510	{
2511	f->ts = x->ts;
2512	f->value.function.name = gfc_get_string (format: "__set_exponent_%d", x->ts.kind);
2513	}
2514
2515
2516	void
2517	gfc_resolve_shape (gfc_expr *f, gfc_expr *array, gfc_expr *kind)
2518	{
2519	f->ts.type = BT_INTEGER;
2520
2521	if (kind)
2522	f->ts.kind = mpz_get_si (kind->value.integer);
2523	else
2524	f->ts.kind = gfc_default_integer_kind;
2525
2526	f->rank = 1;
2527	if (array->rank != -1)
2528	{
2529	f->shape = gfc_get_shape (1);
2530	mpz_init_set_ui (f->shape[0], array->rank);
2531	}
2532
2533	f->value.function.name = gfc_get_string (PREFIX ("shape_%d"), f->ts.kind);
2534	}
2535
2536
2537	void
2538	gfc_resolve_shift (gfc_expr *f, gfc_expr *i, gfc_expr *shift ATTRIBUTE_UNUSED)
2539	{
2540	f->ts = i->ts;
2541	if (f->value.function.isym->id == GFC_ISYM_SHIFTA)
2542	f->value.function.name = gfc_get_string (format: "shifta_i%d", f->ts.kind);
2543	else if (f->value.function.isym->id == GFC_ISYM_SHIFTL)
2544	f->value.function.name = gfc_get_string (format: "shiftl_i%d", f->ts.kind);
2545	else if (f->value.function.isym->id == GFC_ISYM_SHIFTR)
2546	f->value.function.name = gfc_get_string (format: "shiftr_i%d", f->ts.kind);
2547	else
2548	gcc_unreachable ();
2549	}
2550
2551
2552	void
2553	gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b ATTRIBUTE_UNUSED)
2554	{
2555	f->ts = a->ts;
2556	f->value.function.name
2557	= gfc_get_string (format: "__sign_%c%d", gfc_type_letter (a->ts.type),
2558	gfc_type_abi_kind (ts: &a->ts));
2559	}
2560
2561
2562	void
2563	gfc_resolve_signal (gfc_expr *f, gfc_expr *number, gfc_expr *handler)
2564	{
2565	f->ts.type = BT_INTEGER;
2566	f->ts.kind = gfc_c_int_kind;
2567
2568	/* handler can be either BT_INTEGER or BT_PROCEDURE */
2569	if (handler->ts.type == BT_INTEGER)
2570	{
2571	if (handler->ts.kind != gfc_c_int_kind)
2572	gfc_convert_type (handler, &f->ts, 2);
2573	f->value.function.name = gfc_get_string (PREFIX ("signal_func_int"));
2574	}
2575	else
2576	f->value.function.name = gfc_get_string (PREFIX ("signal_func"));
2577
2578	if (number->ts.kind != gfc_c_int_kind)
2579	gfc_convert_type (number, &f->ts, 2);
2580	}
2581
2582
2583	void
2584	gfc_resolve_sin (gfc_expr *f, gfc_expr *x)
2585	{
2586	f->ts = x->ts;
2587	f->value.function.name
2588	= gfc_get_string (format: "__sin_%c%d", gfc_type_letter (x->ts.type),
2589	gfc_type_abi_kind (ts: &x->ts));
2590	}
2591
2592
2593	void
2594	gfc_resolve_sinh (gfc_expr *f, gfc_expr *x)
2595	{
2596	f->ts = x->ts;
2597	f->value.function.name
2598	= gfc_get_string (format: "__sinh_%c%d", gfc_type_letter (x->ts.type),
2599	gfc_type_abi_kind (ts: &x->ts));
2600	}
2601
2602
2603	void
2604	gfc_resolve_size (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2605	gfc_expr *dim ATTRIBUTE_UNUSED, gfc_expr *kind)
2606	{
2607	f->ts.type = BT_INTEGER;
2608	if (kind)
2609	f->ts.kind = mpz_get_si (kind->value.integer);
2610	else
2611	f->ts.kind = gfc_default_integer_kind;
2612	}
2613
2614
2615	void
2616	gfc_resolve_stride (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2617	gfc_expr *dim ATTRIBUTE_UNUSED)
2618	{
2619	f->ts.type = BT_INTEGER;
2620	f->ts.kind = gfc_index_integer_kind;
2621	}
2622
2623
2624	void
2625	gfc_resolve_spacing (gfc_expr *f, gfc_expr *x)
2626	{
2627	f->ts = x->ts;
2628	f->value.function.name = gfc_get_string (format: "__spacing_%d", x->ts.kind);
2629	}
2630
2631
2632	void
2633	gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim,
2634	gfc_expr *ncopies)
2635	{
2636	if (source->ts.type == BT_CHARACTER && source->ref)
2637	gfc_resolve_substring_charlen (source);
2638
2639	if (source->ts.type == BT_CHARACTER)
2640	check_charlen_present (source);
2641
2642	f->ts = source->ts;
2643	f->rank = source->rank + 1;
2644	if (source->rank == 0)
2645	{
2646	if (source->ts.type == BT_CHARACTER)
2647	f->value.function.name
2648	= source->ts.kind == 1 ? PREFIX ("spread_char_scalar")
2649	: gfc_get_string
2650	(PREFIX ("spread_char%d_scalar"),
2651	source->ts.kind);
2652	else
2653	f->value.function.name = PREFIX ("spread_scalar");
2654	}
2655	else
2656	{
2657	if (source->ts.type == BT_CHARACTER)
2658	f->value.function.name
2659	= source->ts.kind == 1 ? PREFIX ("spread_char")
2660	: gfc_get_string
2661	(PREFIX ("spread_char%d"),
2662	source->ts.kind);
2663	else
2664	f->value.function.name = PREFIX ("spread");
2665	}
2666
2667	if (dim && gfc_is_constant_expr (dim)
2668	&& ncopies && gfc_is_constant_expr (ncopies) && source->shape[0])
2669	{
2670	int i, idim;
2671	idim = mpz_get_ui (gmp_z: dim->value.integer);
2672	f->shape = gfc_get_shape (f->rank);
2673	for (i = 0; i < (idim - 1); i++)
2674	mpz_init_set (f->shape[i], source->shape[i]);
2675
2676	mpz_init_set (f->shape[idim - 1], ncopies->value.integer);
2677
2678	for (i = idim; i < f->rank ; i++)
2679	mpz_init_set (f->shape[i], source->shape[i-1]);
2680	}
2681
2682
2683	gfc_resolve_dim_arg (dim);
2684	gfc_resolve_index (ncopies, 1);
2685	}
2686
2687
2688	void
2689	gfc_resolve_sqrt (gfc_expr *f, gfc_expr *x)
2690	{
2691	f->ts = x->ts;
2692	f->value.function.name
2693	= gfc_get_string (format: "__sqrt_%c%d", gfc_type_letter (x->ts.type),
2694	gfc_type_abi_kind (ts: &x->ts));
2695	}
2696
2697
2698	/* Resolve the g77 compatibility function STAT AND FSTAT. */
2699
2700	void
2701	gfc_resolve_stat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2702	gfc_expr *a ATTRIBUTE_UNUSED)
2703	{
2704	f->ts.type = BT_INTEGER;
2705	f->ts.kind = gfc_default_integer_kind;
2706	f->value.function.name = gfc_get_string (PREFIX ("stat_i%d"), f->ts.kind);
2707	}
2708
2709
2710	void
2711	gfc_resolve_lstat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2712	gfc_expr *a ATTRIBUTE_UNUSED)
2713	{
2714	f->ts.type = BT_INTEGER;
2715	f->ts.kind = gfc_default_integer_kind;
2716	f->value.function.name = gfc_get_string (PREFIX ("lstat_i%d"), f->ts.kind);
2717	}
2718
2719
2720	void
2721	gfc_resolve_fstat (gfc_expr *f, gfc_expr *n, gfc_expr *a ATTRIBUTE_UNUSED)
2722	{
2723	f->ts.type = BT_INTEGER;
2724	f->ts.kind = gfc_default_integer_kind;
2725	if (n->ts.kind != f->ts.kind)
2726	gfc_convert_type (n, &f->ts, 2);
2727
2728	f->value.function.name = gfc_get_string (PREFIX ("fstat_i%d"), f->ts.kind);
2729	}
2730
2731
2732	void
2733	gfc_resolve_fgetc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2734	{
2735	gfc_typespec ts;
2736	gfc_clear_ts (&ts);
2737
2738	f->ts.type = BT_INTEGER;
2739	f->ts.kind = gfc_c_int_kind;
2740	if (u->ts.kind != gfc_c_int_kind)
2741	{
2742	ts.type = BT_INTEGER;
2743	ts.kind = gfc_c_int_kind;
2744	ts.u.derived = NULL;
2745	ts.u.cl = NULL;
2746	gfc_convert_type (u, &ts, 2);
2747	}
2748
2749	f->value.function.name = gfc_get_string (PREFIX ("fgetc"));
2750	}
2751
2752
2753	void
2754	gfc_resolve_fget (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2755	{
2756	f->ts.type = BT_INTEGER;
2757	f->ts.kind = gfc_c_int_kind;
2758	f->value.function.name = gfc_get_string (PREFIX ("fget"));
2759	}
2760
2761
2762	void
2763	gfc_resolve_fputc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2764	{
2765	gfc_typespec ts;
2766	gfc_clear_ts (&ts);
2767
2768	f->ts.type = BT_INTEGER;
2769	f->ts.kind = gfc_c_int_kind;
2770	if (u->ts.kind != gfc_c_int_kind)
2771	{
2772	ts.type = BT_INTEGER;
2773	ts.kind = gfc_c_int_kind;
2774	ts.u.derived = NULL;
2775	ts.u.cl = NULL;
2776	gfc_convert_type (u, &ts, 2);
2777	}
2778
2779	f->value.function.name = gfc_get_string (PREFIX ("fputc"));
2780	}
2781
2782
2783	void
2784	gfc_resolve_fput (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2785	{
2786	f->ts.type = BT_INTEGER;
2787	f->ts.kind = gfc_c_int_kind;
2788	f->value.function.name = gfc_get_string (PREFIX ("fput"));
2789	}
2790
2791
2792	void
2793	gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
2794	{
2795	gfc_typespec ts;
2796	gfc_clear_ts (&ts);
2797
2798	f->ts.type = BT_INTEGER;
2799	f->ts.kind = gfc_intio_kind;
2800	if (u->ts.kind != gfc_c_int_kind)
2801	{
2802	ts.type = BT_INTEGER;
2803	ts.kind = gfc_c_int_kind;
2804	ts.u.derived = NULL;
2805	ts.u.cl = NULL;
2806	gfc_convert_type (u, &ts, 2);
2807	}
2808
2809	f->value.function.name = gfc_get_string (PREFIX ("ftell"));
2810	}
2811
2812
2813	void
2814	gfc_resolve_storage_size (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
2815	gfc_expr *kind)
2816	{
2817	f->ts.type = BT_INTEGER;
2818	if (kind)
2819	f->ts.kind = mpz_get_si (kind->value.integer);
2820	else
2821	f->ts.kind = gfc_default_integer_kind;
2822	}
2823
2824
2825	void
2826	gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
2827	{
2828	resolve_transformational (name: "sum", f, array, dim, mask);
2829	}
2830
2831
2832	void
2833	gfc_resolve_symlnk (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
2834	gfc_expr *p2 ATTRIBUTE_UNUSED)
2835	{
2836	f->ts.type = BT_INTEGER;
2837	f->ts.kind = gfc_default_integer_kind;
2838	f->value.function.name = gfc_get_string (PREFIX ("symlnk_i%d"), f->ts.kind);
2839	}
2840
2841
2842	/* Resolve the g77 compatibility function SYSTEM. */
2843
2844	void
2845	gfc_resolve_system (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
2846	{
2847	f->ts.type = BT_INTEGER;
2848	f->ts.kind = 4;
2849	f->value.function.name = gfc_get_string (PREFIX ("system"));
2850	}
2851
2852
2853	void
2854	gfc_resolve_tan (gfc_expr *f, gfc_expr *x)
2855	{
2856	f->ts = x->ts;
2857	f->value.function.name
2858	= gfc_get_string (format: "__tan_%c%d", gfc_type_letter (x->ts.type),
2859	gfc_type_abi_kind (ts: &x->ts));
2860	}
2861
2862
2863	void
2864	gfc_resolve_tanh (gfc_expr *f, gfc_expr *x)
2865	{
2866	f->ts = x->ts;
2867	f->value.function.name
2868	= gfc_get_string (format: "__tanh_%c%d", gfc_type_letter (x->ts.type),
2869	gfc_type_abi_kind (ts: &x->ts));
2870	}
2871
2872
2873	/* Resolve failed_images (team, kind). */
2874
2875	void
2876	gfc_resolve_failed_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED,
2877	gfc_expr *kind)
2878	{
2879	static char failed_images[] = "_gfortran_caf_failed_images";
2880	f->rank = 1;
2881	f->ts.type = BT_INTEGER;
2882	if (kind == NULL)
2883	f->ts.kind = gfc_default_integer_kind;
2884	else
2885	gfc_extract_int (kind, &f->ts.kind);
2886	f->value.function.name = failed_images;
2887	}
2888
2889
2890	/* Resolve image_status (image, team). */
2891
2892	void
2893	gfc_resolve_image_status (gfc_expr *f, gfc_expr *image ATTRIBUTE_UNUSED,
2894	gfc_expr *team ATTRIBUTE_UNUSED)
2895	{
2896	static char image_status[] = "_gfortran_caf_image_status";
2897	f->ts.type = BT_INTEGER;
2898	f->ts.kind = gfc_default_integer_kind;
2899	f->value.function.name = image_status;
2900	}
2901
2902
2903	/* Resolve get_team (). */
2904
2905	void
2906	gfc_resolve_get_team (gfc_expr *f, gfc_expr *level ATTRIBUTE_UNUSED)
2907	{
2908	static char get_team[] = "_gfortran_caf_get_team";
2909	f->rank = 0;
2910	f->ts.type = BT_INTEGER;
2911	f->ts.kind = gfc_default_integer_kind;
2912	f->value.function.name = get_team;
2913	}
2914
2915
2916	/* Resolve image_index (...). */
2917
2918	void
2919	gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2920	gfc_expr *sub ATTRIBUTE_UNUSED)
2921	{
2922	static char image_index[] = "__image_index";
2923	f->ts.type = BT_INTEGER;
2924	f->ts.kind = gfc_default_integer_kind;
2925	f->value.function.name = image_index;
2926	}
2927
2928
2929	/* Resolve stopped_images (team, kind). */
2930
2931	void
2932	gfc_resolve_stopped_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED,
2933	gfc_expr *kind)
2934	{
2935	static char stopped_images[] = "_gfortran_caf_stopped_images";
2936	f->rank = 1;
2937	f->ts.type = BT_INTEGER;
2938	if (kind == NULL)
2939	f->ts.kind = gfc_default_integer_kind;
2940	else
2941	gfc_extract_int (kind, &f->ts.kind);
2942	f->value.function.name = stopped_images;
2943	}
2944
2945
2946	/* Resolve team_number (team). */
2947
2948	void
2949	gfc_resolve_team_number (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED)
2950	{
2951	static char team_number[] = "_gfortran_caf_team_number";
2952	f->rank = 0;
2953	f->ts.type = BT_INTEGER;
2954	f->ts.kind = gfc_default_integer_kind;
2955	f->value.function.name = team_number;
2956	}
2957
2958
2959	void
2960	gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
2961	gfc_expr *distance ATTRIBUTE_UNUSED)
2962	{
2963	static char this_image[] = "__this_image";
2964	if (array && gfc_is_coarray (array))
2965	resolve_bound (f, array, dim, NULL, name: "__this_image", coarray: true);
2966	else
2967	{
2968	f->ts.type = BT_INTEGER;
2969	f->ts.kind = gfc_default_integer_kind;
2970	f->value.function.name = this_image;
2971	}
2972	}
2973
2974
2975	void
2976	gfc_resolve_time (gfc_expr *f)
2977	{
2978	f->ts.type = BT_INTEGER;
2979	f->ts.kind = 4;
2980	f->value.function.name = gfc_get_string (PREFIX ("time_func"));
2981	}
2982
2983
2984	void
2985	gfc_resolve_time8 (gfc_expr *f)
2986	{
2987	f->ts.type = BT_INTEGER;
2988	f->ts.kind = 8;
2989	f->value.function.name = gfc_get_string (PREFIX ("time8_func"));
2990	}
2991
2992
2993	void
2994	gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
2995	gfc_expr *mold, gfc_expr *size)
2996	{
2997	/* TODO: Make this do something meaningful. */
2998	static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
2999
3000	if (mold->ts.type == BT_CHARACTER
3001	&& !mold->ts.u.cl->length
3002	&& gfc_is_constant_expr (mold))
3003	{
3004	int len;
3005	if (mold->expr_type == EXPR_CONSTANT)
3006	{
3007	len = mold->value.character.length;
3008	mold->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
3009	NULL, len);
3010	}
3011	else
3012	{
3013	gfc_constructor *c = gfc_constructor_first (base: mold->value.constructor);
3014	len = c->expr->value.character.length;
3015	mold->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
3016	NULL, len);
3017	}
3018	}
3019
3020	f->ts = mold->ts;
3021
3022	if (size == NULL && mold->rank == 0)
3023	{
3024	f->rank = 0;
3025	f->value.function.name = transfer0;
3026	}
3027	else
3028	{
3029	f->rank = 1;
3030	f->value.function.name = transfer1;
3031	if (size && gfc_is_constant_expr (size))
3032	{
3033	f->shape = gfc_get_shape (1);
3034	mpz_init_set (f->shape[0], size->value.integer);
3035	}
3036	}
3037	}
3038
3039
3040	void
3041	gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
3042	{
3043
3044	if (matrix->ts.type == BT_CHARACTER && matrix->ref)
3045	gfc_resolve_substring_charlen (matrix);
3046
3047	f->ts = matrix->ts;
3048	f->rank = 2;
3049	if (matrix->shape)
3050	{
3051	f->shape = gfc_get_shape (2);
3052	mpz_init_set (f->shape[0], matrix->shape[1]);
3053	mpz_init_set (f->shape[1], matrix->shape[0]);
3054	}
3055
3056	switch (matrix->ts.kind)
3057	{
3058	case 4:
3059	case 8:
3060	case 10:
3061	case 16:
3062	switch (matrix->ts.type)
3063	{
3064	case BT_REAL:
3065	case BT_COMPLEX:
3066	f->value.function.name
3067	= gfc_get_string (PREFIX ("transpose_%c%d"),
3068	gfc_type_letter (matrix->ts.type),
3069	gfc_type_abi_kind (ts: &matrix->ts));
3070	break;
3071
3072	case BT_INTEGER:
3073	case BT_LOGICAL:
3074	/* Use the integer routines for real and logical cases. This
3075	assumes they all have the same alignment requirements. */
3076	f->value.function.name
3077	= gfc_get_string (PREFIX ("transpose_i%d"), matrix->ts.kind);
3078	break;
3079
3080	default:
3081	if (matrix->ts.type == BT_CHARACTER && matrix->ts.kind == 4)
3082	f->value.function.name = PREFIX ("transpose_char4");
3083	else
3084	f->value.function.name = PREFIX ("transpose");
3085	break;
3086	}
3087	break;
3088
3089	default:
3090	f->value.function.name = (matrix->ts.type == BT_CHARACTER
3091	? PREFIX ("transpose_char")
3092	: PREFIX ("transpose"));
3093	break;
3094	}
3095	}
3096
3097
3098	void
3099	gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
3100	{
3101	f->ts.type = BT_CHARACTER;
3102	f->ts.kind = string->ts.kind;
3103	f->value.function.name = gfc_get_string (format: "__trim_%d", string->ts.kind);
3104	}
3105
3106
3107	/* Resolve the degree trigonometric functions. This amounts to setting
3108	the function return type-spec from its argument and building a
3109	library function names of the form _gfortran_sind_r4. */
3110
3111	void
3112	gfc_resolve_trigd (gfc_expr *f, gfc_expr *x)
3113	{
3114	f->ts = x->ts;
3115	f->value.function.name
3116	= gfc_get_string (PREFIX ("%s_%c%d"), f->value.function.isym->name,
3117	gfc_type_letter (x->ts.type),
3118	gfc_type_abi_kind (ts: &x->ts));
3119	}
3120
3121
3122	void
3123	gfc_resolve_trigd2 (gfc_expr *f, gfc_expr *y, gfc_expr *x)
3124	{
3125	f->ts = y->ts;
3126	f->value.function.name
3127	= gfc_get_string (PREFIX ("%s_%d"), f->value.function.isym->name,
3128	x->ts.kind);
3129	}
3130
3131
3132	void
3133	gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3134	{
3135	resolve_bound (f, array, dim, kind, name: "__ubound", coarray: false);
3136	}
3137
3138
3139	void
3140	gfc_resolve_ucobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3141	{
3142	resolve_bound (f, array, dim, kind, name: "__ucobound", coarray: true);
3143	}
3144
3145
3146	/* Resolve the g77 compatibility function UMASK. */
3147
3148	void
3149	gfc_resolve_umask (gfc_expr *f, gfc_expr *n)
3150	{
3151	f->ts.type = BT_INTEGER;
3152	f->ts.kind = n->ts.kind;
3153	f->value.function.name = gfc_get_string (PREFIX ("umask_i%d"), n->ts.kind);
3154	}
3155
3156
3157	/* Resolve the g77 compatibility function UNLINK. */
3158
3159	void
3160	gfc_resolve_unlink (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
3161	{
3162	f->ts.type = BT_INTEGER;
3163	f->ts.kind = 4;
3164	f->value.function.name = gfc_get_string (PREFIX ("unlink"));
3165	}
3166
3167
3168	void
3169	gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit)
3170	{
3171	gfc_typespec ts;
3172	gfc_clear_ts (&ts);
3173
3174	f->ts.type = BT_CHARACTER;
3175	f->ts.kind = gfc_default_character_kind;
3176
3177	if (unit->ts.kind != gfc_c_int_kind)
3178	{
3179	ts.type = BT_INTEGER;
3180	ts.kind = gfc_c_int_kind;
3181	ts.u.derived = NULL;
3182	ts.u.cl = NULL;
3183	gfc_convert_type (unit, &ts, 2);
3184	}
3185
3186	f->value.function.name = gfc_get_string (PREFIX ("ttynam"));
3187	}
3188
3189
3190	void
3191	gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
3192	gfc_expr *field ATTRIBUTE_UNUSED)
3193	{
3194	if (vector->ts.type == BT_CHARACTER && vector->ref)
3195	gfc_resolve_substring_charlen (vector);
3196
3197	f->ts = vector->ts;
3198	f->rank = mask->rank;
3199	resolve_mask_arg (mask);
3200
3201	if (vector->ts.type == BT_CHARACTER)
3202	{
3203	if (vector->ts.kind == 1)
3204	f->value.function.name
3205	= gfc_get_string (PREFIX ("unpack%d_char"), field->rank > 0 ? 1 : 0);
3206	else
3207	f->value.function.name
3208	= gfc_get_string (PREFIX ("unpack%d_char%d"),
3209	field->rank > 0 ? 1 : 0, vector->ts.kind);
3210	}
3211	else
3212	f->value.function.name
3213	= gfc_get_string (PREFIX ("unpack%d"), field->rank > 0 ? 1 : 0);
3214	}
3215
3216
3217	void
3218	gfc_resolve_verify (gfc_expr *f, gfc_expr *string,
3219	gfc_expr *set ATTRIBUTE_UNUSED,
3220	gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
3221	{
3222	f->ts.type = BT_INTEGER;
3223	if (kind)
3224	f->ts.kind = mpz_get_si (kind->value.integer);
3225	else
3226	f->ts.kind = gfc_default_integer_kind;
3227	f->value.function.name = gfc_get_string (format: "__verify_%d", string->ts.kind);
3228	}
3229
3230
3231	void
3232	gfc_resolve_xor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
3233	{
3234	f->ts.type = i->ts.type;
3235	f->ts.kind = gfc_kind_max (i, j);
3236
3237	if (i->ts.kind != j->ts.kind)
3238	{
3239	if (i->ts.kind == gfc_kind_max (i, j))
3240	gfc_convert_type (j, &i->ts, 2);
3241	else
3242	gfc_convert_type (i, &j->ts, 2);
3243	}
3244
3245	f->value.function.name
3246	= gfc_get_string (format: "__xor_%c%d", gfc_type_letter (i->ts.type),
3247	gfc_type_abi_kind (ts: &f->ts));
3248	}
3249
3250
3251	/* Intrinsic subroutine resolution. */
3252
3253	void
3254	gfc_resolve_alarm_sub (gfc_code *c)
3255	{
3256	const char *name;
3257	gfc_expr *seconds, *handler;
3258	gfc_typespec ts;
3259	gfc_clear_ts (&ts);
3260
3261	seconds = c->ext.actual->expr;
3262	handler = c->ext.actual->next->expr;
3263	ts.type = BT_INTEGER;
3264	ts.kind = gfc_c_int_kind;
3265
3266	/* handler can be either BT_INTEGER or BT_PROCEDURE.
3267	In all cases, the status argument is of default integer kind
3268	(enforced in check.cc) so that the function suffix is fixed. */
3269	if (handler->ts.type == BT_INTEGER)
3270	{
3271	if (handler->ts.kind != gfc_c_int_kind)
3272	gfc_convert_type (handler, &ts, 2);
3273	name = gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
3274	gfc_default_integer_kind);
3275	}
3276	else
3277	name = gfc_get_string (PREFIX ("alarm_sub_i%d"),
3278	gfc_default_integer_kind);
3279
3280	if (seconds->ts.kind != gfc_c_int_kind)
3281	gfc_convert_type (seconds, &ts, 2);
3282
3283	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3284	}
3285
3286	void
3287	gfc_resolve_cpu_time (gfc_code *c)
3288	{
3289	const char *name;
3290	name = gfc_get_string (PREFIX ("cpu_time_%d"), c->ext.actual->expr->ts.kind);
3291	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3292	}
3293
3294
3295	/* Create a formal arglist based on an actual one and set the INTENTs given. */
3296
3297	static gfc_formal_arglist*
3298	create_formal_for_intents (gfc_actual_arglist* actual, const sym_intent* ints)
3299	{
3300	gfc_formal_arglist* head;
3301	gfc_formal_arglist* tail;
3302	int i;
3303
3304	if (!actual)
3305	return NULL;
3306
3307	head = tail = gfc_get_formal_arglist ();
3308	for (i = 0; actual; actual = actual->next, tail = tail->next, ++i)
3309	{
3310	gfc_symbol* sym;
3311
3312	sym = gfc_new_symbol ("dummyarg", NULL);
3313	sym->ts = actual->expr->ts;
3314
3315	sym->attr.intent = ints[i];
3316	tail->sym = sym;
3317
3318	if (actual->next)
3319	tail->next = gfc_get_formal_arglist ();
3320	}
3321
3322	return head;
3323	}
3324
3325
3326	void
3327	gfc_resolve_atomic_def (gfc_code *c)
3328	{
3329	const char *name = "atomic_define";
3330	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3331	}
3332
3333
3334	void
3335	gfc_resolve_atomic_ref (gfc_code *c)
3336	{
3337	const char *name = "atomic_ref";
3338	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3339	}
3340
3341	void
3342	gfc_resolve_event_query (gfc_code *c)
3343	{
3344	const char *name = "event_query";
3345	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3346	}
3347
3348	void
3349	gfc_resolve_mvbits (gfc_code *c)
3350	{
3351	static const sym_intent INTENTS[] = {INTENT_IN, INTENT_IN, INTENT_IN,
3352	INTENT_INOUT, INTENT_IN};
3353	const char *name;
3354
3355	/* TO and FROM are guaranteed to have the same kind parameter. */
3356	name = gfc_get_string (PREFIX ("mvbits_i%d"),
3357	c->ext.actual->expr->ts.kind);
3358	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3359	/* Mark as elemental subroutine as this does not happen automatically. */
3360	c->resolved_sym->attr.elemental = 1;
3361
3362	/* Create a dummy formal arglist so the INTENTs are known later for purpose
3363	of creating temporaries. */
3364	c->resolved_sym->formal = create_formal_for_intents (actual: c->ext.actual, ints: INTENTS);
3365	}
3366
3367
3368	/* Set up the call to RANDOM_INIT. */
3369
3370	void
3371	gfc_resolve_random_init (gfc_code *c)
3372	{
3373	const char *name;
3374	name = gfc_get_string (PREFIX ("random_init"));
3375	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3376	}
3377
3378
3379	void
3380	gfc_resolve_random_number (gfc_code *c)
3381	{
3382	const char *name;
3383	int kind;
3384
3385	kind = gfc_type_abi_kind (ts: &c->ext.actual->expr->ts);
3386	if (c->ext.actual->expr->rank == 0)
3387	name = gfc_get_string (PREFIX ("random_r%d"), kind);
3388	else
3389	name = gfc_get_string (PREFIX ("arandom_r%d"), kind);
3390
3391	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3392	}
3393
3394
3395	void
3396	gfc_resolve_random_seed (gfc_code *c)
3397	{
3398	const char *name;
3399
3400	name = gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind);
3401	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3402	}
3403
3404
3405	void
3406	gfc_resolve_rename_sub (gfc_code *c)
3407	{
3408	const char *name;
3409	int kind;
3410
3411	/* Find the type of status. If not present use default integer kind. */
3412	if (c->ext.actual->next->next->expr != NULL)
3413	kind = c->ext.actual->next->next->expr->ts.kind;
3414	else
3415	kind = gfc_default_integer_kind;
3416
3417	name = gfc_get_string (PREFIX ("rename_i%d_sub"), kind);
3418	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3419	}
3420
3421
3422	void
3423	gfc_resolve_link_sub (gfc_code *c)
3424	{
3425	const char *name;
3426	int kind;
3427
3428	if (c->ext.actual->next->next->expr != NULL)
3429	kind = c->ext.actual->next->next->expr->ts.kind;
3430	else
3431	kind = gfc_default_integer_kind;
3432
3433	name = gfc_get_string (PREFIX ("link_i%d_sub"), kind);
3434	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3435	}
3436
3437
3438	void
3439	gfc_resolve_symlnk_sub (gfc_code *c)
3440	{
3441	const char *name;
3442	int kind;
3443
3444	if (c->ext.actual->next->next->expr != NULL)
3445	kind = c->ext.actual->next->next->expr->ts.kind;
3446	else
3447	kind = gfc_default_integer_kind;
3448
3449	name = gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind);
3450	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3451	}
3452
3453
3454	/* G77 compatibility subroutines dtime() and etime(). */
3455
3456	void
3457	gfc_resolve_dtime_sub (gfc_code *c)
3458	{
3459	const char *name;
3460	name = gfc_get_string (PREFIX ("dtime_sub"));
3461	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3462	}
3463
3464	void
3465	gfc_resolve_etime_sub (gfc_code *c)
3466	{
3467	const char *name;
3468	name = gfc_get_string (PREFIX ("etime_sub"));
3469	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3470	}
3471
3472
3473	/* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
3474
3475	void
3476	gfc_resolve_itime (gfc_code *c)
3477	{
3478	c->resolved_sym
3479	= gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
3480	gfc_default_integer_kind));
3481	}
3482
3483	void
3484	gfc_resolve_idate (gfc_code *c)
3485	{
3486	c->resolved_sym
3487	= gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
3488	gfc_default_integer_kind));
3489	}
3490
3491	void
3492	gfc_resolve_ltime (gfc_code *c)
3493	{
3494	c->resolved_sym
3495	= gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
3496	gfc_default_integer_kind));
3497	}
3498
3499	void
3500	gfc_resolve_gmtime (gfc_code *c)
3501	{
3502	c->resolved_sym
3503	= gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
3504	gfc_default_integer_kind));
3505	}
3506
3507
3508	/* G77 compatibility subroutine second(). */
3509
3510	void
3511	gfc_resolve_second_sub (gfc_code *c)
3512	{
3513	const char *name;
3514	name = gfc_get_string (PREFIX ("second_sub"));
3515	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3516	}
3517
3518
3519	void
3520	gfc_resolve_sleep_sub (gfc_code *c)
3521	{
3522	const char *name;
3523	int kind;
3524
3525	if (c->ext.actual->expr != NULL)
3526	kind = c->ext.actual->expr->ts.kind;
3527	else
3528	kind = gfc_default_integer_kind;
3529
3530	name = gfc_get_string (PREFIX ("sleep_i%d_sub"), kind);
3531	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3532	}
3533
3534
3535	/* G77 compatibility function srand(). */
3536
3537	void
3538	gfc_resolve_srand (gfc_code *c)
3539	{
3540	const char *name;
3541	name = gfc_get_string (PREFIX ("srand"));
3542	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3543	}
3544
3545
3546	/* Resolve the getarg intrinsic subroutine. */
3547
3548	void
3549	gfc_resolve_getarg (gfc_code *c)
3550	{
3551	const char *name;
3552
3553	if (c->ext.actual->expr->ts.kind != gfc_default_integer_kind)
3554	{
3555	gfc_typespec ts;
3556	gfc_clear_ts (&ts);
3557
3558	ts.type = BT_INTEGER;
3559	ts.kind = gfc_default_integer_kind;
3560
3561	gfc_convert_type (c->ext.actual->expr, &ts, 2);
3562	}
3563
3564	name = gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind);
3565	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3566	}
3567
3568
3569	/* Resolve the getcwd intrinsic subroutine. */
3570
3571	void
3572	gfc_resolve_getcwd_sub (gfc_code *c)
3573	{
3574	const char *name;
3575	int kind;
3576
3577	if (c->ext.actual->next->expr != NULL)
3578	kind = c->ext.actual->next->expr->ts.kind;
3579	else
3580	kind = gfc_default_integer_kind;
3581
3582	name = gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind);
3583	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3584	}
3585
3586
3587	/* Resolve the get_command intrinsic subroutine. */
3588
3589	void
3590	gfc_resolve_get_command (gfc_code *c)
3591	{
3592	const char *name;
3593	int kind;
3594	kind = gfc_default_integer_kind;
3595	name = gfc_get_string (PREFIX ("get_command_i%d"), kind);
3596	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3597	}
3598
3599
3600	/* Resolve the get_command_argument intrinsic subroutine. */
3601
3602	void
3603	gfc_resolve_get_command_argument (gfc_code *c)
3604	{
3605	const char *name;
3606	int kind;
3607	kind = gfc_default_integer_kind;
3608	name = gfc_get_string (PREFIX ("get_command_argument_i%d"), kind);
3609	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3610	}
3611
3612
3613	/* Resolve the get_environment_variable intrinsic subroutine. */
3614
3615	void
3616	gfc_resolve_get_environment_variable (gfc_code *code)
3617	{
3618	const char *name;
3619	int kind;
3620	kind = gfc_default_integer_kind;
3621	name = gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind);
3622	code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3623	}
3624
3625
3626	void
3627	gfc_resolve_signal_sub (gfc_code *c)
3628	{
3629	const char *name;
3630	gfc_expr *number, *handler, *status;
3631	gfc_typespec ts;
3632	gfc_clear_ts (&ts);
3633
3634	number = c->ext.actual->expr;
3635	handler = c->ext.actual->next->expr;
3636	status = c->ext.actual->next->next->expr;
3637	ts.type = BT_INTEGER;
3638	ts.kind = gfc_c_int_kind;
3639
3640	/* handler can be either BT_INTEGER or BT_PROCEDURE */
3641	if (handler->ts.type == BT_INTEGER)
3642	{
3643	if (handler->ts.kind != gfc_c_int_kind)
3644	gfc_convert_type (handler, &ts, 2);
3645	name = gfc_get_string (PREFIX ("signal_sub_int"));
3646	}
3647	else
3648	name = gfc_get_string (PREFIX ("signal_sub"));
3649
3650	if (number->ts.kind != gfc_c_int_kind)
3651	gfc_convert_type (number, &ts, 2);
3652	if (status != NULL && status->ts.kind != gfc_c_int_kind)
3653	gfc_convert_type (status, &ts, 2);
3654
3655	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3656	}
3657
3658
3659	/* Resolve the SYSTEM intrinsic subroutine. */
3660
3661	void
3662	gfc_resolve_system_sub (gfc_code *c)
3663	{
3664	const char *name;
3665	name = gfc_get_string (PREFIX ("system_sub"));
3666	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3667	}
3668
3669
3670	/* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
3671
3672	void
3673	gfc_resolve_system_clock (gfc_code *c)
3674	{
3675	const char *name;
3676	int kind;
3677	gfc_expr *count = c->ext.actual->expr;
3678	gfc_expr *count_max = c->ext.actual->next->next->expr;
3679
3680	/* The INTEGER(8) version has higher precision, it is used if both COUNT
3681	and COUNT_MAX can hold 64-bit values, or are absent. */
3682	if ((!count || count->ts.kind >= 8)
3683	&& (!count_max || count_max->ts.kind >= 8))
3684	kind = 8;
3685	else
3686	kind = gfc_default_integer_kind;
3687
3688	name = gfc_get_string (PREFIX ("system_clock_%d"), kind);
3689	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3690	}
3691
3692
3693	/* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine. */
3694	void
3695	gfc_resolve_execute_command_line (gfc_code *c)
3696	{
3697	const char *name;
3698	name = gfc_get_string (PREFIX ("execute_command_line_i%d"),
3699	gfc_default_integer_kind);
3700	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3701	}
3702
3703
3704	/* Resolve the EXIT intrinsic subroutine. */
3705
3706	void
3707	gfc_resolve_exit (gfc_code *c)
3708	{
3709	const char *name;
3710	gfc_typespec ts;
3711	gfc_expr *n;
3712	gfc_clear_ts (&ts);
3713
3714	/* The STATUS argument has to be of default kind. If it is not,
3715	we convert it. */
3716	ts.type = BT_INTEGER;
3717	ts.kind = gfc_default_integer_kind;
3718	n = c->ext.actual->expr;
3719	if (n != NULL && n->ts.kind != ts.kind)
3720	gfc_convert_type (n, &ts, 2);
3721
3722	name = gfc_get_string (PREFIX ("exit_i%d"), ts.kind);
3723	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3724	}
3725
3726
3727	/* Resolve the FLUSH intrinsic subroutine. */
3728
3729	void
3730	gfc_resolve_flush (gfc_code *c)
3731	{
3732	const char *name;
3733	gfc_typespec ts;
3734	gfc_expr *n;
3735	gfc_clear_ts (&ts);
3736
3737	ts.type = BT_INTEGER;
3738	ts.kind = gfc_default_integer_kind;
3739	n = c->ext.actual->expr;
3740	if (n != NULL && n->ts.kind != ts.kind)
3741	gfc_convert_type (n, &ts, 2);
3742
3743	name = gfc_get_string (PREFIX ("flush_i%d"), ts.kind);
3744	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3745	}
3746
3747
3748	void
3749	gfc_resolve_ctime_sub (gfc_code *c)
3750	{
3751	gfc_typespec ts;
3752	gfc_clear_ts (&ts);
3753
3754	/* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3755	if (c->ext.actual->expr->ts.kind != 8)
3756	{
3757	ts.type = BT_INTEGER;
3758	ts.kind = 8;
3759	ts.u.derived = NULL;
3760	ts.u.cl = NULL;
3761	gfc_convert_type (c->ext.actual->expr, &ts, 2);
3762	}
3763
3764	c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3765	}
3766
3767
3768	void
3769	gfc_resolve_fdate_sub (gfc_code *c)
3770	{
3771	c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3772	}
3773
3774
3775	void
3776	gfc_resolve_gerror (gfc_code *c)
3777	{
3778	c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3779	}
3780
3781
3782	void
3783	gfc_resolve_getlog (gfc_code *c)
3784	{
3785	c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3786	}
3787
3788
3789	void
3790	gfc_resolve_hostnm_sub (gfc_code *c)
3791	{
3792	const char *name;
3793	int kind;
3794
3795	if (c->ext.actual->next->expr != NULL)
3796	kind = c->ext.actual->next->expr->ts.kind;
3797	else
3798	kind = gfc_default_integer_kind;
3799
3800	name = gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind);
3801	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3802	}
3803
3804
3805	void
3806	gfc_resolve_perror (gfc_code *c)
3807	{
3808	c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3809	}
3810
3811	/* Resolve the STAT and FSTAT intrinsic subroutines. */
3812
3813	void
3814	gfc_resolve_stat_sub (gfc_code *c)
3815	{
3816	const char *name;
3817	name = gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind);
3818	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3819	}
3820
3821
3822	void
3823	gfc_resolve_lstat_sub (gfc_code *c)
3824	{
3825	const char *name;
3826	name = gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind);
3827	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3828	}
3829
3830
3831	void
3832	gfc_resolve_fstat_sub (gfc_code *c)
3833	{
3834	const char *name;
3835	gfc_expr *u;
3836	gfc_typespec *ts;
3837
3838	u = c->ext.actual->expr;
3839	ts = &c->ext.actual->next->expr->ts;
3840	if (u->ts.kind != ts->kind)
3841	gfc_convert_type (u, ts, 2);
3842	name = gfc_get_string (PREFIX ("fstat_i%d_sub"), ts->kind);
3843	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3844	}
3845
3846
3847	void
3848	gfc_resolve_fgetc_sub (gfc_code *c)
3849	{
3850	const char *name;
3851	gfc_typespec ts;
3852	gfc_expr *u, *st;
3853	gfc_clear_ts (&ts);
3854
3855	u = c->ext.actual->expr;
3856	st = c->ext.actual->next->next->expr;
3857
3858	if (u->ts.kind != gfc_c_int_kind)
3859	{
3860	ts.type = BT_INTEGER;
3861	ts.kind = gfc_c_int_kind;
3862	ts.u.derived = NULL;
3863	ts.u.cl = NULL;
3864	gfc_convert_type (u, &ts, 2);
3865	}
3866
3867	if (st != NULL)
3868	name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), st->ts.kind);
3869	else
3870	name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind);
3871
3872	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3873	}
3874
3875
3876	void
3877	gfc_resolve_fget_sub (gfc_code *c)
3878	{
3879	const char *name;
3880	gfc_expr *st;
3881
3882	st = c->ext.actual->next->expr;
3883	if (st != NULL)
3884	name = gfc_get_string (PREFIX ("fget_i%d_sub"), st->ts.kind);
3885	else
3886	name = gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind);
3887
3888	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3889	}
3890
3891
3892	void
3893	gfc_resolve_fputc_sub (gfc_code *c)
3894	{
3895	const char *name;
3896	gfc_typespec ts;
3897	gfc_expr *u, *st;
3898	gfc_clear_ts (&ts);
3899
3900	u = c->ext.actual->expr;
3901	st = c->ext.actual->next->next->expr;
3902
3903	if (u->ts.kind != gfc_c_int_kind)
3904	{
3905	ts.type = BT_INTEGER;
3906	ts.kind = gfc_c_int_kind;
3907	ts.u.derived = NULL;
3908	ts.u.cl = NULL;
3909	gfc_convert_type (u, &ts, 2);
3910	}
3911
3912	if (st != NULL)
3913	name = gfc_get_string (PREFIX ("fputc_i%d_sub"), st->ts.kind);
3914	else
3915	name = gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind);
3916
3917	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3918	}
3919
3920
3921	void
3922	gfc_resolve_fput_sub (gfc_code *c)
3923	{
3924	const char *name;
3925	gfc_expr *st;
3926
3927	st = c->ext.actual->next->expr;
3928	if (st != NULL)
3929	name = gfc_get_string (PREFIX ("fput_i%d_sub"), st->ts.kind);
3930	else
3931	name = gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind);
3932
3933	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3934	}
3935
3936
3937	void
3938	gfc_resolve_fseek_sub (gfc_code *c)
3939	{
3940	gfc_expr *unit;
3941	gfc_expr *offset;
3942	gfc_expr *whence;
3943	gfc_typespec ts;
3944	gfc_clear_ts (&ts);
3945
3946	unit = c->ext.actual->expr;
3947	offset = c->ext.actual->next->expr;
3948	whence = c->ext.actual->next->next->expr;
3949
3950	if (unit->ts.kind != gfc_c_int_kind)
3951	{
3952	ts.type = BT_INTEGER;
3953	ts.kind = gfc_c_int_kind;
3954	ts.u.derived = NULL;
3955	ts.u.cl = NULL;
3956	gfc_convert_type (unit, &ts, 2);
3957	}
3958
3959	if (offset->ts.kind != gfc_intio_kind)
3960	{
3961	ts.type = BT_INTEGER;
3962	ts.kind = gfc_intio_kind;
3963	ts.u.derived = NULL;
3964	ts.u.cl = NULL;
3965	gfc_convert_type (offset, &ts, 2);
3966	}
3967
3968	if (whence->ts.kind != gfc_c_int_kind)
3969	{
3970	ts.type = BT_INTEGER;
3971	ts.kind = gfc_c_int_kind;
3972	ts.u.derived = NULL;
3973	ts.u.cl = NULL;
3974	gfc_convert_type (whence, &ts, 2);
3975	}
3976
3977	c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
3978	}
3979
3980	void
3981	gfc_resolve_ftell_sub (gfc_code *c)
3982	{
3983	const char *name;
3984	gfc_expr *unit;
3985	gfc_expr *offset;
3986	gfc_typespec ts;
3987	gfc_clear_ts (&ts);
3988
3989	unit = c->ext.actual->expr;
3990	offset = c->ext.actual->next->expr;
3991
3992	if (unit->ts.kind != gfc_c_int_kind)
3993	{
3994	ts.type = BT_INTEGER;
3995	ts.kind = gfc_c_int_kind;
3996	ts.u.derived = NULL;
3997	ts.u.cl = NULL;
3998	gfc_convert_type (unit, &ts, 2);
3999	}
4000
4001	name = gfc_get_string (PREFIX ("ftell_i%d_sub"), offset->ts.kind);
4002	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4003	}
4004
4005
4006	void
4007	gfc_resolve_ttynam_sub (gfc_code *c)
4008	{
4009	gfc_typespec ts;
4010	gfc_clear_ts (&ts);
4011
4012	if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
4013	{
4014	ts.type = BT_INTEGER;
4015	ts.kind = gfc_c_int_kind;
4016	ts.u.derived = NULL;
4017	ts.u.cl = NULL;
4018	gfc_convert_type (c->ext.actual->expr, &ts, 2);
4019	}
4020
4021	c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
4022	}
4023
4024
4025	/* Resolve the UMASK intrinsic subroutine. */
4026
4027	void
4028	gfc_resolve_umask_sub (gfc_code *c)
4029	{
4030	const char *name;
4031	int kind;
4032
4033	if (c->ext.actual->next->expr != NULL)
4034	kind = c->ext.actual->next->expr->ts.kind;
4035	else
4036	kind = gfc_default_integer_kind;
4037
4038	name = gfc_get_string (PREFIX ("umask_i%d_sub"), kind);
4039	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4040	}
4041
4042	/* Resolve the UNLINK intrinsic subroutine. */
4043
4044	void
4045	gfc_resolve_unlink_sub (gfc_code *c)
4046	{
4047	const char *name;
4048	int kind;
4049
4050	if (c->ext.actual->next->expr != NULL)
4051	kind = c->ext.actual->next->expr->ts.kind;
4052	else
4053	kind = gfc_default_integer_kind;
4054
4055	name = gfc_get_string (PREFIX ("unlink_i%d_sub"), kind);
4056	c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4057	}
4058