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
, ...)
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 && strncmp ("__", f
->value
.function
.name
, 2) == 0);
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
)
1049 vtab
= gfc_find_derived_vtab (a
->ts
.u
.derived
);
1050 /* Clear the old expr. */
1051 gfc_free_ref_list (a
->ref
);
1053 memset (a
, '\0', sizeof (gfc_expr
));
1054 /* Construct a new one. */
1055 a
->expr_type
= EXPR_VARIABLE
;
1056 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
1062 /* Replace the second argument with the corresponding vtab. */
1063 if (mo
->ts
.type
== BT_CLASS
)
1064 gfc_add_vptr_component (mo
);
1065 else if (mo
->ts
.type
== BT_DERIVED
)
1069 vtab
= gfc_find_derived_vtab (mo
->ts
.u
.derived
);
1070 /* Clear the old expr. */
1072 gfc_free_ref_list (mo
->ref
);
1073 memset (mo
, '\0', sizeof (gfc_expr
));
1074 /* Construct a new one. */
1075 mo
->expr_type
= EXPR_VARIABLE
;
1076 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
1082 f
->ts
.type
= BT_LOGICAL
;
1085 f
->value
.function
.isym
->formal
->ts
= a
->ts
;
1086 f
->value
.function
.isym
->formal
->next
->ts
= mo
->ts
;
1088 /* Call library function. */
1089 f
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
1094 gfc_resolve_fdate (gfc_expr
*f
)
1096 f
->ts
.type
= BT_CHARACTER
;
1097 f
->ts
.kind
= gfc_default_character_kind
;
1098 f
->value
.function
.name
= gfc_get_string (PREFIX ("fdate"));
1103 gfc_resolve_floor (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1105 f
->ts
.type
= BT_INTEGER
;
1106 f
->ts
.kind
= (kind
== NULL
)
1107 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
1108 f
->value
.function
.name
1109 = gfc_get_string ("__floor%d_%c%d", f
->ts
.kind
,
1110 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1115 gfc_resolve_fnum (gfc_expr
*f
, gfc_expr
*n
)
1117 f
->ts
.type
= BT_INTEGER
;
1118 f
->ts
.kind
= gfc_default_integer_kind
;
1119 if (n
->ts
.kind
!= f
->ts
.kind
)
1120 gfc_convert_type (n
, &f
->ts
, 2);
1121 f
->value
.function
.name
= gfc_get_string (PREFIX ("fnum_i%d"), f
->ts
.kind
);
1126 gfc_resolve_fraction (gfc_expr
*f
, gfc_expr
*x
)
1129 f
->value
.function
.name
= gfc_get_string ("__fraction_%d", x
->ts
.kind
);
1133 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
1136 gfc_resolve_g77_math1 (gfc_expr
*f
, gfc_expr
*x
)
1139 f
->value
.function
.name
= gfc_get_string ("<intrinsic>");
1144 gfc_resolve_gamma (gfc_expr
*f
, gfc_expr
*x
)
1147 f
->value
.function
.name
1148 = gfc_get_string ("__tgamma_%d", x
->ts
.kind
);
1153 gfc_resolve_getcwd (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
1155 f
->ts
.type
= BT_INTEGER
;
1157 f
->value
.function
.name
= gfc_get_string (PREFIX ("getcwd"));
1162 gfc_resolve_getgid (gfc_expr
*f
)
1164 f
->ts
.type
= BT_INTEGER
;
1166 f
->value
.function
.name
= gfc_get_string (PREFIX ("getgid"));
1171 gfc_resolve_getpid (gfc_expr
*f
)
1173 f
->ts
.type
= BT_INTEGER
;
1175 f
->value
.function
.name
= gfc_get_string (PREFIX ("getpid"));
1180 gfc_resolve_getuid (gfc_expr
*f
)
1182 f
->ts
.type
= BT_INTEGER
;
1184 f
->value
.function
.name
= gfc_get_string (PREFIX ("getuid"));
1189 gfc_resolve_hostnm (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
1191 f
->ts
.type
= BT_INTEGER
;
1193 f
->value
.function
.name
= gfc_get_string (PREFIX ("hostnm"));
1198 gfc_resolve_hypot (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
1201 f
->value
.function
.name
= gfc_get_string ("__hypot_r%d", x
->ts
.kind
);
1206 gfc_resolve_iall (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
1208 resolve_transformational ("iall", f
, array
, dim
, mask
);
1213 gfc_resolve_iand (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1215 /* If the kind of i and j are different, then g77 cross-promoted the
1216 kinds to the largest value. The Fortran 95 standard requires the
1218 if (i
->ts
.kind
!= j
->ts
.kind
)
1220 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1221 gfc_convert_type (j
, &i
->ts
, 2);
1223 gfc_convert_type (i
, &j
->ts
, 2);
1227 f
->value
.function
.name
= gfc_get_string ("__iand_%d", i
->ts
.kind
);
1232 gfc_resolve_iany (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
1234 resolve_transformational ("iany", f
, array
, dim
, mask
);
1239 gfc_resolve_ibclr (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
)
1242 f
->value
.function
.name
= gfc_get_string ("__ibclr_%d", i
->ts
.kind
);
1247 gfc_resolve_ibits (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
,
1248 gfc_expr
*len ATTRIBUTE_UNUSED
)
1251 f
->value
.function
.name
= gfc_get_string ("__ibits_%d", i
->ts
.kind
);
1256 gfc_resolve_ibset (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
)
1259 f
->value
.function
.name
= gfc_get_string ("__ibset_%d", i
->ts
.kind
);
1264 gfc_resolve_iachar (gfc_expr
*f
, gfc_expr
*c
, gfc_expr
*kind
)
1266 f
->ts
.type
= BT_INTEGER
;
1268 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1270 f
->ts
.kind
= gfc_default_integer_kind
;
1271 f
->value
.function
.name
= gfc_get_string ("__ichar_%d", c
->ts
.kind
);
1276 gfc_resolve_ichar (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_idnint (gfc_expr
*f
, gfc_expr
*a
)
1290 gfc_resolve_nint (f
, a
, NULL
);
1295 gfc_resolve_ierrno (gfc_expr
*f
)
1297 f
->ts
.type
= BT_INTEGER
;
1298 f
->ts
.kind
= gfc_default_integer_kind
;
1299 f
->value
.function
.name
= gfc_get_string (PREFIX ("ierrno_i%d"), f
->ts
.kind
);
1304 gfc_resolve_ieor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1306 /* If the kind of i and j are different, then g77 cross-promoted the
1307 kinds to the largest value. The Fortran 95 standard requires the
1309 if (i
->ts
.kind
!= j
->ts
.kind
)
1311 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1312 gfc_convert_type (j
, &i
->ts
, 2);
1314 gfc_convert_type (i
, &j
->ts
, 2);
1318 f
->value
.function
.name
= gfc_get_string ("__ieor_%d", i
->ts
.kind
);
1323 gfc_resolve_ior (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1325 /* If the kind of i and j are different, then g77 cross-promoted the
1326 kinds to the largest value. The Fortran 95 standard requires the
1328 if (i
->ts
.kind
!= j
->ts
.kind
)
1330 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1331 gfc_convert_type (j
, &i
->ts
, 2);
1333 gfc_convert_type (i
, &j
->ts
, 2);
1337 f
->value
.function
.name
= gfc_get_string ("__ior_%d", i
->ts
.kind
);
1342 gfc_resolve_index_func (gfc_expr
*f
, gfc_expr
*str
,
1343 gfc_expr
*sub_str ATTRIBUTE_UNUSED
, gfc_expr
*back
,
1349 f
->ts
.type
= BT_INTEGER
;
1351 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1353 f
->ts
.kind
= gfc_default_integer_kind
;
1355 if (back
&& back
->ts
.kind
!= gfc_default_integer_kind
)
1357 ts
.type
= BT_LOGICAL
;
1358 ts
.kind
= gfc_default_integer_kind
;
1359 ts
.u
.derived
= NULL
;
1361 gfc_convert_type (back
, &ts
, 2);
1364 f
->value
.function
.name
1365 = gfc_get_string ("__index_%d_i%d", str
->ts
.kind
, f
->ts
.kind
);
1370 gfc_resolve_int (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1372 f
->ts
.type
= BT_INTEGER
;
1373 f
->ts
.kind
= (kind
== NULL
)
1374 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
1375 f
->value
.function
.name
1376 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1377 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1382 gfc_resolve_int2 (gfc_expr
*f
, gfc_expr
*a
)
1384 f
->ts
.type
= BT_INTEGER
;
1386 f
->value
.function
.name
1387 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1388 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1393 gfc_resolve_int8 (gfc_expr
*f
, gfc_expr
*a
)
1395 f
->ts
.type
= BT_INTEGER
;
1397 f
->value
.function
.name
1398 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1399 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1404 gfc_resolve_long (gfc_expr
*f
, gfc_expr
*a
)
1406 f
->ts
.type
= BT_INTEGER
;
1408 f
->value
.function
.name
1409 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1410 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1415 gfc_resolve_iparity (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
1417 resolve_transformational ("iparity", f
, array
, dim
, mask
);
1422 gfc_resolve_isatty (gfc_expr
*f
, gfc_expr
*u
)
1427 f
->ts
.type
= BT_LOGICAL
;
1428 f
->ts
.kind
= gfc_default_integer_kind
;
1429 if (u
->ts
.kind
!= gfc_c_int_kind
)
1431 ts
.type
= BT_INTEGER
;
1432 ts
.kind
= gfc_c_int_kind
;
1433 ts
.u
.derived
= NULL
;
1435 gfc_convert_type (u
, &ts
, 2);
1438 f
->value
.function
.name
= gfc_get_string (PREFIX ("isatty_l%d"), f
->ts
.kind
);
1443 gfc_resolve_ishft (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1446 f
->value
.function
.name
1447 = gfc_get_string ("__ishft_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1452 gfc_resolve_rshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1455 f
->value
.function
.name
1456 = gfc_get_string ("__rshift_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1461 gfc_resolve_lshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1464 f
->value
.function
.name
1465 = gfc_get_string ("__lshift_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1470 gfc_resolve_ishftc (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
1474 s_kind
= (size
== NULL
) ? gfc_default_integer_kind
: size
->ts
.kind
;
1477 f
->value
.function
.name
1478 = gfc_get_string ("__ishftc_%d_%d_%d", i
->ts
.kind
, shift
->ts
.kind
, s_kind
);
1483 gfc_resolve_kill (gfc_expr
*f
, gfc_expr
*p ATTRIBUTE_UNUSED
,
1484 gfc_expr
*s ATTRIBUTE_UNUSED
)
1486 f
->ts
.type
= BT_INTEGER
;
1487 f
->ts
.kind
= gfc_default_integer_kind
;
1488 f
->value
.function
.name
= gfc_get_string (PREFIX ("kill_i%d"), f
->ts
.kind
);
1493 gfc_resolve_lbound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
1495 resolve_bound (f
, array
, dim
, kind
, "__lbound", false);
1500 gfc_resolve_lcobound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
1502 resolve_bound (f
, array
, dim
, kind
, "__lcobound", true);
1507 gfc_resolve_len (gfc_expr
*f
, gfc_expr
*string
, gfc_expr
*kind
)
1509 f
->ts
.type
= BT_INTEGER
;
1511 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1513 f
->ts
.kind
= gfc_default_integer_kind
;
1514 f
->value
.function
.name
1515 = gfc_get_string ("__len_%d_i%d", string
->ts
.kind
,
1516 gfc_default_integer_kind
);
1521 gfc_resolve_len_trim (gfc_expr
*f
, gfc_expr
*string
, gfc_expr
*kind
)
1523 f
->ts
.type
= BT_INTEGER
;
1525 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1527 f
->ts
.kind
= gfc_default_integer_kind
;
1528 f
->value
.function
.name
= gfc_get_string ("__len_trim%d", string
->ts
.kind
);
1533 gfc_resolve_lgamma (gfc_expr
*f
, gfc_expr
*x
)
1536 f
->value
.function
.name
1537 = gfc_get_string ("__lgamma_%d", x
->ts
.kind
);
1542 gfc_resolve_link (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
1543 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
1545 f
->ts
.type
= BT_INTEGER
;
1546 f
->ts
.kind
= gfc_default_integer_kind
;
1547 f
->value
.function
.name
= gfc_get_string (PREFIX ("link_i%d"), f
->ts
.kind
);
1552 gfc_resolve_loc (gfc_expr
*f
, gfc_expr
*x
)
1554 f
->ts
.type
= BT_INTEGER
;
1555 f
->ts
.kind
= gfc_index_integer_kind
;
1556 f
->value
.function
.name
= gfc_get_string ("__loc_%d", x
->ts
.kind
);
1561 gfc_resolve_log (gfc_expr
*f
, gfc_expr
*x
)
1564 f
->value
.function
.name
1565 = gfc_get_string ("__log_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1570 gfc_resolve_log10 (gfc_expr
*f
, gfc_expr
*x
)
1573 f
->value
.function
.name
1574 = gfc_get_string ("__log10_%c%d", gfc_type_letter (x
->ts
.type
),
1580 gfc_resolve_logical (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1582 f
->ts
.type
= BT_LOGICAL
;
1583 f
->ts
.kind
= (kind
== NULL
)
1584 ? gfc_default_logical_kind
: mpz_get_si (kind
->value
.integer
);
1587 f
->value
.function
.name
1588 = gfc_get_string ("__logical_%d_%c%d", f
->ts
.kind
,
1589 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1594 gfc_resolve_matmul (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b
)
1598 if (a
->ts
.type
== BT_LOGICAL
&& b
->ts
.type
== BT_LOGICAL
)
1600 f
->ts
.type
= BT_LOGICAL
;
1601 f
->ts
.kind
= gfc_default_logical_kind
;
1605 temp
.expr_type
= EXPR_OP
;
1606 gfc_clear_ts (&temp
.ts
);
1607 temp
.value
.op
.op
= INTRINSIC_NONE
;
1608 temp
.value
.op
.op1
= a
;
1609 temp
.value
.op
.op2
= b
;
1610 gfc_type_convert_binary (&temp
, 1);
1614 f
->rank
= (a
->rank
== 2 && b
->rank
== 2) ? 2 : 1;
1616 if (a
->rank
== 2 && b
->rank
== 2)
1618 if (a
->shape
&& b
->shape
)
1620 f
->shape
= gfc_get_shape (f
->rank
);
1621 mpz_init_set (f
->shape
[0], a
->shape
[0]);
1622 mpz_init_set (f
->shape
[1], b
->shape
[1]);
1625 else if (a
->rank
== 1)
1629 f
->shape
= gfc_get_shape (f
->rank
);
1630 mpz_init_set (f
->shape
[0], b
->shape
[1]);
1635 /* b->rank == 1 and a->rank == 2 here, all other cases have
1636 been caught in check.c. */
1639 f
->shape
= gfc_get_shape (f
->rank
);
1640 mpz_init_set (f
->shape
[0], a
->shape
[0]);
1644 f
->value
.function
.name
1645 = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f
->ts
.type
),
1651 gfc_resolve_minmax (const char *name
, gfc_expr
*f
, gfc_actual_arglist
*args
)
1653 gfc_actual_arglist
*a
;
1655 f
->ts
.type
= args
->expr
->ts
.type
;
1656 f
->ts
.kind
= args
->expr
->ts
.kind
;
1657 /* Find the largest type kind. */
1658 for (a
= args
->next
; a
; a
= a
->next
)
1660 if (a
->expr
->ts
.kind
> f
->ts
.kind
)
1661 f
->ts
.kind
= a
->expr
->ts
.kind
;
1664 /* Convert all parameters to the required kind. */
1665 for (a
= args
; a
; a
= a
->next
)
1667 if (a
->expr
->ts
.kind
!= f
->ts
.kind
)
1668 gfc_convert_type (a
->expr
, &f
->ts
, 2);
1671 f
->value
.function
.name
1672 = gfc_get_string (name
, gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
1677 gfc_resolve_max (gfc_expr
*f
, gfc_actual_arglist
*args
)
1679 gfc_resolve_minmax ("__max_%c%d", f
, args
);
1684 gfc_resolve_maxloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1690 f
->ts
.type
= BT_INTEGER
;
1691 f
->ts
.kind
= gfc_default_integer_kind
;
1696 f
->shape
= gfc_get_shape (1);
1697 mpz_init_set_si (f
->shape
[0], array
->rank
);
1701 f
->rank
= array
->rank
- 1;
1702 gfc_resolve_dim_arg (dim
);
1703 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1705 idim
= (int) mpz_get_si (dim
->value
.integer
);
1706 f
->shape
= gfc_get_shape (f
->rank
);
1707 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1709 if (i
== (idim
- 1))
1711 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1718 if (mask
->rank
== 0)
1723 resolve_mask_arg (mask
);
1728 f
->value
.function
.name
1729 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name
, dim
!= NULL
, f
->ts
.kind
,
1730 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1735 gfc_resolve_maxval (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1745 f
->rank
= array
->rank
- 1;
1746 gfc_resolve_dim_arg (dim
);
1748 if (f
->rank
&& array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1750 idim
= (int) mpz_get_si (dim
->value
.integer
);
1751 f
->shape
= gfc_get_shape (f
->rank
);
1752 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1754 if (i
== (idim
- 1))
1756 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1763 if (mask
->rank
== 0)
1768 resolve_mask_arg (mask
);
1773 f
->value
.function
.name
1774 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
1775 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1780 gfc_resolve_mclock (gfc_expr
*f
)
1782 f
->ts
.type
= BT_INTEGER
;
1784 f
->value
.function
.name
= PREFIX ("mclock");
1789 gfc_resolve_mclock8 (gfc_expr
*f
)
1791 f
->ts
.type
= BT_INTEGER
;
1793 f
->value
.function
.name
= PREFIX ("mclock8");
1798 gfc_resolve_mask (gfc_expr
*f
, gfc_expr
*i ATTRIBUTE_UNUSED
,
1801 f
->ts
.type
= BT_INTEGER
;
1802 f
->ts
.kind
= kind
? mpz_get_si (kind
->value
.integer
)
1803 : gfc_default_integer_kind
;
1805 if (f
->value
.function
.isym
->id
== GFC_ISYM_MASKL
)
1806 f
->value
.function
.name
= gfc_get_string ("__maskl_i%d", f
->ts
.kind
);
1808 f
->value
.function
.name
= gfc_get_string ("__maskr_i%d", f
->ts
.kind
);
1813 gfc_resolve_merge (gfc_expr
*f
, gfc_expr
*tsource
,
1814 gfc_expr
*fsource ATTRIBUTE_UNUSED
,
1815 gfc_expr
*mask ATTRIBUTE_UNUSED
)
1817 if (tsource
->ts
.type
== BT_CHARACTER
&& tsource
->ref
)
1818 gfc_resolve_substring_charlen (tsource
);
1820 if (fsource
->ts
.type
== BT_CHARACTER
&& fsource
->ref
)
1821 gfc_resolve_substring_charlen (fsource
);
1823 if (tsource
->ts
.type
== BT_CHARACTER
)
1824 check_charlen_present (tsource
);
1826 f
->ts
= tsource
->ts
;
1827 f
->value
.function
.name
1828 = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource
->ts
.type
),
1834 gfc_resolve_merge_bits (gfc_expr
*f
, gfc_expr
*i
,
1835 gfc_expr
*j ATTRIBUTE_UNUSED
,
1836 gfc_expr
*mask ATTRIBUTE_UNUSED
)
1839 f
->value
.function
.name
= gfc_get_string ("__merge_bits_i%d", i
->ts
.kind
);
1844 gfc_resolve_min (gfc_expr
*f
, gfc_actual_arglist
*args
)
1846 gfc_resolve_minmax ("__min_%c%d", f
, args
);
1851 gfc_resolve_minloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1857 f
->ts
.type
= BT_INTEGER
;
1858 f
->ts
.kind
= gfc_default_integer_kind
;
1863 f
->shape
= gfc_get_shape (1);
1864 mpz_init_set_si (f
->shape
[0], array
->rank
);
1868 f
->rank
= array
->rank
- 1;
1869 gfc_resolve_dim_arg (dim
);
1870 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1872 idim
= (int) mpz_get_si (dim
->value
.integer
);
1873 f
->shape
= gfc_get_shape (f
->rank
);
1874 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1876 if (i
== (idim
- 1))
1878 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1885 if (mask
->rank
== 0)
1890 resolve_mask_arg (mask
);
1895 f
->value
.function
.name
1896 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name
, dim
!= NULL
, f
->ts
.kind
,
1897 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1902 gfc_resolve_minval (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1912 f
->rank
= array
->rank
- 1;
1913 gfc_resolve_dim_arg (dim
);
1915 if (f
->rank
&& array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1917 idim
= (int) mpz_get_si (dim
->value
.integer
);
1918 f
->shape
= gfc_get_shape (f
->rank
);
1919 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1921 if (i
== (idim
- 1))
1923 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1930 if (mask
->rank
== 0)
1935 resolve_mask_arg (mask
);
1940 f
->value
.function
.name
1941 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
1942 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1947 gfc_resolve_mod (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
1949 f
->ts
.type
= a
->ts
.type
;
1951 f
->ts
.kind
= gfc_kind_max (a
,p
);
1953 f
->ts
.kind
= a
->ts
.kind
;
1955 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
1957 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
1958 gfc_convert_type (p
, &a
->ts
, 2);
1960 gfc_convert_type (a
, &p
->ts
, 2);
1963 f
->value
.function
.name
1964 = gfc_get_string ("__mod_%c%d", gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
1969 gfc_resolve_modulo (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
1971 f
->ts
.type
= a
->ts
.type
;
1973 f
->ts
.kind
= gfc_kind_max (a
,p
);
1975 f
->ts
.kind
= a
->ts
.kind
;
1977 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
1979 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
1980 gfc_convert_type (p
, &a
->ts
, 2);
1982 gfc_convert_type (a
, &p
->ts
, 2);
1985 f
->value
.function
.name
1986 = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f
->ts
.type
),
1991 gfc_resolve_nearest (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
1993 if (p
->ts
.kind
!= a
->ts
.kind
)
1994 gfc_convert_type (p
, &a
->ts
, 2);
1997 f
->value
.function
.name
1998 = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a
->ts
.type
),
2003 gfc_resolve_nint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
2005 f
->ts
.type
= BT_INTEGER
;
2006 f
->ts
.kind
= (kind
== NULL
)
2007 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
2008 f
->value
.function
.name
2009 = gfc_get_string ("__nint_%d_%d", f
->ts
.kind
, a
->ts
.kind
);
2014 gfc_resolve_norm2 (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
)
2016 resolve_transformational ("norm2", f
, array
, dim
, NULL
);
2021 gfc_resolve_not (gfc_expr
*f
, gfc_expr
*i
)
2024 f
->value
.function
.name
= gfc_get_string ("__not_%d", i
->ts
.kind
);
2029 gfc_resolve_or (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
2031 f
->ts
.type
= i
->ts
.type
;
2032 f
->ts
.kind
= gfc_kind_max (i
, j
);
2034 if (i
->ts
.kind
!= j
->ts
.kind
)
2036 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
2037 gfc_convert_type (j
, &i
->ts
, 2);
2039 gfc_convert_type (i
, &j
->ts
, 2);
2042 f
->value
.function
.name
2043 = gfc_get_string ("__or_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
2048 gfc_resolve_pack (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*mask
,
2049 gfc_expr
*vector ATTRIBUTE_UNUSED
)
2051 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
2052 gfc_resolve_substring_charlen (array
);
2057 resolve_mask_arg (mask
);
2059 if (mask
->rank
!= 0)
2061 if (array
->ts
.type
== BT_CHARACTER
)
2062 f
->value
.function
.name
2063 = array
->ts
.kind
== 1 ? PREFIX ("pack_char")
2065 (PREFIX ("pack_char%d"),
2068 f
->value
.function
.name
= PREFIX ("pack");
2072 if (array
->ts
.type
== BT_CHARACTER
)
2073 f
->value
.function
.name
2074 = array
->ts
.kind
== 1 ? PREFIX ("pack_s_char")
2076 (PREFIX ("pack_s_char%d"),
2079 f
->value
.function
.name
= PREFIX ("pack_s");
2085 gfc_resolve_parity (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
)
2087 resolve_transformational ("parity", f
, array
, dim
, NULL
);
2092 gfc_resolve_product (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
2095 resolve_transformational ("product", f
, array
, dim
, mask
);
2100 gfc_resolve_rank (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
)
2102 f
->ts
.type
= BT_INTEGER
;
2103 f
->ts
.kind
= gfc_default_integer_kind
;
2104 f
->value
.function
.name
= gfc_get_string ("__rank");
2109 gfc_resolve_real (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
2111 f
->ts
.type
= BT_REAL
;
2114 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2116 f
->ts
.kind
= (a
->ts
.type
== BT_COMPLEX
)
2117 ? a
->ts
.kind
: gfc_default_real_kind
;
2119 f
->value
.function
.name
2120 = gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
2121 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2126 gfc_resolve_realpart (gfc_expr
*f
, gfc_expr
*a
)
2128 f
->ts
.type
= BT_REAL
;
2129 f
->ts
.kind
= a
->ts
.kind
;
2130 f
->value
.function
.name
2131 = gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
2132 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2137 gfc_resolve_rename (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
2138 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
2140 f
->ts
.type
= BT_INTEGER
;
2141 f
->ts
.kind
= gfc_default_integer_kind
;
2142 f
->value
.function
.name
= gfc_get_string (PREFIX ("rename_i%d"), f
->ts
.kind
);
2147 gfc_resolve_repeat (gfc_expr
*f
, gfc_expr
*string
,
2151 f
->ts
.type
= BT_CHARACTER
;
2152 f
->ts
.kind
= string
->ts
.kind
;
2153 f
->value
.function
.name
= gfc_get_string ("__repeat_%d", string
->ts
.kind
);
2155 /* If possible, generate a character length. */
2156 if (f
->ts
.u
.cl
== NULL
)
2157 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2160 if (string
->expr_type
== EXPR_CONSTANT
)
2162 tmp
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
2163 string
->value
.character
.length
);
2165 else if (string
->ts
.u
.cl
&& string
->ts
.u
.cl
->length
)
2167 tmp
= gfc_copy_expr (string
->ts
.u
.cl
->length
);
2171 f
->ts
.u
.cl
->length
= gfc_multiply (tmp
, gfc_copy_expr (ncopies
));
2176 gfc_resolve_reshape (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*shape
,
2177 gfc_expr
*pad ATTRIBUTE_UNUSED
,
2178 gfc_expr
*order ATTRIBUTE_UNUSED
)
2184 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
2185 gfc_resolve_substring_charlen (source
);
2189 gfc_array_size (shape
, &rank
);
2190 f
->rank
= mpz_get_si (rank
);
2192 switch (source
->ts
.type
)
2199 kind
= source
->ts
.kind
;
2213 if (source
->ts
.type
== BT_COMPLEX
|| source
->ts
.type
== BT_REAL
)
2214 f
->value
.function
.name
2215 = gfc_get_string (PREFIX ("reshape_%c%d"),
2216 gfc_type_letter (source
->ts
.type
),
2218 else if (source
->ts
.type
== BT_CHARACTER
)
2219 f
->value
.function
.name
= gfc_get_string (PREFIX ("reshape_char%d"),
2222 f
->value
.function
.name
2223 = gfc_get_string (PREFIX ("reshape_%d"), source
->ts
.kind
);
2227 f
->value
.function
.name
= (source
->ts
.type
== BT_CHARACTER
2228 ? PREFIX ("reshape_char") : PREFIX ("reshape"));
2232 if (shape
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (shape
))
2235 f
->shape
= gfc_get_shape (f
->rank
);
2236 c
= gfc_constructor_first (shape
->value
.constructor
);
2237 for (i
= 0; i
< f
->rank
; i
++)
2239 mpz_init_set (f
->shape
[i
], c
->expr
->value
.integer
);
2240 c
= gfc_constructor_next (c
);
2244 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
2245 so many runtime variations. */
2246 if (shape
->ts
.kind
!= gfc_index_integer_kind
)
2248 gfc_typespec ts
= shape
->ts
;
2249 ts
.kind
= gfc_index_integer_kind
;
2250 gfc_convert_type_warn (shape
, &ts
, 2, 0);
2252 if (order
&& order
->ts
.kind
!= gfc_index_integer_kind
)
2253 gfc_convert_type_warn (order
, &shape
->ts
, 2, 0);
2258 gfc_resolve_rrspacing (gfc_expr
*f
, gfc_expr
*x
)
2261 f
->value
.function
.name
= gfc_get_string ("__rrspacing_%d", x
->ts
.kind
);
2265 gfc_resolve_fe_runtime_error (gfc_code
*c
)
2268 gfc_actual_arglist
*a
;
2270 name
= gfc_get_string (PREFIX ("runtime_error"));
2272 for (a
= c
->ext
.actual
->next
; a
; a
= a
->next
)
2275 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2279 gfc_resolve_scale (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*i ATTRIBUTE_UNUSED
)
2282 f
->value
.function
.name
= gfc_get_string ("__scale_%d", x
->ts
.kind
);
2287 gfc_resolve_scan (gfc_expr
*f
, gfc_expr
*string
,
2288 gfc_expr
*set ATTRIBUTE_UNUSED
,
2289 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2291 f
->ts
.type
= BT_INTEGER
;
2293 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2295 f
->ts
.kind
= gfc_default_integer_kind
;
2296 f
->value
.function
.name
= gfc_get_string ("__scan_%d", string
->ts
.kind
);
2301 gfc_resolve_secnds (gfc_expr
*t1
, gfc_expr
*t0
)
2304 t1
->value
.function
.name
= gfc_get_string (PREFIX ("secnds"));
2309 gfc_resolve_set_exponent (gfc_expr
*f
, gfc_expr
*x
,
2310 gfc_expr
*i ATTRIBUTE_UNUSED
)
2313 f
->value
.function
.name
= gfc_get_string ("__set_exponent_%d", x
->ts
.kind
);
2318 gfc_resolve_shape (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*kind
)
2320 f
->ts
.type
= BT_INTEGER
;
2323 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2325 f
->ts
.kind
= gfc_default_integer_kind
;
2328 if (array
->rank
!= -1)
2330 f
->shape
= gfc_get_shape (1);
2331 mpz_init_set_ui (f
->shape
[0], array
->rank
);
2334 f
->value
.function
.name
= gfc_get_string (PREFIX ("shape_%d"), f
->ts
.kind
);
2339 gfc_resolve_shift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift ATTRIBUTE_UNUSED
)
2342 if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTA
)
2343 f
->value
.function
.name
= gfc_get_string ("shifta_i%d", f
->ts
.kind
);
2344 else if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTL
)
2345 f
->value
.function
.name
= gfc_get_string ("shiftl_i%d", f
->ts
.kind
);
2346 else if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTR
)
2347 f
->value
.function
.name
= gfc_get_string ("shiftr_i%d", f
->ts
.kind
);
2354 gfc_resolve_sign (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b ATTRIBUTE_UNUSED
)
2357 f
->value
.function
.name
2358 = gfc_get_string ("__sign_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2363 gfc_resolve_signal (gfc_expr
*f
, gfc_expr
*number
, gfc_expr
*handler
)
2365 f
->ts
.type
= BT_INTEGER
;
2366 f
->ts
.kind
= gfc_c_int_kind
;
2368 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2369 if (handler
->ts
.type
== BT_INTEGER
)
2371 if (handler
->ts
.kind
!= gfc_c_int_kind
)
2372 gfc_convert_type (handler
, &f
->ts
, 2);
2373 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func_int"));
2376 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func"));
2378 if (number
->ts
.kind
!= gfc_c_int_kind
)
2379 gfc_convert_type (number
, &f
->ts
, 2);
2384 gfc_resolve_sin (gfc_expr
*f
, gfc_expr
*x
)
2387 f
->value
.function
.name
2388 = gfc_get_string ("__sin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2393 gfc_resolve_sinh (gfc_expr
*f
, gfc_expr
*x
)
2396 f
->value
.function
.name
2397 = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2402 gfc_resolve_size (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2403 gfc_expr
*dim ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2405 f
->ts
.type
= BT_INTEGER
;
2407 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2409 f
->ts
.kind
= gfc_default_integer_kind
;
2414 gfc_resolve_stride (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2415 gfc_expr
*dim ATTRIBUTE_UNUSED
)
2417 f
->ts
.type
= BT_INTEGER
;
2418 f
->ts
.kind
= gfc_index_integer_kind
;
2423 gfc_resolve_spacing (gfc_expr
*f
, gfc_expr
*x
)
2426 f
->value
.function
.name
= gfc_get_string ("__spacing_%d", x
->ts
.kind
);
2431 gfc_resolve_spread (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*dim
,
2434 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
2435 gfc_resolve_substring_charlen (source
);
2437 if (source
->ts
.type
== BT_CHARACTER
)
2438 check_charlen_present (source
);
2441 f
->rank
= source
->rank
+ 1;
2442 if (source
->rank
== 0)
2444 if (source
->ts
.type
== BT_CHARACTER
)
2445 f
->value
.function
.name
2446 = source
->ts
.kind
== 1 ? PREFIX ("spread_char_scalar")
2448 (PREFIX ("spread_char%d_scalar"),
2451 f
->value
.function
.name
= PREFIX ("spread_scalar");
2455 if (source
->ts
.type
== BT_CHARACTER
)
2456 f
->value
.function
.name
2457 = source
->ts
.kind
== 1 ? PREFIX ("spread_char")
2459 (PREFIX ("spread_char%d"),
2462 f
->value
.function
.name
= PREFIX ("spread");
2465 if (dim
&& gfc_is_constant_expr (dim
)
2466 && ncopies
&& gfc_is_constant_expr (ncopies
) && source
->shape
[0])
2469 idim
= mpz_get_ui (dim
->value
.integer
);
2470 f
->shape
= gfc_get_shape (f
->rank
);
2471 for (i
= 0; i
< (idim
- 1); i
++)
2472 mpz_init_set (f
->shape
[i
], source
->shape
[i
]);
2474 mpz_init_set (f
->shape
[idim
- 1], ncopies
->value
.integer
);
2476 for (i
= idim
; i
< f
->rank
; i
++)
2477 mpz_init_set (f
->shape
[i
], source
->shape
[i
-1]);
2481 gfc_resolve_dim_arg (dim
);
2482 gfc_resolve_index (ncopies
, 1);
2487 gfc_resolve_sqrt (gfc_expr
*f
, gfc_expr
*x
)
2490 f
->value
.function
.name
2491 = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2495 /* Resolve the g77 compatibility function STAT AND FSTAT. */
2498 gfc_resolve_stat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2499 gfc_expr
*a ATTRIBUTE_UNUSED
)
2501 f
->ts
.type
= BT_INTEGER
;
2502 f
->ts
.kind
= gfc_default_integer_kind
;
2503 f
->value
.function
.name
= gfc_get_string (PREFIX ("stat_i%d"), f
->ts
.kind
);
2508 gfc_resolve_lstat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2509 gfc_expr
*a ATTRIBUTE_UNUSED
)
2511 f
->ts
.type
= BT_INTEGER
;
2512 f
->ts
.kind
= gfc_default_integer_kind
;
2513 f
->value
.function
.name
= gfc_get_string (PREFIX ("lstat_i%d"), f
->ts
.kind
);
2518 gfc_resolve_fstat (gfc_expr
*f
, gfc_expr
*n
, gfc_expr
*a ATTRIBUTE_UNUSED
)
2520 f
->ts
.type
= BT_INTEGER
;
2521 f
->ts
.kind
= gfc_default_integer_kind
;
2522 if (n
->ts
.kind
!= f
->ts
.kind
)
2523 gfc_convert_type (n
, &f
->ts
, 2);
2525 f
->value
.function
.name
= gfc_get_string (PREFIX ("fstat_i%d"), f
->ts
.kind
);
2530 gfc_resolve_fgetc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2535 f
->ts
.type
= BT_INTEGER
;
2536 f
->ts
.kind
= gfc_c_int_kind
;
2537 if (u
->ts
.kind
!= gfc_c_int_kind
)
2539 ts
.type
= BT_INTEGER
;
2540 ts
.kind
= gfc_c_int_kind
;
2541 ts
.u
.derived
= NULL
;
2543 gfc_convert_type (u
, &ts
, 2);
2546 f
->value
.function
.name
= gfc_get_string (PREFIX ("fgetc"));
2551 gfc_resolve_fget (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2553 f
->ts
.type
= BT_INTEGER
;
2554 f
->ts
.kind
= gfc_c_int_kind
;
2555 f
->value
.function
.name
= gfc_get_string (PREFIX ("fget"));
2560 gfc_resolve_fputc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2565 f
->ts
.type
= BT_INTEGER
;
2566 f
->ts
.kind
= gfc_c_int_kind
;
2567 if (u
->ts
.kind
!= gfc_c_int_kind
)
2569 ts
.type
= BT_INTEGER
;
2570 ts
.kind
= gfc_c_int_kind
;
2571 ts
.u
.derived
= NULL
;
2573 gfc_convert_type (u
, &ts
, 2);
2576 f
->value
.function
.name
= gfc_get_string (PREFIX ("fputc"));
2581 gfc_resolve_fput (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2583 f
->ts
.type
= BT_INTEGER
;
2584 f
->ts
.kind
= gfc_c_int_kind
;
2585 f
->value
.function
.name
= gfc_get_string (PREFIX ("fput"));
2590 gfc_resolve_ftell (gfc_expr
*f
, gfc_expr
*u
)
2595 f
->ts
.type
= BT_INTEGER
;
2596 f
->ts
.kind
= gfc_intio_kind
;
2597 if (u
->ts
.kind
!= gfc_c_int_kind
)
2599 ts
.type
= BT_INTEGER
;
2600 ts
.kind
= gfc_c_int_kind
;
2601 ts
.u
.derived
= NULL
;
2603 gfc_convert_type (u
, &ts
, 2);
2606 f
->value
.function
.name
= gfc_get_string (PREFIX ("ftell"));
2611 gfc_resolve_storage_size (gfc_expr
*f
, gfc_expr
*a ATTRIBUTE_UNUSED
,
2614 f
->ts
.type
= BT_INTEGER
;
2616 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2618 f
->ts
.kind
= gfc_default_integer_kind
;
2623 gfc_resolve_sum (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2625 resolve_transformational ("sum", f
, array
, dim
, mask
);
2630 gfc_resolve_symlnk (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
2631 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
2633 f
->ts
.type
= BT_INTEGER
;
2634 f
->ts
.kind
= gfc_default_integer_kind
;
2635 f
->value
.function
.name
= gfc_get_string (PREFIX ("symlnk_i%d"), f
->ts
.kind
);
2639 /* Resolve the g77 compatibility function SYSTEM. */
2642 gfc_resolve_system (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
2644 f
->ts
.type
= BT_INTEGER
;
2646 f
->value
.function
.name
= gfc_get_string (PREFIX ("system"));
2651 gfc_resolve_tan (gfc_expr
*f
, gfc_expr
*x
)
2654 f
->value
.function
.name
2655 = gfc_get_string ("__tan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2660 gfc_resolve_tanh (gfc_expr
*f
, gfc_expr
*x
)
2663 f
->value
.function
.name
2664 = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2668 /* Build an expression for converting degrees to radians. */
2671 get_radians (gfc_expr
*deg
)
2673 gfc_expr
*result
, *factor
;
2674 gfc_actual_arglist
*mod_args
;
2676 gcc_assert (deg
->ts
.type
== BT_REAL
);
2678 /* Set deg = deg % 360 to avoid offsets from large angles. */
2679 factor
= gfc_get_constant_expr (deg
->ts
.type
, deg
->ts
.kind
, °
->where
);
2680 mpfr_set_d (factor
->value
.real
, 360.0, GFC_RND_MODE
);
2682 mod_args
= gfc_get_actual_arglist ();
2683 mod_args
->expr
= deg
;
2684 mod_args
->next
= gfc_get_actual_arglist ();
2685 mod_args
->next
->expr
= factor
;
2687 result
= gfc_get_expr ();
2688 result
->ts
= deg
->ts
;
2689 result
->where
= deg
->where
;
2690 result
->expr_type
= EXPR_FUNCTION
;
2691 result
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_MOD
);
2692 result
->value
.function
.actual
= mod_args
;
2694 /* Set factor = pi / 180. */
2695 factor
= gfc_get_constant_expr (deg
->ts
.type
, deg
->ts
.kind
, °
->where
);
2696 mpfr_const_pi (factor
->value
.real
, GFC_RND_MODE
);
2697 mpfr_div_ui (factor
->value
.real
, factor
->value
.real
, 180, GFC_RND_MODE
);
2699 /* Result is rad = (deg % 360) * (pi / 180). */
2700 result
= gfc_multiply (result
, factor
);
2705 /* Build an expression for converting radians to degrees. */
2708 get_degrees (gfc_expr
*rad
)
2710 gfc_expr
*result
, *factor
;
2711 gfc_actual_arglist
*mod_args
;
2714 gcc_assert (rad
->ts
.type
== BT_REAL
);
2716 /* Set rad = rad % 2pi to avoid offsets from large angles. */
2717 factor
= gfc_get_constant_expr (rad
->ts
.type
, rad
->ts
.kind
, &rad
->where
);
2718 mpfr_const_pi (factor
->value
.real
, GFC_RND_MODE
);
2719 mpfr_mul_ui (factor
->value
.real
, factor
->value
.real
, 2, GFC_RND_MODE
);
2721 mod_args
= gfc_get_actual_arglist ();
2722 mod_args
->expr
= rad
;
2723 mod_args
->next
= gfc_get_actual_arglist ();
2724 mod_args
->next
->expr
= factor
;
2726 result
= gfc_get_expr ();
2727 result
->ts
= rad
->ts
;
2728 result
->where
= rad
->where
;
2729 result
->expr_type
= EXPR_FUNCTION
;
2730 result
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_MOD
);
2731 result
->value
.function
.actual
= mod_args
;
2733 /* Set factor = 180 / pi. */
2734 factor
= gfc_get_constant_expr (rad
->ts
.type
, rad
->ts
.kind
, &rad
->where
);
2735 mpfr_set_ui (factor
->value
.real
, 180, GFC_RND_MODE
);
2737 mpfr_const_pi (tmp
, GFC_RND_MODE
);
2738 mpfr_div (factor
->value
.real
, factor
->value
.real
, tmp
, GFC_RND_MODE
);
2741 /* Result is deg = (rad % 2pi) * (180 / pi). */
2742 result
= gfc_multiply (result
, factor
);
2747 /* Resolve a call to a trig function. */
2750 resolve_trig_call (gfc_expr
*f
, gfc_expr
*x
)
2752 switch (f
->value
.function
.isym
->id
)
2755 return gfc_resolve_acos (f
, x
);
2757 return gfc_resolve_asin (f
, x
);
2759 return gfc_resolve_atan (f
, x
);
2760 case GFC_ISYM_ATAN2
:
2761 /* NB. arg3 is unused for atan2 */
2762 return gfc_resolve_atan2 (f
, x
, NULL
);
2764 return gfc_resolve_cos (f
, x
);
2765 case GFC_ISYM_COTAN
:
2766 return gfc_resolve_cotan (f
, x
);
2768 return gfc_resolve_sin (f
, x
);
2770 return gfc_resolve_tan (f
, x
);
2776 /* Resolve degree trig function as trigd (x) = trig (radians (x)). */
2779 gfc_resolve_trigd (gfc_expr
*f
, gfc_expr
*x
)
2781 if (is_trig_resolved (f
))
2784 x
= get_radians (x
);
2785 f
->value
.function
.actual
->expr
= x
;
2787 resolve_trig_call (f
, x
);
2791 /* Resolve degree inverse trig function as atrigd (x) = degrees (atrig (x)). */
2794 gfc_resolve_atrigd (gfc_expr
*f
, gfc_expr
*x
)
2796 gfc_expr
*result
, *fcopy
;
2798 if (is_trig_resolved (f
))
2801 resolve_trig_call (f
, x
);
2803 fcopy
= copy_replace_function_shallow (f
);
2804 result
= get_degrees (fcopy
);
2805 gfc_replace_expr (f
, result
);
2809 /* Resolve atan2d(x) = degrees(atan2(x)). */
2812 gfc_resolve_atan2d (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
2814 /* Note that we lose the second arg here - that's okay because it is
2815 unused in gfc_resolve_atan2 anyway. */
2816 gfc_resolve_atrigd (f
, x
);
2821 gfc_resolve_image_index (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2822 gfc_expr
*sub ATTRIBUTE_UNUSED
)
2824 static char image_index
[] = "__image_index";
2825 f
->ts
.type
= BT_INTEGER
;
2826 f
->ts
.kind
= gfc_default_integer_kind
;
2827 f
->value
.function
.name
= image_index
;
2832 gfc_resolve_this_image (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
2833 gfc_expr
*distance ATTRIBUTE_UNUSED
)
2835 static char this_image
[] = "__this_image";
2836 if (array
&& gfc_is_coarray (array
))
2837 resolve_bound (f
, array
, dim
, NULL
, "__this_image", true);
2840 f
->ts
.type
= BT_INTEGER
;
2841 f
->ts
.kind
= gfc_default_integer_kind
;
2842 f
->value
.function
.name
= this_image
;
2848 gfc_resolve_time (gfc_expr
*f
)
2850 f
->ts
.type
= BT_INTEGER
;
2852 f
->value
.function
.name
= gfc_get_string (PREFIX ("time_func"));
2857 gfc_resolve_time8 (gfc_expr
*f
)
2859 f
->ts
.type
= BT_INTEGER
;
2861 f
->value
.function
.name
= gfc_get_string (PREFIX ("time8_func"));
2866 gfc_resolve_transfer (gfc_expr
*f
, gfc_expr
*source ATTRIBUTE_UNUSED
,
2867 gfc_expr
*mold
, gfc_expr
*size
)
2869 /* TODO: Make this do something meaningful. */
2870 static char transfer0
[] = "__transfer0", transfer1
[] = "__transfer1";
2872 if (mold
->ts
.type
== BT_CHARACTER
2873 && !mold
->ts
.u
.cl
->length
2874 && gfc_is_constant_expr (mold
))
2877 if (mold
->expr_type
== EXPR_CONSTANT
)
2879 len
= mold
->value
.character
.length
;
2880 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
2885 gfc_constructor
*c
= gfc_constructor_first (mold
->value
.constructor
);
2886 len
= c
->expr
->value
.character
.length
;
2887 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
2894 if (size
== NULL
&& mold
->rank
== 0)
2897 f
->value
.function
.name
= transfer0
;
2902 f
->value
.function
.name
= transfer1
;
2903 if (size
&& gfc_is_constant_expr (size
))
2905 f
->shape
= gfc_get_shape (1);
2906 mpz_init_set (f
->shape
[0], size
->value
.integer
);
2913 gfc_resolve_transpose (gfc_expr
*f
, gfc_expr
*matrix
)
2916 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ref
)
2917 gfc_resolve_substring_charlen (matrix
);
2923 f
->shape
= gfc_get_shape (2);
2924 mpz_init_set (f
->shape
[0], matrix
->shape
[1]);
2925 mpz_init_set (f
->shape
[1], matrix
->shape
[0]);
2928 switch (matrix
->ts
.kind
)
2934 switch (matrix
->ts
.type
)
2938 f
->value
.function
.name
2939 = gfc_get_string (PREFIX ("transpose_%c%d"),
2940 gfc_type_letter (matrix
->ts
.type
),
2946 /* Use the integer routines for real and logical cases. This
2947 assumes they all have the same alignment requirements. */
2948 f
->value
.function
.name
2949 = gfc_get_string (PREFIX ("transpose_i%d"), matrix
->ts
.kind
);
2953 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ts
.kind
== 4)
2954 f
->value
.function
.name
= PREFIX ("transpose_char4");
2956 f
->value
.function
.name
= PREFIX ("transpose");
2962 f
->value
.function
.name
= (matrix
->ts
.type
== BT_CHARACTER
2963 ? PREFIX ("transpose_char")
2964 : PREFIX ("transpose"));
2971 gfc_resolve_trim (gfc_expr
*f
, gfc_expr
*string
)
2973 f
->ts
.type
= BT_CHARACTER
;
2974 f
->ts
.kind
= string
->ts
.kind
;
2975 f
->value
.function
.name
= gfc_get_string ("__trim_%d", string
->ts
.kind
);
2980 gfc_resolve_ubound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2982 resolve_bound (f
, array
, dim
, kind
, "__ubound", false);
2987 gfc_resolve_ucobound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2989 resolve_bound (f
, array
, dim
, kind
, "__ucobound", true);
2993 /* Resolve the g77 compatibility function UMASK. */
2996 gfc_resolve_umask (gfc_expr
*f
, gfc_expr
*n
)
2998 f
->ts
.type
= BT_INTEGER
;
2999 f
->ts
.kind
= n
->ts
.kind
;
3000 f
->value
.function
.name
= gfc_get_string (PREFIX ("umask_i%d"), n
->ts
.kind
);
3004 /* Resolve the g77 compatibility function UNLINK. */
3007 gfc_resolve_unlink (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
3009 f
->ts
.type
= BT_INTEGER
;
3011 f
->value
.function
.name
= gfc_get_string (PREFIX ("unlink"));
3016 gfc_resolve_ttynam (gfc_expr
*f
, gfc_expr
*unit
)
3021 f
->ts
.type
= BT_CHARACTER
;
3022 f
->ts
.kind
= gfc_default_character_kind
;
3024 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3026 ts
.type
= BT_INTEGER
;
3027 ts
.kind
= gfc_c_int_kind
;
3028 ts
.u
.derived
= NULL
;
3030 gfc_convert_type (unit
, &ts
, 2);
3033 f
->value
.function
.name
= gfc_get_string (PREFIX ("ttynam"));
3038 gfc_resolve_unpack (gfc_expr
*f
, gfc_expr
*vector
, gfc_expr
*mask
,
3039 gfc_expr
*field ATTRIBUTE_UNUSED
)
3041 if (vector
->ts
.type
== BT_CHARACTER
&& vector
->ref
)
3042 gfc_resolve_substring_charlen (vector
);
3045 f
->rank
= mask
->rank
;
3046 resolve_mask_arg (mask
);
3048 if (vector
->ts
.type
== BT_CHARACTER
)
3050 if (vector
->ts
.kind
== 1)
3051 f
->value
.function
.name
3052 = gfc_get_string (PREFIX ("unpack%d_char"), field
->rank
> 0 ? 1 : 0);
3054 f
->value
.function
.name
3055 = gfc_get_string (PREFIX ("unpack%d_char%d"),
3056 field
->rank
> 0 ? 1 : 0, vector
->ts
.kind
);
3059 f
->value
.function
.name
3060 = gfc_get_string (PREFIX ("unpack%d"), field
->rank
> 0 ? 1 : 0);
3065 gfc_resolve_verify (gfc_expr
*f
, gfc_expr
*string
,
3066 gfc_expr
*set ATTRIBUTE_UNUSED
,
3067 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
3069 f
->ts
.type
= BT_INTEGER
;
3071 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
3073 f
->ts
.kind
= gfc_default_integer_kind
;
3074 f
->value
.function
.name
= gfc_get_string ("__verify_%d", string
->ts
.kind
);
3079 gfc_resolve_xor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
3081 f
->ts
.type
= i
->ts
.type
;
3082 f
->ts
.kind
= gfc_kind_max (i
, j
);
3084 if (i
->ts
.kind
!= j
->ts
.kind
)
3086 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
3087 gfc_convert_type (j
, &i
->ts
, 2);
3089 gfc_convert_type (i
, &j
->ts
, 2);
3092 f
->value
.function
.name
3093 = gfc_get_string ("__xor_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
3097 /* Intrinsic subroutine resolution. */
3100 gfc_resolve_alarm_sub (gfc_code
*c
)
3103 gfc_expr
*seconds
, *handler
;
3107 seconds
= c
->ext
.actual
->expr
;
3108 handler
= c
->ext
.actual
->next
->expr
;
3109 ts
.type
= BT_INTEGER
;
3110 ts
.kind
= gfc_c_int_kind
;
3112 /* handler can be either BT_INTEGER or BT_PROCEDURE.
3113 In all cases, the status argument is of default integer kind
3114 (enforced in check.c) so that the function suffix is fixed. */
3115 if (handler
->ts
.type
== BT_INTEGER
)
3117 if (handler
->ts
.kind
!= gfc_c_int_kind
)
3118 gfc_convert_type (handler
, &ts
, 2);
3119 name
= gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
3120 gfc_default_integer_kind
);
3123 name
= gfc_get_string (PREFIX ("alarm_sub_i%d"),
3124 gfc_default_integer_kind
);
3126 if (seconds
->ts
.kind
!= gfc_c_int_kind
)
3127 gfc_convert_type (seconds
, &ts
, 2);
3129 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3133 gfc_resolve_cpu_time (gfc_code
*c
)
3136 name
= gfc_get_string (PREFIX ("cpu_time_%d"), c
->ext
.actual
->expr
->ts
.kind
);
3137 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3141 /* Create a formal arglist based on an actual one and set the INTENTs given. */
3143 static gfc_formal_arglist
*
3144 create_formal_for_intents (gfc_actual_arglist
* actual
, const sym_intent
* ints
)
3146 gfc_formal_arglist
* head
;
3147 gfc_formal_arglist
* tail
;
3153 head
= tail
= gfc_get_formal_arglist ();
3154 for (i
= 0; actual
; actual
= actual
->next
, tail
= tail
->next
, ++i
)
3158 sym
= gfc_new_symbol ("dummyarg", NULL
);
3159 sym
->ts
= actual
->expr
->ts
;
3161 sym
->attr
.intent
= ints
[i
];
3165 tail
->next
= gfc_get_formal_arglist ();
3173 gfc_resolve_atomic_def (gfc_code
*c
)
3175 const char *name
= "atomic_define";
3176 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3181 gfc_resolve_atomic_ref (gfc_code
*c
)
3183 const char *name
= "atomic_ref";
3184 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3188 gfc_resolve_event_query (gfc_code
*c
)
3190 const char *name
= "event_query";
3191 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3195 gfc_resolve_mvbits (gfc_code
*c
)
3197 static const sym_intent INTENTS
[] = {INTENT_IN
, INTENT_IN
, INTENT_IN
,
3198 INTENT_INOUT
, INTENT_IN
};
3204 /* FROMPOS, LEN and TOPOS are restricted to small values. As such,
3205 they will be converted so that they fit into a C int. */
3206 ts
.type
= BT_INTEGER
;
3207 ts
.kind
= gfc_c_int_kind
;
3208 if (c
->ext
.actual
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
3209 gfc_convert_type (c
->ext
.actual
->next
->expr
, &ts
, 2);
3210 if (c
->ext
.actual
->next
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
3211 gfc_convert_type (c
->ext
.actual
->next
->next
->expr
, &ts
, 2);
3212 if (c
->ext
.actual
->next
->next
->next
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
3213 gfc_convert_type (c
->ext
.actual
->next
->next
->next
->next
->expr
, &ts
, 2);
3215 /* TO and FROM are guaranteed to have the same kind parameter. */
3216 name
= gfc_get_string (PREFIX ("mvbits_i%d"),
3217 c
->ext
.actual
->expr
->ts
.kind
);
3218 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3219 /* Mark as elemental subroutine as this does not happen automatically. */
3220 c
->resolved_sym
->attr
.elemental
= 1;
3222 /* Create a dummy formal arglist so the INTENTs are known later for purpose
3223 of creating temporaries. */
3224 c
->resolved_sym
->formal
= create_formal_for_intents (c
->ext
.actual
, INTENTS
);
3229 gfc_resolve_random_number (gfc_code
*c
)
3234 kind
= c
->ext
.actual
->expr
->ts
.kind
;
3235 if (c
->ext
.actual
->expr
->rank
== 0)
3236 name
= gfc_get_string (PREFIX ("random_r%d"), kind
);
3238 name
= gfc_get_string (PREFIX ("arandom_r%d"), kind
);
3240 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3245 gfc_resolve_random_seed (gfc_code
*c
)
3249 name
= gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind
);
3250 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3255 gfc_resolve_rename_sub (gfc_code
*c
)
3260 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3261 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3263 kind
= gfc_default_integer_kind
;
3265 name
= gfc_get_string (PREFIX ("rename_i%d_sub"), kind
);
3266 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3271 gfc_resolve_kill_sub (gfc_code
*c
)
3276 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3277 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3279 kind
= gfc_default_integer_kind
;
3281 name
= gfc_get_string (PREFIX ("kill_i%d_sub"), kind
);
3282 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3287 gfc_resolve_link_sub (gfc_code
*c
)
3292 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3293 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3295 kind
= gfc_default_integer_kind
;
3297 name
= gfc_get_string (PREFIX ("link_i%d_sub"), kind
);
3298 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3303 gfc_resolve_symlnk_sub (gfc_code
*c
)
3308 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3309 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3311 kind
= gfc_default_integer_kind
;
3313 name
= gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind
);
3314 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3318 /* G77 compatibility subroutines dtime() and etime(). */
3321 gfc_resolve_dtime_sub (gfc_code
*c
)
3324 name
= gfc_get_string (PREFIX ("dtime_sub"));
3325 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3329 gfc_resolve_etime_sub (gfc_code
*c
)
3332 name
= gfc_get_string (PREFIX ("etime_sub"));
3333 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3337 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
3340 gfc_resolve_itime (gfc_code
*c
)
3343 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
3344 gfc_default_integer_kind
));
3348 gfc_resolve_idate (gfc_code
*c
)
3351 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
3352 gfc_default_integer_kind
));
3356 gfc_resolve_ltime (gfc_code
*c
)
3359 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
3360 gfc_default_integer_kind
));
3364 gfc_resolve_gmtime (gfc_code
*c
)
3367 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
3368 gfc_default_integer_kind
));
3372 /* G77 compatibility subroutine second(). */
3375 gfc_resolve_second_sub (gfc_code
*c
)
3378 name
= gfc_get_string (PREFIX ("second_sub"));
3379 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3384 gfc_resolve_sleep_sub (gfc_code
*c
)
3389 if (c
->ext
.actual
->expr
!= NULL
)
3390 kind
= c
->ext
.actual
->expr
->ts
.kind
;
3392 kind
= gfc_default_integer_kind
;
3394 name
= gfc_get_string (PREFIX ("sleep_i%d_sub"), kind
);
3395 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3399 /* G77 compatibility function srand(). */
3402 gfc_resolve_srand (gfc_code
*c
)
3405 name
= gfc_get_string (PREFIX ("srand"));
3406 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3410 /* Resolve the getarg intrinsic subroutine. */
3413 gfc_resolve_getarg (gfc_code
*c
)
3417 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_default_integer_kind
)
3422 ts
.type
= BT_INTEGER
;
3423 ts
.kind
= gfc_default_integer_kind
;
3425 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3428 name
= gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind
);
3429 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3433 /* Resolve the getcwd intrinsic subroutine. */
3436 gfc_resolve_getcwd_sub (gfc_code
*c
)
3441 if (c
->ext
.actual
->next
->expr
!= NULL
)
3442 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3444 kind
= gfc_default_integer_kind
;
3446 name
= gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind
);
3447 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3451 /* Resolve the get_command intrinsic subroutine. */
3454 gfc_resolve_get_command (gfc_code
*c
)
3458 kind
= gfc_default_integer_kind
;
3459 name
= gfc_get_string (PREFIX ("get_command_i%d"), kind
);
3460 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3464 /* Resolve the get_command_argument intrinsic subroutine. */
3467 gfc_resolve_get_command_argument (gfc_code
*c
)
3471 kind
= gfc_default_integer_kind
;
3472 name
= gfc_get_string (PREFIX ("get_command_argument_i%d"), kind
);
3473 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3477 /* Resolve the get_environment_variable intrinsic subroutine. */
3480 gfc_resolve_get_environment_variable (gfc_code
*code
)
3484 kind
= gfc_default_integer_kind
;
3485 name
= gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind
);
3486 code
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3491 gfc_resolve_signal_sub (gfc_code
*c
)
3494 gfc_expr
*number
, *handler
, *status
;
3498 number
= c
->ext
.actual
->expr
;
3499 handler
= c
->ext
.actual
->next
->expr
;
3500 status
= c
->ext
.actual
->next
->next
->expr
;
3501 ts
.type
= BT_INTEGER
;
3502 ts
.kind
= gfc_c_int_kind
;
3504 /* handler can be either BT_INTEGER or BT_PROCEDURE */
3505 if (handler
->ts
.type
== BT_INTEGER
)
3507 if (handler
->ts
.kind
!= gfc_c_int_kind
)
3508 gfc_convert_type (handler
, &ts
, 2);
3509 name
= gfc_get_string (PREFIX ("signal_sub_int"));
3512 name
= gfc_get_string (PREFIX ("signal_sub"));
3514 if (number
->ts
.kind
!= gfc_c_int_kind
)
3515 gfc_convert_type (number
, &ts
, 2);
3516 if (status
!= NULL
&& status
->ts
.kind
!= gfc_c_int_kind
)
3517 gfc_convert_type (status
, &ts
, 2);
3519 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3523 /* Resolve the SYSTEM intrinsic subroutine. */
3526 gfc_resolve_system_sub (gfc_code
*c
)
3529 name
= gfc_get_string (PREFIX ("system_sub"));
3530 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3534 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
3537 gfc_resolve_system_clock (gfc_code
*c
)
3541 gfc_expr
*count
= c
->ext
.actual
->expr
;
3542 gfc_expr
*count_max
= c
->ext
.actual
->next
->next
->expr
;
3544 /* The INTEGER(8) version has higher precision, it is used if both COUNT
3545 and COUNT_MAX can hold 64-bit values, or are absent. */
3546 if ((!count
|| count
->ts
.kind
>= 8)
3547 && (!count_max
|| count_max
->ts
.kind
>= 8))
3550 kind
= gfc_default_integer_kind
;
3552 name
= gfc_get_string (PREFIX ("system_clock_%d"), kind
);
3553 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3557 /* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine. */
3559 gfc_resolve_execute_command_line (gfc_code
*c
)
3562 name
= gfc_get_string (PREFIX ("execute_command_line_i%d"),
3563 gfc_default_integer_kind
);
3564 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3568 /* Resolve the EXIT intrinsic subroutine. */
3571 gfc_resolve_exit (gfc_code
*c
)
3578 /* The STATUS argument has to be of default kind. If it is not,
3580 ts
.type
= BT_INTEGER
;
3581 ts
.kind
= gfc_default_integer_kind
;
3582 n
= c
->ext
.actual
->expr
;
3583 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3584 gfc_convert_type (n
, &ts
, 2);
3586 name
= gfc_get_string (PREFIX ("exit_i%d"), ts
.kind
);
3587 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3591 /* Resolve the FLUSH intrinsic subroutine. */
3594 gfc_resolve_flush (gfc_code
*c
)
3601 ts
.type
= BT_INTEGER
;
3602 ts
.kind
= gfc_default_integer_kind
;
3603 n
= c
->ext
.actual
->expr
;
3604 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3605 gfc_convert_type (n
, &ts
, 2);
3607 name
= gfc_get_string (PREFIX ("flush_i%d"), ts
.kind
);
3608 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3613 gfc_resolve_ctime_sub (gfc_code
*c
)
3618 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3619 if (c
->ext
.actual
->expr
->ts
.kind
!= 8)
3621 ts
.type
= BT_INTEGER
;
3623 ts
.u
.derived
= NULL
;
3625 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3628 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3633 gfc_resolve_fdate_sub (gfc_code
*c
)
3635 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3640 gfc_resolve_gerror (gfc_code
*c
)
3642 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3647 gfc_resolve_getlog (gfc_code
*c
)
3649 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3654 gfc_resolve_hostnm_sub (gfc_code
*c
)
3659 if (c
->ext
.actual
->next
->expr
!= NULL
)
3660 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3662 kind
= gfc_default_integer_kind
;
3664 name
= gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind
);
3665 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3670 gfc_resolve_perror (gfc_code
*c
)
3672 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3675 /* Resolve the STAT and FSTAT intrinsic subroutines. */
3678 gfc_resolve_stat_sub (gfc_code
*c
)
3681 name
= gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind
);
3682 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3687 gfc_resolve_lstat_sub (gfc_code
*c
)
3690 name
= gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind
);
3691 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3696 gfc_resolve_fstat_sub (gfc_code
*c
)
3702 u
= c
->ext
.actual
->expr
;
3703 ts
= &c
->ext
.actual
->next
->expr
->ts
;
3704 if (u
->ts
.kind
!= ts
->kind
)
3705 gfc_convert_type (u
, ts
, 2);
3706 name
= gfc_get_string (PREFIX ("fstat_i%d_sub"), ts
->kind
);
3707 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3712 gfc_resolve_fgetc_sub (gfc_code
*c
)
3719 u
= c
->ext
.actual
->expr
;
3720 st
= c
->ext
.actual
->next
->next
->expr
;
3722 if (u
->ts
.kind
!= gfc_c_int_kind
)
3724 ts
.type
= BT_INTEGER
;
3725 ts
.kind
= gfc_c_int_kind
;
3726 ts
.u
.derived
= NULL
;
3728 gfc_convert_type (u
, &ts
, 2);
3732 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), st
->ts
.kind
);
3734 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind
);
3736 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3741 gfc_resolve_fget_sub (gfc_code
*c
)
3746 st
= c
->ext
.actual
->next
->expr
;
3748 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), st
->ts
.kind
);
3750 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind
);
3752 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3757 gfc_resolve_fputc_sub (gfc_code
*c
)
3764 u
= c
->ext
.actual
->expr
;
3765 st
= c
->ext
.actual
->next
->next
->expr
;
3767 if (u
->ts
.kind
!= gfc_c_int_kind
)
3769 ts
.type
= BT_INTEGER
;
3770 ts
.kind
= gfc_c_int_kind
;
3771 ts
.u
.derived
= NULL
;
3773 gfc_convert_type (u
, &ts
, 2);
3777 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), st
->ts
.kind
);
3779 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind
);
3781 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3786 gfc_resolve_fput_sub (gfc_code
*c
)
3791 st
= c
->ext
.actual
->next
->expr
;
3793 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), st
->ts
.kind
);
3795 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind
);
3797 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3802 gfc_resolve_fseek_sub (gfc_code
*c
)
3810 unit
= c
->ext
.actual
->expr
;
3811 offset
= c
->ext
.actual
->next
->expr
;
3812 whence
= c
->ext
.actual
->next
->next
->expr
;
3814 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3816 ts
.type
= BT_INTEGER
;
3817 ts
.kind
= gfc_c_int_kind
;
3818 ts
.u
.derived
= NULL
;
3820 gfc_convert_type (unit
, &ts
, 2);
3823 if (offset
->ts
.kind
!= gfc_intio_kind
)
3825 ts
.type
= BT_INTEGER
;
3826 ts
.kind
= gfc_intio_kind
;
3827 ts
.u
.derived
= NULL
;
3829 gfc_convert_type (offset
, &ts
, 2);
3832 if (whence
->ts
.kind
!= gfc_c_int_kind
)
3834 ts
.type
= BT_INTEGER
;
3835 ts
.kind
= gfc_c_int_kind
;
3836 ts
.u
.derived
= NULL
;
3838 gfc_convert_type (whence
, &ts
, 2);
3841 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
3845 gfc_resolve_ftell_sub (gfc_code
*c
)
3853 unit
= c
->ext
.actual
->expr
;
3854 offset
= c
->ext
.actual
->next
->expr
;
3856 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3858 ts
.type
= BT_INTEGER
;
3859 ts
.kind
= gfc_c_int_kind
;
3860 ts
.u
.derived
= NULL
;
3862 gfc_convert_type (unit
, &ts
, 2);
3865 name
= gfc_get_string (PREFIX ("ftell_i%d_sub"), offset
->ts
.kind
);
3866 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3871 gfc_resolve_ttynam_sub (gfc_code
*c
)
3876 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
3878 ts
.type
= BT_INTEGER
;
3879 ts
.kind
= gfc_c_int_kind
;
3880 ts
.u
.derived
= NULL
;
3882 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3885 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
3889 /* Resolve the UMASK intrinsic subroutine. */
3892 gfc_resolve_umask_sub (gfc_code
*c
)
3897 if (c
->ext
.actual
->next
->expr
!= NULL
)
3898 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3900 kind
= gfc_default_integer_kind
;
3902 name
= gfc_get_string (PREFIX ("umask_i%d_sub"), kind
);
3903 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3906 /* Resolve the UNLINK intrinsic subroutine. */
3909 gfc_resolve_unlink_sub (gfc_code
*c
)
3914 if (c
->ext
.actual
->next
->expr
!= NULL
)
3915 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3917 kind
= gfc_default_integer_kind
;
3919 name
= gfc_get_string (PREFIX ("unlink_i%d_sub"), kind
);
3920 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);