1 /* Intrinsic function resolution.
2 Copyright (C) 2000-2021 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"
40 /* Given printf-like arguments, return a stable version of the result string.
42 We already have a working, optimized string hashing table in the form of
43 the identifier table. Reusing this table is likely not to be wasted,
44 since if the function name makes it to the gimple output of the frontend,
45 we'll have to create the identifier anyway. */
48 gfc_get_string (const char *format
, ...)
50 /* Provide sufficient space for "_F.caf_token__symbol.symbol_MOD_symbol". */
51 char temp_name
[15 + 2*GFC_MAX_SYMBOL_LEN
+ 5 + GFC_MAX_SYMBOL_LEN
+ 1];
56 /* Handle common case without vsnprintf and temporary buffer. */
57 if (format
[0] == '%' && format
[1] == 's' && format
[2] == '\0')
59 va_start (ap
, format
);
60 str
= va_arg (ap
, const char *);
66 va_start (ap
, format
);
67 ret
= vsnprintf (temp_name
, sizeof (temp_name
), format
, ap
);
69 if (ret
< 1 || ret
>= (int) sizeof (temp_name
)) /* Reject truncation. */
70 gfc_internal_error ("identifier overflow: %d", ret
);
71 temp_name
[sizeof (temp_name
) - 1] = 0;
75 ident
= get_identifier (str
);
76 return IDENTIFIER_POINTER (ident
);
79 /* MERGE and SPREAD need to have source charlen's present for passing
80 to the result expression. */
82 check_charlen_present (gfc_expr
*source
)
84 if (source
->ts
.u
.cl
== NULL
)
85 source
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
87 if (source
->expr_type
== EXPR_CONSTANT
)
89 source
->ts
.u
.cl
->length
90 = gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
91 source
->value
.character
.length
);
94 else if (source
->expr_type
== EXPR_ARRAY
)
96 gfc_constructor
*c
= gfc_constructor_first (source
->value
.constructor
);
97 source
->ts
.u
.cl
->length
98 = gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
99 c
->expr
->value
.character
.length
);
103 /* Helper function for resolving the "mask" argument. */
106 resolve_mask_arg (gfc_expr
*mask
)
114 /* For the scalar case, coerce the mask to kind=4 unconditionally
115 (because this is the only kind we have a library function
118 if (mask
->ts
.kind
!= 4)
120 ts
.type
= BT_LOGICAL
;
122 gfc_convert_type (mask
, &ts
, 2);
127 /* In the library, we access the mask with a GFC_LOGICAL_1
128 argument. No need to waste memory if we are about to create
129 a temporary array. */
130 if (mask
->expr_type
== EXPR_OP
&& mask
->ts
.kind
!= 1)
132 ts
.type
= BT_LOGICAL
;
134 gfc_convert_type_warn (mask
, &ts
, 2, 0);
141 resolve_bound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
,
142 const char *name
, bool coarray
)
144 f
->ts
.type
= BT_INTEGER
;
146 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
148 f
->ts
.kind
= gfc_default_integer_kind
;
153 if (array
->rank
!= -1)
155 f
->shape
= gfc_get_shape (1);
156 mpz_init_set_ui (f
->shape
[0], coarray
? gfc_get_corank (array
)
161 f
->value
.function
.name
= gfc_get_string ("%s", name
);
166 resolve_transformational (const char *name
, gfc_expr
*f
, gfc_expr
*array
,
167 gfc_expr
*dim
, gfc_expr
*mask
)
180 resolve_mask_arg (mask
);
187 f
->rank
= array
->rank
- 1;
188 f
->shape
= gfc_copy_shape_excluding (array
->shape
, array
->rank
, dim
);
189 gfc_resolve_dim_arg (dim
);
192 f
->value
.function
.name
193 = gfc_get_string (PREFIX ("%s%s_%c%d"), prefix
, name
,
194 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
198 /********************** Resolution functions **********************/
202 gfc_resolve_abs (gfc_expr
*f
, gfc_expr
*a
)
205 if (f
->ts
.type
== BT_COMPLEX
)
206 f
->ts
.type
= BT_REAL
;
208 f
->value
.function
.name
209 = gfc_get_string ("__abs_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
214 gfc_resolve_access (gfc_expr
*f
, gfc_expr
*name ATTRIBUTE_UNUSED
,
215 gfc_expr
*mode ATTRIBUTE_UNUSED
)
217 f
->ts
.type
= BT_INTEGER
;
218 f
->ts
.kind
= gfc_c_int_kind
;
219 f
->value
.function
.name
= PREFIX ("access_func");
224 gfc_resolve_adjustl (gfc_expr
*f
, gfc_expr
*string
)
226 f
->ts
.type
= BT_CHARACTER
;
227 f
->ts
.kind
= string
->ts
.kind
;
229 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, string
->ts
.u
.cl
);
231 f
->value
.function
.name
= gfc_get_string ("__adjustl_s%d", f
->ts
.kind
);
236 gfc_resolve_adjustr (gfc_expr
*f
, gfc_expr
*string
)
238 f
->ts
.type
= BT_CHARACTER
;
239 f
->ts
.kind
= string
->ts
.kind
;
241 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, string
->ts
.u
.cl
);
243 f
->value
.function
.name
= gfc_get_string ("__adjustr_s%d", f
->ts
.kind
);
248 gfc_resolve_char_achar (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*kind
,
251 f
->ts
.type
= BT_CHARACTER
;
252 f
->ts
.kind
= (kind
== NULL
)
253 ? gfc_default_character_kind
: mpz_get_si (kind
->value
.integer
);
254 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
255 f
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
257 f
->value
.function
.name
258 = gfc_get_string ("__%schar_%d_%c%d", is_achar
? "a" : "", f
->ts
.kind
,
259 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
264 gfc_resolve_achar (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*kind
)
266 gfc_resolve_char_achar (f
, x
, kind
, true);
271 gfc_resolve_acos (gfc_expr
*f
, gfc_expr
*x
)
274 f
->value
.function
.name
275 = gfc_get_string ("__acos_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
280 gfc_resolve_acosh (gfc_expr
*f
, gfc_expr
*x
)
283 f
->value
.function
.name
284 = gfc_get_string ("__acosh_%c%d", gfc_type_letter (x
->ts
.type
),
290 gfc_resolve_aimag (gfc_expr
*f
, gfc_expr
*x
)
292 f
->ts
.type
= BT_REAL
;
293 f
->ts
.kind
= x
->ts
.kind
;
294 f
->value
.function
.name
295 = gfc_get_string ("__aimag_%c%d", gfc_type_letter (x
->ts
.type
),
301 gfc_resolve_and (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
303 f
->ts
.type
= i
->ts
.type
;
304 f
->ts
.kind
= gfc_kind_max (i
, j
);
306 if (i
->ts
.kind
!= j
->ts
.kind
)
308 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
309 gfc_convert_type (j
, &i
->ts
, 2);
311 gfc_convert_type (i
, &j
->ts
, 2);
314 f
->value
.function
.name
315 = gfc_get_string ("__and_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
320 gfc_resolve_aint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
325 f
->ts
.type
= a
->ts
.type
;
326 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
328 if (a
->ts
.kind
!= f
->ts
.kind
)
330 ts
.type
= f
->ts
.type
;
331 ts
.kind
= f
->ts
.kind
;
332 gfc_convert_type (a
, &ts
, 2);
334 /* The resolved name is only used for specific intrinsics where
335 the return kind is the same as the arg kind. */
336 f
->value
.function
.name
337 = gfc_get_string ("__aint_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
342 gfc_resolve_dint (gfc_expr
*f
, gfc_expr
*a
)
344 gfc_resolve_aint (f
, a
, NULL
);
349 gfc_resolve_all (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
)
355 gfc_resolve_dim_arg (dim
);
356 f
->rank
= mask
->rank
- 1;
357 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
360 f
->value
.function
.name
361 = gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask
->ts
.type
),
367 gfc_resolve_anint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
372 f
->ts
.type
= a
->ts
.type
;
373 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
375 if (a
->ts
.kind
!= f
->ts
.kind
)
377 ts
.type
= f
->ts
.type
;
378 ts
.kind
= f
->ts
.kind
;
379 gfc_convert_type (a
, &ts
, 2);
382 /* The resolved name is only used for specific intrinsics where
383 the return kind is the same as the arg kind. */
384 f
->value
.function
.name
385 = gfc_get_string ("__anint_%c%d", gfc_type_letter (a
->ts
.type
),
391 gfc_resolve_dnint (gfc_expr
*f
, gfc_expr
*a
)
393 gfc_resolve_anint (f
, a
, NULL
);
398 gfc_resolve_any (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
)
404 gfc_resolve_dim_arg (dim
);
405 f
->rank
= mask
->rank
- 1;
406 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
409 f
->value
.function
.name
410 = gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask
->ts
.type
),
416 gfc_resolve_asin (gfc_expr
*f
, gfc_expr
*x
)
419 f
->value
.function
.name
420 = gfc_get_string ("__asin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
424 gfc_resolve_asinh (gfc_expr
*f
, gfc_expr
*x
)
427 f
->value
.function
.name
428 = gfc_get_string ("__asinh_%c%d", gfc_type_letter (x
->ts
.type
),
433 gfc_resolve_atan (gfc_expr
*f
, gfc_expr
*x
)
436 f
->value
.function
.name
437 = gfc_get_string ("__atan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
441 gfc_resolve_atanh (gfc_expr
*f
, gfc_expr
*x
)
444 f
->value
.function
.name
445 = gfc_get_string ("__atanh_%c%d", gfc_type_letter (x
->ts
.type
),
450 gfc_resolve_atan2 (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
453 f
->value
.function
.name
454 = gfc_get_string ("__atan2_%c%d", gfc_type_letter (x
->ts
.type
),
459 /* Resolve the BESYN and BESJN intrinsics. */
462 gfc_resolve_besn (gfc_expr
*f
, gfc_expr
*n
, gfc_expr
*x
)
468 if (n
->ts
.kind
!= gfc_c_int_kind
)
470 ts
.type
= BT_INTEGER
;
471 ts
.kind
= gfc_c_int_kind
;
472 gfc_convert_type (n
, &ts
, 2);
474 f
->value
.function
.name
= gfc_get_string ("<intrinsic>");
479 gfc_resolve_bessel_n2 (gfc_expr
*f
, gfc_expr
*n1
, gfc_expr
*n2
, gfc_expr
*x
)
486 if (n1
->expr_type
== EXPR_CONSTANT
&& n2
->expr_type
== EXPR_CONSTANT
)
488 f
->shape
= gfc_get_shape (1);
489 mpz_init (f
->shape
[0]);
490 mpz_sub (f
->shape
[0], n2
->value
.integer
, n1
->value
.integer
);
491 mpz_add_ui (f
->shape
[0], f
->shape
[0], 1);
494 if (n1
->ts
.kind
!= gfc_c_int_kind
)
496 ts
.type
= BT_INTEGER
;
497 ts
.kind
= gfc_c_int_kind
;
498 gfc_convert_type (n1
, &ts
, 2);
501 if (n2
->ts
.kind
!= gfc_c_int_kind
)
503 ts
.type
= BT_INTEGER
;
504 ts
.kind
= gfc_c_int_kind
;
505 gfc_convert_type (n2
, &ts
, 2);
508 if (f
->value
.function
.isym
->id
== GFC_ISYM_JN2
)
509 f
->value
.function
.name
= gfc_get_string (PREFIX ("bessel_jn_r%d"),
512 f
->value
.function
.name
= gfc_get_string (PREFIX ("bessel_yn_r%d"),
518 gfc_resolve_btest (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos
)
520 f
->ts
.type
= BT_LOGICAL
;
521 f
->ts
.kind
= gfc_default_logical_kind
;
522 f
->value
.function
.name
523 = gfc_get_string ("__btest_%d_%d", i
->ts
.kind
, pos
->ts
.kind
);
528 gfc_resolve_c_loc (gfc_expr
*f
, gfc_expr
*x ATTRIBUTE_UNUSED
)
530 f
->ts
= f
->value
.function
.isym
->ts
;
535 gfc_resolve_c_funloc (gfc_expr
*f
, gfc_expr
*x ATTRIBUTE_UNUSED
)
537 f
->ts
= f
->value
.function
.isym
->ts
;
542 gfc_resolve_ceiling (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
544 f
->ts
.type
= BT_INTEGER
;
545 f
->ts
.kind
= (kind
== NULL
)
546 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
547 f
->value
.function
.name
548 = gfc_get_string ("__ceiling_%d_%c%d", f
->ts
.kind
,
549 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
554 gfc_resolve_char (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
556 gfc_resolve_char_achar (f
, a
, kind
, false);
561 gfc_resolve_chdir (gfc_expr
*f
, gfc_expr
*d ATTRIBUTE_UNUSED
)
563 f
->ts
.type
= BT_INTEGER
;
564 f
->ts
.kind
= gfc_default_integer_kind
;
565 f
->value
.function
.name
= gfc_get_string (PREFIX ("chdir_i%d"), f
->ts
.kind
);
570 gfc_resolve_chdir_sub (gfc_code
*c
)
575 if (c
->ext
.actual
->next
->expr
!= NULL
)
576 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
578 kind
= gfc_default_integer_kind
;
580 name
= gfc_get_string (PREFIX ("chdir_i%d_sub"), kind
);
581 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
586 gfc_resolve_chmod (gfc_expr
*f
, gfc_expr
*name ATTRIBUTE_UNUSED
,
587 gfc_expr
*mode ATTRIBUTE_UNUSED
)
589 f
->ts
.type
= BT_INTEGER
;
590 f
->ts
.kind
= gfc_c_int_kind
;
591 f
->value
.function
.name
= PREFIX ("chmod_func");
596 gfc_resolve_chmod_sub (gfc_code
*c
)
601 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
602 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
604 kind
= gfc_default_integer_kind
;
606 name
= gfc_get_string (PREFIX ("chmod_i%d_sub"), kind
);
607 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
612 gfc_resolve_cmplx (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*kind
)
614 f
->ts
.type
= BT_COMPLEX
;
615 f
->ts
.kind
= (kind
== NULL
)
616 ? gfc_default_real_kind
: mpz_get_si (kind
->value
.integer
);
619 f
->value
.function
.name
620 = gfc_get_string ("__cmplx0_%d_%c%d", f
->ts
.kind
,
621 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
623 f
->value
.function
.name
624 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f
->ts
.kind
,
625 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
,
626 gfc_type_letter (y
->ts
.type
), y
->ts
.kind
);
631 gfc_resolve_dcmplx (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
)
633 gfc_resolve_cmplx (f
, x
, y
, gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
634 gfc_default_double_kind
));
639 gfc_resolve_complex (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
)
643 if (x
->ts
.type
== BT_INTEGER
)
645 if (y
->ts
.type
== BT_INTEGER
)
646 kind
= gfc_default_real_kind
;
652 if (y
->ts
.type
== BT_REAL
)
653 kind
= (x
->ts
.kind
> y
->ts
.kind
) ? x
->ts
.kind
: y
->ts
.kind
;
658 f
->ts
.type
= BT_COMPLEX
;
660 f
->value
.function
.name
661 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f
->ts
.kind
,
662 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
,
663 gfc_type_letter (y
->ts
.type
), y
->ts
.kind
);
668 gfc_resolve_conjg (gfc_expr
*f
, gfc_expr
*x
)
671 f
->value
.function
.name
= gfc_get_string ("__conjg_%d", x
->ts
.kind
);
676 gfc_resolve_cos (gfc_expr
*f
, gfc_expr
*x
)
679 f
->value
.function
.name
680 = gfc_get_string ("__cos_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
685 gfc_resolve_cosh (gfc_expr
*f
, gfc_expr
*x
)
688 f
->value
.function
.name
689 = gfc_get_string ("__cosh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
694 gfc_resolve_count (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
696 f
->ts
.type
= BT_INTEGER
;
698 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
700 f
->ts
.kind
= gfc_default_integer_kind
;
704 f
->rank
= mask
->rank
- 1;
705 gfc_resolve_dim_arg (dim
);
706 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
709 resolve_mask_arg (mask
);
711 f
->value
.function
.name
712 = gfc_get_string (PREFIX ("count_%d_%c"), f
->ts
.kind
,
713 gfc_type_letter (mask
->ts
.type
));
718 gfc_resolve_cshift (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*shift
,
723 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
724 gfc_resolve_substring_charlen (array
);
727 f
->rank
= array
->rank
;
728 f
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
735 /* If dim kind is greater than default integer we need to use the larger. */
736 m
= gfc_default_integer_kind
;
738 m
= m
< dim
->ts
.kind
? dim
->ts
.kind
: m
;
740 /* Convert shift to at least m, so we don't need
741 kind=1 and kind=2 versions of the library functions. */
742 if (shift
->ts
.kind
< m
)
746 ts
.type
= BT_INTEGER
;
748 gfc_convert_type_warn (shift
, &ts
, 2, 0);
753 if (dim
->expr_type
!= EXPR_CONSTANT
&& dim
->symtree
!= NULL
754 && dim
->symtree
->n
.sym
->attr
.optional
)
756 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
757 dim
->representation
.length
= shift
->ts
.kind
;
761 gfc_resolve_dim_arg (dim
);
762 /* Convert dim to shift's kind to reduce variations. */
763 if (dim
->ts
.kind
!= shift
->ts
.kind
)
764 gfc_convert_type_warn (dim
, &shift
->ts
, 2, 0);
768 if (array
->ts
.type
== BT_CHARACTER
)
770 if (array
->ts
.kind
== gfc_default_character_kind
)
771 f
->value
.function
.name
772 = gfc_get_string (PREFIX ("cshift%d_%d_char"), n
, shift
->ts
.kind
);
774 f
->value
.function
.name
775 = gfc_get_string (PREFIX ("cshift%d_%d_char%d"), n
, shift
->ts
.kind
,
779 f
->value
.function
.name
780 = gfc_get_string (PREFIX ("cshift%d_%d"), n
, shift
->ts
.kind
);
785 gfc_resolve_ctime (gfc_expr
*f
, gfc_expr
*time
)
790 f
->ts
.type
= BT_CHARACTER
;
791 f
->ts
.kind
= gfc_default_character_kind
;
793 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
794 if (time
->ts
.kind
!= 8)
796 ts
.type
= BT_INTEGER
;
800 gfc_convert_type (time
, &ts
, 2);
803 f
->value
.function
.name
= gfc_get_string (PREFIX ("ctime"));
808 gfc_resolve_dble (gfc_expr
*f
, gfc_expr
*a
)
810 f
->ts
.type
= BT_REAL
;
811 f
->ts
.kind
= gfc_default_double_kind
;
812 f
->value
.function
.name
813 = gfc_get_string ("__dble_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
818 gfc_resolve_dim (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
820 f
->ts
.type
= a
->ts
.type
;
822 f
->ts
.kind
= gfc_kind_max (a
,p
);
824 f
->ts
.kind
= a
->ts
.kind
;
826 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
828 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
829 gfc_convert_type (p
, &a
->ts
, 2);
831 gfc_convert_type (a
, &p
->ts
, 2);
834 f
->value
.function
.name
835 = gfc_get_string ("__dim_%c%d", gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
840 gfc_resolve_dot_product (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b
)
844 temp
.expr_type
= EXPR_OP
;
845 gfc_clear_ts (&temp
.ts
);
846 temp
.value
.op
.op
= INTRINSIC_NONE
;
847 temp
.value
.op
.op1
= a
;
848 temp
.value
.op
.op2
= b
;
849 gfc_type_convert_binary (&temp
, 1);
851 f
->value
.function
.name
852 = gfc_get_string (PREFIX ("dot_product_%c%d"),
853 gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
858 gfc_resolve_dprod (gfc_expr
*f
, gfc_expr
*a ATTRIBUTE_UNUSED
,
859 gfc_expr
*b ATTRIBUTE_UNUSED
)
861 f
->ts
.kind
= gfc_default_double_kind
;
862 f
->ts
.type
= BT_REAL
;
863 f
->value
.function
.name
= gfc_get_string ("__dprod_r%d", f
->ts
.kind
);
868 gfc_resolve_dshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j ATTRIBUTE_UNUSED
,
869 gfc_expr
*shift ATTRIBUTE_UNUSED
)
872 if (f
->value
.function
.isym
->id
== GFC_ISYM_DSHIFTL
)
873 f
->value
.function
.name
= gfc_get_string ("dshiftl_i%d", f
->ts
.kind
);
874 else if (f
->value
.function
.isym
->id
== GFC_ISYM_DSHIFTR
)
875 f
->value
.function
.name
= gfc_get_string ("dshiftr_i%d", f
->ts
.kind
);
882 gfc_resolve_eoshift (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*shift
,
883 gfc_expr
*boundary
, gfc_expr
*dim
)
887 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
888 gfc_resolve_substring_charlen (array
);
891 f
->rank
= array
->rank
;
892 f
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
897 if (boundary
&& boundary
->rank
> 0)
900 /* If dim kind is greater than default integer we need to use the larger. */
901 m
= gfc_default_integer_kind
;
903 m
= m
< dim
->ts
.kind
? dim
->ts
.kind
: m
;
905 /* Convert shift to at least m, so we don't need
906 kind=1 and kind=2 versions of the library functions. */
907 if (shift
->ts
.kind
< m
)
911 ts
.type
= BT_INTEGER
;
913 gfc_convert_type_warn (shift
, &ts
, 2, 0);
918 if (dim
->expr_type
!= EXPR_CONSTANT
&& dim
->symtree
!= NULL
919 && dim
->symtree
->n
.sym
->attr
.optional
)
921 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
922 dim
->representation
.length
= shift
->ts
.kind
;
926 gfc_resolve_dim_arg (dim
);
927 /* Convert dim to shift's kind to reduce variations. */
928 if (dim
->ts
.kind
!= shift
->ts
.kind
)
929 gfc_convert_type_warn (dim
, &shift
->ts
, 2, 0);
933 if (array
->ts
.type
== BT_CHARACTER
)
935 if (array
->ts
.kind
== gfc_default_character_kind
)
936 f
->value
.function
.name
937 = gfc_get_string (PREFIX ("eoshift%d_%d_char"), n
, shift
->ts
.kind
);
939 f
->value
.function
.name
940 = gfc_get_string (PREFIX ("eoshift%d_%d_char%d"), n
, shift
->ts
.kind
,
944 f
->value
.function
.name
945 = gfc_get_string (PREFIX ("eoshift%d_%d"), n
, shift
->ts
.kind
);
950 gfc_resolve_exp (gfc_expr
*f
, gfc_expr
*x
)
953 f
->value
.function
.name
954 = gfc_get_string ("__exp_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
959 gfc_resolve_exponent (gfc_expr
*f
, gfc_expr
*x
)
961 f
->ts
.type
= BT_INTEGER
;
962 f
->ts
.kind
= gfc_default_integer_kind
;
963 f
->value
.function
.name
= gfc_get_string ("__exponent_%d", x
->ts
.kind
);
967 /* Resolve the EXTENDS_TYPE_OF intrinsic function. */
970 gfc_resolve_extends_type_of (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*mo
)
975 /* Prevent double resolution. */
976 if (f
->ts
.type
== BT_LOGICAL
)
979 /* Replace the first argument with the corresponding vtab. */
980 if (a
->ts
.type
== BT_CLASS
)
981 gfc_add_vptr_component (a
);
982 else if (a
->ts
.type
== BT_DERIVED
)
986 vtab
= gfc_find_derived_vtab (a
->ts
.u
.derived
);
987 /* Clear the old expr. */
988 gfc_free_ref_list (a
->ref
);
990 memset (a
, '\0', sizeof (gfc_expr
));
991 /* Construct a new one. */
992 a
->expr_type
= EXPR_VARIABLE
;
993 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
999 /* Replace the second argument with the corresponding vtab. */
1000 if (mo
->ts
.type
== BT_CLASS
)
1001 gfc_add_vptr_component (mo
);
1002 else if (mo
->ts
.type
== BT_DERIVED
)
1006 vtab
= gfc_find_derived_vtab (mo
->ts
.u
.derived
);
1007 /* Clear the old expr. */
1009 gfc_free_ref_list (mo
->ref
);
1010 memset (mo
, '\0', sizeof (gfc_expr
));
1011 /* Construct a new one. */
1012 mo
->expr_type
= EXPR_VARIABLE
;
1013 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
1019 f
->ts
.type
= BT_LOGICAL
;
1022 f
->value
.function
.isym
->formal
->ts
= a
->ts
;
1023 f
->value
.function
.isym
->formal
->next
->ts
= mo
->ts
;
1025 /* Call library function. */
1026 f
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
1031 gfc_resolve_fdate (gfc_expr
*f
)
1033 f
->ts
.type
= BT_CHARACTER
;
1034 f
->ts
.kind
= gfc_default_character_kind
;
1035 f
->value
.function
.name
= gfc_get_string (PREFIX ("fdate"));
1040 gfc_resolve_floor (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1042 f
->ts
.type
= BT_INTEGER
;
1043 f
->ts
.kind
= (kind
== NULL
)
1044 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
1045 f
->value
.function
.name
1046 = gfc_get_string ("__floor%d_%c%d", f
->ts
.kind
,
1047 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1052 gfc_resolve_fnum (gfc_expr
*f
, gfc_expr
*n
)
1054 f
->ts
.type
= BT_INTEGER
;
1055 f
->ts
.kind
= gfc_default_integer_kind
;
1056 if (n
->ts
.kind
!= f
->ts
.kind
)
1057 gfc_convert_type (n
, &f
->ts
, 2);
1058 f
->value
.function
.name
= gfc_get_string (PREFIX ("fnum_i%d"), f
->ts
.kind
);
1063 gfc_resolve_fraction (gfc_expr
*f
, gfc_expr
*x
)
1066 f
->value
.function
.name
= gfc_get_string ("__fraction_%d", x
->ts
.kind
);
1070 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
1073 gfc_resolve_g77_math1 (gfc_expr
*f
, gfc_expr
*x
)
1076 f
->value
.function
.name
= gfc_get_string ("<intrinsic>");
1081 gfc_resolve_gamma (gfc_expr
*f
, gfc_expr
*x
)
1084 f
->value
.function
.name
1085 = gfc_get_string ("__tgamma_%d", x
->ts
.kind
);
1090 gfc_resolve_getcwd (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
1092 f
->ts
.type
= BT_INTEGER
;
1094 f
->value
.function
.name
= gfc_get_string (PREFIX ("getcwd"));
1099 gfc_resolve_getgid (gfc_expr
*f
)
1101 f
->ts
.type
= BT_INTEGER
;
1103 f
->value
.function
.name
= gfc_get_string (PREFIX ("getgid"));
1108 gfc_resolve_getpid (gfc_expr
*f
)
1110 f
->ts
.type
= BT_INTEGER
;
1112 f
->value
.function
.name
= gfc_get_string (PREFIX ("getpid"));
1117 gfc_resolve_getuid (gfc_expr
*f
)
1119 f
->ts
.type
= BT_INTEGER
;
1121 f
->value
.function
.name
= gfc_get_string (PREFIX ("getuid"));
1126 gfc_resolve_hostnm (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
1128 f
->ts
.type
= BT_INTEGER
;
1130 f
->value
.function
.name
= gfc_get_string (PREFIX ("hostnm"));
1135 gfc_resolve_hypot (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
1138 f
->value
.function
.name
= gfc_get_string ("__hypot_r%d", x
->ts
.kind
);
1143 gfc_resolve_iall (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
1145 resolve_transformational ("iall", f
, array
, dim
, mask
);
1150 gfc_resolve_iand (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1152 /* If the kind of i and j are different, then g77 cross-promoted the
1153 kinds to the largest value. The Fortran 95 standard requires the
1155 if (i
->ts
.kind
!= j
->ts
.kind
)
1157 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1158 gfc_convert_type (j
, &i
->ts
, 2);
1160 gfc_convert_type (i
, &j
->ts
, 2);
1164 f
->value
.function
.name
= gfc_get_string ("__iand_%d", i
->ts
.kind
);
1169 gfc_resolve_iany (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
1171 resolve_transformational ("iany", f
, array
, dim
, mask
);
1176 gfc_resolve_ibclr (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
)
1179 f
->value
.function
.name
= gfc_get_string ("__ibclr_%d", i
->ts
.kind
);
1184 gfc_resolve_ibits (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
,
1185 gfc_expr
*len ATTRIBUTE_UNUSED
)
1188 f
->value
.function
.name
= gfc_get_string ("__ibits_%d", i
->ts
.kind
);
1193 gfc_resolve_ibset (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
)
1196 f
->value
.function
.name
= gfc_get_string ("__ibset_%d", i
->ts
.kind
);
1201 gfc_resolve_iachar (gfc_expr
*f
, gfc_expr
*c
, gfc_expr
*kind
)
1203 f
->ts
.type
= BT_INTEGER
;
1205 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1207 f
->ts
.kind
= gfc_default_integer_kind
;
1208 f
->value
.function
.name
= gfc_get_string ("__ichar_%d", c
->ts
.kind
);
1213 gfc_resolve_ichar (gfc_expr
*f
, gfc_expr
*c
, gfc_expr
*kind
)
1215 f
->ts
.type
= BT_INTEGER
;
1217 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1219 f
->ts
.kind
= gfc_default_integer_kind
;
1220 f
->value
.function
.name
= gfc_get_string ("__ichar_%d", c
->ts
.kind
);
1225 gfc_resolve_idnint (gfc_expr
*f
, gfc_expr
*a
)
1227 gfc_resolve_nint (f
, a
, NULL
);
1232 gfc_resolve_ierrno (gfc_expr
*f
)
1234 f
->ts
.type
= BT_INTEGER
;
1235 f
->ts
.kind
= gfc_default_integer_kind
;
1236 f
->value
.function
.name
= gfc_get_string (PREFIX ("ierrno_i%d"), f
->ts
.kind
);
1241 gfc_resolve_ieor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1243 /* If the kind of i and j are different, then g77 cross-promoted the
1244 kinds to the largest value. The Fortran 95 standard requires the
1246 if (i
->ts
.kind
!= j
->ts
.kind
)
1248 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1249 gfc_convert_type (j
, &i
->ts
, 2);
1251 gfc_convert_type (i
, &j
->ts
, 2);
1255 f
->value
.function
.name
= gfc_get_string ("__ieor_%d", i
->ts
.kind
);
1260 gfc_resolve_ior (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1262 /* If the kind of i and j are different, then g77 cross-promoted the
1263 kinds to the largest value. The Fortran 95 standard requires the
1265 if (i
->ts
.kind
!= j
->ts
.kind
)
1267 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1268 gfc_convert_type (j
, &i
->ts
, 2);
1270 gfc_convert_type (i
, &j
->ts
, 2);
1274 f
->value
.function
.name
= gfc_get_string ("__ior_%d", i
->ts
.kind
);
1279 gfc_resolve_index_func (gfc_expr
*f
, gfc_actual_arglist
*a
)
1283 gfc_expr
*str
, *back
, *kind
;
1284 gfc_actual_arglist
*a_sub_str
, *a_back
, *a_kind
;
1286 if (f
->do_not_resolve_again
)
1289 a_sub_str
= a
->next
;
1290 a_back
= a_sub_str
->next
;
1291 a_kind
= a_back
->next
;
1294 back
= a_back
->expr
;
1295 kind
= a_kind
->expr
;
1297 f
->ts
.type
= BT_INTEGER
;
1299 f
->ts
.kind
= mpz_get_si ((kind
)->value
.integer
);
1301 f
->ts
.kind
= gfc_default_integer_kind
;
1303 if (back
&& back
->ts
.kind
!= gfc_default_integer_kind
)
1305 ts
.type
= BT_LOGICAL
;
1306 ts
.kind
= gfc_default_integer_kind
;
1307 ts
.u
.derived
= NULL
;
1309 gfc_convert_type (back
, &ts
, 2);
1312 f
->value
.function
.name
1313 = gfc_get_string ("__index_%d_i%d", str
->ts
.kind
, f
->ts
.kind
);
1315 f
->do_not_resolve_again
= 1;
1320 gfc_resolve_int (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1322 f
->ts
.type
= BT_INTEGER
;
1323 f
->ts
.kind
= (kind
== NULL
)
1324 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
1325 f
->value
.function
.name
1326 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1327 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1332 gfc_resolve_int2 (gfc_expr
*f
, gfc_expr
*a
)
1334 f
->ts
.type
= BT_INTEGER
;
1336 f
->value
.function
.name
1337 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1338 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1343 gfc_resolve_int8 (gfc_expr
*f
, gfc_expr
*a
)
1345 f
->ts
.type
= BT_INTEGER
;
1347 f
->value
.function
.name
1348 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1349 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1354 gfc_resolve_long (gfc_expr
*f
, gfc_expr
*a
)
1356 f
->ts
.type
= BT_INTEGER
;
1358 f
->value
.function
.name
1359 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1360 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1365 gfc_resolve_iparity (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
1367 resolve_transformational ("iparity", f
, array
, dim
, mask
);
1372 gfc_resolve_isatty (gfc_expr
*f
, gfc_expr
*u
)
1377 f
->ts
.type
= BT_LOGICAL
;
1378 f
->ts
.kind
= gfc_default_integer_kind
;
1379 if (u
->ts
.kind
!= gfc_c_int_kind
)
1381 ts
.type
= BT_INTEGER
;
1382 ts
.kind
= gfc_c_int_kind
;
1383 ts
.u
.derived
= NULL
;
1385 gfc_convert_type (u
, &ts
, 2);
1388 f
->value
.function
.name
= gfc_get_string (PREFIX ("isatty_l%d"), f
->ts
.kind
);
1393 gfc_resolve_is_contiguous (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
)
1395 f
->ts
.type
= BT_LOGICAL
;
1396 f
->ts
.kind
= gfc_default_logical_kind
;
1397 f
->value
.function
.name
= gfc_get_string ("__is_contiguous");
1402 gfc_resolve_ishft (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1405 f
->value
.function
.name
1406 = gfc_get_string ("__ishft_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1411 gfc_resolve_rshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1414 f
->value
.function
.name
1415 = gfc_get_string ("__rshift_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1420 gfc_resolve_lshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1423 f
->value
.function
.name
1424 = gfc_get_string ("__lshift_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1429 gfc_resolve_ishftc (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
1433 s_kind
= (size
== NULL
) ? gfc_default_integer_kind
: size
->ts
.kind
;
1436 f
->value
.function
.name
1437 = gfc_get_string ("__ishftc_%d_%d_%d", i
->ts
.kind
, shift
->ts
.kind
, s_kind
);
1442 gfc_resolve_lbound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
1444 resolve_bound (f
, array
, dim
, kind
, "__lbound", false);
1449 gfc_resolve_lcobound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
1451 resolve_bound (f
, array
, dim
, kind
, "__lcobound", true);
1456 gfc_resolve_len (gfc_expr
*f
, gfc_expr
*string
, gfc_expr
*kind
)
1458 f
->ts
.type
= BT_INTEGER
;
1460 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1462 f
->ts
.kind
= gfc_default_integer_kind
;
1463 f
->value
.function
.name
1464 = gfc_get_string ("__len_%d_i%d", string
->ts
.kind
,
1465 gfc_default_integer_kind
);
1470 gfc_resolve_len_trim (gfc_expr
*f
, gfc_expr
*string
, gfc_expr
*kind
)
1472 f
->ts
.type
= BT_INTEGER
;
1474 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1476 f
->ts
.kind
= gfc_default_integer_kind
;
1477 f
->value
.function
.name
= gfc_get_string ("__len_trim%d", string
->ts
.kind
);
1482 gfc_resolve_lgamma (gfc_expr
*f
, gfc_expr
*x
)
1485 f
->value
.function
.name
1486 = gfc_get_string ("__lgamma_%d", x
->ts
.kind
);
1491 gfc_resolve_link (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
1492 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
1494 f
->ts
.type
= BT_INTEGER
;
1495 f
->ts
.kind
= gfc_default_integer_kind
;
1496 f
->value
.function
.name
= gfc_get_string (PREFIX ("link_i%d"), f
->ts
.kind
);
1501 gfc_resolve_loc (gfc_expr
*f
, gfc_expr
*x
)
1503 f
->ts
.type
= BT_INTEGER
;
1504 f
->ts
.kind
= gfc_index_integer_kind
;
1505 f
->value
.function
.name
= gfc_get_string ("__loc_%d", x
->ts
.kind
);
1510 gfc_resolve_log (gfc_expr
*f
, gfc_expr
*x
)
1513 f
->value
.function
.name
1514 = gfc_get_string ("__log_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1519 gfc_resolve_log10 (gfc_expr
*f
, gfc_expr
*x
)
1522 f
->value
.function
.name
1523 = gfc_get_string ("__log10_%c%d", gfc_type_letter (x
->ts
.type
),
1529 gfc_resolve_logical (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1531 f
->ts
.type
= BT_LOGICAL
;
1532 f
->ts
.kind
= (kind
== NULL
)
1533 ? gfc_default_logical_kind
: mpz_get_si (kind
->value
.integer
);
1536 f
->value
.function
.name
1537 = gfc_get_string ("__logical_%d_%c%d", f
->ts
.kind
,
1538 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1543 gfc_resolve_matmul (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b
)
1547 if (a
->ts
.type
== BT_LOGICAL
&& b
->ts
.type
== BT_LOGICAL
)
1549 f
->ts
.type
= BT_LOGICAL
;
1550 f
->ts
.kind
= gfc_default_logical_kind
;
1554 temp
.expr_type
= EXPR_OP
;
1555 gfc_clear_ts (&temp
.ts
);
1556 temp
.value
.op
.op
= INTRINSIC_NONE
;
1557 temp
.value
.op
.op1
= a
;
1558 temp
.value
.op
.op2
= b
;
1559 gfc_type_convert_binary (&temp
, 1);
1563 f
->rank
= (a
->rank
== 2 && b
->rank
== 2) ? 2 : 1;
1565 if (a
->rank
== 2 && b
->rank
== 2)
1567 if (a
->shape
&& b
->shape
)
1569 f
->shape
= gfc_get_shape (f
->rank
);
1570 mpz_init_set (f
->shape
[0], a
->shape
[0]);
1571 mpz_init_set (f
->shape
[1], b
->shape
[1]);
1574 else if (a
->rank
== 1)
1578 f
->shape
= gfc_get_shape (f
->rank
);
1579 mpz_init_set (f
->shape
[0], b
->shape
[1]);
1584 /* b->rank == 1 and a->rank == 2 here, all other cases have
1585 been caught in check.c. */
1588 f
->shape
= gfc_get_shape (f
->rank
);
1589 mpz_init_set (f
->shape
[0], a
->shape
[0]);
1593 f
->value
.function
.name
1594 = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f
->ts
.type
),
1600 gfc_resolve_minmax (const char *name
, gfc_expr
*f
, gfc_actual_arglist
*args
)
1602 gfc_actual_arglist
*a
;
1604 f
->ts
.type
= args
->expr
->ts
.type
;
1605 f
->ts
.kind
= args
->expr
->ts
.kind
;
1606 /* Find the largest type kind. */
1607 for (a
= args
->next
; a
; a
= a
->next
)
1609 if (a
->expr
->ts
.kind
> f
->ts
.kind
)
1610 f
->ts
.kind
= a
->expr
->ts
.kind
;
1613 /* Convert all parameters to the required kind. */
1614 for (a
= args
; a
; a
= a
->next
)
1616 if (a
->expr
->ts
.kind
!= f
->ts
.kind
)
1617 gfc_convert_type (a
->expr
, &f
->ts
, 2);
1620 f
->value
.function
.name
1621 = gfc_get_string (name
, gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
1626 gfc_resolve_max (gfc_expr
*f
, gfc_actual_arglist
*args
)
1628 gfc_resolve_minmax ("__max_%c%d", f
, args
);
1631 /* The smallest kind for which a minloc and maxloc implementation exists. */
1633 #define MINMAXLOC_MIN_KIND 4
1636 gfc_resolve_maxloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1637 gfc_expr
*mask
, gfc_expr
*kind
, gfc_expr
*back
)
1644 f
->ts
.type
= BT_INTEGER
;
1646 /* The library versions only exist for kinds 4, 8 and 16. For smaller kinds,
1647 we do a type conversion further down. */
1649 fkind
= mpz_get_si (kind
->value
.integer
);
1651 fkind
= gfc_default_integer_kind
;
1653 if (fkind
< MINMAXLOC_MIN_KIND
)
1654 f
->ts
.kind
= MINMAXLOC_MIN_KIND
;
1661 f
->shape
= gfc_get_shape (1);
1662 mpz_init_set_si (f
->shape
[0], array
->rank
);
1666 f
->rank
= array
->rank
- 1;
1667 gfc_resolve_dim_arg (dim
);
1668 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1670 idim
= (int) mpz_get_si (dim
->value
.integer
);
1671 f
->shape
= gfc_get_shape (f
->rank
);
1672 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1674 if (i
== (idim
- 1))
1676 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1683 if (mask
->rank
== 0)
1688 resolve_mask_arg (mask
);
1695 if (array
->ts
.type
!= BT_CHARACTER
|| f
->rank
!= 0)
1703 f
->value
.function
.name
1704 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name
, d_num
, f
->ts
.kind
,
1705 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1708 fkind
= mpz_get_si (kind
->value
.integer
);
1710 fkind
= gfc_default_integer_kind
;
1712 if (fkind
!= f
->ts
.kind
)
1717 ts
.type
= BT_INTEGER
;
1719 gfc_convert_type_warn (f
, &ts
, 2, 0);
1722 if (back
->ts
.kind
!= gfc_logical_4_kind
)
1726 ts
.type
= BT_LOGICAL
;
1727 ts
.kind
= gfc_logical_4_kind
;
1728 gfc_convert_type_warn (back
, &ts
, 2, 0);
1734 gfc_resolve_findloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*value
,
1735 gfc_expr
*dim
, gfc_expr
*mask
, gfc_expr
*kind
,
1743 /* See at the end of the function for why this is necessary. */
1745 if (f
->do_not_resolve_again
)
1748 f
->ts
.type
= BT_INTEGER
;
1750 /* We have a single library version, which uses index_type. */
1753 fkind
= mpz_get_si (kind
->value
.integer
);
1755 fkind
= gfc_default_integer_kind
;
1757 f
->ts
.kind
= gfc_index_integer_kind
;
1759 /* Convert value. If array is not LOGICAL and value is, we already
1760 issued an error earlier. */
1762 if ((array
->ts
.type
!= value
->ts
.type
&& value
->ts
.type
!= BT_LOGICAL
)
1763 || array
->ts
.kind
!= value
->ts
.kind
)
1764 gfc_convert_type_warn (value
, &array
->ts
, 2, 0);
1769 f
->shape
= gfc_get_shape (1);
1770 mpz_init_set_si (f
->shape
[0], array
->rank
);
1774 f
->rank
= array
->rank
- 1;
1775 gfc_resolve_dim_arg (dim
);
1776 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1778 idim
= (int) mpz_get_si (dim
->value
.integer
);
1779 f
->shape
= gfc_get_shape (f
->rank
);
1780 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1782 if (i
== (idim
- 1))
1784 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1791 if (mask
->rank
== 0)
1796 resolve_mask_arg (mask
);
1811 if (back
->ts
.kind
!= gfc_logical_4_kind
)
1815 ts
.type
= BT_LOGICAL
;
1816 ts
.kind
= gfc_logical_4_kind
;
1817 gfc_convert_type_warn (back
, &ts
, 2, 0);
1820 f
->value
.function
.name
1821 = gfc_get_string (PREFIX ("%s%d_%c%d"), name
, d_num
,
1822 gfc_type_letter (array
->ts
.type
, true), array
->ts
.kind
);
1824 /* We only have a single library function, so we need to convert
1825 here. If the function is resolved from within a convert
1826 function generated on a previous round of resolution, endless
1827 recursion could occur. Guard against that here. */
1829 if (f
->ts
.kind
!= fkind
)
1831 f
->do_not_resolve_again
= 1;
1835 ts
.type
= BT_INTEGER
;
1837 gfc_convert_type_warn (f
, &ts
, 2, 0);
1843 gfc_resolve_maxval (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1853 f
->rank
= array
->rank
- 1;
1854 gfc_resolve_dim_arg (dim
);
1856 if (f
->rank
&& array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1858 idim
= (int) mpz_get_si (dim
->value
.integer
);
1859 f
->shape
= gfc_get_shape (f
->rank
);
1860 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1862 if (i
== (idim
- 1))
1864 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1871 if (mask
->rank
== 0)
1876 resolve_mask_arg (mask
);
1881 if (array
->ts
.type
!= BT_CHARACTER
)
1882 f
->value
.function
.name
1883 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
1884 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1886 f
->value
.function
.name
1887 = gfc_get_string (PREFIX ("%s%d_%c%d"), name
, f
->rank
!= 0,
1888 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1893 gfc_resolve_mclock (gfc_expr
*f
)
1895 f
->ts
.type
= BT_INTEGER
;
1897 f
->value
.function
.name
= PREFIX ("mclock");
1902 gfc_resolve_mclock8 (gfc_expr
*f
)
1904 f
->ts
.type
= BT_INTEGER
;
1906 f
->value
.function
.name
= PREFIX ("mclock8");
1911 gfc_resolve_mask (gfc_expr
*f
, gfc_expr
*i ATTRIBUTE_UNUSED
,
1914 f
->ts
.type
= BT_INTEGER
;
1915 f
->ts
.kind
= kind
? mpz_get_si (kind
->value
.integer
)
1916 : gfc_default_integer_kind
;
1918 if (f
->value
.function
.isym
->id
== GFC_ISYM_MASKL
)
1919 f
->value
.function
.name
= gfc_get_string ("__maskl_i%d", f
->ts
.kind
);
1921 f
->value
.function
.name
= gfc_get_string ("__maskr_i%d", f
->ts
.kind
);
1926 gfc_resolve_merge (gfc_expr
*f
, gfc_expr
*tsource
,
1927 gfc_expr
*fsource ATTRIBUTE_UNUSED
,
1928 gfc_expr
*mask ATTRIBUTE_UNUSED
)
1930 if (tsource
->ts
.type
== BT_CHARACTER
&& tsource
->ref
)
1931 gfc_resolve_substring_charlen (tsource
);
1933 if (fsource
->ts
.type
== BT_CHARACTER
&& fsource
->ref
)
1934 gfc_resolve_substring_charlen (fsource
);
1936 if (tsource
->ts
.type
== BT_CHARACTER
)
1937 check_charlen_present (tsource
);
1939 f
->ts
= tsource
->ts
;
1940 f
->value
.function
.name
1941 = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource
->ts
.type
),
1947 gfc_resolve_merge_bits (gfc_expr
*f
, gfc_expr
*i
,
1948 gfc_expr
*j ATTRIBUTE_UNUSED
,
1949 gfc_expr
*mask ATTRIBUTE_UNUSED
)
1952 f
->value
.function
.name
= gfc_get_string ("__merge_bits_i%d", i
->ts
.kind
);
1957 gfc_resolve_min (gfc_expr
*f
, gfc_actual_arglist
*args
)
1959 gfc_resolve_minmax ("__min_%c%d", f
, args
);
1964 gfc_resolve_minloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1965 gfc_expr
*mask
, gfc_expr
*kind
, gfc_expr
*back
)
1972 f
->ts
.type
= BT_INTEGER
;
1974 /* The library versions only exist for kinds 4, 8 and 16. For smaller kinds,
1975 we do a type conversion further down. */
1977 fkind
= mpz_get_si (kind
->value
.integer
);
1979 fkind
= gfc_default_integer_kind
;
1981 if (fkind
< MINMAXLOC_MIN_KIND
)
1982 f
->ts
.kind
= MINMAXLOC_MIN_KIND
;
1989 f
->shape
= gfc_get_shape (1);
1990 mpz_init_set_si (f
->shape
[0], array
->rank
);
1994 f
->rank
= array
->rank
- 1;
1995 gfc_resolve_dim_arg (dim
);
1996 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1998 idim
= (int) mpz_get_si (dim
->value
.integer
);
1999 f
->shape
= gfc_get_shape (f
->rank
);
2000 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
2002 if (i
== (idim
- 1))
2004 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
2011 if (mask
->rank
== 0)
2016 resolve_mask_arg (mask
);
2023 if (array
->ts
.type
!= BT_CHARACTER
|| f
->rank
!= 0)
2031 f
->value
.function
.name
2032 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name
, d_num
, f
->ts
.kind
,
2033 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
2035 if (fkind
!= f
->ts
.kind
)
2040 ts
.type
= BT_INTEGER
;
2042 gfc_convert_type_warn (f
, &ts
, 2, 0);
2045 if (back
->ts
.kind
!= gfc_logical_4_kind
)
2049 ts
.type
= BT_LOGICAL
;
2050 ts
.kind
= gfc_logical_4_kind
;
2051 gfc_convert_type_warn (back
, &ts
, 2, 0);
2057 gfc_resolve_minval (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
2067 f
->rank
= array
->rank
- 1;
2068 gfc_resolve_dim_arg (dim
);
2070 if (f
->rank
&& array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
2072 idim
= (int) mpz_get_si (dim
->value
.integer
);
2073 f
->shape
= gfc_get_shape (f
->rank
);
2074 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
2076 if (i
== (idim
- 1))
2078 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
2085 if (mask
->rank
== 0)
2090 resolve_mask_arg (mask
);
2095 if (array
->ts
.type
!= BT_CHARACTER
)
2096 f
->value
.function
.name
2097 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
2098 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
2100 f
->value
.function
.name
2101 = gfc_get_string (PREFIX ("%s%d_%c%d"), name
, f
->rank
!= 0,
2102 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
2107 gfc_resolve_mod (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
2109 f
->ts
.type
= a
->ts
.type
;
2111 f
->ts
.kind
= gfc_kind_max (a
,p
);
2113 f
->ts
.kind
= a
->ts
.kind
;
2115 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
2117 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
2118 gfc_convert_type (p
, &a
->ts
, 2);
2120 gfc_convert_type (a
, &p
->ts
, 2);
2123 f
->value
.function
.name
2124 = gfc_get_string ("__mod_%c%d", gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
2129 gfc_resolve_modulo (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
2131 f
->ts
.type
= a
->ts
.type
;
2133 f
->ts
.kind
= gfc_kind_max (a
,p
);
2135 f
->ts
.kind
= a
->ts
.kind
;
2137 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
2139 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
2140 gfc_convert_type (p
, &a
->ts
, 2);
2142 gfc_convert_type (a
, &p
->ts
, 2);
2145 f
->value
.function
.name
2146 = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f
->ts
.type
),
2151 gfc_resolve_nearest (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
2153 if (p
->ts
.kind
!= a
->ts
.kind
)
2154 gfc_convert_type (p
, &a
->ts
, 2);
2157 f
->value
.function
.name
2158 = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a
->ts
.type
),
2163 gfc_resolve_nint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
2165 f
->ts
.type
= BT_INTEGER
;
2166 f
->ts
.kind
= (kind
== NULL
)
2167 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
2168 f
->value
.function
.name
2169 = gfc_get_string ("__nint_%d_%d", f
->ts
.kind
, a
->ts
.kind
);
2174 gfc_resolve_norm2 (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
)
2176 resolve_transformational ("norm2", f
, array
, dim
, NULL
);
2181 gfc_resolve_not (gfc_expr
*f
, gfc_expr
*i
)
2184 f
->value
.function
.name
= gfc_get_string ("__not_%d", i
->ts
.kind
);
2189 gfc_resolve_or (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
2191 f
->ts
.type
= i
->ts
.type
;
2192 f
->ts
.kind
= gfc_kind_max (i
, j
);
2194 if (i
->ts
.kind
!= j
->ts
.kind
)
2196 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
2197 gfc_convert_type (j
, &i
->ts
, 2);
2199 gfc_convert_type (i
, &j
->ts
, 2);
2202 f
->value
.function
.name
2203 = gfc_get_string ("__or_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
2208 gfc_resolve_pack (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*mask
,
2209 gfc_expr
*vector ATTRIBUTE_UNUSED
)
2211 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
2212 gfc_resolve_substring_charlen (array
);
2217 resolve_mask_arg (mask
);
2219 if (mask
->rank
!= 0)
2221 if (array
->ts
.type
== BT_CHARACTER
)
2222 f
->value
.function
.name
2223 = array
->ts
.kind
== 1 ? PREFIX ("pack_char")
2225 (PREFIX ("pack_char%d"),
2228 f
->value
.function
.name
= PREFIX ("pack");
2232 if (array
->ts
.type
== BT_CHARACTER
)
2233 f
->value
.function
.name
2234 = array
->ts
.kind
== 1 ? PREFIX ("pack_s_char")
2236 (PREFIX ("pack_s_char%d"),
2239 f
->value
.function
.name
= PREFIX ("pack_s");
2245 gfc_resolve_parity (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
)
2247 resolve_transformational ("parity", f
, array
, dim
, NULL
);
2252 gfc_resolve_product (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
2255 resolve_transformational ("product", f
, array
, dim
, mask
);
2260 gfc_resolve_rank (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
)
2262 f
->ts
.type
= BT_INTEGER
;
2263 f
->ts
.kind
= gfc_default_integer_kind
;
2264 f
->value
.function
.name
= gfc_get_string ("__rank");
2269 gfc_resolve_real (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
2271 f
->ts
.type
= BT_REAL
;
2274 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2276 f
->ts
.kind
= (a
->ts
.type
== BT_COMPLEX
)
2277 ? a
->ts
.kind
: gfc_default_real_kind
;
2279 f
->value
.function
.name
2280 = gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
2281 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2286 gfc_resolve_realpart (gfc_expr
*f
, gfc_expr
*a
)
2288 f
->ts
.type
= BT_REAL
;
2289 f
->ts
.kind
= a
->ts
.kind
;
2290 f
->value
.function
.name
2291 = gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
2292 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2297 gfc_resolve_rename (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
2298 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
2300 f
->ts
.type
= BT_INTEGER
;
2301 f
->ts
.kind
= gfc_default_integer_kind
;
2302 f
->value
.function
.name
= gfc_get_string (PREFIX ("rename_i%d"), f
->ts
.kind
);
2307 gfc_resolve_repeat (gfc_expr
*f
, gfc_expr
*string
,
2311 f
->ts
.type
= BT_CHARACTER
;
2312 f
->ts
.kind
= string
->ts
.kind
;
2313 f
->value
.function
.name
= gfc_get_string ("__repeat_%d", string
->ts
.kind
);
2315 /* If possible, generate a character length. */
2316 if (f
->ts
.u
.cl
== NULL
)
2317 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2320 if (string
->expr_type
== EXPR_CONSTANT
)
2322 tmp
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
2323 string
->value
.character
.length
);
2325 else if (string
->ts
.u
.cl
&& string
->ts
.u
.cl
->length
)
2327 tmp
= gfc_copy_expr (string
->ts
.u
.cl
->length
);
2331 f
->ts
.u
.cl
->length
= gfc_multiply (tmp
, gfc_copy_expr (ncopies
));
2336 gfc_resolve_reshape (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*shape
,
2337 gfc_expr
*pad ATTRIBUTE_UNUSED
,
2338 gfc_expr
*order ATTRIBUTE_UNUSED
)
2344 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
2345 gfc_resolve_substring_charlen (source
);
2349 gfc_array_size (shape
, &rank
);
2350 f
->rank
= mpz_get_si (rank
);
2352 switch (source
->ts
.type
)
2359 kind
= source
->ts
.kind
;
2373 if (source
->ts
.type
== BT_COMPLEX
|| source
->ts
.type
== BT_REAL
)
2374 f
->value
.function
.name
2375 = gfc_get_string (PREFIX ("reshape_%c%d"),
2376 gfc_type_letter (source
->ts
.type
),
2378 else if (source
->ts
.type
== BT_CHARACTER
)
2379 f
->value
.function
.name
= gfc_get_string (PREFIX ("reshape_char%d"),
2382 f
->value
.function
.name
2383 = gfc_get_string (PREFIX ("reshape_%d"), source
->ts
.kind
);
2387 f
->value
.function
.name
= (source
->ts
.type
== BT_CHARACTER
2388 ? PREFIX ("reshape_char") : PREFIX ("reshape"));
2392 if (shape
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (shape
))
2395 f
->shape
= gfc_get_shape (f
->rank
);
2396 c
= gfc_constructor_first (shape
->value
.constructor
);
2397 for (i
= 0; i
< f
->rank
; i
++)
2399 mpz_init_set (f
->shape
[i
], c
->expr
->value
.integer
);
2400 c
= gfc_constructor_next (c
);
2404 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
2405 so many runtime variations. */
2406 if (shape
->ts
.kind
!= gfc_index_integer_kind
)
2408 gfc_typespec ts
= shape
->ts
;
2409 ts
.kind
= gfc_index_integer_kind
;
2410 gfc_convert_type_warn (shape
, &ts
, 2, 0);
2412 if (order
&& order
->ts
.kind
!= gfc_index_integer_kind
)
2413 gfc_convert_type_warn (order
, &shape
->ts
, 2, 0);
2418 gfc_resolve_rrspacing (gfc_expr
*f
, gfc_expr
*x
)
2421 f
->value
.function
.name
= gfc_get_string ("__rrspacing_%d", x
->ts
.kind
);
2425 gfc_resolve_fe_runtime_error (gfc_code
*c
)
2428 gfc_actual_arglist
*a
;
2430 name
= gfc_get_string (PREFIX ("runtime_error"));
2432 for (a
= c
->ext
.actual
->next
; a
; a
= a
->next
)
2435 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2436 /* We set the backend_decl here because runtime_error is a
2437 variadic function and we would use the wrong calling
2438 convention otherwise. */
2439 c
->resolved_sym
->backend_decl
= gfor_fndecl_runtime_error
;
2443 gfc_resolve_scale (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*i ATTRIBUTE_UNUSED
)
2446 f
->value
.function
.name
= gfc_get_string ("__scale_%d", x
->ts
.kind
);
2451 gfc_resolve_scan (gfc_expr
*f
, gfc_expr
*string
,
2452 gfc_expr
*set ATTRIBUTE_UNUSED
,
2453 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2455 f
->ts
.type
= BT_INTEGER
;
2457 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2459 f
->ts
.kind
= gfc_default_integer_kind
;
2460 f
->value
.function
.name
= gfc_get_string ("__scan_%d", string
->ts
.kind
);
2465 gfc_resolve_secnds (gfc_expr
*t1
, gfc_expr
*t0
)
2468 t1
->value
.function
.name
= gfc_get_string (PREFIX ("secnds"));
2473 gfc_resolve_set_exponent (gfc_expr
*f
, gfc_expr
*x
,
2474 gfc_expr
*i ATTRIBUTE_UNUSED
)
2477 f
->value
.function
.name
= gfc_get_string ("__set_exponent_%d", x
->ts
.kind
);
2482 gfc_resolve_shape (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*kind
)
2484 f
->ts
.type
= BT_INTEGER
;
2487 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2489 f
->ts
.kind
= gfc_default_integer_kind
;
2492 if (array
->rank
!= -1)
2494 f
->shape
= gfc_get_shape (1);
2495 mpz_init_set_ui (f
->shape
[0], array
->rank
);
2498 f
->value
.function
.name
= gfc_get_string (PREFIX ("shape_%d"), f
->ts
.kind
);
2503 gfc_resolve_shift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift ATTRIBUTE_UNUSED
)
2506 if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTA
)
2507 f
->value
.function
.name
= gfc_get_string ("shifta_i%d", f
->ts
.kind
);
2508 else if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTL
)
2509 f
->value
.function
.name
= gfc_get_string ("shiftl_i%d", f
->ts
.kind
);
2510 else if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTR
)
2511 f
->value
.function
.name
= gfc_get_string ("shiftr_i%d", f
->ts
.kind
);
2518 gfc_resolve_sign (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b ATTRIBUTE_UNUSED
)
2521 f
->value
.function
.name
2522 = gfc_get_string ("__sign_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2527 gfc_resolve_signal (gfc_expr
*f
, gfc_expr
*number
, gfc_expr
*handler
)
2529 f
->ts
.type
= BT_INTEGER
;
2530 f
->ts
.kind
= gfc_c_int_kind
;
2532 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2533 if (handler
->ts
.type
== BT_INTEGER
)
2535 if (handler
->ts
.kind
!= gfc_c_int_kind
)
2536 gfc_convert_type (handler
, &f
->ts
, 2);
2537 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func_int"));
2540 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func"));
2542 if (number
->ts
.kind
!= gfc_c_int_kind
)
2543 gfc_convert_type (number
, &f
->ts
, 2);
2548 gfc_resolve_sin (gfc_expr
*f
, gfc_expr
*x
)
2551 f
->value
.function
.name
2552 = gfc_get_string ("__sin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2557 gfc_resolve_sinh (gfc_expr
*f
, gfc_expr
*x
)
2560 f
->value
.function
.name
2561 = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2566 gfc_resolve_size (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2567 gfc_expr
*dim ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2569 f
->ts
.type
= BT_INTEGER
;
2571 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2573 f
->ts
.kind
= gfc_default_integer_kind
;
2578 gfc_resolve_stride (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2579 gfc_expr
*dim ATTRIBUTE_UNUSED
)
2581 f
->ts
.type
= BT_INTEGER
;
2582 f
->ts
.kind
= gfc_index_integer_kind
;
2587 gfc_resolve_spacing (gfc_expr
*f
, gfc_expr
*x
)
2590 f
->value
.function
.name
= gfc_get_string ("__spacing_%d", x
->ts
.kind
);
2595 gfc_resolve_spread (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*dim
,
2598 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
2599 gfc_resolve_substring_charlen (source
);
2601 if (source
->ts
.type
== BT_CHARACTER
)
2602 check_charlen_present (source
);
2605 f
->rank
= source
->rank
+ 1;
2606 if (source
->rank
== 0)
2608 if (source
->ts
.type
== BT_CHARACTER
)
2609 f
->value
.function
.name
2610 = source
->ts
.kind
== 1 ? PREFIX ("spread_char_scalar")
2612 (PREFIX ("spread_char%d_scalar"),
2615 f
->value
.function
.name
= PREFIX ("spread_scalar");
2619 if (source
->ts
.type
== BT_CHARACTER
)
2620 f
->value
.function
.name
2621 = source
->ts
.kind
== 1 ? PREFIX ("spread_char")
2623 (PREFIX ("spread_char%d"),
2626 f
->value
.function
.name
= PREFIX ("spread");
2629 if (dim
&& gfc_is_constant_expr (dim
)
2630 && ncopies
&& gfc_is_constant_expr (ncopies
) && source
->shape
[0])
2633 idim
= mpz_get_ui (dim
->value
.integer
);
2634 f
->shape
= gfc_get_shape (f
->rank
);
2635 for (i
= 0; i
< (idim
- 1); i
++)
2636 mpz_init_set (f
->shape
[i
], source
->shape
[i
]);
2638 mpz_init_set (f
->shape
[idim
- 1], ncopies
->value
.integer
);
2640 for (i
= idim
; i
< f
->rank
; i
++)
2641 mpz_init_set (f
->shape
[i
], source
->shape
[i
-1]);
2645 gfc_resolve_dim_arg (dim
);
2646 gfc_resolve_index (ncopies
, 1);
2651 gfc_resolve_sqrt (gfc_expr
*f
, gfc_expr
*x
)
2654 f
->value
.function
.name
2655 = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2659 /* Resolve the g77 compatibility function STAT AND FSTAT. */
2662 gfc_resolve_stat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2663 gfc_expr
*a ATTRIBUTE_UNUSED
)
2665 f
->ts
.type
= BT_INTEGER
;
2666 f
->ts
.kind
= gfc_default_integer_kind
;
2667 f
->value
.function
.name
= gfc_get_string (PREFIX ("stat_i%d"), f
->ts
.kind
);
2672 gfc_resolve_lstat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2673 gfc_expr
*a ATTRIBUTE_UNUSED
)
2675 f
->ts
.type
= BT_INTEGER
;
2676 f
->ts
.kind
= gfc_default_integer_kind
;
2677 f
->value
.function
.name
= gfc_get_string (PREFIX ("lstat_i%d"), f
->ts
.kind
);
2682 gfc_resolve_fstat (gfc_expr
*f
, gfc_expr
*n
, gfc_expr
*a ATTRIBUTE_UNUSED
)
2684 f
->ts
.type
= BT_INTEGER
;
2685 f
->ts
.kind
= gfc_default_integer_kind
;
2686 if (n
->ts
.kind
!= f
->ts
.kind
)
2687 gfc_convert_type (n
, &f
->ts
, 2);
2689 f
->value
.function
.name
= gfc_get_string (PREFIX ("fstat_i%d"), f
->ts
.kind
);
2694 gfc_resolve_fgetc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2699 f
->ts
.type
= BT_INTEGER
;
2700 f
->ts
.kind
= gfc_c_int_kind
;
2701 if (u
->ts
.kind
!= gfc_c_int_kind
)
2703 ts
.type
= BT_INTEGER
;
2704 ts
.kind
= gfc_c_int_kind
;
2705 ts
.u
.derived
= NULL
;
2707 gfc_convert_type (u
, &ts
, 2);
2710 f
->value
.function
.name
= gfc_get_string (PREFIX ("fgetc"));
2715 gfc_resolve_fget (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2717 f
->ts
.type
= BT_INTEGER
;
2718 f
->ts
.kind
= gfc_c_int_kind
;
2719 f
->value
.function
.name
= gfc_get_string (PREFIX ("fget"));
2724 gfc_resolve_fputc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2729 f
->ts
.type
= BT_INTEGER
;
2730 f
->ts
.kind
= gfc_c_int_kind
;
2731 if (u
->ts
.kind
!= gfc_c_int_kind
)
2733 ts
.type
= BT_INTEGER
;
2734 ts
.kind
= gfc_c_int_kind
;
2735 ts
.u
.derived
= NULL
;
2737 gfc_convert_type (u
, &ts
, 2);
2740 f
->value
.function
.name
= gfc_get_string (PREFIX ("fputc"));
2745 gfc_resolve_fput (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2747 f
->ts
.type
= BT_INTEGER
;
2748 f
->ts
.kind
= gfc_c_int_kind
;
2749 f
->value
.function
.name
= gfc_get_string (PREFIX ("fput"));
2754 gfc_resolve_ftell (gfc_expr
*f
, gfc_expr
*u
)
2759 f
->ts
.type
= BT_INTEGER
;
2760 f
->ts
.kind
= gfc_intio_kind
;
2761 if (u
->ts
.kind
!= gfc_c_int_kind
)
2763 ts
.type
= BT_INTEGER
;
2764 ts
.kind
= gfc_c_int_kind
;
2765 ts
.u
.derived
= NULL
;
2767 gfc_convert_type (u
, &ts
, 2);
2770 f
->value
.function
.name
= gfc_get_string (PREFIX ("ftell"));
2775 gfc_resolve_storage_size (gfc_expr
*f
, gfc_expr
*a ATTRIBUTE_UNUSED
,
2778 f
->ts
.type
= BT_INTEGER
;
2780 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2782 f
->ts
.kind
= gfc_default_integer_kind
;
2787 gfc_resolve_sum (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2789 resolve_transformational ("sum", f
, array
, dim
, mask
);
2794 gfc_resolve_symlnk (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
2795 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
2797 f
->ts
.type
= BT_INTEGER
;
2798 f
->ts
.kind
= gfc_default_integer_kind
;
2799 f
->value
.function
.name
= gfc_get_string (PREFIX ("symlnk_i%d"), f
->ts
.kind
);
2803 /* Resolve the g77 compatibility function SYSTEM. */
2806 gfc_resolve_system (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
2808 f
->ts
.type
= BT_INTEGER
;
2810 f
->value
.function
.name
= gfc_get_string (PREFIX ("system"));
2815 gfc_resolve_tan (gfc_expr
*f
, gfc_expr
*x
)
2818 f
->value
.function
.name
2819 = gfc_get_string ("__tan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2824 gfc_resolve_tanh (gfc_expr
*f
, gfc_expr
*x
)
2827 f
->value
.function
.name
2828 = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2832 /* Resolve failed_images (team, kind). */
2835 gfc_resolve_failed_images (gfc_expr
*f
, gfc_expr
*team ATTRIBUTE_UNUSED
,
2838 static char failed_images
[] = "_gfortran_caf_failed_images";
2840 f
->ts
.type
= BT_INTEGER
;
2842 f
->ts
.kind
= gfc_default_integer_kind
;
2844 gfc_extract_int (kind
, &f
->ts
.kind
);
2845 f
->value
.function
.name
= failed_images
;
2849 /* Resolve image_status (image, team). */
2852 gfc_resolve_image_status (gfc_expr
*f
, gfc_expr
*image ATTRIBUTE_UNUSED
,
2853 gfc_expr
*team ATTRIBUTE_UNUSED
)
2855 static char image_status
[] = "_gfortran_caf_image_status";
2856 f
->ts
.type
= BT_INTEGER
;
2857 f
->ts
.kind
= gfc_default_integer_kind
;
2858 f
->value
.function
.name
= image_status
;
2862 /* Resolve get_team (). */
2865 gfc_resolve_get_team (gfc_expr
*f
, gfc_expr
*level ATTRIBUTE_UNUSED
)
2867 static char get_team
[] = "_gfortran_caf_get_team";
2869 f
->ts
.type
= BT_INTEGER
;
2870 f
->ts
.kind
= gfc_default_integer_kind
;
2871 f
->value
.function
.name
= get_team
;
2875 /* Resolve image_index (...). */
2878 gfc_resolve_image_index (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2879 gfc_expr
*sub ATTRIBUTE_UNUSED
)
2881 static char image_index
[] = "__image_index";
2882 f
->ts
.type
= BT_INTEGER
;
2883 f
->ts
.kind
= gfc_default_integer_kind
;
2884 f
->value
.function
.name
= image_index
;
2888 /* Resolve stopped_images (team, kind). */
2891 gfc_resolve_stopped_images (gfc_expr
*f
, gfc_expr
*team ATTRIBUTE_UNUSED
,
2894 static char stopped_images
[] = "_gfortran_caf_stopped_images";
2896 f
->ts
.type
= BT_INTEGER
;
2898 f
->ts
.kind
= gfc_default_integer_kind
;
2900 gfc_extract_int (kind
, &f
->ts
.kind
);
2901 f
->value
.function
.name
= stopped_images
;
2905 /* Resolve team_number (team). */
2908 gfc_resolve_team_number (gfc_expr
*f
, gfc_expr
*team ATTRIBUTE_UNUSED
)
2910 static char team_number
[] = "_gfortran_caf_team_number";
2912 f
->ts
.type
= BT_INTEGER
;
2913 f
->ts
.kind
= gfc_default_integer_kind
;
2914 f
->value
.function
.name
= team_number
;
2919 gfc_resolve_this_image (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
2920 gfc_expr
*distance ATTRIBUTE_UNUSED
)
2922 static char this_image
[] = "__this_image";
2923 if (array
&& gfc_is_coarray (array
))
2924 resolve_bound (f
, array
, dim
, NULL
, "__this_image", true);
2927 f
->ts
.type
= BT_INTEGER
;
2928 f
->ts
.kind
= gfc_default_integer_kind
;
2929 f
->value
.function
.name
= this_image
;
2935 gfc_resolve_time (gfc_expr
*f
)
2937 f
->ts
.type
= BT_INTEGER
;
2939 f
->value
.function
.name
= gfc_get_string (PREFIX ("time_func"));
2944 gfc_resolve_time8 (gfc_expr
*f
)
2946 f
->ts
.type
= BT_INTEGER
;
2948 f
->value
.function
.name
= gfc_get_string (PREFIX ("time8_func"));
2953 gfc_resolve_transfer (gfc_expr
*f
, gfc_expr
*source ATTRIBUTE_UNUSED
,
2954 gfc_expr
*mold
, gfc_expr
*size
)
2956 /* TODO: Make this do something meaningful. */
2957 static char transfer0
[] = "__transfer0", transfer1
[] = "__transfer1";
2959 if (mold
->ts
.type
== BT_CHARACTER
2960 && !mold
->ts
.u
.cl
->length
2961 && gfc_is_constant_expr (mold
))
2964 if (mold
->expr_type
== EXPR_CONSTANT
)
2966 len
= mold
->value
.character
.length
;
2967 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
2972 gfc_constructor
*c
= gfc_constructor_first (mold
->value
.constructor
);
2973 len
= c
->expr
->value
.character
.length
;
2974 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
2981 if (size
== NULL
&& mold
->rank
== 0)
2984 f
->value
.function
.name
= transfer0
;
2989 f
->value
.function
.name
= transfer1
;
2990 if (size
&& gfc_is_constant_expr (size
))
2992 f
->shape
= gfc_get_shape (1);
2993 mpz_init_set (f
->shape
[0], size
->value
.integer
);
3000 gfc_resolve_transpose (gfc_expr
*f
, gfc_expr
*matrix
)
3003 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ref
)
3004 gfc_resolve_substring_charlen (matrix
);
3010 f
->shape
= gfc_get_shape (2);
3011 mpz_init_set (f
->shape
[0], matrix
->shape
[1]);
3012 mpz_init_set (f
->shape
[1], matrix
->shape
[0]);
3015 switch (matrix
->ts
.kind
)
3021 switch (matrix
->ts
.type
)
3025 f
->value
.function
.name
3026 = gfc_get_string (PREFIX ("transpose_%c%d"),
3027 gfc_type_letter (matrix
->ts
.type
),
3033 /* Use the integer routines for real and logical cases. This
3034 assumes they all have the same alignment requirements. */
3035 f
->value
.function
.name
3036 = gfc_get_string (PREFIX ("transpose_i%d"), matrix
->ts
.kind
);
3040 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ts
.kind
== 4)
3041 f
->value
.function
.name
= PREFIX ("transpose_char4");
3043 f
->value
.function
.name
= PREFIX ("transpose");
3049 f
->value
.function
.name
= (matrix
->ts
.type
== BT_CHARACTER
3050 ? PREFIX ("transpose_char")
3051 : PREFIX ("transpose"));
3058 gfc_resolve_trim (gfc_expr
*f
, gfc_expr
*string
)
3060 f
->ts
.type
= BT_CHARACTER
;
3061 f
->ts
.kind
= string
->ts
.kind
;
3062 f
->value
.function
.name
= gfc_get_string ("__trim_%d", string
->ts
.kind
);
3066 /* Resolve the degree trignometric functions. This amounts to setting
3067 the function return type-spec from its argument and building a
3068 library function names of the form _gfortran_sind_r4. */
3071 gfc_resolve_trigd (gfc_expr
*f
, gfc_expr
*x
)
3074 f
->value
.function
.name
3075 = gfc_get_string (PREFIX ("%s_%c%d"), f
->value
.function
.isym
->name
,
3076 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
3081 gfc_resolve_trigd2 (gfc_expr
*f
, gfc_expr
*y
, gfc_expr
*x
)
3084 f
->value
.function
.name
3085 = gfc_get_string (PREFIX ("%s_%d"), f
->value
.function
.isym
->name
,
3091 gfc_resolve_ubound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3093 resolve_bound (f
, array
, dim
, kind
, "__ubound", false);
3098 gfc_resolve_ucobound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3100 resolve_bound (f
, array
, dim
, kind
, "__ucobound", true);
3104 /* Resolve the g77 compatibility function UMASK. */
3107 gfc_resolve_umask (gfc_expr
*f
, gfc_expr
*n
)
3109 f
->ts
.type
= BT_INTEGER
;
3110 f
->ts
.kind
= n
->ts
.kind
;
3111 f
->value
.function
.name
= gfc_get_string (PREFIX ("umask_i%d"), n
->ts
.kind
);
3115 /* Resolve the g77 compatibility function UNLINK. */
3118 gfc_resolve_unlink (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
3120 f
->ts
.type
= BT_INTEGER
;
3122 f
->value
.function
.name
= gfc_get_string (PREFIX ("unlink"));
3127 gfc_resolve_ttynam (gfc_expr
*f
, gfc_expr
*unit
)
3132 f
->ts
.type
= BT_CHARACTER
;
3133 f
->ts
.kind
= gfc_default_character_kind
;
3135 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3137 ts
.type
= BT_INTEGER
;
3138 ts
.kind
= gfc_c_int_kind
;
3139 ts
.u
.derived
= NULL
;
3141 gfc_convert_type (unit
, &ts
, 2);
3144 f
->value
.function
.name
= gfc_get_string (PREFIX ("ttynam"));
3149 gfc_resolve_unpack (gfc_expr
*f
, gfc_expr
*vector
, gfc_expr
*mask
,
3150 gfc_expr
*field ATTRIBUTE_UNUSED
)
3152 if (vector
->ts
.type
== BT_CHARACTER
&& vector
->ref
)
3153 gfc_resolve_substring_charlen (vector
);
3156 f
->rank
= mask
->rank
;
3157 resolve_mask_arg (mask
);
3159 if (vector
->ts
.type
== BT_CHARACTER
)
3161 if (vector
->ts
.kind
== 1)
3162 f
->value
.function
.name
3163 = gfc_get_string (PREFIX ("unpack%d_char"), field
->rank
> 0 ? 1 : 0);
3165 f
->value
.function
.name
3166 = gfc_get_string (PREFIX ("unpack%d_char%d"),
3167 field
->rank
> 0 ? 1 : 0, vector
->ts
.kind
);
3170 f
->value
.function
.name
3171 = gfc_get_string (PREFIX ("unpack%d"), field
->rank
> 0 ? 1 : 0);
3176 gfc_resolve_verify (gfc_expr
*f
, gfc_expr
*string
,
3177 gfc_expr
*set ATTRIBUTE_UNUSED
,
3178 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
3180 f
->ts
.type
= BT_INTEGER
;
3182 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
3184 f
->ts
.kind
= gfc_default_integer_kind
;
3185 f
->value
.function
.name
= gfc_get_string ("__verify_%d", string
->ts
.kind
);
3190 gfc_resolve_xor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
3192 f
->ts
.type
= i
->ts
.type
;
3193 f
->ts
.kind
= gfc_kind_max (i
, j
);
3195 if (i
->ts
.kind
!= j
->ts
.kind
)
3197 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
3198 gfc_convert_type (j
, &i
->ts
, 2);
3200 gfc_convert_type (i
, &j
->ts
, 2);
3203 f
->value
.function
.name
3204 = gfc_get_string ("__xor_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
3208 /* Intrinsic subroutine resolution. */
3211 gfc_resolve_alarm_sub (gfc_code
*c
)
3214 gfc_expr
*seconds
, *handler
;
3218 seconds
= c
->ext
.actual
->expr
;
3219 handler
= c
->ext
.actual
->next
->expr
;
3220 ts
.type
= BT_INTEGER
;
3221 ts
.kind
= gfc_c_int_kind
;
3223 /* handler can be either BT_INTEGER or BT_PROCEDURE.
3224 In all cases, the status argument is of default integer kind
3225 (enforced in check.c) so that the function suffix is fixed. */
3226 if (handler
->ts
.type
== BT_INTEGER
)
3228 if (handler
->ts
.kind
!= gfc_c_int_kind
)
3229 gfc_convert_type (handler
, &ts
, 2);
3230 name
= gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
3231 gfc_default_integer_kind
);
3234 name
= gfc_get_string (PREFIX ("alarm_sub_i%d"),
3235 gfc_default_integer_kind
);
3237 if (seconds
->ts
.kind
!= gfc_c_int_kind
)
3238 gfc_convert_type (seconds
, &ts
, 2);
3240 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3244 gfc_resolve_cpu_time (gfc_code
*c
)
3247 name
= gfc_get_string (PREFIX ("cpu_time_%d"), c
->ext
.actual
->expr
->ts
.kind
);
3248 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3252 /* Create a formal arglist based on an actual one and set the INTENTs given. */
3254 static gfc_formal_arglist
*
3255 create_formal_for_intents (gfc_actual_arglist
* actual
, const sym_intent
* ints
)
3257 gfc_formal_arglist
* head
;
3258 gfc_formal_arglist
* tail
;
3264 head
= tail
= gfc_get_formal_arglist ();
3265 for (i
= 0; actual
; actual
= actual
->next
, tail
= tail
->next
, ++i
)
3269 sym
= gfc_new_symbol ("dummyarg", NULL
);
3270 sym
->ts
= actual
->expr
->ts
;
3272 sym
->attr
.intent
= ints
[i
];
3276 tail
->next
= gfc_get_formal_arglist ();
3284 gfc_resolve_atomic_def (gfc_code
*c
)
3286 const char *name
= "atomic_define";
3287 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3292 gfc_resolve_atomic_ref (gfc_code
*c
)
3294 const char *name
= "atomic_ref";
3295 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3299 gfc_resolve_event_query (gfc_code
*c
)
3301 const char *name
= "event_query";
3302 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3306 gfc_resolve_mvbits (gfc_code
*c
)
3308 static const sym_intent INTENTS
[] = {INTENT_IN
, INTENT_IN
, INTENT_IN
,
3309 INTENT_INOUT
, INTENT_IN
};
3312 /* TO and FROM are guaranteed to have the same kind parameter. */
3313 name
= gfc_get_string (PREFIX ("mvbits_i%d"),
3314 c
->ext
.actual
->expr
->ts
.kind
);
3315 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3316 /* Mark as elemental subroutine as this does not happen automatically. */
3317 c
->resolved_sym
->attr
.elemental
= 1;
3319 /* Create a dummy formal arglist so the INTENTs are known later for purpose
3320 of creating temporaries. */
3321 c
->resolved_sym
->formal
= create_formal_for_intents (c
->ext
.actual
, INTENTS
);
3325 /* Set up the call to RANDOM_INIT. */
3328 gfc_resolve_random_init (gfc_code
*c
)
3331 name
= gfc_get_string (PREFIX ("random_init"));
3332 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3337 gfc_resolve_random_number (gfc_code
*c
)
3342 kind
= c
->ext
.actual
->expr
->ts
.kind
;
3343 if (c
->ext
.actual
->expr
->rank
== 0)
3344 name
= gfc_get_string (PREFIX ("random_r%d"), kind
);
3346 name
= gfc_get_string (PREFIX ("arandom_r%d"), kind
);
3348 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3353 gfc_resolve_random_seed (gfc_code
*c
)
3357 name
= gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind
);
3358 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3363 gfc_resolve_rename_sub (gfc_code
*c
)
3368 /* Find the type of status. If not present use default integer kind. */
3369 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3370 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3372 kind
= gfc_default_integer_kind
;
3374 name
= gfc_get_string (PREFIX ("rename_i%d_sub"), kind
);
3375 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3380 gfc_resolve_link_sub (gfc_code
*c
)
3385 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3386 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3388 kind
= gfc_default_integer_kind
;
3390 name
= gfc_get_string (PREFIX ("link_i%d_sub"), kind
);
3391 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3396 gfc_resolve_symlnk_sub (gfc_code
*c
)
3401 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3402 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3404 kind
= gfc_default_integer_kind
;
3406 name
= gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind
);
3407 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3411 /* G77 compatibility subroutines dtime() and etime(). */
3414 gfc_resolve_dtime_sub (gfc_code
*c
)
3417 name
= gfc_get_string (PREFIX ("dtime_sub"));
3418 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3422 gfc_resolve_etime_sub (gfc_code
*c
)
3425 name
= gfc_get_string (PREFIX ("etime_sub"));
3426 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3430 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
3433 gfc_resolve_itime (gfc_code
*c
)
3436 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
3437 gfc_default_integer_kind
));
3441 gfc_resolve_idate (gfc_code
*c
)
3444 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
3445 gfc_default_integer_kind
));
3449 gfc_resolve_ltime (gfc_code
*c
)
3452 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
3453 gfc_default_integer_kind
));
3457 gfc_resolve_gmtime (gfc_code
*c
)
3460 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
3461 gfc_default_integer_kind
));
3465 /* G77 compatibility subroutine second(). */
3468 gfc_resolve_second_sub (gfc_code
*c
)
3471 name
= gfc_get_string (PREFIX ("second_sub"));
3472 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3477 gfc_resolve_sleep_sub (gfc_code
*c
)
3482 if (c
->ext
.actual
->expr
!= NULL
)
3483 kind
= c
->ext
.actual
->expr
->ts
.kind
;
3485 kind
= gfc_default_integer_kind
;
3487 name
= gfc_get_string (PREFIX ("sleep_i%d_sub"), kind
);
3488 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3492 /* G77 compatibility function srand(). */
3495 gfc_resolve_srand (gfc_code
*c
)
3498 name
= gfc_get_string (PREFIX ("srand"));
3499 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3503 /* Resolve the getarg intrinsic subroutine. */
3506 gfc_resolve_getarg (gfc_code
*c
)
3510 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_default_integer_kind
)
3515 ts
.type
= BT_INTEGER
;
3516 ts
.kind
= gfc_default_integer_kind
;
3518 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3521 name
= gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind
);
3522 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3526 /* Resolve the getcwd intrinsic subroutine. */
3529 gfc_resolve_getcwd_sub (gfc_code
*c
)
3534 if (c
->ext
.actual
->next
->expr
!= NULL
)
3535 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3537 kind
= gfc_default_integer_kind
;
3539 name
= gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind
);
3540 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3544 /* Resolve the get_command intrinsic subroutine. */
3547 gfc_resolve_get_command (gfc_code
*c
)
3551 kind
= gfc_default_integer_kind
;
3552 name
= gfc_get_string (PREFIX ("get_command_i%d"), kind
);
3553 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3557 /* Resolve the get_command_argument intrinsic subroutine. */
3560 gfc_resolve_get_command_argument (gfc_code
*c
)
3564 kind
= gfc_default_integer_kind
;
3565 name
= gfc_get_string (PREFIX ("get_command_argument_i%d"), kind
);
3566 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3570 /* Resolve the get_environment_variable intrinsic subroutine. */
3573 gfc_resolve_get_environment_variable (gfc_code
*code
)
3577 kind
= gfc_default_integer_kind
;
3578 name
= gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind
);
3579 code
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3584 gfc_resolve_signal_sub (gfc_code
*c
)
3587 gfc_expr
*number
, *handler
, *status
;
3591 number
= c
->ext
.actual
->expr
;
3592 handler
= c
->ext
.actual
->next
->expr
;
3593 status
= c
->ext
.actual
->next
->next
->expr
;
3594 ts
.type
= BT_INTEGER
;
3595 ts
.kind
= gfc_c_int_kind
;
3597 /* handler can be either BT_INTEGER or BT_PROCEDURE */
3598 if (handler
->ts
.type
== BT_INTEGER
)
3600 if (handler
->ts
.kind
!= gfc_c_int_kind
)
3601 gfc_convert_type (handler
, &ts
, 2);
3602 name
= gfc_get_string (PREFIX ("signal_sub_int"));
3605 name
= gfc_get_string (PREFIX ("signal_sub"));
3607 if (number
->ts
.kind
!= gfc_c_int_kind
)
3608 gfc_convert_type (number
, &ts
, 2);
3609 if (status
!= NULL
&& status
->ts
.kind
!= gfc_c_int_kind
)
3610 gfc_convert_type (status
, &ts
, 2);
3612 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3616 /* Resolve the SYSTEM intrinsic subroutine. */
3619 gfc_resolve_system_sub (gfc_code
*c
)
3622 name
= gfc_get_string (PREFIX ("system_sub"));
3623 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3627 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
3630 gfc_resolve_system_clock (gfc_code
*c
)
3634 gfc_expr
*count
= c
->ext
.actual
->expr
;
3635 gfc_expr
*count_max
= c
->ext
.actual
->next
->next
->expr
;
3637 /* The INTEGER(8) version has higher precision, it is used if both COUNT
3638 and COUNT_MAX can hold 64-bit values, or are absent. */
3639 if ((!count
|| count
->ts
.kind
>= 8)
3640 && (!count_max
|| count_max
->ts
.kind
>= 8))
3643 kind
= gfc_default_integer_kind
;
3645 name
= gfc_get_string (PREFIX ("system_clock_%d"), kind
);
3646 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3650 /* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine. */
3652 gfc_resolve_execute_command_line (gfc_code
*c
)
3655 name
= gfc_get_string (PREFIX ("execute_command_line_i%d"),
3656 gfc_default_integer_kind
);
3657 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3661 /* Resolve the EXIT intrinsic subroutine. */
3664 gfc_resolve_exit (gfc_code
*c
)
3671 /* The STATUS argument has to be of default kind. If it is not,
3673 ts
.type
= BT_INTEGER
;
3674 ts
.kind
= gfc_default_integer_kind
;
3675 n
= c
->ext
.actual
->expr
;
3676 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3677 gfc_convert_type (n
, &ts
, 2);
3679 name
= gfc_get_string (PREFIX ("exit_i%d"), ts
.kind
);
3680 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3684 /* Resolve the FLUSH intrinsic subroutine. */
3687 gfc_resolve_flush (gfc_code
*c
)
3694 ts
.type
= BT_INTEGER
;
3695 ts
.kind
= gfc_default_integer_kind
;
3696 n
= c
->ext
.actual
->expr
;
3697 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3698 gfc_convert_type (n
, &ts
, 2);
3700 name
= gfc_get_string (PREFIX ("flush_i%d"), ts
.kind
);
3701 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3706 gfc_resolve_ctime_sub (gfc_code
*c
)
3711 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3712 if (c
->ext
.actual
->expr
->ts
.kind
!= 8)
3714 ts
.type
= BT_INTEGER
;
3716 ts
.u
.derived
= NULL
;
3718 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3721 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3726 gfc_resolve_fdate_sub (gfc_code
*c
)
3728 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3733 gfc_resolve_gerror (gfc_code
*c
)
3735 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3740 gfc_resolve_getlog (gfc_code
*c
)
3742 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3747 gfc_resolve_hostnm_sub (gfc_code
*c
)
3752 if (c
->ext
.actual
->next
->expr
!= NULL
)
3753 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3755 kind
= gfc_default_integer_kind
;
3757 name
= gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind
);
3758 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3763 gfc_resolve_perror (gfc_code
*c
)
3765 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3768 /* Resolve the STAT and FSTAT intrinsic subroutines. */
3771 gfc_resolve_stat_sub (gfc_code
*c
)
3774 name
= gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind
);
3775 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3780 gfc_resolve_lstat_sub (gfc_code
*c
)
3783 name
= gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind
);
3784 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3789 gfc_resolve_fstat_sub (gfc_code
*c
)
3795 u
= c
->ext
.actual
->expr
;
3796 ts
= &c
->ext
.actual
->next
->expr
->ts
;
3797 if (u
->ts
.kind
!= ts
->kind
)
3798 gfc_convert_type (u
, ts
, 2);
3799 name
= gfc_get_string (PREFIX ("fstat_i%d_sub"), ts
->kind
);
3800 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3805 gfc_resolve_fgetc_sub (gfc_code
*c
)
3812 u
= c
->ext
.actual
->expr
;
3813 st
= c
->ext
.actual
->next
->next
->expr
;
3815 if (u
->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 (u
, &ts
, 2);
3825 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), st
->ts
.kind
);
3827 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind
);
3829 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3834 gfc_resolve_fget_sub (gfc_code
*c
)
3839 st
= c
->ext
.actual
->next
->expr
;
3841 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), st
->ts
.kind
);
3843 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind
);
3845 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3850 gfc_resolve_fputc_sub (gfc_code
*c
)
3857 u
= c
->ext
.actual
->expr
;
3858 st
= c
->ext
.actual
->next
->next
->expr
;
3860 if (u
->ts
.kind
!= gfc_c_int_kind
)
3862 ts
.type
= BT_INTEGER
;
3863 ts
.kind
= gfc_c_int_kind
;
3864 ts
.u
.derived
= NULL
;
3866 gfc_convert_type (u
, &ts
, 2);
3870 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), st
->ts
.kind
);
3872 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind
);
3874 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3879 gfc_resolve_fput_sub (gfc_code
*c
)
3884 st
= c
->ext
.actual
->next
->expr
;
3886 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), st
->ts
.kind
);
3888 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind
);
3890 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3895 gfc_resolve_fseek_sub (gfc_code
*c
)
3903 unit
= c
->ext
.actual
->expr
;
3904 offset
= c
->ext
.actual
->next
->expr
;
3905 whence
= c
->ext
.actual
->next
->next
->expr
;
3907 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3909 ts
.type
= BT_INTEGER
;
3910 ts
.kind
= gfc_c_int_kind
;
3911 ts
.u
.derived
= NULL
;
3913 gfc_convert_type (unit
, &ts
, 2);
3916 if (offset
->ts
.kind
!= gfc_intio_kind
)
3918 ts
.type
= BT_INTEGER
;
3919 ts
.kind
= gfc_intio_kind
;
3920 ts
.u
.derived
= NULL
;
3922 gfc_convert_type (offset
, &ts
, 2);
3925 if (whence
->ts
.kind
!= gfc_c_int_kind
)
3927 ts
.type
= BT_INTEGER
;
3928 ts
.kind
= gfc_c_int_kind
;
3929 ts
.u
.derived
= NULL
;
3931 gfc_convert_type (whence
, &ts
, 2);
3934 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
3938 gfc_resolve_ftell_sub (gfc_code
*c
)
3946 unit
= c
->ext
.actual
->expr
;
3947 offset
= c
->ext
.actual
->next
->expr
;
3949 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3951 ts
.type
= BT_INTEGER
;
3952 ts
.kind
= gfc_c_int_kind
;
3953 ts
.u
.derived
= NULL
;
3955 gfc_convert_type (unit
, &ts
, 2);
3958 name
= gfc_get_string (PREFIX ("ftell_i%d_sub"), offset
->ts
.kind
);
3959 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3964 gfc_resolve_ttynam_sub (gfc_code
*c
)
3969 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
3971 ts
.type
= BT_INTEGER
;
3972 ts
.kind
= gfc_c_int_kind
;
3973 ts
.u
.derived
= NULL
;
3975 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3978 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
3982 /* Resolve the UMASK intrinsic subroutine. */
3985 gfc_resolve_umask_sub (gfc_code
*c
)
3990 if (c
->ext
.actual
->next
->expr
!= NULL
)
3991 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3993 kind
= gfc_default_integer_kind
;
3995 name
= gfc_get_string (PREFIX ("umask_i%d_sub"), kind
);
3996 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3999 /* Resolve the UNLINK intrinsic subroutine. */
4002 gfc_resolve_unlink_sub (gfc_code
*c
)
4007 if (c
->ext
.actual
->next
->expr
!= NULL
)
4008 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
4010 kind
= gfc_default_integer_kind
;
4012 name
= gfc_get_string (PREFIX ("unlink_i%d_sub"), kind
);
4013 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);