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 && 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
)
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_ui (factor
->value
.real
, factor
->value
.real
, 180, 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
;
2707 gcc_assert (rad
->ts
.type
== BT_REAL
);
2709 /* Set rad = rad % 2pi to avoid offsets from large angles. */
2710 factor
= gfc_get_constant_expr (rad
->ts
.type
, rad
->ts
.kind
, &rad
->where
);
2711 mpfr_const_pi (factor
->value
.real
, GFC_RND_MODE
);
2712 mpfr_mul_ui (factor
->value
.real
, factor
->value
.real
, 2, GFC_RND_MODE
);
2714 mod_args
= gfc_get_actual_arglist ();
2715 mod_args
->expr
= rad
;
2716 mod_args
->next
= gfc_get_actual_arglist ();
2717 mod_args
->next
->expr
= factor
;
2719 result
= gfc_get_expr ();
2720 result
->ts
= rad
->ts
;
2721 result
->where
= rad
->where
;
2722 result
->expr_type
= EXPR_FUNCTION
;
2723 result
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_MOD
);
2724 result
->value
.function
.actual
= mod_args
;
2726 /* Set factor = 180 / pi. */
2727 factor
= gfc_get_constant_expr (rad
->ts
.type
, rad
->ts
.kind
, &rad
->where
);
2728 mpfr_set_ui (factor
->value
.real
, 180, GFC_RND_MODE
);
2730 mpfr_const_pi (tmp
, GFC_RND_MODE
);
2731 mpfr_div (factor
->value
.real
, factor
->value
.real
, tmp
, GFC_RND_MODE
);
2734 /* Result is deg = (rad % 2pi) * (180 / pi). */
2735 result
= gfc_multiply (result
, factor
);
2740 /* Resolve a call to a trig function. */
2743 resolve_trig_call (gfc_expr
*f
, gfc_expr
*x
)
2745 switch (f
->value
.function
.isym
->id
)
2748 return gfc_resolve_acos (f
, x
);
2750 return gfc_resolve_asin (f
, x
);
2752 return gfc_resolve_atan (f
, x
);
2753 case GFC_ISYM_ATAN2
:
2754 /* NB. arg3 is unused for atan2 */
2755 return gfc_resolve_atan2 (f
, x
, NULL
);
2757 return gfc_resolve_cos (f
, x
);
2758 case GFC_ISYM_COTAN
:
2759 return gfc_resolve_cotan (f
, x
);
2761 return gfc_resolve_sin (f
, x
);
2763 return gfc_resolve_tan (f
, x
);
2769 /* Resolve degree trig function as trigd (x) = trig (radians (x)). */
2772 gfc_resolve_trigd (gfc_expr
*f
, gfc_expr
*x
)
2774 if (is_trig_resolved (f
))
2777 x
= get_radians (x
);
2778 f
->value
.function
.actual
->expr
= x
;
2780 resolve_trig_call (f
, x
);
2784 /* Resolve degree inverse trig function as atrigd (x) = degrees (atrig (x)). */
2787 gfc_resolve_atrigd (gfc_expr
*f
, gfc_expr
*x
)
2789 gfc_expr
*result
, *fcopy
;
2791 if (is_trig_resolved (f
))
2794 resolve_trig_call (f
, x
);
2796 fcopy
= copy_replace_function_shallow (f
);
2797 result
= get_degrees (fcopy
);
2798 gfc_replace_expr (f
, result
);
2802 /* Resolve atan2d(x) = degrees(atan2(x)). */
2805 gfc_resolve_atan2d (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
2807 /* Note that we lose the second arg here - that's okay because it is
2808 unused in gfc_resolve_atan2 anyway. */
2809 gfc_resolve_atrigd (f
, x
);
2814 gfc_resolve_image_index (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2815 gfc_expr
*sub ATTRIBUTE_UNUSED
)
2817 static char image_index
[] = "__image_index";
2818 f
->ts
.type
= BT_INTEGER
;
2819 f
->ts
.kind
= gfc_default_integer_kind
;
2820 f
->value
.function
.name
= image_index
;
2825 gfc_resolve_this_image (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
2826 gfc_expr
*distance ATTRIBUTE_UNUSED
)
2828 static char this_image
[] = "__this_image";
2829 if (array
&& gfc_is_coarray (array
))
2830 resolve_bound (f
, array
, dim
, NULL
, "__this_image", true);
2833 f
->ts
.type
= BT_INTEGER
;
2834 f
->ts
.kind
= gfc_default_integer_kind
;
2835 f
->value
.function
.name
= this_image
;
2841 gfc_resolve_time (gfc_expr
*f
)
2843 f
->ts
.type
= BT_INTEGER
;
2845 f
->value
.function
.name
= gfc_get_string (PREFIX ("time_func"));
2850 gfc_resolve_time8 (gfc_expr
*f
)
2852 f
->ts
.type
= BT_INTEGER
;
2854 f
->value
.function
.name
= gfc_get_string (PREFIX ("time8_func"));
2859 gfc_resolve_transfer (gfc_expr
*f
, gfc_expr
*source ATTRIBUTE_UNUSED
,
2860 gfc_expr
*mold
, gfc_expr
*size
)
2862 /* TODO: Make this do something meaningful. */
2863 static char transfer0
[] = "__transfer0", transfer1
[] = "__transfer1";
2865 if (mold
->ts
.type
== BT_CHARACTER
2866 && !mold
->ts
.u
.cl
->length
2867 && gfc_is_constant_expr (mold
))
2870 if (mold
->expr_type
== EXPR_CONSTANT
)
2872 len
= mold
->value
.character
.length
;
2873 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
2878 gfc_constructor
*c
= gfc_constructor_first (mold
->value
.constructor
);
2879 len
= c
->expr
->value
.character
.length
;
2880 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
2887 if (size
== NULL
&& mold
->rank
== 0)
2890 f
->value
.function
.name
= transfer0
;
2895 f
->value
.function
.name
= transfer1
;
2896 if (size
&& gfc_is_constant_expr (size
))
2898 f
->shape
= gfc_get_shape (1);
2899 mpz_init_set (f
->shape
[0], size
->value
.integer
);
2906 gfc_resolve_transpose (gfc_expr
*f
, gfc_expr
*matrix
)
2909 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ref
)
2910 gfc_resolve_substring_charlen (matrix
);
2916 f
->shape
= gfc_get_shape (2);
2917 mpz_init_set (f
->shape
[0], matrix
->shape
[1]);
2918 mpz_init_set (f
->shape
[1], matrix
->shape
[0]);
2921 switch (matrix
->ts
.kind
)
2927 switch (matrix
->ts
.type
)
2931 f
->value
.function
.name
2932 = gfc_get_string (PREFIX ("transpose_%c%d"),
2933 gfc_type_letter (matrix
->ts
.type
),
2939 /* Use the integer routines for real and logical cases. This
2940 assumes they all have the same alignment requirements. */
2941 f
->value
.function
.name
2942 = gfc_get_string (PREFIX ("transpose_i%d"), matrix
->ts
.kind
);
2946 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ts
.kind
== 4)
2947 f
->value
.function
.name
= PREFIX ("transpose_char4");
2949 f
->value
.function
.name
= PREFIX ("transpose");
2955 f
->value
.function
.name
= (matrix
->ts
.type
== BT_CHARACTER
2956 ? PREFIX ("transpose_char")
2957 : PREFIX ("transpose"));
2964 gfc_resolve_trim (gfc_expr
*f
, gfc_expr
*string
)
2966 f
->ts
.type
= BT_CHARACTER
;
2967 f
->ts
.kind
= string
->ts
.kind
;
2968 f
->value
.function
.name
= gfc_get_string ("__trim_%d", string
->ts
.kind
);
2973 gfc_resolve_ubound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2975 resolve_bound (f
, array
, dim
, kind
, "__ubound", false);
2980 gfc_resolve_ucobound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2982 resolve_bound (f
, array
, dim
, kind
, "__ucobound", true);
2986 /* Resolve the g77 compatibility function UMASK. */
2989 gfc_resolve_umask (gfc_expr
*f
, gfc_expr
*n
)
2991 f
->ts
.type
= BT_INTEGER
;
2992 f
->ts
.kind
= n
->ts
.kind
;
2993 f
->value
.function
.name
= gfc_get_string (PREFIX ("umask_i%d"), n
->ts
.kind
);
2997 /* Resolve the g77 compatibility function UNLINK. */
3000 gfc_resolve_unlink (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
3002 f
->ts
.type
= BT_INTEGER
;
3004 f
->value
.function
.name
= gfc_get_string (PREFIX ("unlink"));
3009 gfc_resolve_ttynam (gfc_expr
*f
, gfc_expr
*unit
)
3014 f
->ts
.type
= BT_CHARACTER
;
3015 f
->ts
.kind
= gfc_default_character_kind
;
3017 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3019 ts
.type
= BT_INTEGER
;
3020 ts
.kind
= gfc_c_int_kind
;
3021 ts
.u
.derived
= NULL
;
3023 gfc_convert_type (unit
, &ts
, 2);
3026 f
->value
.function
.name
= gfc_get_string (PREFIX ("ttynam"));
3031 gfc_resolve_unpack (gfc_expr
*f
, gfc_expr
*vector
, gfc_expr
*mask
,
3032 gfc_expr
*field ATTRIBUTE_UNUSED
)
3034 if (vector
->ts
.type
== BT_CHARACTER
&& vector
->ref
)
3035 gfc_resolve_substring_charlen (vector
);
3038 f
->rank
= mask
->rank
;
3039 resolve_mask_arg (mask
);
3041 if (vector
->ts
.type
== BT_CHARACTER
)
3043 if (vector
->ts
.kind
== 1)
3044 f
->value
.function
.name
3045 = gfc_get_string (PREFIX ("unpack%d_char"), field
->rank
> 0 ? 1 : 0);
3047 f
->value
.function
.name
3048 = gfc_get_string (PREFIX ("unpack%d_char%d"),
3049 field
->rank
> 0 ? 1 : 0, vector
->ts
.kind
);
3052 f
->value
.function
.name
3053 = gfc_get_string (PREFIX ("unpack%d"), field
->rank
> 0 ? 1 : 0);
3058 gfc_resolve_verify (gfc_expr
*f
, gfc_expr
*string
,
3059 gfc_expr
*set ATTRIBUTE_UNUSED
,
3060 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
3062 f
->ts
.type
= BT_INTEGER
;
3064 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
3066 f
->ts
.kind
= gfc_default_integer_kind
;
3067 f
->value
.function
.name
= gfc_get_string ("__verify_%d", string
->ts
.kind
);
3072 gfc_resolve_xor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
3074 f
->ts
.type
= i
->ts
.type
;
3075 f
->ts
.kind
= gfc_kind_max (i
, j
);
3077 if (i
->ts
.kind
!= j
->ts
.kind
)
3079 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
3080 gfc_convert_type (j
, &i
->ts
, 2);
3082 gfc_convert_type (i
, &j
->ts
, 2);
3085 f
->value
.function
.name
3086 = gfc_get_string ("__xor_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
3090 /* Intrinsic subroutine resolution. */
3093 gfc_resolve_alarm_sub (gfc_code
*c
)
3096 gfc_expr
*seconds
, *handler
;
3100 seconds
= c
->ext
.actual
->expr
;
3101 handler
= c
->ext
.actual
->next
->expr
;
3102 ts
.type
= BT_INTEGER
;
3103 ts
.kind
= gfc_c_int_kind
;
3105 /* handler can be either BT_INTEGER or BT_PROCEDURE.
3106 In all cases, the status argument is of default integer kind
3107 (enforced in check.c) so that the function suffix is fixed. */
3108 if (handler
->ts
.type
== BT_INTEGER
)
3110 if (handler
->ts
.kind
!= gfc_c_int_kind
)
3111 gfc_convert_type (handler
, &ts
, 2);
3112 name
= gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
3113 gfc_default_integer_kind
);
3116 name
= gfc_get_string (PREFIX ("alarm_sub_i%d"),
3117 gfc_default_integer_kind
);
3119 if (seconds
->ts
.kind
!= gfc_c_int_kind
)
3120 gfc_convert_type (seconds
, &ts
, 2);
3122 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3126 gfc_resolve_cpu_time (gfc_code
*c
)
3129 name
= gfc_get_string (PREFIX ("cpu_time_%d"), c
->ext
.actual
->expr
->ts
.kind
);
3130 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3134 /* Create a formal arglist based on an actual one and set the INTENTs given. */
3136 static gfc_formal_arglist
*
3137 create_formal_for_intents (gfc_actual_arglist
* actual
, const sym_intent
* ints
)
3139 gfc_formal_arglist
* head
;
3140 gfc_formal_arglist
* tail
;
3146 head
= tail
= gfc_get_formal_arglist ();
3147 for (i
= 0; actual
; actual
= actual
->next
, tail
= tail
->next
, ++i
)
3151 sym
= gfc_new_symbol ("dummyarg", NULL
);
3152 sym
->ts
= actual
->expr
->ts
;
3154 sym
->attr
.intent
= ints
[i
];
3158 tail
->next
= gfc_get_formal_arglist ();
3166 gfc_resolve_atomic_def (gfc_code
*c
)
3168 const char *name
= "atomic_define";
3169 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3174 gfc_resolve_atomic_ref (gfc_code
*c
)
3176 const char *name
= "atomic_ref";
3177 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3181 gfc_resolve_event_query (gfc_code
*c
)
3183 const char *name
= "event_query";
3184 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3188 gfc_resolve_mvbits (gfc_code
*c
)
3190 static const sym_intent INTENTS
[] = {INTENT_IN
, INTENT_IN
, INTENT_IN
,
3191 INTENT_INOUT
, INTENT_IN
};
3197 /* FROMPOS, LEN and TOPOS are restricted to small values. As such,
3198 they will be converted so that they fit into a C int. */
3199 ts
.type
= BT_INTEGER
;
3200 ts
.kind
= gfc_c_int_kind
;
3201 if (c
->ext
.actual
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
3202 gfc_convert_type (c
->ext
.actual
->next
->expr
, &ts
, 2);
3203 if (c
->ext
.actual
->next
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
3204 gfc_convert_type (c
->ext
.actual
->next
->next
->expr
, &ts
, 2);
3205 if (c
->ext
.actual
->next
->next
->next
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
3206 gfc_convert_type (c
->ext
.actual
->next
->next
->next
->next
->expr
, &ts
, 2);
3208 /* TO and FROM are guaranteed to have the same kind parameter. */
3209 name
= gfc_get_string (PREFIX ("mvbits_i%d"),
3210 c
->ext
.actual
->expr
->ts
.kind
);
3211 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3212 /* Mark as elemental subroutine as this does not happen automatically. */
3213 c
->resolved_sym
->attr
.elemental
= 1;
3215 /* Create a dummy formal arglist so the INTENTs are known later for purpose
3216 of creating temporaries. */
3217 c
->resolved_sym
->formal
= create_formal_for_intents (c
->ext
.actual
, INTENTS
);
3222 gfc_resolve_random_number (gfc_code
*c
)
3227 kind
= c
->ext
.actual
->expr
->ts
.kind
;
3228 if (c
->ext
.actual
->expr
->rank
== 0)
3229 name
= gfc_get_string (PREFIX ("random_r%d"), kind
);
3231 name
= gfc_get_string (PREFIX ("arandom_r%d"), kind
);
3233 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3238 gfc_resolve_random_seed (gfc_code
*c
)
3242 name
= gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind
);
3243 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3248 gfc_resolve_rename_sub (gfc_code
*c
)
3253 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3254 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3256 kind
= gfc_default_integer_kind
;
3258 name
= gfc_get_string (PREFIX ("rename_i%d_sub"), kind
);
3259 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3264 gfc_resolve_kill_sub (gfc_code
*c
)
3269 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3270 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3272 kind
= gfc_default_integer_kind
;
3274 name
= gfc_get_string (PREFIX ("kill_i%d_sub"), kind
);
3275 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3280 gfc_resolve_link_sub (gfc_code
*c
)
3285 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3286 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3288 kind
= gfc_default_integer_kind
;
3290 name
= gfc_get_string (PREFIX ("link_i%d_sub"), kind
);
3291 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3296 gfc_resolve_symlnk_sub (gfc_code
*c
)
3301 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3302 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3304 kind
= gfc_default_integer_kind
;
3306 name
= gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind
);
3307 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3311 /* G77 compatibility subroutines dtime() and etime(). */
3314 gfc_resolve_dtime_sub (gfc_code
*c
)
3317 name
= gfc_get_string (PREFIX ("dtime_sub"));
3318 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3322 gfc_resolve_etime_sub (gfc_code
*c
)
3325 name
= gfc_get_string (PREFIX ("etime_sub"));
3326 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3330 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
3333 gfc_resolve_itime (gfc_code
*c
)
3336 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
3337 gfc_default_integer_kind
));
3341 gfc_resolve_idate (gfc_code
*c
)
3344 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
3345 gfc_default_integer_kind
));
3349 gfc_resolve_ltime (gfc_code
*c
)
3352 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
3353 gfc_default_integer_kind
));
3357 gfc_resolve_gmtime (gfc_code
*c
)
3360 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
3361 gfc_default_integer_kind
));
3365 /* G77 compatibility subroutine second(). */
3368 gfc_resolve_second_sub (gfc_code
*c
)
3371 name
= gfc_get_string (PREFIX ("second_sub"));
3372 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3377 gfc_resolve_sleep_sub (gfc_code
*c
)
3382 if (c
->ext
.actual
->expr
!= NULL
)
3383 kind
= c
->ext
.actual
->expr
->ts
.kind
;
3385 kind
= gfc_default_integer_kind
;
3387 name
= gfc_get_string (PREFIX ("sleep_i%d_sub"), kind
);
3388 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3392 /* G77 compatibility function srand(). */
3395 gfc_resolve_srand (gfc_code
*c
)
3398 name
= gfc_get_string (PREFIX ("srand"));
3399 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3403 /* Resolve the getarg intrinsic subroutine. */
3406 gfc_resolve_getarg (gfc_code
*c
)
3410 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_default_integer_kind
)
3415 ts
.type
= BT_INTEGER
;
3416 ts
.kind
= gfc_default_integer_kind
;
3418 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3421 name
= gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind
);
3422 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3426 /* Resolve the getcwd intrinsic subroutine. */
3429 gfc_resolve_getcwd_sub (gfc_code
*c
)
3434 if (c
->ext
.actual
->next
->expr
!= NULL
)
3435 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3437 kind
= gfc_default_integer_kind
;
3439 name
= gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind
);
3440 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3444 /* Resolve the get_command intrinsic subroutine. */
3447 gfc_resolve_get_command (gfc_code
*c
)
3451 kind
= gfc_default_integer_kind
;
3452 name
= gfc_get_string (PREFIX ("get_command_i%d"), kind
);
3453 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3457 /* Resolve the get_command_argument intrinsic subroutine. */
3460 gfc_resolve_get_command_argument (gfc_code
*c
)
3464 kind
= gfc_default_integer_kind
;
3465 name
= gfc_get_string (PREFIX ("get_command_argument_i%d"), kind
);
3466 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3470 /* Resolve the get_environment_variable intrinsic subroutine. */
3473 gfc_resolve_get_environment_variable (gfc_code
*code
)
3477 kind
= gfc_default_integer_kind
;
3478 name
= gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind
);
3479 code
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3484 gfc_resolve_signal_sub (gfc_code
*c
)
3487 gfc_expr
*number
, *handler
, *status
;
3491 number
= c
->ext
.actual
->expr
;
3492 handler
= c
->ext
.actual
->next
->expr
;
3493 status
= c
->ext
.actual
->next
->next
->expr
;
3494 ts
.type
= BT_INTEGER
;
3495 ts
.kind
= gfc_c_int_kind
;
3497 /* handler can be either BT_INTEGER or BT_PROCEDURE */
3498 if (handler
->ts
.type
== BT_INTEGER
)
3500 if (handler
->ts
.kind
!= gfc_c_int_kind
)
3501 gfc_convert_type (handler
, &ts
, 2);
3502 name
= gfc_get_string (PREFIX ("signal_sub_int"));
3505 name
= gfc_get_string (PREFIX ("signal_sub"));
3507 if (number
->ts
.kind
!= gfc_c_int_kind
)
3508 gfc_convert_type (number
, &ts
, 2);
3509 if (status
!= NULL
&& status
->ts
.kind
!= gfc_c_int_kind
)
3510 gfc_convert_type (status
, &ts
, 2);
3512 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3516 /* Resolve the SYSTEM intrinsic subroutine. */
3519 gfc_resolve_system_sub (gfc_code
*c
)
3522 name
= gfc_get_string (PREFIX ("system_sub"));
3523 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3527 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
3530 gfc_resolve_system_clock (gfc_code
*c
)
3534 gfc_expr
*count
= c
->ext
.actual
->expr
;
3535 gfc_expr
*count_max
= c
->ext
.actual
->next
->next
->expr
;
3537 /* The INTEGER(8) version has higher precision, it is used if both COUNT
3538 and COUNT_MAX can hold 64-bit values, or are absent. */
3539 if ((!count
|| count
->ts
.kind
>= 8)
3540 && (!count_max
|| count_max
->ts
.kind
>= 8))
3543 kind
= gfc_default_integer_kind
;
3545 name
= gfc_get_string (PREFIX ("system_clock_%d"), kind
);
3546 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3550 /* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine. */
3552 gfc_resolve_execute_command_line (gfc_code
*c
)
3555 name
= gfc_get_string (PREFIX ("execute_command_line_i%d"),
3556 gfc_default_integer_kind
);
3557 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3561 /* Resolve the EXIT intrinsic subroutine. */
3564 gfc_resolve_exit (gfc_code
*c
)
3571 /* The STATUS argument has to be of default kind. If it is not,
3573 ts
.type
= BT_INTEGER
;
3574 ts
.kind
= gfc_default_integer_kind
;
3575 n
= c
->ext
.actual
->expr
;
3576 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3577 gfc_convert_type (n
, &ts
, 2);
3579 name
= gfc_get_string (PREFIX ("exit_i%d"), ts
.kind
);
3580 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3584 /* Resolve the FLUSH intrinsic subroutine. */
3587 gfc_resolve_flush (gfc_code
*c
)
3594 ts
.type
= BT_INTEGER
;
3595 ts
.kind
= gfc_default_integer_kind
;
3596 n
= c
->ext
.actual
->expr
;
3597 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3598 gfc_convert_type (n
, &ts
, 2);
3600 name
= gfc_get_string (PREFIX ("flush_i%d"), ts
.kind
);
3601 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3606 gfc_resolve_ctime_sub (gfc_code
*c
)
3611 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3612 if (c
->ext
.actual
->expr
->ts
.kind
!= 8)
3614 ts
.type
= BT_INTEGER
;
3616 ts
.u
.derived
= NULL
;
3618 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3621 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3626 gfc_resolve_fdate_sub (gfc_code
*c
)
3628 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3633 gfc_resolve_gerror (gfc_code
*c
)
3635 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3640 gfc_resolve_getlog (gfc_code
*c
)
3642 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3647 gfc_resolve_hostnm_sub (gfc_code
*c
)
3652 if (c
->ext
.actual
->next
->expr
!= NULL
)
3653 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3655 kind
= gfc_default_integer_kind
;
3657 name
= gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind
);
3658 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3663 gfc_resolve_perror (gfc_code
*c
)
3665 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3668 /* Resolve the STAT and FSTAT intrinsic subroutines. */
3671 gfc_resolve_stat_sub (gfc_code
*c
)
3674 name
= gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind
);
3675 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3680 gfc_resolve_lstat_sub (gfc_code
*c
)
3683 name
= gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind
);
3684 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3689 gfc_resolve_fstat_sub (gfc_code
*c
)
3695 u
= c
->ext
.actual
->expr
;
3696 ts
= &c
->ext
.actual
->next
->expr
->ts
;
3697 if (u
->ts
.kind
!= ts
->kind
)
3698 gfc_convert_type (u
, ts
, 2);
3699 name
= gfc_get_string (PREFIX ("fstat_i%d_sub"), ts
->kind
);
3700 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3705 gfc_resolve_fgetc_sub (gfc_code
*c
)
3712 u
= c
->ext
.actual
->expr
;
3713 st
= c
->ext
.actual
->next
->next
->expr
;
3715 if (u
->ts
.kind
!= gfc_c_int_kind
)
3717 ts
.type
= BT_INTEGER
;
3718 ts
.kind
= gfc_c_int_kind
;
3719 ts
.u
.derived
= NULL
;
3721 gfc_convert_type (u
, &ts
, 2);
3725 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), st
->ts
.kind
);
3727 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind
);
3729 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3734 gfc_resolve_fget_sub (gfc_code
*c
)
3739 st
= c
->ext
.actual
->next
->expr
;
3741 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), st
->ts
.kind
);
3743 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind
);
3745 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3750 gfc_resolve_fputc_sub (gfc_code
*c
)
3757 u
= c
->ext
.actual
->expr
;
3758 st
= c
->ext
.actual
->next
->next
->expr
;
3760 if (u
->ts
.kind
!= gfc_c_int_kind
)
3762 ts
.type
= BT_INTEGER
;
3763 ts
.kind
= gfc_c_int_kind
;
3764 ts
.u
.derived
= NULL
;
3766 gfc_convert_type (u
, &ts
, 2);
3770 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), st
->ts
.kind
);
3772 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind
);
3774 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3779 gfc_resolve_fput_sub (gfc_code
*c
)
3784 st
= c
->ext
.actual
->next
->expr
;
3786 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), st
->ts
.kind
);
3788 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind
);
3790 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3795 gfc_resolve_fseek_sub (gfc_code
*c
)
3803 unit
= c
->ext
.actual
->expr
;
3804 offset
= c
->ext
.actual
->next
->expr
;
3805 whence
= c
->ext
.actual
->next
->next
->expr
;
3807 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3809 ts
.type
= BT_INTEGER
;
3810 ts
.kind
= gfc_c_int_kind
;
3811 ts
.u
.derived
= NULL
;
3813 gfc_convert_type (unit
, &ts
, 2);
3816 if (offset
->ts
.kind
!= gfc_intio_kind
)
3818 ts
.type
= BT_INTEGER
;
3819 ts
.kind
= gfc_intio_kind
;
3820 ts
.u
.derived
= NULL
;
3822 gfc_convert_type (offset
, &ts
, 2);
3825 if (whence
->ts
.kind
!= gfc_c_int_kind
)
3827 ts
.type
= BT_INTEGER
;
3828 ts
.kind
= gfc_c_int_kind
;
3829 ts
.u
.derived
= NULL
;
3831 gfc_convert_type (whence
, &ts
, 2);
3834 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
3838 gfc_resolve_ftell_sub (gfc_code
*c
)
3846 unit
= c
->ext
.actual
->expr
;
3847 offset
= c
->ext
.actual
->next
->expr
;
3849 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3851 ts
.type
= BT_INTEGER
;
3852 ts
.kind
= gfc_c_int_kind
;
3853 ts
.u
.derived
= NULL
;
3855 gfc_convert_type (unit
, &ts
, 2);
3858 name
= gfc_get_string (PREFIX ("ftell_i%d_sub"), offset
->ts
.kind
);
3859 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3864 gfc_resolve_ttynam_sub (gfc_code
*c
)
3869 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
3871 ts
.type
= BT_INTEGER
;
3872 ts
.kind
= gfc_c_int_kind
;
3873 ts
.u
.derived
= NULL
;
3875 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3878 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
3882 /* Resolve the UMASK intrinsic subroutine. */
3885 gfc_resolve_umask_sub (gfc_code
*c
)
3890 if (c
->ext
.actual
->next
->expr
!= NULL
)
3891 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3893 kind
= gfc_default_integer_kind
;
3895 name
= gfc_get_string (PREFIX ("umask_i%d_sub"), kind
);
3896 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3899 /* Resolve the UNLINK intrinsic subroutine. */
3902 gfc_resolve_unlink_sub (gfc_code
*c
)
3907 if (c
->ext
.actual
->next
->expr
!= NULL
)
3908 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3910 kind
= gfc_default_integer_kind
;
3912 name
= gfc_get_string (PREFIX ("unlink_i%d_sub"), kind
);
3913 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);