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