1 /* Intrinsic function resolution.
2 Copyright (C) 2000-2017 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"
39 /* Given printf-like arguments, return a stable version of the result string.
41 We already have a working, optimized string hashing table in the form of
42 the identifier table. Reusing this table is likely not to be wasted,
43 since if the function name makes it to the gimple output of the frontend,
44 we'll have to create the identifier anyway. */
47 gfc_get_string (const char *format
, ...)
54 /* Handle common case without vsnprintf and temporary buffer. */
55 if (format
[0] == '%' && format
[1] == 's' && format
[2] == '\0')
57 va_start (ap
, format
);
58 str
= va_arg (ap
, const char *);
63 va_start (ap
, format
);
64 vsnprintf (temp_name
, sizeof (temp_name
), format
, ap
);
66 temp_name
[sizeof (temp_name
) - 1] = 0;
70 ident
= get_identifier (str
);
71 return IDENTIFIER_POINTER (ident
);
74 /* MERGE and SPREAD need to have source charlen's present for passing
75 to the result expression. */
77 check_charlen_present (gfc_expr
*source
)
79 if (source
->ts
.u
.cl
== NULL
)
80 source
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
82 if (source
->expr_type
== EXPR_CONSTANT
)
84 source
->ts
.u
.cl
->length
85 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
86 source
->value
.character
.length
);
89 else if (source
->expr_type
== EXPR_ARRAY
)
91 gfc_constructor
*c
= gfc_constructor_first (source
->value
.constructor
);
92 source
->ts
.u
.cl
->length
93 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
94 c
->expr
->value
.character
.length
);
98 /* Helper function for resolving the "mask" argument. */
101 resolve_mask_arg (gfc_expr
*mask
)
109 /* For the scalar case, coerce the mask to kind=4 unconditionally
110 (because this is the only kind we have a library function
113 if (mask
->ts
.kind
!= 4)
115 ts
.type
= BT_LOGICAL
;
117 gfc_convert_type (mask
, &ts
, 2);
122 /* In the library, we access the mask with a GFC_LOGICAL_1
123 argument. No need to waste memory if we are about to create
124 a temporary array. */
125 if (mask
->expr_type
== EXPR_OP
&& mask
->ts
.kind
!= 1)
127 ts
.type
= BT_LOGICAL
;
129 gfc_convert_type_warn (mask
, &ts
, 2, 0);
136 resolve_bound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
,
137 const char *name
, bool coarray
)
139 f
->ts
.type
= BT_INTEGER
;
141 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
143 f
->ts
.kind
= gfc_default_integer_kind
;
148 if (array
->rank
!= -1)
150 f
->shape
= gfc_get_shape (1);
151 mpz_init_set_ui (f
->shape
[0], coarray
? gfc_get_corank (array
)
156 f
->value
.function
.name
= gfc_get_string ("%s", name
);
161 resolve_transformational (const char *name
, gfc_expr
*f
, gfc_expr
*array
,
162 gfc_expr
*dim
, gfc_expr
*mask
)
175 resolve_mask_arg (mask
);
182 f
->rank
= array
->rank
- 1;
183 f
->shape
= gfc_copy_shape_excluding (array
->shape
, array
->rank
, dim
);
184 gfc_resolve_dim_arg (dim
);
187 f
->value
.function
.name
188 = gfc_get_string (PREFIX ("%s%s_%c%d"), prefix
, name
,
189 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
193 /********************** Resolution functions **********************/
197 gfc_resolve_abs (gfc_expr
*f
, gfc_expr
*a
)
200 if (f
->ts
.type
== BT_COMPLEX
)
201 f
->ts
.type
= BT_REAL
;
203 f
->value
.function
.name
204 = gfc_get_string ("__abs_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
209 gfc_resolve_access (gfc_expr
*f
, gfc_expr
*name ATTRIBUTE_UNUSED
,
210 gfc_expr
*mode ATTRIBUTE_UNUSED
)
212 f
->ts
.type
= BT_INTEGER
;
213 f
->ts
.kind
= gfc_c_int_kind
;
214 f
->value
.function
.name
= PREFIX ("access_func");
219 gfc_resolve_adjustl (gfc_expr
*f
, gfc_expr
*string
)
221 f
->ts
.type
= BT_CHARACTER
;
222 f
->ts
.kind
= string
->ts
.kind
;
224 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, string
->ts
.u
.cl
);
226 f
->value
.function
.name
= gfc_get_string ("__adjustl_s%d", f
->ts
.kind
);
231 gfc_resolve_adjustr (gfc_expr
*f
, gfc_expr
*string
)
233 f
->ts
.type
= BT_CHARACTER
;
234 f
->ts
.kind
= string
->ts
.kind
;
236 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, string
->ts
.u
.cl
);
238 f
->value
.function
.name
= gfc_get_string ("__adjustr_s%d", f
->ts
.kind
);
243 gfc_resolve_char_achar (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*kind
,
246 f
->ts
.type
= BT_CHARACTER
;
247 f
->ts
.kind
= (kind
== NULL
)
248 ? gfc_default_character_kind
: mpz_get_si (kind
->value
.integer
);
249 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
250 f
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
252 f
->value
.function
.name
253 = gfc_get_string ("__%schar_%d_%c%d", is_achar
? "a" : "", f
->ts
.kind
,
254 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
259 gfc_resolve_achar (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*kind
)
261 gfc_resolve_char_achar (f
, x
, kind
, true);
266 gfc_resolve_acos (gfc_expr
*f
, gfc_expr
*x
)
269 f
->value
.function
.name
270 = gfc_get_string ("__acos_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
275 gfc_resolve_acosh (gfc_expr
*f
, gfc_expr
*x
)
278 f
->value
.function
.name
279 = gfc_get_string ("__acosh_%c%d", gfc_type_letter (x
->ts
.type
),
285 gfc_resolve_aimag (gfc_expr
*f
, gfc_expr
*x
)
287 f
->ts
.type
= BT_REAL
;
288 f
->ts
.kind
= x
->ts
.kind
;
289 f
->value
.function
.name
290 = gfc_get_string ("__aimag_%c%d", gfc_type_letter (x
->ts
.type
),
296 gfc_resolve_and (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
298 f
->ts
.type
= i
->ts
.type
;
299 f
->ts
.kind
= gfc_kind_max (i
, j
);
301 if (i
->ts
.kind
!= j
->ts
.kind
)
303 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
304 gfc_convert_type (j
, &i
->ts
, 2);
306 gfc_convert_type (i
, &j
->ts
, 2);
309 f
->value
.function
.name
310 = gfc_get_string ("__and_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
315 gfc_resolve_aint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
320 f
->ts
.type
= a
->ts
.type
;
321 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
323 if (a
->ts
.kind
!= f
->ts
.kind
)
325 ts
.type
= f
->ts
.type
;
326 ts
.kind
= f
->ts
.kind
;
327 gfc_convert_type (a
, &ts
, 2);
329 /* The resolved name is only used for specific intrinsics where
330 the return kind is the same as the arg kind. */
331 f
->value
.function
.name
332 = gfc_get_string ("__aint_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
337 gfc_resolve_dint (gfc_expr
*f
, gfc_expr
*a
)
339 gfc_resolve_aint (f
, a
, NULL
);
344 gfc_resolve_all (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
)
350 gfc_resolve_dim_arg (dim
);
351 f
->rank
= mask
->rank
- 1;
352 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
355 f
->value
.function
.name
356 = gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask
->ts
.type
),
362 gfc_resolve_anint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
367 f
->ts
.type
= a
->ts
.type
;
368 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
370 if (a
->ts
.kind
!= f
->ts
.kind
)
372 ts
.type
= f
->ts
.type
;
373 ts
.kind
= f
->ts
.kind
;
374 gfc_convert_type (a
, &ts
, 2);
377 /* The resolved name is only used for specific intrinsics where
378 the return kind is the same as the arg kind. */
379 f
->value
.function
.name
380 = gfc_get_string ("__anint_%c%d", gfc_type_letter (a
->ts
.type
),
386 gfc_resolve_dnint (gfc_expr
*f
, gfc_expr
*a
)
388 gfc_resolve_anint (f
, a
, NULL
);
393 gfc_resolve_any (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
)
399 gfc_resolve_dim_arg (dim
);
400 f
->rank
= mask
->rank
- 1;
401 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
404 f
->value
.function
.name
405 = gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask
->ts
.type
),
411 gfc_resolve_asin (gfc_expr
*f
, gfc_expr
*x
)
414 f
->value
.function
.name
415 = gfc_get_string ("__asin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
419 gfc_resolve_asinh (gfc_expr
*f
, gfc_expr
*x
)
422 f
->value
.function
.name
423 = gfc_get_string ("__asinh_%c%d", gfc_type_letter (x
->ts
.type
),
428 gfc_resolve_atan (gfc_expr
*f
, gfc_expr
*x
)
431 f
->value
.function
.name
432 = gfc_get_string ("__atan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
436 gfc_resolve_atanh (gfc_expr
*f
, gfc_expr
*x
)
439 f
->value
.function
.name
440 = gfc_get_string ("__atanh_%c%d", gfc_type_letter (x
->ts
.type
),
445 gfc_resolve_atan2 (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
448 f
->value
.function
.name
449 = gfc_get_string ("__atan2_%c%d", gfc_type_letter (x
->ts
.type
),
454 /* Resolve the BESYN and BESJN intrinsics. */
457 gfc_resolve_besn (gfc_expr
*f
, gfc_expr
*n
, gfc_expr
*x
)
463 if (n
->ts
.kind
!= gfc_c_int_kind
)
465 ts
.type
= BT_INTEGER
;
466 ts
.kind
= gfc_c_int_kind
;
467 gfc_convert_type (n
, &ts
, 2);
469 f
->value
.function
.name
= gfc_get_string ("<intrinsic>");
474 gfc_resolve_bessel_n2 (gfc_expr
*f
, gfc_expr
*n1
, gfc_expr
*n2
, gfc_expr
*x
)
481 if (n1
->expr_type
== EXPR_CONSTANT
&& n2
->expr_type
== EXPR_CONSTANT
)
483 f
->shape
= gfc_get_shape (1);
484 mpz_init (f
->shape
[0]);
485 mpz_sub (f
->shape
[0], n2
->value
.integer
, n1
->value
.integer
);
486 mpz_add_ui (f
->shape
[0], f
->shape
[0], 1);
489 if (n1
->ts
.kind
!= gfc_c_int_kind
)
491 ts
.type
= BT_INTEGER
;
492 ts
.kind
= gfc_c_int_kind
;
493 gfc_convert_type (n1
, &ts
, 2);
496 if (n2
->ts
.kind
!= gfc_c_int_kind
)
498 ts
.type
= BT_INTEGER
;
499 ts
.kind
= gfc_c_int_kind
;
500 gfc_convert_type (n2
, &ts
, 2);
503 if (f
->value
.function
.isym
->id
== GFC_ISYM_JN2
)
504 f
->value
.function
.name
= gfc_get_string (PREFIX ("bessel_jn_r%d"),
507 f
->value
.function
.name
= gfc_get_string (PREFIX ("bessel_yn_r%d"),
513 gfc_resolve_btest (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos
)
515 f
->ts
.type
= BT_LOGICAL
;
516 f
->ts
.kind
= gfc_default_logical_kind
;
517 f
->value
.function
.name
518 = gfc_get_string ("__btest_%d_%d", i
->ts
.kind
, pos
->ts
.kind
);
523 gfc_resolve_c_loc (gfc_expr
*f
, gfc_expr
*x ATTRIBUTE_UNUSED
)
525 f
->ts
= f
->value
.function
.isym
->ts
;
530 gfc_resolve_c_funloc (gfc_expr
*f
, gfc_expr
*x ATTRIBUTE_UNUSED
)
532 f
->ts
= f
->value
.function
.isym
->ts
;
537 gfc_resolve_ceiling (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
539 f
->ts
.type
= BT_INTEGER
;
540 f
->ts
.kind
= (kind
== NULL
)
541 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
542 f
->value
.function
.name
543 = gfc_get_string ("__ceiling_%d_%c%d", f
->ts
.kind
,
544 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
549 gfc_resolve_char (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
551 gfc_resolve_char_achar (f
, a
, kind
, false);
556 gfc_resolve_chdir (gfc_expr
*f
, gfc_expr
*d ATTRIBUTE_UNUSED
)
558 f
->ts
.type
= BT_INTEGER
;
559 f
->ts
.kind
= gfc_default_integer_kind
;
560 f
->value
.function
.name
= gfc_get_string (PREFIX ("chdir_i%d"), f
->ts
.kind
);
565 gfc_resolve_chdir_sub (gfc_code
*c
)
570 if (c
->ext
.actual
->next
->expr
!= NULL
)
571 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
573 kind
= gfc_default_integer_kind
;
575 name
= gfc_get_string (PREFIX ("chdir_i%d_sub"), kind
);
576 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
581 gfc_resolve_chmod (gfc_expr
*f
, gfc_expr
*name ATTRIBUTE_UNUSED
,
582 gfc_expr
*mode ATTRIBUTE_UNUSED
)
584 f
->ts
.type
= BT_INTEGER
;
585 f
->ts
.kind
= gfc_c_int_kind
;
586 f
->value
.function
.name
= PREFIX ("chmod_func");
591 gfc_resolve_chmod_sub (gfc_code
*c
)
596 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
597 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
599 kind
= gfc_default_integer_kind
;
601 name
= gfc_get_string (PREFIX ("chmod_i%d_sub"), kind
);
602 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
607 gfc_resolve_cmplx (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*kind
)
609 f
->ts
.type
= BT_COMPLEX
;
610 f
->ts
.kind
= (kind
== NULL
)
611 ? gfc_default_real_kind
: mpz_get_si (kind
->value
.integer
);
614 f
->value
.function
.name
615 = gfc_get_string ("__cmplx0_%d_%c%d", f
->ts
.kind
,
616 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
618 f
->value
.function
.name
619 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f
->ts
.kind
,
620 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
,
621 gfc_type_letter (y
->ts
.type
), y
->ts
.kind
);
626 gfc_resolve_dcmplx (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
)
628 gfc_resolve_cmplx (f
, x
, y
, gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
629 gfc_default_double_kind
));
634 gfc_resolve_complex (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
)
638 if (x
->ts
.type
== BT_INTEGER
)
640 if (y
->ts
.type
== BT_INTEGER
)
641 kind
= gfc_default_real_kind
;
647 if (y
->ts
.type
== BT_REAL
)
648 kind
= (x
->ts
.kind
> y
->ts
.kind
) ? x
->ts
.kind
: y
->ts
.kind
;
653 f
->ts
.type
= BT_COMPLEX
;
655 f
->value
.function
.name
656 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f
->ts
.kind
,
657 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
,
658 gfc_type_letter (y
->ts
.type
), y
->ts
.kind
);
663 gfc_resolve_conjg (gfc_expr
*f
, gfc_expr
*x
)
666 f
->value
.function
.name
= gfc_get_string ("__conjg_%d", x
->ts
.kind
);
671 gfc_resolve_cos (gfc_expr
*f
, gfc_expr
*x
)
674 f
->value
.function
.name
675 = gfc_get_string ("__cos_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
680 gfc_resolve_cosh (gfc_expr
*f
, gfc_expr
*x
)
683 f
->value
.function
.name
684 = gfc_get_string ("__cosh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
688 /* Our replacement of elements of a trig call with an EXPR_OP (e.g.
689 multiplying the result or operands by a factor to convert to/from degrees)
690 will cause the resolve_* function to be invoked again when resolving the
691 freshly created EXPR_OP. See gfc_resolve_trigd, gfc_resolve_atrigd,
692 gfc_resolve_cotan. We must observe this and avoid recursively creating
693 layers of nested EXPR_OP expressions. */
696 is_trig_resolved (gfc_expr
*f
)
698 /* We know we've already resolved the function if we see the lib call
699 starting with '__'. */
700 return (f
->value
.function
.name
!= NULL
701 && strncmp ("__", f
->value
.function
.name
, 2) == 0);
704 /* Return a shallow copy of the function expression f. The original expression
705 has its pointers cleared so that it may be freed without affecting the
706 shallow copy. This is similar to gfc_copy_expr, but doesn't perform a deep
707 copy of the argument list, allowing it to be reused somewhere else,
708 setting the expression up nicely for gfc_replace_expr. */
711 copy_replace_function_shallow (gfc_expr
*f
)
714 gfc_actual_arglist
*args
;
716 /* The only thing deep-copied in gfc_copy_expr is args. */
717 args
= f
->value
.function
.actual
;
718 f
->value
.function
.actual
= NULL
;
719 fcopy
= gfc_copy_expr (f
);
720 fcopy
->value
.function
.actual
= args
;
722 /* Clear the old function so the shallow copy is not affected if the old
723 expression is freed. */
724 f
->value
.function
.name
= NULL
;
725 f
->value
.function
.isym
= NULL
;
726 f
->value
.function
.actual
= NULL
;
727 f
->value
.function
.esym
= NULL
;
735 /* Resolve cotan = cos / sin. */
738 gfc_resolve_cotan (gfc_expr
*f
, gfc_expr
*x
)
740 gfc_expr
*result
, *fcopy
, *sin
;
741 gfc_actual_arglist
*sin_args
;
743 if (is_trig_resolved (f
))
746 /* Compute cotan (x) = cos (x) / sin (x). */
747 f
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_COS
);
748 gfc_resolve_cos (f
, x
);
750 sin_args
= gfc_get_actual_arglist ();
751 sin_args
->expr
= gfc_copy_expr (x
);
753 sin
= gfc_get_expr ();
755 sin
->where
= f
->where
;
756 sin
->expr_type
= EXPR_FUNCTION
;
757 sin
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_SIN
);
758 sin
->value
.function
.actual
= sin_args
;
759 gfc_resolve_sin (sin
, sin_args
->expr
);
761 /* Replace f with cos/sin - we do this in place in f for the caller. */
762 fcopy
= copy_replace_function_shallow (f
);
763 result
= gfc_divide (fcopy
, sin
);
764 gfc_replace_expr (f
, result
);
769 gfc_resolve_count (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
771 f
->ts
.type
= BT_INTEGER
;
773 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
775 f
->ts
.kind
= gfc_default_integer_kind
;
779 f
->rank
= mask
->rank
- 1;
780 gfc_resolve_dim_arg (dim
);
781 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
784 resolve_mask_arg (mask
);
786 f
->value
.function
.name
787 = gfc_get_string (PREFIX ("count_%d_%c"), f
->ts
.kind
,
788 gfc_type_letter (mask
->ts
.type
));
793 gfc_resolve_cshift (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*shift
,
798 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
799 gfc_resolve_substring_charlen (array
);
802 f
->rank
= array
->rank
;
803 f
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
810 /* If dim kind is greater than default integer we need to use the larger. */
811 m
= gfc_default_integer_kind
;
813 m
= m
< dim
->ts
.kind
? dim
->ts
.kind
: m
;
815 /* Convert shift to at least m, so we don't need
816 kind=1 and kind=2 versions of the library functions. */
817 if (shift
->ts
.kind
< m
)
821 ts
.type
= BT_INTEGER
;
823 gfc_convert_type_warn (shift
, &ts
, 2, 0);
828 if (dim
->expr_type
!= EXPR_CONSTANT
&& dim
->symtree
!= NULL
829 && dim
->symtree
->n
.sym
->attr
.optional
)
831 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
832 dim
->representation
.length
= shift
->ts
.kind
;
836 gfc_resolve_dim_arg (dim
);
837 /* Convert dim to shift's kind to reduce variations. */
838 if (dim
->ts
.kind
!= shift
->ts
.kind
)
839 gfc_convert_type_warn (dim
, &shift
->ts
, 2, 0);
843 if (array
->ts
.type
== BT_CHARACTER
)
845 if (array
->ts
.kind
== gfc_default_character_kind
)
846 f
->value
.function
.name
847 = gfc_get_string (PREFIX ("cshift%d_%d_char"), n
, shift
->ts
.kind
);
849 f
->value
.function
.name
850 = gfc_get_string (PREFIX ("cshift%d_%d_char%d"), n
, shift
->ts
.kind
,
854 f
->value
.function
.name
855 = gfc_get_string (PREFIX ("cshift%d_%d"), n
, shift
->ts
.kind
);
860 gfc_resolve_ctime (gfc_expr
*f
, gfc_expr
*time
)
865 f
->ts
.type
= BT_CHARACTER
;
866 f
->ts
.kind
= gfc_default_character_kind
;
868 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
869 if (time
->ts
.kind
!= 8)
871 ts
.type
= BT_INTEGER
;
875 gfc_convert_type (time
, &ts
, 2);
878 f
->value
.function
.name
= gfc_get_string (PREFIX ("ctime"));
883 gfc_resolve_dble (gfc_expr
*f
, gfc_expr
*a
)
885 f
->ts
.type
= BT_REAL
;
886 f
->ts
.kind
= gfc_default_double_kind
;
887 f
->value
.function
.name
888 = gfc_get_string ("__dble_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
893 gfc_resolve_dim (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
895 f
->ts
.type
= a
->ts
.type
;
897 f
->ts
.kind
= gfc_kind_max (a
,p
);
899 f
->ts
.kind
= a
->ts
.kind
;
901 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
903 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
904 gfc_convert_type (p
, &a
->ts
, 2);
906 gfc_convert_type (a
, &p
->ts
, 2);
909 f
->value
.function
.name
910 = gfc_get_string ("__dim_%c%d", gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
915 gfc_resolve_dot_product (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b
)
919 temp
.expr_type
= EXPR_OP
;
920 gfc_clear_ts (&temp
.ts
);
921 temp
.value
.op
.op
= INTRINSIC_NONE
;
922 temp
.value
.op
.op1
= a
;
923 temp
.value
.op
.op2
= b
;
924 gfc_type_convert_binary (&temp
, 1);
926 f
->value
.function
.name
927 = gfc_get_string (PREFIX ("dot_product_%c%d"),
928 gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
933 gfc_resolve_dprod (gfc_expr
*f
, gfc_expr
*a ATTRIBUTE_UNUSED
,
934 gfc_expr
*b ATTRIBUTE_UNUSED
)
936 f
->ts
.kind
= gfc_default_double_kind
;
937 f
->ts
.type
= BT_REAL
;
938 f
->value
.function
.name
= gfc_get_string ("__dprod_r%d", f
->ts
.kind
);
943 gfc_resolve_dshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j ATTRIBUTE_UNUSED
,
944 gfc_expr
*shift ATTRIBUTE_UNUSED
)
947 if (f
->value
.function
.isym
->id
== GFC_ISYM_DSHIFTL
)
948 f
->value
.function
.name
= gfc_get_string ("dshiftl_i%d", f
->ts
.kind
);
949 else if (f
->value
.function
.isym
->id
== GFC_ISYM_DSHIFTR
)
950 f
->value
.function
.name
= gfc_get_string ("dshiftr_i%d", f
->ts
.kind
);
957 gfc_resolve_eoshift (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*shift
,
958 gfc_expr
*boundary
, gfc_expr
*dim
)
962 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
963 gfc_resolve_substring_charlen (array
);
966 f
->rank
= array
->rank
;
967 f
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
972 if (boundary
&& boundary
->rank
> 0)
975 /* If dim kind is greater than default integer we need to use the larger. */
976 m
= gfc_default_integer_kind
;
978 m
= m
< dim
->ts
.kind
? dim
->ts
.kind
: m
;
980 /* Convert shift to at least m, so we don't need
981 kind=1 and kind=2 versions of the library functions. */
982 if (shift
->ts
.kind
< m
)
986 ts
.type
= BT_INTEGER
;
988 gfc_convert_type_warn (shift
, &ts
, 2, 0);
993 if (dim
->expr_type
!= EXPR_CONSTANT
&& dim
->symtree
!= NULL
994 && dim
->symtree
->n
.sym
->attr
.optional
)
996 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
997 dim
->representation
.length
= shift
->ts
.kind
;
1001 gfc_resolve_dim_arg (dim
);
1002 /* Convert dim to shift's kind to reduce variations. */
1003 if (dim
->ts
.kind
!= shift
->ts
.kind
)
1004 gfc_convert_type_warn (dim
, &shift
->ts
, 2, 0);
1008 if (array
->ts
.type
== BT_CHARACTER
)
1010 if (array
->ts
.kind
== gfc_default_character_kind
)
1011 f
->value
.function
.name
1012 = gfc_get_string (PREFIX ("eoshift%d_%d_char"), n
, shift
->ts
.kind
);
1014 f
->value
.function
.name
1015 = gfc_get_string (PREFIX ("eoshift%d_%d_char%d"), n
, shift
->ts
.kind
,
1019 f
->value
.function
.name
1020 = gfc_get_string (PREFIX ("eoshift%d_%d"), n
, shift
->ts
.kind
);
1025 gfc_resolve_exp (gfc_expr
*f
, gfc_expr
*x
)
1028 f
->value
.function
.name
1029 = gfc_get_string ("__exp_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1034 gfc_resolve_exponent (gfc_expr
*f
, gfc_expr
*x
)
1036 f
->ts
.type
= BT_INTEGER
;
1037 f
->ts
.kind
= gfc_default_integer_kind
;
1038 f
->value
.function
.name
= gfc_get_string ("__exponent_%d", x
->ts
.kind
);
1042 /* Resolve the EXTENDS_TYPE_OF intrinsic function. */
1045 gfc_resolve_extends_type_of (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*mo
)
1050 /* Prevent double resolution. */
1051 if (f
->ts
.type
== BT_LOGICAL
)
1054 /* Replace the first argument with the corresponding vtab. */
1055 if (a
->ts
.type
== BT_CLASS
)
1056 gfc_add_vptr_component (a
);
1057 else if (a
->ts
.type
== BT_DERIVED
)
1061 vtab
= gfc_find_derived_vtab (a
->ts
.u
.derived
);
1062 /* Clear the old expr. */
1063 gfc_free_ref_list (a
->ref
);
1065 memset (a
, '\0', sizeof (gfc_expr
));
1066 /* Construct a new one. */
1067 a
->expr_type
= EXPR_VARIABLE
;
1068 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
1074 /* Replace the second argument with the corresponding vtab. */
1075 if (mo
->ts
.type
== BT_CLASS
)
1076 gfc_add_vptr_component (mo
);
1077 else if (mo
->ts
.type
== BT_DERIVED
)
1081 vtab
= gfc_find_derived_vtab (mo
->ts
.u
.derived
);
1082 /* Clear the old expr. */
1084 gfc_free_ref_list (mo
->ref
);
1085 memset (mo
, '\0', sizeof (gfc_expr
));
1086 /* Construct a new one. */
1087 mo
->expr_type
= EXPR_VARIABLE
;
1088 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
1094 f
->ts
.type
= BT_LOGICAL
;
1097 f
->value
.function
.isym
->formal
->ts
= a
->ts
;
1098 f
->value
.function
.isym
->formal
->next
->ts
= mo
->ts
;
1100 /* Call library function. */
1101 f
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
1106 gfc_resolve_fdate (gfc_expr
*f
)
1108 f
->ts
.type
= BT_CHARACTER
;
1109 f
->ts
.kind
= gfc_default_character_kind
;
1110 f
->value
.function
.name
= gfc_get_string (PREFIX ("fdate"));
1115 gfc_resolve_floor (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1117 f
->ts
.type
= BT_INTEGER
;
1118 f
->ts
.kind
= (kind
== NULL
)
1119 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
1120 f
->value
.function
.name
1121 = gfc_get_string ("__floor%d_%c%d", f
->ts
.kind
,
1122 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1127 gfc_resolve_fnum (gfc_expr
*f
, gfc_expr
*n
)
1129 f
->ts
.type
= BT_INTEGER
;
1130 f
->ts
.kind
= gfc_default_integer_kind
;
1131 if (n
->ts
.kind
!= f
->ts
.kind
)
1132 gfc_convert_type (n
, &f
->ts
, 2);
1133 f
->value
.function
.name
= gfc_get_string (PREFIX ("fnum_i%d"), f
->ts
.kind
);
1138 gfc_resolve_fraction (gfc_expr
*f
, gfc_expr
*x
)
1141 f
->value
.function
.name
= gfc_get_string ("__fraction_%d", x
->ts
.kind
);
1145 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
1148 gfc_resolve_g77_math1 (gfc_expr
*f
, gfc_expr
*x
)
1151 f
->value
.function
.name
= gfc_get_string ("<intrinsic>");
1156 gfc_resolve_gamma (gfc_expr
*f
, gfc_expr
*x
)
1159 f
->value
.function
.name
1160 = gfc_get_string ("__tgamma_%d", x
->ts
.kind
);
1165 gfc_resolve_getcwd (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
1167 f
->ts
.type
= BT_INTEGER
;
1169 f
->value
.function
.name
= gfc_get_string (PREFIX ("getcwd"));
1174 gfc_resolve_getgid (gfc_expr
*f
)
1176 f
->ts
.type
= BT_INTEGER
;
1178 f
->value
.function
.name
= gfc_get_string (PREFIX ("getgid"));
1183 gfc_resolve_getpid (gfc_expr
*f
)
1185 f
->ts
.type
= BT_INTEGER
;
1187 f
->value
.function
.name
= gfc_get_string (PREFIX ("getpid"));
1192 gfc_resolve_getuid (gfc_expr
*f
)
1194 f
->ts
.type
= BT_INTEGER
;
1196 f
->value
.function
.name
= gfc_get_string (PREFIX ("getuid"));
1201 gfc_resolve_hostnm (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
1203 f
->ts
.type
= BT_INTEGER
;
1205 f
->value
.function
.name
= gfc_get_string (PREFIX ("hostnm"));
1210 gfc_resolve_hypot (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
1213 f
->value
.function
.name
= gfc_get_string ("__hypot_r%d", x
->ts
.kind
);
1218 gfc_resolve_iall (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
1220 resolve_transformational ("iall", f
, array
, dim
, mask
);
1225 gfc_resolve_iand (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1227 /* If the kind of i and j are different, then g77 cross-promoted the
1228 kinds to the largest value. The Fortran 95 standard requires the
1230 if (i
->ts
.kind
!= j
->ts
.kind
)
1232 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1233 gfc_convert_type (j
, &i
->ts
, 2);
1235 gfc_convert_type (i
, &j
->ts
, 2);
1239 f
->value
.function
.name
= gfc_get_string ("__iand_%d", i
->ts
.kind
);
1244 gfc_resolve_iany (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
1246 resolve_transformational ("iany", f
, array
, dim
, mask
);
1251 gfc_resolve_ibclr (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
)
1254 f
->value
.function
.name
= gfc_get_string ("__ibclr_%d", i
->ts
.kind
);
1259 gfc_resolve_ibits (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
,
1260 gfc_expr
*len ATTRIBUTE_UNUSED
)
1263 f
->value
.function
.name
= gfc_get_string ("__ibits_%d", i
->ts
.kind
);
1268 gfc_resolve_ibset (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
)
1271 f
->value
.function
.name
= gfc_get_string ("__ibset_%d", i
->ts
.kind
);
1276 gfc_resolve_iachar (gfc_expr
*f
, gfc_expr
*c
, gfc_expr
*kind
)
1278 f
->ts
.type
= BT_INTEGER
;
1280 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1282 f
->ts
.kind
= gfc_default_integer_kind
;
1283 f
->value
.function
.name
= gfc_get_string ("__ichar_%d", c
->ts
.kind
);
1288 gfc_resolve_ichar (gfc_expr
*f
, gfc_expr
*c
, gfc_expr
*kind
)
1290 f
->ts
.type
= BT_INTEGER
;
1292 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1294 f
->ts
.kind
= gfc_default_integer_kind
;
1295 f
->value
.function
.name
= gfc_get_string ("__ichar_%d", c
->ts
.kind
);
1300 gfc_resolve_idnint (gfc_expr
*f
, gfc_expr
*a
)
1302 gfc_resolve_nint (f
, a
, NULL
);
1307 gfc_resolve_ierrno (gfc_expr
*f
)
1309 f
->ts
.type
= BT_INTEGER
;
1310 f
->ts
.kind
= gfc_default_integer_kind
;
1311 f
->value
.function
.name
= gfc_get_string (PREFIX ("ierrno_i%d"), f
->ts
.kind
);
1316 gfc_resolve_ieor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1318 /* If the kind of i and j are different, then g77 cross-promoted the
1319 kinds to the largest value. The Fortran 95 standard requires the
1321 if (i
->ts
.kind
!= j
->ts
.kind
)
1323 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1324 gfc_convert_type (j
, &i
->ts
, 2);
1326 gfc_convert_type (i
, &j
->ts
, 2);
1330 f
->value
.function
.name
= gfc_get_string ("__ieor_%d", i
->ts
.kind
);
1335 gfc_resolve_ior (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1337 /* If the kind of i and j are different, then g77 cross-promoted the
1338 kinds to the largest value. The Fortran 95 standard requires the
1340 if (i
->ts
.kind
!= j
->ts
.kind
)
1342 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1343 gfc_convert_type (j
, &i
->ts
, 2);
1345 gfc_convert_type (i
, &j
->ts
, 2);
1349 f
->value
.function
.name
= gfc_get_string ("__ior_%d", i
->ts
.kind
);
1354 gfc_resolve_index_func (gfc_expr
*f
, gfc_expr
*str
,
1355 gfc_expr
*sub_str ATTRIBUTE_UNUSED
, gfc_expr
*back
,
1361 f
->ts
.type
= BT_INTEGER
;
1363 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1365 f
->ts
.kind
= gfc_default_integer_kind
;
1367 if (back
&& back
->ts
.kind
!= gfc_default_integer_kind
)
1369 ts
.type
= BT_LOGICAL
;
1370 ts
.kind
= gfc_default_integer_kind
;
1371 ts
.u
.derived
= NULL
;
1373 gfc_convert_type (back
, &ts
, 2);
1376 f
->value
.function
.name
1377 = gfc_get_string ("__index_%d_i%d", str
->ts
.kind
, f
->ts
.kind
);
1382 gfc_resolve_int (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1384 f
->ts
.type
= BT_INTEGER
;
1385 f
->ts
.kind
= (kind
== NULL
)
1386 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
1387 f
->value
.function
.name
1388 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1389 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1394 gfc_resolve_int2 (gfc_expr
*f
, gfc_expr
*a
)
1396 f
->ts
.type
= BT_INTEGER
;
1398 f
->value
.function
.name
1399 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1400 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1405 gfc_resolve_int8 (gfc_expr
*f
, gfc_expr
*a
)
1407 f
->ts
.type
= BT_INTEGER
;
1409 f
->value
.function
.name
1410 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1411 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1416 gfc_resolve_long (gfc_expr
*f
, gfc_expr
*a
)
1418 f
->ts
.type
= BT_INTEGER
;
1420 f
->value
.function
.name
1421 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1422 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1427 gfc_resolve_iparity (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
1429 resolve_transformational ("iparity", f
, array
, dim
, mask
);
1434 gfc_resolve_isatty (gfc_expr
*f
, gfc_expr
*u
)
1439 f
->ts
.type
= BT_LOGICAL
;
1440 f
->ts
.kind
= gfc_default_integer_kind
;
1441 if (u
->ts
.kind
!= gfc_c_int_kind
)
1443 ts
.type
= BT_INTEGER
;
1444 ts
.kind
= gfc_c_int_kind
;
1445 ts
.u
.derived
= NULL
;
1447 gfc_convert_type (u
, &ts
, 2);
1450 f
->value
.function
.name
= gfc_get_string (PREFIX ("isatty_l%d"), f
->ts
.kind
);
1455 gfc_resolve_ishft (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1458 f
->value
.function
.name
1459 = gfc_get_string ("__ishft_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1464 gfc_resolve_rshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1467 f
->value
.function
.name
1468 = gfc_get_string ("__rshift_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1473 gfc_resolve_lshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1476 f
->value
.function
.name
1477 = gfc_get_string ("__lshift_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1482 gfc_resolve_ishftc (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
1486 s_kind
= (size
== NULL
) ? gfc_default_integer_kind
: size
->ts
.kind
;
1489 f
->value
.function
.name
1490 = gfc_get_string ("__ishftc_%d_%d_%d", i
->ts
.kind
, shift
->ts
.kind
, s_kind
);
1495 gfc_resolve_kill (gfc_expr
*f
, gfc_expr
*p ATTRIBUTE_UNUSED
,
1496 gfc_expr
*s ATTRIBUTE_UNUSED
)
1498 f
->ts
.type
= BT_INTEGER
;
1499 f
->ts
.kind
= gfc_default_integer_kind
;
1500 f
->value
.function
.name
= gfc_get_string (PREFIX ("kill_i%d"), f
->ts
.kind
);
1505 gfc_resolve_lbound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
1507 resolve_bound (f
, array
, dim
, kind
, "__lbound", false);
1512 gfc_resolve_lcobound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
1514 resolve_bound (f
, array
, dim
, kind
, "__lcobound", true);
1519 gfc_resolve_len (gfc_expr
*f
, gfc_expr
*string
, gfc_expr
*kind
)
1521 f
->ts
.type
= BT_INTEGER
;
1523 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1525 f
->ts
.kind
= gfc_default_integer_kind
;
1526 f
->value
.function
.name
1527 = gfc_get_string ("__len_%d_i%d", string
->ts
.kind
,
1528 gfc_default_integer_kind
);
1533 gfc_resolve_len_trim (gfc_expr
*f
, gfc_expr
*string
, gfc_expr
*kind
)
1535 f
->ts
.type
= BT_INTEGER
;
1537 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1539 f
->ts
.kind
= gfc_default_integer_kind
;
1540 f
->value
.function
.name
= gfc_get_string ("__len_trim%d", string
->ts
.kind
);
1545 gfc_resolve_lgamma (gfc_expr
*f
, gfc_expr
*x
)
1548 f
->value
.function
.name
1549 = gfc_get_string ("__lgamma_%d", x
->ts
.kind
);
1554 gfc_resolve_link (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
1555 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
1557 f
->ts
.type
= BT_INTEGER
;
1558 f
->ts
.kind
= gfc_default_integer_kind
;
1559 f
->value
.function
.name
= gfc_get_string (PREFIX ("link_i%d"), f
->ts
.kind
);
1564 gfc_resolve_loc (gfc_expr
*f
, gfc_expr
*x
)
1566 f
->ts
.type
= BT_INTEGER
;
1567 f
->ts
.kind
= gfc_index_integer_kind
;
1568 f
->value
.function
.name
= gfc_get_string ("__loc_%d", x
->ts
.kind
);
1573 gfc_resolve_log (gfc_expr
*f
, gfc_expr
*x
)
1576 f
->value
.function
.name
1577 = gfc_get_string ("__log_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1582 gfc_resolve_log10 (gfc_expr
*f
, gfc_expr
*x
)
1585 f
->value
.function
.name
1586 = gfc_get_string ("__log10_%c%d", gfc_type_letter (x
->ts
.type
),
1592 gfc_resolve_logical (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1594 f
->ts
.type
= BT_LOGICAL
;
1595 f
->ts
.kind
= (kind
== NULL
)
1596 ? gfc_default_logical_kind
: mpz_get_si (kind
->value
.integer
);
1599 f
->value
.function
.name
1600 = gfc_get_string ("__logical_%d_%c%d", f
->ts
.kind
,
1601 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1606 gfc_resolve_matmul (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b
)
1610 if (a
->ts
.type
== BT_LOGICAL
&& b
->ts
.type
== BT_LOGICAL
)
1612 f
->ts
.type
= BT_LOGICAL
;
1613 f
->ts
.kind
= gfc_default_logical_kind
;
1617 temp
.expr_type
= EXPR_OP
;
1618 gfc_clear_ts (&temp
.ts
);
1619 temp
.value
.op
.op
= INTRINSIC_NONE
;
1620 temp
.value
.op
.op1
= a
;
1621 temp
.value
.op
.op2
= b
;
1622 gfc_type_convert_binary (&temp
, 1);
1626 f
->rank
= (a
->rank
== 2 && b
->rank
== 2) ? 2 : 1;
1628 if (a
->rank
== 2 && b
->rank
== 2)
1630 if (a
->shape
&& b
->shape
)
1632 f
->shape
= gfc_get_shape (f
->rank
);
1633 mpz_init_set (f
->shape
[0], a
->shape
[0]);
1634 mpz_init_set (f
->shape
[1], b
->shape
[1]);
1637 else if (a
->rank
== 1)
1641 f
->shape
= gfc_get_shape (f
->rank
);
1642 mpz_init_set (f
->shape
[0], b
->shape
[1]);
1647 /* b->rank == 1 and a->rank == 2 here, all other cases have
1648 been caught in check.c. */
1651 f
->shape
= gfc_get_shape (f
->rank
);
1652 mpz_init_set (f
->shape
[0], a
->shape
[0]);
1656 f
->value
.function
.name
1657 = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f
->ts
.type
),
1663 gfc_resolve_minmax (const char *name
, gfc_expr
*f
, gfc_actual_arglist
*args
)
1665 gfc_actual_arglist
*a
;
1667 f
->ts
.type
= args
->expr
->ts
.type
;
1668 f
->ts
.kind
= args
->expr
->ts
.kind
;
1669 /* Find the largest type kind. */
1670 for (a
= args
->next
; a
; a
= a
->next
)
1672 if (a
->expr
->ts
.kind
> f
->ts
.kind
)
1673 f
->ts
.kind
= a
->expr
->ts
.kind
;
1676 /* Convert all parameters to the required kind. */
1677 for (a
= args
; a
; a
= a
->next
)
1679 if (a
->expr
->ts
.kind
!= f
->ts
.kind
)
1680 gfc_convert_type (a
->expr
, &f
->ts
, 2);
1683 f
->value
.function
.name
1684 = gfc_get_string (name
, gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
1689 gfc_resolve_max (gfc_expr
*f
, gfc_actual_arglist
*args
)
1691 gfc_resolve_minmax ("__max_%c%d", f
, args
);
1694 /* The smallest kind for which a minloc and maxloc implementation exists. */
1696 #define MINMAXLOC_MIN_KIND 4
1699 gfc_resolve_maxloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1700 gfc_expr
*mask
, gfc_expr
*kind
)
1706 f
->ts
.type
= BT_INTEGER
;
1708 /* The library versions only exist for kinds 4, 8 and 16. For smaller kinds,
1709 we do a type conversion further down. */
1711 fkind
= mpz_get_si (kind
->value
.integer
);
1713 fkind
= gfc_default_integer_kind
;
1715 if (fkind
< MINMAXLOC_MIN_KIND
)
1716 f
->ts
.kind
= MINMAXLOC_MIN_KIND
;
1723 f
->shape
= gfc_get_shape (1);
1724 mpz_init_set_si (f
->shape
[0], array
->rank
);
1728 f
->rank
= array
->rank
- 1;
1729 gfc_resolve_dim_arg (dim
);
1730 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1732 idim
= (int) mpz_get_si (dim
->value
.integer
);
1733 f
->shape
= gfc_get_shape (f
->rank
);
1734 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1736 if (i
== (idim
- 1))
1738 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1745 if (mask
->rank
== 0)
1750 resolve_mask_arg (mask
);
1755 f
->value
.function
.name
1756 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name
, dim
!= NULL
, f
->ts
.kind
,
1757 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1760 fkind
= mpz_get_si (kind
->value
.integer
);
1762 fkind
= gfc_default_integer_kind
;
1764 if (fkind
!= f
->ts
.kind
)
1769 ts
.type
= BT_INTEGER
;
1771 gfc_convert_type_warn (f
, &ts
, 2, 0);
1777 gfc_resolve_maxval (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1787 f
->rank
= array
->rank
- 1;
1788 gfc_resolve_dim_arg (dim
);
1790 if (f
->rank
&& array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1792 idim
= (int) mpz_get_si (dim
->value
.integer
);
1793 f
->shape
= gfc_get_shape (f
->rank
);
1794 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1796 if (i
== (idim
- 1))
1798 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1805 if (mask
->rank
== 0)
1810 resolve_mask_arg (mask
);
1815 f
->value
.function
.name
1816 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
1817 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1822 gfc_resolve_mclock (gfc_expr
*f
)
1824 f
->ts
.type
= BT_INTEGER
;
1826 f
->value
.function
.name
= PREFIX ("mclock");
1831 gfc_resolve_mclock8 (gfc_expr
*f
)
1833 f
->ts
.type
= BT_INTEGER
;
1835 f
->value
.function
.name
= PREFIX ("mclock8");
1840 gfc_resolve_mask (gfc_expr
*f
, gfc_expr
*i ATTRIBUTE_UNUSED
,
1843 f
->ts
.type
= BT_INTEGER
;
1844 f
->ts
.kind
= kind
? mpz_get_si (kind
->value
.integer
)
1845 : gfc_default_integer_kind
;
1847 if (f
->value
.function
.isym
->id
== GFC_ISYM_MASKL
)
1848 f
->value
.function
.name
= gfc_get_string ("__maskl_i%d", f
->ts
.kind
);
1850 f
->value
.function
.name
= gfc_get_string ("__maskr_i%d", f
->ts
.kind
);
1855 gfc_resolve_merge (gfc_expr
*f
, gfc_expr
*tsource
,
1856 gfc_expr
*fsource ATTRIBUTE_UNUSED
,
1857 gfc_expr
*mask ATTRIBUTE_UNUSED
)
1859 if (tsource
->ts
.type
== BT_CHARACTER
&& tsource
->ref
)
1860 gfc_resolve_substring_charlen (tsource
);
1862 if (fsource
->ts
.type
== BT_CHARACTER
&& fsource
->ref
)
1863 gfc_resolve_substring_charlen (fsource
);
1865 if (tsource
->ts
.type
== BT_CHARACTER
)
1866 check_charlen_present (tsource
);
1868 f
->ts
= tsource
->ts
;
1869 f
->value
.function
.name
1870 = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource
->ts
.type
),
1876 gfc_resolve_merge_bits (gfc_expr
*f
, gfc_expr
*i
,
1877 gfc_expr
*j ATTRIBUTE_UNUSED
,
1878 gfc_expr
*mask ATTRIBUTE_UNUSED
)
1881 f
->value
.function
.name
= gfc_get_string ("__merge_bits_i%d", i
->ts
.kind
);
1886 gfc_resolve_min (gfc_expr
*f
, gfc_actual_arglist
*args
)
1888 gfc_resolve_minmax ("__min_%c%d", f
, args
);
1893 gfc_resolve_minloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1894 gfc_expr
*mask
, gfc_expr
*kind
)
1900 f
->ts
.type
= BT_INTEGER
;
1902 /* The library versions only exist for kinds 4, 8 and 16. For smaller kinds,
1903 we do a type conversion further down. */
1905 fkind
= mpz_get_si (kind
->value
.integer
);
1907 fkind
= gfc_default_integer_kind
;
1909 if (fkind
< MINMAXLOC_MIN_KIND
)
1910 f
->ts
.kind
= MINMAXLOC_MIN_KIND
;
1917 f
->shape
= gfc_get_shape (1);
1918 mpz_init_set_si (f
->shape
[0], array
->rank
);
1922 f
->rank
= array
->rank
- 1;
1923 gfc_resolve_dim_arg (dim
);
1924 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1926 idim
= (int) mpz_get_si (dim
->value
.integer
);
1927 f
->shape
= gfc_get_shape (f
->rank
);
1928 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1930 if (i
== (idim
- 1))
1932 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1939 if (mask
->rank
== 0)
1944 resolve_mask_arg (mask
);
1949 f
->value
.function
.name
1950 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name
, dim
!= NULL
, f
->ts
.kind
,
1951 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1953 if (fkind
!= f
->ts
.kind
)
1958 ts
.type
= BT_INTEGER
;
1960 gfc_convert_type_warn (f
, &ts
, 2, 0);
1966 gfc_resolve_minval (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1976 f
->rank
= array
->rank
- 1;
1977 gfc_resolve_dim_arg (dim
);
1979 if (f
->rank
&& array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1981 idim
= (int) mpz_get_si (dim
->value
.integer
);
1982 f
->shape
= gfc_get_shape (f
->rank
);
1983 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1985 if (i
== (idim
- 1))
1987 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1994 if (mask
->rank
== 0)
1999 resolve_mask_arg (mask
);
2004 f
->value
.function
.name
2005 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
2006 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
2011 gfc_resolve_mod (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
2013 f
->ts
.type
= a
->ts
.type
;
2015 f
->ts
.kind
= gfc_kind_max (a
,p
);
2017 f
->ts
.kind
= a
->ts
.kind
;
2019 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
2021 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
2022 gfc_convert_type (p
, &a
->ts
, 2);
2024 gfc_convert_type (a
, &p
->ts
, 2);
2027 f
->value
.function
.name
2028 = gfc_get_string ("__mod_%c%d", gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
2033 gfc_resolve_modulo (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
2035 f
->ts
.type
= a
->ts
.type
;
2037 f
->ts
.kind
= gfc_kind_max (a
,p
);
2039 f
->ts
.kind
= a
->ts
.kind
;
2041 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
2043 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
2044 gfc_convert_type (p
, &a
->ts
, 2);
2046 gfc_convert_type (a
, &p
->ts
, 2);
2049 f
->value
.function
.name
2050 = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f
->ts
.type
),
2055 gfc_resolve_nearest (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
2057 if (p
->ts
.kind
!= a
->ts
.kind
)
2058 gfc_convert_type (p
, &a
->ts
, 2);
2061 f
->value
.function
.name
2062 = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a
->ts
.type
),
2067 gfc_resolve_nint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
2069 f
->ts
.type
= BT_INTEGER
;
2070 f
->ts
.kind
= (kind
== NULL
)
2071 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
2072 f
->value
.function
.name
2073 = gfc_get_string ("__nint_%d_%d", f
->ts
.kind
, a
->ts
.kind
);
2078 gfc_resolve_norm2 (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
)
2080 resolve_transformational ("norm2", f
, array
, dim
, NULL
);
2085 gfc_resolve_not (gfc_expr
*f
, gfc_expr
*i
)
2088 f
->value
.function
.name
= gfc_get_string ("__not_%d", i
->ts
.kind
);
2093 gfc_resolve_or (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
2095 f
->ts
.type
= i
->ts
.type
;
2096 f
->ts
.kind
= gfc_kind_max (i
, j
);
2098 if (i
->ts
.kind
!= j
->ts
.kind
)
2100 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
2101 gfc_convert_type (j
, &i
->ts
, 2);
2103 gfc_convert_type (i
, &j
->ts
, 2);
2106 f
->value
.function
.name
2107 = gfc_get_string ("__or_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
2112 gfc_resolve_pack (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*mask
,
2113 gfc_expr
*vector ATTRIBUTE_UNUSED
)
2115 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
2116 gfc_resolve_substring_charlen (array
);
2121 resolve_mask_arg (mask
);
2123 if (mask
->rank
!= 0)
2125 if (array
->ts
.type
== BT_CHARACTER
)
2126 f
->value
.function
.name
2127 = array
->ts
.kind
== 1 ? PREFIX ("pack_char")
2129 (PREFIX ("pack_char%d"),
2132 f
->value
.function
.name
= PREFIX ("pack");
2136 if (array
->ts
.type
== BT_CHARACTER
)
2137 f
->value
.function
.name
2138 = array
->ts
.kind
== 1 ? PREFIX ("pack_s_char")
2140 (PREFIX ("pack_s_char%d"),
2143 f
->value
.function
.name
= PREFIX ("pack_s");
2149 gfc_resolve_parity (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
)
2151 resolve_transformational ("parity", f
, array
, dim
, NULL
);
2156 gfc_resolve_product (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
2159 resolve_transformational ("product", f
, array
, dim
, mask
);
2164 gfc_resolve_rank (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
)
2166 f
->ts
.type
= BT_INTEGER
;
2167 f
->ts
.kind
= gfc_default_integer_kind
;
2168 f
->value
.function
.name
= gfc_get_string ("__rank");
2173 gfc_resolve_real (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
2175 f
->ts
.type
= BT_REAL
;
2178 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2180 f
->ts
.kind
= (a
->ts
.type
== BT_COMPLEX
)
2181 ? a
->ts
.kind
: gfc_default_real_kind
;
2183 f
->value
.function
.name
2184 = gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
2185 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2190 gfc_resolve_realpart (gfc_expr
*f
, gfc_expr
*a
)
2192 f
->ts
.type
= BT_REAL
;
2193 f
->ts
.kind
= a
->ts
.kind
;
2194 f
->value
.function
.name
2195 = gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
2196 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2201 gfc_resolve_rename (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
2202 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
2204 f
->ts
.type
= BT_INTEGER
;
2205 f
->ts
.kind
= gfc_default_integer_kind
;
2206 f
->value
.function
.name
= gfc_get_string (PREFIX ("rename_i%d"), f
->ts
.kind
);
2211 gfc_resolve_repeat (gfc_expr
*f
, gfc_expr
*string
,
2216 f
->ts
.type
= BT_CHARACTER
;
2217 f
->ts
.kind
= string
->ts
.kind
;
2218 f
->value
.function
.name
= gfc_get_string ("__repeat_%d", string
->ts
.kind
);
2220 /* If possible, generate a character length. */
2221 if (f
->ts
.u
.cl
== NULL
)
2222 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2225 if (string
->expr_type
== EXPR_CONSTANT
)
2227 len
= string
->value
.character
.length
;
2228 tmp
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, len
);
2230 else if (string
->ts
.u
.cl
&& string
->ts
.u
.cl
->length
)
2232 tmp
= gfc_copy_expr (string
->ts
.u
.cl
->length
);
2236 f
->ts
.u
.cl
->length
= gfc_multiply (tmp
, gfc_copy_expr (ncopies
));
2241 gfc_resolve_reshape (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*shape
,
2242 gfc_expr
*pad ATTRIBUTE_UNUSED
,
2243 gfc_expr
*order ATTRIBUTE_UNUSED
)
2249 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
2250 gfc_resolve_substring_charlen (source
);
2254 gfc_array_size (shape
, &rank
);
2255 f
->rank
= mpz_get_si (rank
);
2257 switch (source
->ts
.type
)
2264 kind
= source
->ts
.kind
;
2278 if (source
->ts
.type
== BT_COMPLEX
|| source
->ts
.type
== BT_REAL
)
2279 f
->value
.function
.name
2280 = gfc_get_string (PREFIX ("reshape_%c%d"),
2281 gfc_type_letter (source
->ts
.type
),
2283 else if (source
->ts
.type
== BT_CHARACTER
)
2284 f
->value
.function
.name
= gfc_get_string (PREFIX ("reshape_char%d"),
2287 f
->value
.function
.name
2288 = gfc_get_string (PREFIX ("reshape_%d"), source
->ts
.kind
);
2292 f
->value
.function
.name
= (source
->ts
.type
== BT_CHARACTER
2293 ? PREFIX ("reshape_char") : PREFIX ("reshape"));
2297 if (shape
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (shape
))
2300 f
->shape
= gfc_get_shape (f
->rank
);
2301 c
= gfc_constructor_first (shape
->value
.constructor
);
2302 for (i
= 0; i
< f
->rank
; i
++)
2304 mpz_init_set (f
->shape
[i
], c
->expr
->value
.integer
);
2305 c
= gfc_constructor_next (c
);
2309 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
2310 so many runtime variations. */
2311 if (shape
->ts
.kind
!= gfc_index_integer_kind
)
2313 gfc_typespec ts
= shape
->ts
;
2314 ts
.kind
= gfc_index_integer_kind
;
2315 gfc_convert_type_warn (shape
, &ts
, 2, 0);
2317 if (order
&& order
->ts
.kind
!= gfc_index_integer_kind
)
2318 gfc_convert_type_warn (order
, &shape
->ts
, 2, 0);
2323 gfc_resolve_rrspacing (gfc_expr
*f
, gfc_expr
*x
)
2326 f
->value
.function
.name
= gfc_get_string ("__rrspacing_%d", x
->ts
.kind
);
2330 gfc_resolve_fe_runtime_error (gfc_code
*c
)
2333 gfc_actual_arglist
*a
;
2335 name
= gfc_get_string (PREFIX ("runtime_error"));
2337 for (a
= c
->ext
.actual
->next
; a
; a
= a
->next
)
2340 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2344 gfc_resolve_scale (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*i ATTRIBUTE_UNUSED
)
2347 f
->value
.function
.name
= gfc_get_string ("__scale_%d", x
->ts
.kind
);
2352 gfc_resolve_scan (gfc_expr
*f
, gfc_expr
*string
,
2353 gfc_expr
*set ATTRIBUTE_UNUSED
,
2354 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2356 f
->ts
.type
= BT_INTEGER
;
2358 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2360 f
->ts
.kind
= gfc_default_integer_kind
;
2361 f
->value
.function
.name
= gfc_get_string ("__scan_%d", string
->ts
.kind
);
2366 gfc_resolve_secnds (gfc_expr
*t1
, gfc_expr
*t0
)
2369 t1
->value
.function
.name
= gfc_get_string (PREFIX ("secnds"));
2374 gfc_resolve_set_exponent (gfc_expr
*f
, gfc_expr
*x
,
2375 gfc_expr
*i ATTRIBUTE_UNUSED
)
2378 f
->value
.function
.name
= gfc_get_string ("__set_exponent_%d", x
->ts
.kind
);
2383 gfc_resolve_shape (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*kind
)
2385 f
->ts
.type
= BT_INTEGER
;
2388 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2390 f
->ts
.kind
= gfc_default_integer_kind
;
2393 if (array
->rank
!= -1)
2395 f
->shape
= gfc_get_shape (1);
2396 mpz_init_set_ui (f
->shape
[0], array
->rank
);
2399 f
->value
.function
.name
= gfc_get_string (PREFIX ("shape_%d"), f
->ts
.kind
);
2404 gfc_resolve_shift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift ATTRIBUTE_UNUSED
)
2407 if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTA
)
2408 f
->value
.function
.name
= gfc_get_string ("shifta_i%d", f
->ts
.kind
);
2409 else if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTL
)
2410 f
->value
.function
.name
= gfc_get_string ("shiftl_i%d", f
->ts
.kind
);
2411 else if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTR
)
2412 f
->value
.function
.name
= gfc_get_string ("shiftr_i%d", f
->ts
.kind
);
2419 gfc_resolve_sign (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b ATTRIBUTE_UNUSED
)
2422 f
->value
.function
.name
2423 = gfc_get_string ("__sign_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2428 gfc_resolve_signal (gfc_expr
*f
, gfc_expr
*number
, gfc_expr
*handler
)
2430 f
->ts
.type
= BT_INTEGER
;
2431 f
->ts
.kind
= gfc_c_int_kind
;
2433 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2434 if (handler
->ts
.type
== BT_INTEGER
)
2436 if (handler
->ts
.kind
!= gfc_c_int_kind
)
2437 gfc_convert_type (handler
, &f
->ts
, 2);
2438 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func_int"));
2441 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func"));
2443 if (number
->ts
.kind
!= gfc_c_int_kind
)
2444 gfc_convert_type (number
, &f
->ts
, 2);
2449 gfc_resolve_sin (gfc_expr
*f
, gfc_expr
*x
)
2452 f
->value
.function
.name
2453 = gfc_get_string ("__sin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2458 gfc_resolve_sinh (gfc_expr
*f
, gfc_expr
*x
)
2461 f
->value
.function
.name
2462 = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2467 gfc_resolve_size (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2468 gfc_expr
*dim ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2470 f
->ts
.type
= BT_INTEGER
;
2472 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2474 f
->ts
.kind
= gfc_default_integer_kind
;
2479 gfc_resolve_stride (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2480 gfc_expr
*dim ATTRIBUTE_UNUSED
)
2482 f
->ts
.type
= BT_INTEGER
;
2483 f
->ts
.kind
= gfc_index_integer_kind
;
2488 gfc_resolve_spacing (gfc_expr
*f
, gfc_expr
*x
)
2491 f
->value
.function
.name
= gfc_get_string ("__spacing_%d", x
->ts
.kind
);
2496 gfc_resolve_spread (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*dim
,
2499 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
2500 gfc_resolve_substring_charlen (source
);
2502 if (source
->ts
.type
== BT_CHARACTER
)
2503 check_charlen_present (source
);
2506 f
->rank
= source
->rank
+ 1;
2507 if (source
->rank
== 0)
2509 if (source
->ts
.type
== BT_CHARACTER
)
2510 f
->value
.function
.name
2511 = source
->ts
.kind
== 1 ? PREFIX ("spread_char_scalar")
2513 (PREFIX ("spread_char%d_scalar"),
2516 f
->value
.function
.name
= PREFIX ("spread_scalar");
2520 if (source
->ts
.type
== BT_CHARACTER
)
2521 f
->value
.function
.name
2522 = source
->ts
.kind
== 1 ? PREFIX ("spread_char")
2524 (PREFIX ("spread_char%d"),
2527 f
->value
.function
.name
= PREFIX ("spread");
2530 if (dim
&& gfc_is_constant_expr (dim
)
2531 && ncopies
&& gfc_is_constant_expr (ncopies
) && source
->shape
[0])
2534 idim
= mpz_get_ui (dim
->value
.integer
);
2535 f
->shape
= gfc_get_shape (f
->rank
);
2536 for (i
= 0; i
< (idim
- 1); i
++)
2537 mpz_init_set (f
->shape
[i
], source
->shape
[i
]);
2539 mpz_init_set (f
->shape
[idim
- 1], ncopies
->value
.integer
);
2541 for (i
= idim
; i
< f
->rank
; i
++)
2542 mpz_init_set (f
->shape
[i
], source
->shape
[i
-1]);
2546 gfc_resolve_dim_arg (dim
);
2547 gfc_resolve_index (ncopies
, 1);
2552 gfc_resolve_sqrt (gfc_expr
*f
, gfc_expr
*x
)
2555 f
->value
.function
.name
2556 = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2560 /* Resolve the g77 compatibility function STAT AND FSTAT. */
2563 gfc_resolve_stat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2564 gfc_expr
*a ATTRIBUTE_UNUSED
)
2566 f
->ts
.type
= BT_INTEGER
;
2567 f
->ts
.kind
= gfc_default_integer_kind
;
2568 f
->value
.function
.name
= gfc_get_string (PREFIX ("stat_i%d"), f
->ts
.kind
);
2573 gfc_resolve_lstat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2574 gfc_expr
*a ATTRIBUTE_UNUSED
)
2576 f
->ts
.type
= BT_INTEGER
;
2577 f
->ts
.kind
= gfc_default_integer_kind
;
2578 f
->value
.function
.name
= gfc_get_string (PREFIX ("lstat_i%d"), f
->ts
.kind
);
2583 gfc_resolve_fstat (gfc_expr
*f
, gfc_expr
*n
, gfc_expr
*a ATTRIBUTE_UNUSED
)
2585 f
->ts
.type
= BT_INTEGER
;
2586 f
->ts
.kind
= gfc_default_integer_kind
;
2587 if (n
->ts
.kind
!= f
->ts
.kind
)
2588 gfc_convert_type (n
, &f
->ts
, 2);
2590 f
->value
.function
.name
= gfc_get_string (PREFIX ("fstat_i%d"), f
->ts
.kind
);
2595 gfc_resolve_fgetc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2600 f
->ts
.type
= BT_INTEGER
;
2601 f
->ts
.kind
= gfc_c_int_kind
;
2602 if (u
->ts
.kind
!= gfc_c_int_kind
)
2604 ts
.type
= BT_INTEGER
;
2605 ts
.kind
= gfc_c_int_kind
;
2606 ts
.u
.derived
= NULL
;
2608 gfc_convert_type (u
, &ts
, 2);
2611 f
->value
.function
.name
= gfc_get_string (PREFIX ("fgetc"));
2616 gfc_resolve_fget (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2618 f
->ts
.type
= BT_INTEGER
;
2619 f
->ts
.kind
= gfc_c_int_kind
;
2620 f
->value
.function
.name
= gfc_get_string (PREFIX ("fget"));
2625 gfc_resolve_fputc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2630 f
->ts
.type
= BT_INTEGER
;
2631 f
->ts
.kind
= gfc_c_int_kind
;
2632 if (u
->ts
.kind
!= gfc_c_int_kind
)
2634 ts
.type
= BT_INTEGER
;
2635 ts
.kind
= gfc_c_int_kind
;
2636 ts
.u
.derived
= NULL
;
2638 gfc_convert_type (u
, &ts
, 2);
2641 f
->value
.function
.name
= gfc_get_string (PREFIX ("fputc"));
2646 gfc_resolve_fput (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2648 f
->ts
.type
= BT_INTEGER
;
2649 f
->ts
.kind
= gfc_c_int_kind
;
2650 f
->value
.function
.name
= gfc_get_string (PREFIX ("fput"));
2655 gfc_resolve_ftell (gfc_expr
*f
, gfc_expr
*u
)
2660 f
->ts
.type
= BT_INTEGER
;
2661 f
->ts
.kind
= gfc_intio_kind
;
2662 if (u
->ts
.kind
!= gfc_c_int_kind
)
2664 ts
.type
= BT_INTEGER
;
2665 ts
.kind
= gfc_c_int_kind
;
2666 ts
.u
.derived
= NULL
;
2668 gfc_convert_type (u
, &ts
, 2);
2671 f
->value
.function
.name
= gfc_get_string (PREFIX ("ftell"));
2676 gfc_resolve_storage_size (gfc_expr
*f
, gfc_expr
*a ATTRIBUTE_UNUSED
,
2679 f
->ts
.type
= BT_INTEGER
;
2681 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2683 f
->ts
.kind
= gfc_default_integer_kind
;
2688 gfc_resolve_sum (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2690 resolve_transformational ("sum", f
, array
, dim
, mask
);
2695 gfc_resolve_symlnk (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
2696 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
2698 f
->ts
.type
= BT_INTEGER
;
2699 f
->ts
.kind
= gfc_default_integer_kind
;
2700 f
->value
.function
.name
= gfc_get_string (PREFIX ("symlnk_i%d"), f
->ts
.kind
);
2704 /* Resolve the g77 compatibility function SYSTEM. */
2707 gfc_resolve_system (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
2709 f
->ts
.type
= BT_INTEGER
;
2711 f
->value
.function
.name
= gfc_get_string (PREFIX ("system"));
2716 gfc_resolve_tan (gfc_expr
*f
, gfc_expr
*x
)
2719 f
->value
.function
.name
2720 = gfc_get_string ("__tan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2725 gfc_resolve_tanh (gfc_expr
*f
, gfc_expr
*x
)
2728 f
->value
.function
.name
2729 = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2733 /* Build an expression for converting degrees to radians. */
2736 get_radians (gfc_expr
*deg
)
2738 gfc_expr
*result
, *factor
;
2739 gfc_actual_arglist
*mod_args
;
2741 gcc_assert (deg
->ts
.type
== BT_REAL
);
2743 /* Set deg = deg % 360 to avoid offsets from large angles. */
2744 factor
= gfc_get_constant_expr (deg
->ts
.type
, deg
->ts
.kind
, °
->where
);
2745 mpfr_set_d (factor
->value
.real
, 360.0, GFC_RND_MODE
);
2747 mod_args
= gfc_get_actual_arglist ();
2748 mod_args
->expr
= deg
;
2749 mod_args
->next
= gfc_get_actual_arglist ();
2750 mod_args
->next
->expr
= factor
;
2752 result
= gfc_get_expr ();
2753 result
->ts
= deg
->ts
;
2754 result
->where
= deg
->where
;
2755 result
->expr_type
= EXPR_FUNCTION
;
2756 result
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_MOD
);
2757 result
->value
.function
.actual
= mod_args
;
2759 /* Set factor = pi / 180. */
2760 factor
= gfc_get_constant_expr (deg
->ts
.type
, deg
->ts
.kind
, °
->where
);
2761 mpfr_const_pi (factor
->value
.real
, GFC_RND_MODE
);
2762 mpfr_div_ui (factor
->value
.real
, factor
->value
.real
, 180, GFC_RND_MODE
);
2764 /* Result is rad = (deg % 360) * (pi / 180). */
2765 result
= gfc_multiply (result
, factor
);
2770 /* Build an expression for converting radians to degrees. */
2773 get_degrees (gfc_expr
*rad
)
2775 gfc_expr
*result
, *factor
;
2776 gfc_actual_arglist
*mod_args
;
2779 gcc_assert (rad
->ts
.type
== BT_REAL
);
2781 /* Set rad = rad % 2pi to avoid offsets from large angles. */
2782 factor
= gfc_get_constant_expr (rad
->ts
.type
, rad
->ts
.kind
, &rad
->where
);
2783 mpfr_const_pi (factor
->value
.real
, GFC_RND_MODE
);
2784 mpfr_mul_ui (factor
->value
.real
, factor
->value
.real
, 2, GFC_RND_MODE
);
2786 mod_args
= gfc_get_actual_arglist ();
2787 mod_args
->expr
= rad
;
2788 mod_args
->next
= gfc_get_actual_arglist ();
2789 mod_args
->next
->expr
= factor
;
2791 result
= gfc_get_expr ();
2792 result
->ts
= rad
->ts
;
2793 result
->where
= rad
->where
;
2794 result
->expr_type
= EXPR_FUNCTION
;
2795 result
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_MOD
);
2796 result
->value
.function
.actual
= mod_args
;
2798 /* Set factor = 180 / pi. */
2799 factor
= gfc_get_constant_expr (rad
->ts
.type
, rad
->ts
.kind
, &rad
->where
);
2800 mpfr_set_ui (factor
->value
.real
, 180, GFC_RND_MODE
);
2802 mpfr_const_pi (tmp
, GFC_RND_MODE
);
2803 mpfr_div (factor
->value
.real
, factor
->value
.real
, tmp
, GFC_RND_MODE
);
2806 /* Result is deg = (rad % 2pi) * (180 / pi). */
2807 result
= gfc_multiply (result
, factor
);
2812 /* Resolve a call to a trig function. */
2815 resolve_trig_call (gfc_expr
*f
, gfc_expr
*x
)
2817 switch (f
->value
.function
.isym
->id
)
2820 return gfc_resolve_acos (f
, x
);
2822 return gfc_resolve_asin (f
, x
);
2824 return gfc_resolve_atan (f
, x
);
2825 case GFC_ISYM_ATAN2
:
2826 /* NB. arg3 is unused for atan2 */
2827 return gfc_resolve_atan2 (f
, x
, NULL
);
2829 return gfc_resolve_cos (f
, x
);
2830 case GFC_ISYM_COTAN
:
2831 return gfc_resolve_cotan (f
, x
);
2833 return gfc_resolve_sin (f
, x
);
2835 return gfc_resolve_tan (f
, x
);
2841 /* Resolve degree trig function as trigd (x) = trig (radians (x)). */
2844 gfc_resolve_trigd (gfc_expr
*f
, gfc_expr
*x
)
2846 if (is_trig_resolved (f
))
2849 x
= get_radians (x
);
2850 f
->value
.function
.actual
->expr
= x
;
2852 resolve_trig_call (f
, x
);
2856 /* Resolve degree inverse trig function as atrigd (x) = degrees (atrig (x)). */
2859 gfc_resolve_atrigd (gfc_expr
*f
, gfc_expr
*x
)
2861 gfc_expr
*result
, *fcopy
;
2863 if (is_trig_resolved (f
))
2866 resolve_trig_call (f
, x
);
2868 fcopy
= copy_replace_function_shallow (f
);
2869 result
= get_degrees (fcopy
);
2870 gfc_replace_expr (f
, result
);
2874 /* Resolve atan2d(x) = degrees(atan2(x)). */
2877 gfc_resolve_atan2d (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
2879 /* Note that we lose the second arg here - that's okay because it is
2880 unused in gfc_resolve_atan2 anyway. */
2881 gfc_resolve_atrigd (f
, x
);
2885 /* Resolve failed_images (team, kind). */
2888 gfc_resolve_failed_images (gfc_expr
*f
, gfc_expr
*team ATTRIBUTE_UNUSED
,
2891 static char failed_images
[] = "_gfortran_caf_failed_images";
2893 f
->ts
.type
= BT_INTEGER
;
2895 f
->ts
.kind
= gfc_default_integer_kind
;
2897 gfc_extract_int (kind
, &f
->ts
.kind
);
2898 f
->value
.function
.name
= failed_images
;
2902 /* Resolve image_status (image, team). */
2905 gfc_resolve_image_status (gfc_expr
*f
, gfc_expr
*image ATTRIBUTE_UNUSED
,
2906 gfc_expr
*team ATTRIBUTE_UNUSED
)
2908 static char image_status
[] = "_gfortran_caf_image_status";
2909 f
->ts
.type
= BT_INTEGER
;
2910 f
->ts
.kind
= gfc_default_integer_kind
;
2911 f
->value
.function
.name
= image_status
;
2915 /* Resolve image_index (...). */
2918 gfc_resolve_image_index (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2919 gfc_expr
*sub ATTRIBUTE_UNUSED
)
2921 static char image_index
[] = "__image_index";
2922 f
->ts
.type
= BT_INTEGER
;
2923 f
->ts
.kind
= gfc_default_integer_kind
;
2924 f
->value
.function
.name
= image_index
;
2928 /* Resolve stopped_images (team, kind). */
2931 gfc_resolve_stopped_images (gfc_expr
*f
, gfc_expr
*team ATTRIBUTE_UNUSED
,
2934 static char stopped_images
[] = "_gfortran_caf_stopped_images";
2936 f
->ts
.type
= BT_INTEGER
;
2938 f
->ts
.kind
= gfc_default_integer_kind
;
2940 gfc_extract_int (kind
, &f
->ts
.kind
);
2941 f
->value
.function
.name
= stopped_images
;
2946 gfc_resolve_this_image (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
2947 gfc_expr
*distance ATTRIBUTE_UNUSED
)
2949 static char this_image
[] = "__this_image";
2950 if (array
&& gfc_is_coarray (array
))
2951 resolve_bound (f
, array
, dim
, NULL
, "__this_image", true);
2954 f
->ts
.type
= BT_INTEGER
;
2955 f
->ts
.kind
= gfc_default_integer_kind
;
2956 f
->value
.function
.name
= this_image
;
2962 gfc_resolve_time (gfc_expr
*f
)
2964 f
->ts
.type
= BT_INTEGER
;
2966 f
->value
.function
.name
= gfc_get_string (PREFIX ("time_func"));
2971 gfc_resolve_time8 (gfc_expr
*f
)
2973 f
->ts
.type
= BT_INTEGER
;
2975 f
->value
.function
.name
= gfc_get_string (PREFIX ("time8_func"));
2980 gfc_resolve_transfer (gfc_expr
*f
, gfc_expr
*source ATTRIBUTE_UNUSED
,
2981 gfc_expr
*mold
, gfc_expr
*size
)
2983 /* TODO: Make this do something meaningful. */
2984 static char transfer0
[] = "__transfer0", transfer1
[] = "__transfer1";
2986 if (mold
->ts
.type
== BT_CHARACTER
2987 && !mold
->ts
.u
.cl
->length
2988 && gfc_is_constant_expr (mold
))
2991 if (mold
->expr_type
== EXPR_CONSTANT
)
2993 len
= mold
->value
.character
.length
;
2994 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
2999 gfc_constructor
*c
= gfc_constructor_first (mold
->value
.constructor
);
3000 len
= c
->expr
->value
.character
.length
;
3001 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
3008 if (size
== NULL
&& mold
->rank
== 0)
3011 f
->value
.function
.name
= transfer0
;
3016 f
->value
.function
.name
= transfer1
;
3017 if (size
&& gfc_is_constant_expr (size
))
3019 f
->shape
= gfc_get_shape (1);
3020 mpz_init_set (f
->shape
[0], size
->value
.integer
);
3027 gfc_resolve_transpose (gfc_expr
*f
, gfc_expr
*matrix
)
3030 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ref
)
3031 gfc_resolve_substring_charlen (matrix
);
3037 f
->shape
= gfc_get_shape (2);
3038 mpz_init_set (f
->shape
[0], matrix
->shape
[1]);
3039 mpz_init_set (f
->shape
[1], matrix
->shape
[0]);
3042 switch (matrix
->ts
.kind
)
3048 switch (matrix
->ts
.type
)
3052 f
->value
.function
.name
3053 = gfc_get_string (PREFIX ("transpose_%c%d"),
3054 gfc_type_letter (matrix
->ts
.type
),
3060 /* Use the integer routines for real and logical cases. This
3061 assumes they all have the same alignment requirements. */
3062 f
->value
.function
.name
3063 = gfc_get_string (PREFIX ("transpose_i%d"), matrix
->ts
.kind
);
3067 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ts
.kind
== 4)
3068 f
->value
.function
.name
= PREFIX ("transpose_char4");
3070 f
->value
.function
.name
= PREFIX ("transpose");
3076 f
->value
.function
.name
= (matrix
->ts
.type
== BT_CHARACTER
3077 ? PREFIX ("transpose_char")
3078 : PREFIX ("transpose"));
3085 gfc_resolve_trim (gfc_expr
*f
, gfc_expr
*string
)
3087 f
->ts
.type
= BT_CHARACTER
;
3088 f
->ts
.kind
= string
->ts
.kind
;
3089 f
->value
.function
.name
= gfc_get_string ("__trim_%d", string
->ts
.kind
);
3094 gfc_resolve_ubound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3096 resolve_bound (f
, array
, dim
, kind
, "__ubound", false);
3101 gfc_resolve_ucobound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3103 resolve_bound (f
, array
, dim
, kind
, "__ucobound", true);
3107 /* Resolve the g77 compatibility function UMASK. */
3110 gfc_resolve_umask (gfc_expr
*f
, gfc_expr
*n
)
3112 f
->ts
.type
= BT_INTEGER
;
3113 f
->ts
.kind
= n
->ts
.kind
;
3114 f
->value
.function
.name
= gfc_get_string (PREFIX ("umask_i%d"), n
->ts
.kind
);
3118 /* Resolve the g77 compatibility function UNLINK. */
3121 gfc_resolve_unlink (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
3123 f
->ts
.type
= BT_INTEGER
;
3125 f
->value
.function
.name
= gfc_get_string (PREFIX ("unlink"));
3130 gfc_resolve_ttynam (gfc_expr
*f
, gfc_expr
*unit
)
3135 f
->ts
.type
= BT_CHARACTER
;
3136 f
->ts
.kind
= gfc_default_character_kind
;
3138 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3140 ts
.type
= BT_INTEGER
;
3141 ts
.kind
= gfc_c_int_kind
;
3142 ts
.u
.derived
= NULL
;
3144 gfc_convert_type (unit
, &ts
, 2);
3147 f
->value
.function
.name
= gfc_get_string (PREFIX ("ttynam"));
3152 gfc_resolve_unpack (gfc_expr
*f
, gfc_expr
*vector
, gfc_expr
*mask
,
3153 gfc_expr
*field ATTRIBUTE_UNUSED
)
3155 if (vector
->ts
.type
== BT_CHARACTER
&& vector
->ref
)
3156 gfc_resolve_substring_charlen (vector
);
3159 f
->rank
= mask
->rank
;
3160 resolve_mask_arg (mask
);
3162 if (vector
->ts
.type
== BT_CHARACTER
)
3164 if (vector
->ts
.kind
== 1)
3165 f
->value
.function
.name
3166 = gfc_get_string (PREFIX ("unpack%d_char"), field
->rank
> 0 ? 1 : 0);
3168 f
->value
.function
.name
3169 = gfc_get_string (PREFIX ("unpack%d_char%d"),
3170 field
->rank
> 0 ? 1 : 0, vector
->ts
.kind
);
3173 f
->value
.function
.name
3174 = gfc_get_string (PREFIX ("unpack%d"), field
->rank
> 0 ? 1 : 0);
3179 gfc_resolve_verify (gfc_expr
*f
, gfc_expr
*string
,
3180 gfc_expr
*set ATTRIBUTE_UNUSED
,
3181 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
3183 f
->ts
.type
= BT_INTEGER
;
3185 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
3187 f
->ts
.kind
= gfc_default_integer_kind
;
3188 f
->value
.function
.name
= gfc_get_string ("__verify_%d", string
->ts
.kind
);
3193 gfc_resolve_xor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
3195 f
->ts
.type
= i
->ts
.type
;
3196 f
->ts
.kind
= gfc_kind_max (i
, j
);
3198 if (i
->ts
.kind
!= j
->ts
.kind
)
3200 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
3201 gfc_convert_type (j
, &i
->ts
, 2);
3203 gfc_convert_type (i
, &j
->ts
, 2);
3206 f
->value
.function
.name
3207 = gfc_get_string ("__xor_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
3211 /* Intrinsic subroutine resolution. */
3214 gfc_resolve_alarm_sub (gfc_code
*c
)
3217 gfc_expr
*seconds
, *handler
;
3221 seconds
= c
->ext
.actual
->expr
;
3222 handler
= c
->ext
.actual
->next
->expr
;
3223 ts
.type
= BT_INTEGER
;
3224 ts
.kind
= gfc_c_int_kind
;
3226 /* handler can be either BT_INTEGER or BT_PROCEDURE.
3227 In all cases, the status argument is of default integer kind
3228 (enforced in check.c) so that the function suffix is fixed. */
3229 if (handler
->ts
.type
== BT_INTEGER
)
3231 if (handler
->ts
.kind
!= gfc_c_int_kind
)
3232 gfc_convert_type (handler
, &ts
, 2);
3233 name
= gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
3234 gfc_default_integer_kind
);
3237 name
= gfc_get_string (PREFIX ("alarm_sub_i%d"),
3238 gfc_default_integer_kind
);
3240 if (seconds
->ts
.kind
!= gfc_c_int_kind
)
3241 gfc_convert_type (seconds
, &ts
, 2);
3243 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3247 gfc_resolve_cpu_time (gfc_code
*c
)
3250 name
= gfc_get_string (PREFIX ("cpu_time_%d"), c
->ext
.actual
->expr
->ts
.kind
);
3251 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3255 /* Create a formal arglist based on an actual one and set the INTENTs given. */
3257 static gfc_formal_arglist
*
3258 create_formal_for_intents (gfc_actual_arglist
* actual
, const sym_intent
* ints
)
3260 gfc_formal_arglist
* head
;
3261 gfc_formal_arglist
* tail
;
3267 head
= tail
= gfc_get_formal_arglist ();
3268 for (i
= 0; actual
; actual
= actual
->next
, tail
= tail
->next
, ++i
)
3272 sym
= gfc_new_symbol ("dummyarg", NULL
);
3273 sym
->ts
= actual
->expr
->ts
;
3275 sym
->attr
.intent
= ints
[i
];
3279 tail
->next
= gfc_get_formal_arglist ();
3287 gfc_resolve_atomic_def (gfc_code
*c
)
3289 const char *name
= "atomic_define";
3290 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3295 gfc_resolve_atomic_ref (gfc_code
*c
)
3297 const char *name
= "atomic_ref";
3298 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3302 gfc_resolve_event_query (gfc_code
*c
)
3304 const char *name
= "event_query";
3305 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3309 gfc_resolve_mvbits (gfc_code
*c
)
3311 static const sym_intent INTENTS
[] = {INTENT_IN
, INTENT_IN
, INTENT_IN
,
3312 INTENT_INOUT
, INTENT_IN
};
3318 /* FROMPOS, LEN and TOPOS are restricted to small values. As such,
3319 they will be converted so that they fit into a C int. */
3320 ts
.type
= BT_INTEGER
;
3321 ts
.kind
= gfc_c_int_kind
;
3322 if (c
->ext
.actual
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
3323 gfc_convert_type (c
->ext
.actual
->next
->expr
, &ts
, 2);
3324 if (c
->ext
.actual
->next
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
3325 gfc_convert_type (c
->ext
.actual
->next
->next
->expr
, &ts
, 2);
3326 if (c
->ext
.actual
->next
->next
->next
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
3327 gfc_convert_type (c
->ext
.actual
->next
->next
->next
->next
->expr
, &ts
, 2);
3329 /* TO and FROM are guaranteed to have the same kind parameter. */
3330 name
= gfc_get_string (PREFIX ("mvbits_i%d"),
3331 c
->ext
.actual
->expr
->ts
.kind
);
3332 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3333 /* Mark as elemental subroutine as this does not happen automatically. */
3334 c
->resolved_sym
->attr
.elemental
= 1;
3336 /* Create a dummy formal arglist so the INTENTs are known later for purpose
3337 of creating temporaries. */
3338 c
->resolved_sym
->formal
= create_formal_for_intents (c
->ext
.actual
, INTENTS
);
3343 gfc_resolve_random_number (gfc_code
*c
)
3348 kind
= c
->ext
.actual
->expr
->ts
.kind
;
3349 if (c
->ext
.actual
->expr
->rank
== 0)
3350 name
= gfc_get_string (PREFIX ("random_r%d"), kind
);
3352 name
= gfc_get_string (PREFIX ("arandom_r%d"), kind
);
3354 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3359 gfc_resolve_random_seed (gfc_code
*c
)
3363 name
= gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind
);
3364 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3369 gfc_resolve_rename_sub (gfc_code
*c
)
3374 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3375 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3377 kind
= gfc_default_integer_kind
;
3379 name
= gfc_get_string (PREFIX ("rename_i%d_sub"), kind
);
3380 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3385 gfc_resolve_kill_sub (gfc_code
*c
)
3390 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3391 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3393 kind
= gfc_default_integer_kind
;
3395 name
= gfc_get_string (PREFIX ("kill_i%d_sub"), kind
);
3396 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3401 gfc_resolve_link_sub (gfc_code
*c
)
3406 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3407 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3409 kind
= gfc_default_integer_kind
;
3411 name
= gfc_get_string (PREFIX ("link_i%d_sub"), kind
);
3412 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3417 gfc_resolve_symlnk_sub (gfc_code
*c
)
3422 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3423 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3425 kind
= gfc_default_integer_kind
;
3427 name
= gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind
);
3428 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3432 /* G77 compatibility subroutines dtime() and etime(). */
3435 gfc_resolve_dtime_sub (gfc_code
*c
)
3438 name
= gfc_get_string (PREFIX ("dtime_sub"));
3439 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3443 gfc_resolve_etime_sub (gfc_code
*c
)
3446 name
= gfc_get_string (PREFIX ("etime_sub"));
3447 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3451 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
3454 gfc_resolve_itime (gfc_code
*c
)
3457 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
3458 gfc_default_integer_kind
));
3462 gfc_resolve_idate (gfc_code
*c
)
3465 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
3466 gfc_default_integer_kind
));
3470 gfc_resolve_ltime (gfc_code
*c
)
3473 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
3474 gfc_default_integer_kind
));
3478 gfc_resolve_gmtime (gfc_code
*c
)
3481 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
3482 gfc_default_integer_kind
));
3486 /* G77 compatibility subroutine second(). */
3489 gfc_resolve_second_sub (gfc_code
*c
)
3492 name
= gfc_get_string (PREFIX ("second_sub"));
3493 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3498 gfc_resolve_sleep_sub (gfc_code
*c
)
3503 if (c
->ext
.actual
->expr
!= NULL
)
3504 kind
= c
->ext
.actual
->expr
->ts
.kind
;
3506 kind
= gfc_default_integer_kind
;
3508 name
= gfc_get_string (PREFIX ("sleep_i%d_sub"), kind
);
3509 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3513 /* G77 compatibility function srand(). */
3516 gfc_resolve_srand (gfc_code
*c
)
3519 name
= gfc_get_string (PREFIX ("srand"));
3520 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3524 /* Resolve the getarg intrinsic subroutine. */
3527 gfc_resolve_getarg (gfc_code
*c
)
3531 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_default_integer_kind
)
3536 ts
.type
= BT_INTEGER
;
3537 ts
.kind
= gfc_default_integer_kind
;
3539 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3542 name
= gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind
);
3543 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3547 /* Resolve the getcwd intrinsic subroutine. */
3550 gfc_resolve_getcwd_sub (gfc_code
*c
)
3555 if (c
->ext
.actual
->next
->expr
!= NULL
)
3556 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3558 kind
= gfc_default_integer_kind
;
3560 name
= gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind
);
3561 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3565 /* Resolve the get_command intrinsic subroutine. */
3568 gfc_resolve_get_command (gfc_code
*c
)
3572 kind
= gfc_default_integer_kind
;
3573 name
= gfc_get_string (PREFIX ("get_command_i%d"), kind
);
3574 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3578 /* Resolve the get_command_argument intrinsic subroutine. */
3581 gfc_resolve_get_command_argument (gfc_code
*c
)
3585 kind
= gfc_default_integer_kind
;
3586 name
= gfc_get_string (PREFIX ("get_command_argument_i%d"), kind
);
3587 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3591 /* Resolve the get_environment_variable intrinsic subroutine. */
3594 gfc_resolve_get_environment_variable (gfc_code
*code
)
3598 kind
= gfc_default_integer_kind
;
3599 name
= gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind
);
3600 code
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3605 gfc_resolve_signal_sub (gfc_code
*c
)
3608 gfc_expr
*number
, *handler
, *status
;
3612 number
= c
->ext
.actual
->expr
;
3613 handler
= c
->ext
.actual
->next
->expr
;
3614 status
= c
->ext
.actual
->next
->next
->expr
;
3615 ts
.type
= BT_INTEGER
;
3616 ts
.kind
= gfc_c_int_kind
;
3618 /* handler can be either BT_INTEGER or BT_PROCEDURE */
3619 if (handler
->ts
.type
== BT_INTEGER
)
3621 if (handler
->ts
.kind
!= gfc_c_int_kind
)
3622 gfc_convert_type (handler
, &ts
, 2);
3623 name
= gfc_get_string (PREFIX ("signal_sub_int"));
3626 name
= gfc_get_string (PREFIX ("signal_sub"));
3628 if (number
->ts
.kind
!= gfc_c_int_kind
)
3629 gfc_convert_type (number
, &ts
, 2);
3630 if (status
!= NULL
&& status
->ts
.kind
!= gfc_c_int_kind
)
3631 gfc_convert_type (status
, &ts
, 2);
3633 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3637 /* Resolve the SYSTEM intrinsic subroutine. */
3640 gfc_resolve_system_sub (gfc_code
*c
)
3643 name
= gfc_get_string (PREFIX ("system_sub"));
3644 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3648 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
3651 gfc_resolve_system_clock (gfc_code
*c
)
3655 gfc_expr
*count
= c
->ext
.actual
->expr
;
3656 gfc_expr
*count_max
= c
->ext
.actual
->next
->next
->expr
;
3658 /* The INTEGER(8) version has higher precision, it is used if both COUNT
3659 and COUNT_MAX can hold 64-bit values, or are absent. */
3660 if ((!count
|| count
->ts
.kind
>= 8)
3661 && (!count_max
|| count_max
->ts
.kind
>= 8))
3664 kind
= gfc_default_integer_kind
;
3666 name
= gfc_get_string (PREFIX ("system_clock_%d"), kind
);
3667 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3671 /* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine. */
3673 gfc_resolve_execute_command_line (gfc_code
*c
)
3676 name
= gfc_get_string (PREFIX ("execute_command_line_i%d"),
3677 gfc_default_integer_kind
);
3678 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3682 /* Resolve the EXIT intrinsic subroutine. */
3685 gfc_resolve_exit (gfc_code
*c
)
3692 /* The STATUS argument has to be of default kind. If it is not,
3694 ts
.type
= BT_INTEGER
;
3695 ts
.kind
= gfc_default_integer_kind
;
3696 n
= c
->ext
.actual
->expr
;
3697 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3698 gfc_convert_type (n
, &ts
, 2);
3700 name
= gfc_get_string (PREFIX ("exit_i%d"), ts
.kind
);
3701 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3705 /* Resolve the FLUSH intrinsic subroutine. */
3708 gfc_resolve_flush (gfc_code
*c
)
3715 ts
.type
= BT_INTEGER
;
3716 ts
.kind
= gfc_default_integer_kind
;
3717 n
= c
->ext
.actual
->expr
;
3718 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3719 gfc_convert_type (n
, &ts
, 2);
3721 name
= gfc_get_string (PREFIX ("flush_i%d"), ts
.kind
);
3722 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3727 gfc_resolve_ctime_sub (gfc_code
*c
)
3732 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3733 if (c
->ext
.actual
->expr
->ts
.kind
!= 8)
3735 ts
.type
= BT_INTEGER
;
3737 ts
.u
.derived
= NULL
;
3739 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3742 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3747 gfc_resolve_fdate_sub (gfc_code
*c
)
3749 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3754 gfc_resolve_gerror (gfc_code
*c
)
3756 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3761 gfc_resolve_getlog (gfc_code
*c
)
3763 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3768 gfc_resolve_hostnm_sub (gfc_code
*c
)
3773 if (c
->ext
.actual
->next
->expr
!= NULL
)
3774 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3776 kind
= gfc_default_integer_kind
;
3778 name
= gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind
);
3779 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3784 gfc_resolve_perror (gfc_code
*c
)
3786 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3789 /* Resolve the STAT and FSTAT intrinsic subroutines. */
3792 gfc_resolve_stat_sub (gfc_code
*c
)
3795 name
= gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind
);
3796 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3801 gfc_resolve_lstat_sub (gfc_code
*c
)
3804 name
= gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind
);
3805 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3810 gfc_resolve_fstat_sub (gfc_code
*c
)
3816 u
= c
->ext
.actual
->expr
;
3817 ts
= &c
->ext
.actual
->next
->expr
->ts
;
3818 if (u
->ts
.kind
!= ts
->kind
)
3819 gfc_convert_type (u
, ts
, 2);
3820 name
= gfc_get_string (PREFIX ("fstat_i%d_sub"), ts
->kind
);
3821 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3826 gfc_resolve_fgetc_sub (gfc_code
*c
)
3833 u
= c
->ext
.actual
->expr
;
3834 st
= c
->ext
.actual
->next
->next
->expr
;
3836 if (u
->ts
.kind
!= gfc_c_int_kind
)
3838 ts
.type
= BT_INTEGER
;
3839 ts
.kind
= gfc_c_int_kind
;
3840 ts
.u
.derived
= NULL
;
3842 gfc_convert_type (u
, &ts
, 2);
3846 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), st
->ts
.kind
);
3848 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind
);
3850 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3855 gfc_resolve_fget_sub (gfc_code
*c
)
3860 st
= c
->ext
.actual
->next
->expr
;
3862 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), st
->ts
.kind
);
3864 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind
);
3866 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3871 gfc_resolve_fputc_sub (gfc_code
*c
)
3878 u
= c
->ext
.actual
->expr
;
3879 st
= c
->ext
.actual
->next
->next
->expr
;
3881 if (u
->ts
.kind
!= gfc_c_int_kind
)
3883 ts
.type
= BT_INTEGER
;
3884 ts
.kind
= gfc_c_int_kind
;
3885 ts
.u
.derived
= NULL
;
3887 gfc_convert_type (u
, &ts
, 2);
3891 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), st
->ts
.kind
);
3893 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind
);
3895 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3900 gfc_resolve_fput_sub (gfc_code
*c
)
3905 st
= c
->ext
.actual
->next
->expr
;
3907 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), st
->ts
.kind
);
3909 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind
);
3911 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3916 gfc_resolve_fseek_sub (gfc_code
*c
)
3924 unit
= c
->ext
.actual
->expr
;
3925 offset
= c
->ext
.actual
->next
->expr
;
3926 whence
= c
->ext
.actual
->next
->next
->expr
;
3928 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3930 ts
.type
= BT_INTEGER
;
3931 ts
.kind
= gfc_c_int_kind
;
3932 ts
.u
.derived
= NULL
;
3934 gfc_convert_type (unit
, &ts
, 2);
3937 if (offset
->ts
.kind
!= gfc_intio_kind
)
3939 ts
.type
= BT_INTEGER
;
3940 ts
.kind
= gfc_intio_kind
;
3941 ts
.u
.derived
= NULL
;
3943 gfc_convert_type (offset
, &ts
, 2);
3946 if (whence
->ts
.kind
!= gfc_c_int_kind
)
3948 ts
.type
= BT_INTEGER
;
3949 ts
.kind
= gfc_c_int_kind
;
3950 ts
.u
.derived
= NULL
;
3952 gfc_convert_type (whence
, &ts
, 2);
3955 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
3959 gfc_resolve_ftell_sub (gfc_code
*c
)
3967 unit
= c
->ext
.actual
->expr
;
3968 offset
= c
->ext
.actual
->next
->expr
;
3970 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3972 ts
.type
= BT_INTEGER
;
3973 ts
.kind
= gfc_c_int_kind
;
3974 ts
.u
.derived
= NULL
;
3976 gfc_convert_type (unit
, &ts
, 2);
3979 name
= gfc_get_string (PREFIX ("ftell_i%d_sub"), offset
->ts
.kind
);
3980 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3985 gfc_resolve_ttynam_sub (gfc_code
*c
)
3990 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
3992 ts
.type
= BT_INTEGER
;
3993 ts
.kind
= gfc_c_int_kind
;
3994 ts
.u
.derived
= NULL
;
3996 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3999 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
4003 /* Resolve the UMASK intrinsic subroutine. */
4006 gfc_resolve_umask_sub (gfc_code
*c
)
4011 if (c
->ext
.actual
->next
->expr
!= NULL
)
4012 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
4014 kind
= gfc_default_integer_kind
;
4016 name
= gfc_get_string (PREFIX ("umask_i%d_sub"), kind
);
4017 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
4020 /* Resolve the UNLINK intrinsic subroutine. */
4023 gfc_resolve_unlink_sub (gfc_code
*c
)
4028 if (c
->ext
.actual
->next
->expr
!= NULL
)
4029 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
4031 kind
= gfc_default_integer_kind
;
4033 name
= gfc_get_string (PREFIX ("unlink_i%d_sub"), kind
);
4034 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);