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
;
156 if (array
->rank
!= -1)
158 f
->shape
= gfc_get_shape (1);
159 mpz_init_set_ui (f
->shape
[0], coarray
? gfc_get_corank (array
)
164 f
->value
.function
.name
= gfc_get_string ("%s", name
);
169 resolve_transformational (const char *name
, gfc_expr
*f
, gfc_expr
*array
,
170 gfc_expr
*dim
, gfc_expr
*mask
)
183 resolve_mask_arg (mask
);
190 f
->rank
= array
->rank
- 1;
191 f
->shape
= gfc_copy_shape_excluding (array
->shape
, array
->rank
, dim
);
192 gfc_resolve_dim_arg (dim
);
195 f
->value
.function
.name
196 = gfc_get_string (PREFIX ("%s%s_%c%d"), prefix
, name
,
197 gfc_type_letter (array
->ts
.type
),
198 gfc_type_abi_kind (&array
->ts
));
202 /********************** Resolution functions **********************/
206 gfc_resolve_abs (gfc_expr
*f
, gfc_expr
*a
)
209 if (f
->ts
.type
== BT_COMPLEX
)
210 f
->ts
.type
= BT_REAL
;
212 f
->value
.function
.name
213 = gfc_get_string ("__abs_%c%d", gfc_type_letter (a
->ts
.type
),
214 gfc_type_abi_kind (&a
->ts
));
219 gfc_resolve_access (gfc_expr
*f
, gfc_expr
*name ATTRIBUTE_UNUSED
,
220 gfc_expr
*mode ATTRIBUTE_UNUSED
)
222 f
->ts
.type
= BT_INTEGER
;
223 f
->ts
.kind
= gfc_c_int_kind
;
224 f
->value
.function
.name
= PREFIX ("access_func");
229 gfc_resolve_adjustl (gfc_expr
*f
, gfc_expr
*string
)
231 f
->ts
.type
= BT_CHARACTER
;
232 f
->ts
.kind
= string
->ts
.kind
;
233 if (string
->ts
.deferred
)
235 else if (string
->ts
.u
.cl
)
236 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, string
->ts
.u
.cl
);
238 f
->value
.function
.name
= gfc_get_string ("__adjustl_s%d", f
->ts
.kind
);
243 gfc_resolve_adjustr (gfc_expr
*f
, gfc_expr
*string
)
245 f
->ts
.type
= BT_CHARACTER
;
246 f
->ts
.kind
= string
->ts
.kind
;
247 if (string
->ts
.deferred
)
249 else if (string
->ts
.u
.cl
)
250 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, string
->ts
.u
.cl
);
252 f
->value
.function
.name
= gfc_get_string ("__adjustr_s%d", f
->ts
.kind
);
257 gfc_resolve_char_achar (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*kind
,
260 f
->ts
.type
= BT_CHARACTER
;
261 f
->ts
.kind
= (kind
== NULL
)
262 ? gfc_default_character_kind
: mpz_get_si (kind
->value
.integer
);
263 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
264 f
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
266 f
->value
.function
.name
267 = gfc_get_string ("__%schar_%d_%c%d", is_achar
? "a" : "", f
->ts
.kind
,
268 gfc_type_letter (x
->ts
.type
),
269 gfc_type_abi_kind (&x
->ts
));
274 gfc_resolve_achar (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*kind
)
276 gfc_resolve_char_achar (f
, x
, kind
, true);
281 gfc_resolve_acos (gfc_expr
*f
, gfc_expr
*x
)
284 f
->value
.function
.name
285 = gfc_get_string ("__acos_%c%d", gfc_type_letter (x
->ts
.type
),
286 gfc_type_abi_kind (&x
->ts
));
291 gfc_resolve_acosh (gfc_expr
*f
, gfc_expr
*x
)
294 f
->value
.function
.name
295 = gfc_get_string ("__acosh_%c%d", gfc_type_letter (x
->ts
.type
),
296 gfc_type_abi_kind (&x
->ts
));
301 gfc_resolve_aimag (gfc_expr
*f
, gfc_expr
*x
)
303 f
->ts
.type
= BT_REAL
;
304 f
->ts
.kind
= x
->ts
.kind
;
305 f
->value
.function
.name
306 = gfc_get_string ("__aimag_%c%d", gfc_type_letter (x
->ts
.type
),
307 gfc_type_abi_kind (&x
->ts
));
312 gfc_resolve_and (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
314 f
->ts
.type
= i
->ts
.type
;
315 f
->ts
.kind
= gfc_kind_max (i
, j
);
317 if (i
->ts
.kind
!= j
->ts
.kind
)
319 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
320 gfc_convert_type (j
, &i
->ts
, 2);
322 gfc_convert_type (i
, &j
->ts
, 2);
325 f
->value
.function
.name
326 = gfc_get_string ("__and_%c%d", gfc_type_letter (i
->ts
.type
),
327 gfc_type_abi_kind (&f
->ts
));
332 gfc_resolve_aint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
337 f
->ts
.type
= a
->ts
.type
;
338 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
340 if (a
->ts
.kind
!= f
->ts
.kind
)
342 ts
.type
= f
->ts
.type
;
343 ts
.kind
= f
->ts
.kind
;
344 gfc_convert_type (a
, &ts
, 2);
346 /* The resolved name is only used for specific intrinsics where
347 the return kind is the same as the arg kind. */
348 f
->value
.function
.name
349 = gfc_get_string ("__aint_%c%d", gfc_type_letter (a
->ts
.type
),
350 gfc_type_abi_kind (&a
->ts
));
355 gfc_resolve_dint (gfc_expr
*f
, gfc_expr
*a
)
357 gfc_resolve_aint (f
, a
, NULL
);
362 gfc_resolve_all (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
)
368 gfc_resolve_dim_arg (dim
);
369 f
->rank
= mask
->rank
- 1;
370 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
373 f
->value
.function
.name
374 = gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask
->ts
.type
),
375 gfc_type_abi_kind (&mask
->ts
));
380 gfc_resolve_anint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
385 f
->ts
.type
= a
->ts
.type
;
386 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
388 if (a
->ts
.kind
!= f
->ts
.kind
)
390 ts
.type
= f
->ts
.type
;
391 ts
.kind
= f
->ts
.kind
;
392 gfc_convert_type (a
, &ts
, 2);
395 /* The resolved name is only used for specific intrinsics where
396 the return kind is the same as the arg kind. */
397 f
->value
.function
.name
398 = gfc_get_string ("__anint_%c%d", gfc_type_letter (a
->ts
.type
),
399 gfc_type_abi_kind (&a
->ts
));
404 gfc_resolve_dnint (gfc_expr
*f
, gfc_expr
*a
)
406 gfc_resolve_anint (f
, a
, NULL
);
411 gfc_resolve_any (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
)
417 gfc_resolve_dim_arg (dim
);
418 f
->rank
= mask
->rank
- 1;
419 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
422 f
->value
.function
.name
423 = gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask
->ts
.type
),
424 gfc_type_abi_kind (&mask
->ts
));
429 gfc_resolve_asin (gfc_expr
*f
, gfc_expr
*x
)
432 f
->value
.function
.name
433 = gfc_get_string ("__asin_%c%d", gfc_type_letter (x
->ts
.type
),
434 gfc_type_abi_kind (&x
->ts
));
438 gfc_resolve_asinh (gfc_expr
*f
, gfc_expr
*x
)
441 f
->value
.function
.name
442 = gfc_get_string ("__asinh_%c%d", gfc_type_letter (x
->ts
.type
),
443 gfc_type_abi_kind (&x
->ts
));
447 gfc_resolve_atan (gfc_expr
*f
, gfc_expr
*x
)
450 f
->value
.function
.name
451 = gfc_get_string ("__atan_%c%d", gfc_type_letter (x
->ts
.type
),
452 gfc_type_abi_kind (&x
->ts
));
456 gfc_resolve_atanh (gfc_expr
*f
, gfc_expr
*x
)
459 f
->value
.function
.name
460 = gfc_get_string ("__atanh_%c%d", gfc_type_letter (x
->ts
.type
),
461 gfc_type_abi_kind (&x
->ts
));
465 gfc_resolve_atan2 (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
468 f
->value
.function
.name
469 = gfc_get_string ("__atan2_%c%d", gfc_type_letter (x
->ts
.type
),
470 gfc_type_abi_kind (&x
->ts
));
474 /* Resolve the BESYN and BESJN intrinsics. */
477 gfc_resolve_besn (gfc_expr
*f
, gfc_expr
*n
, gfc_expr
*x
)
483 if (n
->ts
.kind
!= gfc_c_int_kind
)
485 ts
.type
= BT_INTEGER
;
486 ts
.kind
= gfc_c_int_kind
;
487 gfc_convert_type (n
, &ts
, 2);
489 f
->value
.function
.name
= gfc_get_string ("<intrinsic>");
494 gfc_resolve_bessel_n2 (gfc_expr
*f
, gfc_expr
*n1
, gfc_expr
*n2
, gfc_expr
*x
)
501 if (n1
->expr_type
== EXPR_CONSTANT
&& n2
->expr_type
== EXPR_CONSTANT
)
503 f
->shape
= gfc_get_shape (1);
504 mpz_init (f
->shape
[0]);
505 mpz_sub (f
->shape
[0], n2
->value
.integer
, n1
->value
.integer
);
506 mpz_add_ui (f
->shape
[0], f
->shape
[0], 1);
509 if (n1
->ts
.kind
!= gfc_c_int_kind
)
511 ts
.type
= BT_INTEGER
;
512 ts
.kind
= gfc_c_int_kind
;
513 gfc_convert_type (n1
, &ts
, 2);
516 if (n2
->ts
.kind
!= gfc_c_int_kind
)
518 ts
.type
= BT_INTEGER
;
519 ts
.kind
= gfc_c_int_kind
;
520 gfc_convert_type (n2
, &ts
, 2);
523 if (f
->value
.function
.isym
->id
== GFC_ISYM_JN2
)
524 f
->value
.function
.name
= gfc_get_string (PREFIX ("bessel_jn_r%d"),
525 gfc_type_abi_kind (&f
->ts
));
527 f
->value
.function
.name
= gfc_get_string (PREFIX ("bessel_yn_r%d"),
528 gfc_type_abi_kind (&f
->ts
));
533 gfc_resolve_btest (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos
)
535 f
->ts
.type
= BT_LOGICAL
;
536 f
->ts
.kind
= gfc_default_logical_kind
;
537 f
->value
.function
.name
538 = gfc_get_string ("__btest_%d_%d", i
->ts
.kind
, pos
->ts
.kind
);
543 gfc_resolve_c_loc (gfc_expr
*f
, gfc_expr
*x ATTRIBUTE_UNUSED
)
545 f
->ts
= f
->value
.function
.isym
->ts
;
550 gfc_resolve_c_funloc (gfc_expr
*f
, gfc_expr
*x ATTRIBUTE_UNUSED
)
552 f
->ts
= f
->value
.function
.isym
->ts
;
557 gfc_resolve_ceiling (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
559 f
->ts
.type
= BT_INTEGER
;
560 f
->ts
.kind
= (kind
== NULL
)
561 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
562 f
->value
.function
.name
563 = gfc_get_string ("__ceiling_%d_%c%d", f
->ts
.kind
,
564 gfc_type_letter (a
->ts
.type
),
565 gfc_type_abi_kind (&a
->ts
));
570 gfc_resolve_char (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
572 gfc_resolve_char_achar (f
, a
, kind
, false);
577 gfc_resolve_chdir (gfc_expr
*f
, gfc_expr
*d ATTRIBUTE_UNUSED
)
579 f
->ts
.type
= BT_INTEGER
;
580 f
->ts
.kind
= gfc_default_integer_kind
;
581 f
->value
.function
.name
= gfc_get_string (PREFIX ("chdir_i%d"), f
->ts
.kind
);
586 gfc_resolve_chdir_sub (gfc_code
*c
)
591 if (c
->ext
.actual
->next
->expr
!= NULL
)
592 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
594 kind
= gfc_default_integer_kind
;
596 name
= gfc_get_string (PREFIX ("chdir_i%d_sub"), kind
);
597 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
602 gfc_resolve_chmod (gfc_expr
*f
, gfc_expr
*name ATTRIBUTE_UNUSED
,
603 gfc_expr
*mode ATTRIBUTE_UNUSED
)
605 f
->ts
.type
= BT_INTEGER
;
606 f
->ts
.kind
= gfc_c_int_kind
;
607 f
->value
.function
.name
= PREFIX ("chmod_func");
612 gfc_resolve_chmod_sub (gfc_code
*c
)
617 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
618 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
620 kind
= gfc_default_integer_kind
;
622 name
= gfc_get_string (PREFIX ("chmod_i%d_sub"), kind
);
623 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
628 gfc_resolve_cmplx (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*kind
)
630 f
->ts
.type
= BT_COMPLEX
;
631 f
->ts
.kind
= (kind
== NULL
)
632 ? gfc_default_real_kind
: mpz_get_si (kind
->value
.integer
);
635 f
->value
.function
.name
636 = gfc_get_string ("__cmplx0_%d_%c%d", f
->ts
.kind
,
637 gfc_type_letter (x
->ts
.type
),
638 gfc_type_abi_kind (&x
->ts
));
640 f
->value
.function
.name
641 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f
->ts
.kind
,
642 gfc_type_letter (x
->ts
.type
),
643 gfc_type_abi_kind (&x
->ts
),
644 gfc_type_letter (y
->ts
.type
),
645 gfc_type_abi_kind (&y
->ts
));
650 gfc_resolve_dcmplx (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
)
652 gfc_resolve_cmplx (f
, x
, y
, gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
653 gfc_default_double_kind
));
658 gfc_resolve_complex (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
)
662 if (x
->ts
.type
== BT_INTEGER
)
664 if (y
->ts
.type
== BT_INTEGER
)
665 kind
= gfc_default_real_kind
;
671 if (y
->ts
.type
== BT_REAL
)
672 kind
= (x
->ts
.kind
> y
->ts
.kind
) ? x
->ts
.kind
: y
->ts
.kind
;
677 f
->ts
.type
= BT_COMPLEX
;
679 f
->value
.function
.name
680 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f
->ts
.kind
,
681 gfc_type_letter (x
->ts
.type
),
682 gfc_type_abi_kind (&x
->ts
),
683 gfc_type_letter (y
->ts
.type
),
684 gfc_type_abi_kind (&y
->ts
));
689 gfc_resolve_conjg (gfc_expr
*f
, gfc_expr
*x
)
692 f
->value
.function
.name
= gfc_get_string ("__conjg_%d", x
->ts
.kind
);
697 gfc_resolve_cos (gfc_expr
*f
, gfc_expr
*x
)
700 f
->value
.function
.name
701 = gfc_get_string ("__cos_%c%d", gfc_type_letter (x
->ts
.type
),
702 gfc_type_abi_kind (&x
->ts
));
707 gfc_resolve_cosh (gfc_expr
*f
, gfc_expr
*x
)
710 f
->value
.function
.name
711 = gfc_get_string ("__cosh_%c%d", gfc_type_letter (x
->ts
.type
),
712 gfc_type_abi_kind (&x
->ts
));
717 gfc_resolve_count (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
719 f
->ts
.type
= BT_INTEGER
;
721 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
723 f
->ts
.kind
= gfc_default_integer_kind
;
727 f
->rank
= mask
->rank
- 1;
728 gfc_resolve_dim_arg (dim
);
729 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
732 resolve_mask_arg (mask
);
734 f
->value
.function
.name
735 = gfc_get_string (PREFIX ("count_%d_%c"), gfc_type_abi_kind (&f
->ts
),
736 gfc_type_letter (mask
->ts
.type
));
741 gfc_resolve_cshift (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*shift
,
746 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
747 gfc_resolve_substring_charlen (array
);
750 f
->rank
= array
->rank
;
751 f
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
758 /* If dim kind is greater than default integer we need to use the larger. */
759 m
= gfc_default_integer_kind
;
761 m
= m
< dim
->ts
.kind
? dim
->ts
.kind
: m
;
763 /* Convert shift to at least m, so we don't need
764 kind=1 and kind=2 versions of the library functions. */
765 if (shift
->ts
.kind
< m
)
769 ts
.type
= BT_INTEGER
;
771 gfc_convert_type_warn (shift
, &ts
, 2, 0);
776 if (dim
->expr_type
!= EXPR_CONSTANT
&& dim
->symtree
!= NULL
777 && dim
->symtree
->n
.sym
->attr
.optional
)
779 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
780 dim
->representation
.length
= shift
->ts
.kind
;
784 gfc_resolve_dim_arg (dim
);
785 /* Convert dim to shift's kind to reduce variations. */
786 if (dim
->ts
.kind
!= shift
->ts
.kind
)
787 gfc_convert_type_warn (dim
, &shift
->ts
, 2, 0);
791 if (array
->ts
.type
== BT_CHARACTER
)
793 if (array
->ts
.kind
== gfc_default_character_kind
)
794 f
->value
.function
.name
795 = gfc_get_string (PREFIX ("cshift%d_%d_char"), n
, shift
->ts
.kind
);
797 f
->value
.function
.name
798 = gfc_get_string (PREFIX ("cshift%d_%d_char%d"), n
, shift
->ts
.kind
,
802 f
->value
.function
.name
803 = gfc_get_string (PREFIX ("cshift%d_%d"), n
, shift
->ts
.kind
);
808 gfc_resolve_ctime (gfc_expr
*f
, gfc_expr
*time
)
813 f
->ts
.type
= BT_CHARACTER
;
814 f
->ts
.kind
= gfc_default_character_kind
;
816 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
817 if (time
->ts
.kind
!= 8)
819 ts
.type
= BT_INTEGER
;
823 gfc_convert_type (time
, &ts
, 2);
826 f
->value
.function
.name
= gfc_get_string (PREFIX ("ctime"));
831 gfc_resolve_dble (gfc_expr
*f
, gfc_expr
*a
)
833 f
->ts
.type
= BT_REAL
;
834 f
->ts
.kind
= gfc_default_double_kind
;
835 f
->value
.function
.name
836 = gfc_get_string ("__dble_%c%d", gfc_type_letter (a
->ts
.type
),
837 gfc_type_abi_kind (&a
->ts
));
842 gfc_resolve_dim (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
844 f
->ts
.type
= a
->ts
.type
;
846 f
->ts
.kind
= gfc_kind_max (a
,p
);
848 f
->ts
.kind
= a
->ts
.kind
;
850 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
852 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
853 gfc_convert_type (p
, &a
->ts
, 2);
855 gfc_convert_type (a
, &p
->ts
, 2);
858 f
->value
.function
.name
859 = gfc_get_string ("__dim_%c%d", gfc_type_letter (f
->ts
.type
),
860 gfc_type_abi_kind (&f
->ts
));
865 gfc_resolve_dot_product (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b
)
869 temp
.expr_type
= EXPR_OP
;
870 gfc_clear_ts (&temp
.ts
);
871 temp
.value
.op
.op
= INTRINSIC_NONE
;
872 temp
.value
.op
.op1
= a
;
873 temp
.value
.op
.op2
= b
;
874 gfc_type_convert_binary (&temp
, 1);
876 f
->value
.function
.name
877 = gfc_get_string (PREFIX ("dot_product_%c%d"),
878 gfc_type_letter (f
->ts
.type
),
879 gfc_type_abi_kind (&f
->ts
));
884 gfc_resolve_dprod (gfc_expr
*f
, gfc_expr
*a ATTRIBUTE_UNUSED
,
885 gfc_expr
*b ATTRIBUTE_UNUSED
)
887 f
->ts
.kind
= gfc_default_double_kind
;
888 f
->ts
.type
= BT_REAL
;
889 f
->value
.function
.name
= gfc_get_string ("__dprod_r%d",
890 gfc_type_abi_kind (&f
->ts
));
895 gfc_resolve_dshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j ATTRIBUTE_UNUSED
,
896 gfc_expr
*shift ATTRIBUTE_UNUSED
)
899 if (f
->value
.function
.isym
->id
== GFC_ISYM_DSHIFTL
)
900 f
->value
.function
.name
= gfc_get_string ("dshiftl_i%d", f
->ts
.kind
);
901 else if (f
->value
.function
.isym
->id
== GFC_ISYM_DSHIFTR
)
902 f
->value
.function
.name
= gfc_get_string ("dshiftr_i%d", f
->ts
.kind
);
909 gfc_resolve_eoshift (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*shift
,
910 gfc_expr
*boundary
, gfc_expr
*dim
)
914 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
915 gfc_resolve_substring_charlen (array
);
918 f
->rank
= array
->rank
;
919 f
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
924 if (boundary
&& boundary
->rank
> 0)
927 /* If dim kind is greater than default integer we need to use the larger. */
928 m
= gfc_default_integer_kind
;
930 m
= m
< dim
->ts
.kind
? dim
->ts
.kind
: m
;
932 /* Convert shift to at least m, so we don't need
933 kind=1 and kind=2 versions of the library functions. */
934 if (shift
->ts
.kind
< m
)
938 ts
.type
= BT_INTEGER
;
940 gfc_convert_type_warn (shift
, &ts
, 2, 0);
945 if (dim
->expr_type
!= EXPR_CONSTANT
&& dim
->symtree
!= NULL
946 && dim
->symtree
->n
.sym
->attr
.optional
)
948 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
949 dim
->representation
.length
= shift
->ts
.kind
;
953 gfc_resolve_dim_arg (dim
);
954 /* Convert dim to shift's kind to reduce variations. */
955 if (dim
->ts
.kind
!= shift
->ts
.kind
)
956 gfc_convert_type_warn (dim
, &shift
->ts
, 2, 0);
960 if (array
->ts
.type
== BT_CHARACTER
)
962 if (array
->ts
.kind
== gfc_default_character_kind
)
963 f
->value
.function
.name
964 = gfc_get_string (PREFIX ("eoshift%d_%d_char"), n
, shift
->ts
.kind
);
966 f
->value
.function
.name
967 = gfc_get_string (PREFIX ("eoshift%d_%d_char%d"), n
, shift
->ts
.kind
,
971 f
->value
.function
.name
972 = gfc_get_string (PREFIX ("eoshift%d_%d"), n
, shift
->ts
.kind
);
977 gfc_resolve_exp (gfc_expr
*f
, gfc_expr
*x
)
980 f
->value
.function
.name
981 = gfc_get_string ("__exp_%c%d", gfc_type_letter (x
->ts
.type
),
982 gfc_type_abi_kind (&x
->ts
));
987 gfc_resolve_exponent (gfc_expr
*f
, gfc_expr
*x
)
989 f
->ts
.type
= BT_INTEGER
;
990 f
->ts
.kind
= gfc_default_integer_kind
;
991 f
->value
.function
.name
= gfc_get_string ("__exponent_%d", x
->ts
.kind
);
995 /* Resolve the EXTENDS_TYPE_OF intrinsic function. */
998 gfc_resolve_extends_type_of (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*mo
)
1003 /* Prevent double resolution. */
1004 if (f
->ts
.type
== BT_LOGICAL
)
1007 /* Replace the first argument with the corresponding vtab. */
1008 if (a
->ts
.type
== BT_CLASS
)
1009 gfc_add_vptr_component (a
);
1010 else if (a
->ts
.type
== BT_DERIVED
)
1014 vtab
= gfc_find_derived_vtab (a
->ts
.u
.derived
);
1015 /* Clear the old expr. */
1016 gfc_free_ref_list (a
->ref
);
1018 memset (a
, '\0', sizeof (gfc_expr
));
1019 /* Construct a new one. */
1020 a
->expr_type
= EXPR_VARIABLE
;
1021 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
1027 /* Replace the second argument with the corresponding vtab. */
1028 if (mo
->ts
.type
== BT_CLASS
)
1029 gfc_add_vptr_component (mo
);
1030 else if (mo
->ts
.type
== BT_DERIVED
)
1034 vtab
= gfc_find_derived_vtab (mo
->ts
.u
.derived
);
1035 /* Clear the old expr. */
1037 gfc_free_ref_list (mo
->ref
);
1038 memset (mo
, '\0', sizeof (gfc_expr
));
1039 /* Construct a new one. */
1040 mo
->expr_type
= EXPR_VARIABLE
;
1041 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
1047 f
->ts
.type
= BT_LOGICAL
;
1050 f
->value
.function
.isym
->formal
->ts
= a
->ts
;
1051 f
->value
.function
.isym
->formal
->next
->ts
= mo
->ts
;
1053 /* Call library function. */
1054 f
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
1059 gfc_resolve_fdate (gfc_expr
*f
)
1061 f
->ts
.type
= BT_CHARACTER
;
1062 f
->ts
.kind
= gfc_default_character_kind
;
1063 f
->value
.function
.name
= gfc_get_string (PREFIX ("fdate"));
1068 gfc_resolve_floor (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1070 f
->ts
.type
= BT_INTEGER
;
1071 f
->ts
.kind
= (kind
== NULL
)
1072 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
1073 f
->value
.function
.name
1074 = gfc_get_string ("__floor%d_%c%d", f
->ts
.kind
,
1075 gfc_type_letter (a
->ts
.type
),
1076 gfc_type_abi_kind (&a
->ts
));
1081 gfc_resolve_fnum (gfc_expr
*f
, gfc_expr
*n
)
1083 f
->ts
.type
= BT_INTEGER
;
1084 f
->ts
.kind
= gfc_default_integer_kind
;
1085 if (n
->ts
.kind
!= f
->ts
.kind
)
1086 gfc_convert_type (n
, &f
->ts
, 2);
1087 f
->value
.function
.name
= gfc_get_string (PREFIX ("fnum_i%d"), f
->ts
.kind
);
1092 gfc_resolve_fraction (gfc_expr
*f
, gfc_expr
*x
)
1095 f
->value
.function
.name
= gfc_get_string ("__fraction_%d", x
->ts
.kind
);
1099 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
1102 gfc_resolve_g77_math1 (gfc_expr
*f
, gfc_expr
*x
)
1105 f
->value
.function
.name
= gfc_get_string ("<intrinsic>");
1110 gfc_resolve_gamma (gfc_expr
*f
, gfc_expr
*x
)
1113 f
->value
.function
.name
1114 = gfc_get_string ("__tgamma_%d", x
->ts
.kind
);
1119 gfc_resolve_getcwd (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
1121 f
->ts
.type
= BT_INTEGER
;
1123 f
->value
.function
.name
= gfc_get_string (PREFIX ("getcwd"));
1128 gfc_resolve_getgid (gfc_expr
*f
)
1130 f
->ts
.type
= BT_INTEGER
;
1132 f
->value
.function
.name
= gfc_get_string (PREFIX ("getgid"));
1137 gfc_resolve_getpid (gfc_expr
*f
)
1139 f
->ts
.type
= BT_INTEGER
;
1141 f
->value
.function
.name
= gfc_get_string (PREFIX ("getpid"));
1146 gfc_resolve_getuid (gfc_expr
*f
)
1148 f
->ts
.type
= BT_INTEGER
;
1150 f
->value
.function
.name
= gfc_get_string (PREFIX ("getuid"));
1155 gfc_resolve_hostnm (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
1157 f
->ts
.type
= BT_INTEGER
;
1159 f
->value
.function
.name
= gfc_get_string (PREFIX ("hostnm"));
1164 gfc_resolve_hypot (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
1167 f
->value
.function
.name
= gfc_get_string ("__hypot_r%d",
1168 gfc_type_abi_kind (&x
->ts
));
1173 gfc_resolve_iall (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
1175 resolve_transformational ("iall", f
, array
, dim
, mask
);
1180 gfc_resolve_iand (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1182 /* If the kind of i and j are different, then g77 cross-promoted the
1183 kinds to the largest value. The Fortran 95 standard requires the
1185 if (i
->ts
.kind
!= j
->ts
.kind
)
1187 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1188 gfc_convert_type (j
, &i
->ts
, 2);
1190 gfc_convert_type (i
, &j
->ts
, 2);
1194 f
->value
.function
.name
= gfc_get_string ("__iand_%d", i
->ts
.kind
);
1199 gfc_resolve_iany (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
1201 resolve_transformational ("iany", f
, array
, dim
, mask
);
1206 gfc_resolve_ibclr (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
)
1209 f
->value
.function
.name
= gfc_get_string ("__ibclr_%d", i
->ts
.kind
);
1214 gfc_resolve_ibits (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
,
1215 gfc_expr
*len ATTRIBUTE_UNUSED
)
1218 f
->value
.function
.name
= gfc_get_string ("__ibits_%d", i
->ts
.kind
);
1223 gfc_resolve_ibset (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
)
1226 f
->value
.function
.name
= gfc_get_string ("__ibset_%d", i
->ts
.kind
);
1231 gfc_resolve_iachar (gfc_expr
*f
, gfc_expr
*c
, gfc_expr
*kind
)
1233 f
->ts
.type
= BT_INTEGER
;
1235 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1237 f
->ts
.kind
= gfc_default_integer_kind
;
1238 f
->value
.function
.name
= gfc_get_string ("__ichar_%d", c
->ts
.kind
);
1243 gfc_resolve_ichar (gfc_expr
*f
, gfc_expr
*c
, gfc_expr
*kind
)
1245 f
->ts
.type
= BT_INTEGER
;
1247 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1249 f
->ts
.kind
= gfc_default_integer_kind
;
1250 f
->value
.function
.name
= gfc_get_string ("__ichar_%d", c
->ts
.kind
);
1255 gfc_resolve_idnint (gfc_expr
*f
, gfc_expr
*a
)
1257 gfc_resolve_nint (f
, a
, NULL
);
1262 gfc_resolve_ierrno (gfc_expr
*f
)
1264 f
->ts
.type
= BT_INTEGER
;
1265 f
->ts
.kind
= gfc_default_integer_kind
;
1266 f
->value
.function
.name
= gfc_get_string (PREFIX ("ierrno_i%d"), f
->ts
.kind
);
1271 gfc_resolve_ieor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1273 /* If the kind of i and j are different, then g77 cross-promoted the
1274 kinds to the largest value. The Fortran 95 standard requires the
1276 if (i
->ts
.kind
!= j
->ts
.kind
)
1278 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1279 gfc_convert_type (j
, &i
->ts
, 2);
1281 gfc_convert_type (i
, &j
->ts
, 2);
1285 f
->value
.function
.name
= gfc_get_string ("__ieor_%d", i
->ts
.kind
);
1290 gfc_resolve_ior (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1292 /* If the kind of i and j are different, then g77 cross-promoted the
1293 kinds to the largest value. The Fortran 95 standard requires the
1295 if (i
->ts
.kind
!= j
->ts
.kind
)
1297 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1298 gfc_convert_type (j
, &i
->ts
, 2);
1300 gfc_convert_type (i
, &j
->ts
, 2);
1304 f
->value
.function
.name
= gfc_get_string ("__ior_%d", i
->ts
.kind
);
1309 gfc_resolve_index_func (gfc_expr
*f
, gfc_expr
*str
,
1310 gfc_expr
*sub_str ATTRIBUTE_UNUSED
, gfc_expr
*back
,
1316 f
->ts
.type
= BT_INTEGER
;
1318 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1320 f
->ts
.kind
= gfc_default_integer_kind
;
1322 if (back
&& back
->ts
.kind
!= gfc_default_integer_kind
)
1324 ts
.type
= BT_LOGICAL
;
1325 ts
.kind
= gfc_default_integer_kind
;
1326 ts
.u
.derived
= NULL
;
1328 gfc_convert_type (back
, &ts
, 2);
1331 f
->value
.function
.name
1332 = gfc_get_string ("__index_%d_i%d", str
->ts
.kind
, f
->ts
.kind
);
1337 gfc_resolve_int (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1339 f
->ts
.type
= BT_INTEGER
;
1340 f
->ts
.kind
= (kind
== NULL
)
1341 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
1342 f
->value
.function
.name
1343 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1344 gfc_type_letter (a
->ts
.type
),
1345 gfc_type_abi_kind (&a
->ts
));
1350 gfc_resolve_int2 (gfc_expr
*f
, gfc_expr
*a
)
1352 f
->ts
.type
= BT_INTEGER
;
1354 f
->value
.function
.name
1355 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1356 gfc_type_letter (a
->ts
.type
),
1357 gfc_type_abi_kind (&a
->ts
));
1362 gfc_resolve_int8 (gfc_expr
*f
, gfc_expr
*a
)
1364 f
->ts
.type
= BT_INTEGER
;
1366 f
->value
.function
.name
1367 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1368 gfc_type_letter (a
->ts
.type
),
1369 gfc_type_abi_kind (&a
->ts
));
1374 gfc_resolve_long (gfc_expr
*f
, gfc_expr
*a
)
1376 f
->ts
.type
= BT_INTEGER
;
1378 f
->value
.function
.name
1379 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1380 gfc_type_letter (a
->ts
.type
),
1381 gfc_type_abi_kind (&a
->ts
));
1386 gfc_resolve_iparity (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
1388 resolve_transformational ("iparity", f
, array
, dim
, mask
);
1393 gfc_resolve_isatty (gfc_expr
*f
, gfc_expr
*u
)
1398 f
->ts
.type
= BT_LOGICAL
;
1399 f
->ts
.kind
= gfc_default_integer_kind
;
1400 if (u
->ts
.kind
!= gfc_c_int_kind
)
1402 ts
.type
= BT_INTEGER
;
1403 ts
.kind
= gfc_c_int_kind
;
1404 ts
.u
.derived
= NULL
;
1406 gfc_convert_type (u
, &ts
, 2);
1409 f
->value
.function
.name
= gfc_get_string (PREFIX ("isatty_l%d"), f
->ts
.kind
);
1414 gfc_resolve_is_contiguous (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
)
1416 f
->ts
.type
= BT_LOGICAL
;
1417 f
->ts
.kind
= gfc_default_logical_kind
;
1418 f
->value
.function
.name
= gfc_get_string ("__is_contiguous");
1423 gfc_resolve_ishft (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1426 f
->value
.function
.name
1427 = gfc_get_string ("__ishft_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1432 gfc_resolve_rshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1435 f
->value
.function
.name
1436 = gfc_get_string ("__rshift_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1441 gfc_resolve_lshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1444 f
->value
.function
.name
1445 = gfc_get_string ("__lshift_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1450 gfc_resolve_ishftc (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
1454 s_kind
= (size
== NULL
) ? gfc_default_integer_kind
: size
->ts
.kind
;
1457 f
->value
.function
.name
1458 = gfc_get_string ("__ishftc_%d_%d_%d", i
->ts
.kind
, shift
->ts
.kind
, s_kind
);
1463 gfc_resolve_lbound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
1465 resolve_bound (f
, array
, dim
, kind
, "__lbound", false);
1470 gfc_resolve_lcobound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
1472 resolve_bound (f
, array
, dim
, kind
, "__lcobound", true);
1477 gfc_resolve_len (gfc_expr
*f
, gfc_expr
*string
, gfc_expr
*kind
)
1479 f
->ts
.type
= BT_INTEGER
;
1481 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1483 f
->ts
.kind
= gfc_default_integer_kind
;
1484 f
->value
.function
.name
1485 = gfc_get_string ("__len_%d_i%d", string
->ts
.kind
,
1486 gfc_default_integer_kind
);
1491 gfc_resolve_len_trim (gfc_expr
*f
, gfc_expr
*string
, gfc_expr
*kind
)
1493 f
->ts
.type
= BT_INTEGER
;
1495 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1497 f
->ts
.kind
= gfc_default_integer_kind
;
1498 f
->value
.function
.name
= gfc_get_string ("__len_trim%d", string
->ts
.kind
);
1503 gfc_resolve_lgamma (gfc_expr
*f
, gfc_expr
*x
)
1506 f
->value
.function
.name
1507 = gfc_get_string ("__lgamma_%d", x
->ts
.kind
);
1512 gfc_resolve_link (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
1513 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
1515 f
->ts
.type
= BT_INTEGER
;
1516 f
->ts
.kind
= gfc_default_integer_kind
;
1517 f
->value
.function
.name
= gfc_get_string (PREFIX ("link_i%d"), f
->ts
.kind
);
1522 gfc_resolve_loc (gfc_expr
*f
, gfc_expr
*x
)
1524 f
->ts
.type
= BT_INTEGER
;
1525 f
->ts
.kind
= gfc_index_integer_kind
;
1526 f
->value
.function
.name
= gfc_get_string ("__loc_%d", x
->ts
.kind
);
1531 gfc_resolve_log (gfc_expr
*f
, gfc_expr
*x
)
1534 f
->value
.function
.name
1535 = gfc_get_string ("__log_%c%d", gfc_type_letter (x
->ts
.type
),
1536 gfc_type_abi_kind (&x
->ts
));
1541 gfc_resolve_log10 (gfc_expr
*f
, gfc_expr
*x
)
1544 f
->value
.function
.name
1545 = gfc_get_string ("__log10_%c%d", gfc_type_letter (x
->ts
.type
),
1546 gfc_type_abi_kind (&x
->ts
));
1551 gfc_resolve_logical (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1553 f
->ts
.type
= BT_LOGICAL
;
1554 f
->ts
.kind
= (kind
== NULL
)
1555 ? gfc_default_logical_kind
: mpz_get_si (kind
->value
.integer
);
1558 f
->value
.function
.name
1559 = gfc_get_string ("__logical_%d_%c%d", f
->ts
.kind
,
1560 gfc_type_letter (a
->ts
.type
),
1561 gfc_type_abi_kind (&a
->ts
));
1566 gfc_resolve_matmul (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b
)
1570 if (a
->ts
.type
== BT_LOGICAL
&& b
->ts
.type
== BT_LOGICAL
)
1572 f
->ts
.type
= BT_LOGICAL
;
1573 f
->ts
.kind
= gfc_default_logical_kind
;
1577 temp
.expr_type
= EXPR_OP
;
1578 gfc_clear_ts (&temp
.ts
);
1579 temp
.value
.op
.op
= INTRINSIC_NONE
;
1580 temp
.value
.op
.op1
= a
;
1581 temp
.value
.op
.op2
= b
;
1582 gfc_type_convert_binary (&temp
, 1);
1586 f
->rank
= (a
->rank
== 2 && b
->rank
== 2) ? 2 : 1;
1588 if (a
->rank
== 2 && b
->rank
== 2)
1590 if (a
->shape
&& b
->shape
)
1592 f
->shape
= gfc_get_shape (f
->rank
);
1593 mpz_init_set (f
->shape
[0], a
->shape
[0]);
1594 mpz_init_set (f
->shape
[1], b
->shape
[1]);
1597 else if (a
->rank
== 1)
1601 f
->shape
= gfc_get_shape (f
->rank
);
1602 mpz_init_set (f
->shape
[0], b
->shape
[1]);
1607 /* b->rank == 1 and a->rank == 2 here, all other cases have
1608 been caught in check.cc. */
1611 f
->shape
= gfc_get_shape (f
->rank
);
1612 mpz_init_set (f
->shape
[0], a
->shape
[0]);
1616 f
->value
.function
.name
1617 = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f
->ts
.type
),
1618 gfc_type_abi_kind (&f
->ts
));
1623 gfc_resolve_minmax (const char *name
, gfc_expr
*f
, gfc_actual_arglist
*args
)
1625 gfc_actual_arglist
*a
;
1627 f
->ts
.type
= args
->expr
->ts
.type
;
1628 f
->ts
.kind
= args
->expr
->ts
.kind
;
1629 /* Find the largest type kind. */
1630 for (a
= args
->next
; a
; a
= a
->next
)
1632 if (a
->expr
->ts
.kind
> f
->ts
.kind
)
1633 f
->ts
.kind
= a
->expr
->ts
.kind
;
1636 /* Convert all parameters to the required kind. */
1637 for (a
= args
; a
; a
= a
->next
)
1639 if (a
->expr
->ts
.kind
!= f
->ts
.kind
)
1640 gfc_convert_type (a
->expr
, &f
->ts
, 2);
1643 f
->value
.function
.name
1644 = gfc_get_string (name
, gfc_type_letter (f
->ts
.type
),
1645 gfc_type_abi_kind (&f
->ts
));
1650 gfc_resolve_max (gfc_expr
*f
, gfc_actual_arglist
*args
)
1652 gfc_resolve_minmax ("__max_%c%d", f
, args
);
1655 /* The smallest kind for which a minloc and maxloc implementation exists. */
1657 #define MINMAXLOC_MIN_KIND 4
1660 gfc_resolve_maxloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1661 gfc_expr
*mask
, gfc_expr
*kind
, gfc_expr
*back
)
1668 f
->ts
.type
= BT_INTEGER
;
1670 /* The library versions only exist for kinds 4, 8 and 16. For smaller kinds,
1671 we do a type conversion further down. */
1673 fkind
= mpz_get_si (kind
->value
.integer
);
1675 fkind
= gfc_default_integer_kind
;
1677 if (fkind
< MINMAXLOC_MIN_KIND
)
1678 f
->ts
.kind
= MINMAXLOC_MIN_KIND
;
1685 f
->shape
= gfc_get_shape (1);
1686 mpz_init_set_si (f
->shape
[0], array
->rank
);
1690 f
->rank
= array
->rank
- 1;
1691 gfc_resolve_dim_arg (dim
);
1692 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1694 idim
= (int) mpz_get_si (dim
->value
.integer
);
1695 f
->shape
= gfc_get_shape (f
->rank
);
1696 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1698 if (i
== (idim
- 1))
1700 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1707 if (mask
->rank
== 0)
1712 resolve_mask_arg (mask
);
1719 if (array
->ts
.type
!= BT_CHARACTER
|| f
->rank
!= 0)
1727 f
->value
.function
.name
1728 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name
, d_num
, f
->ts
.kind
,
1729 gfc_type_letter (array
->ts
.type
),
1730 gfc_type_abi_kind (&array
->ts
));
1733 fkind
= mpz_get_si (kind
->value
.integer
);
1735 fkind
= gfc_default_integer_kind
;
1737 if (fkind
!= f
->ts
.kind
)
1742 ts
.type
= BT_INTEGER
;
1744 gfc_convert_type_warn (f
, &ts
, 2, 0);
1747 if (back
->ts
.kind
!= gfc_logical_4_kind
)
1751 ts
.type
= BT_LOGICAL
;
1752 ts
.kind
= gfc_logical_4_kind
;
1753 gfc_convert_type_warn (back
, &ts
, 2, 0);
1759 gfc_resolve_findloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*value
,
1760 gfc_expr
*dim
, gfc_expr
*mask
, gfc_expr
*kind
,
1768 /* See at the end of the function for why this is necessary. */
1770 if (f
->do_not_resolve_again
)
1773 f
->ts
.type
= BT_INTEGER
;
1775 /* We have a single library version, which uses index_type. */
1778 fkind
= mpz_get_si (kind
->value
.integer
);
1780 fkind
= gfc_default_integer_kind
;
1782 f
->ts
.kind
= gfc_index_integer_kind
;
1784 /* Convert value. If array is not LOGICAL and value is, we already
1785 issued an error earlier. */
1787 if ((array
->ts
.type
!= value
->ts
.type
&& value
->ts
.type
!= BT_LOGICAL
)
1788 || array
->ts
.kind
!= value
->ts
.kind
)
1789 gfc_convert_type_warn (value
, &array
->ts
, 2, 0);
1794 f
->shape
= gfc_get_shape (1);
1795 mpz_init_set_si (f
->shape
[0], array
->rank
);
1799 f
->rank
= array
->rank
- 1;
1800 gfc_resolve_dim_arg (dim
);
1801 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1803 idim
= (int) mpz_get_si (dim
->value
.integer
);
1804 f
->shape
= gfc_get_shape (f
->rank
);
1805 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1807 if (i
== (idim
- 1))
1809 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1816 if (mask
->rank
== 0)
1821 resolve_mask_arg (mask
);
1836 if (back
->ts
.kind
!= gfc_logical_4_kind
)
1840 ts
.type
= BT_LOGICAL
;
1841 ts
.kind
= gfc_logical_4_kind
;
1842 gfc_convert_type_warn (back
, &ts
, 2, 0);
1845 f
->value
.function
.name
1846 = gfc_get_string (PREFIX ("%s%d_%c%d"), name
, d_num
,
1847 gfc_type_letter (array
->ts
.type
, true),
1848 gfc_type_abi_kind (&array
->ts
));
1850 /* We only have a single library function, so we need to convert
1851 here. If the function is resolved from within a convert
1852 function generated on a previous round of resolution, endless
1853 recursion could occur. Guard against that here. */
1855 if (f
->ts
.kind
!= fkind
)
1857 f
->do_not_resolve_again
= 1;
1861 ts
.type
= BT_INTEGER
;
1863 gfc_convert_type_warn (f
, &ts
, 2, 0);
1869 gfc_resolve_maxval (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1879 f
->rank
= array
->rank
- 1;
1880 gfc_resolve_dim_arg (dim
);
1882 if (f
->rank
&& array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1884 idim
= (int) mpz_get_si (dim
->value
.integer
);
1885 f
->shape
= gfc_get_shape (f
->rank
);
1886 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1888 if (i
== (idim
- 1))
1890 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1897 if (mask
->rank
== 0)
1902 resolve_mask_arg (mask
);
1907 if (array
->ts
.type
!= BT_CHARACTER
)
1908 f
->value
.function
.name
1909 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
1910 gfc_type_letter (array
->ts
.type
),
1911 gfc_type_abi_kind (&array
->ts
));
1913 f
->value
.function
.name
1914 = gfc_get_string (PREFIX ("%s%d_%c%d"), name
, f
->rank
!= 0,
1915 gfc_type_letter (array
->ts
.type
),
1916 gfc_type_abi_kind (&array
->ts
));
1921 gfc_resolve_mclock (gfc_expr
*f
)
1923 f
->ts
.type
= BT_INTEGER
;
1925 f
->value
.function
.name
= PREFIX ("mclock");
1930 gfc_resolve_mclock8 (gfc_expr
*f
)
1932 f
->ts
.type
= BT_INTEGER
;
1934 f
->value
.function
.name
= PREFIX ("mclock8");
1939 gfc_resolve_mask (gfc_expr
*f
, gfc_expr
*i ATTRIBUTE_UNUSED
,
1942 f
->ts
.type
= BT_INTEGER
;
1943 f
->ts
.kind
= kind
? mpz_get_si (kind
->value
.integer
)
1944 : gfc_default_integer_kind
;
1946 if (f
->value
.function
.isym
->id
== GFC_ISYM_MASKL
)
1947 f
->value
.function
.name
= gfc_get_string ("__maskl_i%d", f
->ts
.kind
);
1949 f
->value
.function
.name
= gfc_get_string ("__maskr_i%d", f
->ts
.kind
);
1954 gfc_resolve_merge (gfc_expr
*f
, gfc_expr
*tsource
,
1955 gfc_expr
*fsource ATTRIBUTE_UNUSED
,
1956 gfc_expr
*mask ATTRIBUTE_UNUSED
)
1958 if (tsource
->ts
.type
== BT_CHARACTER
&& tsource
->ref
)
1959 gfc_resolve_substring_charlen (tsource
);
1961 if (fsource
->ts
.type
== BT_CHARACTER
&& fsource
->ref
)
1962 gfc_resolve_substring_charlen (fsource
);
1964 if (tsource
->ts
.type
== BT_CHARACTER
)
1965 check_charlen_present (tsource
);
1967 f
->ts
= tsource
->ts
;
1968 f
->value
.function
.name
1969 = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource
->ts
.type
),
1970 gfc_type_abi_kind (&tsource
->ts
));
1975 gfc_resolve_merge_bits (gfc_expr
*f
, gfc_expr
*i
,
1976 gfc_expr
*j ATTRIBUTE_UNUSED
,
1977 gfc_expr
*mask ATTRIBUTE_UNUSED
)
1980 f
->value
.function
.name
= gfc_get_string ("__merge_bits_i%d", i
->ts
.kind
);
1985 gfc_resolve_min (gfc_expr
*f
, gfc_actual_arglist
*args
)
1987 gfc_resolve_minmax ("__min_%c%d", f
, args
);
1992 gfc_resolve_minloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1993 gfc_expr
*mask
, gfc_expr
*kind
, gfc_expr
*back
)
2000 f
->ts
.type
= BT_INTEGER
;
2002 /* The library versions only exist for kinds 4, 8 and 16. For smaller kinds,
2003 we do a type conversion further down. */
2005 fkind
= mpz_get_si (kind
->value
.integer
);
2007 fkind
= gfc_default_integer_kind
;
2009 if (fkind
< MINMAXLOC_MIN_KIND
)
2010 f
->ts
.kind
= MINMAXLOC_MIN_KIND
;
2017 f
->shape
= gfc_get_shape (1);
2018 mpz_init_set_si (f
->shape
[0], array
->rank
);
2022 f
->rank
= array
->rank
- 1;
2023 gfc_resolve_dim_arg (dim
);
2024 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
2026 idim
= (int) mpz_get_si (dim
->value
.integer
);
2027 f
->shape
= gfc_get_shape (f
->rank
);
2028 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
2030 if (i
== (idim
- 1))
2032 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
2039 if (mask
->rank
== 0)
2044 resolve_mask_arg (mask
);
2051 if (array
->ts
.type
!= BT_CHARACTER
|| f
->rank
!= 0)
2059 f
->value
.function
.name
2060 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name
, d_num
, f
->ts
.kind
,
2061 gfc_type_letter (array
->ts
.type
),
2062 gfc_type_abi_kind (&array
->ts
));
2064 if (fkind
!= f
->ts
.kind
)
2069 ts
.type
= BT_INTEGER
;
2071 gfc_convert_type_warn (f
, &ts
, 2, 0);
2074 if (back
->ts
.kind
!= gfc_logical_4_kind
)
2078 ts
.type
= BT_LOGICAL
;
2079 ts
.kind
= gfc_logical_4_kind
;
2080 gfc_convert_type_warn (back
, &ts
, 2, 0);
2086 gfc_resolve_minval (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
2096 f
->rank
= array
->rank
- 1;
2097 gfc_resolve_dim_arg (dim
);
2099 if (f
->rank
&& array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
2101 idim
= (int) mpz_get_si (dim
->value
.integer
);
2102 f
->shape
= gfc_get_shape (f
->rank
);
2103 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
2105 if (i
== (idim
- 1))
2107 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
2114 if (mask
->rank
== 0)
2119 resolve_mask_arg (mask
);
2124 if (array
->ts
.type
!= BT_CHARACTER
)
2125 f
->value
.function
.name
2126 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
2127 gfc_type_letter (array
->ts
.type
),
2128 gfc_type_abi_kind (&array
->ts
));
2130 f
->value
.function
.name
2131 = gfc_get_string (PREFIX ("%s%d_%c%d"), name
, f
->rank
!= 0,
2132 gfc_type_letter (array
->ts
.type
),
2133 gfc_type_abi_kind (&array
->ts
));
2138 gfc_resolve_mod (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
2140 f
->ts
.type
= a
->ts
.type
;
2142 f
->ts
.kind
= gfc_kind_max (a
,p
);
2144 f
->ts
.kind
= a
->ts
.kind
;
2146 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
2148 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
2149 gfc_convert_type (p
, &a
->ts
, 2);
2151 gfc_convert_type (a
, &p
->ts
, 2);
2154 f
->value
.function
.name
2155 = gfc_get_string ("__mod_%c%d", gfc_type_letter (f
->ts
.type
),
2156 gfc_type_abi_kind (&f
->ts
));
2161 gfc_resolve_modulo (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
2163 f
->ts
.type
= a
->ts
.type
;
2165 f
->ts
.kind
= gfc_kind_max (a
,p
);
2167 f
->ts
.kind
= a
->ts
.kind
;
2169 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
2171 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
2172 gfc_convert_type (p
, &a
->ts
, 2);
2174 gfc_convert_type (a
, &p
->ts
, 2);
2177 f
->value
.function
.name
2178 = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f
->ts
.type
),
2179 gfc_type_abi_kind (&f
->ts
));
2183 gfc_resolve_nearest (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
2185 if (p
->ts
.kind
!= a
->ts
.kind
)
2186 gfc_convert_type (p
, &a
->ts
, 2);
2189 f
->value
.function
.name
2190 = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a
->ts
.type
),
2191 gfc_type_abi_kind (&a
->ts
));
2195 gfc_resolve_nint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
2197 f
->ts
.type
= BT_INTEGER
;
2198 f
->ts
.kind
= (kind
== NULL
)
2199 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
2200 f
->value
.function
.name
2201 = gfc_get_string ("__nint_%d_%d", f
->ts
.kind
, a
->ts
.kind
);
2206 gfc_resolve_norm2 (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
)
2208 resolve_transformational ("norm2", f
, array
, dim
, NULL
);
2213 gfc_resolve_not (gfc_expr
*f
, gfc_expr
*i
)
2216 f
->value
.function
.name
= gfc_get_string ("__not_%d", i
->ts
.kind
);
2221 gfc_resolve_or (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
2223 f
->ts
.type
= i
->ts
.type
;
2224 f
->ts
.kind
= gfc_kind_max (i
, j
);
2226 if (i
->ts
.kind
!= j
->ts
.kind
)
2228 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
2229 gfc_convert_type (j
, &i
->ts
, 2);
2231 gfc_convert_type (i
, &j
->ts
, 2);
2234 f
->value
.function
.name
2235 = gfc_get_string ("__or_%c%d", gfc_type_letter (i
->ts
.type
),
2236 gfc_type_abi_kind (&f
->ts
));
2241 gfc_resolve_pack (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*mask
,
2242 gfc_expr
*vector ATTRIBUTE_UNUSED
)
2244 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
2245 gfc_resolve_substring_charlen (array
);
2250 resolve_mask_arg (mask
);
2252 if (mask
->rank
!= 0)
2254 if (array
->ts
.type
== BT_CHARACTER
)
2255 f
->value
.function
.name
2256 = array
->ts
.kind
== 1 ? PREFIX ("pack_char")
2258 (PREFIX ("pack_char%d"),
2261 f
->value
.function
.name
= PREFIX ("pack");
2265 if (array
->ts
.type
== BT_CHARACTER
)
2266 f
->value
.function
.name
2267 = array
->ts
.kind
== 1 ? PREFIX ("pack_s_char")
2269 (PREFIX ("pack_s_char%d"),
2272 f
->value
.function
.name
= PREFIX ("pack_s");
2278 gfc_resolve_parity (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
)
2280 resolve_transformational ("parity", f
, array
, dim
, NULL
);
2285 gfc_resolve_product (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
2288 resolve_transformational ("product", f
, array
, dim
, mask
);
2293 gfc_resolve_rank (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
)
2295 f
->ts
.type
= BT_INTEGER
;
2296 f
->ts
.kind
= gfc_default_integer_kind
;
2297 f
->value
.function
.name
= gfc_get_string ("__rank");
2302 gfc_resolve_real (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
2304 f
->ts
.type
= BT_REAL
;
2307 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2309 f
->ts
.kind
= (a
->ts
.type
== BT_COMPLEX
)
2310 ? a
->ts
.kind
: gfc_default_real_kind
;
2312 f
->value
.function
.name
2313 = gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
2314 gfc_type_letter (a
->ts
.type
),
2315 gfc_type_abi_kind (&a
->ts
));
2320 gfc_resolve_realpart (gfc_expr
*f
, gfc_expr
*a
)
2322 f
->ts
.type
= BT_REAL
;
2323 f
->ts
.kind
= a
->ts
.kind
;
2324 f
->value
.function
.name
2325 = gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
2326 gfc_type_letter (a
->ts
.type
),
2327 gfc_type_abi_kind (&a
->ts
));
2332 gfc_resolve_rename (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
2333 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
2335 f
->ts
.type
= BT_INTEGER
;
2336 f
->ts
.kind
= gfc_default_integer_kind
;
2337 f
->value
.function
.name
= gfc_get_string (PREFIX ("rename_i%d"), f
->ts
.kind
);
2342 gfc_resolve_repeat (gfc_expr
*f
, gfc_expr
*string
,
2346 f
->ts
.type
= BT_CHARACTER
;
2347 f
->ts
.kind
= string
->ts
.kind
;
2348 f
->value
.function
.name
= gfc_get_string ("__repeat_%d", string
->ts
.kind
);
2350 /* If possible, generate a character length. */
2351 if (f
->ts
.u
.cl
== NULL
)
2352 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2355 if (string
->expr_type
== EXPR_CONSTANT
)
2357 tmp
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
2358 string
->value
.character
.length
);
2360 else if (string
->ts
.u
.cl
&& string
->ts
.u
.cl
->length
)
2362 tmp
= gfc_copy_expr (string
->ts
.u
.cl
->length
);
2366 f
->ts
.u
.cl
->length
= gfc_multiply (tmp
, gfc_copy_expr (ncopies
));
2371 gfc_resolve_reshape (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*shape
,
2372 gfc_expr
*pad ATTRIBUTE_UNUSED
,
2373 gfc_expr
*order ATTRIBUTE_UNUSED
)
2379 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
2380 gfc_resolve_substring_charlen (source
);
2384 gfc_array_size (shape
, &rank
);
2385 f
->rank
= mpz_get_si (rank
);
2387 switch (source
->ts
.type
)
2394 kind
= source
->ts
.kind
;
2408 if (source
->ts
.type
== BT_COMPLEX
|| source
->ts
.type
== BT_REAL
)
2409 f
->value
.function
.name
2410 = gfc_get_string (PREFIX ("reshape_%c%d"),
2411 gfc_type_letter (source
->ts
.type
),
2412 gfc_type_abi_kind (&source
->ts
));
2413 else if (source
->ts
.type
== BT_CHARACTER
)
2414 f
->value
.function
.name
= gfc_get_string (PREFIX ("reshape_char%d"),
2417 f
->value
.function
.name
2418 = gfc_get_string (PREFIX ("reshape_%d"), source
->ts
.kind
);
2422 f
->value
.function
.name
= (source
->ts
.type
== BT_CHARACTER
2423 ? PREFIX ("reshape_char") : PREFIX ("reshape"));
2427 if (shape
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_array_expr (shape
))
2430 f
->shape
= gfc_get_shape (f
->rank
);
2431 c
= gfc_constructor_first (shape
->value
.constructor
);
2432 for (i
= 0; i
< f
->rank
; i
++)
2434 mpz_init_set (f
->shape
[i
], c
->expr
->value
.integer
);
2435 c
= gfc_constructor_next (c
);
2439 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
2440 so many runtime variations. */
2441 if (shape
->ts
.kind
!= gfc_index_integer_kind
)
2443 gfc_typespec ts
= shape
->ts
;
2444 ts
.kind
= gfc_index_integer_kind
;
2445 gfc_convert_type_warn (shape
, &ts
, 2, 0);
2447 if (order
&& order
->ts
.kind
!= gfc_index_integer_kind
)
2448 gfc_convert_type_warn (order
, &shape
->ts
, 2, 0);
2453 gfc_resolve_rrspacing (gfc_expr
*f
, gfc_expr
*x
)
2456 f
->value
.function
.name
= gfc_get_string ("__rrspacing_%d", x
->ts
.kind
);
2460 gfc_resolve_fe_runtime_error (gfc_code
*c
)
2463 gfc_actual_arglist
*a
;
2465 name
= gfc_get_string (PREFIX ("runtime_error"));
2467 for (a
= c
->ext
.actual
->next
; a
; a
= a
->next
)
2470 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2471 /* We set the backend_decl here because runtime_error is a
2472 variadic function and we would use the wrong calling
2473 convention otherwise. */
2474 c
->resolved_sym
->backend_decl
= gfor_fndecl_runtime_error
;
2478 gfc_resolve_scale (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*i ATTRIBUTE_UNUSED
)
2481 f
->value
.function
.name
= gfc_get_string ("__scale_%d", x
->ts
.kind
);
2486 gfc_resolve_scan (gfc_expr
*f
, gfc_expr
*string
,
2487 gfc_expr
*set ATTRIBUTE_UNUSED
,
2488 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2490 f
->ts
.type
= BT_INTEGER
;
2492 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2494 f
->ts
.kind
= gfc_default_integer_kind
;
2495 f
->value
.function
.name
= gfc_get_string ("__scan_%d", string
->ts
.kind
);
2500 gfc_resolve_secnds (gfc_expr
*t1
, gfc_expr
*t0
)
2503 t1
->value
.function
.name
= gfc_get_string (PREFIX ("secnds"));
2508 gfc_resolve_set_exponent (gfc_expr
*f
, gfc_expr
*x
,
2509 gfc_expr
*i ATTRIBUTE_UNUSED
)
2512 f
->value
.function
.name
= gfc_get_string ("__set_exponent_%d", x
->ts
.kind
);
2517 gfc_resolve_shape (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*kind
)
2519 f
->ts
.type
= BT_INTEGER
;
2522 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2524 f
->ts
.kind
= gfc_default_integer_kind
;
2527 if (array
->rank
!= -1)
2529 f
->shape
= gfc_get_shape (1);
2530 mpz_init_set_ui (f
->shape
[0], array
->rank
);
2533 f
->value
.function
.name
= gfc_get_string (PREFIX ("shape_%d"), f
->ts
.kind
);
2538 gfc_resolve_shift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift ATTRIBUTE_UNUSED
)
2541 if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTA
)
2542 f
->value
.function
.name
= gfc_get_string ("shifta_i%d", f
->ts
.kind
);
2543 else if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTL
)
2544 f
->value
.function
.name
= gfc_get_string ("shiftl_i%d", f
->ts
.kind
);
2545 else if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTR
)
2546 f
->value
.function
.name
= gfc_get_string ("shiftr_i%d", f
->ts
.kind
);
2553 gfc_resolve_sign (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b ATTRIBUTE_UNUSED
)
2556 f
->value
.function
.name
2557 = gfc_get_string ("__sign_%c%d", gfc_type_letter (a
->ts
.type
),
2558 gfc_type_abi_kind (&a
->ts
));
2563 gfc_resolve_signal (gfc_expr
*f
, gfc_expr
*number
, gfc_expr
*handler
)
2565 f
->ts
.type
= BT_INTEGER
;
2566 f
->ts
.kind
= gfc_c_int_kind
;
2568 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2569 if (handler
->ts
.type
== BT_INTEGER
)
2571 if (handler
->ts
.kind
!= gfc_c_int_kind
)
2572 gfc_convert_type (handler
, &f
->ts
, 2);
2573 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func_int"));
2576 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func"));
2578 if (number
->ts
.kind
!= gfc_c_int_kind
)
2579 gfc_convert_type (number
, &f
->ts
, 2);
2584 gfc_resolve_sin (gfc_expr
*f
, gfc_expr
*x
)
2587 f
->value
.function
.name
2588 = gfc_get_string ("__sin_%c%d", gfc_type_letter (x
->ts
.type
),
2589 gfc_type_abi_kind (&x
->ts
));
2594 gfc_resolve_sinh (gfc_expr
*f
, gfc_expr
*x
)
2597 f
->value
.function
.name
2598 = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x
->ts
.type
),
2599 gfc_type_abi_kind (&x
->ts
));
2604 gfc_resolve_size (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2605 gfc_expr
*dim ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2607 f
->ts
.type
= BT_INTEGER
;
2609 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2611 f
->ts
.kind
= gfc_default_integer_kind
;
2616 gfc_resolve_stride (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2617 gfc_expr
*dim ATTRIBUTE_UNUSED
)
2619 f
->ts
.type
= BT_INTEGER
;
2620 f
->ts
.kind
= gfc_index_integer_kind
;
2625 gfc_resolve_spacing (gfc_expr
*f
, gfc_expr
*x
)
2628 f
->value
.function
.name
= gfc_get_string ("__spacing_%d", x
->ts
.kind
);
2633 gfc_resolve_spread (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*dim
,
2636 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
2637 gfc_resolve_substring_charlen (source
);
2639 if (source
->ts
.type
== BT_CHARACTER
)
2640 check_charlen_present (source
);
2643 f
->rank
= source
->rank
+ 1;
2644 if (source
->rank
== 0)
2646 if (source
->ts
.type
== BT_CHARACTER
)
2647 f
->value
.function
.name
2648 = source
->ts
.kind
== 1 ? PREFIX ("spread_char_scalar")
2650 (PREFIX ("spread_char%d_scalar"),
2653 f
->value
.function
.name
= PREFIX ("spread_scalar");
2657 if (source
->ts
.type
== BT_CHARACTER
)
2658 f
->value
.function
.name
2659 = source
->ts
.kind
== 1 ? PREFIX ("spread_char")
2661 (PREFIX ("spread_char%d"),
2664 f
->value
.function
.name
= PREFIX ("spread");
2667 if (dim
&& gfc_is_constant_expr (dim
)
2668 && ncopies
&& gfc_is_constant_expr (ncopies
) && source
->shape
[0])
2671 idim
= mpz_get_ui (dim
->value
.integer
);
2672 f
->shape
= gfc_get_shape (f
->rank
);
2673 for (i
= 0; i
< (idim
- 1); i
++)
2674 mpz_init_set (f
->shape
[i
], source
->shape
[i
]);
2676 mpz_init_set (f
->shape
[idim
- 1], ncopies
->value
.integer
);
2678 for (i
= idim
; i
< f
->rank
; i
++)
2679 mpz_init_set (f
->shape
[i
], source
->shape
[i
-1]);
2683 gfc_resolve_dim_arg (dim
);
2684 gfc_resolve_index (ncopies
, 1);
2689 gfc_resolve_sqrt (gfc_expr
*f
, gfc_expr
*x
)
2692 f
->value
.function
.name
2693 = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x
->ts
.type
),
2694 gfc_type_abi_kind (&x
->ts
));
2698 /* Resolve the g77 compatibility function STAT AND FSTAT. */
2701 gfc_resolve_stat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2702 gfc_expr
*a ATTRIBUTE_UNUSED
)
2704 f
->ts
.type
= BT_INTEGER
;
2705 f
->ts
.kind
= gfc_default_integer_kind
;
2706 f
->value
.function
.name
= gfc_get_string (PREFIX ("stat_i%d"), f
->ts
.kind
);
2711 gfc_resolve_lstat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2712 gfc_expr
*a ATTRIBUTE_UNUSED
)
2714 f
->ts
.type
= BT_INTEGER
;
2715 f
->ts
.kind
= gfc_default_integer_kind
;
2716 f
->value
.function
.name
= gfc_get_string (PREFIX ("lstat_i%d"), f
->ts
.kind
);
2721 gfc_resolve_fstat (gfc_expr
*f
, gfc_expr
*n
, gfc_expr
*a ATTRIBUTE_UNUSED
)
2723 f
->ts
.type
= BT_INTEGER
;
2724 f
->ts
.kind
= gfc_default_integer_kind
;
2725 if (n
->ts
.kind
!= f
->ts
.kind
)
2726 gfc_convert_type (n
, &f
->ts
, 2);
2728 f
->value
.function
.name
= gfc_get_string (PREFIX ("fstat_i%d"), f
->ts
.kind
);
2733 gfc_resolve_fgetc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2738 f
->ts
.type
= BT_INTEGER
;
2739 f
->ts
.kind
= gfc_c_int_kind
;
2740 if (u
->ts
.kind
!= gfc_c_int_kind
)
2742 ts
.type
= BT_INTEGER
;
2743 ts
.kind
= gfc_c_int_kind
;
2744 ts
.u
.derived
= NULL
;
2746 gfc_convert_type (u
, &ts
, 2);
2749 f
->value
.function
.name
= gfc_get_string (PREFIX ("fgetc"));
2754 gfc_resolve_fget (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2756 f
->ts
.type
= BT_INTEGER
;
2757 f
->ts
.kind
= gfc_c_int_kind
;
2758 f
->value
.function
.name
= gfc_get_string (PREFIX ("fget"));
2763 gfc_resolve_fputc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2768 f
->ts
.type
= BT_INTEGER
;
2769 f
->ts
.kind
= gfc_c_int_kind
;
2770 if (u
->ts
.kind
!= gfc_c_int_kind
)
2772 ts
.type
= BT_INTEGER
;
2773 ts
.kind
= gfc_c_int_kind
;
2774 ts
.u
.derived
= NULL
;
2776 gfc_convert_type (u
, &ts
, 2);
2779 f
->value
.function
.name
= gfc_get_string (PREFIX ("fputc"));
2784 gfc_resolve_fput (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2786 f
->ts
.type
= BT_INTEGER
;
2787 f
->ts
.kind
= gfc_c_int_kind
;
2788 f
->value
.function
.name
= gfc_get_string (PREFIX ("fput"));
2793 gfc_resolve_ftell (gfc_expr
*f
, gfc_expr
*u
)
2798 f
->ts
.type
= BT_INTEGER
;
2799 f
->ts
.kind
= gfc_intio_kind
;
2800 if (u
->ts
.kind
!= gfc_c_int_kind
)
2802 ts
.type
= BT_INTEGER
;
2803 ts
.kind
= gfc_c_int_kind
;
2804 ts
.u
.derived
= NULL
;
2806 gfc_convert_type (u
, &ts
, 2);
2809 f
->value
.function
.name
= gfc_get_string (PREFIX ("ftell"));
2814 gfc_resolve_storage_size (gfc_expr
*f
, gfc_expr
*a ATTRIBUTE_UNUSED
,
2817 f
->ts
.type
= BT_INTEGER
;
2819 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2821 f
->ts
.kind
= gfc_default_integer_kind
;
2826 gfc_resolve_sum (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2828 resolve_transformational ("sum", f
, array
, dim
, mask
);
2833 gfc_resolve_symlnk (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
2834 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
2836 f
->ts
.type
= BT_INTEGER
;
2837 f
->ts
.kind
= gfc_default_integer_kind
;
2838 f
->value
.function
.name
= gfc_get_string (PREFIX ("symlnk_i%d"), f
->ts
.kind
);
2842 /* Resolve the g77 compatibility function SYSTEM. */
2845 gfc_resolve_system (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
2847 f
->ts
.type
= BT_INTEGER
;
2849 f
->value
.function
.name
= gfc_get_string (PREFIX ("system"));
2854 gfc_resolve_tan (gfc_expr
*f
, gfc_expr
*x
)
2857 f
->value
.function
.name
2858 = gfc_get_string ("__tan_%c%d", gfc_type_letter (x
->ts
.type
),
2859 gfc_type_abi_kind (&x
->ts
));
2864 gfc_resolve_tanh (gfc_expr
*f
, gfc_expr
*x
)
2867 f
->value
.function
.name
2868 = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x
->ts
.type
),
2869 gfc_type_abi_kind (&x
->ts
));
2873 /* Resolve failed_images (team, kind). */
2876 gfc_resolve_failed_images (gfc_expr
*f
, gfc_expr
*team ATTRIBUTE_UNUSED
,
2879 static char failed_images
[] = "_gfortran_caf_failed_images";
2881 f
->ts
.type
= BT_INTEGER
;
2883 f
->ts
.kind
= gfc_default_integer_kind
;
2885 gfc_extract_int (kind
, &f
->ts
.kind
);
2886 f
->value
.function
.name
= failed_images
;
2890 /* Resolve image_status (image, team). */
2893 gfc_resolve_image_status (gfc_expr
*f
, gfc_expr
*image ATTRIBUTE_UNUSED
,
2894 gfc_expr
*team ATTRIBUTE_UNUSED
)
2896 static char image_status
[] = "_gfortran_caf_image_status";
2897 f
->ts
.type
= BT_INTEGER
;
2898 f
->ts
.kind
= gfc_default_integer_kind
;
2899 f
->value
.function
.name
= image_status
;
2903 /* Resolve get_team (). */
2906 gfc_resolve_get_team (gfc_expr
*f
, gfc_expr
*level ATTRIBUTE_UNUSED
)
2908 static char get_team
[] = "_gfortran_caf_get_team";
2910 f
->ts
.type
= BT_INTEGER
;
2911 f
->ts
.kind
= gfc_default_integer_kind
;
2912 f
->value
.function
.name
= get_team
;
2916 /* Resolve image_index (...). */
2919 gfc_resolve_image_index (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2920 gfc_expr
*sub ATTRIBUTE_UNUSED
)
2922 static char image_index
[] = "__image_index";
2923 f
->ts
.type
= BT_INTEGER
;
2924 f
->ts
.kind
= gfc_default_integer_kind
;
2925 f
->value
.function
.name
= image_index
;
2929 /* Resolve stopped_images (team, kind). */
2932 gfc_resolve_stopped_images (gfc_expr
*f
, gfc_expr
*team ATTRIBUTE_UNUSED
,
2935 static char stopped_images
[] = "_gfortran_caf_stopped_images";
2937 f
->ts
.type
= BT_INTEGER
;
2939 f
->ts
.kind
= gfc_default_integer_kind
;
2941 gfc_extract_int (kind
, &f
->ts
.kind
);
2942 f
->value
.function
.name
= stopped_images
;
2946 /* Resolve team_number (team). */
2949 gfc_resolve_team_number (gfc_expr
*f
, gfc_expr
*team ATTRIBUTE_UNUSED
)
2951 static char team_number
[] = "_gfortran_caf_team_number";
2953 f
->ts
.type
= BT_INTEGER
;
2954 f
->ts
.kind
= gfc_default_integer_kind
;
2955 f
->value
.function
.name
= team_number
;
2960 gfc_resolve_this_image (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
2961 gfc_expr
*distance ATTRIBUTE_UNUSED
)
2963 static char this_image
[] = "__this_image";
2964 if (array
&& gfc_is_coarray (array
))
2965 resolve_bound (f
, array
, dim
, NULL
, "__this_image", true);
2968 f
->ts
.type
= BT_INTEGER
;
2969 f
->ts
.kind
= gfc_default_integer_kind
;
2970 f
->value
.function
.name
= this_image
;
2976 gfc_resolve_time (gfc_expr
*f
)
2978 f
->ts
.type
= BT_INTEGER
;
2980 f
->value
.function
.name
= gfc_get_string (PREFIX ("time_func"));
2985 gfc_resolve_time8 (gfc_expr
*f
)
2987 f
->ts
.type
= BT_INTEGER
;
2989 f
->value
.function
.name
= gfc_get_string (PREFIX ("time8_func"));
2994 gfc_resolve_transfer (gfc_expr
*f
, gfc_expr
*source ATTRIBUTE_UNUSED
,
2995 gfc_expr
*mold
, gfc_expr
*size
)
2997 /* TODO: Make this do something meaningful. */
2998 static char transfer0
[] = "__transfer0", transfer1
[] = "__transfer1";
3000 if (mold
->ts
.type
== BT_CHARACTER
3001 && !mold
->ts
.u
.cl
->length
3002 && gfc_is_constant_expr (mold
))
3005 if (mold
->expr_type
== EXPR_CONSTANT
)
3007 len
= mold
->value
.character
.length
;
3008 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
3013 gfc_constructor
*c
= gfc_constructor_first (mold
->value
.constructor
);
3014 len
= c
->expr
->value
.character
.length
;
3015 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
3022 if (size
== NULL
&& mold
->rank
== 0)
3025 f
->value
.function
.name
= transfer0
;
3030 f
->value
.function
.name
= transfer1
;
3031 if (size
&& gfc_is_constant_expr (size
))
3033 f
->shape
= gfc_get_shape (1);
3034 mpz_init_set (f
->shape
[0], size
->value
.integer
);
3041 gfc_resolve_transpose (gfc_expr
*f
, gfc_expr
*matrix
)
3044 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ref
)
3045 gfc_resolve_substring_charlen (matrix
);
3051 f
->shape
= gfc_get_shape (2);
3052 mpz_init_set (f
->shape
[0], matrix
->shape
[1]);
3053 mpz_init_set (f
->shape
[1], matrix
->shape
[0]);
3056 switch (matrix
->ts
.kind
)
3062 switch (matrix
->ts
.type
)
3066 f
->value
.function
.name
3067 = gfc_get_string (PREFIX ("transpose_%c%d"),
3068 gfc_type_letter (matrix
->ts
.type
),
3069 gfc_type_abi_kind (&matrix
->ts
));
3074 /* Use the integer routines for real and logical cases. This
3075 assumes they all have the same alignment requirements. */
3076 f
->value
.function
.name
3077 = gfc_get_string (PREFIX ("transpose_i%d"), matrix
->ts
.kind
);
3081 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ts
.kind
== 4)
3082 f
->value
.function
.name
= PREFIX ("transpose_char4");
3084 f
->value
.function
.name
= PREFIX ("transpose");
3090 f
->value
.function
.name
= (matrix
->ts
.type
== BT_CHARACTER
3091 ? PREFIX ("transpose_char")
3092 : PREFIX ("transpose"));
3099 gfc_resolve_trim (gfc_expr
*f
, gfc_expr
*string
)
3101 f
->ts
.type
= BT_CHARACTER
;
3102 f
->ts
.kind
= string
->ts
.kind
;
3103 f
->value
.function
.name
= gfc_get_string ("__trim_%d", string
->ts
.kind
);
3107 /* Resolve the degree trigonometric functions. This amounts to setting
3108 the function return type-spec from its argument and building a
3109 library function names of the form _gfortran_sind_r4. */
3112 gfc_resolve_trigd (gfc_expr
*f
, gfc_expr
*x
)
3115 f
->value
.function
.name
3116 = gfc_get_string (PREFIX ("%s_%c%d"), f
->value
.function
.isym
->name
,
3117 gfc_type_letter (x
->ts
.type
),
3118 gfc_type_abi_kind (&x
->ts
));
3123 gfc_resolve_trigd2 (gfc_expr
*f
, gfc_expr
*y
, gfc_expr
*x
)
3126 f
->value
.function
.name
3127 = gfc_get_string (PREFIX ("%s_%d"), f
->value
.function
.isym
->name
,
3133 gfc_resolve_ubound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3135 resolve_bound (f
, array
, dim
, kind
, "__ubound", false);
3140 gfc_resolve_ucobound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3142 resolve_bound (f
, array
, dim
, kind
, "__ucobound", true);
3146 /* Resolve the g77 compatibility function UMASK. */
3149 gfc_resolve_umask (gfc_expr
*f
, gfc_expr
*n
)
3151 f
->ts
.type
= BT_INTEGER
;
3152 f
->ts
.kind
= n
->ts
.kind
;
3153 f
->value
.function
.name
= gfc_get_string (PREFIX ("umask_i%d"), n
->ts
.kind
);
3157 /* Resolve the g77 compatibility function UNLINK. */
3160 gfc_resolve_unlink (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
3162 f
->ts
.type
= BT_INTEGER
;
3164 f
->value
.function
.name
= gfc_get_string (PREFIX ("unlink"));
3169 gfc_resolve_ttynam (gfc_expr
*f
, gfc_expr
*unit
)
3174 f
->ts
.type
= BT_CHARACTER
;
3175 f
->ts
.kind
= gfc_default_character_kind
;
3177 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3179 ts
.type
= BT_INTEGER
;
3180 ts
.kind
= gfc_c_int_kind
;
3181 ts
.u
.derived
= NULL
;
3183 gfc_convert_type (unit
, &ts
, 2);
3186 f
->value
.function
.name
= gfc_get_string (PREFIX ("ttynam"));
3191 gfc_resolve_unpack (gfc_expr
*f
, gfc_expr
*vector
, gfc_expr
*mask
,
3192 gfc_expr
*field ATTRIBUTE_UNUSED
)
3194 if (vector
->ts
.type
== BT_CHARACTER
&& vector
->ref
)
3195 gfc_resolve_substring_charlen (vector
);
3198 f
->rank
= mask
->rank
;
3199 resolve_mask_arg (mask
);
3201 if (vector
->ts
.type
== BT_CHARACTER
)
3203 if (vector
->ts
.kind
== 1)
3204 f
->value
.function
.name
3205 = gfc_get_string (PREFIX ("unpack%d_char"), field
->rank
> 0 ? 1 : 0);
3207 f
->value
.function
.name
3208 = gfc_get_string (PREFIX ("unpack%d_char%d"),
3209 field
->rank
> 0 ? 1 : 0, vector
->ts
.kind
);
3212 f
->value
.function
.name
3213 = gfc_get_string (PREFIX ("unpack%d"), field
->rank
> 0 ? 1 : 0);
3218 gfc_resolve_verify (gfc_expr
*f
, gfc_expr
*string
,
3219 gfc_expr
*set ATTRIBUTE_UNUSED
,
3220 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
3222 f
->ts
.type
= BT_INTEGER
;
3224 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
3226 f
->ts
.kind
= gfc_default_integer_kind
;
3227 f
->value
.function
.name
= gfc_get_string ("__verify_%d", string
->ts
.kind
);
3232 gfc_resolve_xor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
3234 f
->ts
.type
= i
->ts
.type
;
3235 f
->ts
.kind
= gfc_kind_max (i
, j
);
3237 if (i
->ts
.kind
!= j
->ts
.kind
)
3239 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
3240 gfc_convert_type (j
, &i
->ts
, 2);
3242 gfc_convert_type (i
, &j
->ts
, 2);
3245 f
->value
.function
.name
3246 = gfc_get_string ("__xor_%c%d", gfc_type_letter (i
->ts
.type
),
3247 gfc_type_abi_kind (&f
->ts
));
3251 /* Intrinsic subroutine resolution. */
3254 gfc_resolve_alarm_sub (gfc_code
*c
)
3257 gfc_expr
*seconds
, *handler
;
3261 seconds
= c
->ext
.actual
->expr
;
3262 handler
= c
->ext
.actual
->next
->expr
;
3263 ts
.type
= BT_INTEGER
;
3264 ts
.kind
= gfc_c_int_kind
;
3266 /* handler can be either BT_INTEGER or BT_PROCEDURE.
3267 In all cases, the status argument is of default integer kind
3268 (enforced in check.cc) so that the function suffix is fixed. */
3269 if (handler
->ts
.type
== BT_INTEGER
)
3271 if (handler
->ts
.kind
!= gfc_c_int_kind
)
3272 gfc_convert_type (handler
, &ts
, 2);
3273 name
= gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
3274 gfc_default_integer_kind
);
3277 name
= gfc_get_string (PREFIX ("alarm_sub_i%d"),
3278 gfc_default_integer_kind
);
3280 if (seconds
->ts
.kind
!= gfc_c_int_kind
)
3281 gfc_convert_type (seconds
, &ts
, 2);
3283 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3287 gfc_resolve_cpu_time (gfc_code
*c
)
3290 name
= gfc_get_string (PREFIX ("cpu_time_%d"), c
->ext
.actual
->expr
->ts
.kind
);
3291 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3295 /* Create a formal arglist based on an actual one and set the INTENTs given. */
3297 static gfc_formal_arglist
*
3298 create_formal_for_intents (gfc_actual_arglist
* actual
, const sym_intent
* ints
)
3300 gfc_formal_arglist
* head
;
3301 gfc_formal_arglist
* tail
;
3307 head
= tail
= gfc_get_formal_arglist ();
3308 for (i
= 0; actual
; actual
= actual
->next
, tail
= tail
->next
, ++i
)
3312 sym
= gfc_new_symbol ("dummyarg", NULL
);
3313 sym
->ts
= actual
->expr
->ts
;
3315 sym
->attr
.intent
= ints
[i
];
3319 tail
->next
= gfc_get_formal_arglist ();
3327 gfc_resolve_atomic_def (gfc_code
*c
)
3329 const char *name
= "atomic_define";
3330 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3335 gfc_resolve_atomic_ref (gfc_code
*c
)
3337 const char *name
= "atomic_ref";
3338 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3342 gfc_resolve_event_query (gfc_code
*c
)
3344 const char *name
= "event_query";
3345 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3349 gfc_resolve_mvbits (gfc_code
*c
)
3351 static const sym_intent INTENTS
[] = {INTENT_IN
, INTENT_IN
, INTENT_IN
,
3352 INTENT_INOUT
, INTENT_IN
};
3355 /* TO and FROM are guaranteed to have the same kind parameter. */
3356 name
= gfc_get_string (PREFIX ("mvbits_i%d"),
3357 c
->ext
.actual
->expr
->ts
.kind
);
3358 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3359 /* Mark as elemental subroutine as this does not happen automatically. */
3360 c
->resolved_sym
->attr
.elemental
= 1;
3362 /* Create a dummy formal arglist so the INTENTs are known later for purpose
3363 of creating temporaries. */
3364 c
->resolved_sym
->formal
= create_formal_for_intents (c
->ext
.actual
, INTENTS
);
3368 /* Set up the call to RANDOM_INIT. */
3371 gfc_resolve_random_init (gfc_code
*c
)
3374 name
= gfc_get_string (PREFIX ("random_init"));
3375 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3380 gfc_resolve_random_number (gfc_code
*c
)
3385 kind
= gfc_type_abi_kind (&c
->ext
.actual
->expr
->ts
);
3386 if (c
->ext
.actual
->expr
->rank
== 0)
3387 name
= gfc_get_string (PREFIX ("random_r%d"), kind
);
3389 name
= gfc_get_string (PREFIX ("arandom_r%d"), kind
);
3391 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3396 gfc_resolve_random_seed (gfc_code
*c
)
3400 name
= gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind
);
3401 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3406 gfc_resolve_rename_sub (gfc_code
*c
)
3411 /* Find the type of status. If not present use default integer kind. */
3412 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3413 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3415 kind
= gfc_default_integer_kind
;
3417 name
= gfc_get_string (PREFIX ("rename_i%d_sub"), kind
);
3418 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3423 gfc_resolve_link_sub (gfc_code
*c
)
3428 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3429 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3431 kind
= gfc_default_integer_kind
;
3433 name
= gfc_get_string (PREFIX ("link_i%d_sub"), kind
);
3434 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3439 gfc_resolve_symlnk_sub (gfc_code
*c
)
3444 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3445 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3447 kind
= gfc_default_integer_kind
;
3449 name
= gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind
);
3450 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3454 /* G77 compatibility subroutines dtime() and etime(). */
3457 gfc_resolve_dtime_sub (gfc_code
*c
)
3460 name
= gfc_get_string (PREFIX ("dtime_sub"));
3461 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3465 gfc_resolve_etime_sub (gfc_code
*c
)
3468 name
= gfc_get_string (PREFIX ("etime_sub"));
3469 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3473 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
3476 gfc_resolve_itime (gfc_code
*c
)
3479 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
3480 gfc_default_integer_kind
));
3484 gfc_resolve_idate (gfc_code
*c
)
3487 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
3488 gfc_default_integer_kind
));
3492 gfc_resolve_ltime (gfc_code
*c
)
3495 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
3496 gfc_default_integer_kind
));
3500 gfc_resolve_gmtime (gfc_code
*c
)
3503 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
3504 gfc_default_integer_kind
));
3508 /* G77 compatibility subroutine second(). */
3511 gfc_resolve_second_sub (gfc_code
*c
)
3514 name
= gfc_get_string (PREFIX ("second_sub"));
3515 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3520 gfc_resolve_sleep_sub (gfc_code
*c
)
3525 if (c
->ext
.actual
->expr
!= NULL
)
3526 kind
= c
->ext
.actual
->expr
->ts
.kind
;
3528 kind
= gfc_default_integer_kind
;
3530 name
= gfc_get_string (PREFIX ("sleep_i%d_sub"), kind
);
3531 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3535 /* G77 compatibility function srand(). */
3538 gfc_resolve_srand (gfc_code
*c
)
3541 name
= gfc_get_string (PREFIX ("srand"));
3542 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3546 /* Resolve the getarg intrinsic subroutine. */
3549 gfc_resolve_getarg (gfc_code
*c
)
3553 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_default_integer_kind
)
3558 ts
.type
= BT_INTEGER
;
3559 ts
.kind
= gfc_default_integer_kind
;
3561 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3564 name
= gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind
);
3565 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3569 /* Resolve the getcwd intrinsic subroutine. */
3572 gfc_resolve_getcwd_sub (gfc_code
*c
)
3577 if (c
->ext
.actual
->next
->expr
!= NULL
)
3578 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3580 kind
= gfc_default_integer_kind
;
3582 name
= gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind
);
3583 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3587 /* Resolve the get_command intrinsic subroutine. */
3590 gfc_resolve_get_command (gfc_code
*c
)
3594 kind
= gfc_default_integer_kind
;
3595 name
= gfc_get_string (PREFIX ("get_command_i%d"), kind
);
3596 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3600 /* Resolve the get_command_argument intrinsic subroutine. */
3603 gfc_resolve_get_command_argument (gfc_code
*c
)
3607 kind
= gfc_default_integer_kind
;
3608 name
= gfc_get_string (PREFIX ("get_command_argument_i%d"), kind
);
3609 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3613 /* Resolve the get_environment_variable intrinsic subroutine. */
3616 gfc_resolve_get_environment_variable (gfc_code
*code
)
3620 kind
= gfc_default_integer_kind
;
3621 name
= gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind
);
3622 code
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3627 gfc_resolve_signal_sub (gfc_code
*c
)
3630 gfc_expr
*number
, *handler
, *status
;
3634 number
= c
->ext
.actual
->expr
;
3635 handler
= c
->ext
.actual
->next
->expr
;
3636 status
= c
->ext
.actual
->next
->next
->expr
;
3637 ts
.type
= BT_INTEGER
;
3638 ts
.kind
= gfc_c_int_kind
;
3640 /* handler can be either BT_INTEGER or BT_PROCEDURE */
3641 if (handler
->ts
.type
== BT_INTEGER
)
3643 if (handler
->ts
.kind
!= gfc_c_int_kind
)
3644 gfc_convert_type (handler
, &ts
, 2);
3645 name
= gfc_get_string (PREFIX ("signal_sub_int"));
3648 name
= gfc_get_string (PREFIX ("signal_sub"));
3650 if (number
->ts
.kind
!= gfc_c_int_kind
)
3651 gfc_convert_type (number
, &ts
, 2);
3652 if (status
!= NULL
&& status
->ts
.kind
!= gfc_c_int_kind
)
3653 gfc_convert_type (status
, &ts
, 2);
3655 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3659 /* Resolve the SYSTEM intrinsic subroutine. */
3662 gfc_resolve_system_sub (gfc_code
*c
)
3665 name
= gfc_get_string (PREFIX ("system_sub"));
3666 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3670 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
3673 gfc_resolve_system_clock (gfc_code
*c
)
3677 gfc_expr
*count
= c
->ext
.actual
->expr
;
3678 gfc_expr
*count_max
= c
->ext
.actual
->next
->next
->expr
;
3680 /* The INTEGER(8) version has higher precision, it is used if both COUNT
3681 and COUNT_MAX can hold 64-bit values, or are absent. */
3682 if ((!count
|| count
->ts
.kind
>= 8)
3683 && (!count_max
|| count_max
->ts
.kind
>= 8))
3686 kind
= gfc_default_integer_kind
;
3688 name
= gfc_get_string (PREFIX ("system_clock_%d"), kind
);
3689 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3693 /* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine. */
3695 gfc_resolve_execute_command_line (gfc_code
*c
)
3698 name
= gfc_get_string (PREFIX ("execute_command_line_i%d"),
3699 gfc_default_integer_kind
);
3700 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3704 /* Resolve the EXIT intrinsic subroutine. */
3707 gfc_resolve_exit (gfc_code
*c
)
3714 /* The STATUS argument has to be of default kind. If it is not,
3716 ts
.type
= BT_INTEGER
;
3717 ts
.kind
= gfc_default_integer_kind
;
3718 n
= c
->ext
.actual
->expr
;
3719 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3720 gfc_convert_type (n
, &ts
, 2);
3722 name
= gfc_get_string (PREFIX ("exit_i%d"), ts
.kind
);
3723 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3727 /* Resolve the FLUSH intrinsic subroutine. */
3730 gfc_resolve_flush (gfc_code
*c
)
3737 ts
.type
= BT_INTEGER
;
3738 ts
.kind
= gfc_default_integer_kind
;
3739 n
= c
->ext
.actual
->expr
;
3740 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3741 gfc_convert_type (n
, &ts
, 2);
3743 name
= gfc_get_string (PREFIX ("flush_i%d"), ts
.kind
);
3744 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3749 gfc_resolve_ctime_sub (gfc_code
*c
)
3754 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3755 if (c
->ext
.actual
->expr
->ts
.kind
!= 8)
3757 ts
.type
= BT_INTEGER
;
3759 ts
.u
.derived
= NULL
;
3761 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3764 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3769 gfc_resolve_fdate_sub (gfc_code
*c
)
3771 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3776 gfc_resolve_gerror (gfc_code
*c
)
3778 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3783 gfc_resolve_getlog (gfc_code
*c
)
3785 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3790 gfc_resolve_hostnm_sub (gfc_code
*c
)
3795 if (c
->ext
.actual
->next
->expr
!= NULL
)
3796 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3798 kind
= gfc_default_integer_kind
;
3800 name
= gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind
);
3801 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3806 gfc_resolve_perror (gfc_code
*c
)
3808 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3811 /* Resolve the STAT and FSTAT intrinsic subroutines. */
3814 gfc_resolve_stat_sub (gfc_code
*c
)
3817 name
= gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind
);
3818 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3823 gfc_resolve_lstat_sub (gfc_code
*c
)
3826 name
= gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind
);
3827 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3832 gfc_resolve_fstat_sub (gfc_code
*c
)
3838 u
= c
->ext
.actual
->expr
;
3839 ts
= &c
->ext
.actual
->next
->expr
->ts
;
3840 if (u
->ts
.kind
!= ts
->kind
)
3841 gfc_convert_type (u
, ts
, 2);
3842 name
= gfc_get_string (PREFIX ("fstat_i%d_sub"), ts
->kind
);
3843 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3848 gfc_resolve_fgetc_sub (gfc_code
*c
)
3855 u
= c
->ext
.actual
->expr
;
3856 st
= c
->ext
.actual
->next
->next
->expr
;
3858 if (u
->ts
.kind
!= gfc_c_int_kind
)
3860 ts
.type
= BT_INTEGER
;
3861 ts
.kind
= gfc_c_int_kind
;
3862 ts
.u
.derived
= NULL
;
3864 gfc_convert_type (u
, &ts
, 2);
3868 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), st
->ts
.kind
);
3870 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind
);
3872 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3877 gfc_resolve_fget_sub (gfc_code
*c
)
3882 st
= c
->ext
.actual
->next
->expr
;
3884 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), st
->ts
.kind
);
3886 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind
);
3888 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3893 gfc_resolve_fputc_sub (gfc_code
*c
)
3900 u
= c
->ext
.actual
->expr
;
3901 st
= c
->ext
.actual
->next
->next
->expr
;
3903 if (u
->ts
.kind
!= gfc_c_int_kind
)
3905 ts
.type
= BT_INTEGER
;
3906 ts
.kind
= gfc_c_int_kind
;
3907 ts
.u
.derived
= NULL
;
3909 gfc_convert_type (u
, &ts
, 2);
3913 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), st
->ts
.kind
);
3915 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind
);
3917 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3922 gfc_resolve_fput_sub (gfc_code
*c
)
3927 st
= c
->ext
.actual
->next
->expr
;
3929 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), st
->ts
.kind
);
3931 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind
);
3933 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3938 gfc_resolve_fseek_sub (gfc_code
*c
)
3946 unit
= c
->ext
.actual
->expr
;
3947 offset
= c
->ext
.actual
->next
->expr
;
3948 whence
= c
->ext
.actual
->next
->next
->expr
;
3950 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3952 ts
.type
= BT_INTEGER
;
3953 ts
.kind
= gfc_c_int_kind
;
3954 ts
.u
.derived
= NULL
;
3956 gfc_convert_type (unit
, &ts
, 2);
3959 if (offset
->ts
.kind
!= gfc_intio_kind
)
3961 ts
.type
= BT_INTEGER
;
3962 ts
.kind
= gfc_intio_kind
;
3963 ts
.u
.derived
= NULL
;
3965 gfc_convert_type (offset
, &ts
, 2);
3968 if (whence
->ts
.kind
!= gfc_c_int_kind
)
3970 ts
.type
= BT_INTEGER
;
3971 ts
.kind
= gfc_c_int_kind
;
3972 ts
.u
.derived
= NULL
;
3974 gfc_convert_type (whence
, &ts
, 2);
3977 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
3981 gfc_resolve_ftell_sub (gfc_code
*c
)
3989 unit
= c
->ext
.actual
->expr
;
3990 offset
= c
->ext
.actual
->next
->expr
;
3992 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3994 ts
.type
= BT_INTEGER
;
3995 ts
.kind
= gfc_c_int_kind
;
3996 ts
.u
.derived
= NULL
;
3998 gfc_convert_type (unit
, &ts
, 2);
4001 name
= gfc_get_string (PREFIX ("ftell_i%d_sub"), offset
->ts
.kind
);
4002 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
4007 gfc_resolve_ttynam_sub (gfc_code
*c
)
4012 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
4014 ts
.type
= BT_INTEGER
;
4015 ts
.kind
= gfc_c_int_kind
;
4016 ts
.u
.derived
= NULL
;
4018 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
4021 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
4025 /* Resolve the UMASK intrinsic subroutine. */
4028 gfc_resolve_umask_sub (gfc_code
*c
)
4033 if (c
->ext
.actual
->next
->expr
!= NULL
)
4034 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
4036 kind
= gfc_default_integer_kind
;
4038 name
= gfc_get_string (PREFIX ("umask_i%d_sub"), kind
);
4039 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
4042 /* Resolve the UNLINK intrinsic subroutine. */
4045 gfc_resolve_unlink_sub (gfc_code
*c
)
4050 if (c
->ext
.actual
->next
->expr
!= NULL
)
4051 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
4053 kind
= gfc_default_integer_kind
;
4055 name
= gfc_get_string (PREFIX ("unlink_i%d_sub"), kind
);
4056 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);