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 && gfc_str_startswith (f
->value
.function
.name
, "__"));
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_findloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*value
,
1788 gfc_expr
*dim
, gfc_expr
*mask
, gfc_expr
*kind
,
1796 /* See at the end of the function for why this is necessary. */
1798 if (f
->do_not_resolve_again
)
1801 f
->ts
.type
= BT_INTEGER
;
1803 /* We have a single library version, which uses index_type. */
1806 fkind
= mpz_get_si (kind
->value
.integer
);
1808 fkind
= gfc_default_integer_kind
;
1810 f
->ts
.kind
= gfc_index_integer_kind
;
1812 /* Convert value. If array is not LOGICAL and value is, we already
1813 issued an error earlier. */
1815 if ((array
->ts
.type
!= value
->ts
.type
&& value
->ts
.type
!= BT_LOGICAL
)
1816 || array
->ts
.kind
!= value
->ts
.kind
)
1817 gfc_convert_type_warn (value
, &array
->ts
, 2, 0);
1822 f
->shape
= gfc_get_shape (1);
1823 mpz_init_set_si (f
->shape
[0], array
->rank
);
1827 f
->rank
= array
->rank
- 1;
1828 gfc_resolve_dim_arg (dim
);
1829 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1831 idim
= (int) mpz_get_si (dim
->value
.integer
);
1832 f
->shape
= gfc_get_shape (f
->rank
);
1833 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1835 if (i
== (idim
- 1))
1837 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1844 if (mask
->rank
== 0)
1849 resolve_mask_arg (mask
);
1864 if (back
->ts
.kind
!= gfc_logical_4_kind
)
1868 ts
.type
= BT_LOGICAL
;
1869 ts
.kind
= gfc_logical_4_kind
;
1870 gfc_convert_type_warn (back
, &ts
, 2, 0);
1873 f
->value
.function
.name
1874 = gfc_get_string (PREFIX ("%s%d_%c%d"), name
, d_num
,
1875 gfc_type_letter (array
->ts
.type
, true), array
->ts
.kind
);
1877 /* We only have a single library function, so we need to convert
1878 here. If the function is resolved from within a convert
1879 function generated on a previous round of resolution, endless
1880 recursion could occur. Guard against that here. */
1882 if (f
->ts
.kind
!= fkind
)
1884 f
->do_not_resolve_again
= 1;
1888 ts
.type
= BT_INTEGER
;
1890 gfc_convert_type_warn (f
, &ts
, 2, 0);
1896 gfc_resolve_maxval (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1906 f
->rank
= array
->rank
- 1;
1907 gfc_resolve_dim_arg (dim
);
1909 if (f
->rank
&& array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1911 idim
= (int) mpz_get_si (dim
->value
.integer
);
1912 f
->shape
= gfc_get_shape (f
->rank
);
1913 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1915 if (i
== (idim
- 1))
1917 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1924 if (mask
->rank
== 0)
1929 resolve_mask_arg (mask
);
1934 if (array
->ts
.type
!= BT_CHARACTER
)
1935 f
->value
.function
.name
1936 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
1937 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1939 f
->value
.function
.name
1940 = gfc_get_string (PREFIX ("%s%d_%c%d"), name
, f
->rank
!= 0,
1941 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1946 gfc_resolve_mclock (gfc_expr
*f
)
1948 f
->ts
.type
= BT_INTEGER
;
1950 f
->value
.function
.name
= PREFIX ("mclock");
1955 gfc_resolve_mclock8 (gfc_expr
*f
)
1957 f
->ts
.type
= BT_INTEGER
;
1959 f
->value
.function
.name
= PREFIX ("mclock8");
1964 gfc_resolve_mask (gfc_expr
*f
, gfc_expr
*i ATTRIBUTE_UNUSED
,
1967 f
->ts
.type
= BT_INTEGER
;
1968 f
->ts
.kind
= kind
? mpz_get_si (kind
->value
.integer
)
1969 : gfc_default_integer_kind
;
1971 if (f
->value
.function
.isym
->id
== GFC_ISYM_MASKL
)
1972 f
->value
.function
.name
= gfc_get_string ("__maskl_i%d", f
->ts
.kind
);
1974 f
->value
.function
.name
= gfc_get_string ("__maskr_i%d", f
->ts
.kind
);
1979 gfc_resolve_merge (gfc_expr
*f
, gfc_expr
*tsource
,
1980 gfc_expr
*fsource ATTRIBUTE_UNUSED
,
1981 gfc_expr
*mask ATTRIBUTE_UNUSED
)
1983 if (tsource
->ts
.type
== BT_CHARACTER
&& tsource
->ref
)
1984 gfc_resolve_substring_charlen (tsource
);
1986 if (fsource
->ts
.type
== BT_CHARACTER
&& fsource
->ref
)
1987 gfc_resolve_substring_charlen (fsource
);
1989 if (tsource
->ts
.type
== BT_CHARACTER
)
1990 check_charlen_present (tsource
);
1992 f
->ts
= tsource
->ts
;
1993 f
->value
.function
.name
1994 = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource
->ts
.type
),
2000 gfc_resolve_merge_bits (gfc_expr
*f
, gfc_expr
*i
,
2001 gfc_expr
*j ATTRIBUTE_UNUSED
,
2002 gfc_expr
*mask ATTRIBUTE_UNUSED
)
2005 f
->value
.function
.name
= gfc_get_string ("__merge_bits_i%d", i
->ts
.kind
);
2010 gfc_resolve_min (gfc_expr
*f
, gfc_actual_arglist
*args
)
2012 gfc_resolve_minmax ("__min_%c%d", f
, args
);
2017 gfc_resolve_minloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
2018 gfc_expr
*mask
, gfc_expr
*kind
, gfc_expr
*back
)
2025 f
->ts
.type
= BT_INTEGER
;
2027 /* The library versions only exist for kinds 4, 8 and 16. For smaller kinds,
2028 we do a type conversion further down. */
2030 fkind
= mpz_get_si (kind
->value
.integer
);
2032 fkind
= gfc_default_integer_kind
;
2034 if (fkind
< MINMAXLOC_MIN_KIND
)
2035 f
->ts
.kind
= MINMAXLOC_MIN_KIND
;
2042 f
->shape
= gfc_get_shape (1);
2043 mpz_init_set_si (f
->shape
[0], array
->rank
);
2047 f
->rank
= array
->rank
- 1;
2048 gfc_resolve_dim_arg (dim
);
2049 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
2051 idim
= (int) mpz_get_si (dim
->value
.integer
);
2052 f
->shape
= gfc_get_shape (f
->rank
);
2053 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
2055 if (i
== (idim
- 1))
2057 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
2064 if (mask
->rank
== 0)
2069 resolve_mask_arg (mask
);
2076 if (array
->ts
.type
!= BT_CHARACTER
|| f
->rank
!= 0)
2084 f
->value
.function
.name
2085 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name
, d_num
, f
->ts
.kind
,
2086 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
2088 if (fkind
!= f
->ts
.kind
)
2093 ts
.type
= BT_INTEGER
;
2095 gfc_convert_type_warn (f
, &ts
, 2, 0);
2098 if (back
->ts
.kind
!= gfc_logical_4_kind
)
2102 ts
.type
= BT_LOGICAL
;
2103 ts
.kind
= gfc_logical_4_kind
;
2104 gfc_convert_type_warn (back
, &ts
, 2, 0);
2110 gfc_resolve_minval (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
2120 f
->rank
= array
->rank
- 1;
2121 gfc_resolve_dim_arg (dim
);
2123 if (f
->rank
&& array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
2125 idim
= (int) mpz_get_si (dim
->value
.integer
);
2126 f
->shape
= gfc_get_shape (f
->rank
);
2127 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
2129 if (i
== (idim
- 1))
2131 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
2138 if (mask
->rank
== 0)
2143 resolve_mask_arg (mask
);
2148 if (array
->ts
.type
!= BT_CHARACTER
)
2149 f
->value
.function
.name
2150 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
2151 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
2153 f
->value
.function
.name
2154 = gfc_get_string (PREFIX ("%s%d_%c%d"), name
, f
->rank
!= 0,
2155 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
2160 gfc_resolve_mod (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
2162 f
->ts
.type
= a
->ts
.type
;
2164 f
->ts
.kind
= gfc_kind_max (a
,p
);
2166 f
->ts
.kind
= a
->ts
.kind
;
2168 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
2170 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
2171 gfc_convert_type (p
, &a
->ts
, 2);
2173 gfc_convert_type (a
, &p
->ts
, 2);
2176 f
->value
.function
.name
2177 = gfc_get_string ("__mod_%c%d", gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
2182 gfc_resolve_modulo (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
2184 f
->ts
.type
= a
->ts
.type
;
2186 f
->ts
.kind
= gfc_kind_max (a
,p
);
2188 f
->ts
.kind
= a
->ts
.kind
;
2190 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
2192 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
2193 gfc_convert_type (p
, &a
->ts
, 2);
2195 gfc_convert_type (a
, &p
->ts
, 2);
2198 f
->value
.function
.name
2199 = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f
->ts
.type
),
2204 gfc_resolve_nearest (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
2206 if (p
->ts
.kind
!= a
->ts
.kind
)
2207 gfc_convert_type (p
, &a
->ts
, 2);
2210 f
->value
.function
.name
2211 = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a
->ts
.type
),
2216 gfc_resolve_nint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
2218 f
->ts
.type
= BT_INTEGER
;
2219 f
->ts
.kind
= (kind
== NULL
)
2220 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
2221 f
->value
.function
.name
2222 = gfc_get_string ("__nint_%d_%d", f
->ts
.kind
, a
->ts
.kind
);
2227 gfc_resolve_norm2 (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
)
2229 resolve_transformational ("norm2", f
, array
, dim
, NULL
);
2234 gfc_resolve_not (gfc_expr
*f
, gfc_expr
*i
)
2237 f
->value
.function
.name
= gfc_get_string ("__not_%d", i
->ts
.kind
);
2242 gfc_resolve_or (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
2244 f
->ts
.type
= i
->ts
.type
;
2245 f
->ts
.kind
= gfc_kind_max (i
, j
);
2247 if (i
->ts
.kind
!= j
->ts
.kind
)
2249 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
2250 gfc_convert_type (j
, &i
->ts
, 2);
2252 gfc_convert_type (i
, &j
->ts
, 2);
2255 f
->value
.function
.name
2256 = gfc_get_string ("__or_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
2261 gfc_resolve_pack (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*mask
,
2262 gfc_expr
*vector ATTRIBUTE_UNUSED
)
2264 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
2265 gfc_resolve_substring_charlen (array
);
2270 resolve_mask_arg (mask
);
2272 if (mask
->rank
!= 0)
2274 if (array
->ts
.type
== BT_CHARACTER
)
2275 f
->value
.function
.name
2276 = array
->ts
.kind
== 1 ? PREFIX ("pack_char")
2278 (PREFIX ("pack_char%d"),
2281 f
->value
.function
.name
= PREFIX ("pack");
2285 if (array
->ts
.type
== BT_CHARACTER
)
2286 f
->value
.function
.name
2287 = array
->ts
.kind
== 1 ? PREFIX ("pack_s_char")
2289 (PREFIX ("pack_s_char%d"),
2292 f
->value
.function
.name
= PREFIX ("pack_s");
2298 gfc_resolve_parity (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
)
2300 resolve_transformational ("parity", f
, array
, dim
, NULL
);
2305 gfc_resolve_product (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
2308 resolve_transformational ("product", f
, array
, dim
, mask
);
2313 gfc_resolve_rank (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
)
2315 f
->ts
.type
= BT_INTEGER
;
2316 f
->ts
.kind
= gfc_default_integer_kind
;
2317 f
->value
.function
.name
= gfc_get_string ("__rank");
2322 gfc_resolve_real (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
2324 f
->ts
.type
= BT_REAL
;
2327 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2329 f
->ts
.kind
= (a
->ts
.type
== BT_COMPLEX
)
2330 ? a
->ts
.kind
: gfc_default_real_kind
;
2332 f
->value
.function
.name
2333 = gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
2334 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2339 gfc_resolve_realpart (gfc_expr
*f
, gfc_expr
*a
)
2341 f
->ts
.type
= BT_REAL
;
2342 f
->ts
.kind
= a
->ts
.kind
;
2343 f
->value
.function
.name
2344 = gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
2345 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2350 gfc_resolve_rename (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
2351 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
2353 f
->ts
.type
= BT_INTEGER
;
2354 f
->ts
.kind
= gfc_default_integer_kind
;
2355 f
->value
.function
.name
= gfc_get_string (PREFIX ("rename_i%d"), f
->ts
.kind
);
2360 gfc_resolve_repeat (gfc_expr
*f
, gfc_expr
*string
,
2364 f
->ts
.type
= BT_CHARACTER
;
2365 f
->ts
.kind
= string
->ts
.kind
;
2366 f
->value
.function
.name
= gfc_get_string ("__repeat_%d", string
->ts
.kind
);
2368 /* If possible, generate a character length. */
2369 if (f
->ts
.u
.cl
== NULL
)
2370 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2373 if (string
->expr_type
== EXPR_CONSTANT
)
2375 tmp
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
2376 string
->value
.character
.length
);
2378 else if (string
->ts
.u
.cl
&& string
->ts
.u
.cl
->length
)
2380 tmp
= gfc_copy_expr (string
->ts
.u
.cl
->length
);
2384 f
->ts
.u
.cl
->length
= gfc_multiply (tmp
, gfc_copy_expr (ncopies
));
2389 gfc_resolve_reshape (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*shape
,
2390 gfc_expr
*pad ATTRIBUTE_UNUSED
,
2391 gfc_expr
*order ATTRIBUTE_UNUSED
)
2397 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
2398 gfc_resolve_substring_charlen (source
);
2402 gfc_array_size (shape
, &rank
);
2403 f
->rank
= mpz_get_si (rank
);
2405 switch (source
->ts
.type
)
2412 kind
= source
->ts
.kind
;
2426 if (source
->ts
.type
== BT_COMPLEX
|| source
->ts
.type
== BT_REAL
)
2427 f
->value
.function
.name
2428 = gfc_get_string (PREFIX ("reshape_%c%d"),
2429 gfc_type_letter (source
->ts
.type
),
2431 else if (source
->ts
.type
== BT_CHARACTER
)
2432 f
->value
.function
.name
= gfc_get_string (PREFIX ("reshape_char%d"),
2435 f
->value
.function
.name
2436 = gfc_get_string (PREFIX ("reshape_%d"), source
->ts
.kind
);
2440 f
->value
.function
.name
= (source
->ts
.type
== BT_CHARACTER
2441 ? PREFIX ("reshape_char") : PREFIX ("reshape"));
2445 if (shape
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (shape
))
2448 f
->shape
= gfc_get_shape (f
->rank
);
2449 c
= gfc_constructor_first (shape
->value
.constructor
);
2450 for (i
= 0; i
< f
->rank
; i
++)
2452 mpz_init_set (f
->shape
[i
], c
->expr
->value
.integer
);
2453 c
= gfc_constructor_next (c
);
2457 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
2458 so many runtime variations. */
2459 if (shape
->ts
.kind
!= gfc_index_integer_kind
)
2461 gfc_typespec ts
= shape
->ts
;
2462 ts
.kind
= gfc_index_integer_kind
;
2463 gfc_convert_type_warn (shape
, &ts
, 2, 0);
2465 if (order
&& order
->ts
.kind
!= gfc_index_integer_kind
)
2466 gfc_convert_type_warn (order
, &shape
->ts
, 2, 0);
2471 gfc_resolve_rrspacing (gfc_expr
*f
, gfc_expr
*x
)
2474 f
->value
.function
.name
= gfc_get_string ("__rrspacing_%d", x
->ts
.kind
);
2478 gfc_resolve_fe_runtime_error (gfc_code
*c
)
2481 gfc_actual_arglist
*a
;
2483 name
= gfc_get_string (PREFIX ("runtime_error"));
2485 for (a
= c
->ext
.actual
->next
; a
; a
= a
->next
)
2488 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2492 gfc_resolve_scale (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*i ATTRIBUTE_UNUSED
)
2495 f
->value
.function
.name
= gfc_get_string ("__scale_%d", x
->ts
.kind
);
2500 gfc_resolve_scan (gfc_expr
*f
, gfc_expr
*string
,
2501 gfc_expr
*set ATTRIBUTE_UNUSED
,
2502 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2504 f
->ts
.type
= BT_INTEGER
;
2506 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2508 f
->ts
.kind
= gfc_default_integer_kind
;
2509 f
->value
.function
.name
= gfc_get_string ("__scan_%d", string
->ts
.kind
);
2514 gfc_resolve_secnds (gfc_expr
*t1
, gfc_expr
*t0
)
2517 t1
->value
.function
.name
= gfc_get_string (PREFIX ("secnds"));
2522 gfc_resolve_set_exponent (gfc_expr
*f
, gfc_expr
*x
,
2523 gfc_expr
*i ATTRIBUTE_UNUSED
)
2526 f
->value
.function
.name
= gfc_get_string ("__set_exponent_%d", x
->ts
.kind
);
2531 gfc_resolve_shape (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*kind
)
2533 f
->ts
.type
= BT_INTEGER
;
2536 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2538 f
->ts
.kind
= gfc_default_integer_kind
;
2541 if (array
->rank
!= -1)
2543 f
->shape
= gfc_get_shape (1);
2544 mpz_init_set_ui (f
->shape
[0], array
->rank
);
2547 f
->value
.function
.name
= gfc_get_string (PREFIX ("shape_%d"), f
->ts
.kind
);
2552 gfc_resolve_shift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift ATTRIBUTE_UNUSED
)
2555 if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTA
)
2556 f
->value
.function
.name
= gfc_get_string ("shifta_i%d", f
->ts
.kind
);
2557 else if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTL
)
2558 f
->value
.function
.name
= gfc_get_string ("shiftl_i%d", f
->ts
.kind
);
2559 else if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTR
)
2560 f
->value
.function
.name
= gfc_get_string ("shiftr_i%d", f
->ts
.kind
);
2567 gfc_resolve_sign (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b ATTRIBUTE_UNUSED
)
2570 f
->value
.function
.name
2571 = gfc_get_string ("__sign_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2576 gfc_resolve_signal (gfc_expr
*f
, gfc_expr
*number
, gfc_expr
*handler
)
2578 f
->ts
.type
= BT_INTEGER
;
2579 f
->ts
.kind
= gfc_c_int_kind
;
2581 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2582 if (handler
->ts
.type
== BT_INTEGER
)
2584 if (handler
->ts
.kind
!= gfc_c_int_kind
)
2585 gfc_convert_type (handler
, &f
->ts
, 2);
2586 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func_int"));
2589 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func"));
2591 if (number
->ts
.kind
!= gfc_c_int_kind
)
2592 gfc_convert_type (number
, &f
->ts
, 2);
2597 gfc_resolve_sin (gfc_expr
*f
, gfc_expr
*x
)
2600 f
->value
.function
.name
2601 = gfc_get_string ("__sin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2606 gfc_resolve_sinh (gfc_expr
*f
, gfc_expr
*x
)
2609 f
->value
.function
.name
2610 = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2615 gfc_resolve_size (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2616 gfc_expr
*dim ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2618 f
->ts
.type
= BT_INTEGER
;
2620 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2622 f
->ts
.kind
= gfc_default_integer_kind
;
2627 gfc_resolve_stride (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2628 gfc_expr
*dim ATTRIBUTE_UNUSED
)
2630 f
->ts
.type
= BT_INTEGER
;
2631 f
->ts
.kind
= gfc_index_integer_kind
;
2636 gfc_resolve_spacing (gfc_expr
*f
, gfc_expr
*x
)
2639 f
->value
.function
.name
= gfc_get_string ("__spacing_%d", x
->ts
.kind
);
2644 gfc_resolve_spread (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*dim
,
2647 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
2648 gfc_resolve_substring_charlen (source
);
2650 if (source
->ts
.type
== BT_CHARACTER
)
2651 check_charlen_present (source
);
2654 f
->rank
= source
->rank
+ 1;
2655 if (source
->rank
== 0)
2657 if (source
->ts
.type
== BT_CHARACTER
)
2658 f
->value
.function
.name
2659 = source
->ts
.kind
== 1 ? PREFIX ("spread_char_scalar")
2661 (PREFIX ("spread_char%d_scalar"),
2664 f
->value
.function
.name
= PREFIX ("spread_scalar");
2668 if (source
->ts
.type
== BT_CHARACTER
)
2669 f
->value
.function
.name
2670 = source
->ts
.kind
== 1 ? PREFIX ("spread_char")
2672 (PREFIX ("spread_char%d"),
2675 f
->value
.function
.name
= PREFIX ("spread");
2678 if (dim
&& gfc_is_constant_expr (dim
)
2679 && ncopies
&& gfc_is_constant_expr (ncopies
) && source
->shape
[0])
2682 idim
= mpz_get_ui (dim
->value
.integer
);
2683 f
->shape
= gfc_get_shape (f
->rank
);
2684 for (i
= 0; i
< (idim
- 1); i
++)
2685 mpz_init_set (f
->shape
[i
], source
->shape
[i
]);
2687 mpz_init_set (f
->shape
[idim
- 1], ncopies
->value
.integer
);
2689 for (i
= idim
; i
< f
->rank
; i
++)
2690 mpz_init_set (f
->shape
[i
], source
->shape
[i
-1]);
2694 gfc_resolve_dim_arg (dim
);
2695 gfc_resolve_index (ncopies
, 1);
2700 gfc_resolve_sqrt (gfc_expr
*f
, gfc_expr
*x
)
2703 f
->value
.function
.name
2704 = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2708 /* Resolve the g77 compatibility function STAT AND FSTAT. */
2711 gfc_resolve_stat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2712 gfc_expr
*a ATTRIBUTE_UNUSED
)
2714 f
->ts
.type
= BT_INTEGER
;
2715 f
->ts
.kind
= gfc_default_integer_kind
;
2716 f
->value
.function
.name
= gfc_get_string (PREFIX ("stat_i%d"), f
->ts
.kind
);
2721 gfc_resolve_lstat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2722 gfc_expr
*a ATTRIBUTE_UNUSED
)
2724 f
->ts
.type
= BT_INTEGER
;
2725 f
->ts
.kind
= gfc_default_integer_kind
;
2726 f
->value
.function
.name
= gfc_get_string (PREFIX ("lstat_i%d"), f
->ts
.kind
);
2731 gfc_resolve_fstat (gfc_expr
*f
, gfc_expr
*n
, gfc_expr
*a ATTRIBUTE_UNUSED
)
2733 f
->ts
.type
= BT_INTEGER
;
2734 f
->ts
.kind
= gfc_default_integer_kind
;
2735 if (n
->ts
.kind
!= f
->ts
.kind
)
2736 gfc_convert_type (n
, &f
->ts
, 2);
2738 f
->value
.function
.name
= gfc_get_string (PREFIX ("fstat_i%d"), f
->ts
.kind
);
2743 gfc_resolve_fgetc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2748 f
->ts
.type
= BT_INTEGER
;
2749 f
->ts
.kind
= gfc_c_int_kind
;
2750 if (u
->ts
.kind
!= gfc_c_int_kind
)
2752 ts
.type
= BT_INTEGER
;
2753 ts
.kind
= gfc_c_int_kind
;
2754 ts
.u
.derived
= NULL
;
2756 gfc_convert_type (u
, &ts
, 2);
2759 f
->value
.function
.name
= gfc_get_string (PREFIX ("fgetc"));
2764 gfc_resolve_fget (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2766 f
->ts
.type
= BT_INTEGER
;
2767 f
->ts
.kind
= gfc_c_int_kind
;
2768 f
->value
.function
.name
= gfc_get_string (PREFIX ("fget"));
2773 gfc_resolve_fputc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2778 f
->ts
.type
= BT_INTEGER
;
2779 f
->ts
.kind
= gfc_c_int_kind
;
2780 if (u
->ts
.kind
!= gfc_c_int_kind
)
2782 ts
.type
= BT_INTEGER
;
2783 ts
.kind
= gfc_c_int_kind
;
2784 ts
.u
.derived
= NULL
;
2786 gfc_convert_type (u
, &ts
, 2);
2789 f
->value
.function
.name
= gfc_get_string (PREFIX ("fputc"));
2794 gfc_resolve_fput (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2796 f
->ts
.type
= BT_INTEGER
;
2797 f
->ts
.kind
= gfc_c_int_kind
;
2798 f
->value
.function
.name
= gfc_get_string (PREFIX ("fput"));
2803 gfc_resolve_ftell (gfc_expr
*f
, gfc_expr
*u
)
2808 f
->ts
.type
= BT_INTEGER
;
2809 f
->ts
.kind
= gfc_intio_kind
;
2810 if (u
->ts
.kind
!= gfc_c_int_kind
)
2812 ts
.type
= BT_INTEGER
;
2813 ts
.kind
= gfc_c_int_kind
;
2814 ts
.u
.derived
= NULL
;
2816 gfc_convert_type (u
, &ts
, 2);
2819 f
->value
.function
.name
= gfc_get_string (PREFIX ("ftell"));
2824 gfc_resolve_storage_size (gfc_expr
*f
, gfc_expr
*a ATTRIBUTE_UNUSED
,
2827 f
->ts
.type
= BT_INTEGER
;
2829 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2831 f
->ts
.kind
= gfc_default_integer_kind
;
2836 gfc_resolve_sum (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2838 resolve_transformational ("sum", f
, array
, dim
, mask
);
2843 gfc_resolve_symlnk (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
2844 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
2846 f
->ts
.type
= BT_INTEGER
;
2847 f
->ts
.kind
= gfc_default_integer_kind
;
2848 f
->value
.function
.name
= gfc_get_string (PREFIX ("symlnk_i%d"), f
->ts
.kind
);
2852 /* Resolve the g77 compatibility function SYSTEM. */
2855 gfc_resolve_system (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
2857 f
->ts
.type
= BT_INTEGER
;
2859 f
->value
.function
.name
= gfc_get_string (PREFIX ("system"));
2864 gfc_resolve_tan (gfc_expr
*f
, gfc_expr
*x
)
2867 f
->value
.function
.name
2868 = gfc_get_string ("__tan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2873 gfc_resolve_tanh (gfc_expr
*f
, gfc_expr
*x
)
2876 f
->value
.function
.name
2877 = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2881 /* Build an expression for converting degrees to radians. */
2884 get_radians (gfc_expr
*deg
)
2886 gfc_expr
*result
, *factor
;
2887 gfc_actual_arglist
*mod_args
;
2889 gcc_assert (deg
->ts
.type
== BT_REAL
);
2891 /* Set deg = deg % 360 to avoid offsets from large angles. */
2892 factor
= gfc_get_constant_expr (deg
->ts
.type
, deg
->ts
.kind
, °
->where
);
2893 mpfr_set_d (factor
->value
.real
, 360.0, GFC_RND_MODE
);
2895 mod_args
= gfc_get_actual_arglist ();
2896 mod_args
->expr
= deg
;
2897 mod_args
->next
= gfc_get_actual_arglist ();
2898 mod_args
->next
->expr
= factor
;
2900 result
= gfc_get_expr ();
2901 result
->ts
= deg
->ts
;
2902 result
->where
= deg
->where
;
2903 result
->expr_type
= EXPR_FUNCTION
;
2904 result
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_MOD
);
2905 result
->value
.function
.actual
= mod_args
;
2907 /* Set factor = pi / 180. */
2908 factor
= gfc_get_constant_expr (deg
->ts
.type
, deg
->ts
.kind
, °
->where
);
2909 mpfr_const_pi (factor
->value
.real
, GFC_RND_MODE
);
2910 mpfr_div_ui (factor
->value
.real
, factor
->value
.real
, 180, GFC_RND_MODE
);
2912 /* Result is rad = (deg % 360) * (pi / 180). */
2913 result
= gfc_multiply (result
, factor
);
2918 /* Build an expression for converting radians to degrees. */
2921 get_degrees (gfc_expr
*rad
)
2923 gfc_expr
*result
, *factor
;
2924 gfc_actual_arglist
*mod_args
;
2927 gcc_assert (rad
->ts
.type
== BT_REAL
);
2929 /* Set rad = rad % 2pi to avoid offsets from large angles. */
2930 factor
= gfc_get_constant_expr (rad
->ts
.type
, rad
->ts
.kind
, &rad
->where
);
2931 mpfr_const_pi (factor
->value
.real
, GFC_RND_MODE
);
2932 mpfr_mul_ui (factor
->value
.real
, factor
->value
.real
, 2, GFC_RND_MODE
);
2934 mod_args
= gfc_get_actual_arglist ();
2935 mod_args
->expr
= rad
;
2936 mod_args
->next
= gfc_get_actual_arglist ();
2937 mod_args
->next
->expr
= factor
;
2939 result
= gfc_get_expr ();
2940 result
->ts
= rad
->ts
;
2941 result
->where
= rad
->where
;
2942 result
->expr_type
= EXPR_FUNCTION
;
2943 result
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_MOD
);
2944 result
->value
.function
.actual
= mod_args
;
2946 /* Set factor = 180 / pi. */
2947 factor
= gfc_get_constant_expr (rad
->ts
.type
, rad
->ts
.kind
, &rad
->where
);
2948 mpfr_set_ui (factor
->value
.real
, 180, GFC_RND_MODE
);
2950 mpfr_const_pi (tmp
, GFC_RND_MODE
);
2951 mpfr_div (factor
->value
.real
, factor
->value
.real
, tmp
, GFC_RND_MODE
);
2954 /* Result is deg = (rad % 2pi) * (180 / pi). */
2955 result
= gfc_multiply (result
, factor
);
2960 /* Resolve a call to a trig function. */
2963 resolve_trig_call (gfc_expr
*f
, gfc_expr
*x
)
2965 switch (f
->value
.function
.isym
->id
)
2968 return gfc_resolve_acos (f
, x
);
2970 return gfc_resolve_asin (f
, x
);
2972 return gfc_resolve_atan (f
, x
);
2973 case GFC_ISYM_ATAN2
:
2974 /* NB. arg3 is unused for atan2 */
2975 return gfc_resolve_atan2 (f
, x
, NULL
);
2977 return gfc_resolve_cos (f
, x
);
2978 case GFC_ISYM_COTAN
:
2979 return gfc_resolve_cotan (f
, x
);
2981 return gfc_resolve_sin (f
, x
);
2983 return gfc_resolve_tan (f
, x
);
2989 /* Resolve degree trig function as trigd (x) = trig (radians (x)). */
2992 gfc_resolve_trigd (gfc_expr
*f
, gfc_expr
*x
)
2994 if (is_trig_resolved (f
))
2997 x
= get_radians (x
);
2998 f
->value
.function
.actual
->expr
= x
;
3000 resolve_trig_call (f
, x
);
3004 /* Resolve degree inverse trig function as atrigd (x) = degrees (atrig (x)). */
3007 gfc_resolve_atrigd (gfc_expr
*f
, gfc_expr
*x
)
3009 gfc_expr
*result
, *fcopy
;
3011 if (is_trig_resolved (f
))
3014 resolve_trig_call (f
, x
);
3016 fcopy
= copy_replace_function_shallow (f
);
3017 result
= get_degrees (fcopy
);
3018 gfc_replace_expr (f
, result
);
3022 /* Resolve atan2d(x) = degrees(atan2(x)). */
3025 gfc_resolve_atan2d (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
3027 /* Note that we lose the second arg here - that's okay because it is
3028 unused in gfc_resolve_atan2 anyway. */
3029 gfc_resolve_atrigd (f
, x
);
3033 /* Resolve failed_images (team, kind). */
3036 gfc_resolve_failed_images (gfc_expr
*f
, gfc_expr
*team ATTRIBUTE_UNUSED
,
3039 static char failed_images
[] = "_gfortran_caf_failed_images";
3041 f
->ts
.type
= BT_INTEGER
;
3043 f
->ts
.kind
= gfc_default_integer_kind
;
3045 gfc_extract_int (kind
, &f
->ts
.kind
);
3046 f
->value
.function
.name
= failed_images
;
3050 /* Resolve image_status (image, team). */
3053 gfc_resolve_image_status (gfc_expr
*f
, gfc_expr
*image ATTRIBUTE_UNUSED
,
3054 gfc_expr
*team ATTRIBUTE_UNUSED
)
3056 static char image_status
[] = "_gfortran_caf_image_status";
3057 f
->ts
.type
= BT_INTEGER
;
3058 f
->ts
.kind
= gfc_default_integer_kind
;
3059 f
->value
.function
.name
= image_status
;
3063 /* Resolve get_team (). */
3066 gfc_resolve_get_team (gfc_expr
*f
, gfc_expr
*level ATTRIBUTE_UNUSED
)
3068 static char get_team
[] = "_gfortran_caf_get_team";
3070 f
->ts
.type
= BT_INTEGER
;
3071 f
->ts
.kind
= gfc_default_integer_kind
;
3072 f
->value
.function
.name
= get_team
;
3076 /* Resolve image_index (...). */
3079 gfc_resolve_image_index (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
3080 gfc_expr
*sub ATTRIBUTE_UNUSED
)
3082 static char image_index
[] = "__image_index";
3083 f
->ts
.type
= BT_INTEGER
;
3084 f
->ts
.kind
= gfc_default_integer_kind
;
3085 f
->value
.function
.name
= image_index
;
3089 /* Resolve stopped_images (team, kind). */
3092 gfc_resolve_stopped_images (gfc_expr
*f
, gfc_expr
*team ATTRIBUTE_UNUSED
,
3095 static char stopped_images
[] = "_gfortran_caf_stopped_images";
3097 f
->ts
.type
= BT_INTEGER
;
3099 f
->ts
.kind
= gfc_default_integer_kind
;
3101 gfc_extract_int (kind
, &f
->ts
.kind
);
3102 f
->value
.function
.name
= stopped_images
;
3106 /* Resolve team_number (team). */
3109 gfc_resolve_team_number (gfc_expr
*f
, gfc_expr
*team ATTRIBUTE_UNUSED
)
3111 static char team_number
[] = "_gfortran_caf_team_number";
3113 f
->ts
.type
= BT_INTEGER
;
3114 f
->ts
.kind
= gfc_default_integer_kind
;
3115 f
->value
.function
.name
= team_number
;
3120 gfc_resolve_this_image (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
3121 gfc_expr
*distance ATTRIBUTE_UNUSED
)
3123 static char this_image
[] = "__this_image";
3124 if (array
&& gfc_is_coarray (array
))
3125 resolve_bound (f
, array
, dim
, NULL
, "__this_image", true);
3128 f
->ts
.type
= BT_INTEGER
;
3129 f
->ts
.kind
= gfc_default_integer_kind
;
3130 f
->value
.function
.name
= this_image
;
3136 gfc_resolve_time (gfc_expr
*f
)
3138 f
->ts
.type
= BT_INTEGER
;
3140 f
->value
.function
.name
= gfc_get_string (PREFIX ("time_func"));
3145 gfc_resolve_time8 (gfc_expr
*f
)
3147 f
->ts
.type
= BT_INTEGER
;
3149 f
->value
.function
.name
= gfc_get_string (PREFIX ("time8_func"));
3154 gfc_resolve_transfer (gfc_expr
*f
, gfc_expr
*source ATTRIBUTE_UNUSED
,
3155 gfc_expr
*mold
, gfc_expr
*size
)
3157 /* TODO: Make this do something meaningful. */
3158 static char transfer0
[] = "__transfer0", transfer1
[] = "__transfer1";
3160 if (mold
->ts
.type
== BT_CHARACTER
3161 && !mold
->ts
.u
.cl
->length
3162 && gfc_is_constant_expr (mold
))
3165 if (mold
->expr_type
== EXPR_CONSTANT
)
3167 len
= mold
->value
.character
.length
;
3168 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
3173 gfc_constructor
*c
= gfc_constructor_first (mold
->value
.constructor
);
3174 len
= c
->expr
->value
.character
.length
;
3175 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
3182 if (size
== NULL
&& mold
->rank
== 0)
3185 f
->value
.function
.name
= transfer0
;
3190 f
->value
.function
.name
= transfer1
;
3191 if (size
&& gfc_is_constant_expr (size
))
3193 f
->shape
= gfc_get_shape (1);
3194 mpz_init_set (f
->shape
[0], size
->value
.integer
);
3201 gfc_resolve_transpose (gfc_expr
*f
, gfc_expr
*matrix
)
3204 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ref
)
3205 gfc_resolve_substring_charlen (matrix
);
3211 f
->shape
= gfc_get_shape (2);
3212 mpz_init_set (f
->shape
[0], matrix
->shape
[1]);
3213 mpz_init_set (f
->shape
[1], matrix
->shape
[0]);
3216 switch (matrix
->ts
.kind
)
3222 switch (matrix
->ts
.type
)
3226 f
->value
.function
.name
3227 = gfc_get_string (PREFIX ("transpose_%c%d"),
3228 gfc_type_letter (matrix
->ts
.type
),
3234 /* Use the integer routines for real and logical cases. This
3235 assumes they all have the same alignment requirements. */
3236 f
->value
.function
.name
3237 = gfc_get_string (PREFIX ("transpose_i%d"), matrix
->ts
.kind
);
3241 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ts
.kind
== 4)
3242 f
->value
.function
.name
= PREFIX ("transpose_char4");
3244 f
->value
.function
.name
= PREFIX ("transpose");
3250 f
->value
.function
.name
= (matrix
->ts
.type
== BT_CHARACTER
3251 ? PREFIX ("transpose_char")
3252 : PREFIX ("transpose"));
3259 gfc_resolve_trim (gfc_expr
*f
, gfc_expr
*string
)
3261 f
->ts
.type
= BT_CHARACTER
;
3262 f
->ts
.kind
= string
->ts
.kind
;
3263 f
->value
.function
.name
= gfc_get_string ("__trim_%d", string
->ts
.kind
);
3268 gfc_resolve_ubound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3270 resolve_bound (f
, array
, dim
, kind
, "__ubound", false);
3275 gfc_resolve_ucobound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3277 resolve_bound (f
, array
, dim
, kind
, "__ucobound", true);
3281 /* Resolve the g77 compatibility function UMASK. */
3284 gfc_resolve_umask (gfc_expr
*f
, gfc_expr
*n
)
3286 f
->ts
.type
= BT_INTEGER
;
3287 f
->ts
.kind
= n
->ts
.kind
;
3288 f
->value
.function
.name
= gfc_get_string (PREFIX ("umask_i%d"), n
->ts
.kind
);
3292 /* Resolve the g77 compatibility function UNLINK. */
3295 gfc_resolve_unlink (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
3297 f
->ts
.type
= BT_INTEGER
;
3299 f
->value
.function
.name
= gfc_get_string (PREFIX ("unlink"));
3304 gfc_resolve_ttynam (gfc_expr
*f
, gfc_expr
*unit
)
3309 f
->ts
.type
= BT_CHARACTER
;
3310 f
->ts
.kind
= gfc_default_character_kind
;
3312 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3314 ts
.type
= BT_INTEGER
;
3315 ts
.kind
= gfc_c_int_kind
;
3316 ts
.u
.derived
= NULL
;
3318 gfc_convert_type (unit
, &ts
, 2);
3321 f
->value
.function
.name
= gfc_get_string (PREFIX ("ttynam"));
3326 gfc_resolve_unpack (gfc_expr
*f
, gfc_expr
*vector
, gfc_expr
*mask
,
3327 gfc_expr
*field ATTRIBUTE_UNUSED
)
3329 if (vector
->ts
.type
== BT_CHARACTER
&& vector
->ref
)
3330 gfc_resolve_substring_charlen (vector
);
3333 f
->rank
= mask
->rank
;
3334 resolve_mask_arg (mask
);
3336 if (vector
->ts
.type
== BT_CHARACTER
)
3338 if (vector
->ts
.kind
== 1)
3339 f
->value
.function
.name
3340 = gfc_get_string (PREFIX ("unpack%d_char"), field
->rank
> 0 ? 1 : 0);
3342 f
->value
.function
.name
3343 = gfc_get_string (PREFIX ("unpack%d_char%d"),
3344 field
->rank
> 0 ? 1 : 0, vector
->ts
.kind
);
3347 f
->value
.function
.name
3348 = gfc_get_string (PREFIX ("unpack%d"), field
->rank
> 0 ? 1 : 0);
3353 gfc_resolve_verify (gfc_expr
*f
, gfc_expr
*string
,
3354 gfc_expr
*set ATTRIBUTE_UNUSED
,
3355 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
3357 f
->ts
.type
= BT_INTEGER
;
3359 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
3361 f
->ts
.kind
= gfc_default_integer_kind
;
3362 f
->value
.function
.name
= gfc_get_string ("__verify_%d", string
->ts
.kind
);
3367 gfc_resolve_xor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
3369 f
->ts
.type
= i
->ts
.type
;
3370 f
->ts
.kind
= gfc_kind_max (i
, j
);
3372 if (i
->ts
.kind
!= j
->ts
.kind
)
3374 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
3375 gfc_convert_type (j
, &i
->ts
, 2);
3377 gfc_convert_type (i
, &j
->ts
, 2);
3380 f
->value
.function
.name
3381 = gfc_get_string ("__xor_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
3385 /* Intrinsic subroutine resolution. */
3388 gfc_resolve_alarm_sub (gfc_code
*c
)
3391 gfc_expr
*seconds
, *handler
;
3395 seconds
= c
->ext
.actual
->expr
;
3396 handler
= c
->ext
.actual
->next
->expr
;
3397 ts
.type
= BT_INTEGER
;
3398 ts
.kind
= gfc_c_int_kind
;
3400 /* handler can be either BT_INTEGER or BT_PROCEDURE.
3401 In all cases, the status argument is of default integer kind
3402 (enforced in check.c) so that the function suffix is fixed. */
3403 if (handler
->ts
.type
== BT_INTEGER
)
3405 if (handler
->ts
.kind
!= gfc_c_int_kind
)
3406 gfc_convert_type (handler
, &ts
, 2);
3407 name
= gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
3408 gfc_default_integer_kind
);
3411 name
= gfc_get_string (PREFIX ("alarm_sub_i%d"),
3412 gfc_default_integer_kind
);
3414 if (seconds
->ts
.kind
!= gfc_c_int_kind
)
3415 gfc_convert_type (seconds
, &ts
, 2);
3417 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3421 gfc_resolve_cpu_time (gfc_code
*c
)
3424 name
= gfc_get_string (PREFIX ("cpu_time_%d"), c
->ext
.actual
->expr
->ts
.kind
);
3425 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3429 /* Create a formal arglist based on an actual one and set the INTENTs given. */
3431 static gfc_formal_arglist
*
3432 create_formal_for_intents (gfc_actual_arglist
* actual
, const sym_intent
* ints
)
3434 gfc_formal_arglist
* head
;
3435 gfc_formal_arglist
* tail
;
3441 head
= tail
= gfc_get_formal_arglist ();
3442 for (i
= 0; actual
; actual
= actual
->next
, tail
= tail
->next
, ++i
)
3446 sym
= gfc_new_symbol ("dummyarg", NULL
);
3447 sym
->ts
= actual
->expr
->ts
;
3449 sym
->attr
.intent
= ints
[i
];
3453 tail
->next
= gfc_get_formal_arglist ();
3461 gfc_resolve_atomic_def (gfc_code
*c
)
3463 const char *name
= "atomic_define";
3464 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3469 gfc_resolve_atomic_ref (gfc_code
*c
)
3471 const char *name
= "atomic_ref";
3472 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3476 gfc_resolve_event_query (gfc_code
*c
)
3478 const char *name
= "event_query";
3479 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3483 gfc_resolve_mvbits (gfc_code
*c
)
3485 static const sym_intent INTENTS
[] = {INTENT_IN
, INTENT_IN
, INTENT_IN
,
3486 INTENT_INOUT
, INTENT_IN
};
3492 /* FROMPOS, LEN and TOPOS are restricted to small values. As such,
3493 they will be converted so that they fit into a C int. */
3494 ts
.type
= BT_INTEGER
;
3495 ts
.kind
= gfc_c_int_kind
;
3496 if (c
->ext
.actual
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
3497 gfc_convert_type (c
->ext
.actual
->next
->expr
, &ts
, 2);
3498 if (c
->ext
.actual
->next
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
3499 gfc_convert_type (c
->ext
.actual
->next
->next
->expr
, &ts
, 2);
3500 if (c
->ext
.actual
->next
->next
->next
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
3501 gfc_convert_type (c
->ext
.actual
->next
->next
->next
->next
->expr
, &ts
, 2);
3503 /* TO and FROM are guaranteed to have the same kind parameter. */
3504 name
= gfc_get_string (PREFIX ("mvbits_i%d"),
3505 c
->ext
.actual
->expr
->ts
.kind
);
3506 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3507 /* Mark as elemental subroutine as this does not happen automatically. */
3508 c
->resolved_sym
->attr
.elemental
= 1;
3510 /* Create a dummy formal arglist so the INTENTs are known later for purpose
3511 of creating temporaries. */
3512 c
->resolved_sym
->formal
= create_formal_for_intents (c
->ext
.actual
, INTENTS
);
3516 /* Set up the call to RANDOM_INIT. */
3519 gfc_resolve_random_init (gfc_code
*c
)
3522 name
= gfc_get_string (PREFIX ("random_init"));
3523 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3528 gfc_resolve_random_number (gfc_code
*c
)
3533 kind
= c
->ext
.actual
->expr
->ts
.kind
;
3534 if (c
->ext
.actual
->expr
->rank
== 0)
3535 name
= gfc_get_string (PREFIX ("random_r%d"), kind
);
3537 name
= gfc_get_string (PREFIX ("arandom_r%d"), kind
);
3539 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3544 gfc_resolve_random_seed (gfc_code
*c
)
3548 name
= gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind
);
3549 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3554 gfc_resolve_rename_sub (gfc_code
*c
)
3559 /* Find the type of status. If not present use default integer kind. */
3560 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3561 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3563 kind
= gfc_default_integer_kind
;
3565 name
= gfc_get_string (PREFIX ("rename_i%d_sub"), kind
);
3566 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3571 gfc_resolve_link_sub (gfc_code
*c
)
3576 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3577 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3579 kind
= gfc_default_integer_kind
;
3581 name
= gfc_get_string (PREFIX ("link_i%d_sub"), kind
);
3582 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3587 gfc_resolve_symlnk_sub (gfc_code
*c
)
3592 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3593 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3595 kind
= gfc_default_integer_kind
;
3597 name
= gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind
);
3598 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3602 /* G77 compatibility subroutines dtime() and etime(). */
3605 gfc_resolve_dtime_sub (gfc_code
*c
)
3608 name
= gfc_get_string (PREFIX ("dtime_sub"));
3609 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3613 gfc_resolve_etime_sub (gfc_code
*c
)
3616 name
= gfc_get_string (PREFIX ("etime_sub"));
3617 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3621 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
3624 gfc_resolve_itime (gfc_code
*c
)
3627 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
3628 gfc_default_integer_kind
));
3632 gfc_resolve_idate (gfc_code
*c
)
3635 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
3636 gfc_default_integer_kind
));
3640 gfc_resolve_ltime (gfc_code
*c
)
3643 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
3644 gfc_default_integer_kind
));
3648 gfc_resolve_gmtime (gfc_code
*c
)
3651 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
3652 gfc_default_integer_kind
));
3656 /* G77 compatibility subroutine second(). */
3659 gfc_resolve_second_sub (gfc_code
*c
)
3662 name
= gfc_get_string (PREFIX ("second_sub"));
3663 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3668 gfc_resolve_sleep_sub (gfc_code
*c
)
3673 if (c
->ext
.actual
->expr
!= NULL
)
3674 kind
= c
->ext
.actual
->expr
->ts
.kind
;
3676 kind
= gfc_default_integer_kind
;
3678 name
= gfc_get_string (PREFIX ("sleep_i%d_sub"), kind
);
3679 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3683 /* G77 compatibility function srand(). */
3686 gfc_resolve_srand (gfc_code
*c
)
3689 name
= gfc_get_string (PREFIX ("srand"));
3690 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3694 /* Resolve the getarg intrinsic subroutine. */
3697 gfc_resolve_getarg (gfc_code
*c
)
3701 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_default_integer_kind
)
3706 ts
.type
= BT_INTEGER
;
3707 ts
.kind
= gfc_default_integer_kind
;
3709 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3712 name
= gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind
);
3713 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3717 /* Resolve the getcwd intrinsic subroutine. */
3720 gfc_resolve_getcwd_sub (gfc_code
*c
)
3725 if (c
->ext
.actual
->next
->expr
!= NULL
)
3726 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3728 kind
= gfc_default_integer_kind
;
3730 name
= gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind
);
3731 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3735 /* Resolve the get_command intrinsic subroutine. */
3738 gfc_resolve_get_command (gfc_code
*c
)
3742 kind
= gfc_default_integer_kind
;
3743 name
= gfc_get_string (PREFIX ("get_command_i%d"), kind
);
3744 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3748 /* Resolve the get_command_argument intrinsic subroutine. */
3751 gfc_resolve_get_command_argument (gfc_code
*c
)
3755 kind
= gfc_default_integer_kind
;
3756 name
= gfc_get_string (PREFIX ("get_command_argument_i%d"), kind
);
3757 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3761 /* Resolve the get_environment_variable intrinsic subroutine. */
3764 gfc_resolve_get_environment_variable (gfc_code
*code
)
3768 kind
= gfc_default_integer_kind
;
3769 name
= gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind
);
3770 code
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3775 gfc_resolve_signal_sub (gfc_code
*c
)
3778 gfc_expr
*number
, *handler
, *status
;
3782 number
= c
->ext
.actual
->expr
;
3783 handler
= c
->ext
.actual
->next
->expr
;
3784 status
= c
->ext
.actual
->next
->next
->expr
;
3785 ts
.type
= BT_INTEGER
;
3786 ts
.kind
= gfc_c_int_kind
;
3788 /* handler can be either BT_INTEGER or BT_PROCEDURE */
3789 if (handler
->ts
.type
== BT_INTEGER
)
3791 if (handler
->ts
.kind
!= gfc_c_int_kind
)
3792 gfc_convert_type (handler
, &ts
, 2);
3793 name
= gfc_get_string (PREFIX ("signal_sub_int"));
3796 name
= gfc_get_string (PREFIX ("signal_sub"));
3798 if (number
->ts
.kind
!= gfc_c_int_kind
)
3799 gfc_convert_type (number
, &ts
, 2);
3800 if (status
!= NULL
&& status
->ts
.kind
!= gfc_c_int_kind
)
3801 gfc_convert_type (status
, &ts
, 2);
3803 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3807 /* Resolve the SYSTEM intrinsic subroutine. */
3810 gfc_resolve_system_sub (gfc_code
*c
)
3813 name
= gfc_get_string (PREFIX ("system_sub"));
3814 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3818 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
3821 gfc_resolve_system_clock (gfc_code
*c
)
3825 gfc_expr
*count
= c
->ext
.actual
->expr
;
3826 gfc_expr
*count_max
= c
->ext
.actual
->next
->next
->expr
;
3828 /* The INTEGER(8) version has higher precision, it is used if both COUNT
3829 and COUNT_MAX can hold 64-bit values, or are absent. */
3830 if ((!count
|| count
->ts
.kind
>= 8)
3831 && (!count_max
|| count_max
->ts
.kind
>= 8))
3834 kind
= gfc_default_integer_kind
;
3836 name
= gfc_get_string (PREFIX ("system_clock_%d"), kind
);
3837 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3841 /* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine. */
3843 gfc_resolve_execute_command_line (gfc_code
*c
)
3846 name
= gfc_get_string (PREFIX ("execute_command_line_i%d"),
3847 gfc_default_integer_kind
);
3848 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3852 /* Resolve the EXIT intrinsic subroutine. */
3855 gfc_resolve_exit (gfc_code
*c
)
3862 /* The STATUS argument has to be of default kind. If it is not,
3864 ts
.type
= BT_INTEGER
;
3865 ts
.kind
= gfc_default_integer_kind
;
3866 n
= c
->ext
.actual
->expr
;
3867 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3868 gfc_convert_type (n
, &ts
, 2);
3870 name
= gfc_get_string (PREFIX ("exit_i%d"), ts
.kind
);
3871 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3875 /* Resolve the FLUSH intrinsic subroutine. */
3878 gfc_resolve_flush (gfc_code
*c
)
3885 ts
.type
= BT_INTEGER
;
3886 ts
.kind
= gfc_default_integer_kind
;
3887 n
= c
->ext
.actual
->expr
;
3888 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3889 gfc_convert_type (n
, &ts
, 2);
3891 name
= gfc_get_string (PREFIX ("flush_i%d"), ts
.kind
);
3892 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3897 gfc_resolve_ctime_sub (gfc_code
*c
)
3902 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3903 if (c
->ext
.actual
->expr
->ts
.kind
!= 8)
3905 ts
.type
= BT_INTEGER
;
3907 ts
.u
.derived
= NULL
;
3909 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3912 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3917 gfc_resolve_fdate_sub (gfc_code
*c
)
3919 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3924 gfc_resolve_gerror (gfc_code
*c
)
3926 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3931 gfc_resolve_getlog (gfc_code
*c
)
3933 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3938 gfc_resolve_hostnm_sub (gfc_code
*c
)
3943 if (c
->ext
.actual
->next
->expr
!= NULL
)
3944 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3946 kind
= gfc_default_integer_kind
;
3948 name
= gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind
);
3949 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3954 gfc_resolve_perror (gfc_code
*c
)
3956 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3959 /* Resolve the STAT and FSTAT intrinsic subroutines. */
3962 gfc_resolve_stat_sub (gfc_code
*c
)
3965 name
= gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind
);
3966 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3971 gfc_resolve_lstat_sub (gfc_code
*c
)
3974 name
= gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind
);
3975 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3980 gfc_resolve_fstat_sub (gfc_code
*c
)
3986 u
= c
->ext
.actual
->expr
;
3987 ts
= &c
->ext
.actual
->next
->expr
->ts
;
3988 if (u
->ts
.kind
!= ts
->kind
)
3989 gfc_convert_type (u
, ts
, 2);
3990 name
= gfc_get_string (PREFIX ("fstat_i%d_sub"), ts
->kind
);
3991 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3996 gfc_resolve_fgetc_sub (gfc_code
*c
)
4003 u
= c
->ext
.actual
->expr
;
4004 st
= c
->ext
.actual
->next
->next
->expr
;
4006 if (u
->ts
.kind
!= gfc_c_int_kind
)
4008 ts
.type
= BT_INTEGER
;
4009 ts
.kind
= gfc_c_int_kind
;
4010 ts
.u
.derived
= NULL
;
4012 gfc_convert_type (u
, &ts
, 2);
4016 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), st
->ts
.kind
);
4018 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind
);
4020 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
4025 gfc_resolve_fget_sub (gfc_code
*c
)
4030 st
= c
->ext
.actual
->next
->expr
;
4032 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), st
->ts
.kind
);
4034 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind
);
4036 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
4041 gfc_resolve_fputc_sub (gfc_code
*c
)
4048 u
= c
->ext
.actual
->expr
;
4049 st
= c
->ext
.actual
->next
->next
->expr
;
4051 if (u
->ts
.kind
!= gfc_c_int_kind
)
4053 ts
.type
= BT_INTEGER
;
4054 ts
.kind
= gfc_c_int_kind
;
4055 ts
.u
.derived
= NULL
;
4057 gfc_convert_type (u
, &ts
, 2);
4061 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), st
->ts
.kind
);
4063 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind
);
4065 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
4070 gfc_resolve_fput_sub (gfc_code
*c
)
4075 st
= c
->ext
.actual
->next
->expr
;
4077 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), st
->ts
.kind
);
4079 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind
);
4081 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
4086 gfc_resolve_fseek_sub (gfc_code
*c
)
4094 unit
= c
->ext
.actual
->expr
;
4095 offset
= c
->ext
.actual
->next
->expr
;
4096 whence
= c
->ext
.actual
->next
->next
->expr
;
4098 if (unit
->ts
.kind
!= gfc_c_int_kind
)
4100 ts
.type
= BT_INTEGER
;
4101 ts
.kind
= gfc_c_int_kind
;
4102 ts
.u
.derived
= NULL
;
4104 gfc_convert_type (unit
, &ts
, 2);
4107 if (offset
->ts
.kind
!= gfc_intio_kind
)
4109 ts
.type
= BT_INTEGER
;
4110 ts
.kind
= gfc_intio_kind
;
4111 ts
.u
.derived
= NULL
;
4113 gfc_convert_type (offset
, &ts
, 2);
4116 if (whence
->ts
.kind
!= gfc_c_int_kind
)
4118 ts
.type
= BT_INTEGER
;
4119 ts
.kind
= gfc_c_int_kind
;
4120 ts
.u
.derived
= NULL
;
4122 gfc_convert_type (whence
, &ts
, 2);
4125 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
4129 gfc_resolve_ftell_sub (gfc_code
*c
)
4137 unit
= c
->ext
.actual
->expr
;
4138 offset
= c
->ext
.actual
->next
->expr
;
4140 if (unit
->ts
.kind
!= gfc_c_int_kind
)
4142 ts
.type
= BT_INTEGER
;
4143 ts
.kind
= gfc_c_int_kind
;
4144 ts
.u
.derived
= NULL
;
4146 gfc_convert_type (unit
, &ts
, 2);
4149 name
= gfc_get_string (PREFIX ("ftell_i%d_sub"), offset
->ts
.kind
);
4150 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
4155 gfc_resolve_ttynam_sub (gfc_code
*c
)
4160 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
4162 ts
.type
= BT_INTEGER
;
4163 ts
.kind
= gfc_c_int_kind
;
4164 ts
.u
.derived
= NULL
;
4166 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
4169 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
4173 /* Resolve the UMASK intrinsic subroutine. */
4176 gfc_resolve_umask_sub (gfc_code
*c
)
4181 if (c
->ext
.actual
->next
->expr
!= NULL
)
4182 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
4184 kind
= gfc_default_integer_kind
;
4186 name
= gfc_get_string (PREFIX ("umask_i%d_sub"), kind
);
4187 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
4190 /* Resolve the UNLINK intrinsic subroutine. */
4193 gfc_resolve_unlink_sub (gfc_code
*c
)
4198 if (c
->ext
.actual
->next
->expr
!= NULL
)
4199 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
4201 kind
= gfc_default_integer_kind
;
4203 name
= gfc_get_string (PREFIX ("unlink_i%d_sub"), kind
);
4204 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);