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
)
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
,
2152 f
->ts
.type
= BT_CHARACTER
;
2153 f
->ts
.kind
= string
->ts
.kind
;
2154 f
->value
.function
.name
= gfc_get_string ("__repeat_%d", string
->ts
.kind
);
2156 /* If possible, generate a character length. */
2157 if (f
->ts
.u
.cl
== NULL
)
2158 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2161 if (string
->expr_type
== EXPR_CONSTANT
)
2163 len
= string
->value
.character
.length
;
2164 tmp
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, len
);
2166 else if (string
->ts
.u
.cl
&& string
->ts
.u
.cl
->length
)
2168 tmp
= gfc_copy_expr (string
->ts
.u
.cl
->length
);
2172 f
->ts
.u
.cl
->length
= gfc_multiply (tmp
, gfc_copy_expr (ncopies
));
2177 gfc_resolve_reshape (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*shape
,
2178 gfc_expr
*pad ATTRIBUTE_UNUSED
,
2179 gfc_expr
*order ATTRIBUTE_UNUSED
)
2185 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
2186 gfc_resolve_substring_charlen (source
);
2190 gfc_array_size (shape
, &rank
);
2191 f
->rank
= mpz_get_si (rank
);
2193 switch (source
->ts
.type
)
2200 kind
= source
->ts
.kind
;
2214 if (source
->ts
.type
== BT_COMPLEX
|| source
->ts
.type
== BT_REAL
)
2215 f
->value
.function
.name
2216 = gfc_get_string (PREFIX ("reshape_%c%d"),
2217 gfc_type_letter (source
->ts
.type
),
2219 else if (source
->ts
.type
== BT_CHARACTER
)
2220 f
->value
.function
.name
= gfc_get_string (PREFIX ("reshape_char%d"),
2223 f
->value
.function
.name
2224 = gfc_get_string (PREFIX ("reshape_%d"), source
->ts
.kind
);
2228 f
->value
.function
.name
= (source
->ts
.type
== BT_CHARACTER
2229 ? PREFIX ("reshape_char") : PREFIX ("reshape"));
2233 if (shape
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (shape
))
2236 f
->shape
= gfc_get_shape (f
->rank
);
2237 c
= gfc_constructor_first (shape
->value
.constructor
);
2238 for (i
= 0; i
< f
->rank
; i
++)
2240 mpz_init_set (f
->shape
[i
], c
->expr
->value
.integer
);
2241 c
= gfc_constructor_next (c
);
2245 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
2246 so many runtime variations. */
2247 if (shape
->ts
.kind
!= gfc_index_integer_kind
)
2249 gfc_typespec ts
= shape
->ts
;
2250 ts
.kind
= gfc_index_integer_kind
;
2251 gfc_convert_type_warn (shape
, &ts
, 2, 0);
2253 if (order
&& order
->ts
.kind
!= gfc_index_integer_kind
)
2254 gfc_convert_type_warn (order
, &shape
->ts
, 2, 0);
2259 gfc_resolve_rrspacing (gfc_expr
*f
, gfc_expr
*x
)
2262 f
->value
.function
.name
= gfc_get_string ("__rrspacing_%d", x
->ts
.kind
);
2266 gfc_resolve_fe_runtime_error (gfc_code
*c
)
2269 gfc_actual_arglist
*a
;
2271 name
= gfc_get_string (PREFIX ("runtime_error"));
2273 for (a
= c
->ext
.actual
->next
; a
; a
= a
->next
)
2276 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2280 gfc_resolve_scale (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*i ATTRIBUTE_UNUSED
)
2283 f
->value
.function
.name
= gfc_get_string ("__scale_%d", x
->ts
.kind
);
2288 gfc_resolve_scan (gfc_expr
*f
, gfc_expr
*string
,
2289 gfc_expr
*set ATTRIBUTE_UNUSED
,
2290 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2292 f
->ts
.type
= BT_INTEGER
;
2294 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2296 f
->ts
.kind
= gfc_default_integer_kind
;
2297 f
->value
.function
.name
= gfc_get_string ("__scan_%d", string
->ts
.kind
);
2302 gfc_resolve_secnds (gfc_expr
*t1
, gfc_expr
*t0
)
2305 t1
->value
.function
.name
= gfc_get_string (PREFIX ("secnds"));
2310 gfc_resolve_set_exponent (gfc_expr
*f
, gfc_expr
*x
,
2311 gfc_expr
*i ATTRIBUTE_UNUSED
)
2314 f
->value
.function
.name
= gfc_get_string ("__set_exponent_%d", x
->ts
.kind
);
2319 gfc_resolve_shape (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*kind
)
2321 f
->ts
.type
= BT_INTEGER
;
2324 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2326 f
->ts
.kind
= gfc_default_integer_kind
;
2329 if (array
->rank
!= -1)
2331 f
->shape
= gfc_get_shape (1);
2332 mpz_init_set_ui (f
->shape
[0], array
->rank
);
2335 f
->value
.function
.name
= gfc_get_string (PREFIX ("shape_%d"), f
->ts
.kind
);
2340 gfc_resolve_shift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift ATTRIBUTE_UNUSED
)
2343 if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTA
)
2344 f
->value
.function
.name
= gfc_get_string ("shifta_i%d", f
->ts
.kind
);
2345 else if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTL
)
2346 f
->value
.function
.name
= gfc_get_string ("shiftl_i%d", f
->ts
.kind
);
2347 else if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTR
)
2348 f
->value
.function
.name
= gfc_get_string ("shiftr_i%d", f
->ts
.kind
);
2355 gfc_resolve_sign (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b ATTRIBUTE_UNUSED
)
2358 f
->value
.function
.name
2359 = gfc_get_string ("__sign_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2364 gfc_resolve_signal (gfc_expr
*f
, gfc_expr
*number
, gfc_expr
*handler
)
2366 f
->ts
.type
= BT_INTEGER
;
2367 f
->ts
.kind
= gfc_c_int_kind
;
2369 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2370 if (handler
->ts
.type
== BT_INTEGER
)
2372 if (handler
->ts
.kind
!= gfc_c_int_kind
)
2373 gfc_convert_type (handler
, &f
->ts
, 2);
2374 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func_int"));
2377 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func"));
2379 if (number
->ts
.kind
!= gfc_c_int_kind
)
2380 gfc_convert_type (number
, &f
->ts
, 2);
2385 gfc_resolve_sin (gfc_expr
*f
, gfc_expr
*x
)
2388 f
->value
.function
.name
2389 = gfc_get_string ("__sin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2394 gfc_resolve_sinh (gfc_expr
*f
, gfc_expr
*x
)
2397 f
->value
.function
.name
2398 = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2403 gfc_resolve_size (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2404 gfc_expr
*dim ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2406 f
->ts
.type
= BT_INTEGER
;
2408 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2410 f
->ts
.kind
= gfc_default_integer_kind
;
2415 gfc_resolve_stride (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2416 gfc_expr
*dim ATTRIBUTE_UNUSED
)
2418 f
->ts
.type
= BT_INTEGER
;
2419 f
->ts
.kind
= gfc_index_integer_kind
;
2424 gfc_resolve_spacing (gfc_expr
*f
, gfc_expr
*x
)
2427 f
->value
.function
.name
= gfc_get_string ("__spacing_%d", x
->ts
.kind
);
2432 gfc_resolve_spread (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*dim
,
2435 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
2436 gfc_resolve_substring_charlen (source
);
2438 if (source
->ts
.type
== BT_CHARACTER
)
2439 check_charlen_present (source
);
2442 f
->rank
= source
->rank
+ 1;
2443 if (source
->rank
== 0)
2445 if (source
->ts
.type
== BT_CHARACTER
)
2446 f
->value
.function
.name
2447 = source
->ts
.kind
== 1 ? PREFIX ("spread_char_scalar")
2449 (PREFIX ("spread_char%d_scalar"),
2452 f
->value
.function
.name
= PREFIX ("spread_scalar");
2456 if (source
->ts
.type
== BT_CHARACTER
)
2457 f
->value
.function
.name
2458 = source
->ts
.kind
== 1 ? PREFIX ("spread_char")
2460 (PREFIX ("spread_char%d"),
2463 f
->value
.function
.name
= PREFIX ("spread");
2466 if (dim
&& gfc_is_constant_expr (dim
)
2467 && ncopies
&& gfc_is_constant_expr (ncopies
) && source
->shape
[0])
2470 idim
= mpz_get_ui (dim
->value
.integer
);
2471 f
->shape
= gfc_get_shape (f
->rank
);
2472 for (i
= 0; i
< (idim
- 1); i
++)
2473 mpz_init_set (f
->shape
[i
], source
->shape
[i
]);
2475 mpz_init_set (f
->shape
[idim
- 1], ncopies
->value
.integer
);
2477 for (i
= idim
; i
< f
->rank
; i
++)
2478 mpz_init_set (f
->shape
[i
], source
->shape
[i
-1]);
2482 gfc_resolve_dim_arg (dim
);
2483 gfc_resolve_index (ncopies
, 1);
2488 gfc_resolve_sqrt (gfc_expr
*f
, gfc_expr
*x
)
2491 f
->value
.function
.name
2492 = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2496 /* Resolve the g77 compatibility function STAT AND FSTAT. */
2499 gfc_resolve_stat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2500 gfc_expr
*a ATTRIBUTE_UNUSED
)
2502 f
->ts
.type
= BT_INTEGER
;
2503 f
->ts
.kind
= gfc_default_integer_kind
;
2504 f
->value
.function
.name
= gfc_get_string (PREFIX ("stat_i%d"), f
->ts
.kind
);
2509 gfc_resolve_lstat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2510 gfc_expr
*a ATTRIBUTE_UNUSED
)
2512 f
->ts
.type
= BT_INTEGER
;
2513 f
->ts
.kind
= gfc_default_integer_kind
;
2514 f
->value
.function
.name
= gfc_get_string (PREFIX ("lstat_i%d"), f
->ts
.kind
);
2519 gfc_resolve_fstat (gfc_expr
*f
, gfc_expr
*n
, gfc_expr
*a ATTRIBUTE_UNUSED
)
2521 f
->ts
.type
= BT_INTEGER
;
2522 f
->ts
.kind
= gfc_default_integer_kind
;
2523 if (n
->ts
.kind
!= f
->ts
.kind
)
2524 gfc_convert_type (n
, &f
->ts
, 2);
2526 f
->value
.function
.name
= gfc_get_string (PREFIX ("fstat_i%d"), f
->ts
.kind
);
2531 gfc_resolve_fgetc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2536 f
->ts
.type
= BT_INTEGER
;
2537 f
->ts
.kind
= gfc_c_int_kind
;
2538 if (u
->ts
.kind
!= gfc_c_int_kind
)
2540 ts
.type
= BT_INTEGER
;
2541 ts
.kind
= gfc_c_int_kind
;
2542 ts
.u
.derived
= NULL
;
2544 gfc_convert_type (u
, &ts
, 2);
2547 f
->value
.function
.name
= gfc_get_string (PREFIX ("fgetc"));
2552 gfc_resolve_fget (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2554 f
->ts
.type
= BT_INTEGER
;
2555 f
->ts
.kind
= gfc_c_int_kind
;
2556 f
->value
.function
.name
= gfc_get_string (PREFIX ("fget"));
2561 gfc_resolve_fputc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2566 f
->ts
.type
= BT_INTEGER
;
2567 f
->ts
.kind
= gfc_c_int_kind
;
2568 if (u
->ts
.kind
!= gfc_c_int_kind
)
2570 ts
.type
= BT_INTEGER
;
2571 ts
.kind
= gfc_c_int_kind
;
2572 ts
.u
.derived
= NULL
;
2574 gfc_convert_type (u
, &ts
, 2);
2577 f
->value
.function
.name
= gfc_get_string (PREFIX ("fputc"));
2582 gfc_resolve_fput (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2584 f
->ts
.type
= BT_INTEGER
;
2585 f
->ts
.kind
= gfc_c_int_kind
;
2586 f
->value
.function
.name
= gfc_get_string (PREFIX ("fput"));
2591 gfc_resolve_ftell (gfc_expr
*f
, gfc_expr
*u
)
2596 f
->ts
.type
= BT_INTEGER
;
2597 f
->ts
.kind
= gfc_intio_kind
;
2598 if (u
->ts
.kind
!= gfc_c_int_kind
)
2600 ts
.type
= BT_INTEGER
;
2601 ts
.kind
= gfc_c_int_kind
;
2602 ts
.u
.derived
= NULL
;
2604 gfc_convert_type (u
, &ts
, 2);
2607 f
->value
.function
.name
= gfc_get_string (PREFIX ("ftell2"));
2612 gfc_resolve_storage_size (gfc_expr
*f
, gfc_expr
*a ATTRIBUTE_UNUSED
,
2615 f
->ts
.type
= BT_INTEGER
;
2617 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2619 f
->ts
.kind
= gfc_default_integer_kind
;
2624 gfc_resolve_sum (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2626 resolve_transformational ("sum", f
, array
, dim
, mask
);
2631 gfc_resolve_symlnk (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
2632 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
2634 f
->ts
.type
= BT_INTEGER
;
2635 f
->ts
.kind
= gfc_default_integer_kind
;
2636 f
->value
.function
.name
= gfc_get_string (PREFIX ("symlnk_i%d"), f
->ts
.kind
);
2640 /* Resolve the g77 compatibility function SYSTEM. */
2643 gfc_resolve_system (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
2645 f
->ts
.type
= BT_INTEGER
;
2647 f
->value
.function
.name
= gfc_get_string (PREFIX ("system"));
2652 gfc_resolve_tan (gfc_expr
*f
, gfc_expr
*x
)
2655 f
->value
.function
.name
2656 = gfc_get_string ("__tan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2661 gfc_resolve_tanh (gfc_expr
*f
, gfc_expr
*x
)
2664 f
->value
.function
.name
2665 = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2669 /* Build an expression for converting degrees to radians. */
2672 get_radians (gfc_expr
*deg
)
2674 gfc_expr
*result
, *factor
;
2675 gfc_actual_arglist
*mod_args
;
2677 gcc_assert (deg
->ts
.type
== BT_REAL
);
2679 /* Set deg = deg % 360 to avoid offsets from large angles. */
2680 factor
= gfc_get_constant_expr (deg
->ts
.type
, deg
->ts
.kind
, °
->where
);
2681 mpfr_set_d (factor
->value
.real
, 360.0, GFC_RND_MODE
);
2683 mod_args
= gfc_get_actual_arglist ();
2684 mod_args
->expr
= deg
;
2685 mod_args
->next
= gfc_get_actual_arglist ();
2686 mod_args
->next
->expr
= factor
;
2688 result
= gfc_get_expr ();
2689 result
->ts
= deg
->ts
;
2690 result
->where
= deg
->where
;
2691 result
->expr_type
= EXPR_FUNCTION
;
2692 result
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_MOD
);
2693 result
->value
.function
.actual
= mod_args
;
2695 /* Set factor = pi / 180. */
2696 factor
= gfc_get_constant_expr (deg
->ts
.type
, deg
->ts
.kind
, °
->where
);
2697 mpfr_const_pi (factor
->value
.real
, GFC_RND_MODE
);
2698 mpfr_div_ui (factor
->value
.real
, factor
->value
.real
, 180, GFC_RND_MODE
);
2700 /* Result is rad = (deg % 360) * (pi / 180). */
2701 result
= gfc_multiply (result
, factor
);
2706 /* Build an expression for converting radians to degrees. */
2709 get_degrees (gfc_expr
*rad
)
2711 gfc_expr
*result
, *factor
;
2712 gfc_actual_arglist
*mod_args
;
2715 gcc_assert (rad
->ts
.type
== BT_REAL
);
2717 /* Set rad = rad % 2pi to avoid offsets from large angles. */
2718 factor
= gfc_get_constant_expr (rad
->ts
.type
, rad
->ts
.kind
, &rad
->where
);
2719 mpfr_const_pi (factor
->value
.real
, GFC_RND_MODE
);
2720 mpfr_mul_ui (factor
->value
.real
, factor
->value
.real
, 2, GFC_RND_MODE
);
2722 mod_args
= gfc_get_actual_arglist ();
2723 mod_args
->expr
= rad
;
2724 mod_args
->next
= gfc_get_actual_arglist ();
2725 mod_args
->next
->expr
= factor
;
2727 result
= gfc_get_expr ();
2728 result
->ts
= rad
->ts
;
2729 result
->where
= rad
->where
;
2730 result
->expr_type
= EXPR_FUNCTION
;
2731 result
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_MOD
);
2732 result
->value
.function
.actual
= mod_args
;
2734 /* Set factor = 180 / pi. */
2735 factor
= gfc_get_constant_expr (rad
->ts
.type
, rad
->ts
.kind
, &rad
->where
);
2736 mpfr_set_ui (factor
->value
.real
, 180, GFC_RND_MODE
);
2738 mpfr_const_pi (tmp
, GFC_RND_MODE
);
2739 mpfr_div (factor
->value
.real
, factor
->value
.real
, tmp
, GFC_RND_MODE
);
2742 /* Result is deg = (rad % 2pi) * (180 / pi). */
2743 result
= gfc_multiply (result
, factor
);
2748 /* Resolve a call to a trig function. */
2751 resolve_trig_call (gfc_expr
*f
, gfc_expr
*x
)
2753 switch (f
->value
.function
.isym
->id
)
2756 return gfc_resolve_acos (f
, x
);
2758 return gfc_resolve_asin (f
, x
);
2760 return gfc_resolve_atan (f
, x
);
2761 case GFC_ISYM_ATAN2
:
2762 /* NB. arg3 is unused for atan2 */
2763 return gfc_resolve_atan2 (f
, x
, NULL
);
2765 return gfc_resolve_cos (f
, x
);
2766 case GFC_ISYM_COTAN
:
2767 return gfc_resolve_cotan (f
, x
);
2769 return gfc_resolve_sin (f
, x
);
2771 return gfc_resolve_tan (f
, x
);
2777 /* Resolve degree trig function as trigd (x) = trig (radians (x)). */
2780 gfc_resolve_trigd (gfc_expr
*f
, gfc_expr
*x
)
2782 if (is_trig_resolved (f
))
2785 x
= get_radians (x
);
2786 f
->value
.function
.actual
->expr
= x
;
2788 resolve_trig_call (f
, x
);
2792 /* Resolve degree inverse trig function as atrigd (x) = degrees (atrig (x)). */
2795 gfc_resolve_atrigd (gfc_expr
*f
, gfc_expr
*x
)
2797 gfc_expr
*result
, *fcopy
;
2799 if (is_trig_resolved (f
))
2802 resolve_trig_call (f
, x
);
2804 fcopy
= copy_replace_function_shallow (f
);
2805 result
= get_degrees (fcopy
);
2806 gfc_replace_expr (f
, result
);
2810 /* Resolve atan2d(x) = degrees(atan2(x)). */
2813 gfc_resolve_atan2d (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
2815 /* Note that we lose the second arg here - that's okay because it is
2816 unused in gfc_resolve_atan2 anyway. */
2817 gfc_resolve_atrigd (f
, x
);
2822 gfc_resolve_image_index (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2823 gfc_expr
*sub ATTRIBUTE_UNUSED
)
2825 static char image_index
[] = "__image_index";
2826 f
->ts
.type
= BT_INTEGER
;
2827 f
->ts
.kind
= gfc_default_integer_kind
;
2828 f
->value
.function
.name
= image_index
;
2833 gfc_resolve_this_image (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
2834 gfc_expr
*distance ATTRIBUTE_UNUSED
)
2836 static char this_image
[] = "__this_image";
2837 if (array
&& gfc_is_coarray (array
))
2838 resolve_bound (f
, array
, dim
, NULL
, "__this_image", true);
2841 f
->ts
.type
= BT_INTEGER
;
2842 f
->ts
.kind
= gfc_default_integer_kind
;
2843 f
->value
.function
.name
= this_image
;
2849 gfc_resolve_time (gfc_expr
*f
)
2851 f
->ts
.type
= BT_INTEGER
;
2853 f
->value
.function
.name
= gfc_get_string (PREFIX ("time_func"));
2858 gfc_resolve_time8 (gfc_expr
*f
)
2860 f
->ts
.type
= BT_INTEGER
;
2862 f
->value
.function
.name
= gfc_get_string (PREFIX ("time8_func"));
2867 gfc_resolve_transfer (gfc_expr
*f
, gfc_expr
*source ATTRIBUTE_UNUSED
,
2868 gfc_expr
*mold
, gfc_expr
*size
)
2870 /* TODO: Make this do something meaningful. */
2871 static char transfer0
[] = "__transfer0", transfer1
[] = "__transfer1";
2873 if (mold
->ts
.type
== BT_CHARACTER
2874 && !mold
->ts
.u
.cl
->length
2875 && gfc_is_constant_expr (mold
))
2878 if (mold
->expr_type
== EXPR_CONSTANT
)
2880 len
= mold
->value
.character
.length
;
2881 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
2886 gfc_constructor
*c
= gfc_constructor_first (mold
->value
.constructor
);
2887 len
= c
->expr
->value
.character
.length
;
2888 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
2895 if (size
== NULL
&& mold
->rank
== 0)
2898 f
->value
.function
.name
= transfer0
;
2903 f
->value
.function
.name
= transfer1
;
2904 if (size
&& gfc_is_constant_expr (size
))
2906 f
->shape
= gfc_get_shape (1);
2907 mpz_init_set (f
->shape
[0], size
->value
.integer
);
2914 gfc_resolve_transpose (gfc_expr
*f
, gfc_expr
*matrix
)
2917 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ref
)
2918 gfc_resolve_substring_charlen (matrix
);
2924 f
->shape
= gfc_get_shape (2);
2925 mpz_init_set (f
->shape
[0], matrix
->shape
[1]);
2926 mpz_init_set (f
->shape
[1], matrix
->shape
[0]);
2929 switch (matrix
->ts
.kind
)
2935 switch (matrix
->ts
.type
)
2939 f
->value
.function
.name
2940 = gfc_get_string (PREFIX ("transpose_%c%d"),
2941 gfc_type_letter (matrix
->ts
.type
),
2947 /* Use the integer routines for real and logical cases. This
2948 assumes they all have the same alignment requirements. */
2949 f
->value
.function
.name
2950 = gfc_get_string (PREFIX ("transpose_i%d"), matrix
->ts
.kind
);
2954 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ts
.kind
== 4)
2955 f
->value
.function
.name
= PREFIX ("transpose_char4");
2957 f
->value
.function
.name
= PREFIX ("transpose");
2963 f
->value
.function
.name
= (matrix
->ts
.type
== BT_CHARACTER
2964 ? PREFIX ("transpose_char")
2965 : PREFIX ("transpose"));
2972 gfc_resolve_trim (gfc_expr
*f
, gfc_expr
*string
)
2974 f
->ts
.type
= BT_CHARACTER
;
2975 f
->ts
.kind
= string
->ts
.kind
;
2976 f
->value
.function
.name
= gfc_get_string ("__trim_%d", string
->ts
.kind
);
2981 gfc_resolve_ubound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2983 resolve_bound (f
, array
, dim
, kind
, "__ubound", false);
2988 gfc_resolve_ucobound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2990 resolve_bound (f
, array
, dim
, kind
, "__ucobound", true);
2994 /* Resolve the g77 compatibility function UMASK. */
2997 gfc_resolve_umask (gfc_expr
*f
, gfc_expr
*n
)
2999 f
->ts
.type
= BT_INTEGER
;
3000 f
->ts
.kind
= n
->ts
.kind
;
3001 f
->value
.function
.name
= gfc_get_string (PREFIX ("umask_i%d"), n
->ts
.kind
);
3005 /* Resolve the g77 compatibility function UNLINK. */
3008 gfc_resolve_unlink (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
3010 f
->ts
.type
= BT_INTEGER
;
3012 f
->value
.function
.name
= gfc_get_string (PREFIX ("unlink"));
3017 gfc_resolve_ttynam (gfc_expr
*f
, gfc_expr
*unit
)
3022 f
->ts
.type
= BT_CHARACTER
;
3023 f
->ts
.kind
= gfc_default_character_kind
;
3025 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3027 ts
.type
= BT_INTEGER
;
3028 ts
.kind
= gfc_c_int_kind
;
3029 ts
.u
.derived
= NULL
;
3031 gfc_convert_type (unit
, &ts
, 2);
3034 f
->value
.function
.name
= gfc_get_string (PREFIX ("ttynam"));
3039 gfc_resolve_unpack (gfc_expr
*f
, gfc_expr
*vector
, gfc_expr
*mask
,
3040 gfc_expr
*field ATTRIBUTE_UNUSED
)
3042 if (vector
->ts
.type
== BT_CHARACTER
&& vector
->ref
)
3043 gfc_resolve_substring_charlen (vector
);
3046 f
->rank
= mask
->rank
;
3047 resolve_mask_arg (mask
);
3049 if (vector
->ts
.type
== BT_CHARACTER
)
3051 if (vector
->ts
.kind
== 1)
3052 f
->value
.function
.name
3053 = gfc_get_string (PREFIX ("unpack%d_char"), field
->rank
> 0 ? 1 : 0);
3055 f
->value
.function
.name
3056 = gfc_get_string (PREFIX ("unpack%d_char%d"),
3057 field
->rank
> 0 ? 1 : 0, vector
->ts
.kind
);
3060 f
->value
.function
.name
3061 = gfc_get_string (PREFIX ("unpack%d"), field
->rank
> 0 ? 1 : 0);
3066 gfc_resolve_verify (gfc_expr
*f
, gfc_expr
*string
,
3067 gfc_expr
*set ATTRIBUTE_UNUSED
,
3068 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
3070 f
->ts
.type
= BT_INTEGER
;
3072 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
3074 f
->ts
.kind
= gfc_default_integer_kind
;
3075 f
->value
.function
.name
= gfc_get_string ("__verify_%d", string
->ts
.kind
);
3080 gfc_resolve_xor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
3082 f
->ts
.type
= i
->ts
.type
;
3083 f
->ts
.kind
= gfc_kind_max (i
, j
);
3085 if (i
->ts
.kind
!= j
->ts
.kind
)
3087 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
3088 gfc_convert_type (j
, &i
->ts
, 2);
3090 gfc_convert_type (i
, &j
->ts
, 2);
3093 f
->value
.function
.name
3094 = gfc_get_string ("__xor_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
3098 /* Intrinsic subroutine resolution. */
3101 gfc_resolve_alarm_sub (gfc_code
*c
)
3104 gfc_expr
*seconds
, *handler
;
3108 seconds
= c
->ext
.actual
->expr
;
3109 handler
= c
->ext
.actual
->next
->expr
;
3110 ts
.type
= BT_INTEGER
;
3111 ts
.kind
= gfc_c_int_kind
;
3113 /* handler can be either BT_INTEGER or BT_PROCEDURE.
3114 In all cases, the status argument is of default integer kind
3115 (enforced in check.c) so that the function suffix is fixed. */
3116 if (handler
->ts
.type
== BT_INTEGER
)
3118 if (handler
->ts
.kind
!= gfc_c_int_kind
)
3119 gfc_convert_type (handler
, &ts
, 2);
3120 name
= gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
3121 gfc_default_integer_kind
);
3124 name
= gfc_get_string (PREFIX ("alarm_sub_i%d"),
3125 gfc_default_integer_kind
);
3127 if (seconds
->ts
.kind
!= gfc_c_int_kind
)
3128 gfc_convert_type (seconds
, &ts
, 2);
3130 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3134 gfc_resolve_cpu_time (gfc_code
*c
)
3137 name
= gfc_get_string (PREFIX ("cpu_time_%d"), c
->ext
.actual
->expr
->ts
.kind
);
3138 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3142 /* Create a formal arglist based on an actual one and set the INTENTs given. */
3144 static gfc_formal_arglist
*
3145 create_formal_for_intents (gfc_actual_arglist
* actual
, const sym_intent
* ints
)
3147 gfc_formal_arglist
* head
;
3148 gfc_formal_arglist
* tail
;
3154 head
= tail
= gfc_get_formal_arglist ();
3155 for (i
= 0; actual
; actual
= actual
->next
, tail
= tail
->next
, ++i
)
3159 sym
= gfc_new_symbol ("dummyarg", NULL
);
3160 sym
->ts
= actual
->expr
->ts
;
3162 sym
->attr
.intent
= ints
[i
];
3166 tail
->next
= gfc_get_formal_arglist ();
3174 gfc_resolve_atomic_def (gfc_code
*c
)
3176 const char *name
= "atomic_define";
3177 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3182 gfc_resolve_atomic_ref (gfc_code
*c
)
3184 const char *name
= "atomic_ref";
3185 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3189 gfc_resolve_event_query (gfc_code
*c
)
3191 const char *name
= "event_query";
3192 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3196 gfc_resolve_mvbits (gfc_code
*c
)
3198 static const sym_intent INTENTS
[] = {INTENT_IN
, INTENT_IN
, INTENT_IN
,
3199 INTENT_INOUT
, INTENT_IN
};
3205 /* FROMPOS, LEN and TOPOS are restricted to small values. As such,
3206 they will be converted so that they fit into a C int. */
3207 ts
.type
= BT_INTEGER
;
3208 ts
.kind
= gfc_c_int_kind
;
3209 if (c
->ext
.actual
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
3210 gfc_convert_type (c
->ext
.actual
->next
->expr
, &ts
, 2);
3211 if (c
->ext
.actual
->next
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
3212 gfc_convert_type (c
->ext
.actual
->next
->next
->expr
, &ts
, 2);
3213 if (c
->ext
.actual
->next
->next
->next
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
3214 gfc_convert_type (c
->ext
.actual
->next
->next
->next
->next
->expr
, &ts
, 2);
3216 /* TO and FROM are guaranteed to have the same kind parameter. */
3217 name
= gfc_get_string (PREFIX ("mvbits_i%d"),
3218 c
->ext
.actual
->expr
->ts
.kind
);
3219 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3220 /* Mark as elemental subroutine as this does not happen automatically. */
3221 c
->resolved_sym
->attr
.elemental
= 1;
3223 /* Create a dummy formal arglist so the INTENTs are known later for purpose
3224 of creating temporaries. */
3225 c
->resolved_sym
->formal
= create_formal_for_intents (c
->ext
.actual
, INTENTS
);
3230 gfc_resolve_random_number (gfc_code
*c
)
3235 kind
= c
->ext
.actual
->expr
->ts
.kind
;
3236 if (c
->ext
.actual
->expr
->rank
== 0)
3237 name
= gfc_get_string (PREFIX ("random_r%d"), kind
);
3239 name
= gfc_get_string (PREFIX ("arandom_r%d"), kind
);
3241 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3246 gfc_resolve_random_seed (gfc_code
*c
)
3250 name
= gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind
);
3251 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3256 gfc_resolve_rename_sub (gfc_code
*c
)
3261 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3262 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3264 kind
= gfc_default_integer_kind
;
3266 name
= gfc_get_string (PREFIX ("rename_i%d_sub"), kind
);
3267 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3272 gfc_resolve_kill_sub (gfc_code
*c
)
3277 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3278 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3280 kind
= gfc_default_integer_kind
;
3282 name
= gfc_get_string (PREFIX ("kill_i%d_sub"), kind
);
3283 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3288 gfc_resolve_link_sub (gfc_code
*c
)
3293 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3294 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3296 kind
= gfc_default_integer_kind
;
3298 name
= gfc_get_string (PREFIX ("link_i%d_sub"), kind
);
3299 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3304 gfc_resolve_symlnk_sub (gfc_code
*c
)
3309 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3310 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3312 kind
= gfc_default_integer_kind
;
3314 name
= gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind
);
3315 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3319 /* G77 compatibility subroutines dtime() and etime(). */
3322 gfc_resolve_dtime_sub (gfc_code
*c
)
3325 name
= gfc_get_string (PREFIX ("dtime_sub"));
3326 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3330 gfc_resolve_etime_sub (gfc_code
*c
)
3333 name
= gfc_get_string (PREFIX ("etime_sub"));
3334 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3338 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
3341 gfc_resolve_itime (gfc_code
*c
)
3344 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
3345 gfc_default_integer_kind
));
3349 gfc_resolve_idate (gfc_code
*c
)
3352 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
3353 gfc_default_integer_kind
));
3357 gfc_resolve_ltime (gfc_code
*c
)
3360 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
3361 gfc_default_integer_kind
));
3365 gfc_resolve_gmtime (gfc_code
*c
)
3368 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
3369 gfc_default_integer_kind
));
3373 /* G77 compatibility subroutine second(). */
3376 gfc_resolve_second_sub (gfc_code
*c
)
3379 name
= gfc_get_string (PREFIX ("second_sub"));
3380 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3385 gfc_resolve_sleep_sub (gfc_code
*c
)
3390 if (c
->ext
.actual
->expr
!= NULL
)
3391 kind
= c
->ext
.actual
->expr
->ts
.kind
;
3393 kind
= gfc_default_integer_kind
;
3395 name
= gfc_get_string (PREFIX ("sleep_i%d_sub"), kind
);
3396 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3400 /* G77 compatibility function srand(). */
3403 gfc_resolve_srand (gfc_code
*c
)
3406 name
= gfc_get_string (PREFIX ("srand"));
3407 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3411 /* Resolve the getarg intrinsic subroutine. */
3414 gfc_resolve_getarg (gfc_code
*c
)
3418 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_default_integer_kind
)
3423 ts
.type
= BT_INTEGER
;
3424 ts
.kind
= gfc_default_integer_kind
;
3426 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3429 name
= gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind
);
3430 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3434 /* Resolve the getcwd intrinsic subroutine. */
3437 gfc_resolve_getcwd_sub (gfc_code
*c
)
3442 if (c
->ext
.actual
->next
->expr
!= NULL
)
3443 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3445 kind
= gfc_default_integer_kind
;
3447 name
= gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind
);
3448 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3452 /* Resolve the get_command intrinsic subroutine. */
3455 gfc_resolve_get_command (gfc_code
*c
)
3459 kind
= gfc_default_integer_kind
;
3460 name
= gfc_get_string (PREFIX ("get_command_i%d"), kind
);
3461 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3465 /* Resolve the get_command_argument intrinsic subroutine. */
3468 gfc_resolve_get_command_argument (gfc_code
*c
)
3472 kind
= gfc_default_integer_kind
;
3473 name
= gfc_get_string (PREFIX ("get_command_argument_i%d"), kind
);
3474 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3478 /* Resolve the get_environment_variable intrinsic subroutine. */
3481 gfc_resolve_get_environment_variable (gfc_code
*code
)
3485 kind
= gfc_default_integer_kind
;
3486 name
= gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind
);
3487 code
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3492 gfc_resolve_signal_sub (gfc_code
*c
)
3495 gfc_expr
*number
, *handler
, *status
;
3499 number
= c
->ext
.actual
->expr
;
3500 handler
= c
->ext
.actual
->next
->expr
;
3501 status
= c
->ext
.actual
->next
->next
->expr
;
3502 ts
.type
= BT_INTEGER
;
3503 ts
.kind
= gfc_c_int_kind
;
3505 /* handler can be either BT_INTEGER or BT_PROCEDURE */
3506 if (handler
->ts
.type
== BT_INTEGER
)
3508 if (handler
->ts
.kind
!= gfc_c_int_kind
)
3509 gfc_convert_type (handler
, &ts
, 2);
3510 name
= gfc_get_string (PREFIX ("signal_sub_int"));
3513 name
= gfc_get_string (PREFIX ("signal_sub"));
3515 if (number
->ts
.kind
!= gfc_c_int_kind
)
3516 gfc_convert_type (number
, &ts
, 2);
3517 if (status
!= NULL
&& status
->ts
.kind
!= gfc_c_int_kind
)
3518 gfc_convert_type (status
, &ts
, 2);
3520 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3524 /* Resolve the SYSTEM intrinsic subroutine. */
3527 gfc_resolve_system_sub (gfc_code
*c
)
3530 name
= gfc_get_string (PREFIX ("system_sub"));
3531 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3535 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
3538 gfc_resolve_system_clock (gfc_code
*c
)
3542 gfc_expr
*count
= c
->ext
.actual
->expr
;
3543 gfc_expr
*count_max
= c
->ext
.actual
->next
->next
->expr
;
3545 /* The INTEGER(8) version has higher precision, it is used if both COUNT
3546 and COUNT_MAX can hold 64-bit values, or are absent. */
3547 if ((!count
|| count
->ts
.kind
>= 8)
3548 && (!count_max
|| count_max
->ts
.kind
>= 8))
3551 kind
= gfc_default_integer_kind
;
3553 name
= gfc_get_string (PREFIX ("system_clock_%d"), kind
);
3554 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3558 /* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine. */
3560 gfc_resolve_execute_command_line (gfc_code
*c
)
3563 name
= gfc_get_string (PREFIX ("execute_command_line_i%d"),
3564 gfc_default_integer_kind
);
3565 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3569 /* Resolve the EXIT intrinsic subroutine. */
3572 gfc_resolve_exit (gfc_code
*c
)
3579 /* The STATUS argument has to be of default kind. If it is not,
3581 ts
.type
= BT_INTEGER
;
3582 ts
.kind
= gfc_default_integer_kind
;
3583 n
= c
->ext
.actual
->expr
;
3584 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3585 gfc_convert_type (n
, &ts
, 2);
3587 name
= gfc_get_string (PREFIX ("exit_i%d"), ts
.kind
);
3588 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3592 /* Resolve the FLUSH intrinsic subroutine. */
3595 gfc_resolve_flush (gfc_code
*c
)
3602 ts
.type
= BT_INTEGER
;
3603 ts
.kind
= gfc_default_integer_kind
;
3604 n
= c
->ext
.actual
->expr
;
3605 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3606 gfc_convert_type (n
, &ts
, 2);
3608 name
= gfc_get_string (PREFIX ("flush_i%d"), ts
.kind
);
3609 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3614 gfc_resolve_ctime_sub (gfc_code
*c
)
3619 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3620 if (c
->ext
.actual
->expr
->ts
.kind
!= 8)
3622 ts
.type
= BT_INTEGER
;
3624 ts
.u
.derived
= NULL
;
3626 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3629 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3634 gfc_resolve_fdate_sub (gfc_code
*c
)
3636 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3641 gfc_resolve_gerror (gfc_code
*c
)
3643 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3648 gfc_resolve_getlog (gfc_code
*c
)
3650 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3655 gfc_resolve_hostnm_sub (gfc_code
*c
)
3660 if (c
->ext
.actual
->next
->expr
!= NULL
)
3661 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3663 kind
= gfc_default_integer_kind
;
3665 name
= gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind
);
3666 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3671 gfc_resolve_perror (gfc_code
*c
)
3673 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3676 /* Resolve the STAT and FSTAT intrinsic subroutines. */
3679 gfc_resolve_stat_sub (gfc_code
*c
)
3682 name
= gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind
);
3683 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3688 gfc_resolve_lstat_sub (gfc_code
*c
)
3691 name
= gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind
);
3692 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3697 gfc_resolve_fstat_sub (gfc_code
*c
)
3703 u
= c
->ext
.actual
->expr
;
3704 ts
= &c
->ext
.actual
->next
->expr
->ts
;
3705 if (u
->ts
.kind
!= ts
->kind
)
3706 gfc_convert_type (u
, ts
, 2);
3707 name
= gfc_get_string (PREFIX ("fstat_i%d_sub"), ts
->kind
);
3708 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3713 gfc_resolve_fgetc_sub (gfc_code
*c
)
3720 u
= c
->ext
.actual
->expr
;
3721 st
= c
->ext
.actual
->next
->next
->expr
;
3723 if (u
->ts
.kind
!= gfc_c_int_kind
)
3725 ts
.type
= BT_INTEGER
;
3726 ts
.kind
= gfc_c_int_kind
;
3727 ts
.u
.derived
= NULL
;
3729 gfc_convert_type (u
, &ts
, 2);
3733 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), st
->ts
.kind
);
3735 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind
);
3737 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3742 gfc_resolve_fget_sub (gfc_code
*c
)
3747 st
= c
->ext
.actual
->next
->expr
;
3749 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), st
->ts
.kind
);
3751 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind
);
3753 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3758 gfc_resolve_fputc_sub (gfc_code
*c
)
3765 u
= c
->ext
.actual
->expr
;
3766 st
= c
->ext
.actual
->next
->next
->expr
;
3768 if (u
->ts
.kind
!= gfc_c_int_kind
)
3770 ts
.type
= BT_INTEGER
;
3771 ts
.kind
= gfc_c_int_kind
;
3772 ts
.u
.derived
= NULL
;
3774 gfc_convert_type (u
, &ts
, 2);
3778 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), st
->ts
.kind
);
3780 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind
);
3782 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3787 gfc_resolve_fput_sub (gfc_code
*c
)
3792 st
= c
->ext
.actual
->next
->expr
;
3794 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), st
->ts
.kind
);
3796 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind
);
3798 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3803 gfc_resolve_fseek_sub (gfc_code
*c
)
3811 unit
= c
->ext
.actual
->expr
;
3812 offset
= c
->ext
.actual
->next
->expr
;
3813 whence
= c
->ext
.actual
->next
->next
->expr
;
3815 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3817 ts
.type
= BT_INTEGER
;
3818 ts
.kind
= gfc_c_int_kind
;
3819 ts
.u
.derived
= NULL
;
3821 gfc_convert_type (unit
, &ts
, 2);
3824 if (offset
->ts
.kind
!= gfc_intio_kind
)
3826 ts
.type
= BT_INTEGER
;
3827 ts
.kind
= gfc_intio_kind
;
3828 ts
.u
.derived
= NULL
;
3830 gfc_convert_type (offset
, &ts
, 2);
3833 if (whence
->ts
.kind
!= gfc_c_int_kind
)
3835 ts
.type
= BT_INTEGER
;
3836 ts
.kind
= gfc_c_int_kind
;
3837 ts
.u
.derived
= NULL
;
3839 gfc_convert_type (whence
, &ts
, 2);
3842 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
3846 gfc_resolve_ftell_sub (gfc_code
*c
)
3854 unit
= c
->ext
.actual
->expr
;
3855 offset
= c
->ext
.actual
->next
->expr
;
3857 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3859 ts
.type
= BT_INTEGER
;
3860 ts
.kind
= gfc_c_int_kind
;
3861 ts
.u
.derived
= NULL
;
3863 gfc_convert_type (unit
, &ts
, 2);
3866 name
= gfc_get_string (PREFIX ("ftell_i%d_sub"), offset
->ts
.kind
);
3867 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3872 gfc_resolve_ttynam_sub (gfc_code
*c
)
3877 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
3879 ts
.type
= BT_INTEGER
;
3880 ts
.kind
= gfc_c_int_kind
;
3881 ts
.u
.derived
= NULL
;
3883 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3886 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
3890 /* Resolve the UMASK intrinsic subroutine. */
3893 gfc_resolve_umask_sub (gfc_code
*c
)
3898 if (c
->ext
.actual
->next
->expr
!= NULL
)
3899 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3901 kind
= gfc_default_integer_kind
;
3903 name
= gfc_get_string (PREFIX ("umask_i%d_sub"), kind
);
3904 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3907 /* Resolve the UNLINK intrinsic subroutine. */
3910 gfc_resolve_unlink_sub (gfc_code
*c
)
3915 if (c
->ext
.actual
->next
->expr
!= NULL
)
3916 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3918 kind
= gfc_default_integer_kind
;
3920 name
= gfc_get_string (PREFIX ("unlink_i%d_sub"), kind
);
3921 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);