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 68337890 : gfc_get_string (const char *format, ...)
49 : {
50 : /* Provide sufficient space for "_F.caf_token__symbol.symbol_MOD_symbol". */
51 68337890 : char temp_name[15 + 2*GFC_MAX_SYMBOL_LEN + 5 + GFC_MAX_SYMBOL_LEN + 1];
52 68337890 : const char *str;
53 68337890 : va_list ap;
54 68337890 : tree ident;
55 :
56 : /* Handle common case without vsnprintf and temporary buffer. */
57 68337890 : if (format[0] == '%' && format[1] == 's' && format[2] == '\0')
58 : {
59 58439849 : va_start (ap, format);
60 58439849 : str = va_arg (ap, const char *);
61 58439849 : va_end (ap);
62 : }
63 : else
64 : {
65 9898041 : int ret;
66 9898041 : va_start (ap, format);
67 9898041 : ret = vsnprintf (temp_name, sizeof (temp_name), format, ap);
68 9898041 : va_end (ap);
69 9898041 : if (ret < 1 || ret >= (int) sizeof (temp_name)) /* Reject truncation. */
70 0 : gfc_internal_error ("identifier overflow: %d", ret);
71 9898041 : temp_name[sizeof (temp_name) - 1] = 0;
72 9898041 : str = temp_name;
73 : }
74 :
75 68337890 : ident = get_identifier (str);
76 68337890 : 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 30206 : resolve_bound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind,
164 : const char *name, bool coarray)
165 : {
166 30206 : f->ts.type = BT_INTEGER;
167 30206 : if (kind)
168 3535 : f->ts.kind = mpz_get_si (kind->value.integer);
169 : else
170 26671 : f->ts.kind = gfc_default_integer_kind;
171 :
172 30206 : 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 30206 : f->value.function.name = gfc_get_string ("%s", name);
192 30206 : }
193 :
194 :
195 : static void
196 6146 : 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 6146 : const char *prefix;
201 6146 : bt type;
202 :
203 6146 : f->ts = array->ts;
204 :
205 6146 : 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 6146 : 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 6146 : if (use_integer && array->ts.type == BT_UNSIGNED)
229 : type = BT_INTEGER;
230 : else
231 6038 : type = array->ts.type;
232 :
233 6146 : f->value.function.name
234 12292 : = gfc_get_string (PREFIX ("%s%s_%c%d"), prefix, name,
235 6146 : gfc_type_letter (type),
236 : gfc_type_abi_kind (&array->ts));
237 6146 : }
238 :
239 :
240 : /********************** Resolution functions **********************/
241 :
242 :
243 : void
244 24439 : gfc_resolve_abs (gfc_expr *f, gfc_expr *a)
245 : {
246 24439 : f->ts = a->ts;
247 24439 : if (f->ts.type == BT_COMPLEX)
248 3148 : f->ts.type = BT_REAL;
249 :
250 24439 : f->value.function.name
251 24439 : = gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type),
252 : gfc_type_abi_kind (&a->ts));
253 24439 : }
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 1154 : gfc_resolve_adjustl (gfc_expr *f, gfc_expr *string)
268 : {
269 1154 : f->ts.type = BT_CHARACTER;
270 1154 : f->ts.kind = string->ts.kind;
271 1154 : if (string->ts.deferred)
272 60 : f->ts = string->ts;
273 1094 : else if (string->ts.u.cl)
274 1094 : f->ts.u.cl = gfc_new_charlen (gfc_current_ns, string->ts.u.cl);
275 :
276 1154 : f->value.function.name = gfc_get_string ("__adjustl_s%d", f->ts.kind);
277 1154 : }
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 1587 : gfc_resolve_aimag (gfc_expr *f, gfc_expr *x)
340 : {
341 1587 : f->ts.type = BT_REAL;
342 1587 : f->ts.kind = x->ts.kind;
343 1587 : f->value.function.name
344 1587 : = gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type),
345 : gfc_type_abi_kind (&x->ts));
346 1587 : }
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 41250 : gfc_resolve_any (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
450 : {
451 41250 : f->ts = mask->ts;
452 :
453 41250 : 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 41250 : f->value.function.name
461 41250 : = gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask->ts.type),
462 : gfc_type_abi_kind (&mask->ts));
463 41250 : }
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 6050 : gfc_resolve_c_loc (gfc_expr *f, gfc_expr *x ATTRIBUTE_UNUSED)
582 : {
583 6050 : f->ts = f->value.function.isym->ts;
584 6050 : }
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 864 : gfc_resolve_cos (gfc_expr *f, gfc_expr *x)
736 : {
737 864 : f->ts = x->ts;
738 864 : f->value.function.name
739 864 : = gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type),
740 : gfc_type_abi_kind (&x->ts));
741 864 : }
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 507 : gfc_resolve_dble (gfc_expr *f, gfc_expr *a)
890 : {
891 507 : f->ts.type = BT_REAL;
892 507 : f->ts.kind = gfc_default_double_kind;
893 507 : f->value.function.name
894 507 : = gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type),
895 : gfc_type_abi_kind (&a->ts));
896 507 : }
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 457 : gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
1060 : {
1061 457 : gfc_symbol *vtab;
1062 457 : gfc_symtree *st;
1063 :
1064 : /* Prevent double resolution. */
1065 457 : 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 14848 : gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
1546 : {
1547 14848 : resolve_bound (f, array, dim, kind, "__lbound", false);
1548 14848 : }
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 13422 : gfc_resolve_len (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
1560 : {
1561 13422 : f->ts.type = BT_INTEGER;
1562 13422 : if (kind)
1563 224 : f->ts.kind = mpz_get_si (kind->value.integer);
1564 : else
1565 13198 : f->ts.kind = gfc_default_integer_kind;
1566 13422 : f->value.function.name
1567 13422 : = gfc_get_string ("__len_%d_i%d", string->ts.kind,
1568 : gfc_default_integer_kind);
1569 13422 : }
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 7156 : gfc_resolve_loc (gfc_expr *f, gfc_expr *x)
1605 : {
1606 7156 : f->ts.type= BT_INTEGER;
1607 7156 : f->ts.kind = gfc_index_integer_kind;
1608 7156 : f->value.function.name = gfc_get_string ("__loc_%d", x->ts.kind);
1609 7156 : }
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 1088 : gfc_resolve_matmul (gfc_expr *f, gfc_expr *a, gfc_expr *b)
1650 : {
1651 1088 : gfc_expr temp;
1652 1088 : bt type;
1653 :
1654 1088 : 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 1051 : temp.expr_type = EXPR_OP;
1662 1051 : gfc_clear_ts (&temp.ts);
1663 1051 : temp.value.op.op = INTRINSIC_NONE;
1664 1051 : temp.value.op.op1 = a;
1665 1051 : temp.value.op.op2 = b;
1666 1051 : gfc_type_convert_binary (&temp, 1);
1667 1051 : f->ts = temp.ts;
1668 : }
1669 :
1670 1088 : f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
1671 1088 : f->corank = a->corank;
1672 :
1673 1088 : if (a->rank == 2 && b->rank == 2)
1674 : {
1675 706 : if (a->shape && b->shape)
1676 : {
1677 509 : f->shape = gfc_get_shape (f->rank);
1678 509 : mpz_init_set (f->shape[0], a->shape[0]);
1679 509 : mpz_init_set (f->shape[1], b->shape[1]);
1680 : }
1681 : }
1682 382 : 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 200 : 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 1088 : if (f->ts.type == BT_UNSIGNED)
1705 : type = BT_INTEGER;
1706 : else
1707 1082 : type = f->ts.type;
1708 :
1709 1088 : f->value.function.name
1710 1088 : = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (type),
1711 : gfc_type_abi_kind (&f->ts));
1712 1088 : }
1713 :
1714 :
1715 : static void
1716 4346 : gfc_resolve_minmax (const char *name, gfc_expr *f, gfc_actual_arglist *args)
1717 : {
1718 4346 : gfc_actual_arglist *a;
1719 :
1720 4346 : f->ts.type = args->expr->ts.type;
1721 4346 : f->ts.kind = args->expr->ts.kind;
1722 : /* Find the largest type kind. */
1723 9585 : for (a = args->next; a; a = a->next)
1724 : {
1725 5239 : 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 13931 : for (a = args; a; a = a->next)
1731 : {
1732 9585 : if (a->expr->ts.kind != f->ts.kind)
1733 42 : gfc_convert_type (a->expr, &f->ts, 2);
1734 : }
1735 :
1736 4346 : f->value.function.name
1737 4346 : = gfc_get_string (name, gfc_type_letter (f->ts.type),
1738 : gfc_type_abi_kind (&f->ts));
1739 4346 : }
1740 :
1741 :
1742 : void
1743 2749 : gfc_resolve_max (gfc_expr *f, gfc_actual_arglist *args)
1744 : {
1745 2749 : gfc_resolve_minmax ("__max_%c%d", f, args);
1746 2749 : }
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 4324 : gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p)
2256 : {
2257 4324 : f->ts.type = a->ts.type;
2258 4324 : if (p != NULL)
2259 4276 : f->ts.kind = gfc_kind_max (a,p);
2260 : else
2261 48 : f->ts.kind = a->ts.kind;
2262 :
2263 4324 : if (p != NULL && a->ts.kind != p->ts.kind)
2264 : {
2265 134 : if (a->ts.kind == gfc_kind_max (a,p))
2266 134 : gfc_convert_type (p, &a->ts, 2);
2267 : else
2268 0 : gfc_convert_type (a, &p->ts, 2);
2269 : }
2270 :
2271 4324 : f->value.function.name
2272 4324 : = gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type),
2273 : gfc_type_abi_kind (&f->ts));
2274 4324 : }
2275 :
2276 :
2277 : void
2278 1678 : gfc_resolve_modulo (gfc_expr *f, gfc_expr *a, gfc_expr *p)
2279 : {
2280 1678 : f->ts.type = a->ts.type;
2281 1678 : if (p != NULL)
2282 1678 : f->ts.kind = gfc_kind_max (a,p);
2283 : else
2284 0 : f->ts.kind = a->ts.kind;
2285 :
2286 1678 : 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 1678 : f->value.function.name
2295 1678 : = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type),
2296 : gfc_type_abi_kind (&f->ts));
2297 1678 : }
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 8369 : gfc_resolve_rank (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED)
2412 : {
2413 8369 : f->ts.type = BT_INTEGER;
2414 8369 : f->ts.kind = gfc_default_integer_kind;
2415 8369 : f->value.function.name = gfc_get_string ("__rank");
2416 8369 : }
2417 :
2418 :
2419 : void
2420 5833 : gfc_resolve_real (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
2421 : {
2422 5833 : f->ts.type = BT_REAL;
2423 :
2424 5833 : if (kind != NULL)
2425 1612 : f->ts.kind = mpz_get_si (kind->value.integer);
2426 : else
2427 4221 : f->ts.kind = (a->ts.type == BT_COMPLEX)
2428 4221 : ? a->ts.kind : gfc_default_real_kind;
2429 :
2430 5833 : f->value.function.name
2431 11666 : = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
2432 5833 : gfc_type_letter (a->ts.type),
2433 : gfc_type_abi_kind (&a->ts));
2434 5833 : }
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 3178 : 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 3178 : mpz_t rank;
2716 3178 : int kind;
2717 3178 : int i;
2718 :
2719 3178 : if (source->ts.type == BT_CHARACTER && source->ref)
2720 302 : gfc_resolve_substring_charlen (source);
2721 :
2722 3178 : f->ts = source->ts;
2723 :
2724 3178 : gfc_array_size (shape, &rank);
2725 3178 : f->rank = mpz_get_si (rank);
2726 3178 : mpz_clear (rank);
2727 3178 : switch (source->ts.type)
2728 : {
2729 3058 : case BT_COMPLEX:
2730 3058 : case BT_REAL:
2731 3058 : case BT_INTEGER:
2732 3058 : case BT_LOGICAL:
2733 3058 : case BT_CHARACTER:
2734 3058 : kind = source->ts.kind;
2735 3058 : break;
2736 :
2737 : default:
2738 : kind = 0;
2739 : break;
2740 : }
2741 :
2742 3058 : 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 444 : default:
2762 888 : f->value.function.name = (source->ts.type == BT_CHARACTER
2763 444 : ? PREFIX ("reshape_char") : PREFIX ("reshape"));
2764 444 : break;
2765 : }
2766 :
2767 3178 : if (shape->expr_type == EXPR_ARRAY && gfc_is_constant_array_expr (shape))
2768 : {
2769 1518 : gfc_constructor *c;
2770 1518 : f->shape = gfc_get_shape (f->rank);
2771 1518 : c = gfc_constructor_first (shape->value.constructor);
2772 6460 : for (i = 0; i < f->rank; i++)
2773 : {
2774 3424 : mpz_init_set (f->shape[i], c->expr->value.integer);
2775 3424 : 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 3178 : if (shape->ts.kind != gfc_index_integer_kind)
2782 : {
2783 2607 : gfc_typespec ts = shape->ts;
2784 2607 : ts.kind = gfc_index_integer_kind;
2785 2607 : gfc_convert_type_warn (shape, &ts, 2, 0);
2786 : }
2787 3178 : if (order && order->ts.kind != gfc_index_integer_kind)
2788 110 : gfc_convert_type_warn (order, &shape->ts, 2, 0);
2789 3178 : }
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 391 : gfc_resolve_fe_runtime_error (gfc_code *c)
2801 : {
2802 391 : const char *name;
2803 391 : gfc_actual_arglist *a;
2804 :
2805 391 : name = gfc_get_string (PREFIX ("runtime_error"));
2806 :
2807 1173 : for (a = c->ext.actual->next; a; a = a->next)
2808 782 : a->name = "%VAL";
2809 :
2810 391 : 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 391 : c->resolved_sym->backend_decl = gfor_fndecl_runtime_error;
2815 391 : }
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 9761 : gfc_resolve_shape (gfc_expr *f, gfc_expr *array, gfc_expr *kind)
2858 : {
2859 9761 : f->ts.type = BT_INTEGER;
2860 :
2861 9761 : if (kind)
2862 69 : f->ts.kind = mpz_get_si (kind->value.integer);
2863 : else
2864 9692 : f->ts.kind = gfc_default_integer_kind;
2865 :
2866 9761 : f->rank = 1;
2867 9761 : if (array->rank != -1)
2868 : {
2869 8849 : f->shape = gfc_get_shape (1);
2870 8849 : mpz_init_set_ui (f->shape[0], array->rank);
2871 : }
2872 :
2873 9761 : f->value.function.name = gfc_get_string (PREFIX ("shape_%d"), f->ts.kind);
2874 9761 : }
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 733 : gfc_resolve_sin (gfc_expr *f, gfc_expr *x)
2925 : {
2926 733 : f->ts = x->ts;
2927 733 : f->value.function.name
2928 733 : = gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type),
2929 : gfc_type_abi_kind (&x->ts));
2930 733 : }
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 27806 : gfc_resolve_size (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2945 : gfc_expr *dim ATTRIBUTE_UNUSED, gfc_expr *kind)
2946 : {
2947 27806 : f->ts.type = BT_INTEGER;
2948 27806 : if (kind)
2949 4933 : f->ts.kind = mpz_get_si (kind->value.integer);
2950 : else
2951 22873 : f->ts.kind = gfc_default_integer_kind;
2952 27806 : }
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 4468 : gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
3169 : {
3170 4468 : resolve_transformational ("sum", f, array, dim, mask, true);
3171 4468 : }
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 2879 : gfc_resolve_this_image (gfc_expr *f, gfc_expr *coarray, gfc_expr *dim,
3316 : gfc_expr *team)
3317 : {
3318 2879 : static char this_image[] = "__this_image";
3319 2879 : if (coarray && dim)
3320 819 : resolve_bound (f, coarray, dim, NULL, this_image, true);
3321 2060 : 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 1834 : f->ts.type = BT_INTEGER;
3335 1834 : f->ts.kind = gfc_default_integer_kind;
3336 1834 : f->value.function.name = this_image;
3337 : }
3338 :
3339 2879 : if (team)
3340 22 : gfc_resolve_expr (team);
3341 2879 : }
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 2011 : 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 2011 : static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
3367 :
3368 2011 : if (mold->ts.type == BT_CHARACTER
3369 640 : && !mold->ts.u.cl->length
3370 2206 : && 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 2011 : if (UNLIMITED_POLY (mold))
3389 0 : gfc_error ("TODO: unlimited polymorphic MOLD in TRANSFER intrinsic at %L",
3390 : &mold->where);
3391 :
3392 2011 : f->ts = mold->ts;
3393 :
3394 2011 : if (size == NULL && mold->rank == 0)
3395 : {
3396 1246 : f->rank = 0;
3397 1246 : 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 2011 : }
3410 :
3411 :
3412 : void
3413 1580 : gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
3414 : {
3415 :
3416 1580 : if (matrix->ts.type == BT_CHARACTER && matrix->ref)
3417 156 : gfc_resolve_substring_charlen (matrix);
3418 :
3419 1580 : f->ts = matrix->ts;
3420 1580 : f->rank = 2;
3421 1580 : if (matrix->shape)
3422 : {
3423 1252 : f->shape = gfc_get_shape (2);
3424 1252 : mpz_init_set (f->shape[0], matrix->shape[1]);
3425 1252 : mpz_init_set (f->shape[1], matrix->shape[0]);
3426 : }
3427 :
3428 1580 : switch (matrix->ts.kind)
3429 : {
3430 1466 : case 4:
3431 1466 : case 8:
3432 1466 : case 10:
3433 1466 : case 16:
3434 1466 : switch (matrix->ts.type)
3435 : {
3436 451 : case BT_REAL:
3437 451 : case BT_COMPLEX:
3438 451 : f->value.function.name
3439 902 : = gfc_get_string (PREFIX ("transpose_%c%d"),
3440 451 : gfc_type_letter (matrix->ts.type),
3441 : gfc_type_abi_kind (&matrix->ts));
3442 451 : break;
3443 :
3444 937 : case BT_INTEGER:
3445 937 : case BT_LOGICAL:
3446 : /* Use the integer routines for real and logical cases. This
3447 : assumes they all have the same alignment requirements. */
3448 937 : f->value.function.name
3449 937 : = gfc_get_string (PREFIX ("transpose_i%d"), matrix->ts.kind);
3450 937 : 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 1580 : }
3468 :
3469 :
3470 : void
3471 4556 : gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
3472 : {
3473 4556 : f->ts.type = BT_CHARACTER;
3474 4556 : f->ts.kind = string->ts.kind;
3475 4556 : f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
3476 4556 : }
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_sind_r4. */
3481 :
3482 : void
3483 1404 : gfc_resolve_trig (gfc_expr *f, gfc_expr *x)
3484 : {
3485 1404 : f->ts = x->ts;
3486 1404 : f->value.function.name
3487 2808 : = gfc_get_string (PREFIX ("%s_%c%d"), f->value.function.isym->name,
3488 1404 : gfc_type_letter (x->ts.type),
3489 : gfc_type_abi_kind (&x->ts));
3490 1404 : }
3491 :
3492 : void
3493 240 : gfc_resolve_trig2 (gfc_expr *f, gfc_expr *y, gfc_expr *x)
3494 : {
3495 240 : f->ts = y->ts;
3496 240 : f->value.function.name
3497 240 : = gfc_get_string (PREFIX ("%s_%d"), f->value.function.isym->name,
3498 : x->ts.kind);
3499 240 : }
3500 :
3501 :
3502 : void
3503 13583 : gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3504 : {
3505 13583 : resolve_bound (f, array, dim, kind, "__ubound", false);
3506 13583 : }
3507 :
3508 :
3509 : void
3510 498 : gfc_resolve_ucobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3511 : {
3512 498 : resolve_bound (f, array, dim, kind, "__ucobound", true);
3513 498 : }
3514 :
3515 :
3516 : /* Resolve the g77 compatibility function UMASK. */
3517 :
3518 : void
3519 0 : gfc_resolve_umask (gfc_expr *f, gfc_expr *n)
3520 : {
3521 0 : f->ts.type = BT_INTEGER;
3522 0 : f->ts.kind = n->ts.kind;
3523 0 : f->value.function.name = gfc_get_string (PREFIX ("umask_i%d"), n->ts.kind);
3524 0 : }
3525 :
3526 :
3527 : /* Resolve the g77 compatibility function UNLINK. */
3528 :
3529 : void
3530 1 : gfc_resolve_unlink (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
3531 : {
3532 1 : f->ts.type = BT_INTEGER;
3533 1 : f->ts.kind = 4;
3534 1 : f->value.function.name = gfc_get_string (PREFIX ("unlink"));
3535 1 : }
3536 :
3537 :
3538 : void
3539 0 : gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit)
3540 : {
3541 0 : gfc_typespec ts;
3542 0 : gfc_clear_ts (&ts);
3543 :
3544 0 : f->ts.type = BT_CHARACTER;
3545 0 : f->ts.kind = gfc_default_character_kind;
3546 :
3547 0 : if (unit->ts.kind != gfc_c_int_kind)
3548 : {
3549 0 : ts.type = BT_INTEGER;
3550 0 : ts.kind = gfc_c_int_kind;
3551 0 : ts.u.derived = NULL;
3552 0 : ts.u.cl = NULL;
3553 0 : gfc_convert_type (unit, &ts, 2);
3554 : }
3555 :
3556 0 : f->value.function.name = gfc_get_string (PREFIX ("ttynam"));
3557 0 : }
3558 :
3559 :
3560 : void
3561 460 : gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
3562 : gfc_expr *field ATTRIBUTE_UNUSED)
3563 : {
3564 460 : if (vector->ts.type == BT_CHARACTER && vector->ref)
3565 54 : gfc_resolve_substring_charlen (vector);
3566 :
3567 460 : f->ts = vector->ts;
3568 460 : f->rank = mask->rank;
3569 460 : resolve_mask_arg (mask);
3570 :
3571 460 : if (vector->ts.type == BT_CHARACTER)
3572 : {
3573 54 : if (vector->ts.kind == 1)
3574 30 : f->value.function.name
3575 54 : = gfc_get_string (PREFIX ("unpack%d_char"), field->rank > 0 ? 1 : 0);
3576 : else
3577 24 : f->value.function.name
3578 24 : = gfc_get_string (PREFIX ("unpack%d_char%d"),
3579 24 : field->rank > 0 ? 1 : 0, vector->ts.kind);
3580 : }
3581 : else
3582 406 : f->value.function.name
3583 499 : = gfc_get_string (PREFIX ("unpack%d"), field->rank > 0 ? 1 : 0);
3584 460 : }
3585 :
3586 :
3587 : void
3588 254 : gfc_resolve_verify (gfc_expr *f, gfc_expr *string,
3589 : gfc_expr *set ATTRIBUTE_UNUSED,
3590 : gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
3591 : {
3592 254 : f->ts.type = BT_INTEGER;
3593 254 : if (kind)
3594 16 : f->ts.kind = mpz_get_si (kind->value.integer);
3595 : else
3596 238 : f->ts.kind = gfc_default_integer_kind;
3597 254 : f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
3598 254 : }
3599 :
3600 :
3601 : void
3602 20 : gfc_resolve_xor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
3603 : {
3604 20 : f->ts.type = i->ts.type;
3605 20 : f->ts.kind = gfc_kind_max (i, j);
3606 :
3607 20 : if (i->ts.kind != j->ts.kind)
3608 : {
3609 0 : if (i->ts.kind == gfc_kind_max (i, j))
3610 0 : gfc_convert_type (j, &i->ts, 2);
3611 : else
3612 0 : gfc_convert_type (i, &j->ts, 2);
3613 : }
3614 :
3615 20 : f->value.function.name
3616 20 : = gfc_get_string ("__xor_%c%d", gfc_type_letter (i->ts.type),
3617 : gfc_type_abi_kind (&f->ts));
3618 20 : }
3619 :
3620 :
3621 : /* Intrinsic subroutine resolution. */
3622 :
3623 : void
3624 0 : gfc_resolve_alarm_sub (gfc_code *c)
3625 : {
3626 0 : const char *name;
3627 0 : gfc_expr *seconds, *handler;
3628 0 : gfc_typespec ts;
3629 0 : gfc_clear_ts (&ts);
3630 :
3631 0 : seconds = c->ext.actual->expr;
3632 0 : handler = c->ext.actual->next->expr;
3633 0 : ts.type = BT_INTEGER;
3634 0 : ts.kind = gfc_c_int_kind;
3635 :
3636 : /* handler can be either BT_INTEGER or BT_PROCEDURE.
3637 : In all cases, the status argument is of default integer kind
3638 : (enforced in check.cc) so that the function suffix is fixed. */
3639 0 : if (handler->ts.type == BT_INTEGER)
3640 : {
3641 0 : if (handler->ts.kind != gfc_c_int_kind)
3642 0 : gfc_convert_type (handler, &ts, 2);
3643 0 : name = gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
3644 : gfc_default_integer_kind);
3645 : }
3646 : else
3647 0 : name = gfc_get_string (PREFIX ("alarm_sub_i%d"),
3648 : gfc_default_integer_kind);
3649 :
3650 0 : if (seconds->ts.kind != gfc_c_int_kind)
3651 0 : gfc_convert_type (seconds, &ts, 2);
3652 :
3653 0 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3654 0 : }
3655 :
3656 : void
3657 21 : gfc_resolve_cpu_time (gfc_code *c)
3658 : {
3659 21 : const char *name;
3660 21 : name = gfc_get_string (PREFIX ("cpu_time_%d"), c->ext.actual->expr->ts.kind);
3661 21 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3662 21 : }
3663 :
3664 :
3665 : /* Create a formal arglist based on an actual one and set the INTENTs given. */
3666 :
3667 : static gfc_formal_arglist*
3668 198 : create_formal_for_intents (gfc_actual_arglist* actual, const sym_intent* ints)
3669 : {
3670 198 : gfc_formal_arglist* head;
3671 198 : gfc_formal_arglist* tail;
3672 198 : int i;
3673 :
3674 198 : if (!actual)
3675 : return NULL;
3676 :
3677 198 : head = tail = gfc_get_formal_arglist ();
3678 1188 : for (i = 0; actual; actual = actual->next, tail = tail->next, ++i)
3679 : {
3680 990 : gfc_symbol* sym;
3681 :
3682 990 : sym = gfc_new_symbol ("dummyarg", NULL);
3683 990 : sym->ts = actual->expr->ts;
3684 :
3685 990 : sym->attr.intent = ints[i];
3686 990 : tail->sym = sym;
3687 :
3688 990 : if (actual->next)
3689 792 : tail->next = gfc_get_formal_arglist ();
3690 : }
3691 :
3692 : return head;
3693 : }
3694 :
3695 :
3696 : void
3697 22 : gfc_resolve_atomic_def (gfc_code *c)
3698 : {
3699 22 : const char *name = "atomic_define";
3700 22 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3701 22 : }
3702 :
3703 :
3704 : void
3705 178 : gfc_resolve_atomic_ref (gfc_code *c)
3706 : {
3707 178 : const char *name = "atomic_ref";
3708 178 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3709 178 : }
3710 :
3711 : void
3712 105 : gfc_resolve_event_query (gfc_code *c)
3713 : {
3714 105 : const char *name = "event_query";
3715 105 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3716 105 : }
3717 :
3718 : void
3719 198 : gfc_resolve_mvbits (gfc_code *c)
3720 : {
3721 198 : static const sym_intent INTENTS[] = {INTENT_IN, INTENT_IN, INTENT_IN,
3722 : INTENT_INOUT, INTENT_IN};
3723 198 : const char *name;
3724 :
3725 : /* TO and FROM are guaranteed to have the same kind parameter. */
3726 396 : name = gfc_get_string (PREFIX ("mvbits_i%d"),
3727 198 : c->ext.actual->expr->ts.kind);
3728 198 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3729 : /* Mark as elemental subroutine as this does not happen automatically. */
3730 198 : c->resolved_sym->attr.elemental = 1;
3731 :
3732 : /* Create a dummy formal arglist so the INTENTs are known later for purpose
3733 : of creating temporaries. */
3734 198 : c->resolved_sym->formal = create_formal_for_intents (c->ext.actual, INTENTS);
3735 198 : }
3736 :
3737 :
3738 : /* Set up the call to RANDOM_INIT. */
3739 :
3740 : void
3741 90 : gfc_resolve_random_init (gfc_code *c)
3742 : {
3743 90 : const char *name;
3744 90 : name = gfc_get_string (PREFIX ("random_init"));
3745 90 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3746 90 : }
3747 :
3748 :
3749 : void
3750 530 : gfc_resolve_random_number (gfc_code *c)
3751 : {
3752 530 : const char *name;
3753 530 : int kind;
3754 530 : char type;
3755 :
3756 530 : kind = gfc_type_abi_kind (&c->ext.actual->expr->ts);
3757 530 : type = gfc_type_letter (c->ext.actual->expr->ts.type);
3758 530 : if (c->ext.actual->expr->rank == 0)
3759 105 : name = gfc_get_string (PREFIX ("random_%c%d"), type, kind);
3760 : else
3761 425 : name = gfc_get_string (PREFIX ("arandom_%c%d"), type, kind);
3762 :
3763 530 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3764 530 : }
3765 :
3766 :
3767 : void
3768 303 : gfc_resolve_random_seed (gfc_code *c)
3769 : {
3770 303 : const char *name;
3771 :
3772 303 : name = gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind);
3773 303 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3774 303 : }
3775 :
3776 :
3777 : void
3778 9 : gfc_resolve_rename_sub (gfc_code *c)
3779 : {
3780 9 : const char *name;
3781 9 : int kind;
3782 :
3783 : /* Find the type of status. If not present use default integer kind. */
3784 9 : if (c->ext.actual->next->next->expr != NULL)
3785 7 : kind = c->ext.actual->next->next->expr->ts.kind;
3786 : else
3787 2 : kind = gfc_default_integer_kind;
3788 :
3789 9 : name = gfc_get_string (PREFIX ("rename_i%d_sub"), kind);
3790 9 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3791 9 : }
3792 :
3793 :
3794 : void
3795 9 : gfc_resolve_link_sub (gfc_code *c)
3796 : {
3797 9 : const char *name;
3798 9 : int kind;
3799 :
3800 9 : if (c->ext.actual->next->next->expr != NULL)
3801 7 : kind = c->ext.actual->next->next->expr->ts.kind;
3802 : else
3803 2 : kind = gfc_default_integer_kind;
3804 :
3805 9 : name = gfc_get_string (PREFIX ("link_i%d_sub"), kind);
3806 9 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3807 9 : }
3808 :
3809 :
3810 : void
3811 9 : gfc_resolve_symlnk_sub (gfc_code *c)
3812 : {
3813 9 : const char *name;
3814 9 : int kind;
3815 :
3816 9 : if (c->ext.actual->next->next->expr != NULL)
3817 7 : kind = c->ext.actual->next->next->expr->ts.kind;
3818 : else
3819 2 : kind = gfc_default_integer_kind;
3820 :
3821 9 : name = gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind);
3822 9 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3823 9 : }
3824 :
3825 :
3826 : /* G77 compatibility subroutines dtime() and etime(). */
3827 :
3828 : void
3829 0 : gfc_resolve_dtime_sub (gfc_code *c)
3830 : {
3831 0 : const char *name;
3832 0 : name = gfc_get_string (PREFIX ("dtime_sub"));
3833 0 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3834 0 : }
3835 :
3836 : void
3837 1 : gfc_resolve_etime_sub (gfc_code *c)
3838 : {
3839 1 : const char *name;
3840 1 : name = gfc_get_string (PREFIX ("etime_sub"));
3841 1 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3842 1 : }
3843 :
3844 :
3845 : /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
3846 :
3847 : void
3848 12 : gfc_resolve_itime (gfc_code *c)
3849 : {
3850 12 : c->resolved_sym
3851 12 : = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
3852 : gfc_default_integer_kind));
3853 12 : }
3854 :
3855 : void
3856 12 : gfc_resolve_idate (gfc_code *c)
3857 : {
3858 12 : c->resolved_sym
3859 12 : = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
3860 : gfc_default_integer_kind));
3861 12 : }
3862 :
3863 : void
3864 12 : gfc_resolve_ltime (gfc_code *c)
3865 : {
3866 12 : c->resolved_sym
3867 12 : = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
3868 : gfc_default_integer_kind));
3869 12 : }
3870 :
3871 : void
3872 12 : gfc_resolve_gmtime (gfc_code *c)
3873 : {
3874 12 : c->resolved_sym
3875 12 : = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
3876 : gfc_default_integer_kind));
3877 12 : }
3878 :
3879 :
3880 : /* G77 compatibility subroutine second(). */
3881 :
3882 : void
3883 0 : gfc_resolve_second_sub (gfc_code *c)
3884 : {
3885 0 : const char *name;
3886 0 : name = gfc_get_string (PREFIX ("second_sub"));
3887 0 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3888 0 : }
3889 :
3890 :
3891 : void
3892 28 : gfc_resolve_sleep_sub (gfc_code *c)
3893 : {
3894 28 : const char *name;
3895 28 : int kind;
3896 :
3897 28 : if (c->ext.actual->expr != NULL)
3898 28 : kind = c->ext.actual->expr->ts.kind;
3899 : else
3900 0 : kind = gfc_default_integer_kind;
3901 :
3902 28 : name = gfc_get_string (PREFIX ("sleep_i%d_sub"), kind);
3903 28 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3904 28 : }
3905 :
3906 : void
3907 102 : gfc_resolve_split (gfc_code *c)
3908 : {
3909 102 : const char *name;
3910 102 : gfc_expr *string;
3911 :
3912 102 : string = c->ext.actual->expr;
3913 102 : if (string->ts.type == BT_CHARACTER && string->ts.kind == 4)
3914 : name = "__split_char4";
3915 : else
3916 66 : name = "__split";
3917 102 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3918 102 : }
3919 :
3920 : /* G77 compatibility function srand(). */
3921 :
3922 : void
3923 0 : gfc_resolve_srand (gfc_code *c)
3924 : {
3925 0 : const char *name;
3926 0 : name = gfc_get_string (PREFIX ("srand"));
3927 0 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3928 0 : }
3929 :
3930 :
3931 : /* Resolve the getarg intrinsic subroutine. */
3932 :
3933 : void
3934 55 : gfc_resolve_getarg (gfc_code *c)
3935 : {
3936 55 : const char *name;
3937 :
3938 55 : if (c->ext.actual->expr->ts.kind != gfc_default_integer_kind)
3939 : {
3940 9 : gfc_typespec ts;
3941 9 : gfc_clear_ts (&ts);
3942 :
3943 9 : ts.type = BT_INTEGER;
3944 9 : ts.kind = gfc_default_integer_kind;
3945 :
3946 9 : gfc_convert_type (c->ext.actual->expr, &ts, 2);
3947 : }
3948 :
3949 55 : name = gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind);
3950 55 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3951 55 : }
3952 :
3953 :
3954 : /* Resolve the getcwd intrinsic subroutine. */
3955 :
3956 : void
3957 8 : gfc_resolve_getcwd_sub (gfc_code *c)
3958 : {
3959 8 : const char *name;
3960 8 : int kind;
3961 :
3962 8 : if (c->ext.actual->next->expr != NULL)
3963 1 : kind = c->ext.actual->next->expr->ts.kind;
3964 : else
3965 7 : kind = gfc_default_integer_kind;
3966 :
3967 8 : name = gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind);
3968 8 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3969 8 : }
3970 :
3971 :
3972 : /* Resolve the get_command intrinsic subroutine. */
3973 :
3974 : void
3975 3 : gfc_resolve_get_command (gfc_code *c)
3976 : {
3977 3 : const char *name;
3978 3 : int kind;
3979 3 : kind = gfc_default_integer_kind;
3980 3 : name = gfc_get_string (PREFIX ("get_command_i%d"), kind);
3981 3 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3982 3 : }
3983 :
3984 :
3985 : /* Resolve the get_command_argument intrinsic subroutine. */
3986 :
3987 : void
3988 4 : gfc_resolve_get_command_argument (gfc_code *c)
3989 : {
3990 4 : const char *name;
3991 4 : int kind;
3992 4 : kind = gfc_default_integer_kind;
3993 4 : name = gfc_get_string (PREFIX ("get_command_argument_i%d"), kind);
3994 4 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3995 4 : }
3996 :
3997 :
3998 : /* Resolve the get_environment_variable intrinsic subroutine. */
3999 :
4000 : void
4001 26 : gfc_resolve_get_environment_variable (gfc_code *code)
4002 : {
4003 26 : const char *name;
4004 26 : int kind;
4005 26 : kind = gfc_default_integer_kind;
4006 26 : name = gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind);
4007 26 : code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4008 26 : }
4009 :
4010 :
4011 : void
4012 0 : gfc_resolve_signal_sub (gfc_code *c)
4013 : {
4014 0 : const char *name;
4015 0 : gfc_expr *number, *handler, *status;
4016 0 : gfc_typespec ts;
4017 0 : gfc_clear_ts (&ts);
4018 :
4019 0 : number = c->ext.actual->expr;
4020 0 : handler = c->ext.actual->next->expr;
4021 0 : status = c->ext.actual->next->next->expr;
4022 0 : ts.type = BT_INTEGER;
4023 0 : ts.kind = gfc_c_int_kind;
4024 :
4025 : /* handler can be either BT_INTEGER or BT_PROCEDURE */
4026 0 : if (handler->ts.type == BT_INTEGER)
4027 : {
4028 0 : if (handler->ts.kind != gfc_c_int_kind)
4029 0 : gfc_convert_type (handler, &ts, 2);
4030 0 : name = gfc_get_string (PREFIX ("signal_sub_int"));
4031 : }
4032 : else
4033 0 : name = gfc_get_string (PREFIX ("signal_sub"));
4034 :
4035 0 : if (number->ts.kind != gfc_c_int_kind)
4036 0 : gfc_convert_type (number, &ts, 2);
4037 0 : if (status != NULL && status->ts.kind != gfc_c_int_kind)
4038 0 : gfc_convert_type (status, &ts, 2);
4039 :
4040 0 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4041 0 : }
4042 :
4043 :
4044 : /* Resolve the SYSTEM intrinsic subroutine. */
4045 :
4046 : void
4047 2 : gfc_resolve_system_sub (gfc_code *c)
4048 : {
4049 2 : const char *name;
4050 2 : name = gfc_get_string (PREFIX ("system_sub"));
4051 2 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4052 2 : }
4053 :
4054 :
4055 : /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
4056 :
4057 : void
4058 197 : gfc_resolve_system_clock (gfc_code *c)
4059 : {
4060 197 : const char *name;
4061 197 : int kind;
4062 197 : gfc_expr *count = c->ext.actual->expr;
4063 197 : gfc_expr *count_max = c->ext.actual->next->next->expr;
4064 :
4065 : /* The INTEGER(8) version has higher precision, it is used if both COUNT
4066 : and COUNT_MAX can hold 64-bit values, or are absent. */
4067 197 : if ((!count || count->ts.kind >= 8)
4068 74 : && (!count_max || count_max->ts.kind >= 8))
4069 : kind = 8;
4070 : else
4071 159 : kind = gfc_default_integer_kind;
4072 :
4073 197 : name = gfc_get_string (PREFIX ("system_clock_%d"), kind);
4074 197 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4075 197 : }
4076 :
4077 :
4078 : /* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine. */
4079 : void
4080 20 : gfc_resolve_execute_command_line (gfc_code *c)
4081 : {
4082 20 : const char *name;
4083 20 : name = gfc_get_string (PREFIX ("execute_command_line_i%d"),
4084 : gfc_default_integer_kind);
4085 20 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4086 20 : }
4087 :
4088 :
4089 : /* Resolve the EXIT intrinsic subroutine. */
4090 :
4091 : void
4092 3 : gfc_resolve_exit (gfc_code *c)
4093 : {
4094 3 : const char *name;
4095 3 : gfc_typespec ts;
4096 3 : gfc_expr *n;
4097 3 : gfc_clear_ts (&ts);
4098 :
4099 : /* The STATUS argument has to be of default kind. If it is not,
4100 : we convert it. */
4101 3 : ts.type = BT_INTEGER;
4102 3 : ts.kind = gfc_default_integer_kind;
4103 3 : n = c->ext.actual->expr;
4104 3 : if (n != NULL && n->ts.kind != ts.kind)
4105 0 : gfc_convert_type (n, &ts, 2);
4106 :
4107 3 : name = gfc_get_string (PREFIX ("exit_i%d"), ts.kind);
4108 3 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4109 3 : }
4110 :
4111 :
4112 : /* Resolve the FLUSH intrinsic subroutine. */
4113 :
4114 : void
4115 25 : gfc_resolve_flush (gfc_code *c)
4116 : {
4117 25 : const char *name;
4118 25 : gfc_typespec ts;
4119 25 : gfc_expr *n;
4120 25 : gfc_clear_ts (&ts);
4121 :
4122 25 : ts.type = BT_INTEGER;
4123 25 : ts.kind = gfc_default_integer_kind;
4124 25 : n = c->ext.actual->expr;
4125 25 : if (n != NULL && n->ts.kind != ts.kind)
4126 0 : gfc_convert_type (n, &ts, 2);
4127 :
4128 25 : name = gfc_get_string (PREFIX ("flush_i%d"), ts.kind);
4129 25 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4130 25 : }
4131 :
4132 :
4133 : void
4134 1 : gfc_resolve_ctime_sub (gfc_code *c)
4135 : {
4136 1 : gfc_typespec ts;
4137 1 : gfc_clear_ts (&ts);
4138 :
4139 : /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
4140 1 : if (c->ext.actual->expr->ts.kind != 8)
4141 : {
4142 0 : ts.type = BT_INTEGER;
4143 0 : ts.kind = 8;
4144 0 : ts.u.derived = NULL;
4145 0 : ts.u.cl = NULL;
4146 0 : gfc_convert_type (c->ext.actual->expr, &ts, 2);
4147 : }
4148 :
4149 1 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
4150 1 : }
4151 :
4152 :
4153 : void
4154 1 : gfc_resolve_fdate_sub (gfc_code *c)
4155 : {
4156 1 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
4157 1 : }
4158 :
4159 :
4160 : void
4161 2 : gfc_resolve_gerror (gfc_code *c)
4162 : {
4163 2 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
4164 2 : }
4165 :
4166 :
4167 : void
4168 2 : gfc_resolve_getlog (gfc_code *c)
4169 : {
4170 2 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
4171 2 : }
4172 :
4173 :
4174 : void
4175 9 : gfc_resolve_hostnm_sub (gfc_code *c)
4176 : {
4177 9 : const char *name;
4178 9 : int kind;
4179 :
4180 9 : if (c->ext.actual->next->expr != NULL)
4181 7 : kind = c->ext.actual->next->expr->ts.kind;
4182 : else
4183 2 : kind = gfc_default_integer_kind;
4184 :
4185 9 : name = gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind);
4186 9 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4187 9 : }
4188 :
4189 :
4190 : void
4191 2 : gfc_resolve_perror (gfc_code *c)
4192 : {
4193 2 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
4194 2 : }
4195 :
4196 : /* Resolve the STAT and FSTAT intrinsic subroutines. */
4197 :
4198 : void
4199 24 : gfc_resolve_stat_sub (gfc_code *c)
4200 : {
4201 24 : const char *name;
4202 24 : gfc_typespec *ts;
4203 24 : ts = &c->ext.actual->next->expr->ts;
4204 24 : name = gfc_get_string (PREFIX ("stat_i%d_sub"), ts->kind);
4205 24 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4206 24 : }
4207 :
4208 :
4209 : void
4210 18 : gfc_resolve_lstat_sub (gfc_code *c)
4211 : {
4212 18 : const char *name;
4213 18 : gfc_typespec *ts;
4214 18 : ts = &c->ext.actual->next->expr->ts;
4215 18 : name = gfc_get_string (PREFIX ("lstat_i%d_sub"), ts->kind);
4216 18 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4217 18 : }
4218 :
4219 :
4220 : void
4221 23 : gfc_resolve_fstat_sub (gfc_code *c)
4222 : {
4223 23 : const char *name;
4224 23 : gfc_expr *u;
4225 23 : gfc_typespec *ts;
4226 :
4227 23 : u = c->ext.actual->expr;
4228 23 : ts = &c->ext.actual->next->expr->ts;
4229 23 : if (u->ts.kind != ts->kind)
4230 10 : gfc_convert_type (u, ts, 2);
4231 23 : name = gfc_get_string (PREFIX ("fstat_i%d_sub"), ts->kind);
4232 23 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4233 23 : }
4234 :
4235 :
4236 : void
4237 44 : gfc_resolve_fgetc_sub (gfc_code *c)
4238 : {
4239 44 : const char *name;
4240 44 : gfc_typespec ts;
4241 44 : gfc_expr *u, *st;
4242 44 : gfc_clear_ts (&ts);
4243 :
4244 44 : u = c->ext.actual->expr;
4245 44 : st = c->ext.actual->next->next->expr;
4246 :
4247 44 : if (u->ts.kind != gfc_c_int_kind)
4248 : {
4249 0 : ts.type = BT_INTEGER;
4250 0 : ts.kind = gfc_c_int_kind;
4251 0 : ts.u.derived = NULL;
4252 0 : ts.u.cl = NULL;
4253 0 : gfc_convert_type (u, &ts, 2);
4254 : }
4255 :
4256 44 : if (st != NULL)
4257 31 : name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), st->ts.kind);
4258 : else
4259 13 : name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind);
4260 :
4261 44 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4262 44 : }
4263 :
4264 :
4265 : void
4266 2 : gfc_resolve_fget_sub (gfc_code *c)
4267 : {
4268 2 : const char *name;
4269 2 : gfc_expr *st;
4270 :
4271 2 : st = c->ext.actual->next->expr;
4272 2 : if (st != NULL)
4273 1 : name = gfc_get_string (PREFIX ("fget_i%d_sub"), st->ts.kind);
4274 : else
4275 1 : name = gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind);
4276 :
4277 2 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4278 2 : }
4279 :
4280 :
4281 : void
4282 33 : gfc_resolve_fputc_sub (gfc_code *c)
4283 : {
4284 33 : const char *name;
4285 33 : gfc_typespec ts;
4286 33 : gfc_expr *u, *st;
4287 33 : gfc_clear_ts (&ts);
4288 :
4289 33 : u = c->ext.actual->expr;
4290 33 : st = c->ext.actual->next->next->expr;
4291 :
4292 33 : if (u->ts.kind != gfc_c_int_kind)
4293 : {
4294 0 : ts.type = BT_INTEGER;
4295 0 : ts.kind = gfc_c_int_kind;
4296 0 : ts.u.derived = NULL;
4297 0 : ts.u.cl = NULL;
4298 0 : gfc_convert_type (u, &ts, 2);
4299 : }
4300 :
4301 33 : if (st != NULL)
4302 25 : name = gfc_get_string (PREFIX ("fputc_i%d_sub"), st->ts.kind);
4303 : else
4304 8 : name = gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind);
4305 :
4306 33 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4307 33 : }
4308 :
4309 :
4310 : void
4311 2 : gfc_resolve_fput_sub (gfc_code *c)
4312 : {
4313 2 : const char *name;
4314 2 : gfc_expr *st;
4315 :
4316 2 : st = c->ext.actual->next->expr;
4317 2 : if (st != NULL)
4318 1 : name = gfc_get_string (PREFIX ("fput_i%d_sub"), st->ts.kind);
4319 : else
4320 1 : name = gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind);
4321 :
4322 2 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4323 2 : }
4324 :
4325 :
4326 : void
4327 60 : gfc_resolve_fseek_sub (gfc_code *c)
4328 : {
4329 60 : gfc_expr *unit;
4330 60 : gfc_expr *offset;
4331 60 : gfc_expr *whence;
4332 60 : gfc_typespec ts;
4333 60 : gfc_clear_ts (&ts);
4334 :
4335 60 : unit = c->ext.actual->expr;
4336 60 : offset = c->ext.actual->next->expr;
4337 60 : whence = c->ext.actual->next->next->expr;
4338 :
4339 60 : if (unit->ts.kind != gfc_c_int_kind)
4340 : {
4341 0 : ts.type = BT_INTEGER;
4342 0 : ts.kind = gfc_c_int_kind;
4343 0 : ts.u.derived = NULL;
4344 0 : ts.u.cl = NULL;
4345 0 : gfc_convert_type (unit, &ts, 2);
4346 : }
4347 :
4348 60 : if (offset->ts.kind != gfc_intio_kind)
4349 : {
4350 60 : ts.type = BT_INTEGER;
4351 60 : ts.kind = gfc_intio_kind;
4352 60 : ts.u.derived = NULL;
4353 60 : ts.u.cl = NULL;
4354 60 : gfc_convert_type (offset, &ts, 2);
4355 : }
4356 :
4357 60 : if (whence->ts.kind != gfc_c_int_kind)
4358 : {
4359 0 : ts.type = BT_INTEGER;
4360 0 : ts.kind = gfc_c_int_kind;
4361 0 : ts.u.derived = NULL;
4362 0 : ts.u.cl = NULL;
4363 0 : gfc_convert_type (whence, &ts, 2);
4364 : }
4365 :
4366 60 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
4367 60 : }
4368 :
4369 : void
4370 36 : gfc_resolve_ftell_sub (gfc_code *c)
4371 : {
4372 36 : const char *name;
4373 36 : gfc_expr *unit;
4374 36 : gfc_expr *offset;
4375 36 : gfc_typespec ts;
4376 36 : gfc_clear_ts (&ts);
4377 :
4378 36 : unit = c->ext.actual->expr;
4379 36 : offset = c->ext.actual->next->expr;
4380 :
4381 36 : if (unit->ts.kind != gfc_c_int_kind)
4382 : {
4383 0 : ts.type = BT_INTEGER;
4384 0 : ts.kind = gfc_c_int_kind;
4385 0 : ts.u.derived = NULL;
4386 0 : ts.u.cl = NULL;
4387 0 : gfc_convert_type (unit, &ts, 2);
4388 : }
4389 :
4390 36 : name = gfc_get_string (PREFIX ("ftell_i%d_sub"), offset->ts.kind);
4391 36 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4392 36 : }
4393 :
4394 :
4395 : void
4396 1 : gfc_resolve_ttynam_sub (gfc_code *c)
4397 : {
4398 1 : gfc_typespec ts;
4399 1 : gfc_clear_ts (&ts);
4400 :
4401 1 : if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
4402 : {
4403 0 : ts.type = BT_INTEGER;
4404 0 : ts.kind = gfc_c_int_kind;
4405 0 : ts.u.derived = NULL;
4406 0 : ts.u.cl = NULL;
4407 0 : gfc_convert_type (c->ext.actual->expr, &ts, 2);
4408 : }
4409 :
4410 1 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
4411 1 : }
4412 :
4413 :
4414 : /* Resolve the UMASK intrinsic subroutine. */
4415 :
4416 : void
4417 0 : gfc_resolve_umask_sub (gfc_code *c)
4418 : {
4419 0 : const char *name;
4420 0 : int kind;
4421 :
4422 0 : if (c->ext.actual->next->expr != NULL)
4423 0 : kind = c->ext.actual->next->expr->ts.kind;
4424 : else
4425 0 : kind = gfc_default_integer_kind;
4426 :
4427 0 : name = gfc_get_string (PREFIX ("umask_i%d_sub"), kind);
4428 0 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4429 0 : }
4430 :
4431 : /* Resolve the UNLINK intrinsic subroutine. */
4432 :
4433 : void
4434 10 : gfc_resolve_unlink_sub (gfc_code *c)
4435 : {
4436 10 : const char *name;
4437 10 : int kind;
4438 :
4439 10 : if (c->ext.actual->next->expr != NULL)
4440 1 : kind = c->ext.actual->next->expr->ts.kind;
4441 : else
4442 9 : kind = gfc_default_integer_kind;
4443 :
4444 10 : name = gfc_get_string (PREFIX ("unlink_i%d_sub"), kind);
4445 10 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4446 10 : }
|
