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