1 /* Intrinsic function resolution.
2 Copyright (C) 2000-2017 Free Software Foundation, Inc.
3 Contributed by Andy Vaught & Katherine Holcomb
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
22 /* Assign name and types to intrinsic procedures. For functions, the
23 first argument to a resolution function is an expression pointer to
24 the original function node and the rest are pointers to the
25 arguments of the function call. For subroutines, a pointer to the
26 code node is passed. The result type and library subroutine name
27 are generally set according to the function arguments. */
31 #include "coretypes.h"
34 #include "stringpool.h"
35 #include "intrinsic.h"
36 #include "constructor.h"
39 /* Given printf-like arguments, return a stable version of the result string.
41 We already have a working, optimized string hashing table in the form of
42 the identifier table. Reusing this table is likely not to be wasted,
43 since if the function name makes it to the gimple output of the frontend,
44 we'll have to create the identifier anyway. */
47 gfc_get_string (const char *format
, ...)
54 /* Handle common case without vsnprintf and temporary buffer. */
55 if (format
[0] == '%' && format
[1] == 's' && format
[2] == '\0')
57 va_start (ap
, format
);
58 str
= va_arg (ap
, const char *);
63 va_start (ap
, format
);
64 vsnprintf (temp_name
, sizeof (temp_name
), format
, ap
);
66 temp_name
[sizeof (temp_name
) - 1] = 0;
70 ident
= get_identifier (str
);
71 return IDENTIFIER_POINTER (ident
);
74 /* MERGE and SPREAD need to have source charlen's present for passing
75 to the result expression. */
77 check_charlen_present (gfc_expr
*source
)
79 if (source
->ts
.u
.cl
== NULL
)
80 source
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
82 if (source
->expr_type
== EXPR_CONSTANT
)
84 source
->ts
.u
.cl
->length
85 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
86 source
->value
.character
.length
);
89 else if (source
->expr_type
== EXPR_ARRAY
)
91 gfc_constructor
*c
= gfc_constructor_first (source
->value
.constructor
);
92 source
->ts
.u
.cl
->length
93 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
94 c
->expr
->value
.character
.length
);
98 /* Helper function for resolving the "mask" argument. */
101 resolve_mask_arg (gfc_expr
*mask
)
109 /* For the scalar case, coerce the mask to kind=4 unconditionally
110 (because this is the only kind we have a library function
113 if (mask
->ts
.kind
!= 4)
115 ts
.type
= BT_LOGICAL
;
117 gfc_convert_type (mask
, &ts
, 2);
122 /* In the library, we access the mask with a GFC_LOGICAL_1
123 argument. No need to waste memory if we are about to create
124 a temporary array. */
125 if (mask
->expr_type
== EXPR_OP
&& mask
->ts
.kind
!= 1)
127 ts
.type
= BT_LOGICAL
;
129 gfc_convert_type_warn (mask
, &ts
, 2, 0);
136 resolve_bound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
,
137 const char *name
, bool coarray
)
139 f
->ts
.type
= BT_INTEGER
;
141 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
143 f
->ts
.kind
= gfc_default_integer_kind
;
148 if (array
->rank
!= -1)
150 f
->shape
= gfc_get_shape (1);
151 mpz_init_set_ui (f
->shape
[0], coarray
? gfc_get_corank (array
)
156 f
->value
.function
.name
= gfc_get_string ("%s", name
);
161 resolve_transformational (const char *name
, gfc_expr
*f
, gfc_expr
*array
,
162 gfc_expr
*dim
, gfc_expr
*mask
)
175 resolve_mask_arg (mask
);
182 f
->rank
= array
->rank
- 1;
183 f
->shape
= gfc_copy_shape_excluding (array
->shape
, array
->rank
, dim
);
184 gfc_resolve_dim_arg (dim
);
187 f
->value
.function
.name
188 = gfc_get_string (PREFIX ("%s%s_%c%d"), prefix
, name
,
189 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
193 /********************** Resolution functions **********************/
197 gfc_resolve_abs (gfc_expr
*f
, gfc_expr
*a
)
200 if (f
->ts
.type
== BT_COMPLEX
)
201 f
->ts
.type
= BT_REAL
;
203 f
->value
.function
.name
204 = gfc_get_string ("__abs_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
209 gfc_resolve_access (gfc_expr
*f
, gfc_expr
*name ATTRIBUTE_UNUSED
,
210 gfc_expr
*mode ATTRIBUTE_UNUSED
)
212 f
->ts
.type
= BT_INTEGER
;
213 f
->ts
.kind
= gfc_c_int_kind
;
214 f
->value
.function
.name
= PREFIX ("access_func");
219 gfc_resolve_adjustl (gfc_expr
*f
, gfc_expr
*string
)
221 f
->ts
.type
= BT_CHARACTER
;
222 f
->ts
.kind
= string
->ts
.kind
;
224 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, string
->ts
.u
.cl
);
226 f
->value
.function
.name
= gfc_get_string ("__adjustl_s%d", f
->ts
.kind
);
231 gfc_resolve_adjustr (gfc_expr
*f
, gfc_expr
*string
)
233 f
->ts
.type
= BT_CHARACTER
;
234 f
->ts
.kind
= string
->ts
.kind
;
236 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, string
->ts
.u
.cl
);
238 f
->value
.function
.name
= gfc_get_string ("__adjustr_s%d", f
->ts
.kind
);
243 gfc_resolve_char_achar (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*kind
,
246 f
->ts
.type
= BT_CHARACTER
;
247 f
->ts
.kind
= (kind
== NULL
)
248 ? gfc_default_character_kind
: mpz_get_si (kind
->value
.integer
);
249 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
250 f
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
252 f
->value
.function
.name
253 = gfc_get_string ("__%schar_%d_%c%d", is_achar
? "a" : "", f
->ts
.kind
,
254 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
259 gfc_resolve_achar (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*kind
)
261 gfc_resolve_char_achar (f
, x
, kind
, true);
266 gfc_resolve_acos (gfc_expr
*f
, gfc_expr
*x
)
269 f
->value
.function
.name
270 = gfc_get_string ("__acos_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
275 gfc_resolve_acosh (gfc_expr
*f
, gfc_expr
*x
)
278 f
->value
.function
.name
279 = gfc_get_string ("__acosh_%c%d", gfc_type_letter (x
->ts
.type
),
285 gfc_resolve_aimag (gfc_expr
*f
, gfc_expr
*x
)
287 f
->ts
.type
= BT_REAL
;
288 f
->ts
.kind
= x
->ts
.kind
;
289 f
->value
.function
.name
290 = gfc_get_string ("__aimag_%c%d", gfc_type_letter (x
->ts
.type
),
296 gfc_resolve_and (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
298 f
->ts
.type
= i
->ts
.type
;
299 f
->ts
.kind
= gfc_kind_max (i
, j
);
301 if (i
->ts
.kind
!= j
->ts
.kind
)
303 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
304 gfc_convert_type (j
, &i
->ts
, 2);
306 gfc_convert_type (i
, &j
->ts
, 2);
309 f
->value
.function
.name
310 = gfc_get_string ("__and_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
315 gfc_resolve_aint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
320 f
->ts
.type
= a
->ts
.type
;
321 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
323 if (a
->ts
.kind
!= f
->ts
.kind
)
325 ts
.type
= f
->ts
.type
;
326 ts
.kind
= f
->ts
.kind
;
327 gfc_convert_type (a
, &ts
, 2);
329 /* The resolved name is only used for specific intrinsics where
330 the return kind is the same as the arg kind. */
331 f
->value
.function
.name
332 = gfc_get_string ("__aint_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
337 gfc_resolve_dint (gfc_expr
*f
, gfc_expr
*a
)
339 gfc_resolve_aint (f
, a
, NULL
);
344 gfc_resolve_all (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
)
350 gfc_resolve_dim_arg (dim
);
351 f
->rank
= mask
->rank
- 1;
352 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
355 f
->value
.function
.name
356 = gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask
->ts
.type
),
362 gfc_resolve_anint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
367 f
->ts
.type
= a
->ts
.type
;
368 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
370 if (a
->ts
.kind
!= f
->ts
.kind
)
372 ts
.type
= f
->ts
.type
;
373 ts
.kind
= f
->ts
.kind
;
374 gfc_convert_type (a
, &ts
, 2);
377 /* The resolved name is only used for specific intrinsics where
378 the return kind is the same as the arg kind. */
379 f
->value
.function
.name
380 = gfc_get_string ("__anint_%c%d", gfc_type_letter (a
->ts
.type
),
386 gfc_resolve_dnint (gfc_expr
*f
, gfc_expr
*a
)
388 gfc_resolve_anint (f
, a
, NULL
);
393 gfc_resolve_any (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
)
399 gfc_resolve_dim_arg (dim
);
400 f
->rank
= mask
->rank
- 1;
401 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
404 f
->value
.function
.name
405 = gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask
->ts
.type
),
411 gfc_resolve_asin (gfc_expr
*f
, gfc_expr
*x
)
414 f
->value
.function
.name
415 = gfc_get_string ("__asin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
419 gfc_resolve_asinh (gfc_expr
*f
, gfc_expr
*x
)
422 f
->value
.function
.name
423 = gfc_get_string ("__asinh_%c%d", gfc_type_letter (x
->ts
.type
),
428 gfc_resolve_atan (gfc_expr
*f
, gfc_expr
*x
)
431 f
->value
.function
.name
432 = gfc_get_string ("__atan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
436 gfc_resolve_atanh (gfc_expr
*f
, gfc_expr
*x
)
439 f
->value
.function
.name
440 = gfc_get_string ("__atanh_%c%d", gfc_type_letter (x
->ts
.type
),
445 gfc_resolve_atan2 (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
448 f
->value
.function
.name
449 = gfc_get_string ("__atan2_%c%d", gfc_type_letter (x
->ts
.type
),
454 /* Resolve the BESYN and BESJN intrinsics. */
457 gfc_resolve_besn (gfc_expr
*f
, gfc_expr
*n
, gfc_expr
*x
)
463 if (n
->ts
.kind
!= gfc_c_int_kind
)
465 ts
.type
= BT_INTEGER
;
466 ts
.kind
= gfc_c_int_kind
;
467 gfc_convert_type (n
, &ts
, 2);
469 f
->value
.function
.name
= gfc_get_string ("<intrinsic>");
474 gfc_resolve_bessel_n2 (gfc_expr
*f
, gfc_expr
*n1
, gfc_expr
*n2
, gfc_expr
*x
)
481 if (n1
->expr_type
== EXPR_CONSTANT
&& n2
->expr_type
== EXPR_CONSTANT
)
483 f
->shape
= gfc_get_shape (1);
484 mpz_init (f
->shape
[0]);
485 mpz_sub (f
->shape
[0], n2
->value
.integer
, n1
->value
.integer
);
486 mpz_add_ui (f
->shape
[0], f
->shape
[0], 1);
489 if (n1
->ts
.kind
!= gfc_c_int_kind
)
491 ts
.type
= BT_INTEGER
;
492 ts
.kind
= gfc_c_int_kind
;
493 gfc_convert_type (n1
, &ts
, 2);
496 if (n2
->ts
.kind
!= gfc_c_int_kind
)
498 ts
.type
= BT_INTEGER
;
499 ts
.kind
= gfc_c_int_kind
;
500 gfc_convert_type (n2
, &ts
, 2);
503 if (f
->value
.function
.isym
->id
== GFC_ISYM_JN2
)
504 f
->value
.function
.name
= gfc_get_string (PREFIX ("bessel_jn_r%d"),
507 f
->value
.function
.name
= gfc_get_string (PREFIX ("bessel_yn_r%d"),
513 gfc_resolve_btest (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos
)
515 f
->ts
.type
= BT_LOGICAL
;
516 f
->ts
.kind
= gfc_default_logical_kind
;
517 f
->value
.function
.name
518 = gfc_get_string ("__btest_%d_%d", i
->ts
.kind
, pos
->ts
.kind
);
523 gfc_resolve_c_loc (gfc_expr
*f
, gfc_expr
*x ATTRIBUTE_UNUSED
)
525 f
->ts
= f
->value
.function
.isym
->ts
;
530 gfc_resolve_c_funloc (gfc_expr
*f
, gfc_expr
*x ATTRIBUTE_UNUSED
)
532 f
->ts
= f
->value
.function
.isym
->ts
;
537 gfc_resolve_ceiling (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
539 f
->ts
.type
= BT_INTEGER
;
540 f
->ts
.kind
= (kind
== NULL
)
541 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
542 f
->value
.function
.name
543 = gfc_get_string ("__ceiling_%d_%c%d", f
->ts
.kind
,
544 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
549 gfc_resolve_char (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
551 gfc_resolve_char_achar (f
, a
, kind
, false);
556 gfc_resolve_chdir (gfc_expr
*f
, gfc_expr
*d ATTRIBUTE_UNUSED
)
558 f
->ts
.type
= BT_INTEGER
;
559 f
->ts
.kind
= gfc_default_integer_kind
;
560 f
->value
.function
.name
= gfc_get_string (PREFIX ("chdir_i%d"), f
->ts
.kind
);
565 gfc_resolve_chdir_sub (gfc_code
*c
)
570 if (c
->ext
.actual
->next
->expr
!= NULL
)
571 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
573 kind
= gfc_default_integer_kind
;
575 name
= gfc_get_string (PREFIX ("chdir_i%d_sub"), kind
);
576 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
581 gfc_resolve_chmod (gfc_expr
*f
, gfc_expr
*name ATTRIBUTE_UNUSED
,
582 gfc_expr
*mode ATTRIBUTE_UNUSED
)
584 f
->ts
.type
= BT_INTEGER
;
585 f
->ts
.kind
= gfc_c_int_kind
;
586 f
->value
.function
.name
= PREFIX ("chmod_func");
591 gfc_resolve_chmod_sub (gfc_code
*c
)
596 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
597 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
599 kind
= gfc_default_integer_kind
;
601 name
= gfc_get_string (PREFIX ("chmod_i%d_sub"), kind
);
602 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
607 gfc_resolve_cmplx (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*kind
)
609 f
->ts
.type
= BT_COMPLEX
;
610 f
->ts
.kind
= (kind
== NULL
)
611 ? gfc_default_real_kind
: mpz_get_si (kind
->value
.integer
);
614 f
->value
.function
.name
615 = gfc_get_string ("__cmplx0_%d_%c%d", f
->ts
.kind
,
616 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
618 f
->value
.function
.name
619 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f
->ts
.kind
,
620 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
,
621 gfc_type_letter (y
->ts
.type
), y
->ts
.kind
);
626 gfc_resolve_dcmplx (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
)
628 gfc_resolve_cmplx (f
, x
, y
, gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
629 gfc_default_double_kind
));
634 gfc_resolve_complex (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
)
638 if (x
->ts
.type
== BT_INTEGER
)
640 if (y
->ts
.type
== BT_INTEGER
)
641 kind
= gfc_default_real_kind
;
647 if (y
->ts
.type
== BT_REAL
)
648 kind
= (x
->ts
.kind
> y
->ts
.kind
) ? x
->ts
.kind
: y
->ts
.kind
;
653 f
->ts
.type
= BT_COMPLEX
;
655 f
->value
.function
.name
656 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f
->ts
.kind
,
657 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
,
658 gfc_type_letter (y
->ts
.type
), y
->ts
.kind
);
663 gfc_resolve_conjg (gfc_expr
*f
, gfc_expr
*x
)
666 f
->value
.function
.name
= gfc_get_string ("__conjg_%d", x
->ts
.kind
);
671 gfc_resolve_cos (gfc_expr
*f
, gfc_expr
*x
)
674 f
->value
.function
.name
675 = gfc_get_string ("__cos_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
680 gfc_resolve_cosh (gfc_expr
*f
, gfc_expr
*x
)
683 f
->value
.function
.name
684 = gfc_get_string ("__cosh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
688 /* Our replacement of elements of a trig call with an EXPR_OP (e.g.
689 multiplying the result or operands by a factor to convert to/from degrees)
690 will cause the resolve_* function to be invoked again when resolving the
691 freshly created EXPR_OP. See gfc_resolve_trigd, gfc_resolve_atrigd,
692 gfc_resolve_cotan. We must observe this and avoid recursively creating
693 layers of nested EXPR_OP expressions. */
696 is_trig_resolved (gfc_expr
*f
)
698 /* We know we've already resolved the function if we see the lib call
699 starting with '__'. */
700 return (f
->value
.function
.name
!= NULL
701 && strncmp ("__", f
->value
.function
.name
, 2) == 0);
704 /* Return a shallow copy of the function expression f. The original expression
705 has its pointers cleared so that it may be freed without affecting the
706 shallow copy. This is similar to gfc_copy_expr, but doesn't perform a deep
707 copy of the argument list, allowing it to be reused somewhere else,
708 setting the expression up nicely for gfc_replace_expr. */
711 copy_replace_function_shallow (gfc_expr
*f
)
714 gfc_actual_arglist
*args
;
716 /* The only thing deep-copied in gfc_copy_expr is args. */
717 args
= f
->value
.function
.actual
;
718 f
->value
.function
.actual
= NULL
;
719 fcopy
= gfc_copy_expr (f
);
720 fcopy
->value
.function
.actual
= args
;
722 /* Clear the old function so the shallow copy is not affected if the old
723 expression is freed. */
724 f
->value
.function
.name
= NULL
;
725 f
->value
.function
.isym
= NULL
;
726 f
->value
.function
.actual
= NULL
;
727 f
->value
.function
.esym
= NULL
;
735 /* Resolve cotan = cos / sin. */
738 gfc_resolve_cotan (gfc_expr
*f
, gfc_expr
*x
)
740 gfc_expr
*result
, *fcopy
, *sin
;
741 gfc_actual_arglist
*sin_args
;
743 if (is_trig_resolved (f
))
746 /* Compute cotan (x) = cos (x) / sin (x). */
747 f
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_COS
);
748 gfc_resolve_cos (f
, x
);
750 sin_args
= gfc_get_actual_arglist ();
751 sin_args
->expr
= gfc_copy_expr (x
);
753 sin
= gfc_get_expr ();
755 sin
->where
= f
->where
;
756 sin
->expr_type
= EXPR_FUNCTION
;
757 sin
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_SIN
);
758 sin
->value
.function
.actual
= sin_args
;
759 gfc_resolve_sin (sin
, sin_args
->expr
);
761 /* Replace f with cos/sin - we do this in place in f for the caller. */
762 fcopy
= copy_replace_function_shallow (f
);
763 result
= gfc_divide (fcopy
, sin
);
764 gfc_replace_expr (f
, result
);
769 gfc_resolve_count (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
771 f
->ts
.type
= BT_INTEGER
;
773 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
775 f
->ts
.kind
= gfc_default_integer_kind
;
779 f
->rank
= mask
->rank
- 1;
780 gfc_resolve_dim_arg (dim
);
781 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
784 resolve_mask_arg (mask
);
786 f
->value
.function
.name
787 = gfc_get_string (PREFIX ("count_%d_%c"), f
->ts
.kind
,
788 gfc_type_letter (mask
->ts
.type
));
793 gfc_resolve_cshift (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*shift
,
798 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
799 gfc_resolve_substring_charlen (array
);
802 f
->rank
= array
->rank
;
803 f
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
810 /* If dim kind is greater than default integer we need to use the larger. */
811 m
= gfc_default_integer_kind
;
813 m
= m
< dim
->ts
.kind
? dim
->ts
.kind
: m
;
815 /* Convert shift to at least m, so we don't need
816 kind=1 and kind=2 versions of the library functions. */
817 if (shift
->ts
.kind
< m
)
821 ts
.type
= BT_INTEGER
;
823 gfc_convert_type_warn (shift
, &ts
, 2, 0);
828 if (dim
->expr_type
!= EXPR_CONSTANT
&& dim
->symtree
!= NULL
829 && dim
->symtree
->n
.sym
->attr
.optional
)
831 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
832 dim
->representation
.length
= shift
->ts
.kind
;
836 gfc_resolve_dim_arg (dim
);
837 /* Convert dim to shift's kind to reduce variations. */
838 if (dim
->ts
.kind
!= shift
->ts
.kind
)
839 gfc_convert_type_warn (dim
, &shift
->ts
, 2, 0);
843 if (array
->ts
.type
== BT_CHARACTER
)
845 if (array
->ts
.kind
== gfc_default_character_kind
)
846 f
->value
.function
.name
847 = gfc_get_string (PREFIX ("cshift%d_%d_char"), n
, shift
->ts
.kind
);
849 f
->value
.function
.name
850 = gfc_get_string (PREFIX ("cshift%d_%d_char%d"), n
, shift
->ts
.kind
,
854 f
->value
.function
.name
855 = gfc_get_string (PREFIX ("cshift%d_%d"), n
, shift
->ts
.kind
);
860 gfc_resolve_ctime (gfc_expr
*f
, gfc_expr
*time
)
865 f
->ts
.type
= BT_CHARACTER
;
866 f
->ts
.kind
= gfc_default_character_kind
;
868 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
869 if (time
->ts
.kind
!= 8)
871 ts
.type
= BT_INTEGER
;
875 gfc_convert_type (time
, &ts
, 2);
878 f
->value
.function
.name
= gfc_get_string (PREFIX ("ctime"));
883 gfc_resolve_dble (gfc_expr
*f
, gfc_expr
*a
)
885 f
->ts
.type
= BT_REAL
;
886 f
->ts
.kind
= gfc_default_double_kind
;
887 f
->value
.function
.name
888 = gfc_get_string ("__dble_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
893 gfc_resolve_dim (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
895 f
->ts
.type
= a
->ts
.type
;
897 f
->ts
.kind
= gfc_kind_max (a
,p
);
899 f
->ts
.kind
= a
->ts
.kind
;
901 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
903 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
904 gfc_convert_type (p
, &a
->ts
, 2);
906 gfc_convert_type (a
, &p
->ts
, 2);
909 f
->value
.function
.name
910 = gfc_get_string ("__dim_%c%d", gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
915 gfc_resolve_dot_product (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b
)
919 temp
.expr_type
= EXPR_OP
;
920 gfc_clear_ts (&temp
.ts
);
921 temp
.value
.op
.op
= INTRINSIC_NONE
;
922 temp
.value
.op
.op1
= a
;
923 temp
.value
.op
.op2
= b
;
924 gfc_type_convert_binary (&temp
, 1);
926 f
->value
.function
.name
927 = gfc_get_string (PREFIX ("dot_product_%c%d"),
928 gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
933 gfc_resolve_dprod (gfc_expr
*f
, gfc_expr
*a ATTRIBUTE_UNUSED
,
934 gfc_expr
*b ATTRIBUTE_UNUSED
)
936 f
->ts
.kind
= gfc_default_double_kind
;
937 f
->ts
.type
= BT_REAL
;
938 f
->value
.function
.name
= gfc_get_string ("__dprod_r%d", f
->ts
.kind
);
943 gfc_resolve_dshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j ATTRIBUTE_UNUSED
,
944 gfc_expr
*shift ATTRIBUTE_UNUSED
)
947 if (f
->value
.function
.isym
->id
== GFC_ISYM_DSHIFTL
)
948 f
->value
.function
.name
= gfc_get_string ("dshiftl_i%d", f
->ts
.kind
);
949 else if (f
->value
.function
.isym
->id
== GFC_ISYM_DSHIFTR
)
950 f
->value
.function
.name
= gfc_get_string ("dshiftr_i%d", f
->ts
.kind
);
957 gfc_resolve_eoshift (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*shift
,
958 gfc_expr
*boundary
, gfc_expr
*dim
)
962 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
963 gfc_resolve_substring_charlen (array
);
966 f
->rank
= array
->rank
;
967 f
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
972 if (boundary
&& boundary
->rank
> 0)
975 /* If dim kind is greater than default integer we need to use the larger. */
976 m
= gfc_default_integer_kind
;
978 m
= m
< dim
->ts
.kind
? dim
->ts
.kind
: m
;
980 /* Convert shift to at least m, so we don't need
981 kind=1 and kind=2 versions of the library functions. */
982 if (shift
->ts
.kind
< m
)
986 ts
.type
= BT_INTEGER
;
988 gfc_convert_type_warn (shift
, &ts
, 2, 0);
993 if (dim
->expr_type
!= EXPR_CONSTANT
&& dim
->symtree
!= NULL
994 && dim
->symtree
->n
.sym
->attr
.optional
)
996 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
997 dim
->representation
.length
= shift
->ts
.kind
;
1001 gfc_resolve_dim_arg (dim
);
1002 /* Convert dim to shift's kind to reduce variations. */
1003 if (dim
->ts
.kind
!= shift
->ts
.kind
)
1004 gfc_convert_type_warn (dim
, &shift
->ts
, 2, 0);
1008 if (array
->ts
.type
== BT_CHARACTER
)
1010 if (array
->ts
.kind
== gfc_default_character_kind
)
1011 f
->value
.function
.name
1012 = gfc_get_string (PREFIX ("eoshift%d_%d_char"), n
, shift
->ts
.kind
);
1014 f
->value
.function
.name
1015 = gfc_get_string (PREFIX ("eoshift%d_%d_char%d"), n
, shift
->ts
.kind
,
1019 f
->value
.function
.name
1020 = gfc_get_string (PREFIX ("eoshift%d_%d"), n
, shift
->ts
.kind
);
1025 gfc_resolve_exp (gfc_expr
*f
, gfc_expr
*x
)
1028 f
->value
.function
.name
1029 = gfc_get_string ("__exp_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1034 gfc_resolve_exponent (gfc_expr
*f
, gfc_expr
*x
)
1036 f
->ts
.type
= BT_INTEGER
;
1037 f
->ts
.kind
= gfc_default_integer_kind
;
1038 f
->value
.function
.name
= gfc_get_string ("__exponent_%d", x
->ts
.kind
);
1042 /* Resolve the EXTENDS_TYPE_OF intrinsic function. */
1045 gfc_resolve_extends_type_of (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*mo
)
1050 /* Prevent double resolution. */
1051 if (f
->ts
.type
== BT_LOGICAL
)
1054 /* Replace the first argument with the corresponding vtab. */
1055 if (a
->ts
.type
== BT_CLASS
)
1056 gfc_add_vptr_component (a
);
1057 else if (a
->ts
.type
== BT_DERIVED
)
1061 vtab
= gfc_find_derived_vtab (a
->ts
.u
.derived
);
1062 /* Clear the old expr. */
1063 gfc_free_ref_list (a
->ref
);
1065 memset (a
, '\0', sizeof (gfc_expr
));
1066 /* Construct a new one. */
1067 a
->expr_type
= EXPR_VARIABLE
;
1068 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
1074 /* Replace the second argument with the corresponding vtab. */
1075 if (mo
->ts
.type
== BT_CLASS
)
1076 gfc_add_vptr_component (mo
);
1077 else if (mo
->ts
.type
== BT_DERIVED
)
1081 vtab
= gfc_find_derived_vtab (mo
->ts
.u
.derived
);
1082 /* Clear the old expr. */
1084 gfc_free_ref_list (mo
->ref
);
1085 memset (mo
, '\0', sizeof (gfc_expr
));
1086 /* Construct a new one. */
1087 mo
->expr_type
= EXPR_VARIABLE
;
1088 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
1094 f
->ts
.type
= BT_LOGICAL
;
1097 f
->value
.function
.isym
->formal
->ts
= a
->ts
;
1098 f
->value
.function
.isym
->formal
->next
->ts
= mo
->ts
;
1100 /* Call library function. */
1101 f
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
1106 gfc_resolve_fdate (gfc_expr
*f
)
1108 f
->ts
.type
= BT_CHARACTER
;
1109 f
->ts
.kind
= gfc_default_character_kind
;
1110 f
->value
.function
.name
= gfc_get_string (PREFIX ("fdate"));
1115 gfc_resolve_floor (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1117 f
->ts
.type
= BT_INTEGER
;
1118 f
->ts
.kind
= (kind
== NULL
)
1119 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
1120 f
->value
.function
.name
1121 = gfc_get_string ("__floor%d_%c%d", f
->ts
.kind
,
1122 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1127 gfc_resolve_fnum (gfc_expr
*f
, gfc_expr
*n
)
1129 f
->ts
.type
= BT_INTEGER
;
1130 f
->ts
.kind
= gfc_default_integer_kind
;
1131 if (n
->ts
.kind
!= f
->ts
.kind
)
1132 gfc_convert_type (n
, &f
->ts
, 2);
1133 f
->value
.function
.name
= gfc_get_string (PREFIX ("fnum_i%d"), f
->ts
.kind
);
1138 gfc_resolve_fraction (gfc_expr
*f
, gfc_expr
*x
)
1141 f
->value
.function
.name
= gfc_get_string ("__fraction_%d", x
->ts
.kind
);
1145 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
1148 gfc_resolve_g77_math1 (gfc_expr
*f
, gfc_expr
*x
)
1151 f
->value
.function
.name
= gfc_get_string ("<intrinsic>");
1156 gfc_resolve_gamma (gfc_expr
*f
, gfc_expr
*x
)
1159 f
->value
.function
.name
1160 = gfc_get_string ("__tgamma_%d", x
->ts
.kind
);
1165 gfc_resolve_getcwd (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
1167 f
->ts
.type
= BT_INTEGER
;
1169 f
->value
.function
.name
= gfc_get_string (PREFIX ("getcwd"));
1174 gfc_resolve_getgid (gfc_expr
*f
)
1176 f
->ts
.type
= BT_INTEGER
;
1178 f
->value
.function
.name
= gfc_get_string (PREFIX ("getgid"));
1183 gfc_resolve_getpid (gfc_expr
*f
)
1185 f
->ts
.type
= BT_INTEGER
;
1187 f
->value
.function
.name
= gfc_get_string (PREFIX ("getpid"));
1192 gfc_resolve_getuid (gfc_expr
*f
)
1194 f
->ts
.type
= BT_INTEGER
;
1196 f
->value
.function
.name
= gfc_get_string (PREFIX ("getuid"));
1201 gfc_resolve_hostnm (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
1203 f
->ts
.type
= BT_INTEGER
;
1205 f
->value
.function
.name
= gfc_get_string (PREFIX ("hostnm"));
1210 gfc_resolve_hypot (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
1213 f
->value
.function
.name
= gfc_get_string ("__hypot_r%d", x
->ts
.kind
);
1218 gfc_resolve_iall (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
1220 resolve_transformational ("iall", f
, array
, dim
, mask
);
1225 gfc_resolve_iand (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1227 /* If the kind of i and j are different, then g77 cross-promoted the
1228 kinds to the largest value. The Fortran 95 standard requires the
1230 if (i
->ts
.kind
!= j
->ts
.kind
)
1232 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1233 gfc_convert_type (j
, &i
->ts
, 2);
1235 gfc_convert_type (i
, &j
->ts
, 2);
1239 f
->value
.function
.name
= gfc_get_string ("__iand_%d", i
->ts
.kind
);
1244 gfc_resolve_iany (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
1246 resolve_transformational ("iany", f
, array
, dim
, mask
);
1251 gfc_resolve_ibclr (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
)
1254 f
->value
.function
.name
= gfc_get_string ("__ibclr_%d", i
->ts
.kind
);
1259 gfc_resolve_ibits (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
,
1260 gfc_expr
*len ATTRIBUTE_UNUSED
)
1263 f
->value
.function
.name
= gfc_get_string ("__ibits_%d", i
->ts
.kind
);
1268 gfc_resolve_ibset (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
)
1271 f
->value
.function
.name
= gfc_get_string ("__ibset_%d", i
->ts
.kind
);
1276 gfc_resolve_iachar (gfc_expr
*f
, gfc_expr
*c
, gfc_expr
*kind
)
1278 f
->ts
.type
= BT_INTEGER
;
1280 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1282 f
->ts
.kind
= gfc_default_integer_kind
;
1283 f
->value
.function
.name
= gfc_get_string ("__ichar_%d", c
->ts
.kind
);
1288 gfc_resolve_ichar (gfc_expr
*f
, gfc_expr
*c
, gfc_expr
*kind
)
1290 f
->ts
.type
= BT_INTEGER
;
1292 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1294 f
->ts
.kind
= gfc_default_integer_kind
;
1295 f
->value
.function
.name
= gfc_get_string ("__ichar_%d", c
->ts
.kind
);
1300 gfc_resolve_idnint (gfc_expr
*f
, gfc_expr
*a
)
1302 gfc_resolve_nint (f
, a
, NULL
);
1307 gfc_resolve_ierrno (gfc_expr
*f
)
1309 f
->ts
.type
= BT_INTEGER
;
1310 f
->ts
.kind
= gfc_default_integer_kind
;
1311 f
->value
.function
.name
= gfc_get_string (PREFIX ("ierrno_i%d"), f
->ts
.kind
);
1316 gfc_resolve_ieor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1318 /* If the kind of i and j are different, then g77 cross-promoted the
1319 kinds to the largest value. The Fortran 95 standard requires the
1321 if (i
->ts
.kind
!= j
->ts
.kind
)
1323 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1324 gfc_convert_type (j
, &i
->ts
, 2);
1326 gfc_convert_type (i
, &j
->ts
, 2);
1330 f
->value
.function
.name
= gfc_get_string ("__ieor_%d", i
->ts
.kind
);
1335 gfc_resolve_ior (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1337 /* If the kind of i and j are different, then g77 cross-promoted the
1338 kinds to the largest value. The Fortran 95 standard requires the
1340 if (i
->ts
.kind
!= j
->ts
.kind
)
1342 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1343 gfc_convert_type (j
, &i
->ts
, 2);
1345 gfc_convert_type (i
, &j
->ts
, 2);
1349 f
->value
.function
.name
= gfc_get_string ("__ior_%d", i
->ts
.kind
);
1354 gfc_resolve_index_func (gfc_expr
*f
, gfc_expr
*str
,
1355 gfc_expr
*sub_str ATTRIBUTE_UNUSED
, gfc_expr
*back
,
1361 f
->ts
.type
= BT_INTEGER
;
1363 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1365 f
->ts
.kind
= gfc_default_integer_kind
;
1367 if (back
&& back
->ts
.kind
!= gfc_default_integer_kind
)
1369 ts
.type
= BT_LOGICAL
;
1370 ts
.kind
= gfc_default_integer_kind
;
1371 ts
.u
.derived
= NULL
;
1373 gfc_convert_type (back
, &ts
, 2);
1376 f
->value
.function
.name
1377 = gfc_get_string ("__index_%d_i%d", str
->ts
.kind
, f
->ts
.kind
);
1382 gfc_resolve_int (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1384 f
->ts
.type
= BT_INTEGER
;
1385 f
->ts
.kind
= (kind
== NULL
)
1386 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
1387 f
->value
.function
.name
1388 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1389 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1394 gfc_resolve_int2 (gfc_expr
*f
, gfc_expr
*a
)
1396 f
->ts
.type
= BT_INTEGER
;
1398 f
->value
.function
.name
1399 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1400 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1405 gfc_resolve_int8 (gfc_expr
*f
, gfc_expr
*a
)
1407 f
->ts
.type
= BT_INTEGER
;
1409 f
->value
.function
.name
1410 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1411 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1416 gfc_resolve_long (gfc_expr
*f
, gfc_expr
*a
)
1418 f
->ts
.type
= BT_INTEGER
;
1420 f
->value
.function
.name
1421 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1422 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1427 gfc_resolve_iparity (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
1429 resolve_transformational ("iparity", f
, array
, dim
, mask
);
1434 gfc_resolve_isatty (gfc_expr
*f
, gfc_expr
*u
)
1439 f
->ts
.type
= BT_LOGICAL
;
1440 f
->ts
.kind
= gfc_default_integer_kind
;
1441 if (u
->ts
.kind
!= gfc_c_int_kind
)
1443 ts
.type
= BT_INTEGER
;
1444 ts
.kind
= gfc_c_int_kind
;
1445 ts
.u
.derived
= NULL
;
1447 gfc_convert_type (u
, &ts
, 2);
1450 f
->value
.function
.name
= gfc_get_string (PREFIX ("isatty_l%d"), f
->ts
.kind
);
1455 gfc_resolve_ishft (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1458 f
->value
.function
.name
1459 = gfc_get_string ("__ishft_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1464 gfc_resolve_rshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1467 f
->value
.function
.name
1468 = gfc_get_string ("__rshift_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1473 gfc_resolve_lshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1476 f
->value
.function
.name
1477 = gfc_get_string ("__lshift_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1482 gfc_resolve_ishftc (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
1486 s_kind
= (size
== NULL
) ? gfc_default_integer_kind
: size
->ts
.kind
;
1489 f
->value
.function
.name
1490 = gfc_get_string ("__ishftc_%d_%d_%d", i
->ts
.kind
, shift
->ts
.kind
, s_kind
);
1495 gfc_resolve_kill (gfc_expr
*f
, gfc_expr
*p ATTRIBUTE_UNUSED
,
1496 gfc_expr
*s ATTRIBUTE_UNUSED
)
1498 f
->ts
.type
= BT_INTEGER
;
1499 f
->ts
.kind
= gfc_default_integer_kind
;
1500 f
->value
.function
.name
= gfc_get_string (PREFIX ("kill_i%d"), f
->ts
.kind
);
1505 gfc_resolve_lbound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
1507 resolve_bound (f
, array
, dim
, kind
, "__lbound", false);
1512 gfc_resolve_lcobound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
1514 resolve_bound (f
, array
, dim
, kind
, "__lcobound", true);
1519 gfc_resolve_len (gfc_expr
*f
, gfc_expr
*string
, gfc_expr
*kind
)
1521 f
->ts
.type
= BT_INTEGER
;
1523 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1525 f
->ts
.kind
= gfc_default_integer_kind
;
1526 f
->value
.function
.name
1527 = gfc_get_string ("__len_%d_i%d", string
->ts
.kind
,
1528 gfc_default_integer_kind
);
1533 gfc_resolve_len_trim (gfc_expr
*f
, gfc_expr
*string
, gfc_expr
*kind
)
1535 f
->ts
.type
= BT_INTEGER
;
1537 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1539 f
->ts
.kind
= gfc_default_integer_kind
;
1540 f
->value
.function
.name
= gfc_get_string ("__len_trim%d", string
->ts
.kind
);
1545 gfc_resolve_lgamma (gfc_expr
*f
, gfc_expr
*x
)
1548 f
->value
.function
.name
1549 = gfc_get_string ("__lgamma_%d", x
->ts
.kind
);
1554 gfc_resolve_link (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
1555 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
1557 f
->ts
.type
= BT_INTEGER
;
1558 f
->ts
.kind
= gfc_default_integer_kind
;
1559 f
->value
.function
.name
= gfc_get_string (PREFIX ("link_i%d"), f
->ts
.kind
);
1564 gfc_resolve_loc (gfc_expr
*f
, gfc_expr
*x
)
1566 f
->ts
.type
= BT_INTEGER
;
1567 f
->ts
.kind
= gfc_index_integer_kind
;
1568 f
->value
.function
.name
= gfc_get_string ("__loc_%d", x
->ts
.kind
);
1573 gfc_resolve_log (gfc_expr
*f
, gfc_expr
*x
)
1576 f
->value
.function
.name
1577 = gfc_get_string ("__log_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1582 gfc_resolve_log10 (gfc_expr
*f
, gfc_expr
*x
)
1585 f
->value
.function
.name
1586 = gfc_get_string ("__log10_%c%d", gfc_type_letter (x
->ts
.type
),
1592 gfc_resolve_logical (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1594 f
->ts
.type
= BT_LOGICAL
;
1595 f
->ts
.kind
= (kind
== NULL
)
1596 ? gfc_default_logical_kind
: mpz_get_si (kind
->value
.integer
);
1599 f
->value
.function
.name
1600 = gfc_get_string ("__logical_%d_%c%d", f
->ts
.kind
,
1601 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1606 gfc_resolve_matmul (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b
)
1610 if (a
->ts
.type
== BT_LOGICAL
&& b
->ts
.type
== BT_LOGICAL
)
1612 f
->ts
.type
= BT_LOGICAL
;
1613 f
->ts
.kind
= gfc_default_logical_kind
;
1617 temp
.expr_type
= EXPR_OP
;
1618 gfc_clear_ts (&temp
.ts
);
1619 temp
.value
.op
.op
= INTRINSIC_NONE
;
1620 temp
.value
.op
.op1
= a
;
1621 temp
.value
.op
.op2
= b
;
1622 gfc_type_convert_binary (&temp
, 1);
1626 f
->rank
= (a
->rank
== 2 && b
->rank
== 2) ? 2 : 1;
1628 if (a
->rank
== 2 && b
->rank
== 2)
1630 if (a
->shape
&& b
->shape
)
1632 f
->shape
= gfc_get_shape (f
->rank
);
1633 mpz_init_set (f
->shape
[0], a
->shape
[0]);
1634 mpz_init_set (f
->shape
[1], b
->shape
[1]);
1637 else if (a
->rank
== 1)
1641 f
->shape
= gfc_get_shape (f
->rank
);
1642 mpz_init_set (f
->shape
[0], b
->shape
[1]);
1647 /* b->rank == 1 and a->rank == 2 here, all other cases have
1648 been caught in check.c. */
1651 f
->shape
= gfc_get_shape (f
->rank
);
1652 mpz_init_set (f
->shape
[0], a
->shape
[0]);
1656 f
->value
.function
.name
1657 = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f
->ts
.type
),
1663 gfc_resolve_minmax (const char *name
, gfc_expr
*f
, gfc_actual_arglist
*args
)
1665 gfc_actual_arglist
*a
;
1667 f
->ts
.type
= args
->expr
->ts
.type
;
1668 f
->ts
.kind
= args
->expr
->ts
.kind
;
1669 /* Find the largest type kind. */
1670 for (a
= args
->next
; a
; a
= a
->next
)
1672 if (a
->expr
->ts
.kind
> f
->ts
.kind
)
1673 f
->ts
.kind
= a
->expr
->ts
.kind
;
1676 /* Convert all parameters to the required kind. */
1677 for (a
= args
; a
; a
= a
->next
)
1679 if (a
->expr
->ts
.kind
!= f
->ts
.kind
)
1680 gfc_convert_type (a
->expr
, &f
->ts
, 2);
1683 f
->value
.function
.name
1684 = gfc_get_string (name
, gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
1689 gfc_resolve_max (gfc_expr
*f
, gfc_actual_arglist
*args
)
1691 gfc_resolve_minmax ("__max_%c%d", f
, args
);
1696 gfc_resolve_maxloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1702 f
->ts
.type
= BT_INTEGER
;
1703 f
->ts
.kind
= gfc_default_integer_kind
;
1708 f
->shape
= gfc_get_shape (1);
1709 mpz_init_set_si (f
->shape
[0], array
->rank
);
1713 f
->rank
= array
->rank
- 1;
1714 gfc_resolve_dim_arg (dim
);
1715 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1717 idim
= (int) mpz_get_si (dim
->value
.integer
);
1718 f
->shape
= gfc_get_shape (f
->rank
);
1719 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1721 if (i
== (idim
- 1))
1723 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1730 if (mask
->rank
== 0)
1735 resolve_mask_arg (mask
);
1740 f
->value
.function
.name
1741 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name
, dim
!= NULL
, f
->ts
.kind
,
1742 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1747 gfc_resolve_maxval (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1757 f
->rank
= array
->rank
- 1;
1758 gfc_resolve_dim_arg (dim
);
1760 if (f
->rank
&& array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1762 idim
= (int) mpz_get_si (dim
->value
.integer
);
1763 f
->shape
= gfc_get_shape (f
->rank
);
1764 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1766 if (i
== (idim
- 1))
1768 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1775 if (mask
->rank
== 0)
1780 resolve_mask_arg (mask
);
1785 f
->value
.function
.name
1786 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
1787 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1792 gfc_resolve_mclock (gfc_expr
*f
)
1794 f
->ts
.type
= BT_INTEGER
;
1796 f
->value
.function
.name
= PREFIX ("mclock");
1801 gfc_resolve_mclock8 (gfc_expr
*f
)
1803 f
->ts
.type
= BT_INTEGER
;
1805 f
->value
.function
.name
= PREFIX ("mclock8");
1810 gfc_resolve_mask (gfc_expr
*f
, gfc_expr
*i ATTRIBUTE_UNUSED
,
1813 f
->ts
.type
= BT_INTEGER
;
1814 f
->ts
.kind
= kind
? mpz_get_si (kind
->value
.integer
)
1815 : gfc_default_integer_kind
;
1817 if (f
->value
.function
.isym
->id
== GFC_ISYM_MASKL
)
1818 f
->value
.function
.name
= gfc_get_string ("__maskl_i%d", f
->ts
.kind
);
1820 f
->value
.function
.name
= gfc_get_string ("__maskr_i%d", f
->ts
.kind
);
1825 gfc_resolve_merge (gfc_expr
*f
, gfc_expr
*tsource
,
1826 gfc_expr
*fsource ATTRIBUTE_UNUSED
,
1827 gfc_expr
*mask ATTRIBUTE_UNUSED
)
1829 if (tsource
->ts
.type
== BT_CHARACTER
&& tsource
->ref
)
1830 gfc_resolve_substring_charlen (tsource
);
1832 if (fsource
->ts
.type
== BT_CHARACTER
&& fsource
->ref
)
1833 gfc_resolve_substring_charlen (fsource
);
1835 if (tsource
->ts
.type
== BT_CHARACTER
)
1836 check_charlen_present (tsource
);
1838 f
->ts
= tsource
->ts
;
1839 f
->value
.function
.name
1840 = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource
->ts
.type
),
1846 gfc_resolve_merge_bits (gfc_expr
*f
, gfc_expr
*i
,
1847 gfc_expr
*j ATTRIBUTE_UNUSED
,
1848 gfc_expr
*mask ATTRIBUTE_UNUSED
)
1851 f
->value
.function
.name
= gfc_get_string ("__merge_bits_i%d", i
->ts
.kind
);
1856 gfc_resolve_min (gfc_expr
*f
, gfc_actual_arglist
*args
)
1858 gfc_resolve_minmax ("__min_%c%d", f
, args
);
1863 gfc_resolve_minloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1869 f
->ts
.type
= BT_INTEGER
;
1870 f
->ts
.kind
= gfc_default_integer_kind
;
1875 f
->shape
= gfc_get_shape (1);
1876 mpz_init_set_si (f
->shape
[0], array
->rank
);
1880 f
->rank
= array
->rank
- 1;
1881 gfc_resolve_dim_arg (dim
);
1882 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1884 idim
= (int) mpz_get_si (dim
->value
.integer
);
1885 f
->shape
= gfc_get_shape (f
->rank
);
1886 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1888 if (i
== (idim
- 1))
1890 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1897 if (mask
->rank
== 0)
1902 resolve_mask_arg (mask
);
1907 f
->value
.function
.name
1908 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name
, dim
!= NULL
, f
->ts
.kind
,
1909 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1914 gfc_resolve_minval (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1924 f
->rank
= array
->rank
- 1;
1925 gfc_resolve_dim_arg (dim
);
1927 if (f
->rank
&& array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1929 idim
= (int) mpz_get_si (dim
->value
.integer
);
1930 f
->shape
= gfc_get_shape (f
->rank
);
1931 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1933 if (i
== (idim
- 1))
1935 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1942 if (mask
->rank
== 0)
1947 resolve_mask_arg (mask
);
1952 f
->value
.function
.name
1953 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
1954 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1959 gfc_resolve_mod (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
1961 f
->ts
.type
= a
->ts
.type
;
1963 f
->ts
.kind
= gfc_kind_max (a
,p
);
1965 f
->ts
.kind
= a
->ts
.kind
;
1967 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
1969 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
1970 gfc_convert_type (p
, &a
->ts
, 2);
1972 gfc_convert_type (a
, &p
->ts
, 2);
1975 f
->value
.function
.name
1976 = gfc_get_string ("__mod_%c%d", gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
1981 gfc_resolve_modulo (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
1983 f
->ts
.type
= a
->ts
.type
;
1985 f
->ts
.kind
= gfc_kind_max (a
,p
);
1987 f
->ts
.kind
= a
->ts
.kind
;
1989 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
1991 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
1992 gfc_convert_type (p
, &a
->ts
, 2);
1994 gfc_convert_type (a
, &p
->ts
, 2);
1997 f
->value
.function
.name
1998 = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f
->ts
.type
),
2003 gfc_resolve_nearest (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
2005 if (p
->ts
.kind
!= a
->ts
.kind
)
2006 gfc_convert_type (p
, &a
->ts
, 2);
2009 f
->value
.function
.name
2010 = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a
->ts
.type
),
2015 gfc_resolve_nint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
2017 f
->ts
.type
= BT_INTEGER
;
2018 f
->ts
.kind
= (kind
== NULL
)
2019 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
2020 f
->value
.function
.name
2021 = gfc_get_string ("__nint_%d_%d", f
->ts
.kind
, a
->ts
.kind
);
2026 gfc_resolve_norm2 (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
)
2028 resolve_transformational ("norm2", f
, array
, dim
, NULL
);
2033 gfc_resolve_not (gfc_expr
*f
, gfc_expr
*i
)
2036 f
->value
.function
.name
= gfc_get_string ("__not_%d", i
->ts
.kind
);
2041 gfc_resolve_or (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
2043 f
->ts
.type
= i
->ts
.type
;
2044 f
->ts
.kind
= gfc_kind_max (i
, j
);
2046 if (i
->ts
.kind
!= j
->ts
.kind
)
2048 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
2049 gfc_convert_type (j
, &i
->ts
, 2);
2051 gfc_convert_type (i
, &j
->ts
, 2);
2054 f
->value
.function
.name
2055 = gfc_get_string ("__or_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
2060 gfc_resolve_pack (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*mask
,
2061 gfc_expr
*vector ATTRIBUTE_UNUSED
)
2063 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
2064 gfc_resolve_substring_charlen (array
);
2069 resolve_mask_arg (mask
);
2071 if (mask
->rank
!= 0)
2073 if (array
->ts
.type
== BT_CHARACTER
)
2074 f
->value
.function
.name
2075 = array
->ts
.kind
== 1 ? PREFIX ("pack_char")
2077 (PREFIX ("pack_char%d"),
2080 f
->value
.function
.name
= PREFIX ("pack");
2084 if (array
->ts
.type
== BT_CHARACTER
)
2085 f
->value
.function
.name
2086 = array
->ts
.kind
== 1 ? PREFIX ("pack_s_char")
2088 (PREFIX ("pack_s_char%d"),
2091 f
->value
.function
.name
= PREFIX ("pack_s");
2097 gfc_resolve_parity (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
)
2099 resolve_transformational ("parity", f
, array
, dim
, NULL
);
2104 gfc_resolve_product (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
2107 resolve_transformational ("product", f
, array
, dim
, mask
);
2112 gfc_resolve_rank (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
)
2114 f
->ts
.type
= BT_INTEGER
;
2115 f
->ts
.kind
= gfc_default_integer_kind
;
2116 f
->value
.function
.name
= gfc_get_string ("__rank");
2121 gfc_resolve_real (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
2123 f
->ts
.type
= BT_REAL
;
2126 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2128 f
->ts
.kind
= (a
->ts
.type
== BT_COMPLEX
)
2129 ? a
->ts
.kind
: gfc_default_real_kind
;
2131 f
->value
.function
.name
2132 = gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
2133 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2138 gfc_resolve_realpart (gfc_expr
*f
, gfc_expr
*a
)
2140 f
->ts
.type
= BT_REAL
;
2141 f
->ts
.kind
= a
->ts
.kind
;
2142 f
->value
.function
.name
2143 = gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
2144 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2149 gfc_resolve_rename (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
2150 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
2152 f
->ts
.type
= BT_INTEGER
;
2153 f
->ts
.kind
= gfc_default_integer_kind
;
2154 f
->value
.function
.name
= gfc_get_string (PREFIX ("rename_i%d"), f
->ts
.kind
);
2159 gfc_resolve_repeat (gfc_expr
*f
, gfc_expr
*string
,
2164 f
->ts
.type
= BT_CHARACTER
;
2165 f
->ts
.kind
= string
->ts
.kind
;
2166 f
->value
.function
.name
= gfc_get_string ("__repeat_%d", string
->ts
.kind
);
2168 /* If possible, generate a character length. */
2169 if (f
->ts
.u
.cl
== NULL
)
2170 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2173 if (string
->expr_type
== EXPR_CONSTANT
)
2175 len
= string
->value
.character
.length
;
2176 tmp
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, len
);
2178 else if (string
->ts
.u
.cl
&& string
->ts
.u
.cl
->length
)
2180 tmp
= gfc_copy_expr (string
->ts
.u
.cl
->length
);
2184 f
->ts
.u
.cl
->length
= gfc_multiply (tmp
, gfc_copy_expr (ncopies
));
2189 gfc_resolve_reshape (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*shape
,
2190 gfc_expr
*pad ATTRIBUTE_UNUSED
,
2191 gfc_expr
*order ATTRIBUTE_UNUSED
)
2197 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
2198 gfc_resolve_substring_charlen (source
);
2202 gfc_array_size (shape
, &rank
);
2203 f
->rank
= mpz_get_si (rank
);
2205 switch (source
->ts
.type
)
2212 kind
= source
->ts
.kind
;
2226 if (source
->ts
.type
== BT_COMPLEX
|| source
->ts
.type
== BT_REAL
)
2227 f
->value
.function
.name
2228 = gfc_get_string (PREFIX ("reshape_%c%d"),
2229 gfc_type_letter (source
->ts
.type
),
2231 else if (source
->ts
.type
== BT_CHARACTER
)
2232 f
->value
.function
.name
= gfc_get_string (PREFIX ("reshape_char%d"),
2235 f
->value
.function
.name
2236 = gfc_get_string (PREFIX ("reshape_%d"), source
->ts
.kind
);
2240 f
->value
.function
.name
= (source
->ts
.type
== BT_CHARACTER
2241 ? PREFIX ("reshape_char") : PREFIX ("reshape"));
2245 if (shape
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (shape
))
2248 f
->shape
= gfc_get_shape (f
->rank
);
2249 c
= gfc_constructor_first (shape
->value
.constructor
);
2250 for (i
= 0; i
< f
->rank
; i
++)
2252 mpz_init_set (f
->shape
[i
], c
->expr
->value
.integer
);
2253 c
= gfc_constructor_next (c
);
2257 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
2258 so many runtime variations. */
2259 if (shape
->ts
.kind
!= gfc_index_integer_kind
)
2261 gfc_typespec ts
= shape
->ts
;
2262 ts
.kind
= gfc_index_integer_kind
;
2263 gfc_convert_type_warn (shape
, &ts
, 2, 0);
2265 if (order
&& order
->ts
.kind
!= gfc_index_integer_kind
)
2266 gfc_convert_type_warn (order
, &shape
->ts
, 2, 0);
2271 gfc_resolve_rrspacing (gfc_expr
*f
, gfc_expr
*x
)
2274 f
->value
.function
.name
= gfc_get_string ("__rrspacing_%d", x
->ts
.kind
);
2278 gfc_resolve_fe_runtime_error (gfc_code
*c
)
2281 gfc_actual_arglist
*a
;
2283 name
= gfc_get_string (PREFIX ("runtime_error"));
2285 for (a
= c
->ext
.actual
->next
; a
; a
= a
->next
)
2288 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2292 gfc_resolve_scale (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*i ATTRIBUTE_UNUSED
)
2295 f
->value
.function
.name
= gfc_get_string ("__scale_%d", x
->ts
.kind
);
2300 gfc_resolve_scan (gfc_expr
*f
, gfc_expr
*string
,
2301 gfc_expr
*set ATTRIBUTE_UNUSED
,
2302 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2304 f
->ts
.type
= BT_INTEGER
;
2306 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2308 f
->ts
.kind
= gfc_default_integer_kind
;
2309 f
->value
.function
.name
= gfc_get_string ("__scan_%d", string
->ts
.kind
);
2314 gfc_resolve_secnds (gfc_expr
*t1
, gfc_expr
*t0
)
2317 t1
->value
.function
.name
= gfc_get_string (PREFIX ("secnds"));
2322 gfc_resolve_set_exponent (gfc_expr
*f
, gfc_expr
*x
,
2323 gfc_expr
*i ATTRIBUTE_UNUSED
)
2326 f
->value
.function
.name
= gfc_get_string ("__set_exponent_%d", x
->ts
.kind
);
2331 gfc_resolve_shape (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*kind
)
2333 f
->ts
.type
= BT_INTEGER
;
2336 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2338 f
->ts
.kind
= gfc_default_integer_kind
;
2341 if (array
->rank
!= -1)
2343 f
->shape
= gfc_get_shape (1);
2344 mpz_init_set_ui (f
->shape
[0], array
->rank
);
2347 f
->value
.function
.name
= gfc_get_string (PREFIX ("shape_%d"), f
->ts
.kind
);
2352 gfc_resolve_shift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift ATTRIBUTE_UNUSED
)
2355 if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTA
)
2356 f
->value
.function
.name
= gfc_get_string ("shifta_i%d", f
->ts
.kind
);
2357 else if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTL
)
2358 f
->value
.function
.name
= gfc_get_string ("shiftl_i%d", f
->ts
.kind
);
2359 else if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTR
)
2360 f
->value
.function
.name
= gfc_get_string ("shiftr_i%d", f
->ts
.kind
);
2367 gfc_resolve_sign (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b ATTRIBUTE_UNUSED
)
2370 f
->value
.function
.name
2371 = gfc_get_string ("__sign_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2376 gfc_resolve_signal (gfc_expr
*f
, gfc_expr
*number
, gfc_expr
*handler
)
2378 f
->ts
.type
= BT_INTEGER
;
2379 f
->ts
.kind
= gfc_c_int_kind
;
2381 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2382 if (handler
->ts
.type
== BT_INTEGER
)
2384 if (handler
->ts
.kind
!= gfc_c_int_kind
)
2385 gfc_convert_type (handler
, &f
->ts
, 2);
2386 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func_int"));
2389 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func"));
2391 if (number
->ts
.kind
!= gfc_c_int_kind
)
2392 gfc_convert_type (number
, &f
->ts
, 2);
2397 gfc_resolve_sin (gfc_expr
*f
, gfc_expr
*x
)
2400 f
->value
.function
.name
2401 = gfc_get_string ("__sin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2406 gfc_resolve_sinh (gfc_expr
*f
, gfc_expr
*x
)
2409 f
->value
.function
.name
2410 = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2415 gfc_resolve_size (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2416 gfc_expr
*dim ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2418 f
->ts
.type
= BT_INTEGER
;
2420 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2422 f
->ts
.kind
= gfc_default_integer_kind
;
2427 gfc_resolve_stride (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2428 gfc_expr
*dim ATTRIBUTE_UNUSED
)
2430 f
->ts
.type
= BT_INTEGER
;
2431 f
->ts
.kind
= gfc_index_integer_kind
;
2436 gfc_resolve_spacing (gfc_expr
*f
, gfc_expr
*x
)
2439 f
->value
.function
.name
= gfc_get_string ("__spacing_%d", x
->ts
.kind
);
2444 gfc_resolve_spread (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*dim
,
2447 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
2448 gfc_resolve_substring_charlen (source
);
2450 if (source
->ts
.type
== BT_CHARACTER
)
2451 check_charlen_present (source
);
2454 f
->rank
= source
->rank
+ 1;
2455 if (source
->rank
== 0)
2457 if (source
->ts
.type
== BT_CHARACTER
)
2458 f
->value
.function
.name
2459 = source
->ts
.kind
== 1 ? PREFIX ("spread_char_scalar")
2461 (PREFIX ("spread_char%d_scalar"),
2464 f
->value
.function
.name
= PREFIX ("spread_scalar");
2468 if (source
->ts
.type
== BT_CHARACTER
)
2469 f
->value
.function
.name
2470 = source
->ts
.kind
== 1 ? PREFIX ("spread_char")
2472 (PREFIX ("spread_char%d"),
2475 f
->value
.function
.name
= PREFIX ("spread");
2478 if (dim
&& gfc_is_constant_expr (dim
)
2479 && ncopies
&& gfc_is_constant_expr (ncopies
) && source
->shape
[0])
2482 idim
= mpz_get_ui (dim
->value
.integer
);
2483 f
->shape
= gfc_get_shape (f
->rank
);
2484 for (i
= 0; i
< (idim
- 1); i
++)
2485 mpz_init_set (f
->shape
[i
], source
->shape
[i
]);
2487 mpz_init_set (f
->shape
[idim
- 1], ncopies
->value
.integer
);
2489 for (i
= idim
; i
< f
->rank
; i
++)
2490 mpz_init_set (f
->shape
[i
], source
->shape
[i
-1]);
2494 gfc_resolve_dim_arg (dim
);
2495 gfc_resolve_index (ncopies
, 1);
2500 gfc_resolve_sqrt (gfc_expr
*f
, gfc_expr
*x
)
2503 f
->value
.function
.name
2504 = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2508 /* Resolve the g77 compatibility function STAT AND FSTAT. */
2511 gfc_resolve_stat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2512 gfc_expr
*a ATTRIBUTE_UNUSED
)
2514 f
->ts
.type
= BT_INTEGER
;
2515 f
->ts
.kind
= gfc_default_integer_kind
;
2516 f
->value
.function
.name
= gfc_get_string (PREFIX ("stat_i%d"), f
->ts
.kind
);
2521 gfc_resolve_lstat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2522 gfc_expr
*a ATTRIBUTE_UNUSED
)
2524 f
->ts
.type
= BT_INTEGER
;
2525 f
->ts
.kind
= gfc_default_integer_kind
;
2526 f
->value
.function
.name
= gfc_get_string (PREFIX ("lstat_i%d"), f
->ts
.kind
);
2531 gfc_resolve_fstat (gfc_expr
*f
, gfc_expr
*n
, gfc_expr
*a ATTRIBUTE_UNUSED
)
2533 f
->ts
.type
= BT_INTEGER
;
2534 f
->ts
.kind
= gfc_default_integer_kind
;
2535 if (n
->ts
.kind
!= f
->ts
.kind
)
2536 gfc_convert_type (n
, &f
->ts
, 2);
2538 f
->value
.function
.name
= gfc_get_string (PREFIX ("fstat_i%d"), f
->ts
.kind
);
2543 gfc_resolve_fgetc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2548 f
->ts
.type
= BT_INTEGER
;
2549 f
->ts
.kind
= gfc_c_int_kind
;
2550 if (u
->ts
.kind
!= gfc_c_int_kind
)
2552 ts
.type
= BT_INTEGER
;
2553 ts
.kind
= gfc_c_int_kind
;
2554 ts
.u
.derived
= NULL
;
2556 gfc_convert_type (u
, &ts
, 2);
2559 f
->value
.function
.name
= gfc_get_string (PREFIX ("fgetc"));
2564 gfc_resolve_fget (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2566 f
->ts
.type
= BT_INTEGER
;
2567 f
->ts
.kind
= gfc_c_int_kind
;
2568 f
->value
.function
.name
= gfc_get_string (PREFIX ("fget"));
2573 gfc_resolve_fputc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2578 f
->ts
.type
= BT_INTEGER
;
2579 f
->ts
.kind
= gfc_c_int_kind
;
2580 if (u
->ts
.kind
!= gfc_c_int_kind
)
2582 ts
.type
= BT_INTEGER
;
2583 ts
.kind
= gfc_c_int_kind
;
2584 ts
.u
.derived
= NULL
;
2586 gfc_convert_type (u
, &ts
, 2);
2589 f
->value
.function
.name
= gfc_get_string (PREFIX ("fputc"));
2594 gfc_resolve_fput (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2596 f
->ts
.type
= BT_INTEGER
;
2597 f
->ts
.kind
= gfc_c_int_kind
;
2598 f
->value
.function
.name
= gfc_get_string (PREFIX ("fput"));
2603 gfc_resolve_ftell (gfc_expr
*f
, gfc_expr
*u
)
2608 f
->ts
.type
= BT_INTEGER
;
2609 f
->ts
.kind
= gfc_intio_kind
;
2610 if (u
->ts
.kind
!= gfc_c_int_kind
)
2612 ts
.type
= BT_INTEGER
;
2613 ts
.kind
= gfc_c_int_kind
;
2614 ts
.u
.derived
= NULL
;
2616 gfc_convert_type (u
, &ts
, 2);
2619 f
->value
.function
.name
= gfc_get_string (PREFIX ("ftell"));
2624 gfc_resolve_storage_size (gfc_expr
*f
, gfc_expr
*a ATTRIBUTE_UNUSED
,
2627 f
->ts
.type
= BT_INTEGER
;
2629 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2631 f
->ts
.kind
= gfc_default_integer_kind
;
2636 gfc_resolve_sum (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2638 resolve_transformational ("sum", f
, array
, dim
, mask
);
2643 gfc_resolve_symlnk (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
2644 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
2646 f
->ts
.type
= BT_INTEGER
;
2647 f
->ts
.kind
= gfc_default_integer_kind
;
2648 f
->value
.function
.name
= gfc_get_string (PREFIX ("symlnk_i%d"), f
->ts
.kind
);
2652 /* Resolve the g77 compatibility function SYSTEM. */
2655 gfc_resolve_system (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
2657 f
->ts
.type
= BT_INTEGER
;
2659 f
->value
.function
.name
= gfc_get_string (PREFIX ("system"));
2664 gfc_resolve_tan (gfc_expr
*f
, gfc_expr
*x
)
2667 f
->value
.function
.name
2668 = gfc_get_string ("__tan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2673 gfc_resolve_tanh (gfc_expr
*f
, gfc_expr
*x
)
2676 f
->value
.function
.name
2677 = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2681 /* Build an expression for converting degrees to radians. */
2684 get_radians (gfc_expr
*deg
)
2686 gfc_expr
*result
, *factor
;
2687 gfc_actual_arglist
*mod_args
;
2689 gcc_assert (deg
->ts
.type
== BT_REAL
);
2691 /* Set deg = deg % 360 to avoid offsets from large angles. */
2692 factor
= gfc_get_constant_expr (deg
->ts
.type
, deg
->ts
.kind
, °
->where
);
2693 mpfr_set_d (factor
->value
.real
, 360.0, GFC_RND_MODE
);
2695 mod_args
= gfc_get_actual_arglist ();
2696 mod_args
->expr
= deg
;
2697 mod_args
->next
= gfc_get_actual_arglist ();
2698 mod_args
->next
->expr
= factor
;
2700 result
= gfc_get_expr ();
2701 result
->ts
= deg
->ts
;
2702 result
->where
= deg
->where
;
2703 result
->expr_type
= EXPR_FUNCTION
;
2704 result
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_MOD
);
2705 result
->value
.function
.actual
= mod_args
;
2707 /* Set factor = pi / 180. */
2708 factor
= gfc_get_constant_expr (deg
->ts
.type
, deg
->ts
.kind
, °
->where
);
2709 mpfr_const_pi (factor
->value
.real
, GFC_RND_MODE
);
2710 mpfr_div_ui (factor
->value
.real
, factor
->value
.real
, 180, GFC_RND_MODE
);
2712 /* Result is rad = (deg % 360) * (pi / 180). */
2713 result
= gfc_multiply (result
, factor
);
2718 /* Build an expression for converting radians to degrees. */
2721 get_degrees (gfc_expr
*rad
)
2723 gfc_expr
*result
, *factor
;
2724 gfc_actual_arglist
*mod_args
;
2727 gcc_assert (rad
->ts
.type
== BT_REAL
);
2729 /* Set rad = rad % 2pi to avoid offsets from large angles. */
2730 factor
= gfc_get_constant_expr (rad
->ts
.type
, rad
->ts
.kind
, &rad
->where
);
2731 mpfr_const_pi (factor
->value
.real
, GFC_RND_MODE
);
2732 mpfr_mul_ui (factor
->value
.real
, factor
->value
.real
, 2, GFC_RND_MODE
);
2734 mod_args
= gfc_get_actual_arglist ();
2735 mod_args
->expr
= rad
;
2736 mod_args
->next
= gfc_get_actual_arglist ();
2737 mod_args
->next
->expr
= factor
;
2739 result
= gfc_get_expr ();
2740 result
->ts
= rad
->ts
;
2741 result
->where
= rad
->where
;
2742 result
->expr_type
= EXPR_FUNCTION
;
2743 result
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_MOD
);
2744 result
->value
.function
.actual
= mod_args
;
2746 /* Set factor = 180 / pi. */
2747 factor
= gfc_get_constant_expr (rad
->ts
.type
, rad
->ts
.kind
, &rad
->where
);
2748 mpfr_set_ui (factor
->value
.real
, 180, GFC_RND_MODE
);
2750 mpfr_const_pi (tmp
, GFC_RND_MODE
);
2751 mpfr_div (factor
->value
.real
, factor
->value
.real
, tmp
, GFC_RND_MODE
);
2754 /* Result is deg = (rad % 2pi) * (180 / pi). */
2755 result
= gfc_multiply (result
, factor
);
2760 /* Resolve a call to a trig function. */
2763 resolve_trig_call (gfc_expr
*f
, gfc_expr
*x
)
2765 switch (f
->value
.function
.isym
->id
)
2768 return gfc_resolve_acos (f
, x
);
2770 return gfc_resolve_asin (f
, x
);
2772 return gfc_resolve_atan (f
, x
);
2773 case GFC_ISYM_ATAN2
:
2774 /* NB. arg3 is unused for atan2 */
2775 return gfc_resolve_atan2 (f
, x
, NULL
);
2777 return gfc_resolve_cos (f
, x
);
2778 case GFC_ISYM_COTAN
:
2779 return gfc_resolve_cotan (f
, x
);
2781 return gfc_resolve_sin (f
, x
);
2783 return gfc_resolve_tan (f
, x
);
2789 /* Resolve degree trig function as trigd (x) = trig (radians (x)). */
2792 gfc_resolve_trigd (gfc_expr
*f
, gfc_expr
*x
)
2794 if (is_trig_resolved (f
))
2797 x
= get_radians (x
);
2798 f
->value
.function
.actual
->expr
= x
;
2800 resolve_trig_call (f
, x
);
2804 /* Resolve degree inverse trig function as atrigd (x) = degrees (atrig (x)). */
2807 gfc_resolve_atrigd (gfc_expr
*f
, gfc_expr
*x
)
2809 gfc_expr
*result
, *fcopy
;
2811 if (is_trig_resolved (f
))
2814 resolve_trig_call (f
, x
);
2816 fcopy
= copy_replace_function_shallow (f
);
2817 result
= get_degrees (fcopy
);
2818 gfc_replace_expr (f
, result
);
2822 /* Resolve atan2d(x) = degrees(atan2(x)). */
2825 gfc_resolve_atan2d (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
2827 /* Note that we lose the second arg here - that's okay because it is
2828 unused in gfc_resolve_atan2 anyway. */
2829 gfc_resolve_atrigd (f
, x
);
2834 gfc_resolve_image_index (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2835 gfc_expr
*sub ATTRIBUTE_UNUSED
)
2837 static char image_index
[] = "__image_index";
2838 f
->ts
.type
= BT_INTEGER
;
2839 f
->ts
.kind
= gfc_default_integer_kind
;
2840 f
->value
.function
.name
= image_index
;
2845 gfc_resolve_this_image (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
2846 gfc_expr
*distance ATTRIBUTE_UNUSED
)
2848 static char this_image
[] = "__this_image";
2849 if (array
&& gfc_is_coarray (array
))
2850 resolve_bound (f
, array
, dim
, NULL
, "__this_image", true);
2853 f
->ts
.type
= BT_INTEGER
;
2854 f
->ts
.kind
= gfc_default_integer_kind
;
2855 f
->value
.function
.name
= this_image
;
2861 gfc_resolve_time (gfc_expr
*f
)
2863 f
->ts
.type
= BT_INTEGER
;
2865 f
->value
.function
.name
= gfc_get_string (PREFIX ("time_func"));
2870 gfc_resolve_time8 (gfc_expr
*f
)
2872 f
->ts
.type
= BT_INTEGER
;
2874 f
->value
.function
.name
= gfc_get_string (PREFIX ("time8_func"));
2879 gfc_resolve_transfer (gfc_expr
*f
, gfc_expr
*source ATTRIBUTE_UNUSED
,
2880 gfc_expr
*mold
, gfc_expr
*size
)
2882 /* TODO: Make this do something meaningful. */
2883 static char transfer0
[] = "__transfer0", transfer1
[] = "__transfer1";
2885 if (mold
->ts
.type
== BT_CHARACTER
2886 && !mold
->ts
.u
.cl
->length
2887 && gfc_is_constant_expr (mold
))
2890 if (mold
->expr_type
== EXPR_CONSTANT
)
2892 len
= mold
->value
.character
.length
;
2893 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
2898 gfc_constructor
*c
= gfc_constructor_first (mold
->value
.constructor
);
2899 len
= c
->expr
->value
.character
.length
;
2900 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
2907 if (size
== NULL
&& mold
->rank
== 0)
2910 f
->value
.function
.name
= transfer0
;
2915 f
->value
.function
.name
= transfer1
;
2916 if (size
&& gfc_is_constant_expr (size
))
2918 f
->shape
= gfc_get_shape (1);
2919 mpz_init_set (f
->shape
[0], size
->value
.integer
);
2926 gfc_resolve_transpose (gfc_expr
*f
, gfc_expr
*matrix
)
2929 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ref
)
2930 gfc_resolve_substring_charlen (matrix
);
2936 f
->shape
= gfc_get_shape (2);
2937 mpz_init_set (f
->shape
[0], matrix
->shape
[1]);
2938 mpz_init_set (f
->shape
[1], matrix
->shape
[0]);
2941 switch (matrix
->ts
.kind
)
2947 switch (matrix
->ts
.type
)
2951 f
->value
.function
.name
2952 = gfc_get_string (PREFIX ("transpose_%c%d"),
2953 gfc_type_letter (matrix
->ts
.type
),
2959 /* Use the integer routines for real and logical cases. This
2960 assumes they all have the same alignment requirements. */
2961 f
->value
.function
.name
2962 = gfc_get_string (PREFIX ("transpose_i%d"), matrix
->ts
.kind
);
2966 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ts
.kind
== 4)
2967 f
->value
.function
.name
= PREFIX ("transpose_char4");
2969 f
->value
.function
.name
= PREFIX ("transpose");
2975 f
->value
.function
.name
= (matrix
->ts
.type
== BT_CHARACTER
2976 ? PREFIX ("transpose_char")
2977 : PREFIX ("transpose"));
2984 gfc_resolve_trim (gfc_expr
*f
, gfc_expr
*string
)
2986 f
->ts
.type
= BT_CHARACTER
;
2987 f
->ts
.kind
= string
->ts
.kind
;
2988 f
->value
.function
.name
= gfc_get_string ("__trim_%d", string
->ts
.kind
);
2993 gfc_resolve_ubound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2995 resolve_bound (f
, array
, dim
, kind
, "__ubound", false);
3000 gfc_resolve_ucobound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3002 resolve_bound (f
, array
, dim
, kind
, "__ucobound", true);
3006 /* Resolve the g77 compatibility function UMASK. */
3009 gfc_resolve_umask (gfc_expr
*f
, gfc_expr
*n
)
3011 f
->ts
.type
= BT_INTEGER
;
3012 f
->ts
.kind
= n
->ts
.kind
;
3013 f
->value
.function
.name
= gfc_get_string (PREFIX ("umask_i%d"), n
->ts
.kind
);
3017 /* Resolve the g77 compatibility function UNLINK. */
3020 gfc_resolve_unlink (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
3022 f
->ts
.type
= BT_INTEGER
;
3024 f
->value
.function
.name
= gfc_get_string (PREFIX ("unlink"));
3029 gfc_resolve_ttynam (gfc_expr
*f
, gfc_expr
*unit
)
3034 f
->ts
.type
= BT_CHARACTER
;
3035 f
->ts
.kind
= gfc_default_character_kind
;
3037 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3039 ts
.type
= BT_INTEGER
;
3040 ts
.kind
= gfc_c_int_kind
;
3041 ts
.u
.derived
= NULL
;
3043 gfc_convert_type (unit
, &ts
, 2);
3046 f
->value
.function
.name
= gfc_get_string (PREFIX ("ttynam"));
3051 gfc_resolve_unpack (gfc_expr
*f
, gfc_expr
*vector
, gfc_expr
*mask
,
3052 gfc_expr
*field ATTRIBUTE_UNUSED
)
3054 if (vector
->ts
.type
== BT_CHARACTER
&& vector
->ref
)
3055 gfc_resolve_substring_charlen (vector
);
3058 f
->rank
= mask
->rank
;
3059 resolve_mask_arg (mask
);
3061 if (vector
->ts
.type
== BT_CHARACTER
)
3063 if (vector
->ts
.kind
== 1)
3064 f
->value
.function
.name
3065 = gfc_get_string (PREFIX ("unpack%d_char"), field
->rank
> 0 ? 1 : 0);
3067 f
->value
.function
.name
3068 = gfc_get_string (PREFIX ("unpack%d_char%d"),
3069 field
->rank
> 0 ? 1 : 0, vector
->ts
.kind
);
3072 f
->value
.function
.name
3073 = gfc_get_string (PREFIX ("unpack%d"), field
->rank
> 0 ? 1 : 0);
3078 gfc_resolve_verify (gfc_expr
*f
, gfc_expr
*string
,
3079 gfc_expr
*set ATTRIBUTE_UNUSED
,
3080 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
3082 f
->ts
.type
= BT_INTEGER
;
3084 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
3086 f
->ts
.kind
= gfc_default_integer_kind
;
3087 f
->value
.function
.name
= gfc_get_string ("__verify_%d", string
->ts
.kind
);
3092 gfc_resolve_xor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
3094 f
->ts
.type
= i
->ts
.type
;
3095 f
->ts
.kind
= gfc_kind_max (i
, j
);
3097 if (i
->ts
.kind
!= j
->ts
.kind
)
3099 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
3100 gfc_convert_type (j
, &i
->ts
, 2);
3102 gfc_convert_type (i
, &j
->ts
, 2);
3105 f
->value
.function
.name
3106 = gfc_get_string ("__xor_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
3110 /* Intrinsic subroutine resolution. */
3113 gfc_resolve_alarm_sub (gfc_code
*c
)
3116 gfc_expr
*seconds
, *handler
;
3120 seconds
= c
->ext
.actual
->expr
;
3121 handler
= c
->ext
.actual
->next
->expr
;
3122 ts
.type
= BT_INTEGER
;
3123 ts
.kind
= gfc_c_int_kind
;
3125 /* handler can be either BT_INTEGER or BT_PROCEDURE.
3126 In all cases, the status argument is of default integer kind
3127 (enforced in check.c) so that the function suffix is fixed. */
3128 if (handler
->ts
.type
== BT_INTEGER
)
3130 if (handler
->ts
.kind
!= gfc_c_int_kind
)
3131 gfc_convert_type (handler
, &ts
, 2);
3132 name
= gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
3133 gfc_default_integer_kind
);
3136 name
= gfc_get_string (PREFIX ("alarm_sub_i%d"),
3137 gfc_default_integer_kind
);
3139 if (seconds
->ts
.kind
!= gfc_c_int_kind
)
3140 gfc_convert_type (seconds
, &ts
, 2);
3142 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3146 gfc_resolve_cpu_time (gfc_code
*c
)
3149 name
= gfc_get_string (PREFIX ("cpu_time_%d"), c
->ext
.actual
->expr
->ts
.kind
);
3150 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3154 /* Create a formal arglist based on an actual one and set the INTENTs given. */
3156 static gfc_formal_arglist
*
3157 create_formal_for_intents (gfc_actual_arglist
* actual
, const sym_intent
* ints
)
3159 gfc_formal_arglist
* head
;
3160 gfc_formal_arglist
* tail
;
3166 head
= tail
= gfc_get_formal_arglist ();
3167 for (i
= 0; actual
; actual
= actual
->next
, tail
= tail
->next
, ++i
)
3171 sym
= gfc_new_symbol ("dummyarg", NULL
);
3172 sym
->ts
= actual
->expr
->ts
;
3174 sym
->attr
.intent
= ints
[i
];
3178 tail
->next
= gfc_get_formal_arglist ();
3186 gfc_resolve_atomic_def (gfc_code
*c
)
3188 const char *name
= "atomic_define";
3189 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3194 gfc_resolve_atomic_ref (gfc_code
*c
)
3196 const char *name
= "atomic_ref";
3197 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3201 gfc_resolve_event_query (gfc_code
*c
)
3203 const char *name
= "event_query";
3204 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3208 gfc_resolve_mvbits (gfc_code
*c
)
3210 static const sym_intent INTENTS
[] = {INTENT_IN
, INTENT_IN
, INTENT_IN
,
3211 INTENT_INOUT
, INTENT_IN
};
3217 /* FROMPOS, LEN and TOPOS are restricted to small values. As such,
3218 they will be converted so that they fit into a C int. */
3219 ts
.type
= BT_INTEGER
;
3220 ts
.kind
= gfc_c_int_kind
;
3221 if (c
->ext
.actual
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
3222 gfc_convert_type (c
->ext
.actual
->next
->expr
, &ts
, 2);
3223 if (c
->ext
.actual
->next
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
3224 gfc_convert_type (c
->ext
.actual
->next
->next
->expr
, &ts
, 2);
3225 if (c
->ext
.actual
->next
->next
->next
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
3226 gfc_convert_type (c
->ext
.actual
->next
->next
->next
->next
->expr
, &ts
, 2);
3228 /* TO and FROM are guaranteed to have the same kind parameter. */
3229 name
= gfc_get_string (PREFIX ("mvbits_i%d"),
3230 c
->ext
.actual
->expr
->ts
.kind
);
3231 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3232 /* Mark as elemental subroutine as this does not happen automatically. */
3233 c
->resolved_sym
->attr
.elemental
= 1;
3235 /* Create a dummy formal arglist so the INTENTs are known later for purpose
3236 of creating temporaries. */
3237 c
->resolved_sym
->formal
= create_formal_for_intents (c
->ext
.actual
, INTENTS
);
3242 gfc_resolve_random_number (gfc_code
*c
)
3247 kind
= c
->ext
.actual
->expr
->ts
.kind
;
3248 if (c
->ext
.actual
->expr
->rank
== 0)
3249 name
= gfc_get_string (PREFIX ("random_r%d"), kind
);
3251 name
= gfc_get_string (PREFIX ("arandom_r%d"), kind
);
3253 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3258 gfc_resolve_random_seed (gfc_code
*c
)
3262 name
= gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind
);
3263 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3268 gfc_resolve_rename_sub (gfc_code
*c
)
3273 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3274 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3276 kind
= gfc_default_integer_kind
;
3278 name
= gfc_get_string (PREFIX ("rename_i%d_sub"), kind
);
3279 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3284 gfc_resolve_kill_sub (gfc_code
*c
)
3289 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3290 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3292 kind
= gfc_default_integer_kind
;
3294 name
= gfc_get_string (PREFIX ("kill_i%d_sub"), kind
);
3295 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3300 gfc_resolve_link_sub (gfc_code
*c
)
3305 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3306 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3308 kind
= gfc_default_integer_kind
;
3310 name
= gfc_get_string (PREFIX ("link_i%d_sub"), kind
);
3311 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3316 gfc_resolve_symlnk_sub (gfc_code
*c
)
3321 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3322 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3324 kind
= gfc_default_integer_kind
;
3326 name
= gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind
);
3327 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3331 /* G77 compatibility subroutines dtime() and etime(). */
3334 gfc_resolve_dtime_sub (gfc_code
*c
)
3337 name
= gfc_get_string (PREFIX ("dtime_sub"));
3338 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3342 gfc_resolve_etime_sub (gfc_code
*c
)
3345 name
= gfc_get_string (PREFIX ("etime_sub"));
3346 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3350 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
3353 gfc_resolve_itime (gfc_code
*c
)
3356 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
3357 gfc_default_integer_kind
));
3361 gfc_resolve_idate (gfc_code
*c
)
3364 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
3365 gfc_default_integer_kind
));
3369 gfc_resolve_ltime (gfc_code
*c
)
3372 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
3373 gfc_default_integer_kind
));
3377 gfc_resolve_gmtime (gfc_code
*c
)
3380 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
3381 gfc_default_integer_kind
));
3385 /* G77 compatibility subroutine second(). */
3388 gfc_resolve_second_sub (gfc_code
*c
)
3391 name
= gfc_get_string (PREFIX ("second_sub"));
3392 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3397 gfc_resolve_sleep_sub (gfc_code
*c
)
3402 if (c
->ext
.actual
->expr
!= NULL
)
3403 kind
= c
->ext
.actual
->expr
->ts
.kind
;
3405 kind
= gfc_default_integer_kind
;
3407 name
= gfc_get_string (PREFIX ("sleep_i%d_sub"), kind
);
3408 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3412 /* G77 compatibility function srand(). */
3415 gfc_resolve_srand (gfc_code
*c
)
3418 name
= gfc_get_string (PREFIX ("srand"));
3419 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3423 /* Resolve the getarg intrinsic subroutine. */
3426 gfc_resolve_getarg (gfc_code
*c
)
3430 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_default_integer_kind
)
3435 ts
.type
= BT_INTEGER
;
3436 ts
.kind
= gfc_default_integer_kind
;
3438 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3441 name
= gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind
);
3442 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3446 /* Resolve the getcwd intrinsic subroutine. */
3449 gfc_resolve_getcwd_sub (gfc_code
*c
)
3454 if (c
->ext
.actual
->next
->expr
!= NULL
)
3455 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3457 kind
= gfc_default_integer_kind
;
3459 name
= gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind
);
3460 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3464 /* Resolve the get_command intrinsic subroutine. */
3467 gfc_resolve_get_command (gfc_code
*c
)
3471 kind
= gfc_default_integer_kind
;
3472 name
= gfc_get_string (PREFIX ("get_command_i%d"), kind
);
3473 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3477 /* Resolve the get_command_argument intrinsic subroutine. */
3480 gfc_resolve_get_command_argument (gfc_code
*c
)
3484 kind
= gfc_default_integer_kind
;
3485 name
= gfc_get_string (PREFIX ("get_command_argument_i%d"), kind
);
3486 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3490 /* Resolve the get_environment_variable intrinsic subroutine. */
3493 gfc_resolve_get_environment_variable (gfc_code
*code
)
3497 kind
= gfc_default_integer_kind
;
3498 name
= gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind
);
3499 code
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3504 gfc_resolve_signal_sub (gfc_code
*c
)
3507 gfc_expr
*number
, *handler
, *status
;
3511 number
= c
->ext
.actual
->expr
;
3512 handler
= c
->ext
.actual
->next
->expr
;
3513 status
= c
->ext
.actual
->next
->next
->expr
;
3514 ts
.type
= BT_INTEGER
;
3515 ts
.kind
= gfc_c_int_kind
;
3517 /* handler can be either BT_INTEGER or BT_PROCEDURE */
3518 if (handler
->ts
.type
== BT_INTEGER
)
3520 if (handler
->ts
.kind
!= gfc_c_int_kind
)
3521 gfc_convert_type (handler
, &ts
, 2);
3522 name
= gfc_get_string (PREFIX ("signal_sub_int"));
3525 name
= gfc_get_string (PREFIX ("signal_sub"));
3527 if (number
->ts
.kind
!= gfc_c_int_kind
)
3528 gfc_convert_type (number
, &ts
, 2);
3529 if (status
!= NULL
&& status
->ts
.kind
!= gfc_c_int_kind
)
3530 gfc_convert_type (status
, &ts
, 2);
3532 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3536 /* Resolve the SYSTEM intrinsic subroutine. */
3539 gfc_resolve_system_sub (gfc_code
*c
)
3542 name
= gfc_get_string (PREFIX ("system_sub"));
3543 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3547 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
3550 gfc_resolve_system_clock (gfc_code
*c
)
3554 gfc_expr
*count
= c
->ext
.actual
->expr
;
3555 gfc_expr
*count_max
= c
->ext
.actual
->next
->next
->expr
;
3557 /* The INTEGER(8) version has higher precision, it is used if both COUNT
3558 and COUNT_MAX can hold 64-bit values, or are absent. */
3559 if ((!count
|| count
->ts
.kind
>= 8)
3560 && (!count_max
|| count_max
->ts
.kind
>= 8))
3563 kind
= gfc_default_integer_kind
;
3565 name
= gfc_get_string (PREFIX ("system_clock_%d"), kind
);
3566 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3570 /* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine. */
3572 gfc_resolve_execute_command_line (gfc_code
*c
)
3575 name
= gfc_get_string (PREFIX ("execute_command_line_i%d"),
3576 gfc_default_integer_kind
);
3577 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3581 /* Resolve the EXIT intrinsic subroutine. */
3584 gfc_resolve_exit (gfc_code
*c
)
3591 /* The STATUS argument has to be of default kind. If it is not,
3593 ts
.type
= BT_INTEGER
;
3594 ts
.kind
= gfc_default_integer_kind
;
3595 n
= c
->ext
.actual
->expr
;
3596 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3597 gfc_convert_type (n
, &ts
, 2);
3599 name
= gfc_get_string (PREFIX ("exit_i%d"), ts
.kind
);
3600 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3604 /* Resolve the FLUSH intrinsic subroutine. */
3607 gfc_resolve_flush (gfc_code
*c
)
3614 ts
.type
= BT_INTEGER
;
3615 ts
.kind
= gfc_default_integer_kind
;
3616 n
= c
->ext
.actual
->expr
;
3617 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3618 gfc_convert_type (n
, &ts
, 2);
3620 name
= gfc_get_string (PREFIX ("flush_i%d"), ts
.kind
);
3621 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3626 gfc_resolve_ctime_sub (gfc_code
*c
)
3631 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3632 if (c
->ext
.actual
->expr
->ts
.kind
!= 8)
3634 ts
.type
= BT_INTEGER
;
3636 ts
.u
.derived
= NULL
;
3638 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3641 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3646 gfc_resolve_fdate_sub (gfc_code
*c
)
3648 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3653 gfc_resolve_gerror (gfc_code
*c
)
3655 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3660 gfc_resolve_getlog (gfc_code
*c
)
3662 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3667 gfc_resolve_hostnm_sub (gfc_code
*c
)
3672 if (c
->ext
.actual
->next
->expr
!= NULL
)
3673 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3675 kind
= gfc_default_integer_kind
;
3677 name
= gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind
);
3678 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3683 gfc_resolve_perror (gfc_code
*c
)
3685 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3688 /* Resolve the STAT and FSTAT intrinsic subroutines. */
3691 gfc_resolve_stat_sub (gfc_code
*c
)
3694 name
= gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind
);
3695 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3700 gfc_resolve_lstat_sub (gfc_code
*c
)
3703 name
= gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind
);
3704 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3709 gfc_resolve_fstat_sub (gfc_code
*c
)
3715 u
= c
->ext
.actual
->expr
;
3716 ts
= &c
->ext
.actual
->next
->expr
->ts
;
3717 if (u
->ts
.kind
!= ts
->kind
)
3718 gfc_convert_type (u
, ts
, 2);
3719 name
= gfc_get_string (PREFIX ("fstat_i%d_sub"), ts
->kind
);
3720 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3725 gfc_resolve_fgetc_sub (gfc_code
*c
)
3732 u
= c
->ext
.actual
->expr
;
3733 st
= c
->ext
.actual
->next
->next
->expr
;
3735 if (u
->ts
.kind
!= gfc_c_int_kind
)
3737 ts
.type
= BT_INTEGER
;
3738 ts
.kind
= gfc_c_int_kind
;
3739 ts
.u
.derived
= NULL
;
3741 gfc_convert_type (u
, &ts
, 2);
3745 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), st
->ts
.kind
);
3747 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind
);
3749 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3754 gfc_resolve_fget_sub (gfc_code
*c
)
3759 st
= c
->ext
.actual
->next
->expr
;
3761 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), st
->ts
.kind
);
3763 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind
);
3765 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3770 gfc_resolve_fputc_sub (gfc_code
*c
)
3777 u
= c
->ext
.actual
->expr
;
3778 st
= c
->ext
.actual
->next
->next
->expr
;
3780 if (u
->ts
.kind
!= gfc_c_int_kind
)
3782 ts
.type
= BT_INTEGER
;
3783 ts
.kind
= gfc_c_int_kind
;
3784 ts
.u
.derived
= NULL
;
3786 gfc_convert_type (u
, &ts
, 2);
3790 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), st
->ts
.kind
);
3792 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind
);
3794 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3799 gfc_resolve_fput_sub (gfc_code
*c
)
3804 st
= c
->ext
.actual
->next
->expr
;
3806 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), st
->ts
.kind
);
3808 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind
);
3810 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3815 gfc_resolve_fseek_sub (gfc_code
*c
)
3823 unit
= c
->ext
.actual
->expr
;
3824 offset
= c
->ext
.actual
->next
->expr
;
3825 whence
= c
->ext
.actual
->next
->next
->expr
;
3827 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3829 ts
.type
= BT_INTEGER
;
3830 ts
.kind
= gfc_c_int_kind
;
3831 ts
.u
.derived
= NULL
;
3833 gfc_convert_type (unit
, &ts
, 2);
3836 if (offset
->ts
.kind
!= gfc_intio_kind
)
3838 ts
.type
= BT_INTEGER
;
3839 ts
.kind
= gfc_intio_kind
;
3840 ts
.u
.derived
= NULL
;
3842 gfc_convert_type (offset
, &ts
, 2);
3845 if (whence
->ts
.kind
!= gfc_c_int_kind
)
3847 ts
.type
= BT_INTEGER
;
3848 ts
.kind
= gfc_c_int_kind
;
3849 ts
.u
.derived
= NULL
;
3851 gfc_convert_type (whence
, &ts
, 2);
3854 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
3858 gfc_resolve_ftell_sub (gfc_code
*c
)
3866 unit
= c
->ext
.actual
->expr
;
3867 offset
= c
->ext
.actual
->next
->expr
;
3869 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3871 ts
.type
= BT_INTEGER
;
3872 ts
.kind
= gfc_c_int_kind
;
3873 ts
.u
.derived
= NULL
;
3875 gfc_convert_type (unit
, &ts
, 2);
3878 name
= gfc_get_string (PREFIX ("ftell_i%d_sub"), offset
->ts
.kind
);
3879 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3884 gfc_resolve_ttynam_sub (gfc_code
*c
)
3889 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
3891 ts
.type
= BT_INTEGER
;
3892 ts
.kind
= gfc_c_int_kind
;
3893 ts
.u
.derived
= NULL
;
3895 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3898 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
3902 /* Resolve the UMASK intrinsic subroutine. */
3905 gfc_resolve_umask_sub (gfc_code
*c
)
3910 if (c
->ext
.actual
->next
->expr
!= NULL
)
3911 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3913 kind
= gfc_default_integer_kind
;
3915 name
= gfc_get_string (PREFIX ("umask_i%d_sub"), kind
);
3916 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3919 /* Resolve the UNLINK intrinsic subroutine. */
3922 gfc_resolve_unlink_sub (gfc_code
*c
)
3927 if (c
->ext
.actual
->next
->expr
!= NULL
)
3928 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3930 kind
= gfc_default_integer_kind
;
3932 name
= gfc_get_string (PREFIX ("unlink_i%d_sub"), kind
);
3933 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);