1 /* Intrinsic function resolution.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught & Katherine Holcomb
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
24 /* Assign name and types to intrinsic procedures. For functions, the
25 first argument to a resolution function is an expression pointer to
26 the original function node and the rest are pointers to the
27 arguments of the function call. For subroutines, a pointer to the
28 code node is passed. The result type and library subroutine name
29 are generally set according to the function arguments. */
33 #include "coretypes.h"
36 #include "intrinsic.h"
37 #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
, ...)
54 va_start (ap
, format
);
55 vsnprintf (temp_name
, sizeof (temp_name
), format
, ap
);
57 temp_name
[sizeof (temp_name
) - 1] = 0;
59 ident
= get_identifier (temp_name
);
60 return IDENTIFIER_POINTER (ident
);
63 /* MERGE and SPREAD need to have source charlen's present for passing
64 to the result expression. */
66 check_charlen_present (gfc_expr
*source
)
68 if (source
->ts
.u
.cl
== NULL
)
69 source
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
71 if (source
->expr_type
== EXPR_CONSTANT
)
73 source
->ts
.u
.cl
->length
74 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
75 source
->value
.character
.length
);
78 else if (source
->expr_type
== EXPR_ARRAY
)
80 gfc_constructor
*c
= gfc_constructor_first (source
->value
.constructor
);
81 source
->ts
.u
.cl
->length
82 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
83 c
->expr
->value
.character
.length
);
87 /* Helper function for resolving the "mask" argument. */
90 resolve_mask_arg (gfc_expr
*mask
)
98 /* For the scalar case, coerce the mask to kind=4 unconditionally
99 (because this is the only kind we have a library function
102 if (mask
->ts
.kind
!= 4)
104 ts
.type
= BT_LOGICAL
;
106 gfc_convert_type (mask
, &ts
, 2);
111 /* In the library, we access the mask with a GFC_LOGICAL_1
112 argument. No need to waste memory if we are about to create
113 a temporary array. */
114 if (mask
->expr_type
== EXPR_OP
&& mask
->ts
.kind
!= 1)
116 ts
.type
= BT_LOGICAL
;
118 gfc_convert_type_warn (mask
, &ts
, 2, 0);
125 resolve_bound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
,
126 const char *name
, bool coarray
)
128 f
->ts
.type
= BT_INTEGER
;
130 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
132 f
->ts
.kind
= gfc_default_integer_kind
;
137 if (array
->rank
!= -1)
139 f
->shape
= gfc_get_shape (1);
140 mpz_init_set_ui (f
->shape
[0], coarray
? gfc_get_corank (array
)
145 f
->value
.function
.name
= xstrdup (name
);
150 resolve_transformational (const char *name
, gfc_expr
*f
, gfc_expr
*array
,
151 gfc_expr
*dim
, gfc_expr
*mask
)
164 resolve_mask_arg (mask
);
171 f
->rank
= array
->rank
- 1;
172 f
->shape
= gfc_copy_shape_excluding (array
->shape
, array
->rank
, dim
);
173 gfc_resolve_dim_arg (dim
);
176 f
->value
.function
.name
177 = gfc_get_string (PREFIX ("%s%s_%c%d"), prefix
, name
,
178 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
182 /********************** Resolution functions **********************/
186 gfc_resolve_abs (gfc_expr
*f
, gfc_expr
*a
)
189 if (f
->ts
.type
== BT_COMPLEX
)
190 f
->ts
.type
= BT_REAL
;
192 f
->value
.function
.name
193 = gfc_get_string ("__abs_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
198 gfc_resolve_access (gfc_expr
*f
, gfc_expr
*name ATTRIBUTE_UNUSED
,
199 gfc_expr
*mode ATTRIBUTE_UNUSED
)
201 f
->ts
.type
= BT_INTEGER
;
202 f
->ts
.kind
= gfc_c_int_kind
;
203 f
->value
.function
.name
= PREFIX ("access_func");
208 gfc_resolve_adjustl (gfc_expr
*f
, gfc_expr
*string
)
210 f
->ts
.type
= BT_CHARACTER
;
211 f
->ts
.kind
= string
->ts
.kind
;
212 f
->value
.function
.name
= gfc_get_string ("__adjustl_s%d", f
->ts
.kind
);
217 gfc_resolve_adjustr (gfc_expr
*f
, gfc_expr
*string
)
219 f
->ts
.type
= BT_CHARACTER
;
220 f
->ts
.kind
= string
->ts
.kind
;
221 f
->value
.function
.name
= gfc_get_string ("__adjustr_s%d", f
->ts
.kind
);
226 gfc_resolve_char_achar (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*kind
,
229 f
->ts
.type
= BT_CHARACTER
;
230 f
->ts
.kind
= (kind
== NULL
)
231 ? gfc_default_character_kind
: mpz_get_si (kind
->value
.integer
);
232 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
233 f
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
235 f
->value
.function
.name
= gfc_get_string (name
, f
->ts
.kind
,
236 gfc_type_letter (x
->ts
.type
),
242 gfc_resolve_achar (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*kind
)
244 gfc_resolve_char_achar (f
, x
, kind
, "__achar_%d_%c%d");
249 gfc_resolve_acos (gfc_expr
*f
, gfc_expr
*x
)
252 f
->value
.function
.name
253 = gfc_get_string ("__acos_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
258 gfc_resolve_acosh (gfc_expr
*f
, gfc_expr
*x
)
261 f
->value
.function
.name
262 = gfc_get_string ("__acosh_%c%d", gfc_type_letter (x
->ts
.type
),
268 gfc_resolve_aimag (gfc_expr
*f
, gfc_expr
*x
)
270 f
->ts
.type
= BT_REAL
;
271 f
->ts
.kind
= x
->ts
.kind
;
272 f
->value
.function
.name
273 = gfc_get_string ("__aimag_%c%d", gfc_type_letter (x
->ts
.type
),
279 gfc_resolve_and (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
281 f
->ts
.type
= i
->ts
.type
;
282 f
->ts
.kind
= gfc_kind_max (i
, j
);
284 if (i
->ts
.kind
!= j
->ts
.kind
)
286 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
287 gfc_convert_type (j
, &i
->ts
, 2);
289 gfc_convert_type (i
, &j
->ts
, 2);
292 f
->value
.function
.name
293 = gfc_get_string ("__and_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
298 gfc_resolve_aint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
303 f
->ts
.type
= a
->ts
.type
;
304 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
306 if (a
->ts
.kind
!= f
->ts
.kind
)
308 ts
.type
= f
->ts
.type
;
309 ts
.kind
= f
->ts
.kind
;
310 gfc_convert_type (a
, &ts
, 2);
312 /* The resolved name is only used for specific intrinsics where
313 the return kind is the same as the arg kind. */
314 f
->value
.function
.name
315 = gfc_get_string ("__aint_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
320 gfc_resolve_dint (gfc_expr
*f
, gfc_expr
*a
)
322 gfc_resolve_aint (f
, a
, NULL
);
327 gfc_resolve_all (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
)
333 gfc_resolve_dim_arg (dim
);
334 f
->rank
= mask
->rank
- 1;
335 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
338 f
->value
.function
.name
339 = gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask
->ts
.type
),
345 gfc_resolve_anint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
350 f
->ts
.type
= a
->ts
.type
;
351 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
353 if (a
->ts
.kind
!= f
->ts
.kind
)
355 ts
.type
= f
->ts
.type
;
356 ts
.kind
= f
->ts
.kind
;
357 gfc_convert_type (a
, &ts
, 2);
360 /* The resolved name is only used for specific intrinsics where
361 the return kind is the same as the arg kind. */
362 f
->value
.function
.name
363 = gfc_get_string ("__anint_%c%d", gfc_type_letter (a
->ts
.type
),
369 gfc_resolve_dnint (gfc_expr
*f
, gfc_expr
*a
)
371 gfc_resolve_anint (f
, a
, NULL
);
376 gfc_resolve_any (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
)
382 gfc_resolve_dim_arg (dim
);
383 f
->rank
= mask
->rank
- 1;
384 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
387 f
->value
.function
.name
388 = gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask
->ts
.type
),
394 gfc_resolve_asin (gfc_expr
*f
, gfc_expr
*x
)
397 f
->value
.function
.name
398 = gfc_get_string ("__asin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
402 gfc_resolve_asinh (gfc_expr
*f
, gfc_expr
*x
)
405 f
->value
.function
.name
406 = gfc_get_string ("__asinh_%c%d", gfc_type_letter (x
->ts
.type
),
411 gfc_resolve_atan (gfc_expr
*f
, gfc_expr
*x
)
414 f
->value
.function
.name
415 = gfc_get_string ("__atan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
419 gfc_resolve_atanh (gfc_expr
*f
, gfc_expr
*x
)
422 f
->value
.function
.name
423 = gfc_get_string ("__atanh_%c%d", gfc_type_letter (x
->ts
.type
),
428 gfc_resolve_atan2 (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
431 f
->value
.function
.name
432 = gfc_get_string ("__atan2_%c%d", gfc_type_letter (x
->ts
.type
),
437 /* Resolve the BESYN and BESJN intrinsics. */
440 gfc_resolve_besn (gfc_expr
*f
, gfc_expr
*n
, gfc_expr
*x
)
446 if (n
->ts
.kind
!= gfc_c_int_kind
)
448 ts
.type
= BT_INTEGER
;
449 ts
.kind
= gfc_c_int_kind
;
450 gfc_convert_type (n
, &ts
, 2);
452 f
->value
.function
.name
= gfc_get_string ("<intrinsic>");
457 gfc_resolve_bessel_n2 (gfc_expr
*f
, gfc_expr
*n1
, gfc_expr
*n2
, gfc_expr
*x
)
464 if (n1
->expr_type
== EXPR_CONSTANT
&& n2
->expr_type
== EXPR_CONSTANT
)
466 f
->shape
= gfc_get_shape (1);
467 mpz_init (f
->shape
[0]);
468 mpz_sub (f
->shape
[0], n2
->value
.integer
, n1
->value
.integer
);
469 mpz_add_ui (f
->shape
[0], f
->shape
[0], 1);
472 if (n1
->ts
.kind
!= gfc_c_int_kind
)
474 ts
.type
= BT_INTEGER
;
475 ts
.kind
= gfc_c_int_kind
;
476 gfc_convert_type (n1
, &ts
, 2);
479 if (n2
->ts
.kind
!= gfc_c_int_kind
)
481 ts
.type
= BT_INTEGER
;
482 ts
.kind
= gfc_c_int_kind
;
483 gfc_convert_type (n2
, &ts
, 2);
486 if (f
->value
.function
.isym
->id
== GFC_ISYM_JN2
)
487 f
->value
.function
.name
= gfc_get_string (PREFIX ("bessel_jn_r%d"),
490 f
->value
.function
.name
= gfc_get_string (PREFIX ("bessel_yn_r%d"),
496 gfc_resolve_btest (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos
)
498 f
->ts
.type
= BT_LOGICAL
;
499 f
->ts
.kind
= gfc_default_logical_kind
;
500 f
->value
.function
.name
501 = gfc_get_string ("__btest_%d_%d", i
->ts
.kind
, pos
->ts
.kind
);
506 gfc_resolve_ceiling (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
508 f
->ts
.type
= BT_INTEGER
;
509 f
->ts
.kind
= (kind
== NULL
)
510 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
511 f
->value
.function
.name
512 = gfc_get_string ("__ceiling_%d_%c%d", f
->ts
.kind
,
513 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
518 gfc_resolve_char (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
520 gfc_resolve_char_achar (f
, a
, kind
, "__char_%d_%c%d");
525 gfc_resolve_chdir (gfc_expr
*f
, gfc_expr
*d ATTRIBUTE_UNUSED
)
527 f
->ts
.type
= BT_INTEGER
;
528 f
->ts
.kind
= gfc_default_integer_kind
;
529 f
->value
.function
.name
= gfc_get_string (PREFIX ("chdir_i%d"), f
->ts
.kind
);
534 gfc_resolve_chdir_sub (gfc_code
*c
)
539 if (c
->ext
.actual
->next
->expr
!= NULL
)
540 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
542 kind
= gfc_default_integer_kind
;
544 name
= gfc_get_string (PREFIX ("chdir_i%d_sub"), kind
);
545 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
550 gfc_resolve_chmod (gfc_expr
*f
, gfc_expr
*name ATTRIBUTE_UNUSED
,
551 gfc_expr
*mode ATTRIBUTE_UNUSED
)
553 f
->ts
.type
= BT_INTEGER
;
554 f
->ts
.kind
= gfc_c_int_kind
;
555 f
->value
.function
.name
= PREFIX ("chmod_func");
560 gfc_resolve_chmod_sub (gfc_code
*c
)
565 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
566 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
568 kind
= gfc_default_integer_kind
;
570 name
= gfc_get_string (PREFIX ("chmod_i%d_sub"), kind
);
571 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
576 gfc_resolve_cmplx (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*kind
)
578 f
->ts
.type
= BT_COMPLEX
;
579 f
->ts
.kind
= (kind
== NULL
)
580 ? gfc_default_real_kind
: mpz_get_si (kind
->value
.integer
);
583 f
->value
.function
.name
584 = gfc_get_string ("__cmplx0_%d_%c%d", f
->ts
.kind
,
585 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
587 f
->value
.function
.name
588 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f
->ts
.kind
,
589 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
,
590 gfc_type_letter (y
->ts
.type
), y
->ts
.kind
);
595 gfc_resolve_dcmplx (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
)
597 gfc_resolve_cmplx (f
, x
, y
, gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
598 gfc_default_double_kind
));
603 gfc_resolve_complex (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
)
607 if (x
->ts
.type
== BT_INTEGER
)
609 if (y
->ts
.type
== BT_INTEGER
)
610 kind
= gfc_default_real_kind
;
616 if (y
->ts
.type
== BT_REAL
)
617 kind
= (x
->ts
.kind
> y
->ts
.kind
) ? x
->ts
.kind
: y
->ts
.kind
;
622 f
->ts
.type
= BT_COMPLEX
;
624 f
->value
.function
.name
625 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f
->ts
.kind
,
626 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
,
627 gfc_type_letter (y
->ts
.type
), y
->ts
.kind
);
632 gfc_resolve_conjg (gfc_expr
*f
, gfc_expr
*x
)
635 f
->value
.function
.name
= gfc_get_string ("__conjg_%d", x
->ts
.kind
);
640 gfc_resolve_cos (gfc_expr
*f
, gfc_expr
*x
)
643 f
->value
.function
.name
644 = gfc_get_string ("__cos_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
649 gfc_resolve_cosh (gfc_expr
*f
, gfc_expr
*x
)
652 f
->value
.function
.name
653 = gfc_get_string ("__cosh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
658 gfc_resolve_count (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
660 f
->ts
.type
= BT_INTEGER
;
662 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
664 f
->ts
.kind
= gfc_default_integer_kind
;
668 f
->rank
= mask
->rank
- 1;
669 gfc_resolve_dim_arg (dim
);
670 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
673 resolve_mask_arg (mask
);
675 f
->value
.function
.name
676 = gfc_get_string (PREFIX ("count_%d_%c"), f
->ts
.kind
,
677 gfc_type_letter (mask
->ts
.type
));
682 gfc_resolve_cshift (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*shift
,
687 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
688 gfc_resolve_substring_charlen (array
);
691 f
->rank
= array
->rank
;
692 f
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
699 /* If dim kind is greater than default integer we need to use the larger. */
700 m
= gfc_default_integer_kind
;
702 m
= m
< dim
->ts
.kind
? dim
->ts
.kind
: m
;
704 /* Convert shift to at least m, so we don't need
705 kind=1 and kind=2 versions of the library functions. */
706 if (shift
->ts
.kind
< m
)
710 ts
.type
= BT_INTEGER
;
712 gfc_convert_type_warn (shift
, &ts
, 2, 0);
717 if (dim
->expr_type
!= EXPR_CONSTANT
&& dim
->symtree
!= NULL
718 && dim
->symtree
->n
.sym
->attr
.optional
)
720 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
721 dim
->representation
.length
= shift
->ts
.kind
;
725 gfc_resolve_dim_arg (dim
);
726 /* Convert dim to shift's kind to reduce variations. */
727 if (dim
->ts
.kind
!= shift
->ts
.kind
)
728 gfc_convert_type_warn (dim
, &shift
->ts
, 2, 0);
732 if (array
->ts
.type
== BT_CHARACTER
)
734 if (array
->ts
.kind
== gfc_default_character_kind
)
735 f
->value
.function
.name
736 = gfc_get_string (PREFIX ("cshift%d_%d_char"), n
, shift
->ts
.kind
);
738 f
->value
.function
.name
739 = gfc_get_string (PREFIX ("cshift%d_%d_char%d"), n
, shift
->ts
.kind
,
743 f
->value
.function
.name
744 = gfc_get_string (PREFIX ("cshift%d_%d"), n
, shift
->ts
.kind
);
749 gfc_resolve_ctime (gfc_expr
*f
, gfc_expr
*time
)
754 f
->ts
.type
= BT_CHARACTER
;
755 f
->ts
.kind
= gfc_default_character_kind
;
757 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
758 if (time
->ts
.kind
!= 8)
760 ts
.type
= BT_INTEGER
;
764 gfc_convert_type (time
, &ts
, 2);
767 f
->value
.function
.name
= gfc_get_string (PREFIX ("ctime"));
772 gfc_resolve_dble (gfc_expr
*f
, gfc_expr
*a
)
774 f
->ts
.type
= BT_REAL
;
775 f
->ts
.kind
= gfc_default_double_kind
;
776 f
->value
.function
.name
777 = gfc_get_string ("__dble_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
782 gfc_resolve_dim (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
784 f
->ts
.type
= a
->ts
.type
;
786 f
->ts
.kind
= gfc_kind_max (a
,p
);
788 f
->ts
.kind
= a
->ts
.kind
;
790 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
792 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
793 gfc_convert_type (p
, &a
->ts
, 2);
795 gfc_convert_type (a
, &p
->ts
, 2);
798 f
->value
.function
.name
799 = gfc_get_string ("__dim_%c%d", gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
804 gfc_resolve_dot_product (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b
)
808 temp
.expr_type
= EXPR_OP
;
809 gfc_clear_ts (&temp
.ts
);
810 temp
.value
.op
.op
= INTRINSIC_NONE
;
811 temp
.value
.op
.op1
= a
;
812 temp
.value
.op
.op2
= b
;
813 gfc_type_convert_binary (&temp
, 1);
815 f
->value
.function
.name
816 = gfc_get_string (PREFIX ("dot_product_%c%d"),
817 gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
822 gfc_resolve_dprod (gfc_expr
*f
, gfc_expr
*a ATTRIBUTE_UNUSED
,
823 gfc_expr
*b ATTRIBUTE_UNUSED
)
825 f
->ts
.kind
= gfc_default_double_kind
;
826 f
->ts
.type
= BT_REAL
;
827 f
->value
.function
.name
= gfc_get_string ("__dprod_r%d", f
->ts
.kind
);
832 gfc_resolve_dshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j ATTRIBUTE_UNUSED
,
833 gfc_expr
*shift ATTRIBUTE_UNUSED
)
836 if (f
->value
.function
.isym
->id
== GFC_ISYM_DSHIFTL
)
837 f
->value
.function
.name
= gfc_get_string ("dshiftl_i%d", f
->ts
.kind
);
838 else if (f
->value
.function
.isym
->id
== GFC_ISYM_DSHIFTR
)
839 f
->value
.function
.name
= gfc_get_string ("dshiftr_i%d", f
->ts
.kind
);
846 gfc_resolve_eoshift (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*shift
,
847 gfc_expr
*boundary
, gfc_expr
*dim
)
851 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
852 gfc_resolve_substring_charlen (array
);
855 f
->rank
= array
->rank
;
856 f
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
861 if (boundary
&& boundary
->rank
> 0)
864 /* If dim kind is greater than default integer we need to use the larger. */
865 m
= gfc_default_integer_kind
;
867 m
= m
< dim
->ts
.kind
? dim
->ts
.kind
: m
;
869 /* Convert shift to at least m, so we don't need
870 kind=1 and kind=2 versions of the library functions. */
871 if (shift
->ts
.kind
< m
)
875 ts
.type
= BT_INTEGER
;
877 gfc_convert_type_warn (shift
, &ts
, 2, 0);
882 if (dim
->expr_type
!= EXPR_CONSTANT
&& dim
->symtree
!= NULL
883 && dim
->symtree
->n
.sym
->attr
.optional
)
885 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
886 dim
->representation
.length
= shift
->ts
.kind
;
890 gfc_resolve_dim_arg (dim
);
891 /* Convert dim to shift's kind to reduce variations. */
892 if (dim
->ts
.kind
!= shift
->ts
.kind
)
893 gfc_convert_type_warn (dim
, &shift
->ts
, 2, 0);
897 if (array
->ts
.type
== BT_CHARACTER
)
899 if (array
->ts
.kind
== gfc_default_character_kind
)
900 f
->value
.function
.name
901 = gfc_get_string (PREFIX ("eoshift%d_%d_char"), n
, shift
->ts
.kind
);
903 f
->value
.function
.name
904 = gfc_get_string (PREFIX ("eoshift%d_%d_char%d"), n
, shift
->ts
.kind
,
908 f
->value
.function
.name
909 = gfc_get_string (PREFIX ("eoshift%d_%d"), n
, shift
->ts
.kind
);
914 gfc_resolve_exp (gfc_expr
*f
, gfc_expr
*x
)
917 f
->value
.function
.name
918 = gfc_get_string ("__exp_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
923 gfc_resolve_exponent (gfc_expr
*f
, gfc_expr
*x
)
925 f
->ts
.type
= BT_INTEGER
;
926 f
->ts
.kind
= gfc_default_integer_kind
;
927 f
->value
.function
.name
= gfc_get_string ("__exponent_%d", x
->ts
.kind
);
931 /* Resolve the EXTENDS_TYPE_OF intrinsic function. */
934 gfc_resolve_extends_type_of (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*mo
)
939 /* Prevent double resolution. */
940 if (f
->ts
.type
== BT_LOGICAL
)
943 /* Replace the first argument with the corresponding vtab. */
944 if (a
->ts
.type
== BT_CLASS
)
945 gfc_add_vptr_component (a
);
946 else if (a
->ts
.type
== BT_DERIVED
)
948 vtab
= gfc_find_derived_vtab (a
->ts
.u
.derived
);
949 /* Clear the old expr. */
950 gfc_free_ref_list (a
->ref
);
951 memset (a
, '\0', sizeof (gfc_expr
));
952 /* Construct a new one. */
953 a
->expr_type
= EXPR_VARIABLE
;
954 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
959 /* Replace the second argument with the corresponding vtab. */
960 if (mo
->ts
.type
== BT_CLASS
)
961 gfc_add_vptr_component (mo
);
962 else if (mo
->ts
.type
== BT_DERIVED
)
964 vtab
= gfc_find_derived_vtab (mo
->ts
.u
.derived
);
965 /* Clear the old expr. */
966 gfc_free_ref_list (mo
->ref
);
967 memset (mo
, '\0', sizeof (gfc_expr
));
968 /* Construct a new one. */
969 mo
->expr_type
= EXPR_VARIABLE
;
970 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
975 f
->ts
.type
= BT_LOGICAL
;
978 f
->value
.function
.isym
->formal
->ts
= a
->ts
;
979 f
->value
.function
.isym
->formal
->next
->ts
= mo
->ts
;
981 /* Call library function. */
982 f
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
987 gfc_resolve_fdate (gfc_expr
*f
)
989 f
->ts
.type
= BT_CHARACTER
;
990 f
->ts
.kind
= gfc_default_character_kind
;
991 f
->value
.function
.name
= gfc_get_string (PREFIX ("fdate"));
996 gfc_resolve_floor (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
998 f
->ts
.type
= BT_INTEGER
;
999 f
->ts
.kind
= (kind
== NULL
)
1000 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
1001 f
->value
.function
.name
1002 = gfc_get_string ("__floor%d_%c%d", f
->ts
.kind
,
1003 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1008 gfc_resolve_fnum (gfc_expr
*f
, gfc_expr
*n
)
1010 f
->ts
.type
= BT_INTEGER
;
1011 f
->ts
.kind
= gfc_default_integer_kind
;
1012 if (n
->ts
.kind
!= f
->ts
.kind
)
1013 gfc_convert_type (n
, &f
->ts
, 2);
1014 f
->value
.function
.name
= gfc_get_string (PREFIX ("fnum_i%d"), f
->ts
.kind
);
1019 gfc_resolve_fraction (gfc_expr
*f
, gfc_expr
*x
)
1022 f
->value
.function
.name
= gfc_get_string ("__fraction_%d", x
->ts
.kind
);
1026 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
1029 gfc_resolve_g77_math1 (gfc_expr
*f
, gfc_expr
*x
)
1032 f
->value
.function
.name
= gfc_get_string ("<intrinsic>");
1037 gfc_resolve_gamma (gfc_expr
*f
, gfc_expr
*x
)
1040 f
->value
.function
.name
1041 = gfc_get_string ("__tgamma_%d", x
->ts
.kind
);
1046 gfc_resolve_getcwd (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
1048 f
->ts
.type
= BT_INTEGER
;
1050 f
->value
.function
.name
= gfc_get_string (PREFIX ("getcwd"));
1055 gfc_resolve_getgid (gfc_expr
*f
)
1057 f
->ts
.type
= BT_INTEGER
;
1059 f
->value
.function
.name
= gfc_get_string (PREFIX ("getgid"));
1064 gfc_resolve_getpid (gfc_expr
*f
)
1066 f
->ts
.type
= BT_INTEGER
;
1068 f
->value
.function
.name
= gfc_get_string (PREFIX ("getpid"));
1073 gfc_resolve_getuid (gfc_expr
*f
)
1075 f
->ts
.type
= BT_INTEGER
;
1077 f
->value
.function
.name
= gfc_get_string (PREFIX ("getuid"));
1082 gfc_resolve_hostnm (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
1084 f
->ts
.type
= BT_INTEGER
;
1086 f
->value
.function
.name
= gfc_get_string (PREFIX ("hostnm"));
1091 gfc_resolve_hypot (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
1094 f
->value
.function
.name
= gfc_get_string ("__hypot_r%d", x
->ts
.kind
);
1099 gfc_resolve_iall (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
1101 resolve_transformational ("iall", f
, array
, dim
, mask
);
1106 gfc_resolve_iand (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1108 /* If the kind of i and j are different, then g77 cross-promoted the
1109 kinds to the largest value. The Fortran 95 standard requires the
1111 if (i
->ts
.kind
!= j
->ts
.kind
)
1113 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1114 gfc_convert_type (j
, &i
->ts
, 2);
1116 gfc_convert_type (i
, &j
->ts
, 2);
1120 f
->value
.function
.name
= gfc_get_string ("__iand_%d", i
->ts
.kind
);
1125 gfc_resolve_iany (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
1127 resolve_transformational ("iany", f
, array
, dim
, mask
);
1132 gfc_resolve_ibclr (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
)
1135 f
->value
.function
.name
= gfc_get_string ("__ibclr_%d", i
->ts
.kind
);
1140 gfc_resolve_ibits (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
,
1141 gfc_expr
*len ATTRIBUTE_UNUSED
)
1144 f
->value
.function
.name
= gfc_get_string ("__ibits_%d", i
->ts
.kind
);
1149 gfc_resolve_ibset (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
)
1152 f
->value
.function
.name
= gfc_get_string ("__ibset_%d", i
->ts
.kind
);
1157 gfc_resolve_iachar (gfc_expr
*f
, gfc_expr
*c
, gfc_expr
*kind
)
1159 f
->ts
.type
= BT_INTEGER
;
1161 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1163 f
->ts
.kind
= gfc_default_integer_kind
;
1164 f
->value
.function
.name
= gfc_get_string ("__ichar_%d", c
->ts
.kind
);
1169 gfc_resolve_ichar (gfc_expr
*f
, gfc_expr
*c
, gfc_expr
*kind
)
1171 f
->ts
.type
= BT_INTEGER
;
1173 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1175 f
->ts
.kind
= gfc_default_integer_kind
;
1176 f
->value
.function
.name
= gfc_get_string ("__ichar_%d", c
->ts
.kind
);
1181 gfc_resolve_idnint (gfc_expr
*f
, gfc_expr
*a
)
1183 gfc_resolve_nint (f
, a
, NULL
);
1188 gfc_resolve_ierrno (gfc_expr
*f
)
1190 f
->ts
.type
= BT_INTEGER
;
1191 f
->ts
.kind
= gfc_default_integer_kind
;
1192 f
->value
.function
.name
= gfc_get_string (PREFIX ("ierrno_i%d"), f
->ts
.kind
);
1197 gfc_resolve_ieor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1199 /* If the kind of i and j are different, then g77 cross-promoted the
1200 kinds to the largest value. The Fortran 95 standard requires the
1202 if (i
->ts
.kind
!= j
->ts
.kind
)
1204 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1205 gfc_convert_type (j
, &i
->ts
, 2);
1207 gfc_convert_type (i
, &j
->ts
, 2);
1211 f
->value
.function
.name
= gfc_get_string ("__ieor_%d", i
->ts
.kind
);
1216 gfc_resolve_ior (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1218 /* If the kind of i and j are different, then g77 cross-promoted the
1219 kinds to the largest value. The Fortran 95 standard requires the
1221 if (i
->ts
.kind
!= j
->ts
.kind
)
1223 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1224 gfc_convert_type (j
, &i
->ts
, 2);
1226 gfc_convert_type (i
, &j
->ts
, 2);
1230 f
->value
.function
.name
= gfc_get_string ("__ior_%d", i
->ts
.kind
);
1235 gfc_resolve_index_func (gfc_expr
*f
, gfc_expr
*str
,
1236 gfc_expr
*sub_str ATTRIBUTE_UNUSED
, gfc_expr
*back
,
1242 f
->ts
.type
= BT_INTEGER
;
1244 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1246 f
->ts
.kind
= gfc_default_integer_kind
;
1248 if (back
&& back
->ts
.kind
!= gfc_default_integer_kind
)
1250 ts
.type
= BT_LOGICAL
;
1251 ts
.kind
= gfc_default_integer_kind
;
1252 ts
.u
.derived
= NULL
;
1254 gfc_convert_type (back
, &ts
, 2);
1257 f
->value
.function
.name
1258 = gfc_get_string ("__index_%d_i%d", str
->ts
.kind
, f
->ts
.kind
);
1263 gfc_resolve_int (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1265 f
->ts
.type
= BT_INTEGER
;
1266 f
->ts
.kind
= (kind
== NULL
)
1267 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
1268 f
->value
.function
.name
1269 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1270 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1275 gfc_resolve_int2 (gfc_expr
*f
, gfc_expr
*a
)
1277 f
->ts
.type
= BT_INTEGER
;
1279 f
->value
.function
.name
1280 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1281 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1286 gfc_resolve_int8 (gfc_expr
*f
, gfc_expr
*a
)
1288 f
->ts
.type
= BT_INTEGER
;
1290 f
->value
.function
.name
1291 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1292 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1297 gfc_resolve_long (gfc_expr
*f
, gfc_expr
*a
)
1299 f
->ts
.type
= BT_INTEGER
;
1301 f
->value
.function
.name
1302 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1303 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1308 gfc_resolve_iparity (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
1310 resolve_transformational ("iparity", f
, array
, dim
, mask
);
1315 gfc_resolve_isatty (gfc_expr
*f
, gfc_expr
*u
)
1320 f
->ts
.type
= BT_LOGICAL
;
1321 f
->ts
.kind
= gfc_default_integer_kind
;
1322 if (u
->ts
.kind
!= gfc_c_int_kind
)
1324 ts
.type
= BT_INTEGER
;
1325 ts
.kind
= gfc_c_int_kind
;
1326 ts
.u
.derived
= NULL
;
1328 gfc_convert_type (u
, &ts
, 2);
1331 f
->value
.function
.name
= gfc_get_string (PREFIX ("isatty_l%d"), f
->ts
.kind
);
1336 gfc_resolve_ishft (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1339 f
->value
.function
.name
1340 = gfc_get_string ("__ishft_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1345 gfc_resolve_rshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1348 f
->value
.function
.name
1349 = gfc_get_string ("__rshift_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1354 gfc_resolve_lshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1357 f
->value
.function
.name
1358 = gfc_get_string ("__lshift_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1363 gfc_resolve_ishftc (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
1367 s_kind
= (size
== NULL
) ? gfc_default_integer_kind
: size
->ts
.kind
;
1370 f
->value
.function
.name
1371 = gfc_get_string ("__ishftc_%d_%d_%d", i
->ts
.kind
, shift
->ts
.kind
, s_kind
);
1376 gfc_resolve_kill (gfc_expr
*f
, gfc_expr
*p ATTRIBUTE_UNUSED
,
1377 gfc_expr
*s ATTRIBUTE_UNUSED
)
1379 f
->ts
.type
= BT_INTEGER
;
1380 f
->ts
.kind
= gfc_default_integer_kind
;
1381 f
->value
.function
.name
= gfc_get_string (PREFIX ("kill_i%d"), f
->ts
.kind
);
1386 gfc_resolve_lbound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
1388 resolve_bound (f
, array
, dim
, kind
, "__lbound", false);
1393 gfc_resolve_lcobound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
1395 resolve_bound (f
, array
, dim
, kind
, "__lcobound", true);
1400 gfc_resolve_len (gfc_expr
*f
, gfc_expr
*string
, gfc_expr
*kind
)
1402 f
->ts
.type
= BT_INTEGER
;
1404 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1406 f
->ts
.kind
= gfc_default_integer_kind
;
1407 f
->value
.function
.name
1408 = gfc_get_string ("__len_%d_i%d", string
->ts
.kind
,
1409 gfc_default_integer_kind
);
1414 gfc_resolve_len_trim (gfc_expr
*f
, gfc_expr
*string
, gfc_expr
*kind
)
1416 f
->ts
.type
= BT_INTEGER
;
1418 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1420 f
->ts
.kind
= gfc_default_integer_kind
;
1421 f
->value
.function
.name
= gfc_get_string ("__len_trim%d", string
->ts
.kind
);
1426 gfc_resolve_lgamma (gfc_expr
*f
, gfc_expr
*x
)
1429 f
->value
.function
.name
1430 = gfc_get_string ("__lgamma_%d", x
->ts
.kind
);
1435 gfc_resolve_link (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
1436 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
1438 f
->ts
.type
= BT_INTEGER
;
1439 f
->ts
.kind
= gfc_default_integer_kind
;
1440 f
->value
.function
.name
= gfc_get_string (PREFIX ("link_i%d"), f
->ts
.kind
);
1445 gfc_resolve_loc (gfc_expr
*f
, gfc_expr
*x
)
1447 f
->ts
.type
= BT_INTEGER
;
1448 f
->ts
.kind
= gfc_index_integer_kind
;
1449 f
->value
.function
.name
= gfc_get_string ("__loc_%d", x
->ts
.kind
);
1454 gfc_resolve_log (gfc_expr
*f
, gfc_expr
*x
)
1457 f
->value
.function
.name
1458 = gfc_get_string ("__log_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1463 gfc_resolve_log10 (gfc_expr
*f
, gfc_expr
*x
)
1466 f
->value
.function
.name
1467 = gfc_get_string ("__log10_%c%d", gfc_type_letter (x
->ts
.type
),
1473 gfc_resolve_logical (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1475 f
->ts
.type
= BT_LOGICAL
;
1476 f
->ts
.kind
= (kind
== NULL
)
1477 ? gfc_default_logical_kind
: mpz_get_si (kind
->value
.integer
);
1480 f
->value
.function
.name
1481 = gfc_get_string ("__logical_%d_%c%d", f
->ts
.kind
,
1482 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1487 gfc_resolve_malloc (gfc_expr
*f
, gfc_expr
*size
)
1489 if (size
->ts
.kind
< gfc_index_integer_kind
)
1494 ts
.type
= BT_INTEGER
;
1495 ts
.kind
= gfc_index_integer_kind
;
1496 gfc_convert_type_warn (size
, &ts
, 2, 0);
1499 f
->ts
.type
= BT_INTEGER
;
1500 f
->ts
.kind
= gfc_index_integer_kind
;
1501 f
->value
.function
.name
= gfc_get_string (PREFIX ("malloc"));
1506 gfc_resolve_matmul (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b
)
1510 if (a
->ts
.type
== BT_LOGICAL
&& b
->ts
.type
== BT_LOGICAL
)
1512 f
->ts
.type
= BT_LOGICAL
;
1513 f
->ts
.kind
= gfc_default_logical_kind
;
1517 temp
.expr_type
= EXPR_OP
;
1518 gfc_clear_ts (&temp
.ts
);
1519 temp
.value
.op
.op
= INTRINSIC_NONE
;
1520 temp
.value
.op
.op1
= a
;
1521 temp
.value
.op
.op2
= b
;
1522 gfc_type_convert_binary (&temp
, 1);
1526 f
->rank
= (a
->rank
== 2 && b
->rank
== 2) ? 2 : 1;
1528 if (a
->rank
== 2 && b
->rank
== 2)
1530 if (a
->shape
&& b
->shape
)
1532 f
->shape
= gfc_get_shape (f
->rank
);
1533 mpz_init_set (f
->shape
[0], a
->shape
[0]);
1534 mpz_init_set (f
->shape
[1], b
->shape
[1]);
1537 else if (a
->rank
== 1)
1541 f
->shape
= gfc_get_shape (f
->rank
);
1542 mpz_init_set (f
->shape
[0], b
->shape
[1]);
1547 /* b->rank == 1 and a->rank == 2 here, all other cases have
1548 been caught in check.c. */
1551 f
->shape
= gfc_get_shape (f
->rank
);
1552 mpz_init_set (f
->shape
[0], a
->shape
[0]);
1556 f
->value
.function
.name
1557 = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f
->ts
.type
),
1563 gfc_resolve_minmax (const char *name
, gfc_expr
*f
, gfc_actual_arglist
*args
)
1565 gfc_actual_arglist
*a
;
1567 f
->ts
.type
= args
->expr
->ts
.type
;
1568 f
->ts
.kind
= args
->expr
->ts
.kind
;
1569 /* Find the largest type kind. */
1570 for (a
= args
->next
; a
; a
= a
->next
)
1572 if (a
->expr
->ts
.kind
> f
->ts
.kind
)
1573 f
->ts
.kind
= a
->expr
->ts
.kind
;
1576 /* Convert all parameters to the required kind. */
1577 for (a
= args
; a
; a
= a
->next
)
1579 if (a
->expr
->ts
.kind
!= f
->ts
.kind
)
1580 gfc_convert_type (a
->expr
, &f
->ts
, 2);
1583 f
->value
.function
.name
1584 = gfc_get_string (name
, gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
1589 gfc_resolve_max (gfc_expr
*f
, gfc_actual_arglist
*args
)
1591 gfc_resolve_minmax ("__max_%c%d", f
, args
);
1596 gfc_resolve_maxloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1602 f
->ts
.type
= BT_INTEGER
;
1603 f
->ts
.kind
= gfc_default_integer_kind
;
1608 f
->shape
= gfc_get_shape (1);
1609 mpz_init_set_si (f
->shape
[0], array
->rank
);
1613 f
->rank
= array
->rank
- 1;
1614 gfc_resolve_dim_arg (dim
);
1615 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1617 idim
= (int) mpz_get_si (dim
->value
.integer
);
1618 f
->shape
= gfc_get_shape (f
->rank
);
1619 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1621 if (i
== (idim
- 1))
1623 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1630 if (mask
->rank
== 0)
1635 resolve_mask_arg (mask
);
1640 f
->value
.function
.name
1641 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name
, dim
!= NULL
, f
->ts
.kind
,
1642 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1647 gfc_resolve_maxval (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1657 f
->rank
= array
->rank
- 1;
1658 gfc_resolve_dim_arg (dim
);
1660 if (f
->rank
&& array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1662 idim
= (int) mpz_get_si (dim
->value
.integer
);
1663 f
->shape
= gfc_get_shape (f
->rank
);
1664 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1666 if (i
== (idim
- 1))
1668 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1675 if (mask
->rank
== 0)
1680 resolve_mask_arg (mask
);
1685 f
->value
.function
.name
1686 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
1687 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1692 gfc_resolve_mclock (gfc_expr
*f
)
1694 f
->ts
.type
= BT_INTEGER
;
1696 f
->value
.function
.name
= PREFIX ("mclock");
1701 gfc_resolve_mclock8 (gfc_expr
*f
)
1703 f
->ts
.type
= BT_INTEGER
;
1705 f
->value
.function
.name
= PREFIX ("mclock8");
1710 gfc_resolve_mask (gfc_expr
*f
, gfc_expr
*i ATTRIBUTE_UNUSED
,
1713 f
->ts
.type
= BT_INTEGER
;
1714 f
->ts
.kind
= kind
? mpz_get_si (kind
->value
.integer
)
1715 : gfc_default_integer_kind
;
1717 if (f
->value
.function
.isym
->id
== GFC_ISYM_MASKL
)
1718 f
->value
.function
.name
= gfc_get_string ("__maskl_i%d", f
->ts
.kind
);
1720 f
->value
.function
.name
= gfc_get_string ("__maskr_i%d", f
->ts
.kind
);
1725 gfc_resolve_merge (gfc_expr
*f
, gfc_expr
*tsource
,
1726 gfc_expr
*fsource ATTRIBUTE_UNUSED
,
1727 gfc_expr
*mask ATTRIBUTE_UNUSED
)
1729 if (tsource
->ts
.type
== BT_CHARACTER
&& tsource
->ref
)
1730 gfc_resolve_substring_charlen (tsource
);
1732 if (fsource
->ts
.type
== BT_CHARACTER
&& fsource
->ref
)
1733 gfc_resolve_substring_charlen (fsource
);
1735 if (tsource
->ts
.type
== BT_CHARACTER
)
1736 check_charlen_present (tsource
);
1738 f
->ts
= tsource
->ts
;
1739 f
->value
.function
.name
1740 = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource
->ts
.type
),
1746 gfc_resolve_merge_bits (gfc_expr
*f
, gfc_expr
*i
,
1747 gfc_expr
*j ATTRIBUTE_UNUSED
,
1748 gfc_expr
*mask ATTRIBUTE_UNUSED
)
1751 f
->value
.function
.name
= gfc_get_string ("__merge_bits_i%d", i
->ts
.kind
);
1756 gfc_resolve_min (gfc_expr
*f
, gfc_actual_arglist
*args
)
1758 gfc_resolve_minmax ("__min_%c%d", f
, args
);
1763 gfc_resolve_minloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1769 f
->ts
.type
= BT_INTEGER
;
1770 f
->ts
.kind
= gfc_default_integer_kind
;
1775 f
->shape
= gfc_get_shape (1);
1776 mpz_init_set_si (f
->shape
[0], array
->rank
);
1780 f
->rank
= array
->rank
- 1;
1781 gfc_resolve_dim_arg (dim
);
1782 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1784 idim
= (int) mpz_get_si (dim
->value
.integer
);
1785 f
->shape
= gfc_get_shape (f
->rank
);
1786 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1788 if (i
== (idim
- 1))
1790 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1797 if (mask
->rank
== 0)
1802 resolve_mask_arg (mask
);
1807 f
->value
.function
.name
1808 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name
, dim
!= NULL
, f
->ts
.kind
,
1809 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1814 gfc_resolve_minval (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1824 f
->rank
= array
->rank
- 1;
1825 gfc_resolve_dim_arg (dim
);
1827 if (f
->rank
&& array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1829 idim
= (int) mpz_get_si (dim
->value
.integer
);
1830 f
->shape
= gfc_get_shape (f
->rank
);
1831 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1833 if (i
== (idim
- 1))
1835 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1842 if (mask
->rank
== 0)
1847 resolve_mask_arg (mask
);
1852 f
->value
.function
.name
1853 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
1854 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1859 gfc_resolve_mod (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
1861 f
->ts
.type
= a
->ts
.type
;
1863 f
->ts
.kind
= gfc_kind_max (a
,p
);
1865 f
->ts
.kind
= a
->ts
.kind
;
1867 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
1869 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
1870 gfc_convert_type (p
, &a
->ts
, 2);
1872 gfc_convert_type (a
, &p
->ts
, 2);
1875 f
->value
.function
.name
1876 = gfc_get_string ("__mod_%c%d", gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
1881 gfc_resolve_modulo (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
1883 f
->ts
.type
= a
->ts
.type
;
1885 f
->ts
.kind
= gfc_kind_max (a
,p
);
1887 f
->ts
.kind
= a
->ts
.kind
;
1889 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
1891 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
1892 gfc_convert_type (p
, &a
->ts
, 2);
1894 gfc_convert_type (a
, &p
->ts
, 2);
1897 f
->value
.function
.name
1898 = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f
->ts
.type
),
1903 gfc_resolve_nearest (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
1905 if (p
->ts
.kind
!= a
->ts
.kind
)
1906 gfc_convert_type (p
, &a
->ts
, 2);
1909 f
->value
.function
.name
1910 = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a
->ts
.type
),
1915 gfc_resolve_nint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1917 f
->ts
.type
= BT_INTEGER
;
1918 f
->ts
.kind
= (kind
== NULL
)
1919 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
1920 f
->value
.function
.name
1921 = gfc_get_string ("__nint_%d_%d", f
->ts
.kind
, a
->ts
.kind
);
1926 gfc_resolve_norm2 (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
)
1928 resolve_transformational ("norm2", f
, array
, dim
, NULL
);
1933 gfc_resolve_not (gfc_expr
*f
, gfc_expr
*i
)
1936 f
->value
.function
.name
= gfc_get_string ("__not_%d", i
->ts
.kind
);
1941 gfc_resolve_or (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1943 f
->ts
.type
= i
->ts
.type
;
1944 f
->ts
.kind
= gfc_kind_max (i
, j
);
1946 if (i
->ts
.kind
!= j
->ts
.kind
)
1948 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1949 gfc_convert_type (j
, &i
->ts
, 2);
1951 gfc_convert_type (i
, &j
->ts
, 2);
1954 f
->value
.function
.name
1955 = gfc_get_string ("__or_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
1960 gfc_resolve_pack (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*mask
,
1961 gfc_expr
*vector ATTRIBUTE_UNUSED
)
1963 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
1964 gfc_resolve_substring_charlen (array
);
1969 resolve_mask_arg (mask
);
1971 if (mask
->rank
!= 0)
1973 if (array
->ts
.type
== BT_CHARACTER
)
1974 f
->value
.function
.name
1975 = array
->ts
.kind
== 1 ? PREFIX ("pack_char")
1977 (PREFIX ("pack_char%d"),
1980 f
->value
.function
.name
= PREFIX ("pack");
1984 if (array
->ts
.type
== BT_CHARACTER
)
1985 f
->value
.function
.name
1986 = array
->ts
.kind
== 1 ? PREFIX ("pack_s_char")
1988 (PREFIX ("pack_s_char%d"),
1991 f
->value
.function
.name
= PREFIX ("pack_s");
1997 gfc_resolve_parity (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
)
1999 resolve_transformational ("parity", f
, array
, dim
, NULL
);
2004 gfc_resolve_product (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
2007 resolve_transformational ("product", f
, array
, dim
, mask
);
2012 gfc_resolve_rank (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
)
2014 f
->ts
.type
= BT_INTEGER
;
2015 f
->ts
.kind
= gfc_default_integer_kind
;
2016 f
->value
.function
.name
= gfc_get_string ("__rank");
2021 gfc_resolve_real (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
2023 f
->ts
.type
= BT_REAL
;
2026 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2028 f
->ts
.kind
= (a
->ts
.type
== BT_COMPLEX
)
2029 ? a
->ts
.kind
: gfc_default_real_kind
;
2031 f
->value
.function
.name
2032 = gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
2033 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2038 gfc_resolve_realpart (gfc_expr
*f
, gfc_expr
*a
)
2040 f
->ts
.type
= BT_REAL
;
2041 f
->ts
.kind
= a
->ts
.kind
;
2042 f
->value
.function
.name
2043 = gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
2044 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2049 gfc_resolve_rename (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
2050 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
2052 f
->ts
.type
= BT_INTEGER
;
2053 f
->ts
.kind
= gfc_default_integer_kind
;
2054 f
->value
.function
.name
= gfc_get_string (PREFIX ("rename_i%d"), f
->ts
.kind
);
2059 gfc_resolve_repeat (gfc_expr
*f
, gfc_expr
*string
,
2064 f
->ts
.type
= BT_CHARACTER
;
2065 f
->ts
.kind
= string
->ts
.kind
;
2066 f
->value
.function
.name
= gfc_get_string ("__repeat_%d", string
->ts
.kind
);
2068 /* If possible, generate a character length. */
2069 if (f
->ts
.u
.cl
== NULL
)
2070 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2073 if (string
->expr_type
== EXPR_CONSTANT
)
2075 len
= string
->value
.character
.length
;
2076 tmp
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, len
);
2078 else if (string
->ts
.u
.cl
&& string
->ts
.u
.cl
->length
)
2080 tmp
= gfc_copy_expr (string
->ts
.u
.cl
->length
);
2084 f
->ts
.u
.cl
->length
= gfc_multiply (tmp
, gfc_copy_expr (ncopies
));
2089 gfc_resolve_reshape (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*shape
,
2090 gfc_expr
*pad ATTRIBUTE_UNUSED
,
2091 gfc_expr
*order ATTRIBUTE_UNUSED
)
2097 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
2098 gfc_resolve_substring_charlen (source
);
2102 gfc_array_size (shape
, &rank
);
2103 f
->rank
= mpz_get_si (rank
);
2105 switch (source
->ts
.type
)
2112 kind
= source
->ts
.kind
;
2126 if (source
->ts
.type
== BT_COMPLEX
|| source
->ts
.type
== BT_REAL
)
2127 f
->value
.function
.name
2128 = gfc_get_string (PREFIX ("reshape_%c%d"),
2129 gfc_type_letter (source
->ts
.type
),
2131 else if (source
->ts
.type
== BT_CHARACTER
)
2132 f
->value
.function
.name
= gfc_get_string (PREFIX ("reshape_char%d"),
2135 f
->value
.function
.name
2136 = gfc_get_string (PREFIX ("reshape_%d"), source
->ts
.kind
);
2140 f
->value
.function
.name
= (source
->ts
.type
== BT_CHARACTER
2141 ? PREFIX ("reshape_char") : PREFIX ("reshape"));
2145 /* TODO: Make this work with a constant ORDER parameter. */
2146 if (shape
->expr_type
== EXPR_ARRAY
2147 && gfc_is_constant_expr (shape
)
2151 f
->shape
= gfc_get_shape (f
->rank
);
2152 c
= gfc_constructor_first (shape
->value
.constructor
);
2153 for (i
= 0; i
< f
->rank
; i
++)
2155 mpz_init_set (f
->shape
[i
], c
->expr
->value
.integer
);
2156 c
= gfc_constructor_next (c
);
2160 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
2161 so many runtime variations. */
2162 if (shape
->ts
.kind
!= gfc_index_integer_kind
)
2164 gfc_typespec ts
= shape
->ts
;
2165 ts
.kind
= gfc_index_integer_kind
;
2166 gfc_convert_type_warn (shape
, &ts
, 2, 0);
2168 if (order
&& order
->ts
.kind
!= gfc_index_integer_kind
)
2169 gfc_convert_type_warn (order
, &shape
->ts
, 2, 0);
2174 gfc_resolve_rrspacing (gfc_expr
*f
, gfc_expr
*x
)
2177 f
->value
.function
.name
= gfc_get_string ("__rrspacing_%d", x
->ts
.kind
);
2182 gfc_resolve_scale (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*i ATTRIBUTE_UNUSED
)
2185 f
->value
.function
.name
= gfc_get_string ("__scale_%d", x
->ts
.kind
);
2190 gfc_resolve_scan (gfc_expr
*f
, gfc_expr
*string
,
2191 gfc_expr
*set ATTRIBUTE_UNUSED
,
2192 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2194 f
->ts
.type
= BT_INTEGER
;
2196 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2198 f
->ts
.kind
= gfc_default_integer_kind
;
2199 f
->value
.function
.name
= gfc_get_string ("__scan_%d", string
->ts
.kind
);
2204 gfc_resolve_secnds (gfc_expr
*t1
, gfc_expr
*t0
)
2207 t1
->value
.function
.name
= gfc_get_string (PREFIX ("secnds"));
2212 gfc_resolve_set_exponent (gfc_expr
*f
, gfc_expr
*x
,
2213 gfc_expr
*i ATTRIBUTE_UNUSED
)
2216 f
->value
.function
.name
= gfc_get_string ("__set_exponent_%d", x
->ts
.kind
);
2221 gfc_resolve_shape (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*kind
)
2223 f
->ts
.type
= BT_INTEGER
;
2226 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2228 f
->ts
.kind
= gfc_default_integer_kind
;
2231 if (array
->rank
!= -1)
2233 f
->shape
= gfc_get_shape (1);
2234 mpz_init_set_ui (f
->shape
[0], array
->rank
);
2237 f
->value
.function
.name
= gfc_get_string (PREFIX ("shape_%d"), f
->ts
.kind
);
2242 gfc_resolve_shift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift ATTRIBUTE_UNUSED
)
2245 if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTA
)
2246 f
->value
.function
.name
= gfc_get_string ("shifta_i%d", f
->ts
.kind
);
2247 else if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTL
)
2248 f
->value
.function
.name
= gfc_get_string ("shiftl_i%d", f
->ts
.kind
);
2249 else if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTR
)
2250 f
->value
.function
.name
= gfc_get_string ("shiftr_i%d", f
->ts
.kind
);
2257 gfc_resolve_sign (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b ATTRIBUTE_UNUSED
)
2260 f
->value
.function
.name
2261 = gfc_get_string ("__sign_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2266 gfc_resolve_signal (gfc_expr
*f
, gfc_expr
*number
, gfc_expr
*handler
)
2268 f
->ts
.type
= BT_INTEGER
;
2269 f
->ts
.kind
= gfc_c_int_kind
;
2271 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2272 if (handler
->ts
.type
== BT_INTEGER
)
2274 if (handler
->ts
.kind
!= gfc_c_int_kind
)
2275 gfc_convert_type (handler
, &f
->ts
, 2);
2276 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func_int"));
2279 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func"));
2281 if (number
->ts
.kind
!= gfc_c_int_kind
)
2282 gfc_convert_type (number
, &f
->ts
, 2);
2287 gfc_resolve_sin (gfc_expr
*f
, gfc_expr
*x
)
2290 f
->value
.function
.name
2291 = gfc_get_string ("__sin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2296 gfc_resolve_sinh (gfc_expr
*f
, gfc_expr
*x
)
2299 f
->value
.function
.name
2300 = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2305 gfc_resolve_size (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2306 gfc_expr
*dim ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2308 f
->ts
.type
= BT_INTEGER
;
2310 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2312 f
->ts
.kind
= gfc_default_integer_kind
;
2317 gfc_resolve_spacing (gfc_expr
*f
, gfc_expr
*x
)
2320 f
->value
.function
.name
= gfc_get_string ("__spacing_%d", x
->ts
.kind
);
2325 gfc_resolve_spread (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*dim
,
2328 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
2329 gfc_resolve_substring_charlen (source
);
2331 if (source
->ts
.type
== BT_CHARACTER
)
2332 check_charlen_present (source
);
2335 f
->rank
= source
->rank
+ 1;
2336 if (source
->rank
== 0)
2338 if (source
->ts
.type
== BT_CHARACTER
)
2339 f
->value
.function
.name
2340 = source
->ts
.kind
== 1 ? PREFIX ("spread_char_scalar")
2342 (PREFIX ("spread_char%d_scalar"),
2345 f
->value
.function
.name
= PREFIX ("spread_scalar");
2349 if (source
->ts
.type
== BT_CHARACTER
)
2350 f
->value
.function
.name
2351 = source
->ts
.kind
== 1 ? PREFIX ("spread_char")
2353 (PREFIX ("spread_char%d"),
2356 f
->value
.function
.name
= PREFIX ("spread");
2359 if (dim
&& gfc_is_constant_expr (dim
)
2360 && ncopies
&& gfc_is_constant_expr (ncopies
) && source
->shape
[0])
2363 idim
= mpz_get_ui (dim
->value
.integer
);
2364 f
->shape
= gfc_get_shape (f
->rank
);
2365 for (i
= 0; i
< (idim
- 1); i
++)
2366 mpz_init_set (f
->shape
[i
], source
->shape
[i
]);
2368 mpz_init_set (f
->shape
[idim
- 1], ncopies
->value
.integer
);
2370 for (i
= idim
; i
< f
->rank
; i
++)
2371 mpz_init_set (f
->shape
[i
], source
->shape
[i
-1]);
2375 gfc_resolve_dim_arg (dim
);
2376 gfc_resolve_index (ncopies
, 1);
2381 gfc_resolve_sqrt (gfc_expr
*f
, gfc_expr
*x
)
2384 f
->value
.function
.name
2385 = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2389 /* Resolve the g77 compatibility function STAT AND FSTAT. */
2392 gfc_resolve_stat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2393 gfc_expr
*a ATTRIBUTE_UNUSED
)
2395 f
->ts
.type
= BT_INTEGER
;
2396 f
->ts
.kind
= gfc_default_integer_kind
;
2397 f
->value
.function
.name
= gfc_get_string (PREFIX ("stat_i%d"), f
->ts
.kind
);
2402 gfc_resolve_lstat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2403 gfc_expr
*a ATTRIBUTE_UNUSED
)
2405 f
->ts
.type
= BT_INTEGER
;
2406 f
->ts
.kind
= gfc_default_integer_kind
;
2407 f
->value
.function
.name
= gfc_get_string (PREFIX ("lstat_i%d"), f
->ts
.kind
);
2412 gfc_resolve_fstat (gfc_expr
*f
, gfc_expr
*n
, gfc_expr
*a ATTRIBUTE_UNUSED
)
2414 f
->ts
.type
= BT_INTEGER
;
2415 f
->ts
.kind
= gfc_default_integer_kind
;
2416 if (n
->ts
.kind
!= f
->ts
.kind
)
2417 gfc_convert_type (n
, &f
->ts
, 2);
2419 f
->value
.function
.name
= gfc_get_string (PREFIX ("fstat_i%d"), f
->ts
.kind
);
2424 gfc_resolve_fgetc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2429 f
->ts
.type
= BT_INTEGER
;
2430 f
->ts
.kind
= gfc_c_int_kind
;
2431 if (u
->ts
.kind
!= gfc_c_int_kind
)
2433 ts
.type
= BT_INTEGER
;
2434 ts
.kind
= gfc_c_int_kind
;
2435 ts
.u
.derived
= NULL
;
2437 gfc_convert_type (u
, &ts
, 2);
2440 f
->value
.function
.name
= gfc_get_string (PREFIX ("fgetc"));
2445 gfc_resolve_fget (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2447 f
->ts
.type
= BT_INTEGER
;
2448 f
->ts
.kind
= gfc_c_int_kind
;
2449 f
->value
.function
.name
= gfc_get_string (PREFIX ("fget"));
2454 gfc_resolve_fputc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2459 f
->ts
.type
= BT_INTEGER
;
2460 f
->ts
.kind
= gfc_c_int_kind
;
2461 if (u
->ts
.kind
!= gfc_c_int_kind
)
2463 ts
.type
= BT_INTEGER
;
2464 ts
.kind
= gfc_c_int_kind
;
2465 ts
.u
.derived
= NULL
;
2467 gfc_convert_type (u
, &ts
, 2);
2470 f
->value
.function
.name
= gfc_get_string (PREFIX ("fputc"));
2475 gfc_resolve_fput (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2477 f
->ts
.type
= BT_INTEGER
;
2478 f
->ts
.kind
= gfc_c_int_kind
;
2479 f
->value
.function
.name
= gfc_get_string (PREFIX ("fput"));
2484 gfc_resolve_ftell (gfc_expr
*f
, gfc_expr
*u
)
2489 f
->ts
.type
= BT_INTEGER
;
2490 f
->ts
.kind
= gfc_intio_kind
;
2491 if (u
->ts
.kind
!= gfc_c_int_kind
)
2493 ts
.type
= BT_INTEGER
;
2494 ts
.kind
= gfc_c_int_kind
;
2495 ts
.u
.derived
= NULL
;
2497 gfc_convert_type (u
, &ts
, 2);
2500 f
->value
.function
.name
= gfc_get_string (PREFIX ("ftell2"));
2505 gfc_resolve_storage_size (gfc_expr
*f
, gfc_expr
*a ATTRIBUTE_UNUSED
,
2508 f
->ts
.type
= BT_INTEGER
;
2510 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2512 f
->ts
.kind
= gfc_default_integer_kind
;
2517 gfc_resolve_sum (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2519 resolve_transformational ("sum", f
, array
, dim
, mask
);
2524 gfc_resolve_symlnk (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
2525 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
2527 f
->ts
.type
= BT_INTEGER
;
2528 f
->ts
.kind
= gfc_default_integer_kind
;
2529 f
->value
.function
.name
= gfc_get_string (PREFIX ("symlnk_i%d"), f
->ts
.kind
);
2533 /* Resolve the g77 compatibility function SYSTEM. */
2536 gfc_resolve_system (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
2538 f
->ts
.type
= BT_INTEGER
;
2540 f
->value
.function
.name
= gfc_get_string (PREFIX ("system"));
2545 gfc_resolve_tan (gfc_expr
*f
, gfc_expr
*x
)
2548 f
->value
.function
.name
2549 = gfc_get_string ("__tan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2554 gfc_resolve_tanh (gfc_expr
*f
, gfc_expr
*x
)
2557 f
->value
.function
.name
2558 = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2563 gfc_resolve_image_index (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2564 gfc_expr
*sub ATTRIBUTE_UNUSED
)
2566 static char image_index
[] = "__image_index";
2567 f
->ts
.type
= BT_INTEGER
;
2568 f
->ts
.kind
= gfc_default_integer_kind
;
2569 f
->value
.function
.name
= image_index
;
2574 gfc_resolve_this_image (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
)
2576 static char this_image
[] = "__this_image";
2578 resolve_bound (f
, array
, dim
, NULL
, "__this_image", true);
2581 f
->ts
.type
= BT_INTEGER
;
2582 f
->ts
.kind
= gfc_default_integer_kind
;
2583 f
->value
.function
.name
= this_image
;
2589 gfc_resolve_time (gfc_expr
*f
)
2591 f
->ts
.type
= BT_INTEGER
;
2593 f
->value
.function
.name
= gfc_get_string (PREFIX ("time_func"));
2598 gfc_resolve_time8 (gfc_expr
*f
)
2600 f
->ts
.type
= BT_INTEGER
;
2602 f
->value
.function
.name
= gfc_get_string (PREFIX ("time8_func"));
2607 gfc_resolve_transfer (gfc_expr
*f
, gfc_expr
*source ATTRIBUTE_UNUSED
,
2608 gfc_expr
*mold
, gfc_expr
*size
)
2610 /* TODO: Make this do something meaningful. */
2611 static char transfer0
[] = "__transfer0", transfer1
[] = "__transfer1";
2613 if (mold
->ts
.type
== BT_CHARACTER
2614 && !mold
->ts
.u
.cl
->length
2615 && gfc_is_constant_expr (mold
))
2618 if (mold
->expr_type
== EXPR_CONSTANT
)
2620 len
= mold
->value
.character
.length
;
2621 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
2626 gfc_constructor
*c
= gfc_constructor_first (mold
->value
.constructor
);
2627 len
= c
->expr
->value
.character
.length
;
2628 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
2635 if (size
== NULL
&& mold
->rank
== 0)
2638 f
->value
.function
.name
= transfer0
;
2643 f
->value
.function
.name
= transfer1
;
2644 if (size
&& gfc_is_constant_expr (size
))
2646 f
->shape
= gfc_get_shape (1);
2647 mpz_init_set (f
->shape
[0], size
->value
.integer
);
2654 gfc_resolve_transpose (gfc_expr
*f
, gfc_expr
*matrix
)
2657 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ref
)
2658 gfc_resolve_substring_charlen (matrix
);
2664 f
->shape
= gfc_get_shape (2);
2665 mpz_init_set (f
->shape
[0], matrix
->shape
[1]);
2666 mpz_init_set (f
->shape
[1], matrix
->shape
[0]);
2669 switch (matrix
->ts
.kind
)
2675 switch (matrix
->ts
.type
)
2679 f
->value
.function
.name
2680 = gfc_get_string (PREFIX ("transpose_%c%d"),
2681 gfc_type_letter (matrix
->ts
.type
),
2687 /* Use the integer routines for real and logical cases. This
2688 assumes they all have the same alignment requirements. */
2689 f
->value
.function
.name
2690 = gfc_get_string (PREFIX ("transpose_i%d"), matrix
->ts
.kind
);
2694 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ts
.kind
== 4)
2695 f
->value
.function
.name
= PREFIX ("transpose_char4");
2697 f
->value
.function
.name
= PREFIX ("transpose");
2703 f
->value
.function
.name
= (matrix
->ts
.type
== BT_CHARACTER
2704 ? PREFIX ("transpose_char")
2705 : PREFIX ("transpose"));
2712 gfc_resolve_trim (gfc_expr
*f
, gfc_expr
*string
)
2714 f
->ts
.type
= BT_CHARACTER
;
2715 f
->ts
.kind
= string
->ts
.kind
;
2716 f
->value
.function
.name
= gfc_get_string ("__trim_%d", string
->ts
.kind
);
2721 gfc_resolve_ubound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2723 resolve_bound (f
, array
, dim
, kind
, "__ubound", false);
2728 gfc_resolve_ucobound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2730 resolve_bound (f
, array
, dim
, kind
, "__ucobound", true);
2734 /* Resolve the g77 compatibility function UMASK. */
2737 gfc_resolve_umask (gfc_expr
*f
, gfc_expr
*n
)
2739 f
->ts
.type
= BT_INTEGER
;
2740 f
->ts
.kind
= n
->ts
.kind
;
2741 f
->value
.function
.name
= gfc_get_string (PREFIX ("umask_i%d"), n
->ts
.kind
);
2745 /* Resolve the g77 compatibility function UNLINK. */
2748 gfc_resolve_unlink (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
2750 f
->ts
.type
= BT_INTEGER
;
2752 f
->value
.function
.name
= gfc_get_string (PREFIX ("unlink"));
2757 gfc_resolve_ttynam (gfc_expr
*f
, gfc_expr
*unit
)
2762 f
->ts
.type
= BT_CHARACTER
;
2763 f
->ts
.kind
= gfc_default_character_kind
;
2765 if (unit
->ts
.kind
!= gfc_c_int_kind
)
2767 ts
.type
= BT_INTEGER
;
2768 ts
.kind
= gfc_c_int_kind
;
2769 ts
.u
.derived
= NULL
;
2771 gfc_convert_type (unit
, &ts
, 2);
2774 f
->value
.function
.name
= gfc_get_string (PREFIX ("ttynam"));
2779 gfc_resolve_unpack (gfc_expr
*f
, gfc_expr
*vector
, gfc_expr
*mask
,
2780 gfc_expr
*field ATTRIBUTE_UNUSED
)
2782 if (vector
->ts
.type
== BT_CHARACTER
&& vector
->ref
)
2783 gfc_resolve_substring_charlen (vector
);
2786 f
->rank
= mask
->rank
;
2787 resolve_mask_arg (mask
);
2789 if (vector
->ts
.type
== BT_CHARACTER
)
2791 if (vector
->ts
.kind
== 1)
2792 f
->value
.function
.name
2793 = gfc_get_string (PREFIX ("unpack%d_char"), field
->rank
> 0 ? 1 : 0);
2795 f
->value
.function
.name
2796 = gfc_get_string (PREFIX ("unpack%d_char%d"),
2797 field
->rank
> 0 ? 1 : 0, vector
->ts
.kind
);
2800 f
->value
.function
.name
2801 = gfc_get_string (PREFIX ("unpack%d"), field
->rank
> 0 ? 1 : 0);
2806 gfc_resolve_verify (gfc_expr
*f
, gfc_expr
*string
,
2807 gfc_expr
*set ATTRIBUTE_UNUSED
,
2808 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2810 f
->ts
.type
= BT_INTEGER
;
2812 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2814 f
->ts
.kind
= gfc_default_integer_kind
;
2815 f
->value
.function
.name
= gfc_get_string ("__verify_%d", string
->ts
.kind
);
2820 gfc_resolve_xor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
2822 f
->ts
.type
= i
->ts
.type
;
2823 f
->ts
.kind
= gfc_kind_max (i
, j
);
2825 if (i
->ts
.kind
!= j
->ts
.kind
)
2827 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
2828 gfc_convert_type (j
, &i
->ts
, 2);
2830 gfc_convert_type (i
, &j
->ts
, 2);
2833 f
->value
.function
.name
2834 = gfc_get_string ("__xor_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
2838 /* Intrinsic subroutine resolution. */
2841 gfc_resolve_alarm_sub (gfc_code
*c
)
2844 gfc_expr
*seconds
, *handler
;
2848 seconds
= c
->ext
.actual
->expr
;
2849 handler
= c
->ext
.actual
->next
->expr
;
2850 ts
.type
= BT_INTEGER
;
2851 ts
.kind
= gfc_c_int_kind
;
2853 /* handler can be either BT_INTEGER or BT_PROCEDURE.
2854 In all cases, the status argument is of default integer kind
2855 (enforced in check.c) so that the function suffix is fixed. */
2856 if (handler
->ts
.type
== BT_INTEGER
)
2858 if (handler
->ts
.kind
!= gfc_c_int_kind
)
2859 gfc_convert_type (handler
, &ts
, 2);
2860 name
= gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
2861 gfc_default_integer_kind
);
2864 name
= gfc_get_string (PREFIX ("alarm_sub_i%d"),
2865 gfc_default_integer_kind
);
2867 if (seconds
->ts
.kind
!= gfc_c_int_kind
)
2868 gfc_convert_type (seconds
, &ts
, 2);
2870 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2874 gfc_resolve_cpu_time (gfc_code
*c
)
2877 name
= gfc_get_string (PREFIX ("cpu_time_%d"), c
->ext
.actual
->expr
->ts
.kind
);
2878 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2882 /* Create a formal arglist based on an actual one and set the INTENTs given. */
2884 static gfc_formal_arglist
*
2885 create_formal_for_intents (gfc_actual_arglist
* actual
, const sym_intent
* ints
)
2887 gfc_formal_arglist
* head
;
2888 gfc_formal_arglist
* tail
;
2894 head
= tail
= gfc_get_formal_arglist ();
2895 for (i
= 0; actual
; actual
= actual
->next
, tail
= tail
->next
, ++i
)
2899 sym
= gfc_new_symbol ("dummyarg", NULL
);
2900 sym
->ts
= actual
->expr
->ts
;
2902 sym
->attr
.intent
= ints
[i
];
2906 tail
->next
= gfc_get_formal_arglist ();
2914 gfc_resolve_atomic_def (gfc_code
*c
)
2916 const char *name
= "atomic_define";
2917 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2922 gfc_resolve_atomic_ref (gfc_code
*c
)
2924 const char *name
= "atomic_ref";
2925 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2930 gfc_resolve_mvbits (gfc_code
*c
)
2932 static const sym_intent INTENTS
[] = {INTENT_IN
, INTENT_IN
, INTENT_IN
,
2933 INTENT_INOUT
, INTENT_IN
};
2939 /* FROMPOS, LEN and TOPOS are restricted to small values. As such,
2940 they will be converted so that they fit into a C int. */
2941 ts
.type
= BT_INTEGER
;
2942 ts
.kind
= gfc_c_int_kind
;
2943 if (c
->ext
.actual
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
2944 gfc_convert_type (c
->ext
.actual
->next
->expr
, &ts
, 2);
2945 if (c
->ext
.actual
->next
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
2946 gfc_convert_type (c
->ext
.actual
->next
->next
->expr
, &ts
, 2);
2947 if (c
->ext
.actual
->next
->next
->next
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
2948 gfc_convert_type (c
->ext
.actual
->next
->next
->next
->next
->expr
, &ts
, 2);
2950 /* TO and FROM are guaranteed to have the same kind parameter. */
2951 name
= gfc_get_string (PREFIX ("mvbits_i%d"),
2952 c
->ext
.actual
->expr
->ts
.kind
);
2953 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2954 /* Mark as elemental subroutine as this does not happen automatically. */
2955 c
->resolved_sym
->attr
.elemental
= 1;
2957 /* Create a dummy formal arglist so the INTENTs are known later for purpose
2958 of creating temporaries. */
2959 c
->resolved_sym
->formal
= create_formal_for_intents (c
->ext
.actual
, INTENTS
);
2964 gfc_resolve_random_number (gfc_code
*c
)
2969 kind
= c
->ext
.actual
->expr
->ts
.kind
;
2970 if (c
->ext
.actual
->expr
->rank
== 0)
2971 name
= gfc_get_string (PREFIX ("random_r%d"), kind
);
2973 name
= gfc_get_string (PREFIX ("arandom_r%d"), kind
);
2975 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2980 gfc_resolve_random_seed (gfc_code
*c
)
2984 name
= gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind
);
2985 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2990 gfc_resolve_rename_sub (gfc_code
*c
)
2995 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
2996 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
2998 kind
= gfc_default_integer_kind
;
3000 name
= gfc_get_string (PREFIX ("rename_i%d_sub"), kind
);
3001 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3006 gfc_resolve_kill_sub (gfc_code
*c
)
3011 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3012 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3014 kind
= gfc_default_integer_kind
;
3016 name
= gfc_get_string (PREFIX ("kill_i%d_sub"), kind
);
3017 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3022 gfc_resolve_link_sub (gfc_code
*c
)
3027 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3028 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3030 kind
= gfc_default_integer_kind
;
3032 name
= gfc_get_string (PREFIX ("link_i%d_sub"), kind
);
3033 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3038 gfc_resolve_symlnk_sub (gfc_code
*c
)
3043 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3044 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3046 kind
= gfc_default_integer_kind
;
3048 name
= gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind
);
3049 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3053 /* G77 compatibility subroutines dtime() and etime(). */
3056 gfc_resolve_dtime_sub (gfc_code
*c
)
3059 name
= gfc_get_string (PREFIX ("dtime_sub"));
3060 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3064 gfc_resolve_etime_sub (gfc_code
*c
)
3067 name
= gfc_get_string (PREFIX ("etime_sub"));
3068 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3072 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
3075 gfc_resolve_itime (gfc_code
*c
)
3078 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
3079 gfc_default_integer_kind
));
3083 gfc_resolve_idate (gfc_code
*c
)
3086 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
3087 gfc_default_integer_kind
));
3091 gfc_resolve_ltime (gfc_code
*c
)
3094 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
3095 gfc_default_integer_kind
));
3099 gfc_resolve_gmtime (gfc_code
*c
)
3102 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
3103 gfc_default_integer_kind
));
3107 /* G77 compatibility subroutine second(). */
3110 gfc_resolve_second_sub (gfc_code
*c
)
3113 name
= gfc_get_string (PREFIX ("second_sub"));
3114 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3119 gfc_resolve_sleep_sub (gfc_code
*c
)
3124 if (c
->ext
.actual
->expr
!= NULL
)
3125 kind
= c
->ext
.actual
->expr
->ts
.kind
;
3127 kind
= gfc_default_integer_kind
;
3129 name
= gfc_get_string (PREFIX ("sleep_i%d_sub"), kind
);
3130 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3134 /* G77 compatibility function srand(). */
3137 gfc_resolve_srand (gfc_code
*c
)
3140 name
= gfc_get_string (PREFIX ("srand"));
3141 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3145 /* Resolve the getarg intrinsic subroutine. */
3148 gfc_resolve_getarg (gfc_code
*c
)
3152 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_default_integer_kind
)
3157 ts
.type
= BT_INTEGER
;
3158 ts
.kind
= gfc_default_integer_kind
;
3160 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3163 name
= gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind
);
3164 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3168 /* Resolve the getcwd intrinsic subroutine. */
3171 gfc_resolve_getcwd_sub (gfc_code
*c
)
3176 if (c
->ext
.actual
->next
->expr
!= NULL
)
3177 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3179 kind
= gfc_default_integer_kind
;
3181 name
= gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind
);
3182 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3186 /* Resolve the get_command intrinsic subroutine. */
3189 gfc_resolve_get_command (gfc_code
*c
)
3193 kind
= gfc_default_integer_kind
;
3194 name
= gfc_get_string (PREFIX ("get_command_i%d"), kind
);
3195 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3199 /* Resolve the get_command_argument intrinsic subroutine. */
3202 gfc_resolve_get_command_argument (gfc_code
*c
)
3206 kind
= gfc_default_integer_kind
;
3207 name
= gfc_get_string (PREFIX ("get_command_argument_i%d"), kind
);
3208 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3212 /* Resolve the get_environment_variable intrinsic subroutine. */
3215 gfc_resolve_get_environment_variable (gfc_code
*code
)
3219 kind
= gfc_default_integer_kind
;
3220 name
= gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind
);
3221 code
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3226 gfc_resolve_signal_sub (gfc_code
*c
)
3229 gfc_expr
*number
, *handler
, *status
;
3233 number
= c
->ext
.actual
->expr
;
3234 handler
= c
->ext
.actual
->next
->expr
;
3235 status
= c
->ext
.actual
->next
->next
->expr
;
3236 ts
.type
= BT_INTEGER
;
3237 ts
.kind
= gfc_c_int_kind
;
3239 /* handler can be either BT_INTEGER or BT_PROCEDURE */
3240 if (handler
->ts
.type
== BT_INTEGER
)
3242 if (handler
->ts
.kind
!= gfc_c_int_kind
)
3243 gfc_convert_type (handler
, &ts
, 2);
3244 name
= gfc_get_string (PREFIX ("signal_sub_int"));
3247 name
= gfc_get_string (PREFIX ("signal_sub"));
3249 if (number
->ts
.kind
!= gfc_c_int_kind
)
3250 gfc_convert_type (number
, &ts
, 2);
3251 if (status
!= NULL
&& status
->ts
.kind
!= gfc_c_int_kind
)
3252 gfc_convert_type (status
, &ts
, 2);
3254 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3258 /* Resolve the SYSTEM intrinsic subroutine. */
3261 gfc_resolve_system_sub (gfc_code
*c
)
3264 name
= gfc_get_string (PREFIX ("system_sub"));
3265 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3269 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
3272 gfc_resolve_system_clock (gfc_code
*c
)
3277 if (c
->ext
.actual
->expr
!= NULL
)
3278 kind
= c
->ext
.actual
->expr
->ts
.kind
;
3279 else if (c
->ext
.actual
->next
->expr
!= NULL
)
3280 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3281 else if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3282 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3284 kind
= gfc_default_integer_kind
;
3286 name
= gfc_get_string (PREFIX ("system_clock_%d"), kind
);
3287 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3291 /* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine. */
3293 gfc_resolve_execute_command_line (gfc_code
*c
)
3296 name
= gfc_get_string (PREFIX ("execute_command_line_i%d"),
3297 gfc_default_integer_kind
);
3298 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3302 /* Resolve the EXIT intrinsic subroutine. */
3305 gfc_resolve_exit (gfc_code
*c
)
3312 /* The STATUS argument has to be of default kind. If it is not,
3314 ts
.type
= BT_INTEGER
;
3315 ts
.kind
= gfc_default_integer_kind
;
3316 n
= c
->ext
.actual
->expr
;
3317 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3318 gfc_convert_type (n
, &ts
, 2);
3320 name
= gfc_get_string (PREFIX ("exit_i%d"), ts
.kind
);
3321 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3325 /* Resolve the FLUSH intrinsic subroutine. */
3328 gfc_resolve_flush (gfc_code
*c
)
3335 ts
.type
= BT_INTEGER
;
3336 ts
.kind
= gfc_default_integer_kind
;
3337 n
= c
->ext
.actual
->expr
;
3338 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3339 gfc_convert_type (n
, &ts
, 2);
3341 name
= gfc_get_string (PREFIX ("flush_i%d"), ts
.kind
);
3342 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3347 gfc_resolve_free (gfc_code
*c
)
3353 ts
.type
= BT_INTEGER
;
3354 ts
.kind
= gfc_index_integer_kind
;
3355 n
= c
->ext
.actual
->expr
;
3356 if (n
->ts
.kind
!= ts
.kind
)
3357 gfc_convert_type (n
, &ts
, 2);
3359 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("free"));
3364 gfc_resolve_ctime_sub (gfc_code
*c
)
3369 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3370 if (c
->ext
.actual
->expr
->ts
.kind
!= 8)
3372 ts
.type
= BT_INTEGER
;
3374 ts
.u
.derived
= NULL
;
3376 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3379 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3384 gfc_resolve_fdate_sub (gfc_code
*c
)
3386 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3391 gfc_resolve_gerror (gfc_code
*c
)
3393 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3398 gfc_resolve_getlog (gfc_code
*c
)
3400 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3405 gfc_resolve_hostnm_sub (gfc_code
*c
)
3410 if (c
->ext
.actual
->next
->expr
!= NULL
)
3411 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3413 kind
= gfc_default_integer_kind
;
3415 name
= gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind
);
3416 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3421 gfc_resolve_perror (gfc_code
*c
)
3423 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3426 /* Resolve the STAT and FSTAT intrinsic subroutines. */
3429 gfc_resolve_stat_sub (gfc_code
*c
)
3432 name
= gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind
);
3433 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3438 gfc_resolve_lstat_sub (gfc_code
*c
)
3441 name
= gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind
);
3442 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3447 gfc_resolve_fstat_sub (gfc_code
*c
)
3453 u
= c
->ext
.actual
->expr
;
3454 ts
= &c
->ext
.actual
->next
->expr
->ts
;
3455 if (u
->ts
.kind
!= ts
->kind
)
3456 gfc_convert_type (u
, ts
, 2);
3457 name
= gfc_get_string (PREFIX ("fstat_i%d_sub"), ts
->kind
);
3458 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3463 gfc_resolve_fgetc_sub (gfc_code
*c
)
3470 u
= c
->ext
.actual
->expr
;
3471 st
= c
->ext
.actual
->next
->next
->expr
;
3473 if (u
->ts
.kind
!= gfc_c_int_kind
)
3475 ts
.type
= BT_INTEGER
;
3476 ts
.kind
= gfc_c_int_kind
;
3477 ts
.u
.derived
= NULL
;
3479 gfc_convert_type (u
, &ts
, 2);
3483 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), st
->ts
.kind
);
3485 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind
);
3487 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3492 gfc_resolve_fget_sub (gfc_code
*c
)
3497 st
= c
->ext
.actual
->next
->expr
;
3499 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), st
->ts
.kind
);
3501 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind
);
3503 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3508 gfc_resolve_fputc_sub (gfc_code
*c
)
3515 u
= c
->ext
.actual
->expr
;
3516 st
= c
->ext
.actual
->next
->next
->expr
;
3518 if (u
->ts
.kind
!= gfc_c_int_kind
)
3520 ts
.type
= BT_INTEGER
;
3521 ts
.kind
= gfc_c_int_kind
;
3522 ts
.u
.derived
= NULL
;
3524 gfc_convert_type (u
, &ts
, 2);
3528 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), st
->ts
.kind
);
3530 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind
);
3532 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3537 gfc_resolve_fput_sub (gfc_code
*c
)
3542 st
= c
->ext
.actual
->next
->expr
;
3544 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), st
->ts
.kind
);
3546 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind
);
3548 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3553 gfc_resolve_fseek_sub (gfc_code
*c
)
3561 unit
= c
->ext
.actual
->expr
;
3562 offset
= c
->ext
.actual
->next
->expr
;
3563 whence
= c
->ext
.actual
->next
->next
->expr
;
3565 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3567 ts
.type
= BT_INTEGER
;
3568 ts
.kind
= gfc_c_int_kind
;
3569 ts
.u
.derived
= NULL
;
3571 gfc_convert_type (unit
, &ts
, 2);
3574 if (offset
->ts
.kind
!= gfc_intio_kind
)
3576 ts
.type
= BT_INTEGER
;
3577 ts
.kind
= gfc_intio_kind
;
3578 ts
.u
.derived
= NULL
;
3580 gfc_convert_type (offset
, &ts
, 2);
3583 if (whence
->ts
.kind
!= gfc_c_int_kind
)
3585 ts
.type
= BT_INTEGER
;
3586 ts
.kind
= gfc_c_int_kind
;
3587 ts
.u
.derived
= NULL
;
3589 gfc_convert_type (whence
, &ts
, 2);
3592 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
3596 gfc_resolve_ftell_sub (gfc_code
*c
)
3604 unit
= c
->ext
.actual
->expr
;
3605 offset
= c
->ext
.actual
->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 name
= gfc_get_string (PREFIX ("ftell_i%d_sub"), offset
->ts
.kind
);
3617 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3622 gfc_resolve_ttynam_sub (gfc_code
*c
)
3627 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
3629 ts
.type
= BT_INTEGER
;
3630 ts
.kind
= gfc_c_int_kind
;
3631 ts
.u
.derived
= NULL
;
3633 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3636 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
3640 /* Resolve the UMASK intrinsic subroutine. */
3643 gfc_resolve_umask_sub (gfc_code
*c
)
3648 if (c
->ext
.actual
->next
->expr
!= NULL
)
3649 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3651 kind
= gfc_default_integer_kind
;
3653 name
= gfc_get_string (PREFIX ("umask_i%d_sub"), kind
);
3654 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3657 /* Resolve the UNLINK intrinsic subroutine. */
3660 gfc_resolve_unlink_sub (gfc_code
*c
)
3665 if (c
->ext
.actual
->next
->expr
!= NULL
)
3666 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3668 kind
= gfc_default_integer_kind
;
3670 name
= gfc_get_string (PREFIX ("unlink_i%d_sub"), kind
);
3671 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);