1 /* Intrinsic function resolution.
2 Copyright (C) 2000-2018 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_charlen_int_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_charlen_int_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_charlen_int_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_lbound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
1497 resolve_bound (f
, array
, dim
, kind
, "__lbound", false);
1502 gfc_resolve_lcobound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
1504 resolve_bound (f
, array
, dim
, kind
, "__lcobound", true);
1509 gfc_resolve_len (gfc_expr
*f
, gfc_expr
*string
, gfc_expr
*kind
)
1511 f
->ts
.type
= BT_INTEGER
;
1513 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1515 f
->ts
.kind
= gfc_default_integer_kind
;
1516 f
->value
.function
.name
1517 = gfc_get_string ("__len_%d_i%d", string
->ts
.kind
,
1518 gfc_default_integer_kind
);
1523 gfc_resolve_len_trim (gfc_expr
*f
, gfc_expr
*string
, gfc_expr
*kind
)
1525 f
->ts
.type
= BT_INTEGER
;
1527 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1529 f
->ts
.kind
= gfc_default_integer_kind
;
1530 f
->value
.function
.name
= gfc_get_string ("__len_trim%d", string
->ts
.kind
);
1535 gfc_resolve_lgamma (gfc_expr
*f
, gfc_expr
*x
)
1538 f
->value
.function
.name
1539 = gfc_get_string ("__lgamma_%d", x
->ts
.kind
);
1544 gfc_resolve_link (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
1545 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
1547 f
->ts
.type
= BT_INTEGER
;
1548 f
->ts
.kind
= gfc_default_integer_kind
;
1549 f
->value
.function
.name
= gfc_get_string (PREFIX ("link_i%d"), f
->ts
.kind
);
1554 gfc_resolve_loc (gfc_expr
*f
, gfc_expr
*x
)
1556 f
->ts
.type
= BT_INTEGER
;
1557 f
->ts
.kind
= gfc_index_integer_kind
;
1558 f
->value
.function
.name
= gfc_get_string ("__loc_%d", x
->ts
.kind
);
1563 gfc_resolve_log (gfc_expr
*f
, gfc_expr
*x
)
1566 f
->value
.function
.name
1567 = gfc_get_string ("__log_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1572 gfc_resolve_log10 (gfc_expr
*f
, gfc_expr
*x
)
1575 f
->value
.function
.name
1576 = gfc_get_string ("__log10_%c%d", gfc_type_letter (x
->ts
.type
),
1582 gfc_resolve_logical (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1584 f
->ts
.type
= BT_LOGICAL
;
1585 f
->ts
.kind
= (kind
== NULL
)
1586 ? gfc_default_logical_kind
: mpz_get_si (kind
->value
.integer
);
1589 f
->value
.function
.name
1590 = gfc_get_string ("__logical_%d_%c%d", f
->ts
.kind
,
1591 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1596 gfc_resolve_matmul (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b
)
1600 if (a
->ts
.type
== BT_LOGICAL
&& b
->ts
.type
== BT_LOGICAL
)
1602 f
->ts
.type
= BT_LOGICAL
;
1603 f
->ts
.kind
= gfc_default_logical_kind
;
1607 temp
.expr_type
= EXPR_OP
;
1608 gfc_clear_ts (&temp
.ts
);
1609 temp
.value
.op
.op
= INTRINSIC_NONE
;
1610 temp
.value
.op
.op1
= a
;
1611 temp
.value
.op
.op2
= b
;
1612 gfc_type_convert_binary (&temp
, 1);
1616 f
->rank
= (a
->rank
== 2 && b
->rank
== 2) ? 2 : 1;
1618 if (a
->rank
== 2 && b
->rank
== 2)
1620 if (a
->shape
&& b
->shape
)
1622 f
->shape
= gfc_get_shape (f
->rank
);
1623 mpz_init_set (f
->shape
[0], a
->shape
[0]);
1624 mpz_init_set (f
->shape
[1], b
->shape
[1]);
1627 else if (a
->rank
== 1)
1631 f
->shape
= gfc_get_shape (f
->rank
);
1632 mpz_init_set (f
->shape
[0], b
->shape
[1]);
1637 /* b->rank == 1 and a->rank == 2 here, all other cases have
1638 been caught in check.c. */
1641 f
->shape
= gfc_get_shape (f
->rank
);
1642 mpz_init_set (f
->shape
[0], a
->shape
[0]);
1646 f
->value
.function
.name
1647 = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f
->ts
.type
),
1653 gfc_resolve_minmax (const char *name
, gfc_expr
*f
, gfc_actual_arglist
*args
)
1655 gfc_actual_arglist
*a
;
1657 f
->ts
.type
= args
->expr
->ts
.type
;
1658 f
->ts
.kind
= args
->expr
->ts
.kind
;
1659 /* Find the largest type kind. */
1660 for (a
= args
->next
; a
; a
= a
->next
)
1662 if (a
->expr
->ts
.kind
> f
->ts
.kind
)
1663 f
->ts
.kind
= a
->expr
->ts
.kind
;
1666 /* Convert all parameters to the required kind. */
1667 for (a
= args
; a
; a
= a
->next
)
1669 if (a
->expr
->ts
.kind
!= f
->ts
.kind
)
1670 gfc_convert_type (a
->expr
, &f
->ts
, 2);
1673 f
->value
.function
.name
1674 = gfc_get_string (name
, gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
1679 gfc_resolve_max (gfc_expr
*f
, gfc_actual_arglist
*args
)
1681 gfc_resolve_minmax ("__max_%c%d", f
, args
);
1684 /* The smallest kind for which a minloc and maxloc implementation exists. */
1686 #define MINMAXLOC_MIN_KIND 4
1689 gfc_resolve_maxloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1690 gfc_expr
*mask
, gfc_expr
*kind
, gfc_expr
*back
)
1697 f
->ts
.type
= BT_INTEGER
;
1699 /* The library versions only exist for kinds 4, 8 and 16. For smaller kinds,
1700 we do a type conversion further down. */
1702 fkind
= mpz_get_si (kind
->value
.integer
);
1704 fkind
= gfc_default_integer_kind
;
1706 if (fkind
< MINMAXLOC_MIN_KIND
)
1707 f
->ts
.kind
= MINMAXLOC_MIN_KIND
;
1714 f
->shape
= gfc_get_shape (1);
1715 mpz_init_set_si (f
->shape
[0], array
->rank
);
1719 f
->rank
= array
->rank
- 1;
1720 gfc_resolve_dim_arg (dim
);
1721 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1723 idim
= (int) mpz_get_si (dim
->value
.integer
);
1724 f
->shape
= gfc_get_shape (f
->rank
);
1725 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1727 if (i
== (idim
- 1))
1729 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1736 if (mask
->rank
== 0)
1741 resolve_mask_arg (mask
);
1748 if (array
->ts
.type
!= BT_CHARACTER
|| f
->rank
!= 0)
1756 f
->value
.function
.name
1757 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name
, d_num
, f
->ts
.kind
,
1758 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1761 fkind
= mpz_get_si (kind
->value
.integer
);
1763 fkind
= gfc_default_integer_kind
;
1765 if (fkind
!= f
->ts
.kind
)
1770 ts
.type
= BT_INTEGER
;
1772 gfc_convert_type_warn (f
, &ts
, 2, 0);
1775 if (back
->ts
.kind
!= gfc_logical_4_kind
)
1779 ts
.type
= BT_LOGICAL
;
1780 ts
.kind
= gfc_logical_4_kind
;
1781 gfc_convert_type_warn (back
, &ts
, 2, 0);
1787 gfc_resolve_maxval (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1797 f
->rank
= array
->rank
- 1;
1798 gfc_resolve_dim_arg (dim
);
1800 if (f
->rank
&& array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1802 idim
= (int) mpz_get_si (dim
->value
.integer
);
1803 f
->shape
= gfc_get_shape (f
->rank
);
1804 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1806 if (i
== (idim
- 1))
1808 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1815 if (mask
->rank
== 0)
1820 resolve_mask_arg (mask
);
1825 if (array
->ts
.type
!= BT_CHARACTER
)
1826 f
->value
.function
.name
1827 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
1828 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1830 f
->value
.function
.name
1831 = gfc_get_string (PREFIX ("%s%d_%c%d"), name
, f
->rank
!= 0,
1832 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1837 gfc_resolve_mclock (gfc_expr
*f
)
1839 f
->ts
.type
= BT_INTEGER
;
1841 f
->value
.function
.name
= PREFIX ("mclock");
1846 gfc_resolve_mclock8 (gfc_expr
*f
)
1848 f
->ts
.type
= BT_INTEGER
;
1850 f
->value
.function
.name
= PREFIX ("mclock8");
1855 gfc_resolve_mask (gfc_expr
*f
, gfc_expr
*i ATTRIBUTE_UNUSED
,
1858 f
->ts
.type
= BT_INTEGER
;
1859 f
->ts
.kind
= kind
? mpz_get_si (kind
->value
.integer
)
1860 : gfc_default_integer_kind
;
1862 if (f
->value
.function
.isym
->id
== GFC_ISYM_MASKL
)
1863 f
->value
.function
.name
= gfc_get_string ("__maskl_i%d", f
->ts
.kind
);
1865 f
->value
.function
.name
= gfc_get_string ("__maskr_i%d", f
->ts
.kind
);
1870 gfc_resolve_merge (gfc_expr
*f
, gfc_expr
*tsource
,
1871 gfc_expr
*fsource ATTRIBUTE_UNUSED
,
1872 gfc_expr
*mask ATTRIBUTE_UNUSED
)
1874 if (tsource
->ts
.type
== BT_CHARACTER
&& tsource
->ref
)
1875 gfc_resolve_substring_charlen (tsource
);
1877 if (fsource
->ts
.type
== BT_CHARACTER
&& fsource
->ref
)
1878 gfc_resolve_substring_charlen (fsource
);
1880 if (tsource
->ts
.type
== BT_CHARACTER
)
1881 check_charlen_present (tsource
);
1883 f
->ts
= tsource
->ts
;
1884 f
->value
.function
.name
1885 = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource
->ts
.type
),
1891 gfc_resolve_merge_bits (gfc_expr
*f
, gfc_expr
*i
,
1892 gfc_expr
*j ATTRIBUTE_UNUSED
,
1893 gfc_expr
*mask ATTRIBUTE_UNUSED
)
1896 f
->value
.function
.name
= gfc_get_string ("__merge_bits_i%d", i
->ts
.kind
);
1901 gfc_resolve_min (gfc_expr
*f
, gfc_actual_arglist
*args
)
1903 gfc_resolve_minmax ("__min_%c%d", f
, args
);
1908 gfc_resolve_minloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1909 gfc_expr
*mask
, gfc_expr
*kind
, gfc_expr
*back
)
1916 f
->ts
.type
= BT_INTEGER
;
1918 /* The library versions only exist for kinds 4, 8 and 16. For smaller kinds,
1919 we do a type conversion further down. */
1921 fkind
= mpz_get_si (kind
->value
.integer
);
1923 fkind
= gfc_default_integer_kind
;
1925 if (fkind
< MINMAXLOC_MIN_KIND
)
1926 f
->ts
.kind
= MINMAXLOC_MIN_KIND
;
1933 f
->shape
= gfc_get_shape (1);
1934 mpz_init_set_si (f
->shape
[0], array
->rank
);
1938 f
->rank
= array
->rank
- 1;
1939 gfc_resolve_dim_arg (dim
);
1940 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1942 idim
= (int) mpz_get_si (dim
->value
.integer
);
1943 f
->shape
= gfc_get_shape (f
->rank
);
1944 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1946 if (i
== (idim
- 1))
1948 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1955 if (mask
->rank
== 0)
1960 resolve_mask_arg (mask
);
1967 if (array
->ts
.type
!= BT_CHARACTER
|| f
->rank
!= 0)
1975 f
->value
.function
.name
1976 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name
, d_num
, f
->ts
.kind
,
1977 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1979 if (fkind
!= f
->ts
.kind
)
1984 ts
.type
= BT_INTEGER
;
1986 gfc_convert_type_warn (f
, &ts
, 2, 0);
1989 if (back
->ts
.kind
!= gfc_logical_4_kind
)
1993 ts
.type
= BT_LOGICAL
;
1994 ts
.kind
= gfc_logical_4_kind
;
1995 gfc_convert_type_warn (back
, &ts
, 2, 0);
2001 gfc_resolve_minval (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
2011 f
->rank
= array
->rank
- 1;
2012 gfc_resolve_dim_arg (dim
);
2014 if (f
->rank
&& array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
2016 idim
= (int) mpz_get_si (dim
->value
.integer
);
2017 f
->shape
= gfc_get_shape (f
->rank
);
2018 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
2020 if (i
== (idim
- 1))
2022 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
2029 if (mask
->rank
== 0)
2034 resolve_mask_arg (mask
);
2039 if (array
->ts
.type
!= BT_CHARACTER
)
2040 f
->value
.function
.name
2041 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
2042 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
2044 f
->value
.function
.name
2045 = gfc_get_string (PREFIX ("%s%d_%c%d"), name
, f
->rank
!= 0,
2046 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
2051 gfc_resolve_mod (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
2053 f
->ts
.type
= a
->ts
.type
;
2055 f
->ts
.kind
= gfc_kind_max (a
,p
);
2057 f
->ts
.kind
= a
->ts
.kind
;
2059 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
2061 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
2062 gfc_convert_type (p
, &a
->ts
, 2);
2064 gfc_convert_type (a
, &p
->ts
, 2);
2067 f
->value
.function
.name
2068 = gfc_get_string ("__mod_%c%d", gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
2073 gfc_resolve_modulo (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
2075 f
->ts
.type
= a
->ts
.type
;
2077 f
->ts
.kind
= gfc_kind_max (a
,p
);
2079 f
->ts
.kind
= a
->ts
.kind
;
2081 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
2083 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
2084 gfc_convert_type (p
, &a
->ts
, 2);
2086 gfc_convert_type (a
, &p
->ts
, 2);
2089 f
->value
.function
.name
2090 = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f
->ts
.type
),
2095 gfc_resolve_nearest (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
2097 if (p
->ts
.kind
!= a
->ts
.kind
)
2098 gfc_convert_type (p
, &a
->ts
, 2);
2101 f
->value
.function
.name
2102 = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a
->ts
.type
),
2107 gfc_resolve_nint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
2109 f
->ts
.type
= BT_INTEGER
;
2110 f
->ts
.kind
= (kind
== NULL
)
2111 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
2112 f
->value
.function
.name
2113 = gfc_get_string ("__nint_%d_%d", f
->ts
.kind
, a
->ts
.kind
);
2118 gfc_resolve_norm2 (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
)
2120 resolve_transformational ("norm2", f
, array
, dim
, NULL
);
2125 gfc_resolve_not (gfc_expr
*f
, gfc_expr
*i
)
2128 f
->value
.function
.name
= gfc_get_string ("__not_%d", i
->ts
.kind
);
2133 gfc_resolve_or (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
2135 f
->ts
.type
= i
->ts
.type
;
2136 f
->ts
.kind
= gfc_kind_max (i
, j
);
2138 if (i
->ts
.kind
!= j
->ts
.kind
)
2140 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
2141 gfc_convert_type (j
, &i
->ts
, 2);
2143 gfc_convert_type (i
, &j
->ts
, 2);
2146 f
->value
.function
.name
2147 = gfc_get_string ("__or_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
2152 gfc_resolve_pack (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*mask
,
2153 gfc_expr
*vector ATTRIBUTE_UNUSED
)
2155 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
2156 gfc_resolve_substring_charlen (array
);
2161 resolve_mask_arg (mask
);
2163 if (mask
->rank
!= 0)
2165 if (array
->ts
.type
== BT_CHARACTER
)
2166 f
->value
.function
.name
2167 = array
->ts
.kind
== 1 ? PREFIX ("pack_char")
2169 (PREFIX ("pack_char%d"),
2172 f
->value
.function
.name
= PREFIX ("pack");
2176 if (array
->ts
.type
== BT_CHARACTER
)
2177 f
->value
.function
.name
2178 = array
->ts
.kind
== 1 ? PREFIX ("pack_s_char")
2180 (PREFIX ("pack_s_char%d"),
2183 f
->value
.function
.name
= PREFIX ("pack_s");
2189 gfc_resolve_parity (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
)
2191 resolve_transformational ("parity", f
, array
, dim
, NULL
);
2196 gfc_resolve_product (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
2199 resolve_transformational ("product", f
, array
, dim
, mask
);
2204 gfc_resolve_rank (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
)
2206 f
->ts
.type
= BT_INTEGER
;
2207 f
->ts
.kind
= gfc_default_integer_kind
;
2208 f
->value
.function
.name
= gfc_get_string ("__rank");
2213 gfc_resolve_real (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
2215 f
->ts
.type
= BT_REAL
;
2218 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2220 f
->ts
.kind
= (a
->ts
.type
== BT_COMPLEX
)
2221 ? a
->ts
.kind
: gfc_default_real_kind
;
2223 f
->value
.function
.name
2224 = gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
2225 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2230 gfc_resolve_realpart (gfc_expr
*f
, gfc_expr
*a
)
2232 f
->ts
.type
= BT_REAL
;
2233 f
->ts
.kind
= a
->ts
.kind
;
2234 f
->value
.function
.name
2235 = gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
2236 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2241 gfc_resolve_rename (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
2242 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
2244 f
->ts
.type
= BT_INTEGER
;
2245 f
->ts
.kind
= gfc_default_integer_kind
;
2246 f
->value
.function
.name
= gfc_get_string (PREFIX ("rename_i%d"), f
->ts
.kind
);
2251 gfc_resolve_repeat (gfc_expr
*f
, gfc_expr
*string
,
2255 f
->ts
.type
= BT_CHARACTER
;
2256 f
->ts
.kind
= string
->ts
.kind
;
2257 f
->value
.function
.name
= gfc_get_string ("__repeat_%d", string
->ts
.kind
);
2259 /* If possible, generate a character length. */
2260 if (f
->ts
.u
.cl
== NULL
)
2261 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2264 if (string
->expr_type
== EXPR_CONSTANT
)
2266 tmp
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
2267 string
->value
.character
.length
);
2269 else if (string
->ts
.u
.cl
&& string
->ts
.u
.cl
->length
)
2271 tmp
= gfc_copy_expr (string
->ts
.u
.cl
->length
);
2275 f
->ts
.u
.cl
->length
= gfc_multiply (tmp
, gfc_copy_expr (ncopies
));
2280 gfc_resolve_reshape (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*shape
,
2281 gfc_expr
*pad ATTRIBUTE_UNUSED
,
2282 gfc_expr
*order ATTRIBUTE_UNUSED
)
2288 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
2289 gfc_resolve_substring_charlen (source
);
2293 gfc_array_size (shape
, &rank
);
2294 f
->rank
= mpz_get_si (rank
);
2296 switch (source
->ts
.type
)
2303 kind
= source
->ts
.kind
;
2317 if (source
->ts
.type
== BT_COMPLEX
|| source
->ts
.type
== BT_REAL
)
2318 f
->value
.function
.name
2319 = gfc_get_string (PREFIX ("reshape_%c%d"),
2320 gfc_type_letter (source
->ts
.type
),
2322 else if (source
->ts
.type
== BT_CHARACTER
)
2323 f
->value
.function
.name
= gfc_get_string (PREFIX ("reshape_char%d"),
2326 f
->value
.function
.name
2327 = gfc_get_string (PREFIX ("reshape_%d"), source
->ts
.kind
);
2331 f
->value
.function
.name
= (source
->ts
.type
== BT_CHARACTER
2332 ? PREFIX ("reshape_char") : PREFIX ("reshape"));
2336 if (shape
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (shape
))
2339 f
->shape
= gfc_get_shape (f
->rank
);
2340 c
= gfc_constructor_first (shape
->value
.constructor
);
2341 for (i
= 0; i
< f
->rank
; i
++)
2343 mpz_init_set (f
->shape
[i
], c
->expr
->value
.integer
);
2344 c
= gfc_constructor_next (c
);
2348 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
2349 so many runtime variations. */
2350 if (shape
->ts
.kind
!= gfc_index_integer_kind
)
2352 gfc_typespec ts
= shape
->ts
;
2353 ts
.kind
= gfc_index_integer_kind
;
2354 gfc_convert_type_warn (shape
, &ts
, 2, 0);
2356 if (order
&& order
->ts
.kind
!= gfc_index_integer_kind
)
2357 gfc_convert_type_warn (order
, &shape
->ts
, 2, 0);
2362 gfc_resolve_rrspacing (gfc_expr
*f
, gfc_expr
*x
)
2365 f
->value
.function
.name
= gfc_get_string ("__rrspacing_%d", x
->ts
.kind
);
2369 gfc_resolve_fe_runtime_error (gfc_code
*c
)
2372 gfc_actual_arglist
*a
;
2374 name
= gfc_get_string (PREFIX ("runtime_error"));
2376 for (a
= c
->ext
.actual
->next
; a
; a
= a
->next
)
2379 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2383 gfc_resolve_scale (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*i ATTRIBUTE_UNUSED
)
2386 f
->value
.function
.name
= gfc_get_string ("__scale_%d", x
->ts
.kind
);
2391 gfc_resolve_scan (gfc_expr
*f
, gfc_expr
*string
,
2392 gfc_expr
*set ATTRIBUTE_UNUSED
,
2393 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2395 f
->ts
.type
= BT_INTEGER
;
2397 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2399 f
->ts
.kind
= gfc_default_integer_kind
;
2400 f
->value
.function
.name
= gfc_get_string ("__scan_%d", string
->ts
.kind
);
2405 gfc_resolve_secnds (gfc_expr
*t1
, gfc_expr
*t0
)
2408 t1
->value
.function
.name
= gfc_get_string (PREFIX ("secnds"));
2413 gfc_resolve_set_exponent (gfc_expr
*f
, gfc_expr
*x
,
2414 gfc_expr
*i ATTRIBUTE_UNUSED
)
2417 f
->value
.function
.name
= gfc_get_string ("__set_exponent_%d", x
->ts
.kind
);
2422 gfc_resolve_shape (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*kind
)
2424 f
->ts
.type
= BT_INTEGER
;
2427 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2429 f
->ts
.kind
= gfc_default_integer_kind
;
2432 if (array
->rank
!= -1)
2434 f
->shape
= gfc_get_shape (1);
2435 mpz_init_set_ui (f
->shape
[0], array
->rank
);
2438 f
->value
.function
.name
= gfc_get_string (PREFIX ("shape_%d"), f
->ts
.kind
);
2443 gfc_resolve_shift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift ATTRIBUTE_UNUSED
)
2446 if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTA
)
2447 f
->value
.function
.name
= gfc_get_string ("shifta_i%d", f
->ts
.kind
);
2448 else if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTL
)
2449 f
->value
.function
.name
= gfc_get_string ("shiftl_i%d", f
->ts
.kind
);
2450 else if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTR
)
2451 f
->value
.function
.name
= gfc_get_string ("shiftr_i%d", f
->ts
.kind
);
2458 gfc_resolve_sign (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b ATTRIBUTE_UNUSED
)
2461 f
->value
.function
.name
2462 = gfc_get_string ("__sign_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2467 gfc_resolve_signal (gfc_expr
*f
, gfc_expr
*number
, gfc_expr
*handler
)
2469 f
->ts
.type
= BT_INTEGER
;
2470 f
->ts
.kind
= gfc_c_int_kind
;
2472 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2473 if (handler
->ts
.type
== BT_INTEGER
)
2475 if (handler
->ts
.kind
!= gfc_c_int_kind
)
2476 gfc_convert_type (handler
, &f
->ts
, 2);
2477 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func_int"));
2480 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func"));
2482 if (number
->ts
.kind
!= gfc_c_int_kind
)
2483 gfc_convert_type (number
, &f
->ts
, 2);
2488 gfc_resolve_sin (gfc_expr
*f
, gfc_expr
*x
)
2491 f
->value
.function
.name
2492 = gfc_get_string ("__sin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2497 gfc_resolve_sinh (gfc_expr
*f
, gfc_expr
*x
)
2500 f
->value
.function
.name
2501 = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2506 gfc_resolve_size (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2507 gfc_expr
*dim ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2509 f
->ts
.type
= BT_INTEGER
;
2511 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2513 f
->ts
.kind
= gfc_default_integer_kind
;
2518 gfc_resolve_stride (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2519 gfc_expr
*dim ATTRIBUTE_UNUSED
)
2521 f
->ts
.type
= BT_INTEGER
;
2522 f
->ts
.kind
= gfc_index_integer_kind
;
2527 gfc_resolve_spacing (gfc_expr
*f
, gfc_expr
*x
)
2530 f
->value
.function
.name
= gfc_get_string ("__spacing_%d", x
->ts
.kind
);
2535 gfc_resolve_spread (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*dim
,
2538 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
2539 gfc_resolve_substring_charlen (source
);
2541 if (source
->ts
.type
== BT_CHARACTER
)
2542 check_charlen_present (source
);
2545 f
->rank
= source
->rank
+ 1;
2546 if (source
->rank
== 0)
2548 if (source
->ts
.type
== BT_CHARACTER
)
2549 f
->value
.function
.name
2550 = source
->ts
.kind
== 1 ? PREFIX ("spread_char_scalar")
2552 (PREFIX ("spread_char%d_scalar"),
2555 f
->value
.function
.name
= PREFIX ("spread_scalar");
2559 if (source
->ts
.type
== BT_CHARACTER
)
2560 f
->value
.function
.name
2561 = source
->ts
.kind
== 1 ? PREFIX ("spread_char")
2563 (PREFIX ("spread_char%d"),
2566 f
->value
.function
.name
= PREFIX ("spread");
2569 if (dim
&& gfc_is_constant_expr (dim
)
2570 && ncopies
&& gfc_is_constant_expr (ncopies
) && source
->shape
[0])
2573 idim
= mpz_get_ui (dim
->value
.integer
);
2574 f
->shape
= gfc_get_shape (f
->rank
);
2575 for (i
= 0; i
< (idim
- 1); i
++)
2576 mpz_init_set (f
->shape
[i
], source
->shape
[i
]);
2578 mpz_init_set (f
->shape
[idim
- 1], ncopies
->value
.integer
);
2580 for (i
= idim
; i
< f
->rank
; i
++)
2581 mpz_init_set (f
->shape
[i
], source
->shape
[i
-1]);
2585 gfc_resolve_dim_arg (dim
);
2586 gfc_resolve_index (ncopies
, 1);
2591 gfc_resolve_sqrt (gfc_expr
*f
, gfc_expr
*x
)
2594 f
->value
.function
.name
2595 = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2599 /* Resolve the g77 compatibility function STAT AND FSTAT. */
2602 gfc_resolve_stat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2603 gfc_expr
*a ATTRIBUTE_UNUSED
)
2605 f
->ts
.type
= BT_INTEGER
;
2606 f
->ts
.kind
= gfc_default_integer_kind
;
2607 f
->value
.function
.name
= gfc_get_string (PREFIX ("stat_i%d"), f
->ts
.kind
);
2612 gfc_resolve_lstat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2613 gfc_expr
*a ATTRIBUTE_UNUSED
)
2615 f
->ts
.type
= BT_INTEGER
;
2616 f
->ts
.kind
= gfc_default_integer_kind
;
2617 f
->value
.function
.name
= gfc_get_string (PREFIX ("lstat_i%d"), f
->ts
.kind
);
2622 gfc_resolve_fstat (gfc_expr
*f
, gfc_expr
*n
, gfc_expr
*a ATTRIBUTE_UNUSED
)
2624 f
->ts
.type
= BT_INTEGER
;
2625 f
->ts
.kind
= gfc_default_integer_kind
;
2626 if (n
->ts
.kind
!= f
->ts
.kind
)
2627 gfc_convert_type (n
, &f
->ts
, 2);
2629 f
->value
.function
.name
= gfc_get_string (PREFIX ("fstat_i%d"), f
->ts
.kind
);
2634 gfc_resolve_fgetc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2639 f
->ts
.type
= BT_INTEGER
;
2640 f
->ts
.kind
= gfc_c_int_kind
;
2641 if (u
->ts
.kind
!= gfc_c_int_kind
)
2643 ts
.type
= BT_INTEGER
;
2644 ts
.kind
= gfc_c_int_kind
;
2645 ts
.u
.derived
= NULL
;
2647 gfc_convert_type (u
, &ts
, 2);
2650 f
->value
.function
.name
= gfc_get_string (PREFIX ("fgetc"));
2655 gfc_resolve_fget (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2657 f
->ts
.type
= BT_INTEGER
;
2658 f
->ts
.kind
= gfc_c_int_kind
;
2659 f
->value
.function
.name
= gfc_get_string (PREFIX ("fget"));
2664 gfc_resolve_fputc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2669 f
->ts
.type
= BT_INTEGER
;
2670 f
->ts
.kind
= gfc_c_int_kind
;
2671 if (u
->ts
.kind
!= gfc_c_int_kind
)
2673 ts
.type
= BT_INTEGER
;
2674 ts
.kind
= gfc_c_int_kind
;
2675 ts
.u
.derived
= NULL
;
2677 gfc_convert_type (u
, &ts
, 2);
2680 f
->value
.function
.name
= gfc_get_string (PREFIX ("fputc"));
2685 gfc_resolve_fput (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2687 f
->ts
.type
= BT_INTEGER
;
2688 f
->ts
.kind
= gfc_c_int_kind
;
2689 f
->value
.function
.name
= gfc_get_string (PREFIX ("fput"));
2694 gfc_resolve_ftell (gfc_expr
*f
, gfc_expr
*u
)
2699 f
->ts
.type
= BT_INTEGER
;
2700 f
->ts
.kind
= gfc_intio_kind
;
2701 if (u
->ts
.kind
!= gfc_c_int_kind
)
2703 ts
.type
= BT_INTEGER
;
2704 ts
.kind
= gfc_c_int_kind
;
2705 ts
.u
.derived
= NULL
;
2707 gfc_convert_type (u
, &ts
, 2);
2710 f
->value
.function
.name
= gfc_get_string (PREFIX ("ftell"));
2715 gfc_resolve_storage_size (gfc_expr
*f
, gfc_expr
*a ATTRIBUTE_UNUSED
,
2718 f
->ts
.type
= BT_INTEGER
;
2720 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2722 f
->ts
.kind
= gfc_default_integer_kind
;
2727 gfc_resolve_sum (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2729 resolve_transformational ("sum", f
, array
, dim
, mask
);
2734 gfc_resolve_symlnk (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
2735 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
2737 f
->ts
.type
= BT_INTEGER
;
2738 f
->ts
.kind
= gfc_default_integer_kind
;
2739 f
->value
.function
.name
= gfc_get_string (PREFIX ("symlnk_i%d"), f
->ts
.kind
);
2743 /* Resolve the g77 compatibility function SYSTEM. */
2746 gfc_resolve_system (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
2748 f
->ts
.type
= BT_INTEGER
;
2750 f
->value
.function
.name
= gfc_get_string (PREFIX ("system"));
2755 gfc_resolve_tan (gfc_expr
*f
, gfc_expr
*x
)
2758 f
->value
.function
.name
2759 = gfc_get_string ("__tan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2764 gfc_resolve_tanh (gfc_expr
*f
, gfc_expr
*x
)
2767 f
->value
.function
.name
2768 = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2772 /* Build an expression for converting degrees to radians. */
2775 get_radians (gfc_expr
*deg
)
2777 gfc_expr
*result
, *factor
;
2778 gfc_actual_arglist
*mod_args
;
2780 gcc_assert (deg
->ts
.type
== BT_REAL
);
2782 /* Set deg = deg % 360 to avoid offsets from large angles. */
2783 factor
= gfc_get_constant_expr (deg
->ts
.type
, deg
->ts
.kind
, °
->where
);
2784 mpfr_set_d (factor
->value
.real
, 360.0, GFC_RND_MODE
);
2786 mod_args
= gfc_get_actual_arglist ();
2787 mod_args
->expr
= deg
;
2788 mod_args
->next
= gfc_get_actual_arglist ();
2789 mod_args
->next
->expr
= factor
;
2791 result
= gfc_get_expr ();
2792 result
->ts
= deg
->ts
;
2793 result
->where
= deg
->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 = pi / 180. */
2799 factor
= gfc_get_constant_expr (deg
->ts
.type
, deg
->ts
.kind
, °
->where
);
2800 mpfr_const_pi (factor
->value
.real
, GFC_RND_MODE
);
2801 mpfr_div_ui (factor
->value
.real
, factor
->value
.real
, 180, GFC_RND_MODE
);
2803 /* Result is rad = (deg % 360) * (pi / 180). */
2804 result
= gfc_multiply (result
, factor
);
2809 /* Build an expression for converting radians to degrees. */
2812 get_degrees (gfc_expr
*rad
)
2814 gfc_expr
*result
, *factor
;
2815 gfc_actual_arglist
*mod_args
;
2818 gcc_assert (rad
->ts
.type
== BT_REAL
);
2820 /* Set rad = rad % 2pi to avoid offsets from large angles. */
2821 factor
= gfc_get_constant_expr (rad
->ts
.type
, rad
->ts
.kind
, &rad
->where
);
2822 mpfr_const_pi (factor
->value
.real
, GFC_RND_MODE
);
2823 mpfr_mul_ui (factor
->value
.real
, factor
->value
.real
, 2, GFC_RND_MODE
);
2825 mod_args
= gfc_get_actual_arglist ();
2826 mod_args
->expr
= rad
;
2827 mod_args
->next
= gfc_get_actual_arglist ();
2828 mod_args
->next
->expr
= factor
;
2830 result
= gfc_get_expr ();
2831 result
->ts
= rad
->ts
;
2832 result
->where
= rad
->where
;
2833 result
->expr_type
= EXPR_FUNCTION
;
2834 result
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_MOD
);
2835 result
->value
.function
.actual
= mod_args
;
2837 /* Set factor = 180 / pi. */
2838 factor
= gfc_get_constant_expr (rad
->ts
.type
, rad
->ts
.kind
, &rad
->where
);
2839 mpfr_set_ui (factor
->value
.real
, 180, GFC_RND_MODE
);
2841 mpfr_const_pi (tmp
, GFC_RND_MODE
);
2842 mpfr_div (factor
->value
.real
, factor
->value
.real
, tmp
, GFC_RND_MODE
);
2845 /* Result is deg = (rad % 2pi) * (180 / pi). */
2846 result
= gfc_multiply (result
, factor
);
2851 /* Resolve a call to a trig function. */
2854 resolve_trig_call (gfc_expr
*f
, gfc_expr
*x
)
2856 switch (f
->value
.function
.isym
->id
)
2859 return gfc_resolve_acos (f
, x
);
2861 return gfc_resolve_asin (f
, x
);
2863 return gfc_resolve_atan (f
, x
);
2864 case GFC_ISYM_ATAN2
:
2865 /* NB. arg3 is unused for atan2 */
2866 return gfc_resolve_atan2 (f
, x
, NULL
);
2868 return gfc_resolve_cos (f
, x
);
2869 case GFC_ISYM_COTAN
:
2870 return gfc_resolve_cotan (f
, x
);
2872 return gfc_resolve_sin (f
, x
);
2874 return gfc_resolve_tan (f
, x
);
2880 /* Resolve degree trig function as trigd (x) = trig (radians (x)). */
2883 gfc_resolve_trigd (gfc_expr
*f
, gfc_expr
*x
)
2885 if (is_trig_resolved (f
))
2888 x
= get_radians (x
);
2889 f
->value
.function
.actual
->expr
= x
;
2891 resolve_trig_call (f
, x
);
2895 /* Resolve degree inverse trig function as atrigd (x) = degrees (atrig (x)). */
2898 gfc_resolve_atrigd (gfc_expr
*f
, gfc_expr
*x
)
2900 gfc_expr
*result
, *fcopy
;
2902 if (is_trig_resolved (f
))
2905 resolve_trig_call (f
, x
);
2907 fcopy
= copy_replace_function_shallow (f
);
2908 result
= get_degrees (fcopy
);
2909 gfc_replace_expr (f
, result
);
2913 /* Resolve atan2d(x) = degrees(atan2(x)). */
2916 gfc_resolve_atan2d (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
2918 /* Note that we lose the second arg here - that's okay because it is
2919 unused in gfc_resolve_atan2 anyway. */
2920 gfc_resolve_atrigd (f
, x
);
2924 /* Resolve failed_images (team, kind). */
2927 gfc_resolve_failed_images (gfc_expr
*f
, gfc_expr
*team ATTRIBUTE_UNUSED
,
2930 static char failed_images
[] = "_gfortran_caf_failed_images";
2932 f
->ts
.type
= BT_INTEGER
;
2934 f
->ts
.kind
= gfc_default_integer_kind
;
2936 gfc_extract_int (kind
, &f
->ts
.kind
);
2937 f
->value
.function
.name
= failed_images
;
2941 /* Resolve image_status (image, team). */
2944 gfc_resolve_image_status (gfc_expr
*f
, gfc_expr
*image ATTRIBUTE_UNUSED
,
2945 gfc_expr
*team ATTRIBUTE_UNUSED
)
2947 static char image_status
[] = "_gfortran_caf_image_status";
2948 f
->ts
.type
= BT_INTEGER
;
2949 f
->ts
.kind
= gfc_default_integer_kind
;
2950 f
->value
.function
.name
= image_status
;
2954 /* Resolve get_team (). */
2957 gfc_resolve_get_team (gfc_expr
*f
, gfc_expr
*level ATTRIBUTE_UNUSED
)
2959 static char get_team
[] = "_gfortran_caf_get_team";
2961 f
->ts
.type
= BT_INTEGER
;
2962 f
->ts
.kind
= gfc_default_integer_kind
;
2963 f
->value
.function
.name
= get_team
;
2967 /* Resolve image_index (...). */
2970 gfc_resolve_image_index (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2971 gfc_expr
*sub ATTRIBUTE_UNUSED
)
2973 static char image_index
[] = "__image_index";
2974 f
->ts
.type
= BT_INTEGER
;
2975 f
->ts
.kind
= gfc_default_integer_kind
;
2976 f
->value
.function
.name
= image_index
;
2980 /* Resolve stopped_images (team, kind). */
2983 gfc_resolve_stopped_images (gfc_expr
*f
, gfc_expr
*team ATTRIBUTE_UNUSED
,
2986 static char stopped_images
[] = "_gfortran_caf_stopped_images";
2988 f
->ts
.type
= BT_INTEGER
;
2990 f
->ts
.kind
= gfc_default_integer_kind
;
2992 gfc_extract_int (kind
, &f
->ts
.kind
);
2993 f
->value
.function
.name
= stopped_images
;
2997 /* Resolve team_number (team). */
3000 gfc_resolve_team_number (gfc_expr
*f
, gfc_expr
*team ATTRIBUTE_UNUSED
)
3002 static char team_number
[] = "_gfortran_caf_team_number";
3004 f
->ts
.type
= BT_INTEGER
;
3005 f
->ts
.kind
= gfc_default_integer_kind
;
3006 f
->value
.function
.name
= team_number
;
3011 gfc_resolve_this_image (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
3012 gfc_expr
*distance ATTRIBUTE_UNUSED
)
3014 static char this_image
[] = "__this_image";
3015 if (array
&& gfc_is_coarray (array
))
3016 resolve_bound (f
, array
, dim
, NULL
, "__this_image", true);
3019 f
->ts
.type
= BT_INTEGER
;
3020 f
->ts
.kind
= gfc_default_integer_kind
;
3021 f
->value
.function
.name
= this_image
;
3027 gfc_resolve_time (gfc_expr
*f
)
3029 f
->ts
.type
= BT_INTEGER
;
3031 f
->value
.function
.name
= gfc_get_string (PREFIX ("time_func"));
3036 gfc_resolve_time8 (gfc_expr
*f
)
3038 f
->ts
.type
= BT_INTEGER
;
3040 f
->value
.function
.name
= gfc_get_string (PREFIX ("time8_func"));
3045 gfc_resolve_transfer (gfc_expr
*f
, gfc_expr
*source ATTRIBUTE_UNUSED
,
3046 gfc_expr
*mold
, gfc_expr
*size
)
3048 /* TODO: Make this do something meaningful. */
3049 static char transfer0
[] = "__transfer0", transfer1
[] = "__transfer1";
3051 if (mold
->ts
.type
== BT_CHARACTER
3052 && !mold
->ts
.u
.cl
->length
3053 && gfc_is_constant_expr (mold
))
3056 if (mold
->expr_type
== EXPR_CONSTANT
)
3058 len
= mold
->value
.character
.length
;
3059 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
3064 gfc_constructor
*c
= gfc_constructor_first (mold
->value
.constructor
);
3065 len
= c
->expr
->value
.character
.length
;
3066 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
3073 if (size
== NULL
&& mold
->rank
== 0)
3076 f
->value
.function
.name
= transfer0
;
3081 f
->value
.function
.name
= transfer1
;
3082 if (size
&& gfc_is_constant_expr (size
))
3084 f
->shape
= gfc_get_shape (1);
3085 mpz_init_set (f
->shape
[0], size
->value
.integer
);
3092 gfc_resolve_transpose (gfc_expr
*f
, gfc_expr
*matrix
)
3095 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ref
)
3096 gfc_resolve_substring_charlen (matrix
);
3102 f
->shape
= gfc_get_shape (2);
3103 mpz_init_set (f
->shape
[0], matrix
->shape
[1]);
3104 mpz_init_set (f
->shape
[1], matrix
->shape
[0]);
3107 switch (matrix
->ts
.kind
)
3113 switch (matrix
->ts
.type
)
3117 f
->value
.function
.name
3118 = gfc_get_string (PREFIX ("transpose_%c%d"),
3119 gfc_type_letter (matrix
->ts
.type
),
3125 /* Use the integer routines for real and logical cases. This
3126 assumes they all have the same alignment requirements. */
3127 f
->value
.function
.name
3128 = gfc_get_string (PREFIX ("transpose_i%d"), matrix
->ts
.kind
);
3132 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ts
.kind
== 4)
3133 f
->value
.function
.name
= PREFIX ("transpose_char4");
3135 f
->value
.function
.name
= PREFIX ("transpose");
3141 f
->value
.function
.name
= (matrix
->ts
.type
== BT_CHARACTER
3142 ? PREFIX ("transpose_char")
3143 : PREFIX ("transpose"));
3150 gfc_resolve_trim (gfc_expr
*f
, gfc_expr
*string
)
3152 f
->ts
.type
= BT_CHARACTER
;
3153 f
->ts
.kind
= string
->ts
.kind
;
3154 f
->value
.function
.name
= gfc_get_string ("__trim_%d", string
->ts
.kind
);
3159 gfc_resolve_ubound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3161 resolve_bound (f
, array
, dim
, kind
, "__ubound", false);
3166 gfc_resolve_ucobound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3168 resolve_bound (f
, array
, dim
, kind
, "__ucobound", true);
3172 /* Resolve the g77 compatibility function UMASK. */
3175 gfc_resolve_umask (gfc_expr
*f
, gfc_expr
*n
)
3177 f
->ts
.type
= BT_INTEGER
;
3178 f
->ts
.kind
= n
->ts
.kind
;
3179 f
->value
.function
.name
= gfc_get_string (PREFIX ("umask_i%d"), n
->ts
.kind
);
3183 /* Resolve the g77 compatibility function UNLINK. */
3186 gfc_resolve_unlink (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
3188 f
->ts
.type
= BT_INTEGER
;
3190 f
->value
.function
.name
= gfc_get_string (PREFIX ("unlink"));
3195 gfc_resolve_ttynam (gfc_expr
*f
, gfc_expr
*unit
)
3200 f
->ts
.type
= BT_CHARACTER
;
3201 f
->ts
.kind
= gfc_default_character_kind
;
3203 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3205 ts
.type
= BT_INTEGER
;
3206 ts
.kind
= gfc_c_int_kind
;
3207 ts
.u
.derived
= NULL
;
3209 gfc_convert_type (unit
, &ts
, 2);
3212 f
->value
.function
.name
= gfc_get_string (PREFIX ("ttynam"));
3217 gfc_resolve_unpack (gfc_expr
*f
, gfc_expr
*vector
, gfc_expr
*mask
,
3218 gfc_expr
*field ATTRIBUTE_UNUSED
)
3220 if (vector
->ts
.type
== BT_CHARACTER
&& vector
->ref
)
3221 gfc_resolve_substring_charlen (vector
);
3224 f
->rank
= mask
->rank
;
3225 resolve_mask_arg (mask
);
3227 if (vector
->ts
.type
== BT_CHARACTER
)
3229 if (vector
->ts
.kind
== 1)
3230 f
->value
.function
.name
3231 = gfc_get_string (PREFIX ("unpack%d_char"), field
->rank
> 0 ? 1 : 0);
3233 f
->value
.function
.name
3234 = gfc_get_string (PREFIX ("unpack%d_char%d"),
3235 field
->rank
> 0 ? 1 : 0, vector
->ts
.kind
);
3238 f
->value
.function
.name
3239 = gfc_get_string (PREFIX ("unpack%d"), field
->rank
> 0 ? 1 : 0);
3244 gfc_resolve_verify (gfc_expr
*f
, gfc_expr
*string
,
3245 gfc_expr
*set ATTRIBUTE_UNUSED
,
3246 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
3248 f
->ts
.type
= BT_INTEGER
;
3250 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
3252 f
->ts
.kind
= gfc_default_integer_kind
;
3253 f
->value
.function
.name
= gfc_get_string ("__verify_%d", string
->ts
.kind
);
3258 gfc_resolve_xor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
3260 f
->ts
.type
= i
->ts
.type
;
3261 f
->ts
.kind
= gfc_kind_max (i
, j
);
3263 if (i
->ts
.kind
!= j
->ts
.kind
)
3265 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
3266 gfc_convert_type (j
, &i
->ts
, 2);
3268 gfc_convert_type (i
, &j
->ts
, 2);
3271 f
->value
.function
.name
3272 = gfc_get_string ("__xor_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
3276 /* Intrinsic subroutine resolution. */
3279 gfc_resolve_alarm_sub (gfc_code
*c
)
3282 gfc_expr
*seconds
, *handler
;
3286 seconds
= c
->ext
.actual
->expr
;
3287 handler
= c
->ext
.actual
->next
->expr
;
3288 ts
.type
= BT_INTEGER
;
3289 ts
.kind
= gfc_c_int_kind
;
3291 /* handler can be either BT_INTEGER or BT_PROCEDURE.
3292 In all cases, the status argument is of default integer kind
3293 (enforced in check.c) so that the function suffix is fixed. */
3294 if (handler
->ts
.type
== BT_INTEGER
)
3296 if (handler
->ts
.kind
!= gfc_c_int_kind
)
3297 gfc_convert_type (handler
, &ts
, 2);
3298 name
= gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
3299 gfc_default_integer_kind
);
3302 name
= gfc_get_string (PREFIX ("alarm_sub_i%d"),
3303 gfc_default_integer_kind
);
3305 if (seconds
->ts
.kind
!= gfc_c_int_kind
)
3306 gfc_convert_type (seconds
, &ts
, 2);
3308 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3312 gfc_resolve_cpu_time (gfc_code
*c
)
3315 name
= gfc_get_string (PREFIX ("cpu_time_%d"), c
->ext
.actual
->expr
->ts
.kind
);
3316 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3320 /* Create a formal arglist based on an actual one and set the INTENTs given. */
3322 static gfc_formal_arglist
*
3323 create_formal_for_intents (gfc_actual_arglist
* actual
, const sym_intent
* ints
)
3325 gfc_formal_arglist
* head
;
3326 gfc_formal_arglist
* tail
;
3332 head
= tail
= gfc_get_formal_arglist ();
3333 for (i
= 0; actual
; actual
= actual
->next
, tail
= tail
->next
, ++i
)
3337 sym
= gfc_new_symbol ("dummyarg", NULL
);
3338 sym
->ts
= actual
->expr
->ts
;
3340 sym
->attr
.intent
= ints
[i
];
3344 tail
->next
= gfc_get_formal_arglist ();
3352 gfc_resolve_atomic_def (gfc_code
*c
)
3354 const char *name
= "atomic_define";
3355 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3360 gfc_resolve_atomic_ref (gfc_code
*c
)
3362 const char *name
= "atomic_ref";
3363 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3367 gfc_resolve_event_query (gfc_code
*c
)
3369 const char *name
= "event_query";
3370 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3374 gfc_resolve_mvbits (gfc_code
*c
)
3376 static const sym_intent INTENTS
[] = {INTENT_IN
, INTENT_IN
, INTENT_IN
,
3377 INTENT_INOUT
, INTENT_IN
};
3383 /* FROMPOS, LEN and TOPOS are restricted to small values. As such,
3384 they will be converted so that they fit into a C int. */
3385 ts
.type
= BT_INTEGER
;
3386 ts
.kind
= gfc_c_int_kind
;
3387 if (c
->ext
.actual
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
3388 gfc_convert_type (c
->ext
.actual
->next
->expr
, &ts
, 2);
3389 if (c
->ext
.actual
->next
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
3390 gfc_convert_type (c
->ext
.actual
->next
->next
->expr
, &ts
, 2);
3391 if (c
->ext
.actual
->next
->next
->next
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
3392 gfc_convert_type (c
->ext
.actual
->next
->next
->next
->next
->expr
, &ts
, 2);
3394 /* TO and FROM are guaranteed to have the same kind parameter. */
3395 name
= gfc_get_string (PREFIX ("mvbits_i%d"),
3396 c
->ext
.actual
->expr
->ts
.kind
);
3397 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3398 /* Mark as elemental subroutine as this does not happen automatically. */
3399 c
->resolved_sym
->attr
.elemental
= 1;
3401 /* Create a dummy formal arglist so the INTENTs are known later for purpose
3402 of creating temporaries. */
3403 c
->resolved_sym
->formal
= create_formal_for_intents (c
->ext
.actual
, INTENTS
);
3408 gfc_resolve_random_number (gfc_code
*c
)
3413 kind
= c
->ext
.actual
->expr
->ts
.kind
;
3414 if (c
->ext
.actual
->expr
->rank
== 0)
3415 name
= gfc_get_string (PREFIX ("random_r%d"), kind
);
3417 name
= gfc_get_string (PREFIX ("arandom_r%d"), kind
);
3419 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3424 gfc_resolve_random_seed (gfc_code
*c
)
3428 name
= gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind
);
3429 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3434 gfc_resolve_rename_sub (gfc_code
*c
)
3439 /* Find the type of status. If not present use default integer kind. */
3440 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3441 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3443 kind
= gfc_default_integer_kind
;
3445 name
= gfc_get_string (PREFIX ("rename_i%d_sub"), kind
);
3446 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3451 gfc_resolve_link_sub (gfc_code
*c
)
3456 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3457 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3459 kind
= gfc_default_integer_kind
;
3461 name
= gfc_get_string (PREFIX ("link_i%d_sub"), kind
);
3462 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3467 gfc_resolve_symlnk_sub (gfc_code
*c
)
3472 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3473 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3475 kind
= gfc_default_integer_kind
;
3477 name
= gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind
);
3478 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3482 /* G77 compatibility subroutines dtime() and etime(). */
3485 gfc_resolve_dtime_sub (gfc_code
*c
)
3488 name
= gfc_get_string (PREFIX ("dtime_sub"));
3489 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3493 gfc_resolve_etime_sub (gfc_code
*c
)
3496 name
= gfc_get_string (PREFIX ("etime_sub"));
3497 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3501 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
3504 gfc_resolve_itime (gfc_code
*c
)
3507 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
3508 gfc_default_integer_kind
));
3512 gfc_resolve_idate (gfc_code
*c
)
3515 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
3516 gfc_default_integer_kind
));
3520 gfc_resolve_ltime (gfc_code
*c
)
3523 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
3524 gfc_default_integer_kind
));
3528 gfc_resolve_gmtime (gfc_code
*c
)
3531 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
3532 gfc_default_integer_kind
));
3536 /* G77 compatibility subroutine second(). */
3539 gfc_resolve_second_sub (gfc_code
*c
)
3542 name
= gfc_get_string (PREFIX ("second_sub"));
3543 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3548 gfc_resolve_sleep_sub (gfc_code
*c
)
3553 if (c
->ext
.actual
->expr
!= NULL
)
3554 kind
= c
->ext
.actual
->expr
->ts
.kind
;
3556 kind
= gfc_default_integer_kind
;
3558 name
= gfc_get_string (PREFIX ("sleep_i%d_sub"), kind
);
3559 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3563 /* G77 compatibility function srand(). */
3566 gfc_resolve_srand (gfc_code
*c
)
3569 name
= gfc_get_string (PREFIX ("srand"));
3570 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3574 /* Resolve the getarg intrinsic subroutine. */
3577 gfc_resolve_getarg (gfc_code
*c
)
3581 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_default_integer_kind
)
3586 ts
.type
= BT_INTEGER
;
3587 ts
.kind
= gfc_default_integer_kind
;
3589 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3592 name
= gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind
);
3593 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3597 /* Resolve the getcwd intrinsic subroutine. */
3600 gfc_resolve_getcwd_sub (gfc_code
*c
)
3605 if (c
->ext
.actual
->next
->expr
!= NULL
)
3606 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3608 kind
= gfc_default_integer_kind
;
3610 name
= gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind
);
3611 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3615 /* Resolve the get_command intrinsic subroutine. */
3618 gfc_resolve_get_command (gfc_code
*c
)
3622 kind
= gfc_default_integer_kind
;
3623 name
= gfc_get_string (PREFIX ("get_command_i%d"), kind
);
3624 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3628 /* Resolve the get_command_argument intrinsic subroutine. */
3631 gfc_resolve_get_command_argument (gfc_code
*c
)
3635 kind
= gfc_default_integer_kind
;
3636 name
= gfc_get_string (PREFIX ("get_command_argument_i%d"), kind
);
3637 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3641 /* Resolve the get_environment_variable intrinsic subroutine. */
3644 gfc_resolve_get_environment_variable (gfc_code
*code
)
3648 kind
= gfc_default_integer_kind
;
3649 name
= gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind
);
3650 code
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3655 gfc_resolve_signal_sub (gfc_code
*c
)
3658 gfc_expr
*number
, *handler
, *status
;
3662 number
= c
->ext
.actual
->expr
;
3663 handler
= c
->ext
.actual
->next
->expr
;
3664 status
= c
->ext
.actual
->next
->next
->expr
;
3665 ts
.type
= BT_INTEGER
;
3666 ts
.kind
= gfc_c_int_kind
;
3668 /* handler can be either BT_INTEGER or BT_PROCEDURE */
3669 if (handler
->ts
.type
== BT_INTEGER
)
3671 if (handler
->ts
.kind
!= gfc_c_int_kind
)
3672 gfc_convert_type (handler
, &ts
, 2);
3673 name
= gfc_get_string (PREFIX ("signal_sub_int"));
3676 name
= gfc_get_string (PREFIX ("signal_sub"));
3678 if (number
->ts
.kind
!= gfc_c_int_kind
)
3679 gfc_convert_type (number
, &ts
, 2);
3680 if (status
!= NULL
&& status
->ts
.kind
!= gfc_c_int_kind
)
3681 gfc_convert_type (status
, &ts
, 2);
3683 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3687 /* Resolve the SYSTEM intrinsic subroutine. */
3690 gfc_resolve_system_sub (gfc_code
*c
)
3693 name
= gfc_get_string (PREFIX ("system_sub"));
3694 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3698 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
3701 gfc_resolve_system_clock (gfc_code
*c
)
3705 gfc_expr
*count
= c
->ext
.actual
->expr
;
3706 gfc_expr
*count_max
= c
->ext
.actual
->next
->next
->expr
;
3708 /* The INTEGER(8) version has higher precision, it is used if both COUNT
3709 and COUNT_MAX can hold 64-bit values, or are absent. */
3710 if ((!count
|| count
->ts
.kind
>= 8)
3711 && (!count_max
|| count_max
->ts
.kind
>= 8))
3714 kind
= gfc_default_integer_kind
;
3716 name
= gfc_get_string (PREFIX ("system_clock_%d"), kind
);
3717 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3721 /* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine. */
3723 gfc_resolve_execute_command_line (gfc_code
*c
)
3726 name
= gfc_get_string (PREFIX ("execute_command_line_i%d"),
3727 gfc_default_integer_kind
);
3728 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3732 /* Resolve the EXIT intrinsic subroutine. */
3735 gfc_resolve_exit (gfc_code
*c
)
3742 /* The STATUS argument has to be of default kind. If it is not,
3744 ts
.type
= BT_INTEGER
;
3745 ts
.kind
= gfc_default_integer_kind
;
3746 n
= c
->ext
.actual
->expr
;
3747 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3748 gfc_convert_type (n
, &ts
, 2);
3750 name
= gfc_get_string (PREFIX ("exit_i%d"), ts
.kind
);
3751 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3755 /* Resolve the FLUSH intrinsic subroutine. */
3758 gfc_resolve_flush (gfc_code
*c
)
3765 ts
.type
= BT_INTEGER
;
3766 ts
.kind
= gfc_default_integer_kind
;
3767 n
= c
->ext
.actual
->expr
;
3768 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3769 gfc_convert_type (n
, &ts
, 2);
3771 name
= gfc_get_string (PREFIX ("flush_i%d"), ts
.kind
);
3772 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3777 gfc_resolve_ctime_sub (gfc_code
*c
)
3782 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3783 if (c
->ext
.actual
->expr
->ts
.kind
!= 8)
3785 ts
.type
= BT_INTEGER
;
3787 ts
.u
.derived
= NULL
;
3789 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3792 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3797 gfc_resolve_fdate_sub (gfc_code
*c
)
3799 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3804 gfc_resolve_gerror (gfc_code
*c
)
3806 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3811 gfc_resolve_getlog (gfc_code
*c
)
3813 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3818 gfc_resolve_hostnm_sub (gfc_code
*c
)
3823 if (c
->ext
.actual
->next
->expr
!= NULL
)
3824 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3826 kind
= gfc_default_integer_kind
;
3828 name
= gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind
);
3829 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3834 gfc_resolve_perror (gfc_code
*c
)
3836 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3839 /* Resolve the STAT and FSTAT intrinsic subroutines. */
3842 gfc_resolve_stat_sub (gfc_code
*c
)
3845 name
= gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind
);
3846 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3851 gfc_resolve_lstat_sub (gfc_code
*c
)
3854 name
= gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind
);
3855 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3860 gfc_resolve_fstat_sub (gfc_code
*c
)
3866 u
= c
->ext
.actual
->expr
;
3867 ts
= &c
->ext
.actual
->next
->expr
->ts
;
3868 if (u
->ts
.kind
!= ts
->kind
)
3869 gfc_convert_type (u
, ts
, 2);
3870 name
= gfc_get_string (PREFIX ("fstat_i%d_sub"), ts
->kind
);
3871 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3876 gfc_resolve_fgetc_sub (gfc_code
*c
)
3883 u
= c
->ext
.actual
->expr
;
3884 st
= c
->ext
.actual
->next
->next
->expr
;
3886 if (u
->ts
.kind
!= gfc_c_int_kind
)
3888 ts
.type
= BT_INTEGER
;
3889 ts
.kind
= gfc_c_int_kind
;
3890 ts
.u
.derived
= NULL
;
3892 gfc_convert_type (u
, &ts
, 2);
3896 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), st
->ts
.kind
);
3898 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind
);
3900 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3905 gfc_resolve_fget_sub (gfc_code
*c
)
3910 st
= c
->ext
.actual
->next
->expr
;
3912 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), st
->ts
.kind
);
3914 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind
);
3916 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3921 gfc_resolve_fputc_sub (gfc_code
*c
)
3928 u
= c
->ext
.actual
->expr
;
3929 st
= c
->ext
.actual
->next
->next
->expr
;
3931 if (u
->ts
.kind
!= gfc_c_int_kind
)
3933 ts
.type
= BT_INTEGER
;
3934 ts
.kind
= gfc_c_int_kind
;
3935 ts
.u
.derived
= NULL
;
3937 gfc_convert_type (u
, &ts
, 2);
3941 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), st
->ts
.kind
);
3943 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind
);
3945 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3950 gfc_resolve_fput_sub (gfc_code
*c
)
3955 st
= c
->ext
.actual
->next
->expr
;
3957 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), st
->ts
.kind
);
3959 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind
);
3961 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3966 gfc_resolve_fseek_sub (gfc_code
*c
)
3974 unit
= c
->ext
.actual
->expr
;
3975 offset
= c
->ext
.actual
->next
->expr
;
3976 whence
= c
->ext
.actual
->next
->next
->expr
;
3978 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3980 ts
.type
= BT_INTEGER
;
3981 ts
.kind
= gfc_c_int_kind
;
3982 ts
.u
.derived
= NULL
;
3984 gfc_convert_type (unit
, &ts
, 2);
3987 if (offset
->ts
.kind
!= gfc_intio_kind
)
3989 ts
.type
= BT_INTEGER
;
3990 ts
.kind
= gfc_intio_kind
;
3991 ts
.u
.derived
= NULL
;
3993 gfc_convert_type (offset
, &ts
, 2);
3996 if (whence
->ts
.kind
!= gfc_c_int_kind
)
3998 ts
.type
= BT_INTEGER
;
3999 ts
.kind
= gfc_c_int_kind
;
4000 ts
.u
.derived
= NULL
;
4002 gfc_convert_type (whence
, &ts
, 2);
4005 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
4009 gfc_resolve_ftell_sub (gfc_code
*c
)
4017 unit
= c
->ext
.actual
->expr
;
4018 offset
= c
->ext
.actual
->next
->expr
;
4020 if (unit
->ts
.kind
!= gfc_c_int_kind
)
4022 ts
.type
= BT_INTEGER
;
4023 ts
.kind
= gfc_c_int_kind
;
4024 ts
.u
.derived
= NULL
;
4026 gfc_convert_type (unit
, &ts
, 2);
4029 name
= gfc_get_string (PREFIX ("ftell_i%d_sub"), offset
->ts
.kind
);
4030 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
4035 gfc_resolve_ttynam_sub (gfc_code
*c
)
4040 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
4042 ts
.type
= BT_INTEGER
;
4043 ts
.kind
= gfc_c_int_kind
;
4044 ts
.u
.derived
= NULL
;
4046 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
4049 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
4053 /* Resolve the UMASK intrinsic subroutine. */
4056 gfc_resolve_umask_sub (gfc_code
*c
)
4061 if (c
->ext
.actual
->next
->expr
!= NULL
)
4062 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
4064 kind
= gfc_default_integer_kind
;
4066 name
= gfc_get_string (PREFIX ("umask_i%d_sub"), kind
);
4067 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
4070 /* Resolve the UNLINK intrinsic subroutine. */
4073 gfc_resolve_unlink_sub (gfc_code
*c
)
4078 if (c
->ext
.actual
->next
->expr
!= NULL
)
4079 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
4081 kind
= gfc_default_integer_kind
;
4083 name
= gfc_get_string (PREFIX ("unlink_i%d_sub"), kind
);
4084 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);