1 /* Intrinsic function resolution.
2 Copyright (C) 2000-2016 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
, ...)
53 va_start (ap
, format
);
54 vsnprintf (temp_name
, sizeof (temp_name
), format
, ap
);
56 temp_name
[sizeof (temp_name
) - 1] = 0;
58 ident
= get_identifier (temp_name
);
59 return IDENTIFIER_POINTER (ident
);
62 /* MERGE and SPREAD need to have source charlen's present for passing
63 to the result expression. */
65 check_charlen_present (gfc_expr
*source
)
67 if (source
->ts
.u
.cl
== NULL
)
68 source
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
70 if (source
->expr_type
== EXPR_CONSTANT
)
72 source
->ts
.u
.cl
->length
73 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
74 source
->value
.character
.length
);
77 else if (source
->expr_type
== EXPR_ARRAY
)
79 gfc_constructor
*c
= gfc_constructor_first (source
->value
.constructor
);
80 source
->ts
.u
.cl
->length
81 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
82 c
->expr
->value
.character
.length
);
86 /* Helper function for resolving the "mask" argument. */
89 resolve_mask_arg (gfc_expr
*mask
)
97 /* For the scalar case, coerce the mask to kind=4 unconditionally
98 (because this is the only kind we have a library function
101 if (mask
->ts
.kind
!= 4)
103 ts
.type
= BT_LOGICAL
;
105 gfc_convert_type (mask
, &ts
, 2);
110 /* In the library, we access the mask with a GFC_LOGICAL_1
111 argument. No need to waste memory if we are about to create
112 a temporary array. */
113 if (mask
->expr_type
== EXPR_OP
&& mask
->ts
.kind
!= 1)
115 ts
.type
= BT_LOGICAL
;
117 gfc_convert_type_warn (mask
, &ts
, 2, 0);
124 resolve_bound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
,
125 const char *name
, bool coarray
)
127 f
->ts
.type
= BT_INTEGER
;
129 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
131 f
->ts
.kind
= gfc_default_integer_kind
;
136 if (array
->rank
!= -1)
138 f
->shape
= gfc_get_shape (1);
139 mpz_init_set_ui (f
->shape
[0], coarray
? gfc_get_corank (array
)
144 f
->value
.function
.name
= gfc_get_string (name
);
149 resolve_transformational (const char *name
, gfc_expr
*f
, gfc_expr
*array
,
150 gfc_expr
*dim
, gfc_expr
*mask
)
163 resolve_mask_arg (mask
);
170 f
->rank
= array
->rank
- 1;
171 f
->shape
= gfc_copy_shape_excluding (array
->shape
, array
->rank
, dim
);
172 gfc_resolve_dim_arg (dim
);
175 f
->value
.function
.name
176 = gfc_get_string (PREFIX ("%s%s_%c%d"), prefix
, name
,
177 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
181 /********************** Resolution functions **********************/
185 gfc_resolve_abs (gfc_expr
*f
, gfc_expr
*a
)
188 if (f
->ts
.type
== BT_COMPLEX
)
189 f
->ts
.type
= BT_REAL
;
191 f
->value
.function
.name
192 = gfc_get_string ("__abs_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
197 gfc_resolve_access (gfc_expr
*f
, gfc_expr
*name ATTRIBUTE_UNUSED
,
198 gfc_expr
*mode ATTRIBUTE_UNUSED
)
200 f
->ts
.type
= BT_INTEGER
;
201 f
->ts
.kind
= gfc_c_int_kind
;
202 f
->value
.function
.name
= PREFIX ("access_func");
207 gfc_resolve_adjustl (gfc_expr
*f
, gfc_expr
*string
)
209 f
->ts
.type
= BT_CHARACTER
;
210 f
->ts
.kind
= string
->ts
.kind
;
212 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, string
->ts
.u
.cl
);
214 f
->value
.function
.name
= gfc_get_string ("__adjustl_s%d", f
->ts
.kind
);
219 gfc_resolve_adjustr (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 ("__adjustr_s%d", f
->ts
.kind
);
231 gfc_resolve_char_achar (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*kind
,
234 f
->ts
.type
= BT_CHARACTER
;
235 f
->ts
.kind
= (kind
== NULL
)
236 ? gfc_default_character_kind
: mpz_get_si (kind
->value
.integer
);
237 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
238 f
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
240 f
->value
.function
.name
= gfc_get_string (name
, f
->ts
.kind
,
241 gfc_type_letter (x
->ts
.type
),
247 gfc_resolve_achar (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*kind
)
249 gfc_resolve_char_achar (f
, x
, kind
, "__achar_%d_%c%d");
254 gfc_resolve_acos (gfc_expr
*f
, gfc_expr
*x
)
257 f
->value
.function
.name
258 = gfc_get_string ("__acos_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
263 gfc_resolve_acosh (gfc_expr
*f
, gfc_expr
*x
)
266 f
->value
.function
.name
267 = gfc_get_string ("__acosh_%c%d", gfc_type_letter (x
->ts
.type
),
273 gfc_resolve_aimag (gfc_expr
*f
, gfc_expr
*x
)
275 f
->ts
.type
= BT_REAL
;
276 f
->ts
.kind
= x
->ts
.kind
;
277 f
->value
.function
.name
278 = gfc_get_string ("__aimag_%c%d", gfc_type_letter (x
->ts
.type
),
284 gfc_resolve_and (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
286 f
->ts
.type
= i
->ts
.type
;
287 f
->ts
.kind
= gfc_kind_max (i
, j
);
289 if (i
->ts
.kind
!= j
->ts
.kind
)
291 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
292 gfc_convert_type (j
, &i
->ts
, 2);
294 gfc_convert_type (i
, &j
->ts
, 2);
297 f
->value
.function
.name
298 = gfc_get_string ("__and_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
303 gfc_resolve_aint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
308 f
->ts
.type
= a
->ts
.type
;
309 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
311 if (a
->ts
.kind
!= f
->ts
.kind
)
313 ts
.type
= f
->ts
.type
;
314 ts
.kind
= f
->ts
.kind
;
315 gfc_convert_type (a
, &ts
, 2);
317 /* The resolved name is only used for specific intrinsics where
318 the return kind is the same as the arg kind. */
319 f
->value
.function
.name
320 = gfc_get_string ("__aint_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
325 gfc_resolve_dint (gfc_expr
*f
, gfc_expr
*a
)
327 gfc_resolve_aint (f
, a
, NULL
);
332 gfc_resolve_all (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
)
338 gfc_resolve_dim_arg (dim
);
339 f
->rank
= mask
->rank
- 1;
340 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
343 f
->value
.function
.name
344 = gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask
->ts
.type
),
350 gfc_resolve_anint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
355 f
->ts
.type
= a
->ts
.type
;
356 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
358 if (a
->ts
.kind
!= f
->ts
.kind
)
360 ts
.type
= f
->ts
.type
;
361 ts
.kind
= f
->ts
.kind
;
362 gfc_convert_type (a
, &ts
, 2);
365 /* The resolved name is only used for specific intrinsics where
366 the return kind is the same as the arg kind. */
367 f
->value
.function
.name
368 = gfc_get_string ("__anint_%c%d", gfc_type_letter (a
->ts
.type
),
374 gfc_resolve_dnint (gfc_expr
*f
, gfc_expr
*a
)
376 gfc_resolve_anint (f
, a
, NULL
);
381 gfc_resolve_any (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
)
387 gfc_resolve_dim_arg (dim
);
388 f
->rank
= mask
->rank
- 1;
389 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
392 f
->value
.function
.name
393 = gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask
->ts
.type
),
399 gfc_resolve_asin (gfc_expr
*f
, gfc_expr
*x
)
402 f
->value
.function
.name
403 = gfc_get_string ("__asin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
407 gfc_resolve_asinh (gfc_expr
*f
, gfc_expr
*x
)
410 f
->value
.function
.name
411 = gfc_get_string ("__asinh_%c%d", gfc_type_letter (x
->ts
.type
),
416 gfc_resolve_atan (gfc_expr
*f
, gfc_expr
*x
)
419 f
->value
.function
.name
420 = gfc_get_string ("__atan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
424 gfc_resolve_atanh (gfc_expr
*f
, gfc_expr
*x
)
427 f
->value
.function
.name
428 = gfc_get_string ("__atanh_%c%d", gfc_type_letter (x
->ts
.type
),
433 gfc_resolve_atan2 (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
436 f
->value
.function
.name
437 = gfc_get_string ("__atan2_%c%d", gfc_type_letter (x
->ts
.type
),
442 /* Resolve the BESYN and BESJN intrinsics. */
445 gfc_resolve_besn (gfc_expr
*f
, gfc_expr
*n
, gfc_expr
*x
)
451 if (n
->ts
.kind
!= gfc_c_int_kind
)
453 ts
.type
= BT_INTEGER
;
454 ts
.kind
= gfc_c_int_kind
;
455 gfc_convert_type (n
, &ts
, 2);
457 f
->value
.function
.name
= gfc_get_string ("<intrinsic>");
462 gfc_resolve_bessel_n2 (gfc_expr
*f
, gfc_expr
*n1
, gfc_expr
*n2
, gfc_expr
*x
)
469 if (n1
->expr_type
== EXPR_CONSTANT
&& n2
->expr_type
== EXPR_CONSTANT
)
471 f
->shape
= gfc_get_shape (1);
472 mpz_init (f
->shape
[0]);
473 mpz_sub (f
->shape
[0], n2
->value
.integer
, n1
->value
.integer
);
474 mpz_add_ui (f
->shape
[0], f
->shape
[0], 1);
477 if (n1
->ts
.kind
!= gfc_c_int_kind
)
479 ts
.type
= BT_INTEGER
;
480 ts
.kind
= gfc_c_int_kind
;
481 gfc_convert_type (n1
, &ts
, 2);
484 if (n2
->ts
.kind
!= gfc_c_int_kind
)
486 ts
.type
= BT_INTEGER
;
487 ts
.kind
= gfc_c_int_kind
;
488 gfc_convert_type (n2
, &ts
, 2);
491 if (f
->value
.function
.isym
->id
== GFC_ISYM_JN2
)
492 f
->value
.function
.name
= gfc_get_string (PREFIX ("bessel_jn_r%d"),
495 f
->value
.function
.name
= gfc_get_string (PREFIX ("bessel_yn_r%d"),
501 gfc_resolve_btest (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos
)
503 f
->ts
.type
= BT_LOGICAL
;
504 f
->ts
.kind
= gfc_default_logical_kind
;
505 f
->value
.function
.name
506 = gfc_get_string ("__btest_%d_%d", i
->ts
.kind
, pos
->ts
.kind
);
511 gfc_resolve_c_loc (gfc_expr
*f
, gfc_expr
*x ATTRIBUTE_UNUSED
)
513 f
->ts
= f
->value
.function
.isym
->ts
;
518 gfc_resolve_c_funloc (gfc_expr
*f
, gfc_expr
*x ATTRIBUTE_UNUSED
)
520 f
->ts
= f
->value
.function
.isym
->ts
;
525 gfc_resolve_ceiling (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
527 f
->ts
.type
= BT_INTEGER
;
528 f
->ts
.kind
= (kind
== NULL
)
529 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
530 f
->value
.function
.name
531 = gfc_get_string ("__ceiling_%d_%c%d", f
->ts
.kind
,
532 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
537 gfc_resolve_char (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
539 gfc_resolve_char_achar (f
, a
, kind
, "__char_%d_%c%d");
544 gfc_resolve_chdir (gfc_expr
*f
, gfc_expr
*d ATTRIBUTE_UNUSED
)
546 f
->ts
.type
= BT_INTEGER
;
547 f
->ts
.kind
= gfc_default_integer_kind
;
548 f
->value
.function
.name
= gfc_get_string (PREFIX ("chdir_i%d"), f
->ts
.kind
);
553 gfc_resolve_chdir_sub (gfc_code
*c
)
558 if (c
->ext
.actual
->next
->expr
!= NULL
)
559 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
561 kind
= gfc_default_integer_kind
;
563 name
= gfc_get_string (PREFIX ("chdir_i%d_sub"), kind
);
564 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
569 gfc_resolve_chmod (gfc_expr
*f
, gfc_expr
*name ATTRIBUTE_UNUSED
,
570 gfc_expr
*mode ATTRIBUTE_UNUSED
)
572 f
->ts
.type
= BT_INTEGER
;
573 f
->ts
.kind
= gfc_c_int_kind
;
574 f
->value
.function
.name
= PREFIX ("chmod_func");
579 gfc_resolve_chmod_sub (gfc_code
*c
)
584 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
585 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
587 kind
= gfc_default_integer_kind
;
589 name
= gfc_get_string (PREFIX ("chmod_i%d_sub"), kind
);
590 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
595 gfc_resolve_cmplx (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*kind
)
597 f
->ts
.type
= BT_COMPLEX
;
598 f
->ts
.kind
= (kind
== NULL
)
599 ? gfc_default_real_kind
: mpz_get_si (kind
->value
.integer
);
602 f
->value
.function
.name
603 = gfc_get_string ("__cmplx0_%d_%c%d", f
->ts
.kind
,
604 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
606 f
->value
.function
.name
607 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f
->ts
.kind
,
608 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
,
609 gfc_type_letter (y
->ts
.type
), y
->ts
.kind
);
614 gfc_resolve_dcmplx (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
)
616 gfc_resolve_cmplx (f
, x
, y
, gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
617 gfc_default_double_kind
));
622 gfc_resolve_complex (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
)
626 if (x
->ts
.type
== BT_INTEGER
)
628 if (y
->ts
.type
== BT_INTEGER
)
629 kind
= gfc_default_real_kind
;
635 if (y
->ts
.type
== BT_REAL
)
636 kind
= (x
->ts
.kind
> y
->ts
.kind
) ? x
->ts
.kind
: y
->ts
.kind
;
641 f
->ts
.type
= BT_COMPLEX
;
643 f
->value
.function
.name
644 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f
->ts
.kind
,
645 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
,
646 gfc_type_letter (y
->ts
.type
), y
->ts
.kind
);
651 gfc_resolve_conjg (gfc_expr
*f
, gfc_expr
*x
)
654 f
->value
.function
.name
= gfc_get_string ("__conjg_%d", x
->ts
.kind
);
659 gfc_resolve_cos (gfc_expr
*f
, gfc_expr
*x
)
662 f
->value
.function
.name
663 = gfc_get_string ("__cos_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
668 gfc_resolve_cosh (gfc_expr
*f
, gfc_expr
*x
)
671 f
->value
.function
.name
672 = gfc_get_string ("__cosh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
676 /* Our replacement of elements of a trig call with an EXPR_OP (e.g.
677 multiplying the result or operands by a factor to convert to/from degrees)
678 will cause the resolve_* function to be invoked again when resolving the
679 freshly created EXPR_OP. See gfc_resolve_trigd, gfc_resolve_atrigd,
680 gfc_resolve_cotan. We must observe this and avoid recursively creating
681 layers of nested EXPR_OP expressions. */
684 is_trig_resolved (gfc_expr
*f
)
686 /* We know we've already resolved the function if we see the lib call
687 starting with '__'. */
688 return f
->value
.function
.name
!= NULL
689 && 0 == strncmp ("__", f
->value
.function
.name
, 2);
692 /* Return a shallow copy of the function expression f. The original expression
693 has its pointers cleared so that it may be freed without affecting the
694 shallow copy. This is similar to gfc_copy_expr, but doesn't perform a deep
695 copy of the argument list, allowing it to be reused somewhere else,
696 setting the expression up nicely for gfc_replace_expr. */
699 copy_replace_function_shallow (gfc_expr
*f
)
702 gfc_actual_arglist
*args
;
704 /* The only thing deep-copied in gfc_copy_expr is args. */
705 args
= f
->value
.function
.actual
;
706 f
->value
.function
.actual
= NULL
;
707 fcopy
= gfc_copy_expr (f
);
708 fcopy
->value
.function
.actual
= args
;
710 /* Clear the old function so the shallow copy is not affected if the old
711 expression is freed. */
712 f
->value
.function
.name
= NULL
;
713 f
->value
.function
.isym
= NULL
;
714 f
->value
.function
.actual
= NULL
;
715 f
->value
.function
.esym
= NULL
;
723 /* Resolve cotan = cos / sin. */
726 gfc_resolve_cotan (gfc_expr
*f
, gfc_expr
*x
)
728 gfc_expr
*result
, *fcopy
, *sin
;
729 gfc_actual_arglist
*sin_args
;
731 if (is_trig_resolved (f
))
734 /* Compute cotan (x) = cos (x) / sin (x). */
735 f
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_COS
);
736 gfc_resolve_cos (f
, x
);
738 sin_args
= gfc_get_actual_arglist ();
739 sin_args
->expr
= gfc_copy_expr (x
);
741 sin
= gfc_get_expr ();
743 sin
->where
= f
->where
;
744 sin
->expr_type
= EXPR_FUNCTION
;
745 sin
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_SIN
);
746 sin
->value
.function
.actual
= sin_args
;
747 gfc_resolve_sin (sin
, sin_args
->expr
);
749 /* Replace f with cos/sin - we do this in place in f for the caller. */
750 fcopy
= copy_replace_function_shallow (f
);
751 result
= gfc_divide (fcopy
, sin
);
752 gfc_replace_expr (f
, result
);
757 gfc_resolve_count (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
759 f
->ts
.type
= BT_INTEGER
;
761 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
763 f
->ts
.kind
= gfc_default_integer_kind
;
767 f
->rank
= mask
->rank
- 1;
768 gfc_resolve_dim_arg (dim
);
769 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
772 resolve_mask_arg (mask
);
774 f
->value
.function
.name
775 = gfc_get_string (PREFIX ("count_%d_%c"), f
->ts
.kind
,
776 gfc_type_letter (mask
->ts
.type
));
781 gfc_resolve_cshift (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*shift
,
786 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
787 gfc_resolve_substring_charlen (array
);
790 f
->rank
= array
->rank
;
791 f
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
798 /* If dim kind is greater than default integer we need to use the larger. */
799 m
= gfc_default_integer_kind
;
801 m
= m
< dim
->ts
.kind
? dim
->ts
.kind
: m
;
803 /* Convert shift to at least m, so we don't need
804 kind=1 and kind=2 versions of the library functions. */
805 if (shift
->ts
.kind
< m
)
809 ts
.type
= BT_INTEGER
;
811 gfc_convert_type_warn (shift
, &ts
, 2, 0);
816 if (dim
->expr_type
!= EXPR_CONSTANT
&& dim
->symtree
!= NULL
817 && dim
->symtree
->n
.sym
->attr
.optional
)
819 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
820 dim
->representation
.length
= shift
->ts
.kind
;
824 gfc_resolve_dim_arg (dim
);
825 /* Convert dim to shift's kind to reduce variations. */
826 if (dim
->ts
.kind
!= shift
->ts
.kind
)
827 gfc_convert_type_warn (dim
, &shift
->ts
, 2, 0);
831 if (array
->ts
.type
== BT_CHARACTER
)
833 if (array
->ts
.kind
== gfc_default_character_kind
)
834 f
->value
.function
.name
835 = gfc_get_string (PREFIX ("cshift%d_%d_char"), n
, shift
->ts
.kind
);
837 f
->value
.function
.name
838 = gfc_get_string (PREFIX ("cshift%d_%d_char%d"), n
, shift
->ts
.kind
,
842 f
->value
.function
.name
843 = gfc_get_string (PREFIX ("cshift%d_%d"), n
, shift
->ts
.kind
);
848 gfc_resolve_ctime (gfc_expr
*f
, gfc_expr
*time
)
853 f
->ts
.type
= BT_CHARACTER
;
854 f
->ts
.kind
= gfc_default_character_kind
;
856 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
857 if (time
->ts
.kind
!= 8)
859 ts
.type
= BT_INTEGER
;
863 gfc_convert_type (time
, &ts
, 2);
866 f
->value
.function
.name
= gfc_get_string (PREFIX ("ctime"));
871 gfc_resolve_dble (gfc_expr
*f
, gfc_expr
*a
)
873 f
->ts
.type
= BT_REAL
;
874 f
->ts
.kind
= gfc_default_double_kind
;
875 f
->value
.function
.name
876 = gfc_get_string ("__dble_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
881 gfc_resolve_dim (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
883 f
->ts
.type
= a
->ts
.type
;
885 f
->ts
.kind
= gfc_kind_max (a
,p
);
887 f
->ts
.kind
= a
->ts
.kind
;
889 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
891 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
892 gfc_convert_type (p
, &a
->ts
, 2);
894 gfc_convert_type (a
, &p
->ts
, 2);
897 f
->value
.function
.name
898 = gfc_get_string ("__dim_%c%d", gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
903 gfc_resolve_dot_product (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b
)
907 temp
.expr_type
= EXPR_OP
;
908 gfc_clear_ts (&temp
.ts
);
909 temp
.value
.op
.op
= INTRINSIC_NONE
;
910 temp
.value
.op
.op1
= a
;
911 temp
.value
.op
.op2
= b
;
912 gfc_type_convert_binary (&temp
, 1);
914 f
->value
.function
.name
915 = gfc_get_string (PREFIX ("dot_product_%c%d"),
916 gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
921 gfc_resolve_dprod (gfc_expr
*f
, gfc_expr
*a ATTRIBUTE_UNUSED
,
922 gfc_expr
*b ATTRIBUTE_UNUSED
)
924 f
->ts
.kind
= gfc_default_double_kind
;
925 f
->ts
.type
= BT_REAL
;
926 f
->value
.function
.name
= gfc_get_string ("__dprod_r%d", f
->ts
.kind
);
931 gfc_resolve_dshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j ATTRIBUTE_UNUSED
,
932 gfc_expr
*shift ATTRIBUTE_UNUSED
)
935 if (f
->value
.function
.isym
->id
== GFC_ISYM_DSHIFTL
)
936 f
->value
.function
.name
= gfc_get_string ("dshiftl_i%d", f
->ts
.kind
);
937 else if (f
->value
.function
.isym
->id
== GFC_ISYM_DSHIFTR
)
938 f
->value
.function
.name
= gfc_get_string ("dshiftr_i%d", f
->ts
.kind
);
945 gfc_resolve_eoshift (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*shift
,
946 gfc_expr
*boundary
, gfc_expr
*dim
)
950 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
951 gfc_resolve_substring_charlen (array
);
954 f
->rank
= array
->rank
;
955 f
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
960 if (boundary
&& boundary
->rank
> 0)
963 /* If dim kind is greater than default integer we need to use the larger. */
964 m
= gfc_default_integer_kind
;
966 m
= m
< dim
->ts
.kind
? dim
->ts
.kind
: m
;
968 /* Convert shift to at least m, so we don't need
969 kind=1 and kind=2 versions of the library functions. */
970 if (shift
->ts
.kind
< m
)
974 ts
.type
= BT_INTEGER
;
976 gfc_convert_type_warn (shift
, &ts
, 2, 0);
981 if (dim
->expr_type
!= EXPR_CONSTANT
&& dim
->symtree
!= NULL
982 && dim
->symtree
->n
.sym
->attr
.optional
)
984 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
985 dim
->representation
.length
= shift
->ts
.kind
;
989 gfc_resolve_dim_arg (dim
);
990 /* Convert dim to shift's kind to reduce variations. */
991 if (dim
->ts
.kind
!= shift
->ts
.kind
)
992 gfc_convert_type_warn (dim
, &shift
->ts
, 2, 0);
996 if (array
->ts
.type
== BT_CHARACTER
)
998 if (array
->ts
.kind
== gfc_default_character_kind
)
999 f
->value
.function
.name
1000 = gfc_get_string (PREFIX ("eoshift%d_%d_char"), n
, shift
->ts
.kind
);
1002 f
->value
.function
.name
1003 = gfc_get_string (PREFIX ("eoshift%d_%d_char%d"), n
, shift
->ts
.kind
,
1007 f
->value
.function
.name
1008 = gfc_get_string (PREFIX ("eoshift%d_%d"), n
, shift
->ts
.kind
);
1013 gfc_resolve_exp (gfc_expr
*f
, gfc_expr
*x
)
1016 f
->value
.function
.name
1017 = gfc_get_string ("__exp_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1022 gfc_resolve_exponent (gfc_expr
*f
, gfc_expr
*x
)
1024 f
->ts
.type
= BT_INTEGER
;
1025 f
->ts
.kind
= gfc_default_integer_kind
;
1026 f
->value
.function
.name
= gfc_get_string ("__exponent_%d", x
->ts
.kind
);
1030 /* Resolve the EXTENDS_TYPE_OF intrinsic function. */
1033 gfc_resolve_extends_type_of (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*mo
)
1038 /* Prevent double resolution. */
1039 if (f
->ts
.type
== BT_LOGICAL
)
1042 /* Replace the first argument with the corresponding vtab. */
1043 if (a
->ts
.type
== BT_CLASS
)
1044 gfc_add_vptr_component (a
);
1045 else if (a
->ts
.type
== BT_DERIVED
)
1047 vtab
= gfc_find_derived_vtab (a
->ts
.u
.derived
);
1048 /* Clear the old expr. */
1049 gfc_free_ref_list (a
->ref
);
1050 memset (a
, '\0', sizeof (gfc_expr
));
1051 /* Construct a new one. */
1052 a
->expr_type
= EXPR_VARIABLE
;
1053 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
1058 /* Replace the second argument with the corresponding vtab. */
1059 if (mo
->ts
.type
== BT_CLASS
)
1060 gfc_add_vptr_component (mo
);
1061 else if (mo
->ts
.type
== BT_DERIVED
)
1063 vtab
= gfc_find_derived_vtab (mo
->ts
.u
.derived
);
1064 /* Clear the old expr. */
1065 gfc_free_ref_list (mo
->ref
);
1066 memset (mo
, '\0', sizeof (gfc_expr
));
1067 /* Construct a new one. */
1068 mo
->expr_type
= EXPR_VARIABLE
;
1069 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
1074 f
->ts
.type
= BT_LOGICAL
;
1077 f
->value
.function
.isym
->formal
->ts
= a
->ts
;
1078 f
->value
.function
.isym
->formal
->next
->ts
= mo
->ts
;
1080 /* Call library function. */
1081 f
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
1086 gfc_resolve_fdate (gfc_expr
*f
)
1088 f
->ts
.type
= BT_CHARACTER
;
1089 f
->ts
.kind
= gfc_default_character_kind
;
1090 f
->value
.function
.name
= gfc_get_string (PREFIX ("fdate"));
1095 gfc_resolve_floor (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1097 f
->ts
.type
= BT_INTEGER
;
1098 f
->ts
.kind
= (kind
== NULL
)
1099 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
1100 f
->value
.function
.name
1101 = gfc_get_string ("__floor%d_%c%d", f
->ts
.kind
,
1102 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1107 gfc_resolve_fnum (gfc_expr
*f
, gfc_expr
*n
)
1109 f
->ts
.type
= BT_INTEGER
;
1110 f
->ts
.kind
= gfc_default_integer_kind
;
1111 if (n
->ts
.kind
!= f
->ts
.kind
)
1112 gfc_convert_type (n
, &f
->ts
, 2);
1113 f
->value
.function
.name
= gfc_get_string (PREFIX ("fnum_i%d"), f
->ts
.kind
);
1118 gfc_resolve_fraction (gfc_expr
*f
, gfc_expr
*x
)
1121 f
->value
.function
.name
= gfc_get_string ("__fraction_%d", x
->ts
.kind
);
1125 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
1128 gfc_resolve_g77_math1 (gfc_expr
*f
, gfc_expr
*x
)
1131 f
->value
.function
.name
= gfc_get_string ("<intrinsic>");
1136 gfc_resolve_gamma (gfc_expr
*f
, gfc_expr
*x
)
1139 f
->value
.function
.name
1140 = gfc_get_string ("__tgamma_%d", x
->ts
.kind
);
1145 gfc_resolve_getcwd (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
1147 f
->ts
.type
= BT_INTEGER
;
1149 f
->value
.function
.name
= gfc_get_string (PREFIX ("getcwd"));
1154 gfc_resolve_getgid (gfc_expr
*f
)
1156 f
->ts
.type
= BT_INTEGER
;
1158 f
->value
.function
.name
= gfc_get_string (PREFIX ("getgid"));
1163 gfc_resolve_getpid (gfc_expr
*f
)
1165 f
->ts
.type
= BT_INTEGER
;
1167 f
->value
.function
.name
= gfc_get_string (PREFIX ("getpid"));
1172 gfc_resolve_getuid (gfc_expr
*f
)
1174 f
->ts
.type
= BT_INTEGER
;
1176 f
->value
.function
.name
= gfc_get_string (PREFIX ("getuid"));
1181 gfc_resolve_hostnm (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
1183 f
->ts
.type
= BT_INTEGER
;
1185 f
->value
.function
.name
= gfc_get_string (PREFIX ("hostnm"));
1190 gfc_resolve_hypot (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
1193 f
->value
.function
.name
= gfc_get_string ("__hypot_r%d", x
->ts
.kind
);
1198 gfc_resolve_iall (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
1200 resolve_transformational ("iall", f
, array
, dim
, mask
);
1205 gfc_resolve_iand (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1207 /* If the kind of i and j are different, then g77 cross-promoted the
1208 kinds to the largest value. The Fortran 95 standard requires the
1210 if (i
->ts
.kind
!= j
->ts
.kind
)
1212 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1213 gfc_convert_type (j
, &i
->ts
, 2);
1215 gfc_convert_type (i
, &j
->ts
, 2);
1219 f
->value
.function
.name
= gfc_get_string ("__iand_%d", i
->ts
.kind
);
1224 gfc_resolve_iany (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
1226 resolve_transformational ("iany", f
, array
, dim
, mask
);
1231 gfc_resolve_ibclr (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
)
1234 f
->value
.function
.name
= gfc_get_string ("__ibclr_%d", i
->ts
.kind
);
1239 gfc_resolve_ibits (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
,
1240 gfc_expr
*len ATTRIBUTE_UNUSED
)
1243 f
->value
.function
.name
= gfc_get_string ("__ibits_%d", i
->ts
.kind
);
1248 gfc_resolve_ibset (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
)
1251 f
->value
.function
.name
= gfc_get_string ("__ibset_%d", i
->ts
.kind
);
1256 gfc_resolve_iachar (gfc_expr
*f
, gfc_expr
*c
, gfc_expr
*kind
)
1258 f
->ts
.type
= BT_INTEGER
;
1260 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1262 f
->ts
.kind
= gfc_default_integer_kind
;
1263 f
->value
.function
.name
= gfc_get_string ("__ichar_%d", c
->ts
.kind
);
1268 gfc_resolve_ichar (gfc_expr
*f
, gfc_expr
*c
, gfc_expr
*kind
)
1270 f
->ts
.type
= BT_INTEGER
;
1272 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1274 f
->ts
.kind
= gfc_default_integer_kind
;
1275 f
->value
.function
.name
= gfc_get_string ("__ichar_%d", c
->ts
.kind
);
1280 gfc_resolve_idnint (gfc_expr
*f
, gfc_expr
*a
)
1282 gfc_resolve_nint (f
, a
, NULL
);
1287 gfc_resolve_ierrno (gfc_expr
*f
)
1289 f
->ts
.type
= BT_INTEGER
;
1290 f
->ts
.kind
= gfc_default_integer_kind
;
1291 f
->value
.function
.name
= gfc_get_string (PREFIX ("ierrno_i%d"), f
->ts
.kind
);
1296 gfc_resolve_ieor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1298 /* If the kind of i and j are different, then g77 cross-promoted the
1299 kinds to the largest value. The Fortran 95 standard requires the
1301 if (i
->ts
.kind
!= j
->ts
.kind
)
1303 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1304 gfc_convert_type (j
, &i
->ts
, 2);
1306 gfc_convert_type (i
, &j
->ts
, 2);
1310 f
->value
.function
.name
= gfc_get_string ("__ieor_%d", i
->ts
.kind
);
1315 gfc_resolve_ior (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1317 /* If the kind of i and j are different, then g77 cross-promoted the
1318 kinds to the largest value. The Fortran 95 standard requires the
1320 if (i
->ts
.kind
!= j
->ts
.kind
)
1322 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1323 gfc_convert_type (j
, &i
->ts
, 2);
1325 gfc_convert_type (i
, &j
->ts
, 2);
1329 f
->value
.function
.name
= gfc_get_string ("__ior_%d", i
->ts
.kind
);
1334 gfc_resolve_index_func (gfc_expr
*f
, gfc_expr
*str
,
1335 gfc_expr
*sub_str ATTRIBUTE_UNUSED
, gfc_expr
*back
,
1341 f
->ts
.type
= BT_INTEGER
;
1343 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1345 f
->ts
.kind
= gfc_default_integer_kind
;
1347 if (back
&& back
->ts
.kind
!= gfc_default_integer_kind
)
1349 ts
.type
= BT_LOGICAL
;
1350 ts
.kind
= gfc_default_integer_kind
;
1351 ts
.u
.derived
= NULL
;
1353 gfc_convert_type (back
, &ts
, 2);
1356 f
->value
.function
.name
1357 = gfc_get_string ("__index_%d_i%d", str
->ts
.kind
, f
->ts
.kind
);
1362 gfc_resolve_int (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1364 f
->ts
.type
= BT_INTEGER
;
1365 f
->ts
.kind
= (kind
== NULL
)
1366 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
1367 f
->value
.function
.name
1368 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1369 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1374 gfc_resolve_int2 (gfc_expr
*f
, gfc_expr
*a
)
1376 f
->ts
.type
= BT_INTEGER
;
1378 f
->value
.function
.name
1379 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1380 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1385 gfc_resolve_int8 (gfc_expr
*f
, gfc_expr
*a
)
1387 f
->ts
.type
= BT_INTEGER
;
1389 f
->value
.function
.name
1390 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1391 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1396 gfc_resolve_long (gfc_expr
*f
, gfc_expr
*a
)
1398 f
->ts
.type
= BT_INTEGER
;
1400 f
->value
.function
.name
1401 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1402 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1407 gfc_resolve_iparity (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
1409 resolve_transformational ("iparity", f
, array
, dim
, mask
);
1414 gfc_resolve_isatty (gfc_expr
*f
, gfc_expr
*u
)
1419 f
->ts
.type
= BT_LOGICAL
;
1420 f
->ts
.kind
= gfc_default_integer_kind
;
1421 if (u
->ts
.kind
!= gfc_c_int_kind
)
1423 ts
.type
= BT_INTEGER
;
1424 ts
.kind
= gfc_c_int_kind
;
1425 ts
.u
.derived
= NULL
;
1427 gfc_convert_type (u
, &ts
, 2);
1430 f
->value
.function
.name
= gfc_get_string (PREFIX ("isatty_l%d"), f
->ts
.kind
);
1435 gfc_resolve_ishft (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1438 f
->value
.function
.name
1439 = gfc_get_string ("__ishft_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1444 gfc_resolve_rshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1447 f
->value
.function
.name
1448 = gfc_get_string ("__rshift_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1453 gfc_resolve_lshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1456 f
->value
.function
.name
1457 = gfc_get_string ("__lshift_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1462 gfc_resolve_ishftc (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
1466 s_kind
= (size
== NULL
) ? gfc_default_integer_kind
: size
->ts
.kind
;
1469 f
->value
.function
.name
1470 = gfc_get_string ("__ishftc_%d_%d_%d", i
->ts
.kind
, shift
->ts
.kind
, s_kind
);
1475 gfc_resolve_kill (gfc_expr
*f
, gfc_expr
*p ATTRIBUTE_UNUSED
,
1476 gfc_expr
*s ATTRIBUTE_UNUSED
)
1478 f
->ts
.type
= BT_INTEGER
;
1479 f
->ts
.kind
= gfc_default_integer_kind
;
1480 f
->value
.function
.name
= gfc_get_string (PREFIX ("kill_i%d"), f
->ts
.kind
);
1485 gfc_resolve_lbound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
1487 resolve_bound (f
, array
, dim
, kind
, "__lbound", false);
1492 gfc_resolve_lcobound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
1494 resolve_bound (f
, array
, dim
, kind
, "__lcobound", true);
1499 gfc_resolve_len (gfc_expr
*f
, gfc_expr
*string
, gfc_expr
*kind
)
1501 f
->ts
.type
= BT_INTEGER
;
1503 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1505 f
->ts
.kind
= gfc_default_integer_kind
;
1506 f
->value
.function
.name
1507 = gfc_get_string ("__len_%d_i%d", string
->ts
.kind
,
1508 gfc_default_integer_kind
);
1513 gfc_resolve_len_trim (gfc_expr
*f
, gfc_expr
*string
, gfc_expr
*kind
)
1515 f
->ts
.type
= BT_INTEGER
;
1517 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1519 f
->ts
.kind
= gfc_default_integer_kind
;
1520 f
->value
.function
.name
= gfc_get_string ("__len_trim%d", string
->ts
.kind
);
1525 gfc_resolve_lgamma (gfc_expr
*f
, gfc_expr
*x
)
1528 f
->value
.function
.name
1529 = gfc_get_string ("__lgamma_%d", x
->ts
.kind
);
1534 gfc_resolve_link (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
1535 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
1537 f
->ts
.type
= BT_INTEGER
;
1538 f
->ts
.kind
= gfc_default_integer_kind
;
1539 f
->value
.function
.name
= gfc_get_string (PREFIX ("link_i%d"), f
->ts
.kind
);
1544 gfc_resolve_loc (gfc_expr
*f
, gfc_expr
*x
)
1546 f
->ts
.type
= BT_INTEGER
;
1547 f
->ts
.kind
= gfc_index_integer_kind
;
1548 f
->value
.function
.name
= gfc_get_string ("__loc_%d", x
->ts
.kind
);
1553 gfc_resolve_log (gfc_expr
*f
, gfc_expr
*x
)
1556 f
->value
.function
.name
1557 = gfc_get_string ("__log_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1562 gfc_resolve_log10 (gfc_expr
*f
, gfc_expr
*x
)
1565 f
->value
.function
.name
1566 = gfc_get_string ("__log10_%c%d", gfc_type_letter (x
->ts
.type
),
1572 gfc_resolve_logical (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1574 f
->ts
.type
= BT_LOGICAL
;
1575 f
->ts
.kind
= (kind
== NULL
)
1576 ? gfc_default_logical_kind
: mpz_get_si (kind
->value
.integer
);
1579 f
->value
.function
.name
1580 = gfc_get_string ("__logical_%d_%c%d", f
->ts
.kind
,
1581 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1586 gfc_resolve_matmul (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b
)
1590 if (a
->ts
.type
== BT_LOGICAL
&& b
->ts
.type
== BT_LOGICAL
)
1592 f
->ts
.type
= BT_LOGICAL
;
1593 f
->ts
.kind
= gfc_default_logical_kind
;
1597 temp
.expr_type
= EXPR_OP
;
1598 gfc_clear_ts (&temp
.ts
);
1599 temp
.value
.op
.op
= INTRINSIC_NONE
;
1600 temp
.value
.op
.op1
= a
;
1601 temp
.value
.op
.op2
= b
;
1602 gfc_type_convert_binary (&temp
, 1);
1606 f
->rank
= (a
->rank
== 2 && b
->rank
== 2) ? 2 : 1;
1608 if (a
->rank
== 2 && b
->rank
== 2)
1610 if (a
->shape
&& b
->shape
)
1612 f
->shape
= gfc_get_shape (f
->rank
);
1613 mpz_init_set (f
->shape
[0], a
->shape
[0]);
1614 mpz_init_set (f
->shape
[1], b
->shape
[1]);
1617 else if (a
->rank
== 1)
1621 f
->shape
= gfc_get_shape (f
->rank
);
1622 mpz_init_set (f
->shape
[0], b
->shape
[1]);
1627 /* b->rank == 1 and a->rank == 2 here, all other cases have
1628 been caught in check.c. */
1631 f
->shape
= gfc_get_shape (f
->rank
);
1632 mpz_init_set (f
->shape
[0], a
->shape
[0]);
1636 f
->value
.function
.name
1637 = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f
->ts
.type
),
1643 gfc_resolve_minmax (const char *name
, gfc_expr
*f
, gfc_actual_arglist
*args
)
1645 gfc_actual_arglist
*a
;
1647 f
->ts
.type
= args
->expr
->ts
.type
;
1648 f
->ts
.kind
= args
->expr
->ts
.kind
;
1649 /* Find the largest type kind. */
1650 for (a
= args
->next
; a
; a
= a
->next
)
1652 if (a
->expr
->ts
.kind
> f
->ts
.kind
)
1653 f
->ts
.kind
= a
->expr
->ts
.kind
;
1656 /* Convert all parameters to the required kind. */
1657 for (a
= args
; a
; a
= a
->next
)
1659 if (a
->expr
->ts
.kind
!= f
->ts
.kind
)
1660 gfc_convert_type (a
->expr
, &f
->ts
, 2);
1663 f
->value
.function
.name
1664 = gfc_get_string (name
, gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
1669 gfc_resolve_max (gfc_expr
*f
, gfc_actual_arglist
*args
)
1671 gfc_resolve_minmax ("__max_%c%d", f
, args
);
1676 gfc_resolve_maxloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1682 f
->ts
.type
= BT_INTEGER
;
1683 f
->ts
.kind
= gfc_default_integer_kind
;
1688 f
->shape
= gfc_get_shape (1);
1689 mpz_init_set_si (f
->shape
[0], array
->rank
);
1693 f
->rank
= array
->rank
- 1;
1694 gfc_resolve_dim_arg (dim
);
1695 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1697 idim
= (int) mpz_get_si (dim
->value
.integer
);
1698 f
->shape
= gfc_get_shape (f
->rank
);
1699 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1701 if (i
== (idim
- 1))
1703 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1710 if (mask
->rank
== 0)
1715 resolve_mask_arg (mask
);
1720 f
->value
.function
.name
1721 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name
, dim
!= NULL
, f
->ts
.kind
,
1722 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1727 gfc_resolve_maxval (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1737 f
->rank
= array
->rank
- 1;
1738 gfc_resolve_dim_arg (dim
);
1740 if (f
->rank
&& array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1742 idim
= (int) mpz_get_si (dim
->value
.integer
);
1743 f
->shape
= gfc_get_shape (f
->rank
);
1744 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1746 if (i
== (idim
- 1))
1748 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1755 if (mask
->rank
== 0)
1760 resolve_mask_arg (mask
);
1765 f
->value
.function
.name
1766 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
1767 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1772 gfc_resolve_mclock (gfc_expr
*f
)
1774 f
->ts
.type
= BT_INTEGER
;
1776 f
->value
.function
.name
= PREFIX ("mclock");
1781 gfc_resolve_mclock8 (gfc_expr
*f
)
1783 f
->ts
.type
= BT_INTEGER
;
1785 f
->value
.function
.name
= PREFIX ("mclock8");
1790 gfc_resolve_mask (gfc_expr
*f
, gfc_expr
*i ATTRIBUTE_UNUSED
,
1793 f
->ts
.type
= BT_INTEGER
;
1794 f
->ts
.kind
= kind
? mpz_get_si (kind
->value
.integer
)
1795 : gfc_default_integer_kind
;
1797 if (f
->value
.function
.isym
->id
== GFC_ISYM_MASKL
)
1798 f
->value
.function
.name
= gfc_get_string ("__maskl_i%d", f
->ts
.kind
);
1800 f
->value
.function
.name
= gfc_get_string ("__maskr_i%d", f
->ts
.kind
);
1805 gfc_resolve_merge (gfc_expr
*f
, gfc_expr
*tsource
,
1806 gfc_expr
*fsource ATTRIBUTE_UNUSED
,
1807 gfc_expr
*mask ATTRIBUTE_UNUSED
)
1809 if (tsource
->ts
.type
== BT_CHARACTER
&& tsource
->ref
)
1810 gfc_resolve_substring_charlen (tsource
);
1812 if (fsource
->ts
.type
== BT_CHARACTER
&& fsource
->ref
)
1813 gfc_resolve_substring_charlen (fsource
);
1815 if (tsource
->ts
.type
== BT_CHARACTER
)
1816 check_charlen_present (tsource
);
1818 f
->ts
= tsource
->ts
;
1819 f
->value
.function
.name
1820 = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource
->ts
.type
),
1826 gfc_resolve_merge_bits (gfc_expr
*f
, gfc_expr
*i
,
1827 gfc_expr
*j ATTRIBUTE_UNUSED
,
1828 gfc_expr
*mask ATTRIBUTE_UNUSED
)
1831 f
->value
.function
.name
= gfc_get_string ("__merge_bits_i%d", i
->ts
.kind
);
1836 gfc_resolve_min (gfc_expr
*f
, gfc_actual_arglist
*args
)
1838 gfc_resolve_minmax ("__min_%c%d", f
, args
);
1843 gfc_resolve_minloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1849 f
->ts
.type
= BT_INTEGER
;
1850 f
->ts
.kind
= gfc_default_integer_kind
;
1855 f
->shape
= gfc_get_shape (1);
1856 mpz_init_set_si (f
->shape
[0], array
->rank
);
1860 f
->rank
= array
->rank
- 1;
1861 gfc_resolve_dim_arg (dim
);
1862 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1864 idim
= (int) mpz_get_si (dim
->value
.integer
);
1865 f
->shape
= gfc_get_shape (f
->rank
);
1866 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1868 if (i
== (idim
- 1))
1870 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1877 if (mask
->rank
== 0)
1882 resolve_mask_arg (mask
);
1887 f
->value
.function
.name
1888 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name
, dim
!= NULL
, f
->ts
.kind
,
1889 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1894 gfc_resolve_minval (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1904 f
->rank
= array
->rank
- 1;
1905 gfc_resolve_dim_arg (dim
);
1907 if (f
->rank
&& array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1909 idim
= (int) mpz_get_si (dim
->value
.integer
);
1910 f
->shape
= gfc_get_shape (f
->rank
);
1911 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1913 if (i
== (idim
- 1))
1915 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1922 if (mask
->rank
== 0)
1927 resolve_mask_arg (mask
);
1932 f
->value
.function
.name
1933 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
1934 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1939 gfc_resolve_mod (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
1941 f
->ts
.type
= a
->ts
.type
;
1943 f
->ts
.kind
= gfc_kind_max (a
,p
);
1945 f
->ts
.kind
= a
->ts
.kind
;
1947 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
1949 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
1950 gfc_convert_type (p
, &a
->ts
, 2);
1952 gfc_convert_type (a
, &p
->ts
, 2);
1955 f
->value
.function
.name
1956 = gfc_get_string ("__mod_%c%d", gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
1961 gfc_resolve_modulo (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
1963 f
->ts
.type
= a
->ts
.type
;
1965 f
->ts
.kind
= gfc_kind_max (a
,p
);
1967 f
->ts
.kind
= a
->ts
.kind
;
1969 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
1971 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
1972 gfc_convert_type (p
, &a
->ts
, 2);
1974 gfc_convert_type (a
, &p
->ts
, 2);
1977 f
->value
.function
.name
1978 = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f
->ts
.type
),
1983 gfc_resolve_nearest (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
1985 if (p
->ts
.kind
!= a
->ts
.kind
)
1986 gfc_convert_type (p
, &a
->ts
, 2);
1989 f
->value
.function
.name
1990 = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a
->ts
.type
),
1995 gfc_resolve_nint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1997 f
->ts
.type
= BT_INTEGER
;
1998 f
->ts
.kind
= (kind
== NULL
)
1999 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
2000 f
->value
.function
.name
2001 = gfc_get_string ("__nint_%d_%d", f
->ts
.kind
, a
->ts
.kind
);
2006 gfc_resolve_norm2 (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
)
2008 resolve_transformational ("norm2", f
, array
, dim
, NULL
);
2013 gfc_resolve_not (gfc_expr
*f
, gfc_expr
*i
)
2016 f
->value
.function
.name
= gfc_get_string ("__not_%d", i
->ts
.kind
);
2021 gfc_resolve_or (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
2023 f
->ts
.type
= i
->ts
.type
;
2024 f
->ts
.kind
= gfc_kind_max (i
, j
);
2026 if (i
->ts
.kind
!= j
->ts
.kind
)
2028 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
2029 gfc_convert_type (j
, &i
->ts
, 2);
2031 gfc_convert_type (i
, &j
->ts
, 2);
2034 f
->value
.function
.name
2035 = gfc_get_string ("__or_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
2040 gfc_resolve_pack (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*mask
,
2041 gfc_expr
*vector ATTRIBUTE_UNUSED
)
2043 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
2044 gfc_resolve_substring_charlen (array
);
2049 resolve_mask_arg (mask
);
2051 if (mask
->rank
!= 0)
2053 if (array
->ts
.type
== BT_CHARACTER
)
2054 f
->value
.function
.name
2055 = array
->ts
.kind
== 1 ? PREFIX ("pack_char")
2057 (PREFIX ("pack_char%d"),
2060 f
->value
.function
.name
= PREFIX ("pack");
2064 if (array
->ts
.type
== BT_CHARACTER
)
2065 f
->value
.function
.name
2066 = array
->ts
.kind
== 1 ? PREFIX ("pack_s_char")
2068 (PREFIX ("pack_s_char%d"),
2071 f
->value
.function
.name
= PREFIX ("pack_s");
2077 gfc_resolve_parity (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
)
2079 resolve_transformational ("parity", f
, array
, dim
, NULL
);
2084 gfc_resolve_product (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
2087 resolve_transformational ("product", f
, array
, dim
, mask
);
2092 gfc_resolve_rank (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
)
2094 f
->ts
.type
= BT_INTEGER
;
2095 f
->ts
.kind
= gfc_default_integer_kind
;
2096 f
->value
.function
.name
= gfc_get_string ("__rank");
2101 gfc_resolve_real (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
2103 f
->ts
.type
= BT_REAL
;
2106 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2108 f
->ts
.kind
= (a
->ts
.type
== BT_COMPLEX
)
2109 ? a
->ts
.kind
: gfc_default_real_kind
;
2111 f
->value
.function
.name
2112 = gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
2113 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2118 gfc_resolve_realpart (gfc_expr
*f
, gfc_expr
*a
)
2120 f
->ts
.type
= BT_REAL
;
2121 f
->ts
.kind
= a
->ts
.kind
;
2122 f
->value
.function
.name
2123 = gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
2124 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2129 gfc_resolve_rename (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
2130 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
2132 f
->ts
.type
= BT_INTEGER
;
2133 f
->ts
.kind
= gfc_default_integer_kind
;
2134 f
->value
.function
.name
= gfc_get_string (PREFIX ("rename_i%d"), f
->ts
.kind
);
2139 gfc_resolve_repeat (gfc_expr
*f
, gfc_expr
*string
,
2144 f
->ts
.type
= BT_CHARACTER
;
2145 f
->ts
.kind
= string
->ts
.kind
;
2146 f
->value
.function
.name
= gfc_get_string ("__repeat_%d", string
->ts
.kind
);
2148 /* If possible, generate a character length. */
2149 if (f
->ts
.u
.cl
== NULL
)
2150 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2153 if (string
->expr_type
== EXPR_CONSTANT
)
2155 len
= string
->value
.character
.length
;
2156 tmp
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, len
);
2158 else if (string
->ts
.u
.cl
&& string
->ts
.u
.cl
->length
)
2160 tmp
= gfc_copy_expr (string
->ts
.u
.cl
->length
);
2164 f
->ts
.u
.cl
->length
= gfc_multiply (tmp
, gfc_copy_expr (ncopies
));
2169 gfc_resolve_reshape (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*shape
,
2170 gfc_expr
*pad ATTRIBUTE_UNUSED
,
2171 gfc_expr
*order ATTRIBUTE_UNUSED
)
2177 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
2178 gfc_resolve_substring_charlen (source
);
2182 gfc_array_size (shape
, &rank
);
2183 f
->rank
= mpz_get_si (rank
);
2185 switch (source
->ts
.type
)
2192 kind
= source
->ts
.kind
;
2206 if (source
->ts
.type
== BT_COMPLEX
|| source
->ts
.type
== BT_REAL
)
2207 f
->value
.function
.name
2208 = gfc_get_string (PREFIX ("reshape_%c%d"),
2209 gfc_type_letter (source
->ts
.type
),
2211 else if (source
->ts
.type
== BT_CHARACTER
)
2212 f
->value
.function
.name
= gfc_get_string (PREFIX ("reshape_char%d"),
2215 f
->value
.function
.name
2216 = gfc_get_string (PREFIX ("reshape_%d"), source
->ts
.kind
);
2220 f
->value
.function
.name
= (source
->ts
.type
== BT_CHARACTER
2221 ? PREFIX ("reshape_char") : PREFIX ("reshape"));
2225 if (shape
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (shape
))
2228 f
->shape
= gfc_get_shape (f
->rank
);
2229 c
= gfc_constructor_first (shape
->value
.constructor
);
2230 for (i
= 0; i
< f
->rank
; i
++)
2232 mpz_init_set (f
->shape
[i
], c
->expr
->value
.integer
);
2233 c
= gfc_constructor_next (c
);
2237 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
2238 so many runtime variations. */
2239 if (shape
->ts
.kind
!= gfc_index_integer_kind
)
2241 gfc_typespec ts
= shape
->ts
;
2242 ts
.kind
= gfc_index_integer_kind
;
2243 gfc_convert_type_warn (shape
, &ts
, 2, 0);
2245 if (order
&& order
->ts
.kind
!= gfc_index_integer_kind
)
2246 gfc_convert_type_warn (order
, &shape
->ts
, 2, 0);
2251 gfc_resolve_rrspacing (gfc_expr
*f
, gfc_expr
*x
)
2254 f
->value
.function
.name
= gfc_get_string ("__rrspacing_%d", x
->ts
.kind
);
2258 gfc_resolve_fe_runtime_error (gfc_code
*c
)
2261 gfc_actual_arglist
*a
;
2263 name
= gfc_get_string (PREFIX ("runtime_error"));
2265 for (a
= c
->ext
.actual
->next
; a
; a
= a
->next
)
2268 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2272 gfc_resolve_scale (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*i ATTRIBUTE_UNUSED
)
2275 f
->value
.function
.name
= gfc_get_string ("__scale_%d", x
->ts
.kind
);
2280 gfc_resolve_scan (gfc_expr
*f
, gfc_expr
*string
,
2281 gfc_expr
*set ATTRIBUTE_UNUSED
,
2282 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2284 f
->ts
.type
= BT_INTEGER
;
2286 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2288 f
->ts
.kind
= gfc_default_integer_kind
;
2289 f
->value
.function
.name
= gfc_get_string ("__scan_%d", string
->ts
.kind
);
2294 gfc_resolve_secnds (gfc_expr
*t1
, gfc_expr
*t0
)
2297 t1
->value
.function
.name
= gfc_get_string (PREFIX ("secnds"));
2302 gfc_resolve_set_exponent (gfc_expr
*f
, gfc_expr
*x
,
2303 gfc_expr
*i ATTRIBUTE_UNUSED
)
2306 f
->value
.function
.name
= gfc_get_string ("__set_exponent_%d", x
->ts
.kind
);
2311 gfc_resolve_shape (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*kind
)
2313 f
->ts
.type
= BT_INTEGER
;
2316 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2318 f
->ts
.kind
= gfc_default_integer_kind
;
2321 if (array
->rank
!= -1)
2323 f
->shape
= gfc_get_shape (1);
2324 mpz_init_set_ui (f
->shape
[0], array
->rank
);
2327 f
->value
.function
.name
= gfc_get_string (PREFIX ("shape_%d"), f
->ts
.kind
);
2332 gfc_resolve_shift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift ATTRIBUTE_UNUSED
)
2335 if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTA
)
2336 f
->value
.function
.name
= gfc_get_string ("shifta_i%d", f
->ts
.kind
);
2337 else if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTL
)
2338 f
->value
.function
.name
= gfc_get_string ("shiftl_i%d", f
->ts
.kind
);
2339 else if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTR
)
2340 f
->value
.function
.name
= gfc_get_string ("shiftr_i%d", f
->ts
.kind
);
2347 gfc_resolve_sign (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b ATTRIBUTE_UNUSED
)
2350 f
->value
.function
.name
2351 = gfc_get_string ("__sign_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2356 gfc_resolve_signal (gfc_expr
*f
, gfc_expr
*number
, gfc_expr
*handler
)
2358 f
->ts
.type
= BT_INTEGER
;
2359 f
->ts
.kind
= gfc_c_int_kind
;
2361 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2362 if (handler
->ts
.type
== BT_INTEGER
)
2364 if (handler
->ts
.kind
!= gfc_c_int_kind
)
2365 gfc_convert_type (handler
, &f
->ts
, 2);
2366 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func_int"));
2369 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func"));
2371 if (number
->ts
.kind
!= gfc_c_int_kind
)
2372 gfc_convert_type (number
, &f
->ts
, 2);
2377 gfc_resolve_sin (gfc_expr
*f
, gfc_expr
*x
)
2380 f
->value
.function
.name
2381 = gfc_get_string ("__sin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2386 gfc_resolve_sinh (gfc_expr
*f
, gfc_expr
*x
)
2389 f
->value
.function
.name
2390 = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2395 gfc_resolve_size (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2396 gfc_expr
*dim ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2398 f
->ts
.type
= BT_INTEGER
;
2400 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2402 f
->ts
.kind
= gfc_default_integer_kind
;
2407 gfc_resolve_stride (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2408 gfc_expr
*dim ATTRIBUTE_UNUSED
)
2410 f
->ts
.type
= BT_INTEGER
;
2411 f
->ts
.kind
= gfc_index_integer_kind
;
2416 gfc_resolve_spacing (gfc_expr
*f
, gfc_expr
*x
)
2419 f
->value
.function
.name
= gfc_get_string ("__spacing_%d", x
->ts
.kind
);
2424 gfc_resolve_spread (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*dim
,
2427 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
2428 gfc_resolve_substring_charlen (source
);
2430 if (source
->ts
.type
== BT_CHARACTER
)
2431 check_charlen_present (source
);
2434 f
->rank
= source
->rank
+ 1;
2435 if (source
->rank
== 0)
2437 if (source
->ts
.type
== BT_CHARACTER
)
2438 f
->value
.function
.name
2439 = source
->ts
.kind
== 1 ? PREFIX ("spread_char_scalar")
2441 (PREFIX ("spread_char%d_scalar"),
2444 f
->value
.function
.name
= PREFIX ("spread_scalar");
2448 if (source
->ts
.type
== BT_CHARACTER
)
2449 f
->value
.function
.name
2450 = source
->ts
.kind
== 1 ? PREFIX ("spread_char")
2452 (PREFIX ("spread_char%d"),
2455 f
->value
.function
.name
= PREFIX ("spread");
2458 if (dim
&& gfc_is_constant_expr (dim
)
2459 && ncopies
&& gfc_is_constant_expr (ncopies
) && source
->shape
[0])
2462 idim
= mpz_get_ui (dim
->value
.integer
);
2463 f
->shape
= gfc_get_shape (f
->rank
);
2464 for (i
= 0; i
< (idim
- 1); i
++)
2465 mpz_init_set (f
->shape
[i
], source
->shape
[i
]);
2467 mpz_init_set (f
->shape
[idim
- 1], ncopies
->value
.integer
);
2469 for (i
= idim
; i
< f
->rank
; i
++)
2470 mpz_init_set (f
->shape
[i
], source
->shape
[i
-1]);
2474 gfc_resolve_dim_arg (dim
);
2475 gfc_resolve_index (ncopies
, 1);
2480 gfc_resolve_sqrt (gfc_expr
*f
, gfc_expr
*x
)
2483 f
->value
.function
.name
2484 = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2488 /* Resolve the g77 compatibility function STAT AND FSTAT. */
2491 gfc_resolve_stat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2492 gfc_expr
*a ATTRIBUTE_UNUSED
)
2494 f
->ts
.type
= BT_INTEGER
;
2495 f
->ts
.kind
= gfc_default_integer_kind
;
2496 f
->value
.function
.name
= gfc_get_string (PREFIX ("stat_i%d"), f
->ts
.kind
);
2501 gfc_resolve_lstat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2502 gfc_expr
*a ATTRIBUTE_UNUSED
)
2504 f
->ts
.type
= BT_INTEGER
;
2505 f
->ts
.kind
= gfc_default_integer_kind
;
2506 f
->value
.function
.name
= gfc_get_string (PREFIX ("lstat_i%d"), f
->ts
.kind
);
2511 gfc_resolve_fstat (gfc_expr
*f
, gfc_expr
*n
, gfc_expr
*a ATTRIBUTE_UNUSED
)
2513 f
->ts
.type
= BT_INTEGER
;
2514 f
->ts
.kind
= gfc_default_integer_kind
;
2515 if (n
->ts
.kind
!= f
->ts
.kind
)
2516 gfc_convert_type (n
, &f
->ts
, 2);
2518 f
->value
.function
.name
= gfc_get_string (PREFIX ("fstat_i%d"), f
->ts
.kind
);
2523 gfc_resolve_fgetc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2528 f
->ts
.type
= BT_INTEGER
;
2529 f
->ts
.kind
= gfc_c_int_kind
;
2530 if (u
->ts
.kind
!= gfc_c_int_kind
)
2532 ts
.type
= BT_INTEGER
;
2533 ts
.kind
= gfc_c_int_kind
;
2534 ts
.u
.derived
= NULL
;
2536 gfc_convert_type (u
, &ts
, 2);
2539 f
->value
.function
.name
= gfc_get_string (PREFIX ("fgetc"));
2544 gfc_resolve_fget (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2546 f
->ts
.type
= BT_INTEGER
;
2547 f
->ts
.kind
= gfc_c_int_kind
;
2548 f
->value
.function
.name
= gfc_get_string (PREFIX ("fget"));
2553 gfc_resolve_fputc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2558 f
->ts
.type
= BT_INTEGER
;
2559 f
->ts
.kind
= gfc_c_int_kind
;
2560 if (u
->ts
.kind
!= gfc_c_int_kind
)
2562 ts
.type
= BT_INTEGER
;
2563 ts
.kind
= gfc_c_int_kind
;
2564 ts
.u
.derived
= NULL
;
2566 gfc_convert_type (u
, &ts
, 2);
2569 f
->value
.function
.name
= gfc_get_string (PREFIX ("fputc"));
2574 gfc_resolve_fput (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2576 f
->ts
.type
= BT_INTEGER
;
2577 f
->ts
.kind
= gfc_c_int_kind
;
2578 f
->value
.function
.name
= gfc_get_string (PREFIX ("fput"));
2583 gfc_resolve_ftell (gfc_expr
*f
, gfc_expr
*u
)
2588 f
->ts
.type
= BT_INTEGER
;
2589 f
->ts
.kind
= gfc_intio_kind
;
2590 if (u
->ts
.kind
!= gfc_c_int_kind
)
2592 ts
.type
= BT_INTEGER
;
2593 ts
.kind
= gfc_c_int_kind
;
2594 ts
.u
.derived
= NULL
;
2596 gfc_convert_type (u
, &ts
, 2);
2599 f
->value
.function
.name
= gfc_get_string (PREFIX ("ftell2"));
2604 gfc_resolve_storage_size (gfc_expr
*f
, gfc_expr
*a ATTRIBUTE_UNUSED
,
2607 f
->ts
.type
= BT_INTEGER
;
2609 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2611 f
->ts
.kind
= gfc_default_integer_kind
;
2616 gfc_resolve_sum (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2618 resolve_transformational ("sum", f
, array
, dim
, mask
);
2623 gfc_resolve_symlnk (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
2624 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
2626 f
->ts
.type
= BT_INTEGER
;
2627 f
->ts
.kind
= gfc_default_integer_kind
;
2628 f
->value
.function
.name
= gfc_get_string (PREFIX ("symlnk_i%d"), f
->ts
.kind
);
2632 /* Resolve the g77 compatibility function SYSTEM. */
2635 gfc_resolve_system (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
2637 f
->ts
.type
= BT_INTEGER
;
2639 f
->value
.function
.name
= gfc_get_string (PREFIX ("system"));
2644 gfc_resolve_tan (gfc_expr
*f
, gfc_expr
*x
)
2647 f
->value
.function
.name
2648 = gfc_get_string ("__tan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2653 gfc_resolve_tanh (gfc_expr
*f
, gfc_expr
*x
)
2656 f
->value
.function
.name
2657 = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2661 /* Build an expression for converting degrees to radians. */
2664 get_radians (gfc_expr
*deg
)
2666 gfc_expr
*result
, *factor
;
2667 gfc_actual_arglist
*mod_args
;
2669 gcc_assert (deg
->ts
.type
== BT_REAL
);
2671 /* Set deg = deg % 360 to avoid offsets from large angles. */
2672 factor
= gfc_get_constant_expr (deg
->ts
.type
, deg
->ts
.kind
, °
->where
);
2673 mpfr_set_d (factor
->value
.real
, 360.0, GFC_RND_MODE
);
2675 mod_args
= gfc_get_actual_arglist ();
2676 mod_args
->expr
= deg
;
2677 mod_args
->next
= gfc_get_actual_arglist ();
2678 mod_args
->next
->expr
= factor
;
2680 result
= gfc_get_expr ();
2681 result
->ts
= deg
->ts
;
2682 result
->where
= deg
->where
;
2683 result
->expr_type
= EXPR_FUNCTION
;
2684 result
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_MOD
);
2685 result
->value
.function
.actual
= mod_args
;
2687 /* Set factor = pi / 180. */
2688 factor
= gfc_get_constant_expr (deg
->ts
.type
, deg
->ts
.kind
, °
->where
);
2689 mpfr_const_pi (factor
->value
.real
, GFC_RND_MODE
);
2690 mpfr_div_d (factor
->value
.real
, factor
->value
.real
, 180.0, GFC_RND_MODE
);
2692 /* Result is rad = (deg % 360) * (pi / 180). */
2693 result
= gfc_multiply (result
, factor
);
2698 /* Build an expression for converting radians to degrees. */
2701 get_degrees (gfc_expr
*rad
)
2703 gfc_expr
*result
, *factor
;
2704 gfc_actual_arglist
*mod_args
;
2706 gcc_assert (rad
->ts
.type
== BT_REAL
);
2708 /* Set rad = rad % 2pi to avoid offsets from large angles. */
2709 factor
= gfc_get_constant_expr (rad
->ts
.type
, rad
->ts
.kind
, &rad
->where
);
2710 mpfr_const_pi (factor
->value
.real
, GFC_RND_MODE
);
2711 mpfr_mul_ui (factor
->value
.real
, factor
->value
.real
, 2, GFC_RND_MODE
);
2713 mod_args
= gfc_get_actual_arglist ();
2714 mod_args
->expr
= rad
;
2715 mod_args
->next
= gfc_get_actual_arglist ();
2716 mod_args
->next
->expr
= factor
;
2718 result
= gfc_get_expr ();
2719 result
->ts
= rad
->ts
;
2720 result
->where
= rad
->where
;
2721 result
->expr_type
= EXPR_FUNCTION
;
2722 result
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_MOD
);
2723 result
->value
.function
.actual
= mod_args
;
2725 /* Set factor = 180 / pi. */
2726 factor
= gfc_get_constant_expr (rad
->ts
.type
, rad
->ts
.kind
, &rad
->where
);
2727 mpfr_set_d (factor
->value
.real
, 180.0, GFC_RND_MODE
);
2729 mpfr_const_pi (tmp
, GFC_RND_MODE
);
2730 mpfr_div (factor
->value
.real
, factor
->value
.real
, tmp
, GFC_RND_MODE
);
2733 /* Result is deg = (rad % 2pi) * (180 / pi). */
2734 result
= gfc_multiply (result
, factor
);
2739 /* Resolve a call to a trig function. */
2742 resolve_trig_call (gfc_expr
*f
, gfc_expr
*x
)
2744 switch (f
->value
.function
.isym
->id
)
2747 return gfc_resolve_acos (f
, x
);
2749 return gfc_resolve_asin (f
, x
);
2751 return gfc_resolve_atan (f
, x
);
2752 case GFC_ISYM_ATAN2
:
2753 /* NB. arg3 is unused for atan2 */
2754 return gfc_resolve_atan2 (f
, x
, NULL
);
2756 return gfc_resolve_cos (f
, x
);
2757 case GFC_ISYM_COTAN
:
2758 return gfc_resolve_cotan (f
, x
);
2760 return gfc_resolve_sin (f
, x
);
2762 return gfc_resolve_tan (f
, x
);
2770 /* Resolve degree trig function as trigd (x) = trig (radians (x)). */
2773 gfc_resolve_trigd (gfc_expr
*f
, gfc_expr
*x
)
2775 if (is_trig_resolved (f
))
2778 x
= get_radians (x
);
2779 f
->value
.function
.actual
->expr
= x
;
2781 resolve_trig_call (f
, x
);
2785 /* Resolve degree inverse trig function as atrigd (x) = degrees (atrig (x)). */
2788 gfc_resolve_atrigd (gfc_expr
*f
, gfc_expr
*x
)
2790 gfc_expr
*result
, *fcopy
;
2792 if (is_trig_resolved (f
))
2795 resolve_trig_call (f
, x
);
2797 fcopy
= copy_replace_function_shallow (f
);
2798 result
= get_degrees (fcopy
);
2799 gfc_replace_expr (f
, result
);
2803 /* Resolve atan2d(x) = degrees(atan2(x)). */
2806 gfc_resolve_atan2d (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
2808 /* Note that we lose the second arg here - that's okay because it is
2809 unused in gfc_resolve_atan2 anyway. */
2810 gfc_resolve_atrigd (f
, x
);
2815 gfc_resolve_image_index (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2816 gfc_expr
*sub ATTRIBUTE_UNUSED
)
2818 static char image_index
[] = "__image_index";
2819 f
->ts
.type
= BT_INTEGER
;
2820 f
->ts
.kind
= gfc_default_integer_kind
;
2821 f
->value
.function
.name
= image_index
;
2826 gfc_resolve_this_image (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
2827 gfc_expr
*distance ATTRIBUTE_UNUSED
)
2829 static char this_image
[] = "__this_image";
2830 if (array
&& gfc_is_coarray (array
))
2831 resolve_bound (f
, array
, dim
, NULL
, "__this_image", true);
2834 f
->ts
.type
= BT_INTEGER
;
2835 f
->ts
.kind
= gfc_default_integer_kind
;
2836 f
->value
.function
.name
= this_image
;
2842 gfc_resolve_time (gfc_expr
*f
)
2844 f
->ts
.type
= BT_INTEGER
;
2846 f
->value
.function
.name
= gfc_get_string (PREFIX ("time_func"));
2851 gfc_resolve_time8 (gfc_expr
*f
)
2853 f
->ts
.type
= BT_INTEGER
;
2855 f
->value
.function
.name
= gfc_get_string (PREFIX ("time8_func"));
2860 gfc_resolve_transfer (gfc_expr
*f
, gfc_expr
*source ATTRIBUTE_UNUSED
,
2861 gfc_expr
*mold
, gfc_expr
*size
)
2863 /* TODO: Make this do something meaningful. */
2864 static char transfer0
[] = "__transfer0", transfer1
[] = "__transfer1";
2866 if (mold
->ts
.type
== BT_CHARACTER
2867 && !mold
->ts
.u
.cl
->length
2868 && gfc_is_constant_expr (mold
))
2871 if (mold
->expr_type
== EXPR_CONSTANT
)
2873 len
= mold
->value
.character
.length
;
2874 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
2879 gfc_constructor
*c
= gfc_constructor_first (mold
->value
.constructor
);
2880 len
= c
->expr
->value
.character
.length
;
2881 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
2888 if (size
== NULL
&& mold
->rank
== 0)
2891 f
->value
.function
.name
= transfer0
;
2896 f
->value
.function
.name
= transfer1
;
2897 if (size
&& gfc_is_constant_expr (size
))
2899 f
->shape
= gfc_get_shape (1);
2900 mpz_init_set (f
->shape
[0], size
->value
.integer
);
2907 gfc_resolve_transpose (gfc_expr
*f
, gfc_expr
*matrix
)
2910 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ref
)
2911 gfc_resolve_substring_charlen (matrix
);
2917 f
->shape
= gfc_get_shape (2);
2918 mpz_init_set (f
->shape
[0], matrix
->shape
[1]);
2919 mpz_init_set (f
->shape
[1], matrix
->shape
[0]);
2922 switch (matrix
->ts
.kind
)
2928 switch (matrix
->ts
.type
)
2932 f
->value
.function
.name
2933 = gfc_get_string (PREFIX ("transpose_%c%d"),
2934 gfc_type_letter (matrix
->ts
.type
),
2940 /* Use the integer routines for real and logical cases. This
2941 assumes they all have the same alignment requirements. */
2942 f
->value
.function
.name
2943 = gfc_get_string (PREFIX ("transpose_i%d"), matrix
->ts
.kind
);
2947 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ts
.kind
== 4)
2948 f
->value
.function
.name
= PREFIX ("transpose_char4");
2950 f
->value
.function
.name
= PREFIX ("transpose");
2956 f
->value
.function
.name
= (matrix
->ts
.type
== BT_CHARACTER
2957 ? PREFIX ("transpose_char")
2958 : PREFIX ("transpose"));
2965 gfc_resolve_trim (gfc_expr
*f
, gfc_expr
*string
)
2967 f
->ts
.type
= BT_CHARACTER
;
2968 f
->ts
.kind
= string
->ts
.kind
;
2969 f
->value
.function
.name
= gfc_get_string ("__trim_%d", string
->ts
.kind
);
2974 gfc_resolve_ubound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2976 resolve_bound (f
, array
, dim
, kind
, "__ubound", false);
2981 gfc_resolve_ucobound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2983 resolve_bound (f
, array
, dim
, kind
, "__ucobound", true);
2987 /* Resolve the g77 compatibility function UMASK. */
2990 gfc_resolve_umask (gfc_expr
*f
, gfc_expr
*n
)
2992 f
->ts
.type
= BT_INTEGER
;
2993 f
->ts
.kind
= n
->ts
.kind
;
2994 f
->value
.function
.name
= gfc_get_string (PREFIX ("umask_i%d"), n
->ts
.kind
);
2998 /* Resolve the g77 compatibility function UNLINK. */
3001 gfc_resolve_unlink (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
3003 f
->ts
.type
= BT_INTEGER
;
3005 f
->value
.function
.name
= gfc_get_string (PREFIX ("unlink"));
3010 gfc_resolve_ttynam (gfc_expr
*f
, gfc_expr
*unit
)
3015 f
->ts
.type
= BT_CHARACTER
;
3016 f
->ts
.kind
= gfc_default_character_kind
;
3018 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3020 ts
.type
= BT_INTEGER
;
3021 ts
.kind
= gfc_c_int_kind
;
3022 ts
.u
.derived
= NULL
;
3024 gfc_convert_type (unit
, &ts
, 2);
3027 f
->value
.function
.name
= gfc_get_string (PREFIX ("ttynam"));
3032 gfc_resolve_unpack (gfc_expr
*f
, gfc_expr
*vector
, gfc_expr
*mask
,
3033 gfc_expr
*field ATTRIBUTE_UNUSED
)
3035 if (vector
->ts
.type
== BT_CHARACTER
&& vector
->ref
)
3036 gfc_resolve_substring_charlen (vector
);
3039 f
->rank
= mask
->rank
;
3040 resolve_mask_arg (mask
);
3042 if (vector
->ts
.type
== BT_CHARACTER
)
3044 if (vector
->ts
.kind
== 1)
3045 f
->value
.function
.name
3046 = gfc_get_string (PREFIX ("unpack%d_char"), field
->rank
> 0 ? 1 : 0);
3048 f
->value
.function
.name
3049 = gfc_get_string (PREFIX ("unpack%d_char%d"),
3050 field
->rank
> 0 ? 1 : 0, vector
->ts
.kind
);
3053 f
->value
.function
.name
3054 = gfc_get_string (PREFIX ("unpack%d"), field
->rank
> 0 ? 1 : 0);
3059 gfc_resolve_verify (gfc_expr
*f
, gfc_expr
*string
,
3060 gfc_expr
*set ATTRIBUTE_UNUSED
,
3061 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
3063 f
->ts
.type
= BT_INTEGER
;
3065 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
3067 f
->ts
.kind
= gfc_default_integer_kind
;
3068 f
->value
.function
.name
= gfc_get_string ("__verify_%d", string
->ts
.kind
);
3073 gfc_resolve_xor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
3075 f
->ts
.type
= i
->ts
.type
;
3076 f
->ts
.kind
= gfc_kind_max (i
, j
);
3078 if (i
->ts
.kind
!= j
->ts
.kind
)
3080 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
3081 gfc_convert_type (j
, &i
->ts
, 2);
3083 gfc_convert_type (i
, &j
->ts
, 2);
3086 f
->value
.function
.name
3087 = gfc_get_string ("__xor_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
3091 /* Intrinsic subroutine resolution. */
3094 gfc_resolve_alarm_sub (gfc_code
*c
)
3097 gfc_expr
*seconds
, *handler
;
3101 seconds
= c
->ext
.actual
->expr
;
3102 handler
= c
->ext
.actual
->next
->expr
;
3103 ts
.type
= BT_INTEGER
;
3104 ts
.kind
= gfc_c_int_kind
;
3106 /* handler can be either BT_INTEGER or BT_PROCEDURE.
3107 In all cases, the status argument is of default integer kind
3108 (enforced in check.c) so that the function suffix is fixed. */
3109 if (handler
->ts
.type
== BT_INTEGER
)
3111 if (handler
->ts
.kind
!= gfc_c_int_kind
)
3112 gfc_convert_type (handler
, &ts
, 2);
3113 name
= gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
3114 gfc_default_integer_kind
);
3117 name
= gfc_get_string (PREFIX ("alarm_sub_i%d"),
3118 gfc_default_integer_kind
);
3120 if (seconds
->ts
.kind
!= gfc_c_int_kind
)
3121 gfc_convert_type (seconds
, &ts
, 2);
3123 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3127 gfc_resolve_cpu_time (gfc_code
*c
)
3130 name
= gfc_get_string (PREFIX ("cpu_time_%d"), c
->ext
.actual
->expr
->ts
.kind
);
3131 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3135 /* Create a formal arglist based on an actual one and set the INTENTs given. */
3137 static gfc_formal_arglist
*
3138 create_formal_for_intents (gfc_actual_arglist
* actual
, const sym_intent
* ints
)
3140 gfc_formal_arglist
* head
;
3141 gfc_formal_arglist
* tail
;
3147 head
= tail
= gfc_get_formal_arglist ();
3148 for (i
= 0; actual
; actual
= actual
->next
, tail
= tail
->next
, ++i
)
3152 sym
= gfc_new_symbol ("dummyarg", NULL
);
3153 sym
->ts
= actual
->expr
->ts
;
3155 sym
->attr
.intent
= ints
[i
];
3159 tail
->next
= gfc_get_formal_arglist ();
3167 gfc_resolve_atomic_def (gfc_code
*c
)
3169 const char *name
= "atomic_define";
3170 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3175 gfc_resolve_atomic_ref (gfc_code
*c
)
3177 const char *name
= "atomic_ref";
3178 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3182 gfc_resolve_event_query (gfc_code
*c
)
3184 const char *name
= "event_query";
3185 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3189 gfc_resolve_mvbits (gfc_code
*c
)
3191 static const sym_intent INTENTS
[] = {INTENT_IN
, INTENT_IN
, INTENT_IN
,
3192 INTENT_INOUT
, INTENT_IN
};
3198 /* FROMPOS, LEN and TOPOS are restricted to small values. As such,
3199 they will be converted so that they fit into a C int. */
3200 ts
.type
= BT_INTEGER
;
3201 ts
.kind
= gfc_c_int_kind
;
3202 if (c
->ext
.actual
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
3203 gfc_convert_type (c
->ext
.actual
->next
->expr
, &ts
, 2);
3204 if (c
->ext
.actual
->next
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
3205 gfc_convert_type (c
->ext
.actual
->next
->next
->expr
, &ts
, 2);
3206 if (c
->ext
.actual
->next
->next
->next
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
3207 gfc_convert_type (c
->ext
.actual
->next
->next
->next
->next
->expr
, &ts
, 2);
3209 /* TO and FROM are guaranteed to have the same kind parameter. */
3210 name
= gfc_get_string (PREFIX ("mvbits_i%d"),
3211 c
->ext
.actual
->expr
->ts
.kind
);
3212 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3213 /* Mark as elemental subroutine as this does not happen automatically. */
3214 c
->resolved_sym
->attr
.elemental
= 1;
3216 /* Create a dummy formal arglist so the INTENTs are known later for purpose
3217 of creating temporaries. */
3218 c
->resolved_sym
->formal
= create_formal_for_intents (c
->ext
.actual
, INTENTS
);
3223 gfc_resolve_random_number (gfc_code
*c
)
3228 kind
= c
->ext
.actual
->expr
->ts
.kind
;
3229 if (c
->ext
.actual
->expr
->rank
== 0)
3230 name
= gfc_get_string (PREFIX ("random_r%d"), kind
);
3232 name
= gfc_get_string (PREFIX ("arandom_r%d"), kind
);
3234 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3239 gfc_resolve_random_seed (gfc_code
*c
)
3243 name
= gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind
);
3244 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3249 gfc_resolve_rename_sub (gfc_code
*c
)
3254 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3255 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3257 kind
= gfc_default_integer_kind
;
3259 name
= gfc_get_string (PREFIX ("rename_i%d_sub"), kind
);
3260 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3265 gfc_resolve_kill_sub (gfc_code
*c
)
3270 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3271 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3273 kind
= gfc_default_integer_kind
;
3275 name
= gfc_get_string (PREFIX ("kill_i%d_sub"), kind
);
3276 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3281 gfc_resolve_link_sub (gfc_code
*c
)
3286 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3287 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3289 kind
= gfc_default_integer_kind
;
3291 name
= gfc_get_string (PREFIX ("link_i%d_sub"), kind
);
3292 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3297 gfc_resolve_symlnk_sub (gfc_code
*c
)
3302 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3303 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3305 kind
= gfc_default_integer_kind
;
3307 name
= gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind
);
3308 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3312 /* G77 compatibility subroutines dtime() and etime(). */
3315 gfc_resolve_dtime_sub (gfc_code
*c
)
3318 name
= gfc_get_string (PREFIX ("dtime_sub"));
3319 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3323 gfc_resolve_etime_sub (gfc_code
*c
)
3326 name
= gfc_get_string (PREFIX ("etime_sub"));
3327 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3331 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
3334 gfc_resolve_itime (gfc_code
*c
)
3337 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
3338 gfc_default_integer_kind
));
3342 gfc_resolve_idate (gfc_code
*c
)
3345 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
3346 gfc_default_integer_kind
));
3350 gfc_resolve_ltime (gfc_code
*c
)
3353 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
3354 gfc_default_integer_kind
));
3358 gfc_resolve_gmtime (gfc_code
*c
)
3361 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
3362 gfc_default_integer_kind
));
3366 /* G77 compatibility subroutine second(). */
3369 gfc_resolve_second_sub (gfc_code
*c
)
3372 name
= gfc_get_string (PREFIX ("second_sub"));
3373 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3378 gfc_resolve_sleep_sub (gfc_code
*c
)
3383 if (c
->ext
.actual
->expr
!= NULL
)
3384 kind
= c
->ext
.actual
->expr
->ts
.kind
;
3386 kind
= gfc_default_integer_kind
;
3388 name
= gfc_get_string (PREFIX ("sleep_i%d_sub"), kind
);
3389 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3393 /* G77 compatibility function srand(). */
3396 gfc_resolve_srand (gfc_code
*c
)
3399 name
= gfc_get_string (PREFIX ("srand"));
3400 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3404 /* Resolve the getarg intrinsic subroutine. */
3407 gfc_resolve_getarg (gfc_code
*c
)
3411 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_default_integer_kind
)
3416 ts
.type
= BT_INTEGER
;
3417 ts
.kind
= gfc_default_integer_kind
;
3419 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3422 name
= gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind
);
3423 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3427 /* Resolve the getcwd intrinsic subroutine. */
3430 gfc_resolve_getcwd_sub (gfc_code
*c
)
3435 if (c
->ext
.actual
->next
->expr
!= NULL
)
3436 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3438 kind
= gfc_default_integer_kind
;
3440 name
= gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind
);
3441 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3445 /* Resolve the get_command intrinsic subroutine. */
3448 gfc_resolve_get_command (gfc_code
*c
)
3452 kind
= gfc_default_integer_kind
;
3453 name
= gfc_get_string (PREFIX ("get_command_i%d"), kind
);
3454 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3458 /* Resolve the get_command_argument intrinsic subroutine. */
3461 gfc_resolve_get_command_argument (gfc_code
*c
)
3465 kind
= gfc_default_integer_kind
;
3466 name
= gfc_get_string (PREFIX ("get_command_argument_i%d"), kind
);
3467 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3471 /* Resolve the get_environment_variable intrinsic subroutine. */
3474 gfc_resolve_get_environment_variable (gfc_code
*code
)
3478 kind
= gfc_default_integer_kind
;
3479 name
= gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind
);
3480 code
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3485 gfc_resolve_signal_sub (gfc_code
*c
)
3488 gfc_expr
*number
, *handler
, *status
;
3492 number
= c
->ext
.actual
->expr
;
3493 handler
= c
->ext
.actual
->next
->expr
;
3494 status
= c
->ext
.actual
->next
->next
->expr
;
3495 ts
.type
= BT_INTEGER
;
3496 ts
.kind
= gfc_c_int_kind
;
3498 /* handler can be either BT_INTEGER or BT_PROCEDURE */
3499 if (handler
->ts
.type
== BT_INTEGER
)
3501 if (handler
->ts
.kind
!= gfc_c_int_kind
)
3502 gfc_convert_type (handler
, &ts
, 2);
3503 name
= gfc_get_string (PREFIX ("signal_sub_int"));
3506 name
= gfc_get_string (PREFIX ("signal_sub"));
3508 if (number
->ts
.kind
!= gfc_c_int_kind
)
3509 gfc_convert_type (number
, &ts
, 2);
3510 if (status
!= NULL
&& status
->ts
.kind
!= gfc_c_int_kind
)
3511 gfc_convert_type (status
, &ts
, 2);
3513 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3517 /* Resolve the SYSTEM intrinsic subroutine. */
3520 gfc_resolve_system_sub (gfc_code
*c
)
3523 name
= gfc_get_string (PREFIX ("system_sub"));
3524 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3528 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
3531 gfc_resolve_system_clock (gfc_code
*c
)
3535 gfc_expr
*count
= c
->ext
.actual
->expr
;
3536 gfc_expr
*count_max
= c
->ext
.actual
->next
->next
->expr
;
3538 /* The INTEGER(8) version has higher precision, it is used if both COUNT
3539 and COUNT_MAX can hold 64-bit values, or are absent. */
3540 if ((!count
|| count
->ts
.kind
>= 8)
3541 && (!count_max
|| count_max
->ts
.kind
>= 8))
3544 kind
= gfc_default_integer_kind
;
3546 name
= gfc_get_string (PREFIX ("system_clock_%d"), kind
);
3547 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3551 /* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine. */
3553 gfc_resolve_execute_command_line (gfc_code
*c
)
3556 name
= gfc_get_string (PREFIX ("execute_command_line_i%d"),
3557 gfc_default_integer_kind
);
3558 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3562 /* Resolve the EXIT intrinsic subroutine. */
3565 gfc_resolve_exit (gfc_code
*c
)
3572 /* The STATUS argument has to be of default kind. If it is not,
3574 ts
.type
= BT_INTEGER
;
3575 ts
.kind
= gfc_default_integer_kind
;
3576 n
= c
->ext
.actual
->expr
;
3577 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3578 gfc_convert_type (n
, &ts
, 2);
3580 name
= gfc_get_string (PREFIX ("exit_i%d"), ts
.kind
);
3581 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3585 /* Resolve the FLUSH intrinsic subroutine. */
3588 gfc_resolve_flush (gfc_code
*c
)
3595 ts
.type
= BT_INTEGER
;
3596 ts
.kind
= gfc_default_integer_kind
;
3597 n
= c
->ext
.actual
->expr
;
3598 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3599 gfc_convert_type (n
, &ts
, 2);
3601 name
= gfc_get_string (PREFIX ("flush_i%d"), ts
.kind
);
3602 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3607 gfc_resolve_ctime_sub (gfc_code
*c
)
3612 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3613 if (c
->ext
.actual
->expr
->ts
.kind
!= 8)
3615 ts
.type
= BT_INTEGER
;
3617 ts
.u
.derived
= NULL
;
3619 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3622 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3627 gfc_resolve_fdate_sub (gfc_code
*c
)
3629 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3634 gfc_resolve_gerror (gfc_code
*c
)
3636 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3641 gfc_resolve_getlog (gfc_code
*c
)
3643 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3648 gfc_resolve_hostnm_sub (gfc_code
*c
)
3653 if (c
->ext
.actual
->next
->expr
!= NULL
)
3654 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3656 kind
= gfc_default_integer_kind
;
3658 name
= gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind
);
3659 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3664 gfc_resolve_perror (gfc_code
*c
)
3666 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3669 /* Resolve the STAT and FSTAT intrinsic subroutines. */
3672 gfc_resolve_stat_sub (gfc_code
*c
)
3675 name
= gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind
);
3676 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3681 gfc_resolve_lstat_sub (gfc_code
*c
)
3684 name
= gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind
);
3685 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3690 gfc_resolve_fstat_sub (gfc_code
*c
)
3696 u
= c
->ext
.actual
->expr
;
3697 ts
= &c
->ext
.actual
->next
->expr
->ts
;
3698 if (u
->ts
.kind
!= ts
->kind
)
3699 gfc_convert_type (u
, ts
, 2);
3700 name
= gfc_get_string (PREFIX ("fstat_i%d_sub"), ts
->kind
);
3701 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3706 gfc_resolve_fgetc_sub (gfc_code
*c
)
3713 u
= c
->ext
.actual
->expr
;
3714 st
= c
->ext
.actual
->next
->next
->expr
;
3716 if (u
->ts
.kind
!= gfc_c_int_kind
)
3718 ts
.type
= BT_INTEGER
;
3719 ts
.kind
= gfc_c_int_kind
;
3720 ts
.u
.derived
= NULL
;
3722 gfc_convert_type (u
, &ts
, 2);
3726 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), st
->ts
.kind
);
3728 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind
);
3730 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3735 gfc_resolve_fget_sub (gfc_code
*c
)
3740 st
= c
->ext
.actual
->next
->expr
;
3742 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), st
->ts
.kind
);
3744 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind
);
3746 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3751 gfc_resolve_fputc_sub (gfc_code
*c
)
3758 u
= c
->ext
.actual
->expr
;
3759 st
= c
->ext
.actual
->next
->next
->expr
;
3761 if (u
->ts
.kind
!= gfc_c_int_kind
)
3763 ts
.type
= BT_INTEGER
;
3764 ts
.kind
= gfc_c_int_kind
;
3765 ts
.u
.derived
= NULL
;
3767 gfc_convert_type (u
, &ts
, 2);
3771 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), st
->ts
.kind
);
3773 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind
);
3775 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3780 gfc_resolve_fput_sub (gfc_code
*c
)
3785 st
= c
->ext
.actual
->next
->expr
;
3787 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), st
->ts
.kind
);
3789 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind
);
3791 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3796 gfc_resolve_fseek_sub (gfc_code
*c
)
3804 unit
= c
->ext
.actual
->expr
;
3805 offset
= c
->ext
.actual
->next
->expr
;
3806 whence
= c
->ext
.actual
->next
->next
->expr
;
3808 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3810 ts
.type
= BT_INTEGER
;
3811 ts
.kind
= gfc_c_int_kind
;
3812 ts
.u
.derived
= NULL
;
3814 gfc_convert_type (unit
, &ts
, 2);
3817 if (offset
->ts
.kind
!= gfc_intio_kind
)
3819 ts
.type
= BT_INTEGER
;
3820 ts
.kind
= gfc_intio_kind
;
3821 ts
.u
.derived
= NULL
;
3823 gfc_convert_type (offset
, &ts
, 2);
3826 if (whence
->ts
.kind
!= gfc_c_int_kind
)
3828 ts
.type
= BT_INTEGER
;
3829 ts
.kind
= gfc_c_int_kind
;
3830 ts
.u
.derived
= NULL
;
3832 gfc_convert_type (whence
, &ts
, 2);
3835 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
3839 gfc_resolve_ftell_sub (gfc_code
*c
)
3847 unit
= c
->ext
.actual
->expr
;
3848 offset
= c
->ext
.actual
->next
->expr
;
3850 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3852 ts
.type
= BT_INTEGER
;
3853 ts
.kind
= gfc_c_int_kind
;
3854 ts
.u
.derived
= NULL
;
3856 gfc_convert_type (unit
, &ts
, 2);
3859 name
= gfc_get_string (PREFIX ("ftell_i%d_sub"), offset
->ts
.kind
);
3860 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3865 gfc_resolve_ttynam_sub (gfc_code
*c
)
3870 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
3872 ts
.type
= BT_INTEGER
;
3873 ts
.kind
= gfc_c_int_kind
;
3874 ts
.u
.derived
= NULL
;
3876 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3879 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
3883 /* Resolve the UMASK intrinsic subroutine. */
3886 gfc_resolve_umask_sub (gfc_code
*c
)
3891 if (c
->ext
.actual
->next
->expr
!= NULL
)
3892 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3894 kind
= gfc_default_integer_kind
;
3896 name
= gfc_get_string (PREFIX ("umask_i%d_sub"), kind
);
3897 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3900 /* Resolve the UNLINK intrinsic subroutine. */
3903 gfc_resolve_unlink_sub (gfc_code
*c
)
3908 if (c
->ext
.actual
->next
->expr
!= NULL
)
3909 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3911 kind
= gfc_default_integer_kind
;
3913 name
= gfc_get_string (PREFIX ("unlink_i%d_sub"), kind
);
3914 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);