1 /* Intrinsic function resolution.
2 Copyright (C) 2000-2015 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"
35 #include "stringpool.h"
37 #include "intrinsic.h"
38 #include "constructor.h"
41 /* Given printf-like arguments, return a stable version of the result string.
43 We already have a working, optimized string hashing table in the form of
44 the identifier table. Reusing this table is likely not to be wasted,
45 since if the function name makes it to the gimple output of the frontend,
46 we'll have to create the identifier anyway. */
49 gfc_get_string (const char *format
, ...)
55 va_start (ap
, format
);
56 vsnprintf (temp_name
, sizeof (temp_name
), format
, ap
);
58 temp_name
[sizeof (temp_name
) - 1] = 0;
60 ident
= get_identifier (temp_name
);
61 return IDENTIFIER_POINTER (ident
);
64 /* MERGE and SPREAD need to have source charlen's present for passing
65 to the result expression. */
67 check_charlen_present (gfc_expr
*source
)
69 if (source
->ts
.u
.cl
== NULL
)
70 source
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
72 if (source
->expr_type
== EXPR_CONSTANT
)
74 source
->ts
.u
.cl
->length
75 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
76 source
->value
.character
.length
);
79 else if (source
->expr_type
== EXPR_ARRAY
)
81 gfc_constructor
*c
= gfc_constructor_first (source
->value
.constructor
);
82 source
->ts
.u
.cl
->length
83 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
84 c
->expr
->value
.character
.length
);
88 /* Helper function for resolving the "mask" argument. */
91 resolve_mask_arg (gfc_expr
*mask
)
99 /* For the scalar case, coerce the mask to kind=4 unconditionally
100 (because this is the only kind we have a library function
103 if (mask
->ts
.kind
!= 4)
105 ts
.type
= BT_LOGICAL
;
107 gfc_convert_type (mask
, &ts
, 2);
112 /* In the library, we access the mask with a GFC_LOGICAL_1
113 argument. No need to waste memory if we are about to create
114 a temporary array. */
115 if (mask
->expr_type
== EXPR_OP
&& mask
->ts
.kind
!= 1)
117 ts
.type
= BT_LOGICAL
;
119 gfc_convert_type_warn (mask
, &ts
, 2, 0);
126 resolve_bound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
,
127 const char *name
, bool coarray
)
129 f
->ts
.type
= BT_INTEGER
;
131 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
133 f
->ts
.kind
= gfc_default_integer_kind
;
138 if (array
->rank
!= -1)
140 f
->shape
= gfc_get_shape (1);
141 mpz_init_set_ui (f
->shape
[0], coarray
? gfc_get_corank (array
)
146 f
->value
.function
.name
= gfc_get_string (name
);
151 resolve_transformational (const char *name
, gfc_expr
*f
, gfc_expr
*array
,
152 gfc_expr
*dim
, gfc_expr
*mask
)
165 resolve_mask_arg (mask
);
172 f
->rank
= array
->rank
- 1;
173 f
->shape
= gfc_copy_shape_excluding (array
->shape
, array
->rank
, dim
);
174 gfc_resolve_dim_arg (dim
);
177 f
->value
.function
.name
178 = gfc_get_string (PREFIX ("%s%s_%c%d"), prefix
, name
,
179 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
183 /********************** Resolution functions **********************/
187 gfc_resolve_abs (gfc_expr
*f
, gfc_expr
*a
)
190 if (f
->ts
.type
== BT_COMPLEX
)
191 f
->ts
.type
= BT_REAL
;
193 f
->value
.function
.name
194 = gfc_get_string ("__abs_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
199 gfc_resolve_access (gfc_expr
*f
, gfc_expr
*name ATTRIBUTE_UNUSED
,
200 gfc_expr
*mode ATTRIBUTE_UNUSED
)
202 f
->ts
.type
= BT_INTEGER
;
203 f
->ts
.kind
= gfc_c_int_kind
;
204 f
->value
.function
.name
= PREFIX ("access_func");
209 gfc_resolve_adjustl (gfc_expr
*f
, gfc_expr
*string
)
211 f
->ts
.type
= BT_CHARACTER
;
212 f
->ts
.kind
= string
->ts
.kind
;
214 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, string
->ts
.u
.cl
);
216 f
->value
.function
.name
= gfc_get_string ("__adjustl_s%d", f
->ts
.kind
);
221 gfc_resolve_adjustr (gfc_expr
*f
, gfc_expr
*string
)
223 f
->ts
.type
= BT_CHARACTER
;
224 f
->ts
.kind
= string
->ts
.kind
;
226 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, string
->ts
.u
.cl
);
228 f
->value
.function
.name
= gfc_get_string ("__adjustr_s%d", f
->ts
.kind
);
233 gfc_resolve_char_achar (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*kind
,
236 f
->ts
.type
= BT_CHARACTER
;
237 f
->ts
.kind
= (kind
== NULL
)
238 ? gfc_default_character_kind
: mpz_get_si (kind
->value
.integer
);
239 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
240 f
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
242 f
->value
.function
.name
= gfc_get_string (name
, f
->ts
.kind
,
243 gfc_type_letter (x
->ts
.type
),
249 gfc_resolve_achar (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*kind
)
251 gfc_resolve_char_achar (f
, x
, kind
, "__achar_%d_%c%d");
256 gfc_resolve_acos (gfc_expr
*f
, gfc_expr
*x
)
259 f
->value
.function
.name
260 = gfc_get_string ("__acos_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
265 gfc_resolve_acosh (gfc_expr
*f
, gfc_expr
*x
)
268 f
->value
.function
.name
269 = gfc_get_string ("__acosh_%c%d", gfc_type_letter (x
->ts
.type
),
275 gfc_resolve_aimag (gfc_expr
*f
, gfc_expr
*x
)
277 f
->ts
.type
= BT_REAL
;
278 f
->ts
.kind
= x
->ts
.kind
;
279 f
->value
.function
.name
280 = gfc_get_string ("__aimag_%c%d", gfc_type_letter (x
->ts
.type
),
286 gfc_resolve_and (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
288 f
->ts
.type
= i
->ts
.type
;
289 f
->ts
.kind
= gfc_kind_max (i
, j
);
291 if (i
->ts
.kind
!= j
->ts
.kind
)
293 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
294 gfc_convert_type (j
, &i
->ts
, 2);
296 gfc_convert_type (i
, &j
->ts
, 2);
299 f
->value
.function
.name
300 = gfc_get_string ("__and_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
305 gfc_resolve_aint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
310 f
->ts
.type
= a
->ts
.type
;
311 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
313 if (a
->ts
.kind
!= f
->ts
.kind
)
315 ts
.type
= f
->ts
.type
;
316 ts
.kind
= f
->ts
.kind
;
317 gfc_convert_type (a
, &ts
, 2);
319 /* The resolved name is only used for specific intrinsics where
320 the return kind is the same as the arg kind. */
321 f
->value
.function
.name
322 = gfc_get_string ("__aint_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
327 gfc_resolve_dint (gfc_expr
*f
, gfc_expr
*a
)
329 gfc_resolve_aint (f
, a
, NULL
);
334 gfc_resolve_all (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
)
340 gfc_resolve_dim_arg (dim
);
341 f
->rank
= mask
->rank
- 1;
342 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
345 f
->value
.function
.name
346 = gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask
->ts
.type
),
352 gfc_resolve_anint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
357 f
->ts
.type
= a
->ts
.type
;
358 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
360 if (a
->ts
.kind
!= f
->ts
.kind
)
362 ts
.type
= f
->ts
.type
;
363 ts
.kind
= f
->ts
.kind
;
364 gfc_convert_type (a
, &ts
, 2);
367 /* The resolved name is only used for specific intrinsics where
368 the return kind is the same as the arg kind. */
369 f
->value
.function
.name
370 = gfc_get_string ("__anint_%c%d", gfc_type_letter (a
->ts
.type
),
376 gfc_resolve_dnint (gfc_expr
*f
, gfc_expr
*a
)
378 gfc_resolve_anint (f
, a
, NULL
);
383 gfc_resolve_any (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
)
389 gfc_resolve_dim_arg (dim
);
390 f
->rank
= mask
->rank
- 1;
391 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
394 f
->value
.function
.name
395 = gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask
->ts
.type
),
401 gfc_resolve_asin (gfc_expr
*f
, gfc_expr
*x
)
404 f
->value
.function
.name
405 = gfc_get_string ("__asin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
409 gfc_resolve_asinh (gfc_expr
*f
, gfc_expr
*x
)
412 f
->value
.function
.name
413 = gfc_get_string ("__asinh_%c%d", gfc_type_letter (x
->ts
.type
),
418 gfc_resolve_atan (gfc_expr
*f
, gfc_expr
*x
)
421 f
->value
.function
.name
422 = gfc_get_string ("__atan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
426 gfc_resolve_atanh (gfc_expr
*f
, gfc_expr
*x
)
429 f
->value
.function
.name
430 = gfc_get_string ("__atanh_%c%d", gfc_type_letter (x
->ts
.type
),
435 gfc_resolve_atan2 (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
438 f
->value
.function
.name
439 = gfc_get_string ("__atan2_%c%d", gfc_type_letter (x
->ts
.type
),
444 /* Resolve the BESYN and BESJN intrinsics. */
447 gfc_resolve_besn (gfc_expr
*f
, gfc_expr
*n
, gfc_expr
*x
)
453 if (n
->ts
.kind
!= gfc_c_int_kind
)
455 ts
.type
= BT_INTEGER
;
456 ts
.kind
= gfc_c_int_kind
;
457 gfc_convert_type (n
, &ts
, 2);
459 f
->value
.function
.name
= gfc_get_string ("<intrinsic>");
464 gfc_resolve_bessel_n2 (gfc_expr
*f
, gfc_expr
*n1
, gfc_expr
*n2
, gfc_expr
*x
)
471 if (n1
->expr_type
== EXPR_CONSTANT
&& n2
->expr_type
== EXPR_CONSTANT
)
473 f
->shape
= gfc_get_shape (1);
474 mpz_init (f
->shape
[0]);
475 mpz_sub (f
->shape
[0], n2
->value
.integer
, n1
->value
.integer
);
476 mpz_add_ui (f
->shape
[0], f
->shape
[0], 1);
479 if (n1
->ts
.kind
!= gfc_c_int_kind
)
481 ts
.type
= BT_INTEGER
;
482 ts
.kind
= gfc_c_int_kind
;
483 gfc_convert_type (n1
, &ts
, 2);
486 if (n2
->ts
.kind
!= gfc_c_int_kind
)
488 ts
.type
= BT_INTEGER
;
489 ts
.kind
= gfc_c_int_kind
;
490 gfc_convert_type (n2
, &ts
, 2);
493 if (f
->value
.function
.isym
->id
== GFC_ISYM_JN2
)
494 f
->value
.function
.name
= gfc_get_string (PREFIX ("bessel_jn_r%d"),
497 f
->value
.function
.name
= gfc_get_string (PREFIX ("bessel_yn_r%d"),
503 gfc_resolve_btest (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos
)
505 f
->ts
.type
= BT_LOGICAL
;
506 f
->ts
.kind
= gfc_default_logical_kind
;
507 f
->value
.function
.name
508 = gfc_get_string ("__btest_%d_%d", i
->ts
.kind
, pos
->ts
.kind
);
513 gfc_resolve_c_loc (gfc_expr
*f
, gfc_expr
*x ATTRIBUTE_UNUSED
)
515 f
->ts
= f
->value
.function
.isym
->ts
;
520 gfc_resolve_c_funloc (gfc_expr
*f
, gfc_expr
*x ATTRIBUTE_UNUSED
)
522 f
->ts
= f
->value
.function
.isym
->ts
;
527 gfc_resolve_ceiling (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
529 f
->ts
.type
= BT_INTEGER
;
530 f
->ts
.kind
= (kind
== NULL
)
531 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
532 f
->value
.function
.name
533 = gfc_get_string ("__ceiling_%d_%c%d", f
->ts
.kind
,
534 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
539 gfc_resolve_char (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
541 gfc_resolve_char_achar (f
, a
, kind
, "__char_%d_%c%d");
546 gfc_resolve_chdir (gfc_expr
*f
, gfc_expr
*d ATTRIBUTE_UNUSED
)
548 f
->ts
.type
= BT_INTEGER
;
549 f
->ts
.kind
= gfc_default_integer_kind
;
550 f
->value
.function
.name
= gfc_get_string (PREFIX ("chdir_i%d"), f
->ts
.kind
);
555 gfc_resolve_chdir_sub (gfc_code
*c
)
560 if (c
->ext
.actual
->next
->expr
!= NULL
)
561 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
563 kind
= gfc_default_integer_kind
;
565 name
= gfc_get_string (PREFIX ("chdir_i%d_sub"), kind
);
566 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
571 gfc_resolve_chmod (gfc_expr
*f
, gfc_expr
*name ATTRIBUTE_UNUSED
,
572 gfc_expr
*mode ATTRIBUTE_UNUSED
)
574 f
->ts
.type
= BT_INTEGER
;
575 f
->ts
.kind
= gfc_c_int_kind
;
576 f
->value
.function
.name
= PREFIX ("chmod_func");
581 gfc_resolve_chmod_sub (gfc_code
*c
)
586 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
587 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
589 kind
= gfc_default_integer_kind
;
591 name
= gfc_get_string (PREFIX ("chmod_i%d_sub"), kind
);
592 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
597 gfc_resolve_cmplx (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*kind
)
599 f
->ts
.type
= BT_COMPLEX
;
600 f
->ts
.kind
= (kind
== NULL
)
601 ? gfc_default_real_kind
: mpz_get_si (kind
->value
.integer
);
604 f
->value
.function
.name
605 = gfc_get_string ("__cmplx0_%d_%c%d", f
->ts
.kind
,
606 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
608 f
->value
.function
.name
609 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f
->ts
.kind
,
610 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
,
611 gfc_type_letter (y
->ts
.type
), y
->ts
.kind
);
616 gfc_resolve_dcmplx (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
)
618 gfc_resolve_cmplx (f
, x
, y
, gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
619 gfc_default_double_kind
));
624 gfc_resolve_complex (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
)
628 if (x
->ts
.type
== BT_INTEGER
)
630 if (y
->ts
.type
== BT_INTEGER
)
631 kind
= gfc_default_real_kind
;
637 if (y
->ts
.type
== BT_REAL
)
638 kind
= (x
->ts
.kind
> y
->ts
.kind
) ? x
->ts
.kind
: y
->ts
.kind
;
643 f
->ts
.type
= BT_COMPLEX
;
645 f
->value
.function
.name
646 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f
->ts
.kind
,
647 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
,
648 gfc_type_letter (y
->ts
.type
), y
->ts
.kind
);
653 gfc_resolve_conjg (gfc_expr
*f
, gfc_expr
*x
)
656 f
->value
.function
.name
= gfc_get_string ("__conjg_%d", x
->ts
.kind
);
661 gfc_resolve_cos (gfc_expr
*f
, gfc_expr
*x
)
664 f
->value
.function
.name
665 = gfc_get_string ("__cos_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
670 gfc_resolve_cosh (gfc_expr
*f
, gfc_expr
*x
)
673 f
->value
.function
.name
674 = gfc_get_string ("__cosh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
679 gfc_resolve_count (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
681 f
->ts
.type
= BT_INTEGER
;
683 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
685 f
->ts
.kind
= gfc_default_integer_kind
;
689 f
->rank
= mask
->rank
- 1;
690 gfc_resolve_dim_arg (dim
);
691 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
694 resolve_mask_arg (mask
);
696 f
->value
.function
.name
697 = gfc_get_string (PREFIX ("count_%d_%c"), f
->ts
.kind
,
698 gfc_type_letter (mask
->ts
.type
));
703 gfc_resolve_cshift (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*shift
,
708 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
709 gfc_resolve_substring_charlen (array
);
712 f
->rank
= array
->rank
;
713 f
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
720 /* If dim kind is greater than default integer we need to use the larger. */
721 m
= gfc_default_integer_kind
;
723 m
= m
< dim
->ts
.kind
? dim
->ts
.kind
: m
;
725 /* Convert shift to at least m, so we don't need
726 kind=1 and kind=2 versions of the library functions. */
727 if (shift
->ts
.kind
< m
)
731 ts
.type
= BT_INTEGER
;
733 gfc_convert_type_warn (shift
, &ts
, 2, 0);
738 if (dim
->expr_type
!= EXPR_CONSTANT
&& dim
->symtree
!= NULL
739 && dim
->symtree
->n
.sym
->attr
.optional
)
741 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
742 dim
->representation
.length
= shift
->ts
.kind
;
746 gfc_resolve_dim_arg (dim
);
747 /* Convert dim to shift's kind to reduce variations. */
748 if (dim
->ts
.kind
!= shift
->ts
.kind
)
749 gfc_convert_type_warn (dim
, &shift
->ts
, 2, 0);
753 if (array
->ts
.type
== BT_CHARACTER
)
755 if (array
->ts
.kind
== gfc_default_character_kind
)
756 f
->value
.function
.name
757 = gfc_get_string (PREFIX ("cshift%d_%d_char"), n
, shift
->ts
.kind
);
759 f
->value
.function
.name
760 = gfc_get_string (PREFIX ("cshift%d_%d_char%d"), n
, shift
->ts
.kind
,
764 f
->value
.function
.name
765 = gfc_get_string (PREFIX ("cshift%d_%d"), n
, shift
->ts
.kind
);
770 gfc_resolve_ctime (gfc_expr
*f
, gfc_expr
*time
)
775 f
->ts
.type
= BT_CHARACTER
;
776 f
->ts
.kind
= gfc_default_character_kind
;
778 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
779 if (time
->ts
.kind
!= 8)
781 ts
.type
= BT_INTEGER
;
785 gfc_convert_type (time
, &ts
, 2);
788 f
->value
.function
.name
= gfc_get_string (PREFIX ("ctime"));
793 gfc_resolve_dble (gfc_expr
*f
, gfc_expr
*a
)
795 f
->ts
.type
= BT_REAL
;
796 f
->ts
.kind
= gfc_default_double_kind
;
797 f
->value
.function
.name
798 = gfc_get_string ("__dble_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
803 gfc_resolve_dim (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
805 f
->ts
.type
= a
->ts
.type
;
807 f
->ts
.kind
= gfc_kind_max (a
,p
);
809 f
->ts
.kind
= a
->ts
.kind
;
811 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
813 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
814 gfc_convert_type (p
, &a
->ts
, 2);
816 gfc_convert_type (a
, &p
->ts
, 2);
819 f
->value
.function
.name
820 = gfc_get_string ("__dim_%c%d", gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
825 gfc_resolve_dot_product (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b
)
829 temp
.expr_type
= EXPR_OP
;
830 gfc_clear_ts (&temp
.ts
);
831 temp
.value
.op
.op
= INTRINSIC_NONE
;
832 temp
.value
.op
.op1
= a
;
833 temp
.value
.op
.op2
= b
;
834 gfc_type_convert_binary (&temp
, 1);
836 f
->value
.function
.name
837 = gfc_get_string (PREFIX ("dot_product_%c%d"),
838 gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
843 gfc_resolve_dprod (gfc_expr
*f
, gfc_expr
*a ATTRIBUTE_UNUSED
,
844 gfc_expr
*b ATTRIBUTE_UNUSED
)
846 f
->ts
.kind
= gfc_default_double_kind
;
847 f
->ts
.type
= BT_REAL
;
848 f
->value
.function
.name
= gfc_get_string ("__dprod_r%d", f
->ts
.kind
);
853 gfc_resolve_dshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j ATTRIBUTE_UNUSED
,
854 gfc_expr
*shift ATTRIBUTE_UNUSED
)
857 if (f
->value
.function
.isym
->id
== GFC_ISYM_DSHIFTL
)
858 f
->value
.function
.name
= gfc_get_string ("dshiftl_i%d", f
->ts
.kind
);
859 else if (f
->value
.function
.isym
->id
== GFC_ISYM_DSHIFTR
)
860 f
->value
.function
.name
= gfc_get_string ("dshiftr_i%d", f
->ts
.kind
);
867 gfc_resolve_eoshift (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*shift
,
868 gfc_expr
*boundary
, gfc_expr
*dim
)
872 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
873 gfc_resolve_substring_charlen (array
);
876 f
->rank
= array
->rank
;
877 f
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
882 if (boundary
&& boundary
->rank
> 0)
885 /* If dim kind is greater than default integer we need to use the larger. */
886 m
= gfc_default_integer_kind
;
888 m
= m
< dim
->ts
.kind
? dim
->ts
.kind
: m
;
890 /* Convert shift to at least m, so we don't need
891 kind=1 and kind=2 versions of the library functions. */
892 if (shift
->ts
.kind
< m
)
896 ts
.type
= BT_INTEGER
;
898 gfc_convert_type_warn (shift
, &ts
, 2, 0);
903 if (dim
->expr_type
!= EXPR_CONSTANT
&& dim
->symtree
!= NULL
904 && dim
->symtree
->n
.sym
->attr
.optional
)
906 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
907 dim
->representation
.length
= shift
->ts
.kind
;
911 gfc_resolve_dim_arg (dim
);
912 /* Convert dim to shift's kind to reduce variations. */
913 if (dim
->ts
.kind
!= shift
->ts
.kind
)
914 gfc_convert_type_warn (dim
, &shift
->ts
, 2, 0);
918 if (array
->ts
.type
== BT_CHARACTER
)
920 if (array
->ts
.kind
== gfc_default_character_kind
)
921 f
->value
.function
.name
922 = gfc_get_string (PREFIX ("eoshift%d_%d_char"), n
, shift
->ts
.kind
);
924 f
->value
.function
.name
925 = gfc_get_string (PREFIX ("eoshift%d_%d_char%d"), n
, shift
->ts
.kind
,
929 f
->value
.function
.name
930 = gfc_get_string (PREFIX ("eoshift%d_%d"), n
, shift
->ts
.kind
);
935 gfc_resolve_exp (gfc_expr
*f
, gfc_expr
*x
)
938 f
->value
.function
.name
939 = gfc_get_string ("__exp_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
944 gfc_resolve_exponent (gfc_expr
*f
, gfc_expr
*x
)
946 f
->ts
.type
= BT_INTEGER
;
947 f
->ts
.kind
= gfc_default_integer_kind
;
948 f
->value
.function
.name
= gfc_get_string ("__exponent_%d", x
->ts
.kind
);
952 /* Resolve the EXTENDS_TYPE_OF intrinsic function. */
955 gfc_resolve_extends_type_of (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*mo
)
960 /* Prevent double resolution. */
961 if (f
->ts
.type
== BT_LOGICAL
)
964 /* Replace the first argument with the corresponding vtab. */
965 if (a
->ts
.type
== BT_CLASS
)
966 gfc_add_vptr_component (a
);
967 else if (a
->ts
.type
== BT_DERIVED
)
969 vtab
= gfc_find_derived_vtab (a
->ts
.u
.derived
);
970 /* Clear the old expr. */
971 gfc_free_ref_list (a
->ref
);
972 memset (a
, '\0', sizeof (gfc_expr
));
973 /* Construct a new one. */
974 a
->expr_type
= EXPR_VARIABLE
;
975 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
980 /* Replace the second argument with the corresponding vtab. */
981 if (mo
->ts
.type
== BT_CLASS
)
982 gfc_add_vptr_component (mo
);
983 else if (mo
->ts
.type
== BT_DERIVED
)
985 vtab
= gfc_find_derived_vtab (mo
->ts
.u
.derived
);
986 /* Clear the old expr. */
987 gfc_free_ref_list (mo
->ref
);
988 memset (mo
, '\0', sizeof (gfc_expr
));
989 /* Construct a new one. */
990 mo
->expr_type
= EXPR_VARIABLE
;
991 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
996 f
->ts
.type
= BT_LOGICAL
;
999 f
->value
.function
.isym
->formal
->ts
= a
->ts
;
1000 f
->value
.function
.isym
->formal
->next
->ts
= mo
->ts
;
1002 /* Call library function. */
1003 f
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
1008 gfc_resolve_fdate (gfc_expr
*f
)
1010 f
->ts
.type
= BT_CHARACTER
;
1011 f
->ts
.kind
= gfc_default_character_kind
;
1012 f
->value
.function
.name
= gfc_get_string (PREFIX ("fdate"));
1017 gfc_resolve_floor (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1019 f
->ts
.type
= BT_INTEGER
;
1020 f
->ts
.kind
= (kind
== NULL
)
1021 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
1022 f
->value
.function
.name
1023 = gfc_get_string ("__floor%d_%c%d", f
->ts
.kind
,
1024 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1029 gfc_resolve_fnum (gfc_expr
*f
, gfc_expr
*n
)
1031 f
->ts
.type
= BT_INTEGER
;
1032 f
->ts
.kind
= gfc_default_integer_kind
;
1033 if (n
->ts
.kind
!= f
->ts
.kind
)
1034 gfc_convert_type (n
, &f
->ts
, 2);
1035 f
->value
.function
.name
= gfc_get_string (PREFIX ("fnum_i%d"), f
->ts
.kind
);
1040 gfc_resolve_fraction (gfc_expr
*f
, gfc_expr
*x
)
1043 f
->value
.function
.name
= gfc_get_string ("__fraction_%d", x
->ts
.kind
);
1047 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
1050 gfc_resolve_g77_math1 (gfc_expr
*f
, gfc_expr
*x
)
1053 f
->value
.function
.name
= gfc_get_string ("<intrinsic>");
1058 gfc_resolve_gamma (gfc_expr
*f
, gfc_expr
*x
)
1061 f
->value
.function
.name
1062 = gfc_get_string ("__tgamma_%d", x
->ts
.kind
);
1067 gfc_resolve_getcwd (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
1069 f
->ts
.type
= BT_INTEGER
;
1071 f
->value
.function
.name
= gfc_get_string (PREFIX ("getcwd"));
1076 gfc_resolve_getgid (gfc_expr
*f
)
1078 f
->ts
.type
= BT_INTEGER
;
1080 f
->value
.function
.name
= gfc_get_string (PREFIX ("getgid"));
1085 gfc_resolve_getpid (gfc_expr
*f
)
1087 f
->ts
.type
= BT_INTEGER
;
1089 f
->value
.function
.name
= gfc_get_string (PREFIX ("getpid"));
1094 gfc_resolve_getuid (gfc_expr
*f
)
1096 f
->ts
.type
= BT_INTEGER
;
1098 f
->value
.function
.name
= gfc_get_string (PREFIX ("getuid"));
1103 gfc_resolve_hostnm (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
1105 f
->ts
.type
= BT_INTEGER
;
1107 f
->value
.function
.name
= gfc_get_string (PREFIX ("hostnm"));
1112 gfc_resolve_hypot (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
1115 f
->value
.function
.name
= gfc_get_string ("__hypot_r%d", x
->ts
.kind
);
1120 gfc_resolve_iall (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
1122 resolve_transformational ("iall", f
, array
, dim
, mask
);
1127 gfc_resolve_iand (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1129 /* If the kind of i and j are different, then g77 cross-promoted the
1130 kinds to the largest value. The Fortran 95 standard requires the
1132 if (i
->ts
.kind
!= j
->ts
.kind
)
1134 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1135 gfc_convert_type (j
, &i
->ts
, 2);
1137 gfc_convert_type (i
, &j
->ts
, 2);
1141 f
->value
.function
.name
= gfc_get_string ("__iand_%d", i
->ts
.kind
);
1146 gfc_resolve_iany (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
1148 resolve_transformational ("iany", f
, array
, dim
, mask
);
1153 gfc_resolve_ibclr (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
)
1156 f
->value
.function
.name
= gfc_get_string ("__ibclr_%d", i
->ts
.kind
);
1161 gfc_resolve_ibits (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
,
1162 gfc_expr
*len ATTRIBUTE_UNUSED
)
1165 f
->value
.function
.name
= gfc_get_string ("__ibits_%d", i
->ts
.kind
);
1170 gfc_resolve_ibset (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
)
1173 f
->value
.function
.name
= gfc_get_string ("__ibset_%d", i
->ts
.kind
);
1178 gfc_resolve_iachar (gfc_expr
*f
, gfc_expr
*c
, gfc_expr
*kind
)
1180 f
->ts
.type
= BT_INTEGER
;
1182 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1184 f
->ts
.kind
= gfc_default_integer_kind
;
1185 f
->value
.function
.name
= gfc_get_string ("__ichar_%d", c
->ts
.kind
);
1190 gfc_resolve_ichar (gfc_expr
*f
, gfc_expr
*c
, gfc_expr
*kind
)
1192 f
->ts
.type
= BT_INTEGER
;
1194 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1196 f
->ts
.kind
= gfc_default_integer_kind
;
1197 f
->value
.function
.name
= gfc_get_string ("__ichar_%d", c
->ts
.kind
);
1202 gfc_resolve_idnint (gfc_expr
*f
, gfc_expr
*a
)
1204 gfc_resolve_nint (f
, a
, NULL
);
1209 gfc_resolve_ierrno (gfc_expr
*f
)
1211 f
->ts
.type
= BT_INTEGER
;
1212 f
->ts
.kind
= gfc_default_integer_kind
;
1213 f
->value
.function
.name
= gfc_get_string (PREFIX ("ierrno_i%d"), f
->ts
.kind
);
1218 gfc_resolve_ieor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1220 /* If the kind of i and j are different, then g77 cross-promoted the
1221 kinds to the largest value. The Fortran 95 standard requires the
1223 if (i
->ts
.kind
!= j
->ts
.kind
)
1225 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1226 gfc_convert_type (j
, &i
->ts
, 2);
1228 gfc_convert_type (i
, &j
->ts
, 2);
1232 f
->value
.function
.name
= gfc_get_string ("__ieor_%d", i
->ts
.kind
);
1237 gfc_resolve_ior (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1239 /* If the kind of i and j are different, then g77 cross-promoted the
1240 kinds to the largest value. The Fortran 95 standard requires the
1242 if (i
->ts
.kind
!= j
->ts
.kind
)
1244 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1245 gfc_convert_type (j
, &i
->ts
, 2);
1247 gfc_convert_type (i
, &j
->ts
, 2);
1251 f
->value
.function
.name
= gfc_get_string ("__ior_%d", i
->ts
.kind
);
1256 gfc_resolve_index_func (gfc_expr
*f
, gfc_expr
*str
,
1257 gfc_expr
*sub_str ATTRIBUTE_UNUSED
, gfc_expr
*back
,
1263 f
->ts
.type
= BT_INTEGER
;
1265 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1267 f
->ts
.kind
= gfc_default_integer_kind
;
1269 if (back
&& back
->ts
.kind
!= gfc_default_integer_kind
)
1271 ts
.type
= BT_LOGICAL
;
1272 ts
.kind
= gfc_default_integer_kind
;
1273 ts
.u
.derived
= NULL
;
1275 gfc_convert_type (back
, &ts
, 2);
1278 f
->value
.function
.name
1279 = gfc_get_string ("__index_%d_i%d", str
->ts
.kind
, f
->ts
.kind
);
1284 gfc_resolve_int (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1286 f
->ts
.type
= BT_INTEGER
;
1287 f
->ts
.kind
= (kind
== NULL
)
1288 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
1289 f
->value
.function
.name
1290 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1291 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1296 gfc_resolve_int2 (gfc_expr
*f
, gfc_expr
*a
)
1298 f
->ts
.type
= BT_INTEGER
;
1300 f
->value
.function
.name
1301 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1302 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1307 gfc_resolve_int8 (gfc_expr
*f
, gfc_expr
*a
)
1309 f
->ts
.type
= BT_INTEGER
;
1311 f
->value
.function
.name
1312 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1313 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1318 gfc_resolve_long (gfc_expr
*f
, gfc_expr
*a
)
1320 f
->ts
.type
= BT_INTEGER
;
1322 f
->value
.function
.name
1323 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1324 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1329 gfc_resolve_iparity (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
1331 resolve_transformational ("iparity", f
, array
, dim
, mask
);
1336 gfc_resolve_isatty (gfc_expr
*f
, gfc_expr
*u
)
1341 f
->ts
.type
= BT_LOGICAL
;
1342 f
->ts
.kind
= gfc_default_integer_kind
;
1343 if (u
->ts
.kind
!= gfc_c_int_kind
)
1345 ts
.type
= BT_INTEGER
;
1346 ts
.kind
= gfc_c_int_kind
;
1347 ts
.u
.derived
= NULL
;
1349 gfc_convert_type (u
, &ts
, 2);
1352 f
->value
.function
.name
= gfc_get_string (PREFIX ("isatty_l%d"), f
->ts
.kind
);
1357 gfc_resolve_ishft (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1360 f
->value
.function
.name
1361 = gfc_get_string ("__ishft_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1366 gfc_resolve_rshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1369 f
->value
.function
.name
1370 = gfc_get_string ("__rshift_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1375 gfc_resolve_lshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1378 f
->value
.function
.name
1379 = gfc_get_string ("__lshift_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1384 gfc_resolve_ishftc (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
1388 s_kind
= (size
== NULL
) ? gfc_default_integer_kind
: size
->ts
.kind
;
1391 f
->value
.function
.name
1392 = gfc_get_string ("__ishftc_%d_%d_%d", i
->ts
.kind
, shift
->ts
.kind
, s_kind
);
1397 gfc_resolve_kill (gfc_expr
*f
, gfc_expr
*p ATTRIBUTE_UNUSED
,
1398 gfc_expr
*s ATTRIBUTE_UNUSED
)
1400 f
->ts
.type
= BT_INTEGER
;
1401 f
->ts
.kind
= gfc_default_integer_kind
;
1402 f
->value
.function
.name
= gfc_get_string (PREFIX ("kill_i%d"), f
->ts
.kind
);
1407 gfc_resolve_lbound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
1409 resolve_bound (f
, array
, dim
, kind
, "__lbound", false);
1414 gfc_resolve_lcobound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
1416 resolve_bound (f
, array
, dim
, kind
, "__lcobound", true);
1421 gfc_resolve_len (gfc_expr
*f
, gfc_expr
*string
, gfc_expr
*kind
)
1423 f
->ts
.type
= BT_INTEGER
;
1425 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1427 f
->ts
.kind
= gfc_default_integer_kind
;
1428 f
->value
.function
.name
1429 = gfc_get_string ("__len_%d_i%d", string
->ts
.kind
,
1430 gfc_default_integer_kind
);
1435 gfc_resolve_len_trim (gfc_expr
*f
, gfc_expr
*string
, gfc_expr
*kind
)
1437 f
->ts
.type
= BT_INTEGER
;
1439 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1441 f
->ts
.kind
= gfc_default_integer_kind
;
1442 f
->value
.function
.name
= gfc_get_string ("__len_trim%d", string
->ts
.kind
);
1447 gfc_resolve_lgamma (gfc_expr
*f
, gfc_expr
*x
)
1450 f
->value
.function
.name
1451 = gfc_get_string ("__lgamma_%d", x
->ts
.kind
);
1456 gfc_resolve_link (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
1457 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
1459 f
->ts
.type
= BT_INTEGER
;
1460 f
->ts
.kind
= gfc_default_integer_kind
;
1461 f
->value
.function
.name
= gfc_get_string (PREFIX ("link_i%d"), f
->ts
.kind
);
1466 gfc_resolve_loc (gfc_expr
*f
, gfc_expr
*x
)
1468 f
->ts
.type
= BT_INTEGER
;
1469 f
->ts
.kind
= gfc_index_integer_kind
;
1470 f
->value
.function
.name
= gfc_get_string ("__loc_%d", x
->ts
.kind
);
1475 gfc_resolve_log (gfc_expr
*f
, gfc_expr
*x
)
1478 f
->value
.function
.name
1479 = gfc_get_string ("__log_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1484 gfc_resolve_log10 (gfc_expr
*f
, gfc_expr
*x
)
1487 f
->value
.function
.name
1488 = gfc_get_string ("__log10_%c%d", gfc_type_letter (x
->ts
.type
),
1494 gfc_resolve_logical (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1496 f
->ts
.type
= BT_LOGICAL
;
1497 f
->ts
.kind
= (kind
== NULL
)
1498 ? gfc_default_logical_kind
: mpz_get_si (kind
->value
.integer
);
1501 f
->value
.function
.name
1502 = gfc_get_string ("__logical_%d_%c%d", f
->ts
.kind
,
1503 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1508 gfc_resolve_malloc (gfc_expr
*f
, gfc_expr
*size
)
1510 if (size
->ts
.kind
< gfc_index_integer_kind
)
1515 ts
.type
= BT_INTEGER
;
1516 ts
.kind
= gfc_index_integer_kind
;
1517 gfc_convert_type_warn (size
, &ts
, 2, 0);
1520 f
->ts
.type
= BT_INTEGER
;
1521 f
->ts
.kind
= gfc_index_integer_kind
;
1522 f
->value
.function
.name
= gfc_get_string (PREFIX ("malloc"));
1527 gfc_resolve_matmul (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b
)
1531 if (a
->ts
.type
== BT_LOGICAL
&& b
->ts
.type
== BT_LOGICAL
)
1533 f
->ts
.type
= BT_LOGICAL
;
1534 f
->ts
.kind
= gfc_default_logical_kind
;
1538 temp
.expr_type
= EXPR_OP
;
1539 gfc_clear_ts (&temp
.ts
);
1540 temp
.value
.op
.op
= INTRINSIC_NONE
;
1541 temp
.value
.op
.op1
= a
;
1542 temp
.value
.op
.op2
= b
;
1543 gfc_type_convert_binary (&temp
, 1);
1547 f
->rank
= (a
->rank
== 2 && b
->rank
== 2) ? 2 : 1;
1549 if (a
->rank
== 2 && b
->rank
== 2)
1551 if (a
->shape
&& b
->shape
)
1553 f
->shape
= gfc_get_shape (f
->rank
);
1554 mpz_init_set (f
->shape
[0], a
->shape
[0]);
1555 mpz_init_set (f
->shape
[1], b
->shape
[1]);
1558 else if (a
->rank
== 1)
1562 f
->shape
= gfc_get_shape (f
->rank
);
1563 mpz_init_set (f
->shape
[0], b
->shape
[1]);
1568 /* b->rank == 1 and a->rank == 2 here, all other cases have
1569 been caught in check.c. */
1572 f
->shape
= gfc_get_shape (f
->rank
);
1573 mpz_init_set (f
->shape
[0], a
->shape
[0]);
1577 f
->value
.function
.name
1578 = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f
->ts
.type
),
1584 gfc_resolve_minmax (const char *name
, gfc_expr
*f
, gfc_actual_arglist
*args
)
1586 gfc_actual_arglist
*a
;
1588 f
->ts
.type
= args
->expr
->ts
.type
;
1589 f
->ts
.kind
= args
->expr
->ts
.kind
;
1590 /* Find the largest type kind. */
1591 for (a
= args
->next
; a
; a
= a
->next
)
1593 if (a
->expr
->ts
.kind
> f
->ts
.kind
)
1594 f
->ts
.kind
= a
->expr
->ts
.kind
;
1597 /* Convert all parameters to the required kind. */
1598 for (a
= args
; a
; a
= a
->next
)
1600 if (a
->expr
->ts
.kind
!= f
->ts
.kind
)
1601 gfc_convert_type (a
->expr
, &f
->ts
, 2);
1604 f
->value
.function
.name
1605 = gfc_get_string (name
, gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
1610 gfc_resolve_max (gfc_expr
*f
, gfc_actual_arglist
*args
)
1612 gfc_resolve_minmax ("__max_%c%d", f
, args
);
1617 gfc_resolve_maxloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1623 f
->ts
.type
= BT_INTEGER
;
1624 f
->ts
.kind
= gfc_default_integer_kind
;
1629 f
->shape
= gfc_get_shape (1);
1630 mpz_init_set_si (f
->shape
[0], array
->rank
);
1634 f
->rank
= array
->rank
- 1;
1635 gfc_resolve_dim_arg (dim
);
1636 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1638 idim
= (int) mpz_get_si (dim
->value
.integer
);
1639 f
->shape
= gfc_get_shape (f
->rank
);
1640 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1642 if (i
== (idim
- 1))
1644 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1651 if (mask
->rank
== 0)
1656 resolve_mask_arg (mask
);
1661 f
->value
.function
.name
1662 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name
, dim
!= NULL
, f
->ts
.kind
,
1663 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1668 gfc_resolve_maxval (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1678 f
->rank
= array
->rank
- 1;
1679 gfc_resolve_dim_arg (dim
);
1681 if (f
->rank
&& array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1683 idim
= (int) mpz_get_si (dim
->value
.integer
);
1684 f
->shape
= gfc_get_shape (f
->rank
);
1685 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1687 if (i
== (idim
- 1))
1689 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1696 if (mask
->rank
== 0)
1701 resolve_mask_arg (mask
);
1706 f
->value
.function
.name
1707 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
1708 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1713 gfc_resolve_mclock (gfc_expr
*f
)
1715 f
->ts
.type
= BT_INTEGER
;
1717 f
->value
.function
.name
= PREFIX ("mclock");
1722 gfc_resolve_mclock8 (gfc_expr
*f
)
1724 f
->ts
.type
= BT_INTEGER
;
1726 f
->value
.function
.name
= PREFIX ("mclock8");
1731 gfc_resolve_mask (gfc_expr
*f
, gfc_expr
*i ATTRIBUTE_UNUSED
,
1734 f
->ts
.type
= BT_INTEGER
;
1735 f
->ts
.kind
= kind
? mpz_get_si (kind
->value
.integer
)
1736 : gfc_default_integer_kind
;
1738 if (f
->value
.function
.isym
->id
== GFC_ISYM_MASKL
)
1739 f
->value
.function
.name
= gfc_get_string ("__maskl_i%d", f
->ts
.kind
);
1741 f
->value
.function
.name
= gfc_get_string ("__maskr_i%d", f
->ts
.kind
);
1746 gfc_resolve_merge (gfc_expr
*f
, gfc_expr
*tsource
,
1747 gfc_expr
*fsource ATTRIBUTE_UNUSED
,
1748 gfc_expr
*mask ATTRIBUTE_UNUSED
)
1750 if (tsource
->ts
.type
== BT_CHARACTER
&& tsource
->ref
)
1751 gfc_resolve_substring_charlen (tsource
);
1753 if (fsource
->ts
.type
== BT_CHARACTER
&& fsource
->ref
)
1754 gfc_resolve_substring_charlen (fsource
);
1756 if (tsource
->ts
.type
== BT_CHARACTER
)
1757 check_charlen_present (tsource
);
1759 f
->ts
= tsource
->ts
;
1760 f
->value
.function
.name
1761 = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource
->ts
.type
),
1767 gfc_resolve_merge_bits (gfc_expr
*f
, gfc_expr
*i
,
1768 gfc_expr
*j ATTRIBUTE_UNUSED
,
1769 gfc_expr
*mask ATTRIBUTE_UNUSED
)
1772 f
->value
.function
.name
= gfc_get_string ("__merge_bits_i%d", i
->ts
.kind
);
1777 gfc_resolve_min (gfc_expr
*f
, gfc_actual_arglist
*args
)
1779 gfc_resolve_minmax ("__min_%c%d", f
, args
);
1784 gfc_resolve_minloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1790 f
->ts
.type
= BT_INTEGER
;
1791 f
->ts
.kind
= gfc_default_integer_kind
;
1796 f
->shape
= gfc_get_shape (1);
1797 mpz_init_set_si (f
->shape
[0], array
->rank
);
1801 f
->rank
= array
->rank
- 1;
1802 gfc_resolve_dim_arg (dim
);
1803 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1805 idim
= (int) mpz_get_si (dim
->value
.integer
);
1806 f
->shape
= gfc_get_shape (f
->rank
);
1807 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1809 if (i
== (idim
- 1))
1811 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1818 if (mask
->rank
== 0)
1823 resolve_mask_arg (mask
);
1828 f
->value
.function
.name
1829 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name
, dim
!= NULL
, f
->ts
.kind
,
1830 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1835 gfc_resolve_minval (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1845 f
->rank
= array
->rank
- 1;
1846 gfc_resolve_dim_arg (dim
);
1848 if (f
->rank
&& array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1850 idim
= (int) mpz_get_si (dim
->value
.integer
);
1851 f
->shape
= gfc_get_shape (f
->rank
);
1852 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1854 if (i
== (idim
- 1))
1856 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1863 if (mask
->rank
== 0)
1868 resolve_mask_arg (mask
);
1873 f
->value
.function
.name
1874 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
1875 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1880 gfc_resolve_mod (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
1882 f
->ts
.type
= a
->ts
.type
;
1884 f
->ts
.kind
= gfc_kind_max (a
,p
);
1886 f
->ts
.kind
= a
->ts
.kind
;
1888 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
1890 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
1891 gfc_convert_type (p
, &a
->ts
, 2);
1893 gfc_convert_type (a
, &p
->ts
, 2);
1896 f
->value
.function
.name
1897 = gfc_get_string ("__mod_%c%d", gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
1902 gfc_resolve_modulo (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
1904 f
->ts
.type
= a
->ts
.type
;
1906 f
->ts
.kind
= gfc_kind_max (a
,p
);
1908 f
->ts
.kind
= a
->ts
.kind
;
1910 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
1912 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
1913 gfc_convert_type (p
, &a
->ts
, 2);
1915 gfc_convert_type (a
, &p
->ts
, 2);
1918 f
->value
.function
.name
1919 = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f
->ts
.type
),
1924 gfc_resolve_nearest (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
1926 if (p
->ts
.kind
!= a
->ts
.kind
)
1927 gfc_convert_type (p
, &a
->ts
, 2);
1930 f
->value
.function
.name
1931 = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a
->ts
.type
),
1936 gfc_resolve_nint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1938 f
->ts
.type
= BT_INTEGER
;
1939 f
->ts
.kind
= (kind
== NULL
)
1940 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
1941 f
->value
.function
.name
1942 = gfc_get_string ("__nint_%d_%d", f
->ts
.kind
, a
->ts
.kind
);
1947 gfc_resolve_norm2 (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
)
1949 resolve_transformational ("norm2", f
, array
, dim
, NULL
);
1954 gfc_resolve_not (gfc_expr
*f
, gfc_expr
*i
)
1957 f
->value
.function
.name
= gfc_get_string ("__not_%d", i
->ts
.kind
);
1962 gfc_resolve_or (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1964 f
->ts
.type
= i
->ts
.type
;
1965 f
->ts
.kind
= gfc_kind_max (i
, j
);
1967 if (i
->ts
.kind
!= j
->ts
.kind
)
1969 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1970 gfc_convert_type (j
, &i
->ts
, 2);
1972 gfc_convert_type (i
, &j
->ts
, 2);
1975 f
->value
.function
.name
1976 = gfc_get_string ("__or_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
1981 gfc_resolve_pack (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*mask
,
1982 gfc_expr
*vector ATTRIBUTE_UNUSED
)
1984 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
1985 gfc_resolve_substring_charlen (array
);
1990 resolve_mask_arg (mask
);
1992 if (mask
->rank
!= 0)
1994 if (array
->ts
.type
== BT_CHARACTER
)
1995 f
->value
.function
.name
1996 = array
->ts
.kind
== 1 ? PREFIX ("pack_char")
1998 (PREFIX ("pack_char%d"),
2001 f
->value
.function
.name
= PREFIX ("pack");
2005 if (array
->ts
.type
== BT_CHARACTER
)
2006 f
->value
.function
.name
2007 = array
->ts
.kind
== 1 ? PREFIX ("pack_s_char")
2009 (PREFIX ("pack_s_char%d"),
2012 f
->value
.function
.name
= PREFIX ("pack_s");
2018 gfc_resolve_parity (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
)
2020 resolve_transformational ("parity", f
, array
, dim
, NULL
);
2025 gfc_resolve_product (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
2028 resolve_transformational ("product", f
, array
, dim
, mask
);
2033 gfc_resolve_rank (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
)
2035 f
->ts
.type
= BT_INTEGER
;
2036 f
->ts
.kind
= gfc_default_integer_kind
;
2037 f
->value
.function
.name
= gfc_get_string ("__rank");
2042 gfc_resolve_real (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
2044 f
->ts
.type
= BT_REAL
;
2047 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2049 f
->ts
.kind
= (a
->ts
.type
== BT_COMPLEX
)
2050 ? a
->ts
.kind
: gfc_default_real_kind
;
2052 f
->value
.function
.name
2053 = gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
2054 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2059 gfc_resolve_realpart (gfc_expr
*f
, gfc_expr
*a
)
2061 f
->ts
.type
= BT_REAL
;
2062 f
->ts
.kind
= a
->ts
.kind
;
2063 f
->value
.function
.name
2064 = gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
2065 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2070 gfc_resolve_rename (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
2071 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
2073 f
->ts
.type
= BT_INTEGER
;
2074 f
->ts
.kind
= gfc_default_integer_kind
;
2075 f
->value
.function
.name
= gfc_get_string (PREFIX ("rename_i%d"), f
->ts
.kind
);
2080 gfc_resolve_repeat (gfc_expr
*f
, gfc_expr
*string
,
2085 f
->ts
.type
= BT_CHARACTER
;
2086 f
->ts
.kind
= string
->ts
.kind
;
2087 f
->value
.function
.name
= gfc_get_string ("__repeat_%d", string
->ts
.kind
);
2089 /* If possible, generate a character length. */
2090 if (f
->ts
.u
.cl
== NULL
)
2091 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2094 if (string
->expr_type
== EXPR_CONSTANT
)
2096 len
= string
->value
.character
.length
;
2097 tmp
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, len
);
2099 else if (string
->ts
.u
.cl
&& string
->ts
.u
.cl
->length
)
2101 tmp
= gfc_copy_expr (string
->ts
.u
.cl
->length
);
2105 f
->ts
.u
.cl
->length
= gfc_multiply (tmp
, gfc_copy_expr (ncopies
));
2110 gfc_resolve_reshape (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*shape
,
2111 gfc_expr
*pad ATTRIBUTE_UNUSED
,
2112 gfc_expr
*order ATTRIBUTE_UNUSED
)
2118 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
2119 gfc_resolve_substring_charlen (source
);
2123 gfc_array_size (shape
, &rank
);
2124 f
->rank
= mpz_get_si (rank
);
2126 switch (source
->ts
.type
)
2133 kind
= source
->ts
.kind
;
2147 if (source
->ts
.type
== BT_COMPLEX
|| source
->ts
.type
== BT_REAL
)
2148 f
->value
.function
.name
2149 = gfc_get_string (PREFIX ("reshape_%c%d"),
2150 gfc_type_letter (source
->ts
.type
),
2152 else if (source
->ts
.type
== BT_CHARACTER
)
2153 f
->value
.function
.name
= gfc_get_string (PREFIX ("reshape_char%d"),
2156 f
->value
.function
.name
2157 = gfc_get_string (PREFIX ("reshape_%d"), source
->ts
.kind
);
2161 f
->value
.function
.name
= (source
->ts
.type
== BT_CHARACTER
2162 ? PREFIX ("reshape_char") : PREFIX ("reshape"));
2166 if (shape
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (shape
))
2169 f
->shape
= gfc_get_shape (f
->rank
);
2170 c
= gfc_constructor_first (shape
->value
.constructor
);
2171 for (i
= 0; i
< f
->rank
; i
++)
2173 mpz_init_set (f
->shape
[i
], c
->expr
->value
.integer
);
2174 c
= gfc_constructor_next (c
);
2178 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
2179 so many runtime variations. */
2180 if (shape
->ts
.kind
!= gfc_index_integer_kind
)
2182 gfc_typespec ts
= shape
->ts
;
2183 ts
.kind
= gfc_index_integer_kind
;
2184 gfc_convert_type_warn (shape
, &ts
, 2, 0);
2186 if (order
&& order
->ts
.kind
!= gfc_index_integer_kind
)
2187 gfc_convert_type_warn (order
, &shape
->ts
, 2, 0);
2192 gfc_resolve_rrspacing (gfc_expr
*f
, gfc_expr
*x
)
2195 f
->value
.function
.name
= gfc_get_string ("__rrspacing_%d", x
->ts
.kind
);
2199 gfc_resolve_fe_runtime_error (gfc_code
*c
)
2202 gfc_actual_arglist
*a
;
2204 name
= gfc_get_string (PREFIX ("runtime_error"));
2206 for (a
= c
->ext
.actual
->next
; a
; a
= a
->next
)
2209 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2213 gfc_resolve_scale (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*i ATTRIBUTE_UNUSED
)
2216 f
->value
.function
.name
= gfc_get_string ("__scale_%d", x
->ts
.kind
);
2221 gfc_resolve_scan (gfc_expr
*f
, gfc_expr
*string
,
2222 gfc_expr
*set ATTRIBUTE_UNUSED
,
2223 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2225 f
->ts
.type
= BT_INTEGER
;
2227 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2229 f
->ts
.kind
= gfc_default_integer_kind
;
2230 f
->value
.function
.name
= gfc_get_string ("__scan_%d", string
->ts
.kind
);
2235 gfc_resolve_secnds (gfc_expr
*t1
, gfc_expr
*t0
)
2238 t1
->value
.function
.name
= gfc_get_string (PREFIX ("secnds"));
2243 gfc_resolve_set_exponent (gfc_expr
*f
, gfc_expr
*x
,
2244 gfc_expr
*i ATTRIBUTE_UNUSED
)
2247 f
->value
.function
.name
= gfc_get_string ("__set_exponent_%d", x
->ts
.kind
);
2252 gfc_resolve_shape (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*kind
)
2254 f
->ts
.type
= BT_INTEGER
;
2257 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2259 f
->ts
.kind
= gfc_default_integer_kind
;
2262 if (array
->rank
!= -1)
2264 f
->shape
= gfc_get_shape (1);
2265 mpz_init_set_ui (f
->shape
[0], array
->rank
);
2268 f
->value
.function
.name
= gfc_get_string (PREFIX ("shape_%d"), f
->ts
.kind
);
2273 gfc_resolve_shift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift ATTRIBUTE_UNUSED
)
2276 if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTA
)
2277 f
->value
.function
.name
= gfc_get_string ("shifta_i%d", f
->ts
.kind
);
2278 else if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTL
)
2279 f
->value
.function
.name
= gfc_get_string ("shiftl_i%d", f
->ts
.kind
);
2280 else if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTR
)
2281 f
->value
.function
.name
= gfc_get_string ("shiftr_i%d", f
->ts
.kind
);
2288 gfc_resolve_sign (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b ATTRIBUTE_UNUSED
)
2291 f
->value
.function
.name
2292 = gfc_get_string ("__sign_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2297 gfc_resolve_signal (gfc_expr
*f
, gfc_expr
*number
, gfc_expr
*handler
)
2299 f
->ts
.type
= BT_INTEGER
;
2300 f
->ts
.kind
= gfc_c_int_kind
;
2302 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2303 if (handler
->ts
.type
== BT_INTEGER
)
2305 if (handler
->ts
.kind
!= gfc_c_int_kind
)
2306 gfc_convert_type (handler
, &f
->ts
, 2);
2307 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func_int"));
2310 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func"));
2312 if (number
->ts
.kind
!= gfc_c_int_kind
)
2313 gfc_convert_type (number
, &f
->ts
, 2);
2318 gfc_resolve_sin (gfc_expr
*f
, gfc_expr
*x
)
2321 f
->value
.function
.name
2322 = gfc_get_string ("__sin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2327 gfc_resolve_sinh (gfc_expr
*f
, gfc_expr
*x
)
2330 f
->value
.function
.name
2331 = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2336 gfc_resolve_size (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2337 gfc_expr
*dim ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2339 f
->ts
.type
= BT_INTEGER
;
2341 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2343 f
->ts
.kind
= gfc_default_integer_kind
;
2348 gfc_resolve_stride (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2349 gfc_expr
*dim ATTRIBUTE_UNUSED
)
2351 f
->ts
.type
= BT_INTEGER
;
2352 f
->ts
.kind
= gfc_index_integer_kind
;
2357 gfc_resolve_spacing (gfc_expr
*f
, gfc_expr
*x
)
2360 f
->value
.function
.name
= gfc_get_string ("__spacing_%d", x
->ts
.kind
);
2365 gfc_resolve_spread (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*dim
,
2368 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
2369 gfc_resolve_substring_charlen (source
);
2371 if (source
->ts
.type
== BT_CHARACTER
)
2372 check_charlen_present (source
);
2375 f
->rank
= source
->rank
+ 1;
2376 if (source
->rank
== 0)
2378 if (source
->ts
.type
== BT_CHARACTER
)
2379 f
->value
.function
.name
2380 = source
->ts
.kind
== 1 ? PREFIX ("spread_char_scalar")
2382 (PREFIX ("spread_char%d_scalar"),
2385 f
->value
.function
.name
= PREFIX ("spread_scalar");
2389 if (source
->ts
.type
== BT_CHARACTER
)
2390 f
->value
.function
.name
2391 = source
->ts
.kind
== 1 ? PREFIX ("spread_char")
2393 (PREFIX ("spread_char%d"),
2396 f
->value
.function
.name
= PREFIX ("spread");
2399 if (dim
&& gfc_is_constant_expr (dim
)
2400 && ncopies
&& gfc_is_constant_expr (ncopies
) && source
->shape
[0])
2403 idim
= mpz_get_ui (dim
->value
.integer
);
2404 f
->shape
= gfc_get_shape (f
->rank
);
2405 for (i
= 0; i
< (idim
- 1); i
++)
2406 mpz_init_set (f
->shape
[i
], source
->shape
[i
]);
2408 mpz_init_set (f
->shape
[idim
- 1], ncopies
->value
.integer
);
2410 for (i
= idim
; i
< f
->rank
; i
++)
2411 mpz_init_set (f
->shape
[i
], source
->shape
[i
-1]);
2415 gfc_resolve_dim_arg (dim
);
2416 gfc_resolve_index (ncopies
, 1);
2421 gfc_resolve_sqrt (gfc_expr
*f
, gfc_expr
*x
)
2424 f
->value
.function
.name
2425 = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2429 /* Resolve the g77 compatibility function STAT AND FSTAT. */
2432 gfc_resolve_stat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2433 gfc_expr
*a ATTRIBUTE_UNUSED
)
2435 f
->ts
.type
= BT_INTEGER
;
2436 f
->ts
.kind
= gfc_default_integer_kind
;
2437 f
->value
.function
.name
= gfc_get_string (PREFIX ("stat_i%d"), f
->ts
.kind
);
2442 gfc_resolve_lstat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2443 gfc_expr
*a ATTRIBUTE_UNUSED
)
2445 f
->ts
.type
= BT_INTEGER
;
2446 f
->ts
.kind
= gfc_default_integer_kind
;
2447 f
->value
.function
.name
= gfc_get_string (PREFIX ("lstat_i%d"), f
->ts
.kind
);
2452 gfc_resolve_fstat (gfc_expr
*f
, gfc_expr
*n
, gfc_expr
*a ATTRIBUTE_UNUSED
)
2454 f
->ts
.type
= BT_INTEGER
;
2455 f
->ts
.kind
= gfc_default_integer_kind
;
2456 if (n
->ts
.kind
!= f
->ts
.kind
)
2457 gfc_convert_type (n
, &f
->ts
, 2);
2459 f
->value
.function
.name
= gfc_get_string (PREFIX ("fstat_i%d"), f
->ts
.kind
);
2464 gfc_resolve_fgetc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2469 f
->ts
.type
= BT_INTEGER
;
2470 f
->ts
.kind
= gfc_c_int_kind
;
2471 if (u
->ts
.kind
!= gfc_c_int_kind
)
2473 ts
.type
= BT_INTEGER
;
2474 ts
.kind
= gfc_c_int_kind
;
2475 ts
.u
.derived
= NULL
;
2477 gfc_convert_type (u
, &ts
, 2);
2480 f
->value
.function
.name
= gfc_get_string (PREFIX ("fgetc"));
2485 gfc_resolve_fget (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2487 f
->ts
.type
= BT_INTEGER
;
2488 f
->ts
.kind
= gfc_c_int_kind
;
2489 f
->value
.function
.name
= gfc_get_string (PREFIX ("fget"));
2494 gfc_resolve_fputc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2499 f
->ts
.type
= BT_INTEGER
;
2500 f
->ts
.kind
= gfc_c_int_kind
;
2501 if (u
->ts
.kind
!= gfc_c_int_kind
)
2503 ts
.type
= BT_INTEGER
;
2504 ts
.kind
= gfc_c_int_kind
;
2505 ts
.u
.derived
= NULL
;
2507 gfc_convert_type (u
, &ts
, 2);
2510 f
->value
.function
.name
= gfc_get_string (PREFIX ("fputc"));
2515 gfc_resolve_fput (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2517 f
->ts
.type
= BT_INTEGER
;
2518 f
->ts
.kind
= gfc_c_int_kind
;
2519 f
->value
.function
.name
= gfc_get_string (PREFIX ("fput"));
2524 gfc_resolve_ftell (gfc_expr
*f
, gfc_expr
*u
)
2529 f
->ts
.type
= BT_INTEGER
;
2530 f
->ts
.kind
= gfc_intio_kind
;
2531 if (u
->ts
.kind
!= gfc_c_int_kind
)
2533 ts
.type
= BT_INTEGER
;
2534 ts
.kind
= gfc_c_int_kind
;
2535 ts
.u
.derived
= NULL
;
2537 gfc_convert_type (u
, &ts
, 2);
2540 f
->value
.function
.name
= gfc_get_string (PREFIX ("ftell2"));
2545 gfc_resolve_storage_size (gfc_expr
*f
, gfc_expr
*a ATTRIBUTE_UNUSED
,
2548 f
->ts
.type
= BT_INTEGER
;
2550 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2552 f
->ts
.kind
= gfc_default_integer_kind
;
2557 gfc_resolve_sum (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2559 resolve_transformational ("sum", f
, array
, dim
, mask
);
2564 gfc_resolve_symlnk (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
2565 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
2567 f
->ts
.type
= BT_INTEGER
;
2568 f
->ts
.kind
= gfc_default_integer_kind
;
2569 f
->value
.function
.name
= gfc_get_string (PREFIX ("symlnk_i%d"), f
->ts
.kind
);
2573 /* Resolve the g77 compatibility function SYSTEM. */
2576 gfc_resolve_system (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
2578 f
->ts
.type
= BT_INTEGER
;
2580 f
->value
.function
.name
= gfc_get_string (PREFIX ("system"));
2585 gfc_resolve_tan (gfc_expr
*f
, gfc_expr
*x
)
2588 f
->value
.function
.name
2589 = gfc_get_string ("__tan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2594 gfc_resolve_tanh (gfc_expr
*f
, gfc_expr
*x
)
2597 f
->value
.function
.name
2598 = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2603 gfc_resolve_image_index (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2604 gfc_expr
*sub ATTRIBUTE_UNUSED
)
2606 static char image_index
[] = "__image_index";
2607 f
->ts
.type
= BT_INTEGER
;
2608 f
->ts
.kind
= gfc_default_integer_kind
;
2609 f
->value
.function
.name
= image_index
;
2614 gfc_resolve_this_image (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
2615 gfc_expr
*distance ATTRIBUTE_UNUSED
)
2617 static char this_image
[] = "__this_image";
2618 if (array
&& gfc_is_coarray (array
))
2619 resolve_bound (f
, array
, dim
, NULL
, "__this_image", true);
2622 f
->ts
.type
= BT_INTEGER
;
2623 f
->ts
.kind
= gfc_default_integer_kind
;
2624 f
->value
.function
.name
= this_image
;
2630 gfc_resolve_time (gfc_expr
*f
)
2632 f
->ts
.type
= BT_INTEGER
;
2634 f
->value
.function
.name
= gfc_get_string (PREFIX ("time_func"));
2639 gfc_resolve_time8 (gfc_expr
*f
)
2641 f
->ts
.type
= BT_INTEGER
;
2643 f
->value
.function
.name
= gfc_get_string (PREFIX ("time8_func"));
2648 gfc_resolve_transfer (gfc_expr
*f
, gfc_expr
*source ATTRIBUTE_UNUSED
,
2649 gfc_expr
*mold
, gfc_expr
*size
)
2651 /* TODO: Make this do something meaningful. */
2652 static char transfer0
[] = "__transfer0", transfer1
[] = "__transfer1";
2654 if (mold
->ts
.type
== BT_CHARACTER
2655 && !mold
->ts
.u
.cl
->length
2656 && gfc_is_constant_expr (mold
))
2659 if (mold
->expr_type
== EXPR_CONSTANT
)
2661 len
= mold
->value
.character
.length
;
2662 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
2667 gfc_constructor
*c
= gfc_constructor_first (mold
->value
.constructor
);
2668 len
= c
->expr
->value
.character
.length
;
2669 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
2676 if (size
== NULL
&& mold
->rank
== 0)
2679 f
->value
.function
.name
= transfer0
;
2684 f
->value
.function
.name
= transfer1
;
2685 if (size
&& gfc_is_constant_expr (size
))
2687 f
->shape
= gfc_get_shape (1);
2688 mpz_init_set (f
->shape
[0], size
->value
.integer
);
2695 gfc_resolve_transpose (gfc_expr
*f
, gfc_expr
*matrix
)
2698 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ref
)
2699 gfc_resolve_substring_charlen (matrix
);
2705 f
->shape
= gfc_get_shape (2);
2706 mpz_init_set (f
->shape
[0], matrix
->shape
[1]);
2707 mpz_init_set (f
->shape
[1], matrix
->shape
[0]);
2710 switch (matrix
->ts
.kind
)
2716 switch (matrix
->ts
.type
)
2720 f
->value
.function
.name
2721 = gfc_get_string (PREFIX ("transpose_%c%d"),
2722 gfc_type_letter (matrix
->ts
.type
),
2728 /* Use the integer routines for real and logical cases. This
2729 assumes they all have the same alignment requirements. */
2730 f
->value
.function
.name
2731 = gfc_get_string (PREFIX ("transpose_i%d"), matrix
->ts
.kind
);
2735 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ts
.kind
== 4)
2736 f
->value
.function
.name
= PREFIX ("transpose_char4");
2738 f
->value
.function
.name
= PREFIX ("transpose");
2744 f
->value
.function
.name
= (matrix
->ts
.type
== BT_CHARACTER
2745 ? PREFIX ("transpose_char")
2746 : PREFIX ("transpose"));
2753 gfc_resolve_trim (gfc_expr
*f
, gfc_expr
*string
)
2755 f
->ts
.type
= BT_CHARACTER
;
2756 f
->ts
.kind
= string
->ts
.kind
;
2757 f
->value
.function
.name
= gfc_get_string ("__trim_%d", string
->ts
.kind
);
2762 gfc_resolve_ubound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2764 resolve_bound (f
, array
, dim
, kind
, "__ubound", false);
2769 gfc_resolve_ucobound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2771 resolve_bound (f
, array
, dim
, kind
, "__ucobound", true);
2775 /* Resolve the g77 compatibility function UMASK. */
2778 gfc_resolve_umask (gfc_expr
*f
, gfc_expr
*n
)
2780 f
->ts
.type
= BT_INTEGER
;
2781 f
->ts
.kind
= n
->ts
.kind
;
2782 f
->value
.function
.name
= gfc_get_string (PREFIX ("umask_i%d"), n
->ts
.kind
);
2786 /* Resolve the g77 compatibility function UNLINK. */
2789 gfc_resolve_unlink (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
2791 f
->ts
.type
= BT_INTEGER
;
2793 f
->value
.function
.name
= gfc_get_string (PREFIX ("unlink"));
2798 gfc_resolve_ttynam (gfc_expr
*f
, gfc_expr
*unit
)
2803 f
->ts
.type
= BT_CHARACTER
;
2804 f
->ts
.kind
= gfc_default_character_kind
;
2806 if (unit
->ts
.kind
!= gfc_c_int_kind
)
2808 ts
.type
= BT_INTEGER
;
2809 ts
.kind
= gfc_c_int_kind
;
2810 ts
.u
.derived
= NULL
;
2812 gfc_convert_type (unit
, &ts
, 2);
2815 f
->value
.function
.name
= gfc_get_string (PREFIX ("ttynam"));
2820 gfc_resolve_unpack (gfc_expr
*f
, gfc_expr
*vector
, gfc_expr
*mask
,
2821 gfc_expr
*field ATTRIBUTE_UNUSED
)
2823 if (vector
->ts
.type
== BT_CHARACTER
&& vector
->ref
)
2824 gfc_resolve_substring_charlen (vector
);
2827 f
->rank
= mask
->rank
;
2828 resolve_mask_arg (mask
);
2830 if (vector
->ts
.type
== BT_CHARACTER
)
2832 if (vector
->ts
.kind
== 1)
2833 f
->value
.function
.name
2834 = gfc_get_string (PREFIX ("unpack%d_char"), field
->rank
> 0 ? 1 : 0);
2836 f
->value
.function
.name
2837 = gfc_get_string (PREFIX ("unpack%d_char%d"),
2838 field
->rank
> 0 ? 1 : 0, vector
->ts
.kind
);
2841 f
->value
.function
.name
2842 = gfc_get_string (PREFIX ("unpack%d"), field
->rank
> 0 ? 1 : 0);
2847 gfc_resolve_verify (gfc_expr
*f
, gfc_expr
*string
,
2848 gfc_expr
*set ATTRIBUTE_UNUSED
,
2849 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2851 f
->ts
.type
= BT_INTEGER
;
2853 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2855 f
->ts
.kind
= gfc_default_integer_kind
;
2856 f
->value
.function
.name
= gfc_get_string ("__verify_%d", string
->ts
.kind
);
2861 gfc_resolve_xor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
2863 f
->ts
.type
= i
->ts
.type
;
2864 f
->ts
.kind
= gfc_kind_max (i
, j
);
2866 if (i
->ts
.kind
!= j
->ts
.kind
)
2868 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
2869 gfc_convert_type (j
, &i
->ts
, 2);
2871 gfc_convert_type (i
, &j
->ts
, 2);
2874 f
->value
.function
.name
2875 = gfc_get_string ("__xor_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
2879 /* Intrinsic subroutine resolution. */
2882 gfc_resolve_alarm_sub (gfc_code
*c
)
2885 gfc_expr
*seconds
, *handler
;
2889 seconds
= c
->ext
.actual
->expr
;
2890 handler
= c
->ext
.actual
->next
->expr
;
2891 ts
.type
= BT_INTEGER
;
2892 ts
.kind
= gfc_c_int_kind
;
2894 /* handler can be either BT_INTEGER or BT_PROCEDURE.
2895 In all cases, the status argument is of default integer kind
2896 (enforced in check.c) so that the function suffix is fixed. */
2897 if (handler
->ts
.type
== BT_INTEGER
)
2899 if (handler
->ts
.kind
!= gfc_c_int_kind
)
2900 gfc_convert_type (handler
, &ts
, 2);
2901 name
= gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
2902 gfc_default_integer_kind
);
2905 name
= gfc_get_string (PREFIX ("alarm_sub_i%d"),
2906 gfc_default_integer_kind
);
2908 if (seconds
->ts
.kind
!= gfc_c_int_kind
)
2909 gfc_convert_type (seconds
, &ts
, 2);
2911 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2915 gfc_resolve_cpu_time (gfc_code
*c
)
2918 name
= gfc_get_string (PREFIX ("cpu_time_%d"), c
->ext
.actual
->expr
->ts
.kind
);
2919 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2923 /* Create a formal arglist based on an actual one and set the INTENTs given. */
2925 static gfc_formal_arglist
*
2926 create_formal_for_intents (gfc_actual_arglist
* actual
, const sym_intent
* ints
)
2928 gfc_formal_arglist
* head
;
2929 gfc_formal_arglist
* tail
;
2935 head
= tail
= gfc_get_formal_arglist ();
2936 for (i
= 0; actual
; actual
= actual
->next
, tail
= tail
->next
, ++i
)
2940 sym
= gfc_new_symbol ("dummyarg", NULL
);
2941 sym
->ts
= actual
->expr
->ts
;
2943 sym
->attr
.intent
= ints
[i
];
2947 tail
->next
= gfc_get_formal_arglist ();
2955 gfc_resolve_atomic_def (gfc_code
*c
)
2957 const char *name
= "atomic_define";
2958 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2963 gfc_resolve_atomic_ref (gfc_code
*c
)
2965 const char *name
= "atomic_ref";
2966 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2971 gfc_resolve_mvbits (gfc_code
*c
)
2973 static const sym_intent INTENTS
[] = {INTENT_IN
, INTENT_IN
, INTENT_IN
,
2974 INTENT_INOUT
, INTENT_IN
};
2980 /* FROMPOS, LEN and TOPOS are restricted to small values. As such,
2981 they will be converted so that they fit into a C int. */
2982 ts
.type
= BT_INTEGER
;
2983 ts
.kind
= gfc_c_int_kind
;
2984 if (c
->ext
.actual
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
2985 gfc_convert_type (c
->ext
.actual
->next
->expr
, &ts
, 2);
2986 if (c
->ext
.actual
->next
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
2987 gfc_convert_type (c
->ext
.actual
->next
->next
->expr
, &ts
, 2);
2988 if (c
->ext
.actual
->next
->next
->next
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
2989 gfc_convert_type (c
->ext
.actual
->next
->next
->next
->next
->expr
, &ts
, 2);
2991 /* TO and FROM are guaranteed to have the same kind parameter. */
2992 name
= gfc_get_string (PREFIX ("mvbits_i%d"),
2993 c
->ext
.actual
->expr
->ts
.kind
);
2994 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2995 /* Mark as elemental subroutine as this does not happen automatically. */
2996 c
->resolved_sym
->attr
.elemental
= 1;
2998 /* Create a dummy formal arglist so the INTENTs are known later for purpose
2999 of creating temporaries. */
3000 c
->resolved_sym
->formal
= create_formal_for_intents (c
->ext
.actual
, INTENTS
);
3005 gfc_resolve_random_number (gfc_code
*c
)
3010 kind
= c
->ext
.actual
->expr
->ts
.kind
;
3011 if (c
->ext
.actual
->expr
->rank
== 0)
3012 name
= gfc_get_string (PREFIX ("random_r%d"), kind
);
3014 name
= gfc_get_string (PREFIX ("arandom_r%d"), kind
);
3016 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3021 gfc_resolve_random_seed (gfc_code
*c
)
3025 name
= gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind
);
3026 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3031 gfc_resolve_rename_sub (gfc_code
*c
)
3036 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3037 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3039 kind
= gfc_default_integer_kind
;
3041 name
= gfc_get_string (PREFIX ("rename_i%d_sub"), kind
);
3042 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3047 gfc_resolve_kill_sub (gfc_code
*c
)
3052 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3053 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3055 kind
= gfc_default_integer_kind
;
3057 name
= gfc_get_string (PREFIX ("kill_i%d_sub"), kind
);
3058 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3063 gfc_resolve_link_sub (gfc_code
*c
)
3068 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3069 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3071 kind
= gfc_default_integer_kind
;
3073 name
= gfc_get_string (PREFIX ("link_i%d_sub"), kind
);
3074 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3079 gfc_resolve_symlnk_sub (gfc_code
*c
)
3084 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3085 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3087 kind
= gfc_default_integer_kind
;
3089 name
= gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind
);
3090 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3094 /* G77 compatibility subroutines dtime() and etime(). */
3097 gfc_resolve_dtime_sub (gfc_code
*c
)
3100 name
= gfc_get_string (PREFIX ("dtime_sub"));
3101 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3105 gfc_resolve_etime_sub (gfc_code
*c
)
3108 name
= gfc_get_string (PREFIX ("etime_sub"));
3109 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3113 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
3116 gfc_resolve_itime (gfc_code
*c
)
3119 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
3120 gfc_default_integer_kind
));
3124 gfc_resolve_idate (gfc_code
*c
)
3127 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
3128 gfc_default_integer_kind
));
3132 gfc_resolve_ltime (gfc_code
*c
)
3135 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
3136 gfc_default_integer_kind
));
3140 gfc_resolve_gmtime (gfc_code
*c
)
3143 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
3144 gfc_default_integer_kind
));
3148 /* G77 compatibility subroutine second(). */
3151 gfc_resolve_second_sub (gfc_code
*c
)
3154 name
= gfc_get_string (PREFIX ("second_sub"));
3155 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3160 gfc_resolve_sleep_sub (gfc_code
*c
)
3165 if (c
->ext
.actual
->expr
!= NULL
)
3166 kind
= c
->ext
.actual
->expr
->ts
.kind
;
3168 kind
= gfc_default_integer_kind
;
3170 name
= gfc_get_string (PREFIX ("sleep_i%d_sub"), kind
);
3171 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3175 /* G77 compatibility function srand(). */
3178 gfc_resolve_srand (gfc_code
*c
)
3181 name
= gfc_get_string (PREFIX ("srand"));
3182 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3186 /* Resolve the getarg intrinsic subroutine. */
3189 gfc_resolve_getarg (gfc_code
*c
)
3193 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_default_integer_kind
)
3198 ts
.type
= BT_INTEGER
;
3199 ts
.kind
= gfc_default_integer_kind
;
3201 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3204 name
= gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind
);
3205 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3209 /* Resolve the getcwd intrinsic subroutine. */
3212 gfc_resolve_getcwd_sub (gfc_code
*c
)
3217 if (c
->ext
.actual
->next
->expr
!= NULL
)
3218 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3220 kind
= gfc_default_integer_kind
;
3222 name
= gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind
);
3223 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3227 /* Resolve the get_command intrinsic subroutine. */
3230 gfc_resolve_get_command (gfc_code
*c
)
3234 kind
= gfc_default_integer_kind
;
3235 name
= gfc_get_string (PREFIX ("get_command_i%d"), kind
);
3236 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3240 /* Resolve the get_command_argument intrinsic subroutine. */
3243 gfc_resolve_get_command_argument (gfc_code
*c
)
3247 kind
= gfc_default_integer_kind
;
3248 name
= gfc_get_string (PREFIX ("get_command_argument_i%d"), kind
);
3249 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3253 /* Resolve the get_environment_variable intrinsic subroutine. */
3256 gfc_resolve_get_environment_variable (gfc_code
*code
)
3260 kind
= gfc_default_integer_kind
;
3261 name
= gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind
);
3262 code
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3267 gfc_resolve_signal_sub (gfc_code
*c
)
3270 gfc_expr
*number
, *handler
, *status
;
3274 number
= c
->ext
.actual
->expr
;
3275 handler
= c
->ext
.actual
->next
->expr
;
3276 status
= c
->ext
.actual
->next
->next
->expr
;
3277 ts
.type
= BT_INTEGER
;
3278 ts
.kind
= gfc_c_int_kind
;
3280 /* handler can be either BT_INTEGER or BT_PROCEDURE */
3281 if (handler
->ts
.type
== BT_INTEGER
)
3283 if (handler
->ts
.kind
!= gfc_c_int_kind
)
3284 gfc_convert_type (handler
, &ts
, 2);
3285 name
= gfc_get_string (PREFIX ("signal_sub_int"));
3288 name
= gfc_get_string (PREFIX ("signal_sub"));
3290 if (number
->ts
.kind
!= gfc_c_int_kind
)
3291 gfc_convert_type (number
, &ts
, 2);
3292 if (status
!= NULL
&& status
->ts
.kind
!= gfc_c_int_kind
)
3293 gfc_convert_type (status
, &ts
, 2);
3295 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3299 /* Resolve the SYSTEM intrinsic subroutine. */
3302 gfc_resolve_system_sub (gfc_code
*c
)
3305 name
= gfc_get_string (PREFIX ("system_sub"));
3306 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3310 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
3313 gfc_resolve_system_clock (gfc_code
*c
)
3317 gfc_expr
*count
= c
->ext
.actual
->expr
;
3318 gfc_expr
*count_max
= c
->ext
.actual
->next
->next
->expr
;
3320 /* The INTEGER(8) version has higher precision, it is used if both COUNT
3321 and COUNT_MAX can hold 64-bit values, or are absent. */
3322 if ((!count
|| count
->ts
.kind
>= 8)
3323 && (!count_max
|| count_max
->ts
.kind
>= 8))
3326 kind
= gfc_default_integer_kind
;
3328 name
= gfc_get_string (PREFIX ("system_clock_%d"), kind
);
3329 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3333 /* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine. */
3335 gfc_resolve_execute_command_line (gfc_code
*c
)
3338 name
= gfc_get_string (PREFIX ("execute_command_line_i%d"),
3339 gfc_default_integer_kind
);
3340 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3344 /* Resolve the EXIT intrinsic subroutine. */
3347 gfc_resolve_exit (gfc_code
*c
)
3354 /* The STATUS argument has to be of default kind. If it is not,
3356 ts
.type
= BT_INTEGER
;
3357 ts
.kind
= gfc_default_integer_kind
;
3358 n
= c
->ext
.actual
->expr
;
3359 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3360 gfc_convert_type (n
, &ts
, 2);
3362 name
= gfc_get_string (PREFIX ("exit_i%d"), ts
.kind
);
3363 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3367 /* Resolve the FLUSH intrinsic subroutine. */
3370 gfc_resolve_flush (gfc_code
*c
)
3377 ts
.type
= BT_INTEGER
;
3378 ts
.kind
= gfc_default_integer_kind
;
3379 n
= c
->ext
.actual
->expr
;
3380 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3381 gfc_convert_type (n
, &ts
, 2);
3383 name
= gfc_get_string (PREFIX ("flush_i%d"), ts
.kind
);
3384 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3389 gfc_resolve_free (gfc_code
*c
)
3395 ts
.type
= BT_INTEGER
;
3396 ts
.kind
= gfc_index_integer_kind
;
3397 n
= c
->ext
.actual
->expr
;
3398 if (n
->ts
.kind
!= ts
.kind
)
3399 gfc_convert_type (n
, &ts
, 2);
3401 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("free"));
3406 gfc_resolve_ctime_sub (gfc_code
*c
)
3411 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3412 if (c
->ext
.actual
->expr
->ts
.kind
!= 8)
3414 ts
.type
= BT_INTEGER
;
3416 ts
.u
.derived
= NULL
;
3418 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3421 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3426 gfc_resolve_fdate_sub (gfc_code
*c
)
3428 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3433 gfc_resolve_gerror (gfc_code
*c
)
3435 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3440 gfc_resolve_getlog (gfc_code
*c
)
3442 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3447 gfc_resolve_hostnm_sub (gfc_code
*c
)
3452 if (c
->ext
.actual
->next
->expr
!= NULL
)
3453 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3455 kind
= gfc_default_integer_kind
;
3457 name
= gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind
);
3458 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3463 gfc_resolve_perror (gfc_code
*c
)
3465 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3468 /* Resolve the STAT and FSTAT intrinsic subroutines. */
3471 gfc_resolve_stat_sub (gfc_code
*c
)
3474 name
= gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind
);
3475 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3480 gfc_resolve_lstat_sub (gfc_code
*c
)
3483 name
= gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind
);
3484 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3489 gfc_resolve_fstat_sub (gfc_code
*c
)
3495 u
= c
->ext
.actual
->expr
;
3496 ts
= &c
->ext
.actual
->next
->expr
->ts
;
3497 if (u
->ts
.kind
!= ts
->kind
)
3498 gfc_convert_type (u
, ts
, 2);
3499 name
= gfc_get_string (PREFIX ("fstat_i%d_sub"), ts
->kind
);
3500 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3505 gfc_resolve_fgetc_sub (gfc_code
*c
)
3512 u
= c
->ext
.actual
->expr
;
3513 st
= c
->ext
.actual
->next
->next
->expr
;
3515 if (u
->ts
.kind
!= gfc_c_int_kind
)
3517 ts
.type
= BT_INTEGER
;
3518 ts
.kind
= gfc_c_int_kind
;
3519 ts
.u
.derived
= NULL
;
3521 gfc_convert_type (u
, &ts
, 2);
3525 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), st
->ts
.kind
);
3527 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind
);
3529 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3534 gfc_resolve_fget_sub (gfc_code
*c
)
3539 st
= c
->ext
.actual
->next
->expr
;
3541 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), st
->ts
.kind
);
3543 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind
);
3545 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3550 gfc_resolve_fputc_sub (gfc_code
*c
)
3557 u
= c
->ext
.actual
->expr
;
3558 st
= c
->ext
.actual
->next
->next
->expr
;
3560 if (u
->ts
.kind
!= gfc_c_int_kind
)
3562 ts
.type
= BT_INTEGER
;
3563 ts
.kind
= gfc_c_int_kind
;
3564 ts
.u
.derived
= NULL
;
3566 gfc_convert_type (u
, &ts
, 2);
3570 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), st
->ts
.kind
);
3572 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind
);
3574 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3579 gfc_resolve_fput_sub (gfc_code
*c
)
3584 st
= c
->ext
.actual
->next
->expr
;
3586 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), st
->ts
.kind
);
3588 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind
);
3590 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3595 gfc_resolve_fseek_sub (gfc_code
*c
)
3603 unit
= c
->ext
.actual
->expr
;
3604 offset
= c
->ext
.actual
->next
->expr
;
3605 whence
= c
->ext
.actual
->next
->next
->expr
;
3607 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3609 ts
.type
= BT_INTEGER
;
3610 ts
.kind
= gfc_c_int_kind
;
3611 ts
.u
.derived
= NULL
;
3613 gfc_convert_type (unit
, &ts
, 2);
3616 if (offset
->ts
.kind
!= gfc_intio_kind
)
3618 ts
.type
= BT_INTEGER
;
3619 ts
.kind
= gfc_intio_kind
;
3620 ts
.u
.derived
= NULL
;
3622 gfc_convert_type (offset
, &ts
, 2);
3625 if (whence
->ts
.kind
!= gfc_c_int_kind
)
3627 ts
.type
= BT_INTEGER
;
3628 ts
.kind
= gfc_c_int_kind
;
3629 ts
.u
.derived
= NULL
;
3631 gfc_convert_type (whence
, &ts
, 2);
3634 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
3638 gfc_resolve_ftell_sub (gfc_code
*c
)
3646 unit
= c
->ext
.actual
->expr
;
3647 offset
= c
->ext
.actual
->next
->expr
;
3649 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3651 ts
.type
= BT_INTEGER
;
3652 ts
.kind
= gfc_c_int_kind
;
3653 ts
.u
.derived
= NULL
;
3655 gfc_convert_type (unit
, &ts
, 2);
3658 name
= gfc_get_string (PREFIX ("ftell_i%d_sub"), offset
->ts
.kind
);
3659 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3664 gfc_resolve_ttynam_sub (gfc_code
*c
)
3669 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
3671 ts
.type
= BT_INTEGER
;
3672 ts
.kind
= gfc_c_int_kind
;
3673 ts
.u
.derived
= NULL
;
3675 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3678 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
3682 /* Resolve the UMASK intrinsic subroutine. */
3685 gfc_resolve_umask_sub (gfc_code
*c
)
3690 if (c
->ext
.actual
->next
->expr
!= NULL
)
3691 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3693 kind
= gfc_default_integer_kind
;
3695 name
= gfc_get_string (PREFIX ("umask_i%d_sub"), kind
);
3696 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3699 /* Resolve the UNLINK intrinsic subroutine. */
3702 gfc_resolve_unlink_sub (gfc_code
*c
)
3707 if (c
->ext
.actual
->next
->expr
!= NULL
)
3708 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3710 kind
= gfc_default_integer_kind
;
3712 name
= gfc_get_string (PREFIX ("unlink_i%d_sub"), kind
);
3713 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);