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"
39 /* Given printf-like arguments, return a stable version of the result string.
41 We already have a working, optimized string hashing table in the form of
42 the identifier table. Reusing this table is likely not to be wasted,
43 since if the function name makes it to the gimple output of the frontend,
44 we'll have to create the identifier anyway. */
47 gfc_get_string (const char *format
, ...)
53 va_start (ap
, format
);
54 vsnprintf (temp_name
, sizeof (temp_name
), format
, ap
);
56 temp_name
[sizeof (temp_name
) - 1] = 0;
58 ident
= get_identifier (temp_name
);
59 return IDENTIFIER_POINTER (ident
);
62 /* MERGE and SPREAD need to have source charlen's present for passing
63 to the result expression. */
65 check_charlen_present (gfc_expr
*source
)
67 if (source
->ts
.u
.cl
== NULL
)
68 source
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
70 if (source
->expr_type
== EXPR_CONSTANT
)
72 source
->ts
.u
.cl
->length
73 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
74 source
->value
.character
.length
);
77 else if (source
->expr_type
== EXPR_ARRAY
)
79 gfc_constructor
*c
= gfc_constructor_first (source
->value
.constructor
);
80 source
->ts
.u
.cl
->length
81 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
82 c
->expr
->value
.character
.length
);
86 /* Helper function for resolving the "mask" argument. */
89 resolve_mask_arg (gfc_expr
*mask
)
97 /* For the scalar case, coerce the mask to kind=4 unconditionally
98 (because this is the only kind we have a library function
101 if (mask
->ts
.kind
!= 4)
103 ts
.type
= BT_LOGICAL
;
105 gfc_convert_type (mask
, &ts
, 2);
110 /* In the library, we access the mask with a GFC_LOGICAL_1
111 argument. No need to waste memory if we are about to create
112 a temporary array. */
113 if (mask
->expr_type
== EXPR_OP
&& mask
->ts
.kind
!= 1)
115 ts
.type
= BT_LOGICAL
;
117 gfc_convert_type_warn (mask
, &ts
, 2, 0);
124 resolve_bound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
,
125 const char *name
, bool coarray
)
127 f
->ts
.type
= BT_INTEGER
;
129 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
131 f
->ts
.kind
= gfc_default_integer_kind
;
136 f
->shape
= gfc_get_shape (1);
137 mpz_init_set_ui (f
->shape
[0], coarray
? gfc_get_corank (array
)
141 f
->value
.function
.name
= xstrdup (name
);
146 resolve_transformational (const char *name
, gfc_expr
*f
, gfc_expr
*array
,
147 gfc_expr
*dim
, gfc_expr
*mask
)
160 resolve_mask_arg (mask
);
167 f
->rank
= array
->rank
- 1;
168 f
->shape
= gfc_copy_shape_excluding (array
->shape
, array
->rank
, dim
);
169 gfc_resolve_dim_arg (dim
);
172 f
->value
.function
.name
173 = gfc_get_string (PREFIX ("%s%s_%c%d"), prefix
, name
,
174 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
178 /********************** Resolution functions **********************/
182 gfc_resolve_abs (gfc_expr
*f
, gfc_expr
*a
)
185 if (f
->ts
.type
== BT_COMPLEX
)
186 f
->ts
.type
= BT_REAL
;
188 f
->value
.function
.name
189 = gfc_get_string ("__abs_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
194 gfc_resolve_access (gfc_expr
*f
, gfc_expr
*name ATTRIBUTE_UNUSED
,
195 gfc_expr
*mode ATTRIBUTE_UNUSED
)
197 f
->ts
.type
= BT_INTEGER
;
198 f
->ts
.kind
= gfc_c_int_kind
;
199 f
->value
.function
.name
= PREFIX ("access_func");
204 gfc_resolve_adjustl (gfc_expr
*f
, gfc_expr
*string
)
206 f
->ts
.type
= BT_CHARACTER
;
207 f
->ts
.kind
= string
->ts
.kind
;
208 f
->value
.function
.name
= gfc_get_string ("__adjustl_s%d", f
->ts
.kind
);
213 gfc_resolve_adjustr (gfc_expr
*f
, gfc_expr
*string
)
215 f
->ts
.type
= BT_CHARACTER
;
216 f
->ts
.kind
= string
->ts
.kind
;
217 f
->value
.function
.name
= gfc_get_string ("__adjustr_s%d", f
->ts
.kind
);
222 gfc_resolve_char_achar (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*kind
,
225 f
->ts
.type
= BT_CHARACTER
;
226 f
->ts
.kind
= (kind
== NULL
)
227 ? gfc_default_character_kind
: mpz_get_si (kind
->value
.integer
);
228 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
229 f
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
231 f
->value
.function
.name
= gfc_get_string (name
, f
->ts
.kind
,
232 gfc_type_letter (x
->ts
.type
),
238 gfc_resolve_achar (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*kind
)
240 gfc_resolve_char_achar (f
, x
, kind
, "__achar_%d_%c%d");
245 gfc_resolve_acos (gfc_expr
*f
, gfc_expr
*x
)
248 f
->value
.function
.name
249 = gfc_get_string ("__acos_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
254 gfc_resolve_acosh (gfc_expr
*f
, gfc_expr
*x
)
257 f
->value
.function
.name
258 = gfc_get_string ("__acosh_%c%d", gfc_type_letter (x
->ts
.type
),
264 gfc_resolve_aimag (gfc_expr
*f
, gfc_expr
*x
)
266 f
->ts
.type
= BT_REAL
;
267 f
->ts
.kind
= x
->ts
.kind
;
268 f
->value
.function
.name
269 = gfc_get_string ("__aimag_%c%d", gfc_type_letter (x
->ts
.type
),
275 gfc_resolve_and (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
277 f
->ts
.type
= i
->ts
.type
;
278 f
->ts
.kind
= gfc_kind_max (i
, j
);
280 if (i
->ts
.kind
!= j
->ts
.kind
)
282 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
283 gfc_convert_type (j
, &i
->ts
, 2);
285 gfc_convert_type (i
, &j
->ts
, 2);
288 f
->value
.function
.name
289 = gfc_get_string ("__and_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
294 gfc_resolve_aint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
299 f
->ts
.type
= a
->ts
.type
;
300 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
302 if (a
->ts
.kind
!= f
->ts
.kind
)
304 ts
.type
= f
->ts
.type
;
305 ts
.kind
= f
->ts
.kind
;
306 gfc_convert_type (a
, &ts
, 2);
308 /* The resolved name is only used for specific intrinsics where
309 the return kind is the same as the arg kind. */
310 f
->value
.function
.name
311 = gfc_get_string ("__aint_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
316 gfc_resolve_dint (gfc_expr
*f
, gfc_expr
*a
)
318 gfc_resolve_aint (f
, a
, NULL
);
323 gfc_resolve_all (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
)
329 gfc_resolve_dim_arg (dim
);
330 f
->rank
= mask
->rank
- 1;
331 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
334 f
->value
.function
.name
335 = gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask
->ts
.type
),
341 gfc_resolve_anint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
346 f
->ts
.type
= a
->ts
.type
;
347 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
349 if (a
->ts
.kind
!= f
->ts
.kind
)
351 ts
.type
= f
->ts
.type
;
352 ts
.kind
= f
->ts
.kind
;
353 gfc_convert_type (a
, &ts
, 2);
356 /* The resolved name is only used for specific intrinsics where
357 the return kind is the same as the arg kind. */
358 f
->value
.function
.name
359 = gfc_get_string ("__anint_%c%d", gfc_type_letter (a
->ts
.type
),
365 gfc_resolve_dnint (gfc_expr
*f
, gfc_expr
*a
)
367 gfc_resolve_anint (f
, a
, NULL
);
372 gfc_resolve_any (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
)
378 gfc_resolve_dim_arg (dim
);
379 f
->rank
= mask
->rank
- 1;
380 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
383 f
->value
.function
.name
384 = gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask
->ts
.type
),
390 gfc_resolve_asin (gfc_expr
*f
, gfc_expr
*x
)
393 f
->value
.function
.name
394 = gfc_get_string ("__asin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
398 gfc_resolve_asinh (gfc_expr
*f
, gfc_expr
*x
)
401 f
->value
.function
.name
402 = gfc_get_string ("__asinh_%c%d", gfc_type_letter (x
->ts
.type
),
407 gfc_resolve_atan (gfc_expr
*f
, gfc_expr
*x
)
410 f
->value
.function
.name
411 = gfc_get_string ("__atan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
415 gfc_resolve_atanh (gfc_expr
*f
, gfc_expr
*x
)
418 f
->value
.function
.name
419 = gfc_get_string ("__atanh_%c%d", gfc_type_letter (x
->ts
.type
),
424 gfc_resolve_atan2 (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
427 f
->value
.function
.name
428 = gfc_get_string ("__atan2_%c%d", gfc_type_letter (x
->ts
.type
),
433 /* Resolve the BESYN and BESJN intrinsics. */
436 gfc_resolve_besn (gfc_expr
*f
, gfc_expr
*n
, gfc_expr
*x
)
442 if (n
->ts
.kind
!= gfc_c_int_kind
)
444 ts
.type
= BT_INTEGER
;
445 ts
.kind
= gfc_c_int_kind
;
446 gfc_convert_type (n
, &ts
, 2);
448 f
->value
.function
.name
= gfc_get_string ("<intrinsic>");
453 gfc_resolve_bessel_n2 (gfc_expr
*f
, gfc_expr
*n1
, gfc_expr
*n2
, gfc_expr
*x
)
460 if (n1
->expr_type
== EXPR_CONSTANT
&& n2
->expr_type
== EXPR_CONSTANT
)
462 f
->shape
= gfc_get_shape (1);
463 mpz_init (f
->shape
[0]);
464 mpz_sub (f
->shape
[0], n2
->value
.integer
, n1
->value
.integer
);
465 mpz_add_ui (f
->shape
[0], f
->shape
[0], 1);
468 if (n1
->ts
.kind
!= gfc_c_int_kind
)
470 ts
.type
= BT_INTEGER
;
471 ts
.kind
= gfc_c_int_kind
;
472 gfc_convert_type (n1
, &ts
, 2);
475 if (n2
->ts
.kind
!= gfc_c_int_kind
)
477 ts
.type
= BT_INTEGER
;
478 ts
.kind
= gfc_c_int_kind
;
479 gfc_convert_type (n2
, &ts
, 2);
482 if (f
->value
.function
.isym
->id
== GFC_ISYM_JN2
)
483 f
->value
.function
.name
= gfc_get_string (PREFIX ("bessel_jn_r%d"),
486 f
->value
.function
.name
= gfc_get_string (PREFIX ("bessel_yn_r%d"),
492 gfc_resolve_btest (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos
)
494 f
->ts
.type
= BT_LOGICAL
;
495 f
->ts
.kind
= gfc_default_logical_kind
;
496 f
->value
.function
.name
497 = gfc_get_string ("__btest_%d_%d", i
->ts
.kind
, pos
->ts
.kind
);
502 gfc_resolve_ceiling (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
504 f
->ts
.type
= BT_INTEGER
;
505 f
->ts
.kind
= (kind
== NULL
)
506 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
507 f
->value
.function
.name
508 = gfc_get_string ("__ceiling_%d_%c%d", f
->ts
.kind
,
509 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
514 gfc_resolve_char (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
516 gfc_resolve_char_achar (f
, a
, kind
, "__char_%d_%c%d");
521 gfc_resolve_chdir (gfc_expr
*f
, gfc_expr
*d ATTRIBUTE_UNUSED
)
523 f
->ts
.type
= BT_INTEGER
;
524 f
->ts
.kind
= gfc_default_integer_kind
;
525 f
->value
.function
.name
= gfc_get_string (PREFIX ("chdir_i%d"), f
->ts
.kind
);
530 gfc_resolve_chdir_sub (gfc_code
*c
)
535 if (c
->ext
.actual
->next
->expr
!= NULL
)
536 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
538 kind
= gfc_default_integer_kind
;
540 name
= gfc_get_string (PREFIX ("chdir_i%d_sub"), kind
);
541 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
546 gfc_resolve_chmod (gfc_expr
*f
, gfc_expr
*name ATTRIBUTE_UNUSED
,
547 gfc_expr
*mode ATTRIBUTE_UNUSED
)
549 f
->ts
.type
= BT_INTEGER
;
550 f
->ts
.kind
= gfc_c_int_kind
;
551 f
->value
.function
.name
= PREFIX ("chmod_func");
556 gfc_resolve_chmod_sub (gfc_code
*c
)
561 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
562 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
564 kind
= gfc_default_integer_kind
;
566 name
= gfc_get_string (PREFIX ("chmod_i%d_sub"), kind
);
567 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
572 gfc_resolve_cmplx (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*kind
)
574 f
->ts
.type
= BT_COMPLEX
;
575 f
->ts
.kind
= (kind
== NULL
)
576 ? gfc_default_real_kind
: mpz_get_si (kind
->value
.integer
);
579 f
->value
.function
.name
580 = gfc_get_string ("__cmplx0_%d_%c%d", f
->ts
.kind
,
581 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
583 f
->value
.function
.name
584 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f
->ts
.kind
,
585 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
,
586 gfc_type_letter (y
->ts
.type
), y
->ts
.kind
);
591 gfc_resolve_dcmplx (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
)
593 gfc_resolve_cmplx (f
, x
, y
, gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
594 gfc_default_double_kind
));
599 gfc_resolve_complex (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
)
603 if (x
->ts
.type
== BT_INTEGER
)
605 if (y
->ts
.type
== BT_INTEGER
)
606 kind
= gfc_default_real_kind
;
612 if (y
->ts
.type
== BT_REAL
)
613 kind
= (x
->ts
.kind
> y
->ts
.kind
) ? x
->ts
.kind
: y
->ts
.kind
;
618 f
->ts
.type
= BT_COMPLEX
;
620 f
->value
.function
.name
621 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f
->ts
.kind
,
622 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
,
623 gfc_type_letter (y
->ts
.type
), y
->ts
.kind
);
628 gfc_resolve_conjg (gfc_expr
*f
, gfc_expr
*x
)
631 f
->value
.function
.name
= gfc_get_string ("__conjg_%d", x
->ts
.kind
);
636 gfc_resolve_cos (gfc_expr
*f
, gfc_expr
*x
)
639 f
->value
.function
.name
640 = gfc_get_string ("__cos_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
645 gfc_resolve_cosh (gfc_expr
*f
, gfc_expr
*x
)
648 f
->value
.function
.name
649 = gfc_get_string ("__cosh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
654 gfc_resolve_count (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
656 f
->ts
.type
= BT_INTEGER
;
658 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
660 f
->ts
.kind
= gfc_default_integer_kind
;
664 f
->rank
= mask
->rank
- 1;
665 gfc_resolve_dim_arg (dim
);
666 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
669 resolve_mask_arg (mask
);
671 f
->value
.function
.name
672 = gfc_get_string (PREFIX ("count_%d_%c"), f
->ts
.kind
,
673 gfc_type_letter (mask
->ts
.type
));
678 gfc_resolve_cshift (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*shift
,
683 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
684 gfc_resolve_substring_charlen (array
);
687 f
->rank
= array
->rank
;
688 f
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
695 /* If dim kind is greater than default integer we need to use the larger. */
696 m
= gfc_default_integer_kind
;
698 m
= m
< dim
->ts
.kind
? dim
->ts
.kind
: m
;
700 /* Convert shift to at least m, so we don't need
701 kind=1 and kind=2 versions of the library functions. */
702 if (shift
->ts
.kind
< m
)
706 ts
.type
= BT_INTEGER
;
708 gfc_convert_type_warn (shift
, &ts
, 2, 0);
713 if (dim
->expr_type
!= EXPR_CONSTANT
&& dim
->symtree
!= NULL
714 && dim
->symtree
->n
.sym
->attr
.optional
)
716 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
717 dim
->representation
.length
= shift
->ts
.kind
;
721 gfc_resolve_dim_arg (dim
);
722 /* Convert dim to shift's kind to reduce variations. */
723 if (dim
->ts
.kind
!= shift
->ts
.kind
)
724 gfc_convert_type_warn (dim
, &shift
->ts
, 2, 0);
728 if (array
->ts
.type
== BT_CHARACTER
)
730 if (array
->ts
.kind
== gfc_default_character_kind
)
731 f
->value
.function
.name
732 = gfc_get_string (PREFIX ("cshift%d_%d_char"), n
, shift
->ts
.kind
);
734 f
->value
.function
.name
735 = gfc_get_string (PREFIX ("cshift%d_%d_char%d"), n
, shift
->ts
.kind
,
739 f
->value
.function
.name
740 = gfc_get_string (PREFIX ("cshift%d_%d"), n
, shift
->ts
.kind
);
745 gfc_resolve_ctime (gfc_expr
*f
, gfc_expr
*time
)
750 f
->ts
.type
= BT_CHARACTER
;
751 f
->ts
.kind
= gfc_default_character_kind
;
753 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
754 if (time
->ts
.kind
!= 8)
756 ts
.type
= BT_INTEGER
;
760 gfc_convert_type (time
, &ts
, 2);
763 f
->value
.function
.name
= gfc_get_string (PREFIX ("ctime"));
768 gfc_resolve_dble (gfc_expr
*f
, gfc_expr
*a
)
770 f
->ts
.type
= BT_REAL
;
771 f
->ts
.kind
= gfc_default_double_kind
;
772 f
->value
.function
.name
773 = gfc_get_string ("__dble_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
778 gfc_resolve_dim (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
780 f
->ts
.type
= a
->ts
.type
;
782 f
->ts
.kind
= gfc_kind_max (a
,p
);
784 f
->ts
.kind
= a
->ts
.kind
;
786 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
788 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
789 gfc_convert_type (p
, &a
->ts
, 2);
791 gfc_convert_type (a
, &p
->ts
, 2);
794 f
->value
.function
.name
795 = gfc_get_string ("__dim_%c%d", gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
800 gfc_resolve_dot_product (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b
)
804 temp
.expr_type
= EXPR_OP
;
805 gfc_clear_ts (&temp
.ts
);
806 temp
.value
.op
.op
= INTRINSIC_NONE
;
807 temp
.value
.op
.op1
= a
;
808 temp
.value
.op
.op2
= b
;
809 gfc_type_convert_binary (&temp
, 1);
811 f
->value
.function
.name
812 = gfc_get_string (PREFIX ("dot_product_%c%d"),
813 gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
818 gfc_resolve_dprod (gfc_expr
*f
, gfc_expr
*a ATTRIBUTE_UNUSED
,
819 gfc_expr
*b ATTRIBUTE_UNUSED
)
821 f
->ts
.kind
= gfc_default_double_kind
;
822 f
->ts
.type
= BT_REAL
;
823 f
->value
.function
.name
= gfc_get_string ("__dprod_r%d", f
->ts
.kind
);
828 gfc_resolve_dshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j ATTRIBUTE_UNUSED
,
829 gfc_expr
*shift ATTRIBUTE_UNUSED
)
832 if (f
->value
.function
.isym
->id
== GFC_ISYM_DSHIFTL
)
833 f
->value
.function
.name
= gfc_get_string ("dshiftl_i%d", f
->ts
.kind
);
834 else if (f
->value
.function
.isym
->id
== GFC_ISYM_DSHIFTR
)
835 f
->value
.function
.name
= gfc_get_string ("dshiftr_i%d", f
->ts
.kind
);
842 gfc_resolve_eoshift (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*shift
,
843 gfc_expr
*boundary
, gfc_expr
*dim
)
847 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
848 gfc_resolve_substring_charlen (array
);
851 f
->rank
= array
->rank
;
852 f
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
857 if (boundary
&& boundary
->rank
> 0)
860 /* If dim kind is greater than default integer we need to use the larger. */
861 m
= gfc_default_integer_kind
;
863 m
= m
< dim
->ts
.kind
? dim
->ts
.kind
: m
;
865 /* Convert shift to at least m, so we don't need
866 kind=1 and kind=2 versions of the library functions. */
867 if (shift
->ts
.kind
< m
)
871 ts
.type
= BT_INTEGER
;
873 gfc_convert_type_warn (shift
, &ts
, 2, 0);
878 if (dim
->expr_type
!= EXPR_CONSTANT
&& dim
->symtree
!= NULL
879 && dim
->symtree
->n
.sym
->attr
.optional
)
881 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
882 dim
->representation
.length
= shift
->ts
.kind
;
886 gfc_resolve_dim_arg (dim
);
887 /* Convert dim to shift's kind to reduce variations. */
888 if (dim
->ts
.kind
!= shift
->ts
.kind
)
889 gfc_convert_type_warn (dim
, &shift
->ts
, 2, 0);
893 if (array
->ts
.type
== BT_CHARACTER
)
895 if (array
->ts
.kind
== gfc_default_character_kind
)
896 f
->value
.function
.name
897 = gfc_get_string (PREFIX ("eoshift%d_%d_char"), n
, shift
->ts
.kind
);
899 f
->value
.function
.name
900 = gfc_get_string (PREFIX ("eoshift%d_%d_char%d"), n
, shift
->ts
.kind
,
904 f
->value
.function
.name
905 = gfc_get_string (PREFIX ("eoshift%d_%d"), n
, shift
->ts
.kind
);
910 gfc_resolve_exp (gfc_expr
*f
, gfc_expr
*x
)
913 f
->value
.function
.name
914 = gfc_get_string ("__exp_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
919 gfc_resolve_exponent (gfc_expr
*f
, gfc_expr
*x
)
921 f
->ts
.type
= BT_INTEGER
;
922 f
->ts
.kind
= gfc_default_integer_kind
;
923 f
->value
.function
.name
= gfc_get_string ("__exponent_%d", x
->ts
.kind
);
927 /* Resolve the EXTENDS_TYPE_OF intrinsic function. */
930 gfc_resolve_extends_type_of (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*mo
)
935 /* Prevent double resolution. */
936 if (f
->ts
.type
== BT_LOGICAL
)
939 /* Replace the first argument with the corresponding vtab. */
940 if (a
->ts
.type
== BT_CLASS
)
941 gfc_add_vptr_component (a
);
942 else if (a
->ts
.type
== BT_DERIVED
)
944 vtab
= gfc_find_derived_vtab (a
->ts
.u
.derived
);
945 /* Clear the old expr. */
946 gfc_free_ref_list (a
->ref
);
947 memset (a
, '\0', sizeof (gfc_expr
));
948 /* Construct a new one. */
949 a
->expr_type
= EXPR_VARIABLE
;
950 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
955 /* Replace the second argument with the corresponding vtab. */
956 if (mo
->ts
.type
== BT_CLASS
)
957 gfc_add_vptr_component (mo
);
958 else if (mo
->ts
.type
== BT_DERIVED
)
960 vtab
= gfc_find_derived_vtab (mo
->ts
.u
.derived
);
961 /* Clear the old expr. */
962 gfc_free_ref_list (mo
->ref
);
963 memset (mo
, '\0', sizeof (gfc_expr
));
964 /* Construct a new one. */
965 mo
->expr_type
= EXPR_VARIABLE
;
966 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
971 f
->ts
.type
= BT_LOGICAL
;
974 f
->value
.function
.isym
->formal
->ts
= a
->ts
;
975 f
->value
.function
.isym
->formal
->next
->ts
= mo
->ts
;
977 /* Call library function. */
978 f
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
983 gfc_resolve_fdate (gfc_expr
*f
)
985 f
->ts
.type
= BT_CHARACTER
;
986 f
->ts
.kind
= gfc_default_character_kind
;
987 f
->value
.function
.name
= gfc_get_string (PREFIX ("fdate"));
992 gfc_resolve_floor (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
994 f
->ts
.type
= BT_INTEGER
;
995 f
->ts
.kind
= (kind
== NULL
)
996 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
997 f
->value
.function
.name
998 = gfc_get_string ("__floor%d_%c%d", f
->ts
.kind
,
999 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1004 gfc_resolve_fnum (gfc_expr
*f
, gfc_expr
*n
)
1006 f
->ts
.type
= BT_INTEGER
;
1007 f
->ts
.kind
= gfc_default_integer_kind
;
1008 if (n
->ts
.kind
!= f
->ts
.kind
)
1009 gfc_convert_type (n
, &f
->ts
, 2);
1010 f
->value
.function
.name
= gfc_get_string (PREFIX ("fnum_i%d"), f
->ts
.kind
);
1015 gfc_resolve_fraction (gfc_expr
*f
, gfc_expr
*x
)
1018 f
->value
.function
.name
= gfc_get_string ("__fraction_%d", x
->ts
.kind
);
1022 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
1025 gfc_resolve_g77_math1 (gfc_expr
*f
, gfc_expr
*x
)
1028 f
->value
.function
.name
= gfc_get_string ("<intrinsic>");
1033 gfc_resolve_gamma (gfc_expr
*f
, gfc_expr
*x
)
1036 f
->value
.function
.name
1037 = gfc_get_string ("__tgamma_%d", x
->ts
.kind
);
1042 gfc_resolve_getcwd (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
1044 f
->ts
.type
= BT_INTEGER
;
1046 f
->value
.function
.name
= gfc_get_string (PREFIX ("getcwd"));
1051 gfc_resolve_getgid (gfc_expr
*f
)
1053 f
->ts
.type
= BT_INTEGER
;
1055 f
->value
.function
.name
= gfc_get_string (PREFIX ("getgid"));
1060 gfc_resolve_getpid (gfc_expr
*f
)
1062 f
->ts
.type
= BT_INTEGER
;
1064 f
->value
.function
.name
= gfc_get_string (PREFIX ("getpid"));
1069 gfc_resolve_getuid (gfc_expr
*f
)
1071 f
->ts
.type
= BT_INTEGER
;
1073 f
->value
.function
.name
= gfc_get_string (PREFIX ("getuid"));
1078 gfc_resolve_hostnm (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
1080 f
->ts
.type
= BT_INTEGER
;
1082 f
->value
.function
.name
= gfc_get_string (PREFIX ("hostnm"));
1087 gfc_resolve_hypot (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
1090 f
->value
.function
.name
= gfc_get_string ("__hypot_r%d", x
->ts
.kind
);
1095 gfc_resolve_iall (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
1097 resolve_transformational ("iall", f
, array
, dim
, mask
);
1102 gfc_resolve_iand (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1104 /* If the kind of i and j are different, then g77 cross-promoted the
1105 kinds to the largest value. The Fortran 95 standard requires the
1107 if (i
->ts
.kind
!= j
->ts
.kind
)
1109 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1110 gfc_convert_type (j
, &i
->ts
, 2);
1112 gfc_convert_type (i
, &j
->ts
, 2);
1116 f
->value
.function
.name
= gfc_get_string ("__iand_%d", i
->ts
.kind
);
1121 gfc_resolve_iany (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
1123 resolve_transformational ("iany", f
, array
, dim
, mask
);
1128 gfc_resolve_ibclr (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
)
1131 f
->value
.function
.name
= gfc_get_string ("__ibclr_%d", i
->ts
.kind
);
1136 gfc_resolve_ibits (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
,
1137 gfc_expr
*len ATTRIBUTE_UNUSED
)
1140 f
->value
.function
.name
= gfc_get_string ("__ibits_%d", i
->ts
.kind
);
1145 gfc_resolve_ibset (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
)
1148 f
->value
.function
.name
= gfc_get_string ("__ibset_%d", i
->ts
.kind
);
1153 gfc_resolve_iachar (gfc_expr
*f
, gfc_expr
*c
, gfc_expr
*kind
)
1155 f
->ts
.type
= BT_INTEGER
;
1157 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1159 f
->ts
.kind
= gfc_default_integer_kind
;
1160 f
->value
.function
.name
= gfc_get_string ("__ichar_%d", c
->ts
.kind
);
1165 gfc_resolve_ichar (gfc_expr
*f
, gfc_expr
*c
, gfc_expr
*kind
)
1167 f
->ts
.type
= BT_INTEGER
;
1169 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1171 f
->ts
.kind
= gfc_default_integer_kind
;
1172 f
->value
.function
.name
= gfc_get_string ("__ichar_%d", c
->ts
.kind
);
1177 gfc_resolve_idnint (gfc_expr
*f
, gfc_expr
*a
)
1179 gfc_resolve_nint (f
, a
, NULL
);
1184 gfc_resolve_ierrno (gfc_expr
*f
)
1186 f
->ts
.type
= BT_INTEGER
;
1187 f
->ts
.kind
= gfc_default_integer_kind
;
1188 f
->value
.function
.name
= gfc_get_string (PREFIX ("ierrno_i%d"), f
->ts
.kind
);
1193 gfc_resolve_ieor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1195 /* If the kind of i and j are different, then g77 cross-promoted the
1196 kinds to the largest value. The Fortran 95 standard requires the
1198 if (i
->ts
.kind
!= j
->ts
.kind
)
1200 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1201 gfc_convert_type (j
, &i
->ts
, 2);
1203 gfc_convert_type (i
, &j
->ts
, 2);
1207 f
->value
.function
.name
= gfc_get_string ("__ieor_%d", i
->ts
.kind
);
1212 gfc_resolve_ior (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1214 /* If the kind of i and j are different, then g77 cross-promoted the
1215 kinds to the largest value. The Fortran 95 standard requires the
1217 if (i
->ts
.kind
!= j
->ts
.kind
)
1219 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1220 gfc_convert_type (j
, &i
->ts
, 2);
1222 gfc_convert_type (i
, &j
->ts
, 2);
1226 f
->value
.function
.name
= gfc_get_string ("__ior_%d", i
->ts
.kind
);
1231 gfc_resolve_index_func (gfc_expr
*f
, gfc_expr
*str
,
1232 gfc_expr
*sub_str ATTRIBUTE_UNUSED
, gfc_expr
*back
,
1238 f
->ts
.type
= BT_INTEGER
;
1240 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1242 f
->ts
.kind
= gfc_default_integer_kind
;
1244 if (back
&& back
->ts
.kind
!= gfc_default_integer_kind
)
1246 ts
.type
= BT_LOGICAL
;
1247 ts
.kind
= gfc_default_integer_kind
;
1248 ts
.u
.derived
= NULL
;
1250 gfc_convert_type (back
, &ts
, 2);
1253 f
->value
.function
.name
1254 = gfc_get_string ("__index_%d_i%d", str
->ts
.kind
, f
->ts
.kind
);
1259 gfc_resolve_int (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1261 f
->ts
.type
= BT_INTEGER
;
1262 f
->ts
.kind
= (kind
== NULL
)
1263 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
1264 f
->value
.function
.name
1265 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1266 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1271 gfc_resolve_int2 (gfc_expr
*f
, gfc_expr
*a
)
1273 f
->ts
.type
= BT_INTEGER
;
1275 f
->value
.function
.name
1276 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1277 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1282 gfc_resolve_int8 (gfc_expr
*f
, gfc_expr
*a
)
1284 f
->ts
.type
= BT_INTEGER
;
1286 f
->value
.function
.name
1287 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1288 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1293 gfc_resolve_long (gfc_expr
*f
, gfc_expr
*a
)
1295 f
->ts
.type
= BT_INTEGER
;
1297 f
->value
.function
.name
1298 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1299 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1304 gfc_resolve_iparity (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
1306 resolve_transformational ("iparity", f
, array
, dim
, mask
);
1311 gfc_resolve_isatty (gfc_expr
*f
, gfc_expr
*u
)
1316 f
->ts
.type
= BT_LOGICAL
;
1317 f
->ts
.kind
= gfc_default_integer_kind
;
1318 if (u
->ts
.kind
!= gfc_c_int_kind
)
1320 ts
.type
= BT_INTEGER
;
1321 ts
.kind
= gfc_c_int_kind
;
1322 ts
.u
.derived
= NULL
;
1324 gfc_convert_type (u
, &ts
, 2);
1327 f
->value
.function
.name
= gfc_get_string (PREFIX ("isatty_l%d"), f
->ts
.kind
);
1332 gfc_resolve_ishft (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1335 f
->value
.function
.name
1336 = gfc_get_string ("__ishft_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1341 gfc_resolve_rshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1344 f
->value
.function
.name
1345 = gfc_get_string ("__rshift_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1350 gfc_resolve_lshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1353 f
->value
.function
.name
1354 = gfc_get_string ("__lshift_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1359 gfc_resolve_ishftc (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
1363 s_kind
= (size
== NULL
) ? gfc_default_integer_kind
: size
->ts
.kind
;
1366 f
->value
.function
.name
1367 = gfc_get_string ("__ishftc_%d_%d_%d", i
->ts
.kind
, shift
->ts
.kind
, s_kind
);
1372 gfc_resolve_kill (gfc_expr
*f
, gfc_expr
*p ATTRIBUTE_UNUSED
,
1373 gfc_expr
*s ATTRIBUTE_UNUSED
)
1375 f
->ts
.type
= BT_INTEGER
;
1376 f
->ts
.kind
= gfc_default_integer_kind
;
1377 f
->value
.function
.name
= gfc_get_string (PREFIX ("kill_i%d"), f
->ts
.kind
);
1382 gfc_resolve_lbound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
1384 resolve_bound (f
, array
, dim
, kind
, "__lbound", false);
1389 gfc_resolve_lcobound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
1391 resolve_bound (f
, array
, dim
, kind
, "__lcobound", true);
1396 gfc_resolve_len (gfc_expr
*f
, gfc_expr
*string
, gfc_expr
*kind
)
1398 f
->ts
.type
= BT_INTEGER
;
1400 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1402 f
->ts
.kind
= gfc_default_integer_kind
;
1403 f
->value
.function
.name
1404 = gfc_get_string ("__len_%d_i%d", string
->ts
.kind
,
1405 gfc_default_integer_kind
);
1410 gfc_resolve_len_trim (gfc_expr
*f
, gfc_expr
*string
, gfc_expr
*kind
)
1412 f
->ts
.type
= BT_INTEGER
;
1414 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1416 f
->ts
.kind
= gfc_default_integer_kind
;
1417 f
->value
.function
.name
= gfc_get_string ("__len_trim%d", string
->ts
.kind
);
1422 gfc_resolve_lgamma (gfc_expr
*f
, gfc_expr
*x
)
1425 f
->value
.function
.name
1426 = gfc_get_string ("__lgamma_%d", x
->ts
.kind
);
1431 gfc_resolve_link (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
1432 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
1434 f
->ts
.type
= BT_INTEGER
;
1435 f
->ts
.kind
= gfc_default_integer_kind
;
1436 f
->value
.function
.name
= gfc_get_string (PREFIX ("link_i%d"), f
->ts
.kind
);
1441 gfc_resolve_loc (gfc_expr
*f
, gfc_expr
*x
)
1443 f
->ts
.type
= BT_INTEGER
;
1444 f
->ts
.kind
= gfc_index_integer_kind
;
1445 f
->value
.function
.name
= gfc_get_string ("__loc_%d", x
->ts
.kind
);
1450 gfc_resolve_log (gfc_expr
*f
, gfc_expr
*x
)
1453 f
->value
.function
.name
1454 = gfc_get_string ("__log_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1459 gfc_resolve_log10 (gfc_expr
*f
, gfc_expr
*x
)
1462 f
->value
.function
.name
1463 = gfc_get_string ("__log10_%c%d", gfc_type_letter (x
->ts
.type
),
1469 gfc_resolve_logical (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1471 f
->ts
.type
= BT_LOGICAL
;
1472 f
->ts
.kind
= (kind
== NULL
)
1473 ? gfc_default_logical_kind
: mpz_get_si (kind
->value
.integer
);
1476 f
->value
.function
.name
1477 = gfc_get_string ("__logical_%d_%c%d", f
->ts
.kind
,
1478 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1483 gfc_resolve_malloc (gfc_expr
*f
, gfc_expr
*size
)
1485 if (size
->ts
.kind
< gfc_index_integer_kind
)
1490 ts
.type
= BT_INTEGER
;
1491 ts
.kind
= gfc_index_integer_kind
;
1492 gfc_convert_type_warn (size
, &ts
, 2, 0);
1495 f
->ts
.type
= BT_INTEGER
;
1496 f
->ts
.kind
= gfc_index_integer_kind
;
1497 f
->value
.function
.name
= gfc_get_string (PREFIX ("malloc"));
1502 gfc_resolve_matmul (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b
)
1506 if (a
->ts
.type
== BT_LOGICAL
&& b
->ts
.type
== BT_LOGICAL
)
1508 f
->ts
.type
= BT_LOGICAL
;
1509 f
->ts
.kind
= gfc_default_logical_kind
;
1513 temp
.expr_type
= EXPR_OP
;
1514 gfc_clear_ts (&temp
.ts
);
1515 temp
.value
.op
.op
= INTRINSIC_NONE
;
1516 temp
.value
.op
.op1
= a
;
1517 temp
.value
.op
.op2
= b
;
1518 gfc_type_convert_binary (&temp
, 1);
1522 f
->rank
= (a
->rank
== 2 && b
->rank
== 2) ? 2 : 1;
1524 if (a
->rank
== 2 && b
->rank
== 2)
1526 if (a
->shape
&& b
->shape
)
1528 f
->shape
= gfc_get_shape (f
->rank
);
1529 mpz_init_set (f
->shape
[0], a
->shape
[0]);
1530 mpz_init_set (f
->shape
[1], b
->shape
[1]);
1533 else if (a
->rank
== 1)
1537 f
->shape
= gfc_get_shape (f
->rank
);
1538 mpz_init_set (f
->shape
[0], b
->shape
[1]);
1543 /* b->rank == 1 and a->rank == 2 here, all other cases have
1544 been caught in check.c. */
1547 f
->shape
= gfc_get_shape (f
->rank
);
1548 mpz_init_set (f
->shape
[0], a
->shape
[0]);
1552 f
->value
.function
.name
1553 = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f
->ts
.type
),
1559 gfc_resolve_minmax (const char *name
, gfc_expr
*f
, gfc_actual_arglist
*args
)
1561 gfc_actual_arglist
*a
;
1563 f
->ts
.type
= args
->expr
->ts
.type
;
1564 f
->ts
.kind
= args
->expr
->ts
.kind
;
1565 /* Find the largest type kind. */
1566 for (a
= args
->next
; a
; a
= a
->next
)
1568 if (a
->expr
->ts
.kind
> f
->ts
.kind
)
1569 f
->ts
.kind
= a
->expr
->ts
.kind
;
1572 /* Convert all parameters to the required kind. */
1573 for (a
= args
; a
; a
= a
->next
)
1575 if (a
->expr
->ts
.kind
!= f
->ts
.kind
)
1576 gfc_convert_type (a
->expr
, &f
->ts
, 2);
1579 f
->value
.function
.name
1580 = gfc_get_string (name
, gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
1585 gfc_resolve_max (gfc_expr
*f
, gfc_actual_arglist
*args
)
1587 gfc_resolve_minmax ("__max_%c%d", f
, args
);
1592 gfc_resolve_maxloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1598 f
->ts
.type
= BT_INTEGER
;
1599 f
->ts
.kind
= gfc_default_integer_kind
;
1604 f
->shape
= gfc_get_shape (1);
1605 mpz_init_set_si (f
->shape
[0], array
->rank
);
1609 f
->rank
= array
->rank
- 1;
1610 gfc_resolve_dim_arg (dim
);
1611 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1613 idim
= (int) mpz_get_si (dim
->value
.integer
);
1614 f
->shape
= gfc_get_shape (f
->rank
);
1615 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1617 if (i
== (idim
- 1))
1619 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1626 if (mask
->rank
== 0)
1631 resolve_mask_arg (mask
);
1636 f
->value
.function
.name
1637 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name
, dim
!= NULL
, f
->ts
.kind
,
1638 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1643 gfc_resolve_maxval (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1653 f
->rank
= array
->rank
- 1;
1654 gfc_resolve_dim_arg (dim
);
1656 if (f
->rank
&& array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1658 idim
= (int) mpz_get_si (dim
->value
.integer
);
1659 f
->shape
= gfc_get_shape (f
->rank
);
1660 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1662 if (i
== (idim
- 1))
1664 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1671 if (mask
->rank
== 0)
1676 resolve_mask_arg (mask
);
1681 f
->value
.function
.name
1682 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
1683 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1688 gfc_resolve_mclock (gfc_expr
*f
)
1690 f
->ts
.type
= BT_INTEGER
;
1692 f
->value
.function
.name
= PREFIX ("mclock");
1697 gfc_resolve_mclock8 (gfc_expr
*f
)
1699 f
->ts
.type
= BT_INTEGER
;
1701 f
->value
.function
.name
= PREFIX ("mclock8");
1706 gfc_resolve_mask (gfc_expr
*f
, gfc_expr
*i ATTRIBUTE_UNUSED
,
1709 f
->ts
.type
= BT_INTEGER
;
1710 f
->ts
.kind
= kind
? mpz_get_si (kind
->value
.integer
)
1711 : gfc_default_integer_kind
;
1713 if (f
->value
.function
.isym
->id
== GFC_ISYM_MASKL
)
1714 f
->value
.function
.name
= gfc_get_string ("__maskl_i%d", f
->ts
.kind
);
1716 f
->value
.function
.name
= gfc_get_string ("__maskr_i%d", f
->ts
.kind
);
1721 gfc_resolve_merge (gfc_expr
*f
, gfc_expr
*tsource
,
1722 gfc_expr
*fsource ATTRIBUTE_UNUSED
,
1723 gfc_expr
*mask ATTRIBUTE_UNUSED
)
1725 if (tsource
->ts
.type
== BT_CHARACTER
&& tsource
->ref
)
1726 gfc_resolve_substring_charlen (tsource
);
1728 if (fsource
->ts
.type
== BT_CHARACTER
&& fsource
->ref
)
1729 gfc_resolve_substring_charlen (fsource
);
1731 if (tsource
->ts
.type
== BT_CHARACTER
)
1732 check_charlen_present (tsource
);
1734 f
->ts
= tsource
->ts
;
1735 f
->value
.function
.name
1736 = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource
->ts
.type
),
1742 gfc_resolve_merge_bits (gfc_expr
*f
, gfc_expr
*i
,
1743 gfc_expr
*j ATTRIBUTE_UNUSED
,
1744 gfc_expr
*mask ATTRIBUTE_UNUSED
)
1747 f
->value
.function
.name
= gfc_get_string ("__merge_bits_i%d", i
->ts
.kind
);
1752 gfc_resolve_min (gfc_expr
*f
, gfc_actual_arglist
*args
)
1754 gfc_resolve_minmax ("__min_%c%d", f
, args
);
1759 gfc_resolve_minloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1765 f
->ts
.type
= BT_INTEGER
;
1766 f
->ts
.kind
= gfc_default_integer_kind
;
1771 f
->shape
= gfc_get_shape (1);
1772 mpz_init_set_si (f
->shape
[0], array
->rank
);
1776 f
->rank
= array
->rank
- 1;
1777 gfc_resolve_dim_arg (dim
);
1778 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1780 idim
= (int) mpz_get_si (dim
->value
.integer
);
1781 f
->shape
= gfc_get_shape (f
->rank
);
1782 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1784 if (i
== (idim
- 1))
1786 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1793 if (mask
->rank
== 0)
1798 resolve_mask_arg (mask
);
1803 f
->value
.function
.name
1804 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name
, dim
!= NULL
, f
->ts
.kind
,
1805 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1810 gfc_resolve_minval (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1820 f
->rank
= array
->rank
- 1;
1821 gfc_resolve_dim_arg (dim
);
1823 if (f
->rank
&& array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1825 idim
= (int) mpz_get_si (dim
->value
.integer
);
1826 f
->shape
= gfc_get_shape (f
->rank
);
1827 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1829 if (i
== (idim
- 1))
1831 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1838 if (mask
->rank
== 0)
1843 resolve_mask_arg (mask
);
1848 f
->value
.function
.name
1849 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
1850 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1855 gfc_resolve_mod (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
1857 f
->ts
.type
= a
->ts
.type
;
1859 f
->ts
.kind
= gfc_kind_max (a
,p
);
1861 f
->ts
.kind
= a
->ts
.kind
;
1863 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
1865 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
1866 gfc_convert_type (p
, &a
->ts
, 2);
1868 gfc_convert_type (a
, &p
->ts
, 2);
1871 f
->value
.function
.name
1872 = gfc_get_string ("__mod_%c%d", gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
1877 gfc_resolve_modulo (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
1879 f
->ts
.type
= a
->ts
.type
;
1881 f
->ts
.kind
= gfc_kind_max (a
,p
);
1883 f
->ts
.kind
= a
->ts
.kind
;
1885 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
1887 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
1888 gfc_convert_type (p
, &a
->ts
, 2);
1890 gfc_convert_type (a
, &p
->ts
, 2);
1893 f
->value
.function
.name
1894 = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f
->ts
.type
),
1899 gfc_resolve_nearest (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
1901 if (p
->ts
.kind
!= a
->ts
.kind
)
1902 gfc_convert_type (p
, &a
->ts
, 2);
1905 f
->value
.function
.name
1906 = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a
->ts
.type
),
1911 gfc_resolve_nint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1913 f
->ts
.type
= BT_INTEGER
;
1914 f
->ts
.kind
= (kind
== NULL
)
1915 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
1916 f
->value
.function
.name
1917 = gfc_get_string ("__nint_%d_%d", f
->ts
.kind
, a
->ts
.kind
);
1922 gfc_resolve_norm2 (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
)
1924 resolve_transformational ("norm2", f
, array
, dim
, NULL
);
1929 gfc_resolve_not (gfc_expr
*f
, gfc_expr
*i
)
1932 f
->value
.function
.name
= gfc_get_string ("__not_%d", i
->ts
.kind
);
1937 gfc_resolve_or (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1939 f
->ts
.type
= i
->ts
.type
;
1940 f
->ts
.kind
= gfc_kind_max (i
, j
);
1942 if (i
->ts
.kind
!= j
->ts
.kind
)
1944 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1945 gfc_convert_type (j
, &i
->ts
, 2);
1947 gfc_convert_type (i
, &j
->ts
, 2);
1950 f
->value
.function
.name
1951 = gfc_get_string ("__or_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
1956 gfc_resolve_pack (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*mask
,
1957 gfc_expr
*vector ATTRIBUTE_UNUSED
)
1959 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
1960 gfc_resolve_substring_charlen (array
);
1965 resolve_mask_arg (mask
);
1967 if (mask
->rank
!= 0)
1969 if (array
->ts
.type
== BT_CHARACTER
)
1970 f
->value
.function
.name
1971 = array
->ts
.kind
== 1 ? PREFIX ("pack_char")
1973 (PREFIX ("pack_char%d"),
1976 f
->value
.function
.name
= PREFIX ("pack");
1980 if (array
->ts
.type
== BT_CHARACTER
)
1981 f
->value
.function
.name
1982 = array
->ts
.kind
== 1 ? PREFIX ("pack_s_char")
1984 (PREFIX ("pack_s_char%d"),
1987 f
->value
.function
.name
= PREFIX ("pack_s");
1993 gfc_resolve_parity (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
)
1995 resolve_transformational ("parity", f
, array
, dim
, NULL
);
2000 gfc_resolve_product (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
2003 resolve_transformational ("product", f
, array
, dim
, mask
);
2008 gfc_resolve_real (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
2010 f
->ts
.type
= BT_REAL
;
2013 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2015 f
->ts
.kind
= (a
->ts
.type
== BT_COMPLEX
)
2016 ? a
->ts
.kind
: gfc_default_real_kind
;
2018 f
->value
.function
.name
2019 = gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
2020 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2025 gfc_resolve_realpart (gfc_expr
*f
, gfc_expr
*a
)
2027 f
->ts
.type
= BT_REAL
;
2028 f
->ts
.kind
= a
->ts
.kind
;
2029 f
->value
.function
.name
2030 = gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
2031 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2036 gfc_resolve_rename (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
2037 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
2039 f
->ts
.type
= BT_INTEGER
;
2040 f
->ts
.kind
= gfc_default_integer_kind
;
2041 f
->value
.function
.name
= gfc_get_string (PREFIX ("rename_i%d"), f
->ts
.kind
);
2046 gfc_resolve_repeat (gfc_expr
*f
, gfc_expr
*string
,
2047 gfc_expr
*ncopies ATTRIBUTE_UNUSED
)
2049 f
->ts
.type
= BT_CHARACTER
;
2050 f
->ts
.kind
= string
->ts
.kind
;
2051 f
->value
.function
.name
= gfc_get_string ("__repeat_%d", string
->ts
.kind
);
2056 gfc_resolve_reshape (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*shape
,
2057 gfc_expr
*pad ATTRIBUTE_UNUSED
,
2058 gfc_expr
*order ATTRIBUTE_UNUSED
)
2064 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
2065 gfc_resolve_substring_charlen (source
);
2069 gfc_array_size (shape
, &rank
);
2070 f
->rank
= mpz_get_si (rank
);
2072 switch (source
->ts
.type
)
2079 kind
= source
->ts
.kind
;
2093 if (source
->ts
.type
== BT_COMPLEX
|| source
->ts
.type
== BT_REAL
)
2094 f
->value
.function
.name
2095 = gfc_get_string (PREFIX ("reshape_%c%d"),
2096 gfc_type_letter (source
->ts
.type
),
2098 else if (source
->ts
.type
== BT_CHARACTER
)
2099 f
->value
.function
.name
= gfc_get_string (PREFIX ("reshape_char%d"),
2102 f
->value
.function
.name
2103 = gfc_get_string (PREFIX ("reshape_%d"), source
->ts
.kind
);
2107 f
->value
.function
.name
= (source
->ts
.type
== BT_CHARACTER
2108 ? PREFIX ("reshape_char") : PREFIX ("reshape"));
2112 /* TODO: Make this work with a constant ORDER parameter. */
2113 if (shape
->expr_type
== EXPR_ARRAY
2114 && gfc_is_constant_expr (shape
)
2118 f
->shape
= gfc_get_shape (f
->rank
);
2119 c
= gfc_constructor_first (shape
->value
.constructor
);
2120 for (i
= 0; i
< f
->rank
; i
++)
2122 mpz_init_set (f
->shape
[i
], c
->expr
->value
.integer
);
2123 c
= gfc_constructor_next (c
);
2127 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
2128 so many runtime variations. */
2129 if (shape
->ts
.kind
!= gfc_index_integer_kind
)
2131 gfc_typespec ts
= shape
->ts
;
2132 ts
.kind
= gfc_index_integer_kind
;
2133 gfc_convert_type_warn (shape
, &ts
, 2, 0);
2135 if (order
&& order
->ts
.kind
!= gfc_index_integer_kind
)
2136 gfc_convert_type_warn (order
, &shape
->ts
, 2, 0);
2141 gfc_resolve_rrspacing (gfc_expr
*f
, gfc_expr
*x
)
2144 f
->value
.function
.name
= gfc_get_string ("__rrspacing_%d", x
->ts
.kind
);
2149 gfc_resolve_scale (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*i ATTRIBUTE_UNUSED
)
2152 f
->value
.function
.name
= gfc_get_string ("__scale_%d", x
->ts
.kind
);
2157 gfc_resolve_scan (gfc_expr
*f
, gfc_expr
*string
,
2158 gfc_expr
*set ATTRIBUTE_UNUSED
,
2159 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2161 f
->ts
.type
= BT_INTEGER
;
2163 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2165 f
->ts
.kind
= gfc_default_integer_kind
;
2166 f
->value
.function
.name
= gfc_get_string ("__scan_%d", string
->ts
.kind
);
2171 gfc_resolve_secnds (gfc_expr
*t1
, gfc_expr
*t0
)
2174 t1
->value
.function
.name
= gfc_get_string (PREFIX ("secnds"));
2179 gfc_resolve_set_exponent (gfc_expr
*f
, gfc_expr
*x
,
2180 gfc_expr
*i ATTRIBUTE_UNUSED
)
2183 f
->value
.function
.name
= gfc_get_string ("__set_exponent_%d", x
->ts
.kind
);
2188 gfc_resolve_shape (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*kind
)
2190 f
->ts
.type
= BT_INTEGER
;
2193 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2195 f
->ts
.kind
= gfc_default_integer_kind
;
2198 f
->shape
= gfc_get_shape (1);
2199 mpz_init_set_ui (f
->shape
[0], array
->rank
);
2200 f
->value
.function
.name
= gfc_get_string (PREFIX ("shape_%d"), f
->ts
.kind
);
2205 gfc_resolve_shift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift ATTRIBUTE_UNUSED
)
2208 if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTA
)
2209 f
->value
.function
.name
= gfc_get_string ("shifta_i%d", f
->ts
.kind
);
2210 else if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTL
)
2211 f
->value
.function
.name
= gfc_get_string ("shiftl_i%d", f
->ts
.kind
);
2212 else if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTR
)
2213 f
->value
.function
.name
= gfc_get_string ("shiftr_i%d", f
->ts
.kind
);
2220 gfc_resolve_sign (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b ATTRIBUTE_UNUSED
)
2223 f
->value
.function
.name
2224 = gfc_get_string ("__sign_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2229 gfc_resolve_signal (gfc_expr
*f
, gfc_expr
*number
, gfc_expr
*handler
)
2231 f
->ts
.type
= BT_INTEGER
;
2232 f
->ts
.kind
= gfc_c_int_kind
;
2234 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2235 if (handler
->ts
.type
== BT_INTEGER
)
2237 if (handler
->ts
.kind
!= gfc_c_int_kind
)
2238 gfc_convert_type (handler
, &f
->ts
, 2);
2239 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func_int"));
2242 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func"));
2244 if (number
->ts
.kind
!= gfc_c_int_kind
)
2245 gfc_convert_type (number
, &f
->ts
, 2);
2250 gfc_resolve_sin (gfc_expr
*f
, gfc_expr
*x
)
2253 f
->value
.function
.name
2254 = gfc_get_string ("__sin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2259 gfc_resolve_sinh (gfc_expr
*f
, gfc_expr
*x
)
2262 f
->value
.function
.name
2263 = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2268 gfc_resolve_size (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2269 gfc_expr
*dim ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2271 f
->ts
.type
= BT_INTEGER
;
2273 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2275 f
->ts
.kind
= gfc_default_integer_kind
;
2280 gfc_resolve_spacing (gfc_expr
*f
, gfc_expr
*x
)
2283 f
->value
.function
.name
= gfc_get_string ("__spacing_%d", x
->ts
.kind
);
2288 gfc_resolve_spread (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*dim
,
2291 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
2292 gfc_resolve_substring_charlen (source
);
2294 if (source
->ts
.type
== BT_CHARACTER
)
2295 check_charlen_present (source
);
2298 f
->rank
= source
->rank
+ 1;
2299 if (source
->rank
== 0)
2301 if (source
->ts
.type
== BT_CHARACTER
)
2302 f
->value
.function
.name
2303 = source
->ts
.kind
== 1 ? PREFIX ("spread_char_scalar")
2305 (PREFIX ("spread_char%d_scalar"),
2308 f
->value
.function
.name
= PREFIX ("spread_scalar");
2312 if (source
->ts
.type
== BT_CHARACTER
)
2313 f
->value
.function
.name
2314 = source
->ts
.kind
== 1 ? PREFIX ("spread_char")
2316 (PREFIX ("spread_char%d"),
2319 f
->value
.function
.name
= PREFIX ("spread");
2322 if (dim
&& gfc_is_constant_expr (dim
)
2323 && ncopies
&& gfc_is_constant_expr (ncopies
) && source
->shape
[0])
2326 idim
= mpz_get_ui (dim
->value
.integer
);
2327 f
->shape
= gfc_get_shape (f
->rank
);
2328 for (i
= 0; i
< (idim
- 1); i
++)
2329 mpz_init_set (f
->shape
[i
], source
->shape
[i
]);
2331 mpz_init_set (f
->shape
[idim
- 1], ncopies
->value
.integer
);
2333 for (i
= idim
; i
< f
->rank
; i
++)
2334 mpz_init_set (f
->shape
[i
], source
->shape
[i
-1]);
2338 gfc_resolve_dim_arg (dim
);
2339 gfc_resolve_index (ncopies
, 1);
2344 gfc_resolve_sqrt (gfc_expr
*f
, gfc_expr
*x
)
2347 f
->value
.function
.name
2348 = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2352 /* Resolve the g77 compatibility function STAT AND FSTAT. */
2355 gfc_resolve_stat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2356 gfc_expr
*a ATTRIBUTE_UNUSED
)
2358 f
->ts
.type
= BT_INTEGER
;
2359 f
->ts
.kind
= gfc_default_integer_kind
;
2360 f
->value
.function
.name
= gfc_get_string (PREFIX ("stat_i%d"), f
->ts
.kind
);
2365 gfc_resolve_lstat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2366 gfc_expr
*a ATTRIBUTE_UNUSED
)
2368 f
->ts
.type
= BT_INTEGER
;
2369 f
->ts
.kind
= gfc_default_integer_kind
;
2370 f
->value
.function
.name
= gfc_get_string (PREFIX ("lstat_i%d"), f
->ts
.kind
);
2375 gfc_resolve_fstat (gfc_expr
*f
, gfc_expr
*n
, gfc_expr
*a ATTRIBUTE_UNUSED
)
2377 f
->ts
.type
= BT_INTEGER
;
2378 f
->ts
.kind
= gfc_default_integer_kind
;
2379 if (n
->ts
.kind
!= f
->ts
.kind
)
2380 gfc_convert_type (n
, &f
->ts
, 2);
2382 f
->value
.function
.name
= gfc_get_string (PREFIX ("fstat_i%d"), f
->ts
.kind
);
2387 gfc_resolve_fgetc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2392 f
->ts
.type
= BT_INTEGER
;
2393 f
->ts
.kind
= gfc_c_int_kind
;
2394 if (u
->ts
.kind
!= gfc_c_int_kind
)
2396 ts
.type
= BT_INTEGER
;
2397 ts
.kind
= gfc_c_int_kind
;
2398 ts
.u
.derived
= NULL
;
2400 gfc_convert_type (u
, &ts
, 2);
2403 f
->value
.function
.name
= gfc_get_string (PREFIX ("fgetc"));
2408 gfc_resolve_fget (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2410 f
->ts
.type
= BT_INTEGER
;
2411 f
->ts
.kind
= gfc_c_int_kind
;
2412 f
->value
.function
.name
= gfc_get_string (PREFIX ("fget"));
2417 gfc_resolve_fputc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2422 f
->ts
.type
= BT_INTEGER
;
2423 f
->ts
.kind
= gfc_c_int_kind
;
2424 if (u
->ts
.kind
!= gfc_c_int_kind
)
2426 ts
.type
= BT_INTEGER
;
2427 ts
.kind
= gfc_c_int_kind
;
2428 ts
.u
.derived
= NULL
;
2430 gfc_convert_type (u
, &ts
, 2);
2433 f
->value
.function
.name
= gfc_get_string (PREFIX ("fputc"));
2438 gfc_resolve_fput (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2440 f
->ts
.type
= BT_INTEGER
;
2441 f
->ts
.kind
= gfc_c_int_kind
;
2442 f
->value
.function
.name
= gfc_get_string (PREFIX ("fput"));
2447 gfc_resolve_ftell (gfc_expr
*f
, gfc_expr
*u
)
2452 f
->ts
.type
= BT_INTEGER
;
2453 f
->ts
.kind
= gfc_index_integer_kind
;
2454 if (u
->ts
.kind
!= gfc_c_int_kind
)
2456 ts
.type
= BT_INTEGER
;
2457 ts
.kind
= gfc_c_int_kind
;
2458 ts
.u
.derived
= NULL
;
2460 gfc_convert_type (u
, &ts
, 2);
2463 f
->value
.function
.name
= gfc_get_string (PREFIX ("ftell"));
2468 gfc_resolve_storage_size (gfc_expr
*f
, gfc_expr
*a ATTRIBUTE_UNUSED
,
2471 f
->ts
.type
= BT_INTEGER
;
2473 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2475 f
->ts
.kind
= gfc_default_integer_kind
;
2480 gfc_resolve_sum (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2482 resolve_transformational ("sum", f
, array
, dim
, mask
);
2487 gfc_resolve_symlnk (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
2488 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
2490 f
->ts
.type
= BT_INTEGER
;
2491 f
->ts
.kind
= gfc_default_integer_kind
;
2492 f
->value
.function
.name
= gfc_get_string (PREFIX ("symlnk_i%d"), f
->ts
.kind
);
2496 /* Resolve the g77 compatibility function SYSTEM. */
2499 gfc_resolve_system (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
2501 f
->ts
.type
= BT_INTEGER
;
2503 f
->value
.function
.name
= gfc_get_string (PREFIX ("system"));
2508 gfc_resolve_tan (gfc_expr
*f
, gfc_expr
*x
)
2511 f
->value
.function
.name
2512 = gfc_get_string ("__tan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2517 gfc_resolve_tanh (gfc_expr
*f
, gfc_expr
*x
)
2520 f
->value
.function
.name
2521 = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2526 gfc_resolve_image_index (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2527 gfc_expr
*sub ATTRIBUTE_UNUSED
)
2529 static char this_image
[] = "__image_index";
2530 f
->ts
.kind
= gfc_default_integer_kind
;
2531 f
->value
.function
.name
= this_image
;
2536 gfc_resolve_this_image (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
)
2538 resolve_bound (f
, array
, dim
, NULL
, "__this_image", true);
2543 gfc_resolve_time (gfc_expr
*f
)
2545 f
->ts
.type
= BT_INTEGER
;
2547 f
->value
.function
.name
= gfc_get_string (PREFIX ("time_func"));
2552 gfc_resolve_time8 (gfc_expr
*f
)
2554 f
->ts
.type
= BT_INTEGER
;
2556 f
->value
.function
.name
= gfc_get_string (PREFIX ("time8_func"));
2561 gfc_resolve_transfer (gfc_expr
*f
, gfc_expr
*source ATTRIBUTE_UNUSED
,
2562 gfc_expr
*mold
, gfc_expr
*size
)
2564 /* TODO: Make this do something meaningful. */
2565 static char transfer0
[] = "__transfer0", transfer1
[] = "__transfer1";
2567 if (mold
->ts
.type
== BT_CHARACTER
2568 && !mold
->ts
.u
.cl
->length
2569 && gfc_is_constant_expr (mold
))
2572 if (mold
->expr_type
== EXPR_CONSTANT
)
2574 len
= mold
->value
.character
.length
;
2575 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
2580 gfc_constructor
*c
= gfc_constructor_first (mold
->value
.constructor
);
2581 len
= c
->expr
->value
.character
.length
;
2582 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
2589 if (size
== NULL
&& mold
->rank
== 0)
2592 f
->value
.function
.name
= transfer0
;
2597 f
->value
.function
.name
= transfer1
;
2598 if (size
&& gfc_is_constant_expr (size
))
2600 f
->shape
= gfc_get_shape (1);
2601 mpz_init_set (f
->shape
[0], size
->value
.integer
);
2608 gfc_resolve_transpose (gfc_expr
*f
, gfc_expr
*matrix
)
2611 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ref
)
2612 gfc_resolve_substring_charlen (matrix
);
2618 f
->shape
= gfc_get_shape (2);
2619 mpz_init_set (f
->shape
[0], matrix
->shape
[1]);
2620 mpz_init_set (f
->shape
[1], matrix
->shape
[0]);
2623 switch (matrix
->ts
.kind
)
2629 switch (matrix
->ts
.type
)
2633 f
->value
.function
.name
2634 = gfc_get_string (PREFIX ("transpose_%c%d"),
2635 gfc_type_letter (matrix
->ts
.type
),
2641 /* Use the integer routines for real and logical cases. This
2642 assumes they all have the same alignment requirements. */
2643 f
->value
.function
.name
2644 = gfc_get_string (PREFIX ("transpose_i%d"), matrix
->ts
.kind
);
2648 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ts
.kind
== 4)
2649 f
->value
.function
.name
= PREFIX ("transpose_char4");
2651 f
->value
.function
.name
= PREFIX ("transpose");
2657 f
->value
.function
.name
= (matrix
->ts
.type
== BT_CHARACTER
2658 ? PREFIX ("transpose_char")
2659 : PREFIX ("transpose"));
2666 gfc_resolve_trim (gfc_expr
*f
, gfc_expr
*string
)
2668 f
->ts
.type
= BT_CHARACTER
;
2669 f
->ts
.kind
= string
->ts
.kind
;
2670 f
->value
.function
.name
= gfc_get_string ("__trim_%d", string
->ts
.kind
);
2675 gfc_resolve_ubound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2677 resolve_bound (f
, array
, dim
, kind
, "__ubound", false);
2682 gfc_resolve_ucobound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2684 resolve_bound (f
, array
, dim
, kind
, "__ucobound", true);
2688 /* Resolve the g77 compatibility function UMASK. */
2691 gfc_resolve_umask (gfc_expr
*f
, gfc_expr
*n
)
2693 f
->ts
.type
= BT_INTEGER
;
2694 f
->ts
.kind
= n
->ts
.kind
;
2695 f
->value
.function
.name
= gfc_get_string (PREFIX ("umask_i%d"), n
->ts
.kind
);
2699 /* Resolve the g77 compatibility function UNLINK. */
2702 gfc_resolve_unlink (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
2704 f
->ts
.type
= BT_INTEGER
;
2706 f
->value
.function
.name
= gfc_get_string (PREFIX ("unlink"));
2711 gfc_resolve_ttynam (gfc_expr
*f
, gfc_expr
*unit
)
2716 f
->ts
.type
= BT_CHARACTER
;
2717 f
->ts
.kind
= gfc_default_character_kind
;
2719 if (unit
->ts
.kind
!= gfc_c_int_kind
)
2721 ts
.type
= BT_INTEGER
;
2722 ts
.kind
= gfc_c_int_kind
;
2723 ts
.u
.derived
= NULL
;
2725 gfc_convert_type (unit
, &ts
, 2);
2728 f
->value
.function
.name
= gfc_get_string (PREFIX ("ttynam"));
2733 gfc_resolve_unpack (gfc_expr
*f
, gfc_expr
*vector
, gfc_expr
*mask
,
2734 gfc_expr
*field ATTRIBUTE_UNUSED
)
2736 if (vector
->ts
.type
== BT_CHARACTER
&& vector
->ref
)
2737 gfc_resolve_substring_charlen (vector
);
2740 f
->rank
= mask
->rank
;
2741 resolve_mask_arg (mask
);
2743 if (vector
->ts
.type
== BT_CHARACTER
)
2745 if (vector
->ts
.kind
== 1)
2746 f
->value
.function
.name
2747 = gfc_get_string (PREFIX ("unpack%d_char"), field
->rank
> 0 ? 1 : 0);
2749 f
->value
.function
.name
2750 = gfc_get_string (PREFIX ("unpack%d_char%d"),
2751 field
->rank
> 0 ? 1 : 0, vector
->ts
.kind
);
2754 f
->value
.function
.name
2755 = gfc_get_string (PREFIX ("unpack%d"), field
->rank
> 0 ? 1 : 0);
2760 gfc_resolve_verify (gfc_expr
*f
, gfc_expr
*string
,
2761 gfc_expr
*set ATTRIBUTE_UNUSED
,
2762 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2764 f
->ts
.type
= BT_INTEGER
;
2766 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2768 f
->ts
.kind
= gfc_default_integer_kind
;
2769 f
->value
.function
.name
= gfc_get_string ("__verify_%d", string
->ts
.kind
);
2774 gfc_resolve_xor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
2776 f
->ts
.type
= i
->ts
.type
;
2777 f
->ts
.kind
= gfc_kind_max (i
, j
);
2779 if (i
->ts
.kind
!= j
->ts
.kind
)
2781 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
2782 gfc_convert_type (j
, &i
->ts
, 2);
2784 gfc_convert_type (i
, &j
->ts
, 2);
2787 f
->value
.function
.name
2788 = gfc_get_string ("__xor_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
2792 /* Intrinsic subroutine resolution. */
2795 gfc_resolve_alarm_sub (gfc_code
*c
)
2798 gfc_expr
*seconds
, *handler
;
2802 seconds
= c
->ext
.actual
->expr
;
2803 handler
= c
->ext
.actual
->next
->expr
;
2804 ts
.type
= BT_INTEGER
;
2805 ts
.kind
= gfc_c_int_kind
;
2807 /* handler can be either BT_INTEGER or BT_PROCEDURE.
2808 In all cases, the status argument is of default integer kind
2809 (enforced in check.c) so that the function suffix is fixed. */
2810 if (handler
->ts
.type
== BT_INTEGER
)
2812 if (handler
->ts
.kind
!= gfc_c_int_kind
)
2813 gfc_convert_type (handler
, &ts
, 2);
2814 name
= gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
2815 gfc_default_integer_kind
);
2818 name
= gfc_get_string (PREFIX ("alarm_sub_i%d"),
2819 gfc_default_integer_kind
);
2821 if (seconds
->ts
.kind
!= gfc_c_int_kind
)
2822 gfc_convert_type (seconds
, &ts
, 2);
2824 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2828 gfc_resolve_cpu_time (gfc_code
*c
)
2831 name
= gfc_get_string (PREFIX ("cpu_time_%d"), c
->ext
.actual
->expr
->ts
.kind
);
2832 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2836 /* Create a formal arglist based on an actual one and set the INTENTs given. */
2838 static gfc_formal_arglist
*
2839 create_formal_for_intents (gfc_actual_arglist
* actual
, const sym_intent
* ints
)
2841 gfc_formal_arglist
* head
;
2842 gfc_formal_arglist
* tail
;
2848 head
= tail
= gfc_get_formal_arglist ();
2849 for (i
= 0; actual
; actual
= actual
->next
, tail
= tail
->next
, ++i
)
2853 sym
= gfc_new_symbol ("dummyarg", NULL
);
2854 sym
->ts
= actual
->expr
->ts
;
2856 sym
->attr
.intent
= ints
[i
];
2860 tail
->next
= gfc_get_formal_arglist ();
2868 gfc_resolve_mvbits (gfc_code
*c
)
2870 static const sym_intent INTENTS
[] = {INTENT_IN
, INTENT_IN
, INTENT_IN
,
2871 INTENT_INOUT
, INTENT_IN
};
2877 /* FROMPOS, LEN and TOPOS are restricted to small values. As such,
2878 they will be converted so that they fit into a C int. */
2879 ts
.type
= BT_INTEGER
;
2880 ts
.kind
= gfc_c_int_kind
;
2881 if (c
->ext
.actual
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
2882 gfc_convert_type (c
->ext
.actual
->next
->expr
, &ts
, 2);
2883 if (c
->ext
.actual
->next
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
2884 gfc_convert_type (c
->ext
.actual
->next
->next
->expr
, &ts
, 2);
2885 if (c
->ext
.actual
->next
->next
->next
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
2886 gfc_convert_type (c
->ext
.actual
->next
->next
->next
->next
->expr
, &ts
, 2);
2888 /* TO and FROM are guaranteed to have the same kind parameter. */
2889 name
= gfc_get_string (PREFIX ("mvbits_i%d"),
2890 c
->ext
.actual
->expr
->ts
.kind
);
2891 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2892 /* Mark as elemental subroutine as this does not happen automatically. */
2893 c
->resolved_sym
->attr
.elemental
= 1;
2895 /* Create a dummy formal arglist so the INTENTs are known later for purpose
2896 of creating temporaries. */
2897 c
->resolved_sym
->formal
= create_formal_for_intents (c
->ext
.actual
, INTENTS
);
2902 gfc_resolve_random_number (gfc_code
*c
)
2907 kind
= c
->ext
.actual
->expr
->ts
.kind
;
2908 if (c
->ext
.actual
->expr
->rank
== 0)
2909 name
= gfc_get_string (PREFIX ("random_r%d"), kind
);
2911 name
= gfc_get_string (PREFIX ("arandom_r%d"), kind
);
2913 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2918 gfc_resolve_random_seed (gfc_code
*c
)
2922 name
= gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind
);
2923 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2928 gfc_resolve_rename_sub (gfc_code
*c
)
2933 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
2934 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
2936 kind
= gfc_default_integer_kind
;
2938 name
= gfc_get_string (PREFIX ("rename_i%d_sub"), kind
);
2939 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2944 gfc_resolve_kill_sub (gfc_code
*c
)
2949 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
2950 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
2952 kind
= gfc_default_integer_kind
;
2954 name
= gfc_get_string (PREFIX ("kill_i%d_sub"), kind
);
2955 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2960 gfc_resolve_link_sub (gfc_code
*c
)
2965 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
2966 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
2968 kind
= gfc_default_integer_kind
;
2970 name
= gfc_get_string (PREFIX ("link_i%d_sub"), kind
);
2971 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2976 gfc_resolve_symlnk_sub (gfc_code
*c
)
2981 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
2982 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
2984 kind
= gfc_default_integer_kind
;
2986 name
= gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind
);
2987 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2991 /* G77 compatibility subroutines dtime() and etime(). */
2994 gfc_resolve_dtime_sub (gfc_code
*c
)
2997 name
= gfc_get_string (PREFIX ("dtime_sub"));
2998 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3002 gfc_resolve_etime_sub (gfc_code
*c
)
3005 name
= gfc_get_string (PREFIX ("etime_sub"));
3006 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3010 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
3013 gfc_resolve_itime (gfc_code
*c
)
3016 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
3017 gfc_default_integer_kind
));
3021 gfc_resolve_idate (gfc_code
*c
)
3024 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
3025 gfc_default_integer_kind
));
3029 gfc_resolve_ltime (gfc_code
*c
)
3032 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
3033 gfc_default_integer_kind
));
3037 gfc_resolve_gmtime (gfc_code
*c
)
3040 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
3041 gfc_default_integer_kind
));
3045 /* G77 compatibility subroutine second(). */
3048 gfc_resolve_second_sub (gfc_code
*c
)
3051 name
= gfc_get_string (PREFIX ("second_sub"));
3052 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3057 gfc_resolve_sleep_sub (gfc_code
*c
)
3062 if (c
->ext
.actual
->expr
!= NULL
)
3063 kind
= c
->ext
.actual
->expr
->ts
.kind
;
3065 kind
= gfc_default_integer_kind
;
3067 name
= gfc_get_string (PREFIX ("sleep_i%d_sub"), kind
);
3068 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3072 /* G77 compatibility function srand(). */
3075 gfc_resolve_srand (gfc_code
*c
)
3078 name
= gfc_get_string (PREFIX ("srand"));
3079 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3083 /* Resolve the getarg intrinsic subroutine. */
3086 gfc_resolve_getarg (gfc_code
*c
)
3090 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_default_integer_kind
)
3095 ts
.type
= BT_INTEGER
;
3096 ts
.kind
= gfc_default_integer_kind
;
3098 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3101 name
= gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind
);
3102 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3106 /* Resolve the getcwd intrinsic subroutine. */
3109 gfc_resolve_getcwd_sub (gfc_code
*c
)
3114 if (c
->ext
.actual
->next
->expr
!= NULL
)
3115 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3117 kind
= gfc_default_integer_kind
;
3119 name
= gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind
);
3120 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3124 /* Resolve the get_command intrinsic subroutine. */
3127 gfc_resolve_get_command (gfc_code
*c
)
3131 kind
= gfc_default_integer_kind
;
3132 name
= gfc_get_string (PREFIX ("get_command_i%d"), kind
);
3133 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3137 /* Resolve the get_command_argument intrinsic subroutine. */
3140 gfc_resolve_get_command_argument (gfc_code
*c
)
3144 kind
= gfc_default_integer_kind
;
3145 name
= gfc_get_string (PREFIX ("get_command_argument_i%d"), kind
);
3146 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3150 /* Resolve the get_environment_variable intrinsic subroutine. */
3153 gfc_resolve_get_environment_variable (gfc_code
*code
)
3157 kind
= gfc_default_integer_kind
;
3158 name
= gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind
);
3159 code
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3164 gfc_resolve_signal_sub (gfc_code
*c
)
3167 gfc_expr
*number
, *handler
, *status
;
3171 number
= c
->ext
.actual
->expr
;
3172 handler
= c
->ext
.actual
->next
->expr
;
3173 status
= c
->ext
.actual
->next
->next
->expr
;
3174 ts
.type
= BT_INTEGER
;
3175 ts
.kind
= gfc_c_int_kind
;
3177 /* handler can be either BT_INTEGER or BT_PROCEDURE */
3178 if (handler
->ts
.type
== BT_INTEGER
)
3180 if (handler
->ts
.kind
!= gfc_c_int_kind
)
3181 gfc_convert_type (handler
, &ts
, 2);
3182 name
= gfc_get_string (PREFIX ("signal_sub_int"));
3185 name
= gfc_get_string (PREFIX ("signal_sub"));
3187 if (number
->ts
.kind
!= gfc_c_int_kind
)
3188 gfc_convert_type (number
, &ts
, 2);
3189 if (status
!= NULL
&& status
->ts
.kind
!= gfc_c_int_kind
)
3190 gfc_convert_type (status
, &ts
, 2);
3192 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3196 /* Resolve the SYSTEM intrinsic subroutine. */
3199 gfc_resolve_system_sub (gfc_code
*c
)
3202 name
= gfc_get_string (PREFIX ("system_sub"));
3203 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3207 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
3210 gfc_resolve_system_clock (gfc_code
*c
)
3215 if (c
->ext
.actual
->expr
!= NULL
)
3216 kind
= c
->ext
.actual
->expr
->ts
.kind
;
3217 else if (c
->ext
.actual
->next
->expr
!= NULL
)
3218 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3219 else if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3220 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3222 kind
= gfc_default_integer_kind
;
3224 name
= gfc_get_string (PREFIX ("system_clock_%d"), kind
);
3225 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3229 /* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine. */
3231 gfc_resolve_execute_command_line (gfc_code
*c
)
3234 name
= gfc_get_string (PREFIX ("execute_command_line_i%d"),
3235 gfc_default_integer_kind
);
3236 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3240 /* Resolve the EXIT intrinsic subroutine. */
3243 gfc_resolve_exit (gfc_code
*c
)
3250 /* The STATUS argument has to be of default kind. If it is not,
3252 ts
.type
= BT_INTEGER
;
3253 ts
.kind
= gfc_default_integer_kind
;
3254 n
= c
->ext
.actual
->expr
;
3255 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3256 gfc_convert_type (n
, &ts
, 2);
3258 name
= gfc_get_string (PREFIX ("exit_i%d"), ts
.kind
);
3259 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3263 /* Resolve the FLUSH intrinsic subroutine. */
3266 gfc_resolve_flush (gfc_code
*c
)
3273 ts
.type
= BT_INTEGER
;
3274 ts
.kind
= gfc_default_integer_kind
;
3275 n
= c
->ext
.actual
->expr
;
3276 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3277 gfc_convert_type (n
, &ts
, 2);
3279 name
= gfc_get_string (PREFIX ("flush_i%d"), ts
.kind
);
3280 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3285 gfc_resolve_free (gfc_code
*c
)
3291 ts
.type
= BT_INTEGER
;
3292 ts
.kind
= gfc_index_integer_kind
;
3293 n
= c
->ext
.actual
->expr
;
3294 if (n
->ts
.kind
!= ts
.kind
)
3295 gfc_convert_type (n
, &ts
, 2);
3297 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("free"));
3302 gfc_resolve_ctime_sub (gfc_code
*c
)
3307 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3308 if (c
->ext
.actual
->expr
->ts
.kind
!= 8)
3310 ts
.type
= BT_INTEGER
;
3312 ts
.u
.derived
= NULL
;
3314 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3317 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3322 gfc_resolve_fdate_sub (gfc_code
*c
)
3324 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3329 gfc_resolve_gerror (gfc_code
*c
)
3331 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3336 gfc_resolve_getlog (gfc_code
*c
)
3338 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3343 gfc_resolve_hostnm_sub (gfc_code
*c
)
3348 if (c
->ext
.actual
->next
->expr
!= NULL
)
3349 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3351 kind
= gfc_default_integer_kind
;
3353 name
= gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind
);
3354 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3359 gfc_resolve_perror (gfc_code
*c
)
3361 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3364 /* Resolve the STAT and FSTAT intrinsic subroutines. */
3367 gfc_resolve_stat_sub (gfc_code
*c
)
3370 name
= gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind
);
3371 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3376 gfc_resolve_lstat_sub (gfc_code
*c
)
3379 name
= gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind
);
3380 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3385 gfc_resolve_fstat_sub (gfc_code
*c
)
3391 u
= c
->ext
.actual
->expr
;
3392 ts
= &c
->ext
.actual
->next
->expr
->ts
;
3393 if (u
->ts
.kind
!= ts
->kind
)
3394 gfc_convert_type (u
, ts
, 2);
3395 name
= gfc_get_string (PREFIX ("fstat_i%d_sub"), ts
->kind
);
3396 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3401 gfc_resolve_fgetc_sub (gfc_code
*c
)
3408 u
= c
->ext
.actual
->expr
;
3409 st
= c
->ext
.actual
->next
->next
->expr
;
3411 if (u
->ts
.kind
!= gfc_c_int_kind
)
3413 ts
.type
= BT_INTEGER
;
3414 ts
.kind
= gfc_c_int_kind
;
3415 ts
.u
.derived
= NULL
;
3417 gfc_convert_type (u
, &ts
, 2);
3421 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), st
->ts
.kind
);
3423 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind
);
3425 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3430 gfc_resolve_fget_sub (gfc_code
*c
)
3435 st
= c
->ext
.actual
->next
->expr
;
3437 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), st
->ts
.kind
);
3439 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind
);
3441 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3446 gfc_resolve_fputc_sub (gfc_code
*c
)
3453 u
= c
->ext
.actual
->expr
;
3454 st
= c
->ext
.actual
->next
->next
->expr
;
3456 if (u
->ts
.kind
!= gfc_c_int_kind
)
3458 ts
.type
= BT_INTEGER
;
3459 ts
.kind
= gfc_c_int_kind
;
3460 ts
.u
.derived
= NULL
;
3462 gfc_convert_type (u
, &ts
, 2);
3466 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), st
->ts
.kind
);
3468 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind
);
3470 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3475 gfc_resolve_fput_sub (gfc_code
*c
)
3480 st
= c
->ext
.actual
->next
->expr
;
3482 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), st
->ts
.kind
);
3484 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind
);
3486 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3491 gfc_resolve_fseek_sub (gfc_code
*c
)
3499 unit
= c
->ext
.actual
->expr
;
3500 offset
= c
->ext
.actual
->next
->expr
;
3501 whence
= c
->ext
.actual
->next
->next
->expr
;
3503 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3505 ts
.type
= BT_INTEGER
;
3506 ts
.kind
= gfc_c_int_kind
;
3507 ts
.u
.derived
= NULL
;
3509 gfc_convert_type (unit
, &ts
, 2);
3512 if (offset
->ts
.kind
!= gfc_intio_kind
)
3514 ts
.type
= BT_INTEGER
;
3515 ts
.kind
= gfc_intio_kind
;
3516 ts
.u
.derived
= NULL
;
3518 gfc_convert_type (offset
, &ts
, 2);
3521 if (whence
->ts
.kind
!= gfc_c_int_kind
)
3523 ts
.type
= BT_INTEGER
;
3524 ts
.kind
= gfc_c_int_kind
;
3525 ts
.u
.derived
= NULL
;
3527 gfc_convert_type (whence
, &ts
, 2);
3530 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
3534 gfc_resolve_ftell_sub (gfc_code
*c
)
3542 unit
= c
->ext
.actual
->expr
;
3543 offset
= c
->ext
.actual
->next
->expr
;
3545 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3547 ts
.type
= BT_INTEGER
;
3548 ts
.kind
= gfc_c_int_kind
;
3549 ts
.u
.derived
= NULL
;
3551 gfc_convert_type (unit
, &ts
, 2);
3554 name
= gfc_get_string (PREFIX ("ftell_i%d_sub"), offset
->ts
.kind
);
3555 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3560 gfc_resolve_ttynam_sub (gfc_code
*c
)
3565 if (c
->ext
.actual
->expr
->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 (c
->ext
.actual
->expr
, &ts
, 2);
3574 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
3578 /* Resolve the UMASK intrinsic subroutine. */
3581 gfc_resolve_umask_sub (gfc_code
*c
)
3586 if (c
->ext
.actual
->next
->expr
!= NULL
)
3587 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3589 kind
= gfc_default_integer_kind
;
3591 name
= gfc_get_string (PREFIX ("umask_i%d_sub"), kind
);
3592 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3595 /* Resolve the UNLINK intrinsic subroutine. */
3598 gfc_resolve_unlink_sub (gfc_code
*c
)
3603 if (c
->ext
.actual
->next
->expr
!= NULL
)
3604 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3606 kind
= gfc_default_integer_kind
;
3608 name
= gfc_get_string (PREFIX ("unlink_i%d_sub"), kind
);
3609 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);