1 /* Intrinsic function resolution.
2 Copyright (C) 2000-2024 Free Software Foundation, Inc.
3 Contributed by Andy Vaught & Katherine Holcomb
5 This file is part of GCC.
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
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
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/>. */
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. */
31 #include "coretypes.h"
34 #include "stringpool.h"
35 #include "intrinsic.h"
36 #include "constructor.h"
40 /* Given printf-like arguments, return a stable version of the result string.
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. */
48 gfc_get_string (const char *format
, ...)
50 /* Provide sufficient space for "_F.caf_token__symbol.symbol_MOD_symbol". */
51 char temp_name
[15 + 2*GFC_MAX_SYMBOL_LEN
+ 5 + GFC_MAX_SYMBOL_LEN
+ 1];
56 /* Handle common case without vsnprintf and temporary buffer. */
57 if (format
[0] == '%' && format
[1] == 's' && format
[2] == '\0')
59 va_start (ap
, format
);
60 str
= va_arg (ap
, const char *);
66 va_start (ap
, format
);
67 ret
= vsnprintf (temp_name
, sizeof (temp_name
), format
, ap
);
69 if (ret
< 1 || ret
>= (int) sizeof (temp_name
)) /* Reject truncation. */
70 gfc_internal_error ("identifier overflow: %d", ret
);
71 temp_name
[sizeof (temp_name
) - 1] = 0;
75 ident
= get_identifier (str
);
76 return IDENTIFIER_POINTER (ident
);
79 /* MERGE and SPREAD need to have source charlen's present for passing
80 to the result expression. */
82 check_charlen_present (gfc_expr
*source
)
84 if (source
->ts
.u
.cl
== NULL
)
85 source
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
87 if (source
->expr_type
== EXPR_CONSTANT
)
89 source
->ts
.u
.cl
->length
90 = gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
91 source
->value
.character
.length
);
94 else if (source
->expr_type
== EXPR_ARRAY
)
96 gfc_constructor
*c
= gfc_constructor_first (source
->value
.constructor
);
98 source
->ts
.u
.cl
->length
99 = gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
100 c
->expr
->value
.character
.length
);
101 if (source
->ts
.u
.cl
->length
== NULL
)
102 gfc_internal_error ("check_charlen_present(): length not set");
106 /* Helper function for resolving the "mask" argument. */
109 resolve_mask_arg (gfc_expr
*mask
)
117 /* For the scalar case, coerce the mask to kind=4 unconditionally
118 (because this is the only kind we have a library function
121 if (mask
->ts
.kind
!= 4)
123 ts
.type
= BT_LOGICAL
;
125 gfc_convert_type (mask
, &ts
, 2);
130 /* In the library, we access the mask with a GFC_LOGICAL_1
131 argument. No need to waste memory if we are about to create
132 a temporary array. */
133 if (mask
->expr_type
== EXPR_OP
&& mask
->ts
.kind
!= 1)
135 ts
.type
= BT_LOGICAL
;
137 gfc_convert_type_warn (mask
, &ts
, 2, 0);
144 resolve_bound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
,
145 const char *name
, bool coarray
)
147 f
->ts
.type
= BT_INTEGER
;
149 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
151 f
->ts
.kind
= gfc_default_integer_kind
;
155 if (array
->rank
!= -1)
157 /* Assume f->rank gives the size of the shape, because there is no
158 other way to determine the size. */
159 if (!f
->shape
|| f
->rank
!= 1)
162 gfc_free_shape (&f
->shape
, f
->rank
);
163 f
->shape
= gfc_get_shape (1);
165 mpz_init_set_ui (f
->shape
[0], coarray
? array
->corank
: array
->rank
);
167 /* Applying bound to a coarray always results in a regular array. */
172 f
->value
.function
.name
= gfc_get_string ("%s", name
);
177 resolve_transformational (const char *name
, gfc_expr
*f
, gfc_expr
*array
,
178 gfc_expr
*dim
, gfc_expr
*mask
)
191 resolve_mask_arg (mask
);
198 f
->rank
= array
->rank
- 1;
199 f
->shape
= gfc_copy_shape_excluding (array
->shape
, array
->rank
, dim
);
200 gfc_resolve_dim_arg (dim
);
203 f
->value
.function
.name
204 = gfc_get_string (PREFIX ("%s%s_%c%d"), prefix
, name
,
205 gfc_type_letter (array
->ts
.type
),
206 gfc_type_abi_kind (&array
->ts
));
210 /********************** Resolution functions **********************/
214 gfc_resolve_abs (gfc_expr
*f
, gfc_expr
*a
)
217 if (f
->ts
.type
== BT_COMPLEX
)
218 f
->ts
.type
= BT_REAL
;
220 f
->value
.function
.name
221 = gfc_get_string ("__abs_%c%d", gfc_type_letter (a
->ts
.type
),
222 gfc_type_abi_kind (&a
->ts
));
227 gfc_resolve_access (gfc_expr
*f
, gfc_expr
*name ATTRIBUTE_UNUSED
,
228 gfc_expr
*mode ATTRIBUTE_UNUSED
)
230 f
->ts
.type
= BT_INTEGER
;
231 f
->ts
.kind
= gfc_c_int_kind
;
232 f
->value
.function
.name
= PREFIX ("access_func");
237 gfc_resolve_adjustl (gfc_expr
*f
, gfc_expr
*string
)
239 f
->ts
.type
= BT_CHARACTER
;
240 f
->ts
.kind
= string
->ts
.kind
;
241 if (string
->ts
.deferred
)
243 else if (string
->ts
.u
.cl
)
244 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, string
->ts
.u
.cl
);
246 f
->value
.function
.name
= gfc_get_string ("__adjustl_s%d", f
->ts
.kind
);
251 gfc_resolve_adjustr (gfc_expr
*f
, gfc_expr
*string
)
253 f
->ts
.type
= BT_CHARACTER
;
254 f
->ts
.kind
= string
->ts
.kind
;
255 if (string
->ts
.deferred
)
257 else if (string
->ts
.u
.cl
)
258 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, string
->ts
.u
.cl
);
260 f
->value
.function
.name
= gfc_get_string ("__adjustr_s%d", f
->ts
.kind
);
265 gfc_resolve_char_achar (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*kind
,
268 f
->ts
.type
= BT_CHARACTER
;
269 f
->ts
.kind
= (kind
== NULL
)
270 ? gfc_default_character_kind
: mpz_get_si (kind
->value
.integer
);
271 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
272 f
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
274 f
->value
.function
.name
275 = gfc_get_string ("__%schar_%d_%c%d", is_achar
? "a" : "", f
->ts
.kind
,
276 gfc_type_letter (x
->ts
.type
),
277 gfc_type_abi_kind (&x
->ts
));
282 gfc_resolve_achar (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*kind
)
284 gfc_resolve_char_achar (f
, x
, kind
, true);
289 gfc_resolve_acos (gfc_expr
*f
, gfc_expr
*x
)
292 f
->value
.function
.name
293 = gfc_get_string ("__acos_%c%d", gfc_type_letter (x
->ts
.type
),
294 gfc_type_abi_kind (&x
->ts
));
299 gfc_resolve_acosh (gfc_expr
*f
, gfc_expr
*x
)
302 f
->value
.function
.name
303 = gfc_get_string ("__acosh_%c%d", gfc_type_letter (x
->ts
.type
),
304 gfc_type_abi_kind (&x
->ts
));
309 gfc_resolve_aimag (gfc_expr
*f
, gfc_expr
*x
)
311 f
->ts
.type
= BT_REAL
;
312 f
->ts
.kind
= x
->ts
.kind
;
313 f
->value
.function
.name
314 = gfc_get_string ("__aimag_%c%d", gfc_type_letter (x
->ts
.type
),
315 gfc_type_abi_kind (&x
->ts
));
320 gfc_resolve_and (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
322 f
->ts
.type
= i
->ts
.type
;
323 f
->ts
.kind
= gfc_kind_max (i
, j
);
325 if (i
->ts
.kind
!= j
->ts
.kind
)
327 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
328 gfc_convert_type (j
, &i
->ts
, 2);
330 gfc_convert_type (i
, &j
->ts
, 2);
333 f
->value
.function
.name
334 = gfc_get_string ("__and_%c%d", gfc_type_letter (i
->ts
.type
),
335 gfc_type_abi_kind (&f
->ts
));
340 gfc_resolve_aint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
345 f
->ts
.type
= a
->ts
.type
;
346 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
348 if (a
->ts
.kind
!= f
->ts
.kind
)
350 ts
.type
= f
->ts
.type
;
351 ts
.kind
= f
->ts
.kind
;
352 gfc_convert_type (a
, &ts
, 2);
354 /* The resolved name is only used for specific intrinsics where
355 the return kind is the same as the arg kind. */
356 f
->value
.function
.name
357 = gfc_get_string ("__aint_%c%d", gfc_type_letter (a
->ts
.type
),
358 gfc_type_abi_kind (&a
->ts
));
363 gfc_resolve_dint (gfc_expr
*f
, gfc_expr
*a
)
365 gfc_resolve_aint (f
, a
, NULL
);
370 gfc_resolve_all (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
)
376 gfc_resolve_dim_arg (dim
);
377 f
->rank
= mask
->rank
- 1;
378 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
381 f
->value
.function
.name
382 = gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask
->ts
.type
),
383 gfc_type_abi_kind (&mask
->ts
));
388 gfc_resolve_anint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
393 f
->ts
.type
= a
->ts
.type
;
394 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
396 if (a
->ts
.kind
!= f
->ts
.kind
)
398 ts
.type
= f
->ts
.type
;
399 ts
.kind
= f
->ts
.kind
;
400 gfc_convert_type (a
, &ts
, 2);
403 /* The resolved name is only used for specific intrinsics where
404 the return kind is the same as the arg kind. */
405 f
->value
.function
.name
406 = gfc_get_string ("__anint_%c%d", gfc_type_letter (a
->ts
.type
),
407 gfc_type_abi_kind (&a
->ts
));
412 gfc_resolve_dnint (gfc_expr
*f
, gfc_expr
*a
)
414 gfc_resolve_anint (f
, a
, NULL
);
419 gfc_resolve_any (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
)
425 gfc_resolve_dim_arg (dim
);
426 f
->rank
= mask
->rank
- 1;
427 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
430 f
->value
.function
.name
431 = gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask
->ts
.type
),
432 gfc_type_abi_kind (&mask
->ts
));
437 gfc_resolve_asin (gfc_expr
*f
, gfc_expr
*x
)
440 f
->value
.function
.name
441 = gfc_get_string ("__asin_%c%d", gfc_type_letter (x
->ts
.type
),
442 gfc_type_abi_kind (&x
->ts
));
446 gfc_resolve_asinh (gfc_expr
*f
, gfc_expr
*x
)
449 f
->value
.function
.name
450 = gfc_get_string ("__asinh_%c%d", gfc_type_letter (x
->ts
.type
),
451 gfc_type_abi_kind (&x
->ts
));
455 gfc_resolve_atan (gfc_expr
*f
, gfc_expr
*x
)
458 f
->value
.function
.name
459 = gfc_get_string ("__atan_%c%d", gfc_type_letter (x
->ts
.type
),
460 gfc_type_abi_kind (&x
->ts
));
464 gfc_resolve_atanh (gfc_expr
*f
, gfc_expr
*x
)
467 f
->value
.function
.name
468 = gfc_get_string ("__atanh_%c%d", gfc_type_letter (x
->ts
.type
),
469 gfc_type_abi_kind (&x
->ts
));
473 gfc_resolve_atan2 (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
476 f
->value
.function
.name
477 = gfc_get_string ("__atan2_%c%d", gfc_type_letter (x
->ts
.type
),
478 gfc_type_abi_kind (&x
->ts
));
482 /* Resolve the BESYN and BESJN intrinsics. */
485 gfc_resolve_besn (gfc_expr
*f
, gfc_expr
*n
, gfc_expr
*x
)
491 if (n
->ts
.kind
!= gfc_c_int_kind
)
493 ts
.type
= BT_INTEGER
;
494 ts
.kind
= gfc_c_int_kind
;
495 gfc_convert_type (n
, &ts
, 2);
497 f
->value
.function
.name
= gfc_get_string ("<intrinsic>");
502 gfc_resolve_bessel_n2 (gfc_expr
*f
, gfc_expr
*n1
, gfc_expr
*n2
, gfc_expr
*x
)
509 if (n1
->expr_type
== EXPR_CONSTANT
&& n2
->expr_type
== EXPR_CONSTANT
)
511 f
->shape
= gfc_get_shape (1);
512 mpz_init (f
->shape
[0]);
513 mpz_sub (f
->shape
[0], n2
->value
.integer
, n1
->value
.integer
);
514 mpz_add_ui (f
->shape
[0], f
->shape
[0], 1);
517 if (n1
->ts
.kind
!= gfc_c_int_kind
)
519 ts
.type
= BT_INTEGER
;
520 ts
.kind
= gfc_c_int_kind
;
521 gfc_convert_type (n1
, &ts
, 2);
524 if (n2
->ts
.kind
!= gfc_c_int_kind
)
526 ts
.type
= BT_INTEGER
;
527 ts
.kind
= gfc_c_int_kind
;
528 gfc_convert_type (n2
, &ts
, 2);
531 if (f
->value
.function
.isym
->id
== GFC_ISYM_JN2
)
532 f
->value
.function
.name
= gfc_get_string (PREFIX ("bessel_jn_r%d"),
533 gfc_type_abi_kind (&f
->ts
));
535 f
->value
.function
.name
= gfc_get_string (PREFIX ("bessel_yn_r%d"),
536 gfc_type_abi_kind (&f
->ts
));
541 gfc_resolve_btest (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos
)
543 f
->ts
.type
= BT_LOGICAL
;
544 f
->ts
.kind
= gfc_default_logical_kind
;
545 f
->value
.function
.name
546 = gfc_get_string ("__btest_%d_%d", i
->ts
.kind
, pos
->ts
.kind
);
551 gfc_resolve_c_loc (gfc_expr
*f
, gfc_expr
*x ATTRIBUTE_UNUSED
)
553 f
->ts
= f
->value
.function
.isym
->ts
;
558 gfc_resolve_c_funloc (gfc_expr
*f
, gfc_expr
*x ATTRIBUTE_UNUSED
)
560 f
->ts
= f
->value
.function
.isym
->ts
;
565 gfc_resolve_ceiling (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
567 f
->ts
.type
= BT_INTEGER
;
568 f
->ts
.kind
= (kind
== NULL
)
569 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
570 f
->value
.function
.name
571 = gfc_get_string ("__ceiling_%d_%c%d", f
->ts
.kind
,
572 gfc_type_letter (a
->ts
.type
),
573 gfc_type_abi_kind (&a
->ts
));
578 gfc_resolve_char (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
580 gfc_resolve_char_achar (f
, a
, kind
, false);
585 gfc_resolve_chdir (gfc_expr
*f
, gfc_expr
*d ATTRIBUTE_UNUSED
)
587 f
->ts
.type
= BT_INTEGER
;
588 f
->ts
.kind
= gfc_default_integer_kind
;
589 f
->value
.function
.name
= gfc_get_string (PREFIX ("chdir_i%d"), f
->ts
.kind
);
594 gfc_resolve_chdir_sub (gfc_code
*c
)
599 if (c
->ext
.actual
->next
->expr
!= NULL
)
600 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
602 kind
= gfc_default_integer_kind
;
604 name
= gfc_get_string (PREFIX ("chdir_i%d_sub"), kind
);
605 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
610 gfc_resolve_chmod (gfc_expr
*f
, gfc_expr
*name ATTRIBUTE_UNUSED
,
611 gfc_expr
*mode ATTRIBUTE_UNUSED
)
613 f
->ts
.type
= BT_INTEGER
;
614 f
->ts
.kind
= gfc_c_int_kind
;
615 f
->value
.function
.name
= PREFIX ("chmod_func");
620 gfc_resolve_chmod_sub (gfc_code
*c
)
625 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
626 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
628 kind
= gfc_default_integer_kind
;
630 name
= gfc_get_string (PREFIX ("chmod_i%d_sub"), kind
);
631 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
636 gfc_resolve_cmplx (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*kind
)
638 f
->ts
.type
= BT_COMPLEX
;
639 f
->ts
.kind
= (kind
== NULL
)
640 ? gfc_default_real_kind
: mpz_get_si (kind
->value
.integer
);
643 f
->value
.function
.name
644 = gfc_get_string ("__cmplx0_%d_%c%d", f
->ts
.kind
,
645 gfc_type_letter (x
->ts
.type
),
646 gfc_type_abi_kind (&x
->ts
));
648 f
->value
.function
.name
649 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f
->ts
.kind
,
650 gfc_type_letter (x
->ts
.type
),
651 gfc_type_abi_kind (&x
->ts
),
652 gfc_type_letter (y
->ts
.type
),
653 gfc_type_abi_kind (&y
->ts
));
658 gfc_resolve_dcmplx (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
)
660 gfc_resolve_cmplx (f
, x
, y
, gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
661 gfc_default_double_kind
));
666 gfc_resolve_complex (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
)
670 if (x
->ts
.type
== BT_INTEGER
)
672 if (y
->ts
.type
== BT_INTEGER
)
673 kind
= gfc_default_real_kind
;
679 if (y
->ts
.type
== BT_REAL
)
680 kind
= (x
->ts
.kind
> y
->ts
.kind
) ? x
->ts
.kind
: y
->ts
.kind
;
685 f
->ts
.type
= BT_COMPLEX
;
687 f
->value
.function
.name
688 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f
->ts
.kind
,
689 gfc_type_letter (x
->ts
.type
),
690 gfc_type_abi_kind (&x
->ts
),
691 gfc_type_letter (y
->ts
.type
),
692 gfc_type_abi_kind (&y
->ts
));
697 gfc_resolve_conjg (gfc_expr
*f
, gfc_expr
*x
)
700 f
->value
.function
.name
= gfc_get_string ("__conjg_%d", x
->ts
.kind
);
705 gfc_resolve_cos (gfc_expr
*f
, gfc_expr
*x
)
708 f
->value
.function
.name
709 = gfc_get_string ("__cos_%c%d", gfc_type_letter (x
->ts
.type
),
710 gfc_type_abi_kind (&x
->ts
));
715 gfc_resolve_cosh (gfc_expr
*f
, gfc_expr
*x
)
718 f
->value
.function
.name
719 = gfc_get_string ("__cosh_%c%d", gfc_type_letter (x
->ts
.type
),
720 gfc_type_abi_kind (&x
->ts
));
725 gfc_resolve_count (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
727 f
->ts
.type
= BT_INTEGER
;
729 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
731 f
->ts
.kind
= gfc_default_integer_kind
;
735 f
->rank
= mask
->rank
- 1;
736 gfc_resolve_dim_arg (dim
);
737 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
740 resolve_mask_arg (mask
);
742 f
->value
.function
.name
743 = gfc_get_string (PREFIX ("count_%d_%c"), gfc_type_abi_kind (&f
->ts
),
744 gfc_type_letter (mask
->ts
.type
));
749 gfc_resolve_cshift (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*shift
,
754 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
755 gfc_resolve_substring_charlen (array
);
758 f
->rank
= array
->rank
;
759 f
->corank
= array
->corank
;
760 f
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
767 /* If dim kind is greater than default integer we need to use the larger. */
768 m
= gfc_default_integer_kind
;
770 m
= m
< dim
->ts
.kind
? dim
->ts
.kind
: m
;
772 /* Convert shift to at least m, so we don't need
773 kind=1 and kind=2 versions of the library functions. */
774 if (shift
->ts
.kind
< m
)
778 ts
.type
= BT_INTEGER
;
780 gfc_convert_type_warn (shift
, &ts
, 2, 0);
785 if (dim
->expr_type
!= EXPR_CONSTANT
&& dim
->symtree
!= NULL
786 && dim
->symtree
->n
.sym
->attr
.optional
)
788 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
789 dim
->representation
.length
= shift
->ts
.kind
;
793 gfc_resolve_dim_arg (dim
);
794 /* Convert dim to shift's kind to reduce variations. */
795 if (dim
->ts
.kind
!= shift
->ts
.kind
)
796 gfc_convert_type_warn (dim
, &shift
->ts
, 2, 0);
800 if (array
->ts
.type
== BT_CHARACTER
)
802 if (array
->ts
.kind
== gfc_default_character_kind
)
803 f
->value
.function
.name
804 = gfc_get_string (PREFIX ("cshift%d_%d_char"), n
, shift
->ts
.kind
);
806 f
->value
.function
.name
807 = gfc_get_string (PREFIX ("cshift%d_%d_char%d"), n
, shift
->ts
.kind
,
811 f
->value
.function
.name
812 = gfc_get_string (PREFIX ("cshift%d_%d"), n
, shift
->ts
.kind
);
817 gfc_resolve_ctime (gfc_expr
*f
, gfc_expr
*time
)
822 f
->ts
.type
= BT_CHARACTER
;
823 f
->ts
.kind
= gfc_default_character_kind
;
825 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
826 if (time
->ts
.kind
!= 8)
828 ts
.type
= BT_INTEGER
;
832 gfc_convert_type (time
, &ts
, 2);
835 f
->value
.function
.name
= gfc_get_string (PREFIX ("ctime"));
840 gfc_resolve_dble (gfc_expr
*f
, gfc_expr
*a
)
842 f
->ts
.type
= BT_REAL
;
843 f
->ts
.kind
= gfc_default_double_kind
;
844 f
->value
.function
.name
845 = gfc_get_string ("__dble_%c%d", gfc_type_letter (a
->ts
.type
),
846 gfc_type_abi_kind (&a
->ts
));
851 gfc_resolve_dim (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
853 f
->ts
.type
= a
->ts
.type
;
855 f
->ts
.kind
= gfc_kind_max (a
,p
);
857 f
->ts
.kind
= a
->ts
.kind
;
859 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
861 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
862 gfc_convert_type (p
, &a
->ts
, 2);
864 gfc_convert_type (a
, &p
->ts
, 2);
867 f
->value
.function
.name
868 = gfc_get_string ("__dim_%c%d", gfc_type_letter (f
->ts
.type
),
869 gfc_type_abi_kind (&f
->ts
));
874 gfc_resolve_dot_product (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b
)
878 temp
.expr_type
= EXPR_OP
;
879 gfc_clear_ts (&temp
.ts
);
880 temp
.value
.op
.op
= INTRINSIC_NONE
;
881 temp
.value
.op
.op1
= a
;
882 temp
.value
.op
.op2
= b
;
883 gfc_type_convert_binary (&temp
, 1);
885 f
->value
.function
.name
886 = gfc_get_string (PREFIX ("dot_product_%c%d"),
887 gfc_type_letter (f
->ts
.type
),
888 gfc_type_abi_kind (&f
->ts
));
893 gfc_resolve_dprod (gfc_expr
*f
, gfc_expr
*a ATTRIBUTE_UNUSED
,
894 gfc_expr
*b ATTRIBUTE_UNUSED
)
896 f
->ts
.kind
= gfc_default_double_kind
;
897 f
->ts
.type
= BT_REAL
;
898 f
->value
.function
.name
= gfc_get_string ("__dprod_r%d",
899 gfc_type_abi_kind (&f
->ts
));
904 gfc_resolve_dshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j ATTRIBUTE_UNUSED
,
905 gfc_expr
*shift ATTRIBUTE_UNUSED
)
907 char c
= i
->ts
.type
== BT_INTEGER
? 'i' : 'u';
910 if (f
->value
.function
.isym
->id
== GFC_ISYM_DSHIFTL
)
911 f
->value
.function
.name
= gfc_get_string ("dshiftl_%c%d", c
, f
->ts
.kind
);
912 else if (f
->value
.function
.isym
->id
== GFC_ISYM_DSHIFTR
)
913 f
->value
.function
.name
= gfc_get_string ("dshiftr_%c%d", c
, f
->ts
.kind
);
920 gfc_resolve_eoshift (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*shift
,
921 gfc_expr
*boundary
, gfc_expr
*dim
)
925 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
926 gfc_resolve_substring_charlen (array
);
929 f
->rank
= array
->rank
;
930 f
->corank
= array
->corank
;
931 f
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
936 if (boundary
&& boundary
->rank
> 0)
939 /* If dim kind is greater than default integer we need to use the larger. */
940 m
= gfc_default_integer_kind
;
942 m
= m
< dim
->ts
.kind
? dim
->ts
.kind
: m
;
944 /* Convert shift to at least m, so we don't need
945 kind=1 and kind=2 versions of the library functions. */
946 if (shift
->ts
.kind
< m
)
950 ts
.type
= BT_INTEGER
;
952 gfc_convert_type_warn (shift
, &ts
, 2, 0);
957 if (dim
->expr_type
!= EXPR_CONSTANT
&& dim
->symtree
!= NULL
958 && dim
->symtree
->n
.sym
->attr
.optional
)
960 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
961 dim
->representation
.length
= shift
->ts
.kind
;
965 gfc_resolve_dim_arg (dim
);
966 /* Convert dim to shift's kind to reduce variations. */
967 if (dim
->ts
.kind
!= shift
->ts
.kind
)
968 gfc_convert_type_warn (dim
, &shift
->ts
, 2, 0);
972 if (array
->ts
.type
== BT_CHARACTER
)
974 if (array
->ts
.kind
== gfc_default_character_kind
)
975 f
->value
.function
.name
976 = gfc_get_string (PREFIX ("eoshift%d_%d_char"), n
, shift
->ts
.kind
);
978 f
->value
.function
.name
979 = gfc_get_string (PREFIX ("eoshift%d_%d_char%d"), n
, shift
->ts
.kind
,
983 f
->value
.function
.name
984 = gfc_get_string (PREFIX ("eoshift%d_%d"), n
, shift
->ts
.kind
);
989 gfc_resolve_exp (gfc_expr
*f
, gfc_expr
*x
)
992 f
->value
.function
.name
993 = gfc_get_string ("__exp_%c%d", gfc_type_letter (x
->ts
.type
),
994 gfc_type_abi_kind (&x
->ts
));
999 gfc_resolve_exponent (gfc_expr
*f
, gfc_expr
*x
)
1001 f
->ts
.type
= BT_INTEGER
;
1002 f
->ts
.kind
= gfc_default_integer_kind
;
1003 f
->value
.function
.name
= gfc_get_string ("__exponent_%d", x
->ts
.kind
);
1007 /* Resolve the EXTENDS_TYPE_OF intrinsic function. */
1010 gfc_resolve_extends_type_of (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*mo
)
1015 /* Prevent double resolution. */
1016 if (f
->ts
.type
== BT_LOGICAL
)
1019 /* Replace the first argument with the corresponding vtab. */
1020 if (a
->ts
.type
== BT_CLASS
)
1021 gfc_add_vptr_component (a
);
1022 else if (a
->ts
.type
== BT_DERIVED
)
1026 vtab
= gfc_find_derived_vtab (a
->ts
.u
.derived
);
1027 /* Clear the old expr. */
1028 gfc_free_ref_list (a
->ref
);
1030 memset (a
, '\0', sizeof (gfc_expr
));
1031 /* Construct a new one. */
1032 a
->expr_type
= EXPR_VARIABLE
;
1033 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
1039 /* Replace the second argument with the corresponding vtab. */
1040 if (mo
->ts
.type
== BT_CLASS
)
1041 gfc_add_vptr_component (mo
);
1042 else if (mo
->ts
.type
== BT_DERIVED
)
1046 vtab
= gfc_find_derived_vtab (mo
->ts
.u
.derived
);
1047 /* Clear the old expr. */
1049 gfc_free_ref_list (mo
->ref
);
1050 memset (mo
, '\0', sizeof (gfc_expr
));
1051 /* Construct a new one. */
1052 mo
->expr_type
= EXPR_VARIABLE
;
1053 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
1059 f
->ts
.type
= BT_LOGICAL
;
1062 f
->value
.function
.isym
->formal
->ts
= a
->ts
;
1063 f
->value
.function
.isym
->formal
->next
->ts
= mo
->ts
;
1065 /* Call library function. */
1066 f
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
1071 gfc_resolve_fdate (gfc_expr
*f
)
1073 f
->ts
.type
= BT_CHARACTER
;
1074 f
->ts
.kind
= gfc_default_character_kind
;
1075 f
->value
.function
.name
= gfc_get_string (PREFIX ("fdate"));
1080 gfc_resolve_floor (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1082 f
->ts
.type
= BT_INTEGER
;
1083 f
->ts
.kind
= (kind
== NULL
)
1084 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
1085 f
->value
.function
.name
1086 = gfc_get_string ("__floor%d_%c%d", f
->ts
.kind
,
1087 gfc_type_letter (a
->ts
.type
),
1088 gfc_type_abi_kind (&a
->ts
));
1093 gfc_resolve_fnum (gfc_expr
*f
, gfc_expr
*n
)
1095 f
->ts
.type
= BT_INTEGER
;
1096 f
->ts
.kind
= gfc_default_integer_kind
;
1097 if (n
->ts
.kind
!= f
->ts
.kind
)
1098 gfc_convert_type (n
, &f
->ts
, 2);
1099 f
->value
.function
.name
= gfc_get_string (PREFIX ("fnum_i%d"), f
->ts
.kind
);
1104 gfc_resolve_fraction (gfc_expr
*f
, gfc_expr
*x
)
1107 f
->value
.function
.name
= gfc_get_string ("__fraction_%d", x
->ts
.kind
);
1111 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
1114 gfc_resolve_g77_math1 (gfc_expr
*f
, gfc_expr
*x
)
1117 f
->value
.function
.name
= gfc_get_string ("<intrinsic>");
1122 gfc_resolve_gamma (gfc_expr
*f
, gfc_expr
*x
)
1125 f
->value
.function
.name
1126 = gfc_get_string ("__tgamma_%d", x
->ts
.kind
);
1131 gfc_resolve_getcwd (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
1133 f
->ts
.type
= BT_INTEGER
;
1135 f
->value
.function
.name
= gfc_get_string (PREFIX ("getcwd"));
1140 gfc_resolve_getgid (gfc_expr
*f
)
1142 f
->ts
.type
= BT_INTEGER
;
1144 f
->value
.function
.name
= gfc_get_string (PREFIX ("getgid"));
1149 gfc_resolve_getpid (gfc_expr
*f
)
1151 f
->ts
.type
= BT_INTEGER
;
1153 f
->value
.function
.name
= gfc_get_string (PREFIX ("getpid"));
1158 gfc_resolve_getuid (gfc_expr
*f
)
1160 f
->ts
.type
= BT_INTEGER
;
1162 f
->value
.function
.name
= gfc_get_string (PREFIX ("getuid"));
1167 gfc_resolve_hostnm (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
1169 f
->ts
.type
= BT_INTEGER
;
1171 f
->value
.function
.name
= gfc_get_string (PREFIX ("hostnm"));
1176 gfc_resolve_hypot (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
1179 f
->value
.function
.name
= gfc_get_string ("__hypot_r%d",
1180 gfc_type_abi_kind (&x
->ts
));
1185 gfc_resolve_iall (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
1187 resolve_transformational ("iall", f
, array
, dim
, mask
);
1192 gfc_resolve_iand (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1194 /* If the kind of i and j are different, then g77 cross-promoted the
1195 kinds to the largest value. The Fortran 95 standard requires the
1198 if (i
->ts
.kind
!= j
->ts
.kind
)
1200 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1201 gfc_convert_type (j
, &i
->ts
, 2);
1203 gfc_convert_type (i
, &j
->ts
, 2);
1207 const char *name
= i
->ts
.kind
== BT_UNSIGNED
? "__iand_m_%d" : "__iand_%d";
1208 f
->value
.function
.name
= gfc_get_string (name
, i
->ts
.kind
);
1213 gfc_resolve_iany (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
1215 resolve_transformational ("iany", f
, array
, dim
, mask
);
1220 gfc_resolve_ibclr (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
)
1223 const char *name
= i
->ts
.kind
== BT_UNSIGNED
? "__ibclr_m_%d" : "__ibclr_%d";
1224 f
->value
.function
.name
= gfc_get_string (name
, i
->ts
.kind
);
1229 gfc_resolve_ibits (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
,
1230 gfc_expr
*len ATTRIBUTE_UNUSED
)
1233 const char *name
= i
->ts
.kind
== BT_UNSIGNED
? "__ibits_m_%d" : "__ibits_%d";
1234 f
->value
.function
.name
= gfc_get_string (name
, i
->ts
.kind
);
1239 gfc_resolve_ibset (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
)
1242 const char *name
= i
->ts
.kind
== BT_UNSIGNED
? "__ibset_m_%d" : "__ibset_%d";
1243 f
->value
.function
.name
= gfc_get_string (name
, i
->ts
.kind
);
1248 gfc_resolve_iachar (gfc_expr
*f
, gfc_expr
*c
, gfc_expr
*kind
)
1250 f
->ts
.type
= BT_INTEGER
;
1252 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1254 f
->ts
.kind
= gfc_default_integer_kind
;
1255 f
->value
.function
.name
= gfc_get_string ("__ichar_%d", c
->ts
.kind
);
1260 gfc_resolve_ichar (gfc_expr
*f
, gfc_expr
*c
, gfc_expr
*kind
)
1262 f
->ts
.type
= BT_INTEGER
;
1264 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1266 f
->ts
.kind
= gfc_default_integer_kind
;
1267 f
->value
.function
.name
= gfc_get_string ("__ichar_%d", c
->ts
.kind
);
1272 gfc_resolve_idnint (gfc_expr
*f
, gfc_expr
*a
)
1274 gfc_resolve_nint (f
, a
, NULL
);
1279 gfc_resolve_ierrno (gfc_expr
*f
)
1281 f
->ts
.type
= BT_INTEGER
;
1282 f
->ts
.kind
= gfc_default_integer_kind
;
1283 f
->value
.function
.name
= gfc_get_string (PREFIX ("ierrno_i%d"), f
->ts
.kind
);
1288 gfc_resolve_ieor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1290 /* If the kind of i and j are different, then g77 cross-promoted the
1291 kinds to the largest value. The Fortran 95 standard requires the
1294 if (i
->ts
.kind
!= j
->ts
.kind
)
1296 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1297 gfc_convert_type (j
, &i
->ts
, 2);
1299 gfc_convert_type (i
, &j
->ts
, 2);
1302 const char *name
= i
->ts
.kind
== BT_UNSIGNED
? "__ieor_m_%d" : "__ieor_%d";
1304 f
->value
.function
.name
= gfc_get_string (name
, i
->ts
.kind
);
1309 gfc_resolve_ior (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1311 /* If the kind of i and j are different, then g77 cross-promoted the
1312 kinds to the largest value. The Fortran 95 standard requires the
1315 if (i
->ts
.kind
!= j
->ts
.kind
)
1317 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1318 gfc_convert_type (j
, &i
->ts
, 2);
1320 gfc_convert_type (i
, &j
->ts
, 2);
1323 const char *name
= i
->ts
.kind
== BT_UNSIGNED
? "__ior_m_%d" : "__ior_%d";
1325 f
->value
.function
.name
= gfc_get_string (name
, i
->ts
.kind
);
1330 gfc_resolve_index_func (gfc_expr
*f
, gfc_expr
*str
,
1331 gfc_expr
*sub_str ATTRIBUTE_UNUSED
, gfc_expr
*back
,
1337 f
->ts
.type
= BT_INTEGER
;
1339 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1341 f
->ts
.kind
= gfc_default_integer_kind
;
1343 if (back
&& back
->ts
.kind
!= gfc_default_integer_kind
)
1345 ts
.type
= BT_LOGICAL
;
1346 ts
.kind
= gfc_default_integer_kind
;
1347 ts
.u
.derived
= NULL
;
1349 gfc_convert_type (back
, &ts
, 2);
1352 f
->value
.function
.name
1353 = gfc_get_string ("__index_%d_i%d", str
->ts
.kind
, f
->ts
.kind
);
1358 gfc_resolve_int (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1360 f
->ts
.type
= BT_INTEGER
;
1361 f
->ts
.kind
= (kind
== NULL
)
1362 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
1363 f
->value
.function
.name
1364 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1365 gfc_type_letter (a
->ts
.type
),
1366 gfc_type_abi_kind (&a
->ts
));
1370 gfc_resolve_uint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1372 f
->ts
.type
= BT_UNSIGNED
;
1373 f
->ts
.kind
= (kind
== NULL
)
1374 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
1375 f
->value
.function
.name
1376 = gfc_get_string ("__uint_%d_%c%d", f
->ts
.kind
,
1377 gfc_type_letter (a
->ts
.type
),
1378 gfc_type_abi_kind (&a
->ts
));
1383 gfc_resolve_int2 (gfc_expr
*f
, gfc_expr
*a
)
1385 f
->ts
.type
= BT_INTEGER
;
1387 f
->value
.function
.name
1388 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1389 gfc_type_letter (a
->ts
.type
),
1390 gfc_type_abi_kind (&a
->ts
));
1395 gfc_resolve_int8 (gfc_expr
*f
, gfc_expr
*a
)
1397 f
->ts
.type
= BT_INTEGER
;
1399 f
->value
.function
.name
1400 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1401 gfc_type_letter (a
->ts
.type
),
1402 gfc_type_abi_kind (&a
->ts
));
1407 gfc_resolve_long (gfc_expr
*f
, gfc_expr
*a
)
1409 f
->ts
.type
= BT_INTEGER
;
1411 f
->value
.function
.name
1412 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1413 gfc_type_letter (a
->ts
.type
),
1414 gfc_type_abi_kind (&a
->ts
));
1419 gfc_resolve_iparity (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
1421 resolve_transformational ("iparity", f
, array
, dim
, mask
);
1426 gfc_resolve_isatty (gfc_expr
*f
, gfc_expr
*u
)
1431 f
->ts
.type
= BT_LOGICAL
;
1432 f
->ts
.kind
= gfc_default_integer_kind
;
1433 if (u
->ts
.kind
!= gfc_c_int_kind
)
1435 ts
.type
= BT_INTEGER
;
1436 ts
.kind
= gfc_c_int_kind
;
1437 ts
.u
.derived
= NULL
;
1439 gfc_convert_type (u
, &ts
, 2);
1442 f
->value
.function
.name
= gfc_get_string (PREFIX ("isatty_l%d"), f
->ts
.kind
);
1447 gfc_resolve_is_contiguous (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
)
1449 f
->ts
.type
= BT_LOGICAL
;
1450 f
->ts
.kind
= gfc_default_logical_kind
;
1451 f
->value
.function
.name
= gfc_get_string ("__is_contiguous");
1456 gfc_resolve_ishft (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1459 f
->value
.function
.name
1460 = gfc_get_string ("__ishft_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1465 gfc_resolve_rshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1468 f
->value
.function
.name
1469 = gfc_get_string ("__rshift_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1474 gfc_resolve_lshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1477 f
->value
.function
.name
1478 = gfc_get_string ("__lshift_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1483 gfc_resolve_ishftc (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
1487 s_kind
= (size
== NULL
) ? gfc_default_integer_kind
: size
->ts
.kind
;
1490 f
->value
.function
.name
1491 = gfc_get_string ("__ishftc_%d_%d_%d", i
->ts
.kind
, shift
->ts
.kind
, s_kind
);
1496 gfc_resolve_lbound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
1498 resolve_bound (f
, array
, dim
, kind
, "__lbound", false);
1503 gfc_resolve_lcobound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
1505 resolve_bound (f
, array
, dim
, kind
, "__lcobound", true);
1510 gfc_resolve_len (gfc_expr
*f
, gfc_expr
*string
, gfc_expr
*kind
)
1512 f
->ts
.type
= BT_INTEGER
;
1514 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1516 f
->ts
.kind
= gfc_default_integer_kind
;
1517 f
->value
.function
.name
1518 = gfc_get_string ("__len_%d_i%d", string
->ts
.kind
,
1519 gfc_default_integer_kind
);
1524 gfc_resolve_len_trim (gfc_expr
*f
, gfc_expr
*string
, gfc_expr
*kind
)
1526 f
->ts
.type
= BT_INTEGER
;
1528 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1530 f
->ts
.kind
= gfc_default_integer_kind
;
1531 f
->value
.function
.name
= gfc_get_string ("__len_trim%d", string
->ts
.kind
);
1536 gfc_resolve_lgamma (gfc_expr
*f
, gfc_expr
*x
)
1539 f
->value
.function
.name
1540 = gfc_get_string ("__lgamma_%d", x
->ts
.kind
);
1545 gfc_resolve_link (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
1546 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
1548 f
->ts
.type
= BT_INTEGER
;
1549 f
->ts
.kind
= gfc_default_integer_kind
;
1550 f
->value
.function
.name
= gfc_get_string (PREFIX ("link_i%d"), f
->ts
.kind
);
1555 gfc_resolve_loc (gfc_expr
*f
, gfc_expr
*x
)
1557 f
->ts
.type
= BT_INTEGER
;
1558 f
->ts
.kind
= gfc_index_integer_kind
;
1559 f
->value
.function
.name
= gfc_get_string ("__loc_%d", x
->ts
.kind
);
1564 gfc_resolve_log (gfc_expr
*f
, gfc_expr
*x
)
1567 f
->value
.function
.name
1568 = gfc_get_string ("__log_%c%d", gfc_type_letter (x
->ts
.type
),
1569 gfc_type_abi_kind (&x
->ts
));
1574 gfc_resolve_log10 (gfc_expr
*f
, gfc_expr
*x
)
1577 f
->value
.function
.name
1578 = gfc_get_string ("__log10_%c%d", gfc_type_letter (x
->ts
.type
),
1579 gfc_type_abi_kind (&x
->ts
));
1584 gfc_resolve_logical (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1586 f
->ts
.type
= BT_LOGICAL
;
1587 f
->ts
.kind
= (kind
== NULL
)
1588 ? gfc_default_logical_kind
: mpz_get_si (kind
->value
.integer
);
1590 f
->corank
= a
->corank
;
1592 f
->value
.function
.name
1593 = gfc_get_string ("__logical_%d_%c%d", f
->ts
.kind
,
1594 gfc_type_letter (a
->ts
.type
),
1595 gfc_type_abi_kind (&a
->ts
));
1600 gfc_resolve_matmul (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b
)
1604 if (a
->ts
.type
== BT_LOGICAL
&& b
->ts
.type
== BT_LOGICAL
)
1606 f
->ts
.type
= BT_LOGICAL
;
1607 f
->ts
.kind
= gfc_default_logical_kind
;
1611 temp
.expr_type
= EXPR_OP
;
1612 gfc_clear_ts (&temp
.ts
);
1613 temp
.value
.op
.op
= INTRINSIC_NONE
;
1614 temp
.value
.op
.op1
= a
;
1615 temp
.value
.op
.op2
= b
;
1616 gfc_type_convert_binary (&temp
, 1);
1620 f
->rank
= (a
->rank
== 2 && b
->rank
== 2) ? 2 : 1;
1621 f
->corank
= a
->corank
;
1623 if (a
->rank
== 2 && b
->rank
== 2)
1625 if (a
->shape
&& b
->shape
)
1627 f
->shape
= gfc_get_shape (f
->rank
);
1628 mpz_init_set (f
->shape
[0], a
->shape
[0]);
1629 mpz_init_set (f
->shape
[1], b
->shape
[1]);
1632 else if (a
->rank
== 1)
1636 f
->shape
= gfc_get_shape (f
->rank
);
1637 mpz_init_set (f
->shape
[0], b
->shape
[1]);
1642 /* b->rank == 1 and a->rank == 2 here, all other cases have
1643 been caught in check.cc. */
1646 f
->shape
= gfc_get_shape (f
->rank
);
1647 mpz_init_set (f
->shape
[0], a
->shape
[0]);
1651 f
->value
.function
.name
1652 = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f
->ts
.type
),
1653 gfc_type_abi_kind (&f
->ts
));
1658 gfc_resolve_minmax (const char *name
, gfc_expr
*f
, gfc_actual_arglist
*args
)
1660 gfc_actual_arglist
*a
;
1662 f
->ts
.type
= args
->expr
->ts
.type
;
1663 f
->ts
.kind
= args
->expr
->ts
.kind
;
1664 /* Find the largest type kind. */
1665 for (a
= args
->next
; a
; a
= a
->next
)
1667 if (a
->expr
->ts
.kind
> f
->ts
.kind
)
1668 f
->ts
.kind
= a
->expr
->ts
.kind
;
1671 /* Convert all parameters to the required kind. */
1672 for (a
= args
; a
; a
= a
->next
)
1674 if (a
->expr
->ts
.kind
!= f
->ts
.kind
)
1675 gfc_convert_type (a
->expr
, &f
->ts
, 2);
1678 f
->value
.function
.name
1679 = gfc_get_string (name
, gfc_type_letter (f
->ts
.type
),
1680 gfc_type_abi_kind (&f
->ts
));
1685 gfc_resolve_max (gfc_expr
*f
, gfc_actual_arglist
*args
)
1687 gfc_resolve_minmax ("__max_%c%d", f
, args
);
1690 /* The smallest kind for which a minloc and maxloc implementation exists. */
1692 #define MINMAXLOC_MIN_KIND 4
1695 gfc_resolve_maxloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1696 gfc_expr
*mask
, gfc_expr
*kind
, gfc_expr
*back
)
1703 f
->ts
.type
= BT_INTEGER
;
1705 /* The library versions only exist for kinds 4, 8 and 16. For smaller kinds,
1706 we do a type conversion further down. */
1708 fkind
= mpz_get_si (kind
->value
.integer
);
1710 fkind
= gfc_default_integer_kind
;
1712 if (fkind
< MINMAXLOC_MIN_KIND
)
1713 f
->ts
.kind
= MINMAXLOC_MIN_KIND
;
1720 f
->shape
= gfc_get_shape (1);
1721 mpz_init_set_si (f
->shape
[0], array
->rank
);
1725 f
->rank
= array
->rank
- 1;
1726 gfc_resolve_dim_arg (dim
);
1727 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1729 idim
= (int) mpz_get_si (dim
->value
.integer
);
1730 f
->shape
= gfc_get_shape (f
->rank
);
1731 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1733 if (i
== (idim
- 1))
1735 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1742 if (mask
->rank
== 0)
1747 resolve_mask_arg (mask
);
1754 if (array
->ts
.type
!= BT_CHARACTER
|| f
->rank
!= 0)
1762 f
->value
.function
.name
1763 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name
, d_num
, f
->ts
.kind
,
1764 gfc_type_letter (array
->ts
.type
),
1765 gfc_type_abi_kind (&array
->ts
));
1768 fkind
= mpz_get_si (kind
->value
.integer
);
1770 fkind
= gfc_default_integer_kind
;
1772 if (fkind
!= f
->ts
.kind
)
1777 ts
.type
= BT_INTEGER
;
1779 gfc_convert_type_warn (f
, &ts
, 2, 0);
1782 if (back
->ts
.kind
!= gfc_logical_4_kind
)
1786 ts
.type
= BT_LOGICAL
;
1787 ts
.kind
= gfc_logical_4_kind
;
1788 gfc_convert_type_warn (back
, &ts
, 2, 0);
1794 gfc_resolve_findloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*value
,
1795 gfc_expr
*dim
, gfc_expr
*mask
, gfc_expr
*kind
,
1803 /* See at the end of the function for why this is necessary. */
1805 if (f
->do_not_resolve_again
)
1808 f
->ts
.type
= BT_INTEGER
;
1810 /* We have a single library version, which uses index_type. */
1813 fkind
= mpz_get_si (kind
->value
.integer
);
1815 fkind
= gfc_default_integer_kind
;
1817 f
->ts
.kind
= gfc_index_integer_kind
;
1819 /* Convert value. If array is not LOGICAL and value is, we already
1820 issued an error earlier. */
1822 if ((array
->ts
.type
!= value
->ts
.type
&& value
->ts
.type
!= BT_LOGICAL
)
1823 || array
->ts
.kind
!= value
->ts
.kind
)
1824 gfc_convert_type_warn (value
, &array
->ts
, 2, 0);
1829 f
->shape
= gfc_get_shape (1);
1830 mpz_init_set_si (f
->shape
[0], array
->rank
);
1834 f
->rank
= array
->rank
- 1;
1835 gfc_resolve_dim_arg (dim
);
1836 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1838 idim
= (int) mpz_get_si (dim
->value
.integer
);
1839 f
->shape
= gfc_get_shape (f
->rank
);
1840 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1842 if (i
== (idim
- 1))
1844 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1851 if (mask
->rank
== 0)
1856 resolve_mask_arg (mask
);
1871 if (back
->ts
.kind
!= gfc_logical_4_kind
)
1875 ts
.type
= BT_LOGICAL
;
1876 ts
.kind
= gfc_logical_4_kind
;
1877 gfc_convert_type_warn (back
, &ts
, 2, 0);
1880 f
->value
.function
.name
1881 = gfc_get_string (PREFIX ("%s%d_%c%d"), name
, d_num
,
1882 gfc_type_letter (array
->ts
.type
, true),
1883 gfc_type_abi_kind (&array
->ts
));
1885 /* We only have a single library function, so we need to convert
1886 here. If the function is resolved from within a convert
1887 function generated on a previous round of resolution, endless
1888 recursion could occur. Guard against that here. */
1890 if (f
->ts
.kind
!= fkind
)
1892 f
->do_not_resolve_again
= 1;
1896 ts
.type
= BT_INTEGER
;
1898 gfc_convert_type_warn (f
, &ts
, 2, 0);
1904 gfc_resolve_maxval (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1914 f
->rank
= array
->rank
- 1;
1915 gfc_resolve_dim_arg (dim
);
1917 if (f
->rank
&& array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1919 idim
= (int) mpz_get_si (dim
->value
.integer
);
1920 f
->shape
= gfc_get_shape (f
->rank
);
1921 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1923 if (i
== (idim
- 1))
1925 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1932 if (mask
->rank
== 0)
1937 resolve_mask_arg (mask
);
1942 if (array
->ts
.type
!= BT_CHARACTER
)
1943 f
->value
.function
.name
1944 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
1945 gfc_type_letter (array
->ts
.type
),
1946 gfc_type_abi_kind (&array
->ts
));
1948 f
->value
.function
.name
1949 = gfc_get_string (PREFIX ("%s%d_%c%d"), name
, f
->rank
!= 0,
1950 gfc_type_letter (array
->ts
.type
),
1951 gfc_type_abi_kind (&array
->ts
));
1956 gfc_resolve_mclock (gfc_expr
*f
)
1958 f
->ts
.type
= BT_INTEGER
;
1960 f
->value
.function
.name
= PREFIX ("mclock");
1965 gfc_resolve_mclock8 (gfc_expr
*f
)
1967 f
->ts
.type
= BT_INTEGER
;
1969 f
->value
.function
.name
= PREFIX ("mclock8");
1974 gfc_resolve_mask (gfc_expr
*f
, gfc_expr
*i ATTRIBUTE_UNUSED
,
1977 f
->ts
.type
= BT_INTEGER
;
1978 f
->ts
.kind
= kind
? mpz_get_si (kind
->value
.integer
)
1979 : gfc_default_integer_kind
;
1981 if (f
->value
.function
.isym
->id
== GFC_ISYM_MASKL
)
1982 f
->value
.function
.name
= gfc_get_string ("__maskl_i%d", f
->ts
.kind
);
1984 f
->value
.function
.name
= gfc_get_string ("__maskr_i%d", f
->ts
.kind
);
1989 gfc_resolve_merge (gfc_expr
*f
, gfc_expr
*tsource
,
1990 gfc_expr
*fsource ATTRIBUTE_UNUSED
,
1991 gfc_expr
*mask ATTRIBUTE_UNUSED
)
1993 if (tsource
->ts
.type
== BT_CHARACTER
&& tsource
->ref
)
1994 gfc_resolve_substring_charlen (tsource
);
1996 if (fsource
->ts
.type
== BT_CHARACTER
&& fsource
->ref
)
1997 gfc_resolve_substring_charlen (fsource
);
1999 if (tsource
->ts
.type
== BT_CHARACTER
)
2000 check_charlen_present (tsource
);
2002 f
->ts
= tsource
->ts
;
2003 f
->value
.function
.name
2004 = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource
->ts
.type
),
2005 gfc_type_abi_kind (&tsource
->ts
));
2010 gfc_resolve_merge_bits (gfc_expr
*f
, gfc_expr
*i
,
2011 gfc_expr
*j ATTRIBUTE_UNUSED
,
2012 gfc_expr
*mask ATTRIBUTE_UNUSED
)
2016 f
->value
.function
.name
2017 = gfc_get_string ("__merge_bits_%c%d", gfc_type_letter (i
->ts
.type
),
2023 gfc_resolve_min (gfc_expr
*f
, gfc_actual_arglist
*args
)
2025 gfc_resolve_minmax ("__min_%c%d", f
, args
);
2030 gfc_resolve_minloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
2031 gfc_expr
*mask
, gfc_expr
*kind
, gfc_expr
*back
)
2038 f
->ts
.type
= BT_INTEGER
;
2040 /* The library versions only exist for kinds 4, 8 and 16. For smaller kinds,
2041 we do a type conversion further down. */
2043 fkind
= mpz_get_si (kind
->value
.integer
);
2045 fkind
= gfc_default_integer_kind
;
2047 if (fkind
< MINMAXLOC_MIN_KIND
)
2048 f
->ts
.kind
= MINMAXLOC_MIN_KIND
;
2055 f
->shape
= gfc_get_shape (1);
2056 mpz_init_set_si (f
->shape
[0], array
->rank
);
2060 f
->rank
= array
->rank
- 1;
2061 gfc_resolve_dim_arg (dim
);
2062 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
2064 idim
= (int) mpz_get_si (dim
->value
.integer
);
2065 f
->shape
= gfc_get_shape (f
->rank
);
2066 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
2068 if (i
== (idim
- 1))
2070 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
2077 if (mask
->rank
== 0)
2082 resolve_mask_arg (mask
);
2089 if (array
->ts
.type
!= BT_CHARACTER
|| f
->rank
!= 0)
2097 f
->value
.function
.name
2098 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name
, d_num
, f
->ts
.kind
,
2099 gfc_type_letter (array
->ts
.type
),
2100 gfc_type_abi_kind (&array
->ts
));
2102 if (fkind
!= f
->ts
.kind
)
2107 ts
.type
= BT_INTEGER
;
2109 gfc_convert_type_warn (f
, &ts
, 2, 0);
2112 if (back
->ts
.kind
!= gfc_logical_4_kind
)
2116 ts
.type
= BT_LOGICAL
;
2117 ts
.kind
= gfc_logical_4_kind
;
2118 gfc_convert_type_warn (back
, &ts
, 2, 0);
2124 gfc_resolve_minval (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
2134 f
->rank
= array
->rank
- 1;
2135 gfc_resolve_dim_arg (dim
);
2137 if (f
->rank
&& array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
2139 idim
= (int) mpz_get_si (dim
->value
.integer
);
2140 f
->shape
= gfc_get_shape (f
->rank
);
2141 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
2143 if (i
== (idim
- 1))
2145 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
2152 if (mask
->rank
== 0)
2157 resolve_mask_arg (mask
);
2162 if (array
->ts
.type
!= BT_CHARACTER
)
2163 f
->value
.function
.name
2164 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
2165 gfc_type_letter (array
->ts
.type
),
2166 gfc_type_abi_kind (&array
->ts
));
2168 f
->value
.function
.name
2169 = gfc_get_string (PREFIX ("%s%d_%c%d"), name
, f
->rank
!= 0,
2170 gfc_type_letter (array
->ts
.type
),
2171 gfc_type_abi_kind (&array
->ts
));
2176 gfc_resolve_mod (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
2178 f
->ts
.type
= a
->ts
.type
;
2180 f
->ts
.kind
= gfc_kind_max (a
,p
);
2182 f
->ts
.kind
= a
->ts
.kind
;
2184 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
2186 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
2187 gfc_convert_type (p
, &a
->ts
, 2);
2189 gfc_convert_type (a
, &p
->ts
, 2);
2192 f
->value
.function
.name
2193 = gfc_get_string ("__mod_%c%d", gfc_type_letter (f
->ts
.type
),
2194 gfc_type_abi_kind (&f
->ts
));
2199 gfc_resolve_modulo (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
2201 f
->ts
.type
= a
->ts
.type
;
2203 f
->ts
.kind
= gfc_kind_max (a
,p
);
2205 f
->ts
.kind
= a
->ts
.kind
;
2207 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
2209 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
2210 gfc_convert_type (p
, &a
->ts
, 2);
2212 gfc_convert_type (a
, &p
->ts
, 2);
2215 f
->value
.function
.name
2216 = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f
->ts
.type
),
2217 gfc_type_abi_kind (&f
->ts
));
2221 gfc_resolve_nearest (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
2223 if (p
->ts
.kind
!= a
->ts
.kind
)
2224 gfc_convert_type (p
, &a
->ts
, 2);
2227 f
->value
.function
.name
2228 = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a
->ts
.type
),
2229 gfc_type_abi_kind (&a
->ts
));
2233 gfc_resolve_nint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
2235 f
->ts
.type
= BT_INTEGER
;
2236 f
->ts
.kind
= (kind
== NULL
)
2237 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
2238 f
->value
.function
.name
2239 = gfc_get_string ("__nint_%d_%d", f
->ts
.kind
, a
->ts
.kind
);
2244 gfc_resolve_norm2 (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
)
2246 resolve_transformational ("norm2", f
, array
, dim
, NULL
);
2251 gfc_resolve_not (gfc_expr
*f
, gfc_expr
*i
)
2254 const char *name
= i
->ts
.kind
== BT_UNSIGNED
? "__not_u_%d" : "__not_%d";
2255 f
->value
.function
.name
= gfc_get_string (name
, i
->ts
.kind
);
2260 gfc_resolve_or (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
2262 f
->ts
.type
= i
->ts
.type
;
2263 f
->ts
.kind
= gfc_kind_max (i
, j
);
2265 if (i
->ts
.kind
!= j
->ts
.kind
)
2267 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
2268 gfc_convert_type (j
, &i
->ts
, 2);
2270 gfc_convert_type (i
, &j
->ts
, 2);
2273 f
->value
.function
.name
2274 = gfc_get_string ("__or_%c%d", gfc_type_letter (i
->ts
.type
),
2275 gfc_type_abi_kind (&f
->ts
));
2280 gfc_resolve_pack (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*mask
,
2281 gfc_expr
*vector ATTRIBUTE_UNUSED
)
2283 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
2284 gfc_resolve_substring_charlen (array
);
2289 resolve_mask_arg (mask
);
2291 if (mask
->rank
!= 0)
2293 if (array
->ts
.type
== BT_CHARACTER
)
2294 f
->value
.function
.name
2295 = array
->ts
.kind
== 1 ? PREFIX ("pack_char")
2297 (PREFIX ("pack_char%d"),
2300 f
->value
.function
.name
= PREFIX ("pack");
2304 if (array
->ts
.type
== BT_CHARACTER
)
2305 f
->value
.function
.name
2306 = array
->ts
.kind
== 1 ? PREFIX ("pack_s_char")
2308 (PREFIX ("pack_s_char%d"),
2311 f
->value
.function
.name
= PREFIX ("pack_s");
2317 gfc_resolve_parity (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
)
2319 resolve_transformational ("parity", f
, array
, dim
, NULL
);
2324 gfc_resolve_product (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
2327 resolve_transformational ("product", f
, array
, dim
, mask
);
2332 gfc_resolve_rank (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
)
2334 f
->ts
.type
= BT_INTEGER
;
2335 f
->ts
.kind
= gfc_default_integer_kind
;
2336 f
->value
.function
.name
= gfc_get_string ("__rank");
2341 gfc_resolve_real (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
2343 f
->ts
.type
= BT_REAL
;
2346 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2348 f
->ts
.kind
= (a
->ts
.type
== BT_COMPLEX
)
2349 ? a
->ts
.kind
: gfc_default_real_kind
;
2351 f
->value
.function
.name
2352 = gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
2353 gfc_type_letter (a
->ts
.type
),
2354 gfc_type_abi_kind (&a
->ts
));
2359 gfc_resolve_realpart (gfc_expr
*f
, gfc_expr
*a
)
2361 f
->ts
.type
= BT_REAL
;
2362 f
->ts
.kind
= a
->ts
.kind
;
2363 f
->value
.function
.name
2364 = gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
2365 gfc_type_letter (a
->ts
.type
),
2366 gfc_type_abi_kind (&a
->ts
));
2371 gfc_resolve_rename (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
2372 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
2374 f
->ts
.type
= BT_INTEGER
;
2375 f
->ts
.kind
= gfc_default_integer_kind
;
2376 f
->value
.function
.name
= gfc_get_string (PREFIX ("rename_i%d"), f
->ts
.kind
);
2381 gfc_resolve_repeat (gfc_expr
*f
, gfc_expr
*string
,
2385 f
->ts
.type
= BT_CHARACTER
;
2386 f
->ts
.kind
= string
->ts
.kind
;
2387 f
->value
.function
.name
= gfc_get_string ("__repeat_%d", string
->ts
.kind
);
2389 /* If possible, generate a character length. */
2390 if (f
->ts
.u
.cl
== NULL
)
2391 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2394 if (string
->expr_type
== EXPR_CONSTANT
)
2396 tmp
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
2397 string
->value
.character
.length
);
2399 else if (string
->ts
.u
.cl
&& string
->ts
.u
.cl
->length
)
2401 tmp
= gfc_copy_expr (string
->ts
.u
.cl
->length
);
2406 /* Force-convert to gfc_charlen_int_kind before gfc_multiply. */
2407 gfc_expr
*e
= gfc_copy_expr (ncopies
);
2408 gfc_typespec ts
= tmp
->ts
;
2409 ts
.kind
= gfc_charlen_int_kind
;
2410 gfc_convert_type_warn (e
, &ts
, 2, 0);
2411 gfc_convert_type_warn (tmp
, &ts
, 2, 0);
2412 f
->ts
.u
.cl
->length
= gfc_multiply (tmp
, e
);
2418 gfc_resolve_reshape (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*shape
,
2419 gfc_expr
*pad ATTRIBUTE_UNUSED
,
2420 gfc_expr
*order ATTRIBUTE_UNUSED
)
2426 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
2427 gfc_resolve_substring_charlen (source
);
2431 gfc_array_size (shape
, &rank
);
2432 f
->rank
= mpz_get_si (rank
);
2434 switch (source
->ts
.type
)
2441 kind
= source
->ts
.kind
;
2455 if (source
->ts
.type
== BT_COMPLEX
|| source
->ts
.type
== BT_REAL
)
2456 f
->value
.function
.name
2457 = gfc_get_string (PREFIX ("reshape_%c%d"),
2458 gfc_type_letter (source
->ts
.type
),
2459 gfc_type_abi_kind (&source
->ts
));
2460 else if (source
->ts
.type
== BT_CHARACTER
)
2461 f
->value
.function
.name
= gfc_get_string (PREFIX ("reshape_char%d"),
2464 f
->value
.function
.name
2465 = gfc_get_string (PREFIX ("reshape_%d"), source
->ts
.kind
);
2469 f
->value
.function
.name
= (source
->ts
.type
== BT_CHARACTER
2470 ? PREFIX ("reshape_char") : PREFIX ("reshape"));
2474 if (shape
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_array_expr (shape
))
2477 f
->shape
= gfc_get_shape (f
->rank
);
2478 c
= gfc_constructor_first (shape
->value
.constructor
);
2479 for (i
= 0; i
< f
->rank
; i
++)
2481 mpz_init_set (f
->shape
[i
], c
->expr
->value
.integer
);
2482 c
= gfc_constructor_next (c
);
2486 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
2487 so many runtime variations. */
2488 if (shape
->ts
.kind
!= gfc_index_integer_kind
)
2490 gfc_typespec ts
= shape
->ts
;
2491 ts
.kind
= gfc_index_integer_kind
;
2492 gfc_convert_type_warn (shape
, &ts
, 2, 0);
2494 if (order
&& order
->ts
.kind
!= gfc_index_integer_kind
)
2495 gfc_convert_type_warn (order
, &shape
->ts
, 2, 0);
2500 gfc_resolve_rrspacing (gfc_expr
*f
, gfc_expr
*x
)
2503 f
->value
.function
.name
= gfc_get_string ("__rrspacing_%d", x
->ts
.kind
);
2507 gfc_resolve_fe_runtime_error (gfc_code
*c
)
2510 gfc_actual_arglist
*a
;
2512 name
= gfc_get_string (PREFIX ("runtime_error"));
2514 for (a
= c
->ext
.actual
->next
; a
; a
= a
->next
)
2517 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2518 /* We set the backend_decl here because runtime_error is a
2519 variadic function and we would use the wrong calling
2520 convention otherwise. */
2521 c
->resolved_sym
->backend_decl
= gfor_fndecl_runtime_error
;
2525 gfc_resolve_scale (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*i ATTRIBUTE_UNUSED
)
2528 f
->value
.function
.name
= gfc_get_string ("__scale_%d", x
->ts
.kind
);
2533 gfc_resolve_scan (gfc_expr
*f
, gfc_expr
*string
,
2534 gfc_expr
*set ATTRIBUTE_UNUSED
,
2535 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2537 f
->ts
.type
= BT_INTEGER
;
2539 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2541 f
->ts
.kind
= gfc_default_integer_kind
;
2542 f
->value
.function
.name
= gfc_get_string ("__scan_%d", string
->ts
.kind
);
2547 gfc_resolve_secnds (gfc_expr
*t1
, gfc_expr
*t0
)
2550 t1
->value
.function
.name
= gfc_get_string (PREFIX ("secnds"));
2555 gfc_resolve_set_exponent (gfc_expr
*f
, gfc_expr
*x
,
2556 gfc_expr
*i ATTRIBUTE_UNUSED
)
2559 f
->value
.function
.name
= gfc_get_string ("__set_exponent_%d", x
->ts
.kind
);
2564 gfc_resolve_shape (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*kind
)
2566 f
->ts
.type
= BT_INTEGER
;
2569 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2571 f
->ts
.kind
= gfc_default_integer_kind
;
2574 if (array
->rank
!= -1)
2576 f
->shape
= gfc_get_shape (1);
2577 mpz_init_set_ui (f
->shape
[0], array
->rank
);
2580 f
->value
.function
.name
= gfc_get_string (PREFIX ("shape_%d"), f
->ts
.kind
);
2585 gfc_resolve_shift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift ATTRIBUTE_UNUSED
)
2588 if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTA
)
2589 f
->value
.function
.name
= gfc_get_string ("shifta_i%d", f
->ts
.kind
);
2590 else if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTL
)
2591 f
->value
.function
.name
= gfc_get_string ("shiftl_i%d", f
->ts
.kind
);
2592 else if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTR
)
2593 f
->value
.function
.name
= gfc_get_string ("shiftr_i%d", f
->ts
.kind
);
2600 gfc_resolve_sign (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b ATTRIBUTE_UNUSED
)
2603 f
->value
.function
.name
2604 = gfc_get_string ("__sign_%c%d", gfc_type_letter (a
->ts
.type
),
2605 gfc_type_abi_kind (&a
->ts
));
2610 gfc_resolve_signal (gfc_expr
*f
, gfc_expr
*number
, gfc_expr
*handler
)
2612 f
->ts
.type
= BT_INTEGER
;
2613 f
->ts
.kind
= gfc_c_int_kind
;
2615 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2616 if (handler
->ts
.type
== BT_INTEGER
)
2618 if (handler
->ts
.kind
!= gfc_c_int_kind
)
2619 gfc_convert_type (handler
, &f
->ts
, 2);
2620 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func_int"));
2623 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func"));
2625 if (number
->ts
.kind
!= gfc_c_int_kind
)
2626 gfc_convert_type (number
, &f
->ts
, 2);
2631 gfc_resolve_sin (gfc_expr
*f
, gfc_expr
*x
)
2634 f
->value
.function
.name
2635 = gfc_get_string ("__sin_%c%d", gfc_type_letter (x
->ts
.type
),
2636 gfc_type_abi_kind (&x
->ts
));
2641 gfc_resolve_sinh (gfc_expr
*f
, gfc_expr
*x
)
2644 f
->value
.function
.name
2645 = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x
->ts
.type
),
2646 gfc_type_abi_kind (&x
->ts
));
2651 gfc_resolve_size (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2652 gfc_expr
*dim ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2654 f
->ts
.type
= BT_INTEGER
;
2656 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2658 f
->ts
.kind
= gfc_default_integer_kind
;
2663 gfc_resolve_stride (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2664 gfc_expr
*dim ATTRIBUTE_UNUSED
)
2666 f
->ts
.type
= BT_INTEGER
;
2667 f
->ts
.kind
= gfc_index_integer_kind
;
2672 gfc_resolve_spacing (gfc_expr
*f
, gfc_expr
*x
)
2675 f
->value
.function
.name
= gfc_get_string ("__spacing_%d", x
->ts
.kind
);
2680 gfc_resolve_spread (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*dim
,
2683 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
2684 gfc_resolve_substring_charlen (source
);
2686 if (source
->ts
.type
== BT_CHARACTER
)
2687 check_charlen_present (source
);
2690 f
->rank
= source
->rank
+ 1;
2691 if (source
->rank
== 0)
2693 if (source
->ts
.type
== BT_CHARACTER
)
2694 f
->value
.function
.name
2695 = source
->ts
.kind
== 1 ? PREFIX ("spread_char_scalar")
2697 (PREFIX ("spread_char%d_scalar"),
2700 f
->value
.function
.name
= PREFIX ("spread_scalar");
2704 if (source
->ts
.type
== BT_CHARACTER
)
2705 f
->value
.function
.name
2706 = source
->ts
.kind
== 1 ? PREFIX ("spread_char")
2708 (PREFIX ("spread_char%d"),
2711 f
->value
.function
.name
= PREFIX ("spread");
2714 if (dim
&& gfc_is_constant_expr (dim
)
2715 && ncopies
&& gfc_is_constant_expr (ncopies
) && source
->shape
[0])
2718 idim
= mpz_get_ui (dim
->value
.integer
);
2719 f
->shape
= gfc_get_shape (f
->rank
);
2720 for (i
= 0; i
< (idim
- 1); i
++)
2721 mpz_init_set (f
->shape
[i
], source
->shape
[i
]);
2723 mpz_init_set (f
->shape
[idim
- 1], ncopies
->value
.integer
);
2725 for (i
= idim
; i
< f
->rank
; i
++)
2726 mpz_init_set (f
->shape
[i
], source
->shape
[i
-1]);
2730 gfc_resolve_dim_arg (dim
);
2731 gfc_resolve_index (ncopies
, 1);
2736 gfc_resolve_sqrt (gfc_expr
*f
, gfc_expr
*x
)
2739 f
->value
.function
.name
2740 = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x
->ts
.type
),
2741 gfc_type_abi_kind (&x
->ts
));
2745 /* Resolve the g77 compatibility function STAT AND FSTAT. */
2748 gfc_resolve_stat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2749 gfc_expr
*a ATTRIBUTE_UNUSED
)
2751 f
->ts
.type
= BT_INTEGER
;
2752 f
->ts
.kind
= gfc_default_integer_kind
;
2753 f
->value
.function
.name
= gfc_get_string (PREFIX ("stat_i%d"), f
->ts
.kind
);
2758 gfc_resolve_lstat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2759 gfc_expr
*a ATTRIBUTE_UNUSED
)
2761 f
->ts
.type
= BT_INTEGER
;
2762 f
->ts
.kind
= gfc_default_integer_kind
;
2763 f
->value
.function
.name
= gfc_get_string (PREFIX ("lstat_i%d"), f
->ts
.kind
);
2768 gfc_resolve_fstat (gfc_expr
*f
, gfc_expr
*n
, gfc_expr
*a ATTRIBUTE_UNUSED
)
2770 f
->ts
.type
= BT_INTEGER
;
2771 f
->ts
.kind
= gfc_default_integer_kind
;
2772 if (n
->ts
.kind
!= f
->ts
.kind
)
2773 gfc_convert_type (n
, &f
->ts
, 2);
2775 f
->value
.function
.name
= gfc_get_string (PREFIX ("fstat_i%d"), f
->ts
.kind
);
2780 gfc_resolve_fgetc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2785 f
->ts
.type
= BT_INTEGER
;
2786 f
->ts
.kind
= gfc_c_int_kind
;
2787 if (u
->ts
.kind
!= gfc_c_int_kind
)
2789 ts
.type
= BT_INTEGER
;
2790 ts
.kind
= gfc_c_int_kind
;
2791 ts
.u
.derived
= NULL
;
2793 gfc_convert_type (u
, &ts
, 2);
2796 f
->value
.function
.name
= gfc_get_string (PREFIX ("fgetc"));
2801 gfc_resolve_fget (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2803 f
->ts
.type
= BT_INTEGER
;
2804 f
->ts
.kind
= gfc_c_int_kind
;
2805 f
->value
.function
.name
= gfc_get_string (PREFIX ("fget"));
2810 gfc_resolve_fputc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2815 f
->ts
.type
= BT_INTEGER
;
2816 f
->ts
.kind
= gfc_c_int_kind
;
2817 if (u
->ts
.kind
!= gfc_c_int_kind
)
2819 ts
.type
= BT_INTEGER
;
2820 ts
.kind
= gfc_c_int_kind
;
2821 ts
.u
.derived
= NULL
;
2823 gfc_convert_type (u
, &ts
, 2);
2826 f
->value
.function
.name
= gfc_get_string (PREFIX ("fputc"));
2831 gfc_resolve_fput (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2833 f
->ts
.type
= BT_INTEGER
;
2834 f
->ts
.kind
= gfc_c_int_kind
;
2835 f
->value
.function
.name
= gfc_get_string (PREFIX ("fput"));
2840 gfc_resolve_ftell (gfc_expr
*f
, gfc_expr
*u
)
2845 f
->ts
.type
= BT_INTEGER
;
2846 f
->ts
.kind
= gfc_intio_kind
;
2847 if (u
->ts
.kind
!= gfc_c_int_kind
)
2849 ts
.type
= BT_INTEGER
;
2850 ts
.kind
= gfc_c_int_kind
;
2851 ts
.u
.derived
= NULL
;
2853 gfc_convert_type (u
, &ts
, 2);
2856 f
->value
.function
.name
= gfc_get_string (PREFIX ("ftell"));
2861 gfc_resolve_storage_size (gfc_expr
*f
, gfc_expr
*a ATTRIBUTE_UNUSED
,
2864 f
->ts
.type
= BT_INTEGER
;
2866 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2868 f
->ts
.kind
= gfc_default_integer_kind
;
2873 gfc_resolve_sum (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2875 resolve_transformational ("sum", f
, array
, dim
, mask
);
2880 gfc_resolve_symlnk (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
2881 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
2883 f
->ts
.type
= BT_INTEGER
;
2884 f
->ts
.kind
= gfc_default_integer_kind
;
2885 f
->value
.function
.name
= gfc_get_string (PREFIX ("symlnk_i%d"), f
->ts
.kind
);
2889 /* Resolve the g77 compatibility function SYSTEM. */
2892 gfc_resolve_system (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
2894 f
->ts
.type
= BT_INTEGER
;
2896 f
->value
.function
.name
= gfc_get_string (PREFIX ("system"));
2901 gfc_resolve_tan (gfc_expr
*f
, gfc_expr
*x
)
2904 f
->value
.function
.name
2905 = gfc_get_string ("__tan_%c%d", gfc_type_letter (x
->ts
.type
),
2906 gfc_type_abi_kind (&x
->ts
));
2911 gfc_resolve_tanh (gfc_expr
*f
, gfc_expr
*x
)
2914 f
->value
.function
.name
2915 = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x
->ts
.type
),
2916 gfc_type_abi_kind (&x
->ts
));
2920 /* Resolve failed_images (team, kind). */
2923 gfc_resolve_failed_images (gfc_expr
*f
, gfc_expr
*team ATTRIBUTE_UNUSED
,
2926 static char failed_images
[] = "_gfortran_caf_failed_images";
2928 f
->ts
.type
= BT_INTEGER
;
2930 f
->ts
.kind
= gfc_default_integer_kind
;
2932 gfc_extract_int (kind
, &f
->ts
.kind
);
2933 f
->value
.function
.name
= failed_images
;
2937 /* Resolve image_status (image, team). */
2940 gfc_resolve_image_status (gfc_expr
*f
, gfc_expr
*image ATTRIBUTE_UNUSED
,
2941 gfc_expr
*team ATTRIBUTE_UNUSED
)
2943 static char image_status
[] = "_gfortran_caf_image_status";
2944 f
->ts
.type
= BT_INTEGER
;
2945 f
->ts
.kind
= gfc_default_integer_kind
;
2946 f
->value
.function
.name
= image_status
;
2950 /* Resolve get_team (). */
2953 gfc_resolve_get_team (gfc_expr
*f
, gfc_expr
*level ATTRIBUTE_UNUSED
)
2955 static char get_team
[] = "_gfortran_caf_get_team";
2957 f
->ts
.type
= BT_INTEGER
;
2958 f
->ts
.kind
= gfc_default_integer_kind
;
2959 f
->value
.function
.name
= get_team
;
2963 /* Resolve image_index (...). */
2966 gfc_resolve_image_index (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2967 gfc_expr
*sub ATTRIBUTE_UNUSED
)
2969 static char image_index
[] = "__image_index";
2970 f
->ts
.type
= BT_INTEGER
;
2971 f
->ts
.kind
= gfc_default_integer_kind
;
2972 f
->value
.function
.name
= image_index
;
2976 /* Resolve stopped_images (team, kind). */
2979 gfc_resolve_stopped_images (gfc_expr
*f
, gfc_expr
*team ATTRIBUTE_UNUSED
,
2982 static char stopped_images
[] = "_gfortran_caf_stopped_images";
2984 f
->ts
.type
= BT_INTEGER
;
2986 f
->ts
.kind
= gfc_default_integer_kind
;
2988 gfc_extract_int (kind
, &f
->ts
.kind
);
2989 f
->value
.function
.name
= stopped_images
;
2993 /* Resolve team_number (team). */
2996 gfc_resolve_team_number (gfc_expr
*f
, gfc_expr
*team ATTRIBUTE_UNUSED
)
2998 static char team_number
[] = "_gfortran_caf_team_number";
3000 f
->ts
.type
= BT_INTEGER
;
3001 f
->ts
.kind
= gfc_default_integer_kind
;
3002 f
->value
.function
.name
= team_number
;
3007 gfc_resolve_this_image (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
3008 gfc_expr
*distance ATTRIBUTE_UNUSED
)
3010 static char this_image
[] = "__this_image";
3011 if (array
&& gfc_is_coarray (array
))
3012 resolve_bound (f
, array
, dim
, NULL
, "__this_image", true);
3015 f
->ts
.type
= BT_INTEGER
;
3016 f
->ts
.kind
= gfc_default_integer_kind
;
3017 f
->value
.function
.name
= this_image
;
3023 gfc_resolve_time (gfc_expr
*f
)
3025 f
->ts
.type
= BT_INTEGER
;
3027 f
->value
.function
.name
= gfc_get_string (PREFIX ("time_func"));
3032 gfc_resolve_time8 (gfc_expr
*f
)
3034 f
->ts
.type
= BT_INTEGER
;
3036 f
->value
.function
.name
= gfc_get_string (PREFIX ("time8_func"));
3041 gfc_resolve_transfer (gfc_expr
*f
, gfc_expr
*source ATTRIBUTE_UNUSED
,
3042 gfc_expr
*mold
, gfc_expr
*size
)
3044 /* TODO: Make this do something meaningful. */
3045 static char transfer0
[] = "__transfer0", transfer1
[] = "__transfer1";
3047 if (mold
->ts
.type
== BT_CHARACTER
3048 && !mold
->ts
.u
.cl
->length
3049 && gfc_is_constant_expr (mold
))
3052 if (mold
->expr_type
== EXPR_CONSTANT
)
3054 len
= mold
->value
.character
.length
;
3055 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
3060 gfc_constructor
*c
= gfc_constructor_first (mold
->value
.constructor
);
3061 len
= c
->expr
->value
.character
.length
;
3062 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
3067 if (UNLIMITED_POLY (mold
))
3068 gfc_error ("TODO: unlimited polymorphic MOLD in TRANSFER intrinsic at %L",
3073 if (size
== NULL
&& mold
->rank
== 0)
3076 f
->value
.function
.name
= transfer0
;
3081 f
->value
.function
.name
= transfer1
;
3082 if (size
&& gfc_is_constant_expr (size
))
3084 f
->shape
= gfc_get_shape (1);
3085 mpz_init_set (f
->shape
[0], size
->value
.integer
);
3092 gfc_resolve_transpose (gfc_expr
*f
, gfc_expr
*matrix
)
3095 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ref
)
3096 gfc_resolve_substring_charlen (matrix
);
3102 f
->shape
= gfc_get_shape (2);
3103 mpz_init_set (f
->shape
[0], matrix
->shape
[1]);
3104 mpz_init_set (f
->shape
[1], matrix
->shape
[0]);
3107 switch (matrix
->ts
.kind
)
3113 switch (matrix
->ts
.type
)
3117 f
->value
.function
.name
3118 = gfc_get_string (PREFIX ("transpose_%c%d"),
3119 gfc_type_letter (matrix
->ts
.type
),
3120 gfc_type_abi_kind (&matrix
->ts
));
3125 /* Use the integer routines for real and logical cases. This
3126 assumes they all have the same alignment requirements. */
3127 f
->value
.function
.name
3128 = gfc_get_string (PREFIX ("transpose_i%d"), matrix
->ts
.kind
);
3132 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ts
.kind
== 4)
3133 f
->value
.function
.name
= PREFIX ("transpose_char4");
3135 f
->value
.function
.name
= PREFIX ("transpose");
3141 f
->value
.function
.name
= (matrix
->ts
.type
== BT_CHARACTER
3142 ? PREFIX ("transpose_char")
3143 : PREFIX ("transpose"));
3150 gfc_resolve_trim (gfc_expr
*f
, gfc_expr
*string
)
3152 f
->ts
.type
= BT_CHARACTER
;
3153 f
->ts
.kind
= string
->ts
.kind
;
3154 f
->value
.function
.name
= gfc_get_string ("__trim_%d", string
->ts
.kind
);
3158 /* Resolve the degree trigonometric functions. This amounts to setting
3159 the function return type-spec from its argument and building a
3160 library function names of the form _gfortran_sind_r4. */
3163 gfc_resolve_trigd (gfc_expr
*f
, gfc_expr
*x
)
3166 f
->value
.function
.name
3167 = gfc_get_string (PREFIX ("%s_%c%d"), f
->value
.function
.isym
->name
,
3168 gfc_type_letter (x
->ts
.type
),
3169 gfc_type_abi_kind (&x
->ts
));
3174 gfc_resolve_trigd2 (gfc_expr
*f
, gfc_expr
*y
, gfc_expr
*x
)
3177 f
->value
.function
.name
3178 = gfc_get_string (PREFIX ("%s_%d"), f
->value
.function
.isym
->name
,
3184 gfc_resolve_ubound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3186 resolve_bound (f
, array
, dim
, kind
, "__ubound", false);
3191 gfc_resolve_ucobound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3193 resolve_bound (f
, array
, dim
, kind
, "__ucobound", true);
3197 /* Resolve the g77 compatibility function UMASK. */
3200 gfc_resolve_umask (gfc_expr
*f
, gfc_expr
*n
)
3202 f
->ts
.type
= BT_INTEGER
;
3203 f
->ts
.kind
= n
->ts
.kind
;
3204 f
->value
.function
.name
= gfc_get_string (PREFIX ("umask_i%d"), n
->ts
.kind
);
3208 /* Resolve the g77 compatibility function UNLINK. */
3211 gfc_resolve_unlink (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
3213 f
->ts
.type
= BT_INTEGER
;
3215 f
->value
.function
.name
= gfc_get_string (PREFIX ("unlink"));
3220 gfc_resolve_ttynam (gfc_expr
*f
, gfc_expr
*unit
)
3225 f
->ts
.type
= BT_CHARACTER
;
3226 f
->ts
.kind
= gfc_default_character_kind
;
3228 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3230 ts
.type
= BT_INTEGER
;
3231 ts
.kind
= gfc_c_int_kind
;
3232 ts
.u
.derived
= NULL
;
3234 gfc_convert_type (unit
, &ts
, 2);
3237 f
->value
.function
.name
= gfc_get_string (PREFIX ("ttynam"));
3242 gfc_resolve_unpack (gfc_expr
*f
, gfc_expr
*vector
, gfc_expr
*mask
,
3243 gfc_expr
*field ATTRIBUTE_UNUSED
)
3245 if (vector
->ts
.type
== BT_CHARACTER
&& vector
->ref
)
3246 gfc_resolve_substring_charlen (vector
);
3249 f
->rank
= mask
->rank
;
3250 resolve_mask_arg (mask
);
3252 if (vector
->ts
.type
== BT_CHARACTER
)
3254 if (vector
->ts
.kind
== 1)
3255 f
->value
.function
.name
3256 = gfc_get_string (PREFIX ("unpack%d_char"), field
->rank
> 0 ? 1 : 0);
3258 f
->value
.function
.name
3259 = gfc_get_string (PREFIX ("unpack%d_char%d"),
3260 field
->rank
> 0 ? 1 : 0, vector
->ts
.kind
);
3263 f
->value
.function
.name
3264 = gfc_get_string (PREFIX ("unpack%d"), field
->rank
> 0 ? 1 : 0);
3269 gfc_resolve_verify (gfc_expr
*f
, gfc_expr
*string
,
3270 gfc_expr
*set ATTRIBUTE_UNUSED
,
3271 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
3273 f
->ts
.type
= BT_INTEGER
;
3275 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
3277 f
->ts
.kind
= gfc_default_integer_kind
;
3278 f
->value
.function
.name
= gfc_get_string ("__verify_%d", string
->ts
.kind
);
3283 gfc_resolve_xor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
3285 f
->ts
.type
= i
->ts
.type
;
3286 f
->ts
.kind
= gfc_kind_max (i
, j
);
3288 if (i
->ts
.kind
!= j
->ts
.kind
)
3290 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
3291 gfc_convert_type (j
, &i
->ts
, 2);
3293 gfc_convert_type (i
, &j
->ts
, 2);
3296 f
->value
.function
.name
3297 = gfc_get_string ("__xor_%c%d", gfc_type_letter (i
->ts
.type
),
3298 gfc_type_abi_kind (&f
->ts
));
3302 /* Intrinsic subroutine resolution. */
3305 gfc_resolve_alarm_sub (gfc_code
*c
)
3308 gfc_expr
*seconds
, *handler
;
3312 seconds
= c
->ext
.actual
->expr
;
3313 handler
= c
->ext
.actual
->next
->expr
;
3314 ts
.type
= BT_INTEGER
;
3315 ts
.kind
= gfc_c_int_kind
;
3317 /* handler can be either BT_INTEGER or BT_PROCEDURE.
3318 In all cases, the status argument is of default integer kind
3319 (enforced in check.cc) so that the function suffix is fixed. */
3320 if (handler
->ts
.type
== BT_INTEGER
)
3322 if (handler
->ts
.kind
!= gfc_c_int_kind
)
3323 gfc_convert_type (handler
, &ts
, 2);
3324 name
= gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
3325 gfc_default_integer_kind
);
3328 name
= gfc_get_string (PREFIX ("alarm_sub_i%d"),
3329 gfc_default_integer_kind
);
3331 if (seconds
->ts
.kind
!= gfc_c_int_kind
)
3332 gfc_convert_type (seconds
, &ts
, 2);
3334 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3338 gfc_resolve_cpu_time (gfc_code
*c
)
3341 name
= gfc_get_string (PREFIX ("cpu_time_%d"), c
->ext
.actual
->expr
->ts
.kind
);
3342 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3346 /* Create a formal arglist based on an actual one and set the INTENTs given. */
3348 static gfc_formal_arglist
*
3349 create_formal_for_intents (gfc_actual_arglist
* actual
, const sym_intent
* ints
)
3351 gfc_formal_arglist
* head
;
3352 gfc_formal_arglist
* tail
;
3358 head
= tail
= gfc_get_formal_arglist ();
3359 for (i
= 0; actual
; actual
= actual
->next
, tail
= tail
->next
, ++i
)
3363 sym
= gfc_new_symbol ("dummyarg", NULL
);
3364 sym
->ts
= actual
->expr
->ts
;
3366 sym
->attr
.intent
= ints
[i
];
3370 tail
->next
= gfc_get_formal_arglist ();
3378 gfc_resolve_atomic_def (gfc_code
*c
)
3380 const char *name
= "atomic_define";
3381 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3386 gfc_resolve_atomic_ref (gfc_code
*c
)
3388 const char *name
= "atomic_ref";
3389 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3393 gfc_resolve_event_query (gfc_code
*c
)
3395 const char *name
= "event_query";
3396 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3400 gfc_resolve_mvbits (gfc_code
*c
)
3402 static const sym_intent INTENTS
[] = {INTENT_IN
, INTENT_IN
, INTENT_IN
,
3403 INTENT_INOUT
, INTENT_IN
};
3406 /* TO and FROM are guaranteed to have the same kind parameter. */
3407 name
= gfc_get_string (PREFIX ("mvbits_i%d"),
3408 c
->ext
.actual
->expr
->ts
.kind
);
3409 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3410 /* Mark as elemental subroutine as this does not happen automatically. */
3411 c
->resolved_sym
->attr
.elemental
= 1;
3413 /* Create a dummy formal arglist so the INTENTs are known later for purpose
3414 of creating temporaries. */
3415 c
->resolved_sym
->formal
= create_formal_for_intents (c
->ext
.actual
, INTENTS
);
3419 /* Set up the call to RANDOM_INIT. */
3422 gfc_resolve_random_init (gfc_code
*c
)
3425 name
= gfc_get_string (PREFIX ("random_init"));
3426 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3431 gfc_resolve_random_number (gfc_code
*c
)
3436 kind
= gfc_type_abi_kind (&c
->ext
.actual
->expr
->ts
);
3437 if (c
->ext
.actual
->expr
->rank
== 0)
3438 name
= gfc_get_string (PREFIX ("random_r%d"), kind
);
3440 name
= gfc_get_string (PREFIX ("arandom_r%d"), kind
);
3442 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3447 gfc_resolve_random_seed (gfc_code
*c
)
3451 name
= gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind
);
3452 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3457 gfc_resolve_rename_sub (gfc_code
*c
)
3462 /* Find the type of status. If not present use default integer kind. */
3463 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3464 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3466 kind
= gfc_default_integer_kind
;
3468 name
= gfc_get_string (PREFIX ("rename_i%d_sub"), kind
);
3469 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3474 gfc_resolve_link_sub (gfc_code
*c
)
3479 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3480 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3482 kind
= gfc_default_integer_kind
;
3484 name
= gfc_get_string (PREFIX ("link_i%d_sub"), kind
);
3485 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3490 gfc_resolve_symlnk_sub (gfc_code
*c
)
3495 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3496 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3498 kind
= gfc_default_integer_kind
;
3500 name
= gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind
);
3501 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3505 /* G77 compatibility subroutines dtime() and etime(). */
3508 gfc_resolve_dtime_sub (gfc_code
*c
)
3511 name
= gfc_get_string (PREFIX ("dtime_sub"));
3512 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3516 gfc_resolve_etime_sub (gfc_code
*c
)
3519 name
= gfc_get_string (PREFIX ("etime_sub"));
3520 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3524 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
3527 gfc_resolve_itime (gfc_code
*c
)
3530 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
3531 gfc_default_integer_kind
));
3535 gfc_resolve_idate (gfc_code
*c
)
3538 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
3539 gfc_default_integer_kind
));
3543 gfc_resolve_ltime (gfc_code
*c
)
3546 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
3547 gfc_default_integer_kind
));
3551 gfc_resolve_gmtime (gfc_code
*c
)
3554 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
3555 gfc_default_integer_kind
));
3559 /* G77 compatibility subroutine second(). */
3562 gfc_resolve_second_sub (gfc_code
*c
)
3565 name
= gfc_get_string (PREFIX ("second_sub"));
3566 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3571 gfc_resolve_sleep_sub (gfc_code
*c
)
3576 if (c
->ext
.actual
->expr
!= NULL
)
3577 kind
= c
->ext
.actual
->expr
->ts
.kind
;
3579 kind
= gfc_default_integer_kind
;
3581 name
= gfc_get_string (PREFIX ("sleep_i%d_sub"), kind
);
3582 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3586 /* G77 compatibility function srand(). */
3589 gfc_resolve_srand (gfc_code
*c
)
3592 name
= gfc_get_string (PREFIX ("srand"));
3593 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3597 /* Resolve the getarg intrinsic subroutine. */
3600 gfc_resolve_getarg (gfc_code
*c
)
3604 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_default_integer_kind
)
3609 ts
.type
= BT_INTEGER
;
3610 ts
.kind
= gfc_default_integer_kind
;
3612 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3615 name
= gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind
);
3616 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3620 /* Resolve the getcwd intrinsic subroutine. */
3623 gfc_resolve_getcwd_sub (gfc_code
*c
)
3628 if (c
->ext
.actual
->next
->expr
!= NULL
)
3629 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3631 kind
= gfc_default_integer_kind
;
3633 name
= gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind
);
3634 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3638 /* Resolve the get_command intrinsic subroutine. */
3641 gfc_resolve_get_command (gfc_code
*c
)
3645 kind
= gfc_default_integer_kind
;
3646 name
= gfc_get_string (PREFIX ("get_command_i%d"), kind
);
3647 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3651 /* Resolve the get_command_argument intrinsic subroutine. */
3654 gfc_resolve_get_command_argument (gfc_code
*c
)
3658 kind
= gfc_default_integer_kind
;
3659 name
= gfc_get_string (PREFIX ("get_command_argument_i%d"), kind
);
3660 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3664 /* Resolve the get_environment_variable intrinsic subroutine. */
3667 gfc_resolve_get_environment_variable (gfc_code
*code
)
3671 kind
= gfc_default_integer_kind
;
3672 name
= gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind
);
3673 code
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3678 gfc_resolve_signal_sub (gfc_code
*c
)
3681 gfc_expr
*number
, *handler
, *status
;
3685 number
= c
->ext
.actual
->expr
;
3686 handler
= c
->ext
.actual
->next
->expr
;
3687 status
= c
->ext
.actual
->next
->next
->expr
;
3688 ts
.type
= BT_INTEGER
;
3689 ts
.kind
= gfc_c_int_kind
;
3691 /* handler can be either BT_INTEGER or BT_PROCEDURE */
3692 if (handler
->ts
.type
== BT_INTEGER
)
3694 if (handler
->ts
.kind
!= gfc_c_int_kind
)
3695 gfc_convert_type (handler
, &ts
, 2);
3696 name
= gfc_get_string (PREFIX ("signal_sub_int"));
3699 name
= gfc_get_string (PREFIX ("signal_sub"));
3701 if (number
->ts
.kind
!= gfc_c_int_kind
)
3702 gfc_convert_type (number
, &ts
, 2);
3703 if (status
!= NULL
&& status
->ts
.kind
!= gfc_c_int_kind
)
3704 gfc_convert_type (status
, &ts
, 2);
3706 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3710 /* Resolve the SYSTEM intrinsic subroutine. */
3713 gfc_resolve_system_sub (gfc_code
*c
)
3716 name
= gfc_get_string (PREFIX ("system_sub"));
3717 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3721 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
3724 gfc_resolve_system_clock (gfc_code
*c
)
3728 gfc_expr
*count
= c
->ext
.actual
->expr
;
3729 gfc_expr
*count_max
= c
->ext
.actual
->next
->next
->expr
;
3731 /* The INTEGER(8) version has higher precision, it is used if both COUNT
3732 and COUNT_MAX can hold 64-bit values, or are absent. */
3733 if ((!count
|| count
->ts
.kind
>= 8)
3734 && (!count_max
|| count_max
->ts
.kind
>= 8))
3737 kind
= gfc_default_integer_kind
;
3739 name
= gfc_get_string (PREFIX ("system_clock_%d"), kind
);
3740 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3744 /* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine. */
3746 gfc_resolve_execute_command_line (gfc_code
*c
)
3749 name
= gfc_get_string (PREFIX ("execute_command_line_i%d"),
3750 gfc_default_integer_kind
);
3751 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3755 /* Resolve the EXIT intrinsic subroutine. */
3758 gfc_resolve_exit (gfc_code
*c
)
3765 /* The STATUS argument has to be of default kind. If it is not,
3767 ts
.type
= BT_INTEGER
;
3768 ts
.kind
= gfc_default_integer_kind
;
3769 n
= c
->ext
.actual
->expr
;
3770 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3771 gfc_convert_type (n
, &ts
, 2);
3773 name
= gfc_get_string (PREFIX ("exit_i%d"), ts
.kind
);
3774 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3778 /* Resolve the FLUSH intrinsic subroutine. */
3781 gfc_resolve_flush (gfc_code
*c
)
3788 ts
.type
= BT_INTEGER
;
3789 ts
.kind
= gfc_default_integer_kind
;
3790 n
= c
->ext
.actual
->expr
;
3791 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3792 gfc_convert_type (n
, &ts
, 2);
3794 name
= gfc_get_string (PREFIX ("flush_i%d"), ts
.kind
);
3795 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3800 gfc_resolve_ctime_sub (gfc_code
*c
)
3805 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3806 if (c
->ext
.actual
->expr
->ts
.kind
!= 8)
3808 ts
.type
= BT_INTEGER
;
3810 ts
.u
.derived
= NULL
;
3812 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3815 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3820 gfc_resolve_fdate_sub (gfc_code
*c
)
3822 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3827 gfc_resolve_gerror (gfc_code
*c
)
3829 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3834 gfc_resolve_getlog (gfc_code
*c
)
3836 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3841 gfc_resolve_hostnm_sub (gfc_code
*c
)
3846 if (c
->ext
.actual
->next
->expr
!= NULL
)
3847 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3849 kind
= gfc_default_integer_kind
;
3851 name
= gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind
);
3852 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3857 gfc_resolve_perror (gfc_code
*c
)
3859 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3862 /* Resolve the STAT and FSTAT intrinsic subroutines. */
3865 gfc_resolve_stat_sub (gfc_code
*c
)
3868 name
= gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind
);
3869 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3874 gfc_resolve_lstat_sub (gfc_code
*c
)
3877 name
= gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind
);
3878 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3883 gfc_resolve_fstat_sub (gfc_code
*c
)
3889 u
= c
->ext
.actual
->expr
;
3890 ts
= &c
->ext
.actual
->next
->expr
->ts
;
3891 if (u
->ts
.kind
!= ts
->kind
)
3892 gfc_convert_type (u
, ts
, 2);
3893 name
= gfc_get_string (PREFIX ("fstat_i%d_sub"), ts
->kind
);
3894 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3899 gfc_resolve_fgetc_sub (gfc_code
*c
)
3906 u
= c
->ext
.actual
->expr
;
3907 st
= c
->ext
.actual
->next
->next
->expr
;
3909 if (u
->ts
.kind
!= gfc_c_int_kind
)
3911 ts
.type
= BT_INTEGER
;
3912 ts
.kind
= gfc_c_int_kind
;
3913 ts
.u
.derived
= NULL
;
3915 gfc_convert_type (u
, &ts
, 2);
3919 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), st
->ts
.kind
);
3921 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind
);
3923 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3928 gfc_resolve_fget_sub (gfc_code
*c
)
3933 st
= c
->ext
.actual
->next
->expr
;
3935 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), st
->ts
.kind
);
3937 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind
);
3939 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3944 gfc_resolve_fputc_sub (gfc_code
*c
)
3951 u
= c
->ext
.actual
->expr
;
3952 st
= c
->ext
.actual
->next
->next
->expr
;
3954 if (u
->ts
.kind
!= gfc_c_int_kind
)
3956 ts
.type
= BT_INTEGER
;
3957 ts
.kind
= gfc_c_int_kind
;
3958 ts
.u
.derived
= NULL
;
3960 gfc_convert_type (u
, &ts
, 2);
3964 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), st
->ts
.kind
);
3966 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind
);
3968 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3973 gfc_resolve_fput_sub (gfc_code
*c
)
3978 st
= c
->ext
.actual
->next
->expr
;
3980 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), st
->ts
.kind
);
3982 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind
);
3984 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3989 gfc_resolve_fseek_sub (gfc_code
*c
)
3997 unit
= c
->ext
.actual
->expr
;
3998 offset
= c
->ext
.actual
->next
->expr
;
3999 whence
= c
->ext
.actual
->next
->next
->expr
;
4001 if (unit
->ts
.kind
!= gfc_c_int_kind
)
4003 ts
.type
= BT_INTEGER
;
4004 ts
.kind
= gfc_c_int_kind
;
4005 ts
.u
.derived
= NULL
;
4007 gfc_convert_type (unit
, &ts
, 2);
4010 if (offset
->ts
.kind
!= gfc_intio_kind
)
4012 ts
.type
= BT_INTEGER
;
4013 ts
.kind
= gfc_intio_kind
;
4014 ts
.u
.derived
= NULL
;
4016 gfc_convert_type (offset
, &ts
, 2);
4019 if (whence
->ts
.kind
!= gfc_c_int_kind
)
4021 ts
.type
= BT_INTEGER
;
4022 ts
.kind
= gfc_c_int_kind
;
4023 ts
.u
.derived
= NULL
;
4025 gfc_convert_type (whence
, &ts
, 2);
4028 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
4032 gfc_resolve_ftell_sub (gfc_code
*c
)
4040 unit
= c
->ext
.actual
->expr
;
4041 offset
= c
->ext
.actual
->next
->expr
;
4043 if (unit
->ts
.kind
!= gfc_c_int_kind
)
4045 ts
.type
= BT_INTEGER
;
4046 ts
.kind
= gfc_c_int_kind
;
4047 ts
.u
.derived
= NULL
;
4049 gfc_convert_type (unit
, &ts
, 2);
4052 name
= gfc_get_string (PREFIX ("ftell_i%d_sub"), offset
->ts
.kind
);
4053 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
4058 gfc_resolve_ttynam_sub (gfc_code
*c
)
4063 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
4065 ts
.type
= BT_INTEGER
;
4066 ts
.kind
= gfc_c_int_kind
;
4067 ts
.u
.derived
= NULL
;
4069 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
4072 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
4076 /* Resolve the UMASK intrinsic subroutine. */
4079 gfc_resolve_umask_sub (gfc_code
*c
)
4084 if (c
->ext
.actual
->next
->expr
!= NULL
)
4085 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
4087 kind
= gfc_default_integer_kind
;
4089 name
= gfc_get_string (PREFIX ("umask_i%d_sub"), kind
);
4090 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
4093 /* Resolve the UNLINK intrinsic subroutine. */
4096 gfc_resolve_unlink_sub (gfc_code
*c
)
4101 if (c
->ext
.actual
->next
->expr
!= NULL
)
4102 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
4104 kind
= gfc_default_integer_kind
;
4106 name
= gfc_get_string (PREFIX ("unlink_i%d_sub"), kind
);
4107 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);