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);
122 /********************** Resolution functions **********************/
126 gfc_resolve_abs (gfc_expr
*f
, gfc_expr
*a
)
129 if (f
->ts
.type
== BT_COMPLEX
)
130 f
->ts
.type
= BT_REAL
;
132 f
->value
.function
.name
133 = gfc_get_string ("__abs_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
138 gfc_resolve_access (gfc_expr
*f
, gfc_expr
*name ATTRIBUTE_UNUSED
,
139 gfc_expr
*mode ATTRIBUTE_UNUSED
)
141 f
->ts
.type
= BT_INTEGER
;
142 f
->ts
.kind
= gfc_c_int_kind
;
143 f
->value
.function
.name
= PREFIX ("access_func");
148 gfc_resolve_adjustl (gfc_expr
*f
, gfc_expr
*string
)
150 f
->ts
.type
= BT_CHARACTER
;
151 f
->ts
.kind
= string
->ts
.kind
;
152 f
->value
.function
.name
= gfc_get_string ("__adjustl_s%d", f
->ts
.kind
);
157 gfc_resolve_adjustr (gfc_expr
*f
, gfc_expr
*string
)
159 f
->ts
.type
= BT_CHARACTER
;
160 f
->ts
.kind
= string
->ts
.kind
;
161 f
->value
.function
.name
= gfc_get_string ("__adjustr_s%d", f
->ts
.kind
);
166 gfc_resolve_char_achar (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*kind
,
169 f
->ts
.type
= BT_CHARACTER
;
170 f
->ts
.kind
= (kind
== NULL
)
171 ? gfc_default_character_kind
: mpz_get_si (kind
->value
.integer
);
172 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
173 f
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
175 f
->value
.function
.name
= gfc_get_string (name
, f
->ts
.kind
,
176 gfc_type_letter (x
->ts
.type
),
182 gfc_resolve_achar (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*kind
)
184 gfc_resolve_char_achar (f
, x
, kind
, "__achar_%d_%c%d");
189 gfc_resolve_acos (gfc_expr
*f
, gfc_expr
*x
)
192 f
->value
.function
.name
193 = gfc_get_string ("__acos_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
198 gfc_resolve_acosh (gfc_expr
*f
, gfc_expr
*x
)
201 f
->value
.function
.name
202 = gfc_get_string ("__acosh_%c%d", gfc_type_letter (x
->ts
.type
),
208 gfc_resolve_aimag (gfc_expr
*f
, gfc_expr
*x
)
210 f
->ts
.type
= BT_REAL
;
211 f
->ts
.kind
= x
->ts
.kind
;
212 f
->value
.function
.name
213 = gfc_get_string ("__aimag_%c%d", gfc_type_letter (x
->ts
.type
),
219 gfc_resolve_and (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
221 f
->ts
.type
= i
->ts
.type
;
222 f
->ts
.kind
= gfc_kind_max (i
, j
);
224 if (i
->ts
.kind
!= j
->ts
.kind
)
226 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
227 gfc_convert_type (j
, &i
->ts
, 2);
229 gfc_convert_type (i
, &j
->ts
, 2);
232 f
->value
.function
.name
233 = gfc_get_string ("__and_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
238 gfc_resolve_aint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
243 f
->ts
.type
= a
->ts
.type
;
244 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
246 if (a
->ts
.kind
!= f
->ts
.kind
)
248 ts
.type
= f
->ts
.type
;
249 ts
.kind
= f
->ts
.kind
;
250 gfc_convert_type (a
, &ts
, 2);
252 /* The resolved name is only used for specific intrinsics where
253 the return kind is the same as the arg kind. */
254 f
->value
.function
.name
255 = gfc_get_string ("__aint_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
260 gfc_resolve_dint (gfc_expr
*f
, gfc_expr
*a
)
262 gfc_resolve_aint (f
, a
, NULL
);
267 gfc_resolve_all (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
)
273 gfc_resolve_dim_arg (dim
);
274 f
->rank
= mask
->rank
- 1;
275 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
278 f
->value
.function
.name
279 = gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask
->ts
.type
),
285 gfc_resolve_anint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
290 f
->ts
.type
= a
->ts
.type
;
291 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
293 if (a
->ts
.kind
!= f
->ts
.kind
)
295 ts
.type
= f
->ts
.type
;
296 ts
.kind
= f
->ts
.kind
;
297 gfc_convert_type (a
, &ts
, 2);
300 /* The resolved name is only used for specific intrinsics where
301 the return kind is the same as the arg kind. */
302 f
->value
.function
.name
303 = gfc_get_string ("__anint_%c%d", gfc_type_letter (a
->ts
.type
),
309 gfc_resolve_dnint (gfc_expr
*f
, gfc_expr
*a
)
311 gfc_resolve_anint (f
, a
, NULL
);
316 gfc_resolve_any (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
)
322 gfc_resolve_dim_arg (dim
);
323 f
->rank
= mask
->rank
- 1;
324 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
327 f
->value
.function
.name
328 = gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask
->ts
.type
),
334 gfc_resolve_asin (gfc_expr
*f
, gfc_expr
*x
)
337 f
->value
.function
.name
338 = gfc_get_string ("__asin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
342 gfc_resolve_asinh (gfc_expr
*f
, gfc_expr
*x
)
345 f
->value
.function
.name
346 = gfc_get_string ("__asinh_%c%d", gfc_type_letter (x
->ts
.type
),
351 gfc_resolve_atan (gfc_expr
*f
, gfc_expr
*x
)
354 f
->value
.function
.name
355 = gfc_get_string ("__atan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
359 gfc_resolve_atanh (gfc_expr
*f
, gfc_expr
*x
)
362 f
->value
.function
.name
363 = gfc_get_string ("__atanh_%c%d", gfc_type_letter (x
->ts
.type
),
368 gfc_resolve_atan2 (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
371 f
->value
.function
.name
372 = gfc_get_string ("__atan2_%c%d", gfc_type_letter (x
->ts
.type
),
377 /* Resolve the BESYN and BESJN intrinsics. */
380 gfc_resolve_besn (gfc_expr
*f
, gfc_expr
*n
, gfc_expr
*x
)
386 if (n
->ts
.kind
!= gfc_c_int_kind
)
388 ts
.type
= BT_INTEGER
;
389 ts
.kind
= gfc_c_int_kind
;
390 gfc_convert_type (n
, &ts
, 2);
392 f
->value
.function
.name
= gfc_get_string ("<intrinsic>");
397 gfc_resolve_btest (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos
)
399 f
->ts
.type
= BT_LOGICAL
;
400 f
->ts
.kind
= gfc_default_logical_kind
;
401 f
->value
.function
.name
402 = gfc_get_string ("__btest_%d_%d", i
->ts
.kind
, pos
->ts
.kind
);
407 gfc_resolve_ceiling (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
409 f
->ts
.type
= BT_INTEGER
;
410 f
->ts
.kind
= (kind
== NULL
)
411 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
412 f
->value
.function
.name
413 = gfc_get_string ("__ceiling_%d_%c%d", f
->ts
.kind
,
414 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
419 gfc_resolve_char (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
421 gfc_resolve_char_achar (f
, a
, kind
, "__char_%d_%c%d");
426 gfc_resolve_chdir (gfc_expr
*f
, gfc_expr
*d ATTRIBUTE_UNUSED
)
428 f
->ts
.type
= BT_INTEGER
;
429 f
->ts
.kind
= gfc_default_integer_kind
;
430 f
->value
.function
.name
= gfc_get_string (PREFIX ("chdir_i%d"), f
->ts
.kind
);
435 gfc_resolve_chdir_sub (gfc_code
*c
)
440 if (c
->ext
.actual
->next
->expr
!= NULL
)
441 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
443 kind
= gfc_default_integer_kind
;
445 name
= gfc_get_string (PREFIX ("chdir_i%d_sub"), kind
);
446 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
451 gfc_resolve_chmod (gfc_expr
*f
, gfc_expr
*name ATTRIBUTE_UNUSED
,
452 gfc_expr
*mode ATTRIBUTE_UNUSED
)
454 f
->ts
.type
= BT_INTEGER
;
455 f
->ts
.kind
= gfc_c_int_kind
;
456 f
->value
.function
.name
= PREFIX ("chmod_func");
461 gfc_resolve_chmod_sub (gfc_code
*c
)
466 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
467 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
469 kind
= gfc_default_integer_kind
;
471 name
= gfc_get_string (PREFIX ("chmod_i%d_sub"), kind
);
472 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
477 gfc_resolve_cmplx (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*kind
)
479 f
->ts
.type
= BT_COMPLEX
;
480 f
->ts
.kind
= (kind
== NULL
)
481 ? gfc_default_real_kind
: mpz_get_si (kind
->value
.integer
);
484 f
->value
.function
.name
485 = gfc_get_string ("__cmplx0_%d_%c%d", f
->ts
.kind
,
486 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
488 f
->value
.function
.name
489 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f
->ts
.kind
,
490 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
,
491 gfc_type_letter (y
->ts
.type
), y
->ts
.kind
);
496 gfc_resolve_dcmplx (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
)
498 gfc_resolve_cmplx (f
, x
, y
, gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
499 gfc_default_double_kind
));
504 gfc_resolve_complex (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
)
508 if (x
->ts
.type
== BT_INTEGER
)
510 if (y
->ts
.type
== BT_INTEGER
)
511 kind
= gfc_default_real_kind
;
517 if (y
->ts
.type
== BT_REAL
)
518 kind
= (x
->ts
.kind
> y
->ts
.kind
) ? x
->ts
.kind
: y
->ts
.kind
;
523 f
->ts
.type
= BT_COMPLEX
;
525 f
->value
.function
.name
526 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f
->ts
.kind
,
527 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
,
528 gfc_type_letter (y
->ts
.type
), y
->ts
.kind
);
533 gfc_resolve_conjg (gfc_expr
*f
, gfc_expr
*x
)
536 f
->value
.function
.name
= gfc_get_string ("__conjg_%d", x
->ts
.kind
);
541 gfc_resolve_cos (gfc_expr
*f
, gfc_expr
*x
)
544 f
->value
.function
.name
545 = gfc_get_string ("__cos_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
550 gfc_resolve_cosh (gfc_expr
*f
, gfc_expr
*x
)
553 f
->value
.function
.name
554 = gfc_get_string ("__cosh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
559 gfc_resolve_count (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
561 f
->ts
.type
= BT_INTEGER
;
563 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
565 f
->ts
.kind
= gfc_default_integer_kind
;
569 f
->rank
= mask
->rank
- 1;
570 gfc_resolve_dim_arg (dim
);
571 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
574 resolve_mask_arg (mask
);
576 f
->value
.function
.name
577 = gfc_get_string (PREFIX ("count_%d_%c"), f
->ts
.kind
,
578 gfc_type_letter (mask
->ts
.type
));
583 gfc_resolve_cshift (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*shift
,
588 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
589 gfc_resolve_substring_charlen (array
);
592 f
->rank
= array
->rank
;
593 f
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
600 /* If dim kind is greater than default integer we need to use the larger. */
601 m
= gfc_default_integer_kind
;
603 m
= m
< dim
->ts
.kind
? dim
->ts
.kind
: m
;
605 /* Convert shift to at least m, so we don't need
606 kind=1 and kind=2 versions of the library functions. */
607 if (shift
->ts
.kind
< m
)
611 ts
.type
= BT_INTEGER
;
613 gfc_convert_type_warn (shift
, &ts
, 2, 0);
618 if (dim
->expr_type
!= EXPR_CONSTANT
&& dim
->symtree
!= NULL
619 && dim
->symtree
->n
.sym
->attr
.optional
)
621 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
622 dim
->representation
.length
= shift
->ts
.kind
;
626 gfc_resolve_dim_arg (dim
);
627 /* Convert dim to shift's kind to reduce variations. */
628 if (dim
->ts
.kind
!= shift
->ts
.kind
)
629 gfc_convert_type_warn (dim
, &shift
->ts
, 2, 0);
633 if (array
->ts
.type
== BT_CHARACTER
)
635 if (array
->ts
.kind
== gfc_default_character_kind
)
636 f
->value
.function
.name
637 = gfc_get_string (PREFIX ("cshift%d_%d_char"), n
, shift
->ts
.kind
);
639 f
->value
.function
.name
640 = gfc_get_string (PREFIX ("cshift%d_%d_char%d"), n
, shift
->ts
.kind
,
644 f
->value
.function
.name
645 = gfc_get_string (PREFIX ("cshift%d_%d"), n
, shift
->ts
.kind
);
650 gfc_resolve_ctime (gfc_expr
*f
, gfc_expr
*time
)
655 f
->ts
.type
= BT_CHARACTER
;
656 f
->ts
.kind
= gfc_default_character_kind
;
658 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
659 if (time
->ts
.kind
!= 8)
661 ts
.type
= BT_INTEGER
;
665 gfc_convert_type (time
, &ts
, 2);
668 f
->value
.function
.name
= gfc_get_string (PREFIX ("ctime"));
673 gfc_resolve_dble (gfc_expr
*f
, gfc_expr
*a
)
675 f
->ts
.type
= BT_REAL
;
676 f
->ts
.kind
= gfc_default_double_kind
;
677 f
->value
.function
.name
678 = gfc_get_string ("__dble_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
683 gfc_resolve_dim (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
685 f
->ts
.type
= a
->ts
.type
;
687 f
->ts
.kind
= gfc_kind_max (a
,p
);
689 f
->ts
.kind
= a
->ts
.kind
;
691 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
693 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
694 gfc_convert_type (p
, &a
->ts
, 2);
696 gfc_convert_type (a
, &p
->ts
, 2);
699 f
->value
.function
.name
700 = gfc_get_string ("__dim_%c%d", gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
705 gfc_resolve_dot_product (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b
)
709 temp
.expr_type
= EXPR_OP
;
710 gfc_clear_ts (&temp
.ts
);
711 temp
.value
.op
.op
= INTRINSIC_NONE
;
712 temp
.value
.op
.op1
= a
;
713 temp
.value
.op
.op2
= b
;
714 gfc_type_convert_binary (&temp
, 1);
716 f
->value
.function
.name
717 = gfc_get_string (PREFIX ("dot_product_%c%d"),
718 gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
723 gfc_resolve_dprod (gfc_expr
*f
, gfc_expr
*a ATTRIBUTE_UNUSED
,
724 gfc_expr
*b ATTRIBUTE_UNUSED
)
726 f
->ts
.kind
= gfc_default_double_kind
;
727 f
->ts
.type
= BT_REAL
;
728 f
->value
.function
.name
= gfc_get_string ("__dprod_r%d", f
->ts
.kind
);
733 gfc_resolve_eoshift (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*shift
,
734 gfc_expr
*boundary
, gfc_expr
*dim
)
738 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
739 gfc_resolve_substring_charlen (array
);
742 f
->rank
= array
->rank
;
743 f
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
748 if (boundary
&& boundary
->rank
> 0)
751 /* If dim kind is greater than default integer we need to use the larger. */
752 m
= gfc_default_integer_kind
;
754 m
= m
< dim
->ts
.kind
? dim
->ts
.kind
: m
;
756 /* Convert shift to at least m, so we don't need
757 kind=1 and kind=2 versions of the library functions. */
758 if (shift
->ts
.kind
< m
)
762 ts
.type
= BT_INTEGER
;
764 gfc_convert_type_warn (shift
, &ts
, 2, 0);
769 if (dim
->expr_type
!= EXPR_CONSTANT
&& dim
->symtree
!= NULL
770 && dim
->symtree
->n
.sym
->attr
.optional
)
772 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
773 dim
->representation
.length
= shift
->ts
.kind
;
777 gfc_resolve_dim_arg (dim
);
778 /* Convert dim to shift's kind to reduce variations. */
779 if (dim
->ts
.kind
!= shift
->ts
.kind
)
780 gfc_convert_type_warn (dim
, &shift
->ts
, 2, 0);
784 if (array
->ts
.type
== BT_CHARACTER
)
786 if (array
->ts
.kind
== gfc_default_character_kind
)
787 f
->value
.function
.name
788 = gfc_get_string (PREFIX ("eoshift%d_%d_char"), n
, shift
->ts
.kind
);
790 f
->value
.function
.name
791 = gfc_get_string (PREFIX ("eoshift%d_%d_char%d"), n
, shift
->ts
.kind
,
795 f
->value
.function
.name
796 = gfc_get_string (PREFIX ("eoshift%d_%d"), n
, shift
->ts
.kind
);
801 gfc_resolve_exp (gfc_expr
*f
, gfc_expr
*x
)
804 f
->value
.function
.name
805 = gfc_get_string ("__exp_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
810 gfc_resolve_exponent (gfc_expr
*f
, gfc_expr
*x
)
812 f
->ts
.type
= BT_INTEGER
;
813 f
->ts
.kind
= gfc_default_integer_kind
;
814 f
->value
.function
.name
= gfc_get_string ("__exponent_%d", x
->ts
.kind
);
818 /* Resolve the EXTENDS_TYPE_OF intrinsic function. */
821 gfc_resolve_extends_type_of (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*mo
)
826 /* Prevent double resolution. */
827 if (f
->ts
.type
== BT_LOGICAL
)
830 /* Replace the first argument with the corresponding vtab. */
831 if (a
->ts
.type
== BT_CLASS
)
832 gfc_add_component_ref (a
, "$vptr");
833 else if (a
->ts
.type
== BT_DERIVED
)
835 vtab
= gfc_find_derived_vtab (a
->ts
.u
.derived
, false);
836 /* Clear the old expr. */
837 gfc_free_ref_list (a
->ref
);
838 memset (a
, '\0', sizeof (gfc_expr
));
839 /* Construct a new one. */
840 a
->expr_type
= EXPR_VARIABLE
;
841 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
846 /* Replace the second argument with the corresponding vtab. */
847 if (mo
->ts
.type
== BT_CLASS
)
848 gfc_add_component_ref (mo
, "$vptr");
849 else if (mo
->ts
.type
== BT_DERIVED
)
851 vtab
= gfc_find_derived_vtab (mo
->ts
.u
.derived
, false);
852 /* Clear the old expr. */
853 gfc_free_ref_list (mo
->ref
);
854 memset (mo
, '\0', sizeof (gfc_expr
));
855 /* Construct a new one. */
856 mo
->expr_type
= EXPR_VARIABLE
;
857 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
862 f
->ts
.type
= BT_LOGICAL
;
864 /* Call library function. */
865 f
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
870 gfc_resolve_fdate (gfc_expr
*f
)
872 f
->ts
.type
= BT_CHARACTER
;
873 f
->ts
.kind
= gfc_default_character_kind
;
874 f
->value
.function
.name
= gfc_get_string (PREFIX ("fdate"));
879 gfc_resolve_floor (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
881 f
->ts
.type
= BT_INTEGER
;
882 f
->ts
.kind
= (kind
== NULL
)
883 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
884 f
->value
.function
.name
885 = gfc_get_string ("__floor%d_%c%d", f
->ts
.kind
,
886 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
891 gfc_resolve_fnum (gfc_expr
*f
, gfc_expr
*n
)
893 f
->ts
.type
= BT_INTEGER
;
894 f
->ts
.kind
= gfc_default_integer_kind
;
895 if (n
->ts
.kind
!= f
->ts
.kind
)
896 gfc_convert_type (n
, &f
->ts
, 2);
897 f
->value
.function
.name
= gfc_get_string (PREFIX ("fnum_i%d"), f
->ts
.kind
);
902 gfc_resolve_fraction (gfc_expr
*f
, gfc_expr
*x
)
905 f
->value
.function
.name
= gfc_get_string ("__fraction_%d", x
->ts
.kind
);
909 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
912 gfc_resolve_g77_math1 (gfc_expr
*f
, gfc_expr
*x
)
915 f
->value
.function
.name
= gfc_get_string ("<intrinsic>");
920 gfc_resolve_gamma (gfc_expr
*f
, gfc_expr
*x
)
923 f
->value
.function
.name
924 = gfc_get_string ("__tgamma_%d", x
->ts
.kind
);
929 gfc_resolve_getcwd (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
931 f
->ts
.type
= BT_INTEGER
;
933 f
->value
.function
.name
= gfc_get_string (PREFIX ("getcwd"));
938 gfc_resolve_getgid (gfc_expr
*f
)
940 f
->ts
.type
= BT_INTEGER
;
942 f
->value
.function
.name
= gfc_get_string (PREFIX ("getgid"));
947 gfc_resolve_getpid (gfc_expr
*f
)
949 f
->ts
.type
= BT_INTEGER
;
951 f
->value
.function
.name
= gfc_get_string (PREFIX ("getpid"));
956 gfc_resolve_getuid (gfc_expr
*f
)
958 f
->ts
.type
= BT_INTEGER
;
960 f
->value
.function
.name
= gfc_get_string (PREFIX ("getuid"));
965 gfc_resolve_hostnm (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
967 f
->ts
.type
= BT_INTEGER
;
969 f
->value
.function
.name
= gfc_get_string (PREFIX ("hostnm"));
974 gfc_resolve_hypot (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
977 f
->value
.function
.name
= gfc_get_string ("__hypot_r%d", x
->ts
.kind
);
982 gfc_resolve_iand (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
984 /* If the kind of i and j are different, then g77 cross-promoted the
985 kinds to the largest value. The Fortran 95 standard requires the
987 if (i
->ts
.kind
!= j
->ts
.kind
)
989 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
990 gfc_convert_type (j
, &i
->ts
, 2);
992 gfc_convert_type (i
, &j
->ts
, 2);
996 f
->value
.function
.name
= gfc_get_string ("__iand_%d", i
->ts
.kind
);
1001 gfc_resolve_ibclr (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
)
1004 f
->value
.function
.name
= gfc_get_string ("__ibclr_%d", i
->ts
.kind
);
1009 gfc_resolve_ibits (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
,
1010 gfc_expr
*len ATTRIBUTE_UNUSED
)
1013 f
->value
.function
.name
= gfc_get_string ("__ibits_%d", i
->ts
.kind
);
1018 gfc_resolve_ibset (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
)
1021 f
->value
.function
.name
= gfc_get_string ("__ibset_%d", i
->ts
.kind
);
1026 gfc_resolve_iachar (gfc_expr
*f
, gfc_expr
*c
, gfc_expr
*kind
)
1028 f
->ts
.type
= BT_INTEGER
;
1030 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1032 f
->ts
.kind
= gfc_default_integer_kind
;
1033 f
->value
.function
.name
= gfc_get_string ("__ichar_%d", c
->ts
.kind
);
1038 gfc_resolve_ichar (gfc_expr
*f
, gfc_expr
*c
, gfc_expr
*kind
)
1040 f
->ts
.type
= BT_INTEGER
;
1042 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1044 f
->ts
.kind
= gfc_default_integer_kind
;
1045 f
->value
.function
.name
= gfc_get_string ("__ichar_%d", c
->ts
.kind
);
1050 gfc_resolve_idnint (gfc_expr
*f
, gfc_expr
*a
)
1052 gfc_resolve_nint (f
, a
, NULL
);
1057 gfc_resolve_ierrno (gfc_expr
*f
)
1059 f
->ts
.type
= BT_INTEGER
;
1060 f
->ts
.kind
= gfc_default_integer_kind
;
1061 f
->value
.function
.name
= gfc_get_string (PREFIX ("ierrno_i%d"), f
->ts
.kind
);
1066 gfc_resolve_ieor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1068 /* If the kind of i and j are different, then g77 cross-promoted the
1069 kinds to the largest value. The Fortran 95 standard requires the
1071 if (i
->ts
.kind
!= j
->ts
.kind
)
1073 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1074 gfc_convert_type (j
, &i
->ts
, 2);
1076 gfc_convert_type (i
, &j
->ts
, 2);
1080 f
->value
.function
.name
= gfc_get_string ("__ieor_%d", i
->ts
.kind
);
1085 gfc_resolve_ior (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1087 /* If the kind of i and j are different, then g77 cross-promoted the
1088 kinds to the largest value. The Fortran 95 standard requires the
1090 if (i
->ts
.kind
!= j
->ts
.kind
)
1092 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1093 gfc_convert_type (j
, &i
->ts
, 2);
1095 gfc_convert_type (i
, &j
->ts
, 2);
1099 f
->value
.function
.name
= gfc_get_string ("__ior_%d", i
->ts
.kind
);
1104 gfc_resolve_index_func (gfc_expr
*f
, gfc_expr
*str
,
1105 gfc_expr
*sub_str ATTRIBUTE_UNUSED
, gfc_expr
*back
,
1111 f
->ts
.type
= BT_INTEGER
;
1113 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1115 f
->ts
.kind
= gfc_default_integer_kind
;
1117 if (back
&& back
->ts
.kind
!= gfc_default_integer_kind
)
1119 ts
.type
= BT_LOGICAL
;
1120 ts
.kind
= gfc_default_integer_kind
;
1121 ts
.u
.derived
= NULL
;
1123 gfc_convert_type (back
, &ts
, 2);
1126 f
->value
.function
.name
1127 = gfc_get_string ("__index_%d_i%d", str
->ts
.kind
, f
->ts
.kind
);
1132 gfc_resolve_int (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1134 f
->ts
.type
= BT_INTEGER
;
1135 f
->ts
.kind
= (kind
== NULL
)
1136 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
1137 f
->value
.function
.name
1138 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1139 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1144 gfc_resolve_int2 (gfc_expr
*f
, gfc_expr
*a
)
1146 f
->ts
.type
= BT_INTEGER
;
1148 f
->value
.function
.name
1149 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1150 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1155 gfc_resolve_int8 (gfc_expr
*f
, gfc_expr
*a
)
1157 f
->ts
.type
= BT_INTEGER
;
1159 f
->value
.function
.name
1160 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1161 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1166 gfc_resolve_long (gfc_expr
*f
, gfc_expr
*a
)
1168 f
->ts
.type
= BT_INTEGER
;
1170 f
->value
.function
.name
1171 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1172 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1177 gfc_resolve_isatty (gfc_expr
*f
, gfc_expr
*u
)
1182 f
->ts
.type
= BT_LOGICAL
;
1183 f
->ts
.kind
= gfc_default_integer_kind
;
1184 if (u
->ts
.kind
!= gfc_c_int_kind
)
1186 ts
.type
= BT_INTEGER
;
1187 ts
.kind
= gfc_c_int_kind
;
1188 ts
.u
.derived
= NULL
;
1190 gfc_convert_type (u
, &ts
, 2);
1193 f
->value
.function
.name
= gfc_get_string (PREFIX ("isatty_l%d"), f
->ts
.kind
);
1198 gfc_resolve_ishft (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1201 f
->value
.function
.name
1202 = gfc_get_string ("__ishft_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1207 gfc_resolve_rshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1210 f
->value
.function
.name
1211 = gfc_get_string ("__rshift_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1216 gfc_resolve_lshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1219 f
->value
.function
.name
1220 = gfc_get_string ("__lshift_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1225 gfc_resolve_ishftc (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
1229 s_kind
= (size
== NULL
) ? gfc_default_integer_kind
: size
->ts
.kind
;
1232 f
->value
.function
.name
1233 = gfc_get_string ("__ishftc_%d_%d_%d", i
->ts
.kind
, shift
->ts
.kind
, s_kind
);
1238 gfc_resolve_kill (gfc_expr
*f
, gfc_expr
*p ATTRIBUTE_UNUSED
,
1239 gfc_expr
*s ATTRIBUTE_UNUSED
)
1241 f
->ts
.type
= BT_INTEGER
;
1242 f
->ts
.kind
= gfc_default_integer_kind
;
1243 f
->value
.function
.name
= gfc_get_string (PREFIX ("kill_i%d"), f
->ts
.kind
);
1248 gfc_resolve_lbound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
1250 static char lbound
[] = "__lbound";
1252 f
->ts
.type
= BT_INTEGER
;
1254 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1256 f
->ts
.kind
= gfc_default_integer_kind
;
1261 f
->shape
= gfc_get_shape (1);
1262 mpz_init_set_ui (f
->shape
[0], array
->rank
);
1265 f
->value
.function
.name
= lbound
;
1270 gfc_resolve_len (gfc_expr
*f
, gfc_expr
*string
, gfc_expr
*kind
)
1272 f
->ts
.type
= BT_INTEGER
;
1274 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1276 f
->ts
.kind
= gfc_default_integer_kind
;
1277 f
->value
.function
.name
1278 = gfc_get_string ("__len_%d_i%d", string
->ts
.kind
,
1279 gfc_default_integer_kind
);
1284 gfc_resolve_len_trim (gfc_expr
*f
, gfc_expr
*string
, gfc_expr
*kind
)
1286 f
->ts
.type
= BT_INTEGER
;
1288 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1290 f
->ts
.kind
= gfc_default_integer_kind
;
1291 f
->value
.function
.name
= gfc_get_string ("__len_trim%d", string
->ts
.kind
);
1296 gfc_resolve_lgamma (gfc_expr
*f
, gfc_expr
*x
)
1299 f
->value
.function
.name
1300 = gfc_get_string ("__lgamma_%d", x
->ts
.kind
);
1305 gfc_resolve_link (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
1306 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
1308 f
->ts
.type
= BT_INTEGER
;
1309 f
->ts
.kind
= gfc_default_integer_kind
;
1310 f
->value
.function
.name
= gfc_get_string (PREFIX ("link_i%d"), f
->ts
.kind
);
1315 gfc_resolve_loc (gfc_expr
*f
, gfc_expr
*x
)
1317 f
->ts
.type
= BT_INTEGER
;
1318 f
->ts
.kind
= gfc_index_integer_kind
;
1319 f
->value
.function
.name
= gfc_get_string ("__loc_%d", x
->ts
.kind
);
1324 gfc_resolve_log (gfc_expr
*f
, gfc_expr
*x
)
1327 f
->value
.function
.name
1328 = gfc_get_string ("__log_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1333 gfc_resolve_log10 (gfc_expr
*f
, gfc_expr
*x
)
1336 f
->value
.function
.name
1337 = gfc_get_string ("__log10_%c%d", gfc_type_letter (x
->ts
.type
),
1343 gfc_resolve_logical (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1345 f
->ts
.type
= BT_LOGICAL
;
1346 f
->ts
.kind
= (kind
== NULL
)
1347 ? gfc_default_logical_kind
: mpz_get_si (kind
->value
.integer
);
1350 f
->value
.function
.name
1351 = gfc_get_string ("__logical_%d_%c%d", f
->ts
.kind
,
1352 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1357 gfc_resolve_malloc (gfc_expr
*f
, gfc_expr
*size
)
1359 if (size
->ts
.kind
< gfc_index_integer_kind
)
1364 ts
.type
= BT_INTEGER
;
1365 ts
.kind
= gfc_index_integer_kind
;
1366 gfc_convert_type_warn (size
, &ts
, 2, 0);
1369 f
->ts
.type
= BT_INTEGER
;
1370 f
->ts
.kind
= gfc_index_integer_kind
;
1371 f
->value
.function
.name
= gfc_get_string (PREFIX ("malloc"));
1376 gfc_resolve_matmul (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b
)
1380 if (a
->ts
.type
== BT_LOGICAL
&& b
->ts
.type
== BT_LOGICAL
)
1382 f
->ts
.type
= BT_LOGICAL
;
1383 f
->ts
.kind
= gfc_default_logical_kind
;
1387 temp
.expr_type
= EXPR_OP
;
1388 gfc_clear_ts (&temp
.ts
);
1389 temp
.value
.op
.op
= INTRINSIC_NONE
;
1390 temp
.value
.op
.op1
= a
;
1391 temp
.value
.op
.op2
= b
;
1392 gfc_type_convert_binary (&temp
, 1);
1396 f
->rank
= (a
->rank
== 2 && b
->rank
== 2) ? 2 : 1;
1398 if (a
->rank
== 2 && b
->rank
== 2)
1400 if (a
->shape
&& b
->shape
)
1402 f
->shape
= gfc_get_shape (f
->rank
);
1403 mpz_init_set (f
->shape
[0], a
->shape
[0]);
1404 mpz_init_set (f
->shape
[1], b
->shape
[1]);
1407 else if (a
->rank
== 1)
1411 f
->shape
= gfc_get_shape (f
->rank
);
1412 mpz_init_set (f
->shape
[0], b
->shape
[1]);
1417 /* b->rank == 1 and a->rank == 2 here, all other cases have
1418 been caught in check.c. */
1421 f
->shape
= gfc_get_shape (f
->rank
);
1422 mpz_init_set (f
->shape
[0], a
->shape
[0]);
1426 f
->value
.function
.name
1427 = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f
->ts
.type
),
1433 gfc_resolve_minmax (const char *name
, gfc_expr
*f
, gfc_actual_arglist
*args
)
1435 gfc_actual_arglist
*a
;
1437 f
->ts
.type
= args
->expr
->ts
.type
;
1438 f
->ts
.kind
= args
->expr
->ts
.kind
;
1439 /* Find the largest type kind. */
1440 for (a
= args
->next
; a
; a
= a
->next
)
1442 if (a
->expr
->ts
.kind
> f
->ts
.kind
)
1443 f
->ts
.kind
= a
->expr
->ts
.kind
;
1446 /* Convert all parameters to the required kind. */
1447 for (a
= args
; a
; a
= a
->next
)
1449 if (a
->expr
->ts
.kind
!= f
->ts
.kind
)
1450 gfc_convert_type (a
->expr
, &f
->ts
, 2);
1453 f
->value
.function
.name
1454 = gfc_get_string (name
, gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
1459 gfc_resolve_max (gfc_expr
*f
, gfc_actual_arglist
*args
)
1461 gfc_resolve_minmax ("__max_%c%d", f
, args
);
1466 gfc_resolve_maxloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1472 f
->ts
.type
= BT_INTEGER
;
1473 f
->ts
.kind
= gfc_default_integer_kind
;
1478 f
->shape
= gfc_get_shape (1);
1479 mpz_init_set_si (f
->shape
[0], array
->rank
);
1483 f
->rank
= array
->rank
- 1;
1484 gfc_resolve_dim_arg (dim
);
1485 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1487 idim
= (int) mpz_get_si (dim
->value
.integer
);
1488 f
->shape
= gfc_get_shape (f
->rank
);
1489 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1491 if (i
== (idim
- 1))
1493 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1500 if (mask
->rank
== 0)
1505 resolve_mask_arg (mask
);
1510 f
->value
.function
.name
1511 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name
, dim
!= NULL
, f
->ts
.kind
,
1512 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1517 gfc_resolve_maxval (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1527 f
->rank
= array
->rank
- 1;
1528 gfc_resolve_dim_arg (dim
);
1530 if (f
->rank
&& array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1532 idim
= (int) mpz_get_si (dim
->value
.integer
);
1533 f
->shape
= gfc_get_shape (f
->rank
);
1534 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1536 if (i
== (idim
- 1))
1538 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1545 if (mask
->rank
== 0)
1550 resolve_mask_arg (mask
);
1555 f
->value
.function
.name
1556 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
1557 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1562 gfc_resolve_mclock (gfc_expr
*f
)
1564 f
->ts
.type
= BT_INTEGER
;
1566 f
->value
.function
.name
= PREFIX ("mclock");
1571 gfc_resolve_mclock8 (gfc_expr
*f
)
1573 f
->ts
.type
= BT_INTEGER
;
1575 f
->value
.function
.name
= PREFIX ("mclock8");
1580 gfc_resolve_merge (gfc_expr
*f
, gfc_expr
*tsource
,
1581 gfc_expr
*fsource ATTRIBUTE_UNUSED
,
1582 gfc_expr
*mask ATTRIBUTE_UNUSED
)
1584 if (tsource
->ts
.type
== BT_CHARACTER
&& tsource
->ref
)
1585 gfc_resolve_substring_charlen (tsource
);
1587 if (fsource
->ts
.type
== BT_CHARACTER
&& fsource
->ref
)
1588 gfc_resolve_substring_charlen (fsource
);
1590 if (tsource
->ts
.type
== BT_CHARACTER
)
1591 check_charlen_present (tsource
);
1593 f
->ts
= tsource
->ts
;
1594 f
->value
.function
.name
1595 = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource
->ts
.type
),
1601 gfc_resolve_min (gfc_expr
*f
, gfc_actual_arglist
*args
)
1603 gfc_resolve_minmax ("__min_%c%d", f
, args
);
1608 gfc_resolve_minloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1614 f
->ts
.type
= BT_INTEGER
;
1615 f
->ts
.kind
= gfc_default_integer_kind
;
1620 f
->shape
= gfc_get_shape (1);
1621 mpz_init_set_si (f
->shape
[0], array
->rank
);
1625 f
->rank
= array
->rank
- 1;
1626 gfc_resolve_dim_arg (dim
);
1627 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1629 idim
= (int) mpz_get_si (dim
->value
.integer
);
1630 f
->shape
= gfc_get_shape (f
->rank
);
1631 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1633 if (i
== (idim
- 1))
1635 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1642 if (mask
->rank
== 0)
1647 resolve_mask_arg (mask
);
1652 f
->value
.function
.name
1653 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name
, dim
!= NULL
, f
->ts
.kind
,
1654 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1659 gfc_resolve_minval (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1669 f
->rank
= array
->rank
- 1;
1670 gfc_resolve_dim_arg (dim
);
1672 if (f
->rank
&& array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1674 idim
= (int) mpz_get_si (dim
->value
.integer
);
1675 f
->shape
= gfc_get_shape (f
->rank
);
1676 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1678 if (i
== (idim
- 1))
1680 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1687 if (mask
->rank
== 0)
1692 resolve_mask_arg (mask
);
1697 f
->value
.function
.name
1698 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
1699 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1704 gfc_resolve_mod (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
1706 f
->ts
.type
= a
->ts
.type
;
1708 f
->ts
.kind
= gfc_kind_max (a
,p
);
1710 f
->ts
.kind
= a
->ts
.kind
;
1712 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
1714 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
1715 gfc_convert_type (p
, &a
->ts
, 2);
1717 gfc_convert_type (a
, &p
->ts
, 2);
1720 f
->value
.function
.name
1721 = gfc_get_string ("__mod_%c%d", gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
1726 gfc_resolve_modulo (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
1728 f
->ts
.type
= a
->ts
.type
;
1730 f
->ts
.kind
= gfc_kind_max (a
,p
);
1732 f
->ts
.kind
= a
->ts
.kind
;
1734 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
1736 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
1737 gfc_convert_type (p
, &a
->ts
, 2);
1739 gfc_convert_type (a
, &p
->ts
, 2);
1742 f
->value
.function
.name
1743 = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f
->ts
.type
),
1748 gfc_resolve_nearest (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
1750 if (p
->ts
.kind
!= a
->ts
.kind
)
1751 gfc_convert_type (p
, &a
->ts
, 2);
1754 f
->value
.function
.name
1755 = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a
->ts
.type
),
1760 gfc_resolve_nint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1762 f
->ts
.type
= BT_INTEGER
;
1763 f
->ts
.kind
= (kind
== NULL
)
1764 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
1765 f
->value
.function
.name
1766 = gfc_get_string ("__nint_%d_%d", f
->ts
.kind
, a
->ts
.kind
);
1771 gfc_resolve_not (gfc_expr
*f
, gfc_expr
*i
)
1774 f
->value
.function
.name
= gfc_get_string ("__not_%d", i
->ts
.kind
);
1779 gfc_resolve_or (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1781 f
->ts
.type
= i
->ts
.type
;
1782 f
->ts
.kind
= gfc_kind_max (i
, j
);
1784 if (i
->ts
.kind
!= j
->ts
.kind
)
1786 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1787 gfc_convert_type (j
, &i
->ts
, 2);
1789 gfc_convert_type (i
, &j
->ts
, 2);
1792 f
->value
.function
.name
1793 = gfc_get_string ("__or_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
1798 gfc_resolve_pack (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*mask
,
1799 gfc_expr
*vector ATTRIBUTE_UNUSED
)
1801 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
1802 gfc_resolve_substring_charlen (array
);
1807 resolve_mask_arg (mask
);
1809 if (mask
->rank
!= 0)
1811 if (array
->ts
.type
== BT_CHARACTER
)
1812 f
->value
.function
.name
1813 = array
->ts
.kind
== 1 ? PREFIX ("pack_char")
1815 (PREFIX ("pack_char%d"),
1818 f
->value
.function
.name
= PREFIX ("pack");
1822 if (array
->ts
.type
== BT_CHARACTER
)
1823 f
->value
.function
.name
1824 = array
->ts
.kind
== 1 ? PREFIX ("pack_s_char")
1826 (PREFIX ("pack_s_char%d"),
1829 f
->value
.function
.name
= PREFIX ("pack_s");
1835 gfc_resolve_product (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1844 f
->rank
= array
->rank
- 1;
1845 f
->shape
= gfc_copy_shape_excluding (array
->shape
, array
->rank
, dim
);
1846 gfc_resolve_dim_arg (dim
);
1851 if (mask
->rank
== 0)
1856 resolve_mask_arg (mask
);
1861 f
->value
.function
.name
1862 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
1863 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1868 gfc_resolve_real (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1870 f
->ts
.type
= BT_REAL
;
1873 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1875 f
->ts
.kind
= (a
->ts
.type
== BT_COMPLEX
)
1876 ? a
->ts
.kind
: gfc_default_real_kind
;
1878 f
->value
.function
.name
1879 = gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
1880 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1885 gfc_resolve_realpart (gfc_expr
*f
, gfc_expr
*a
)
1887 f
->ts
.type
= BT_REAL
;
1888 f
->ts
.kind
= a
->ts
.kind
;
1889 f
->value
.function
.name
1890 = gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
1891 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1896 gfc_resolve_rename (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
1897 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
1899 f
->ts
.type
= BT_INTEGER
;
1900 f
->ts
.kind
= gfc_default_integer_kind
;
1901 f
->value
.function
.name
= gfc_get_string (PREFIX ("rename_i%d"), f
->ts
.kind
);
1906 gfc_resolve_repeat (gfc_expr
*f
, gfc_expr
*string
,
1907 gfc_expr
*ncopies ATTRIBUTE_UNUSED
)
1909 f
->ts
.type
= BT_CHARACTER
;
1910 f
->ts
.kind
= string
->ts
.kind
;
1911 f
->value
.function
.name
= gfc_get_string ("__repeat_%d", string
->ts
.kind
);
1916 gfc_resolve_reshape (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*shape
,
1917 gfc_expr
*pad ATTRIBUTE_UNUSED
,
1918 gfc_expr
*order ATTRIBUTE_UNUSED
)
1924 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
1925 gfc_resolve_substring_charlen (source
);
1929 gfc_array_size (shape
, &rank
);
1930 f
->rank
= mpz_get_si (rank
);
1932 switch (source
->ts
.type
)
1939 kind
= source
->ts
.kind
;
1953 if (source
->ts
.type
== BT_COMPLEX
|| source
->ts
.type
== BT_REAL
)
1954 f
->value
.function
.name
1955 = gfc_get_string (PREFIX ("reshape_%c%d"),
1956 gfc_type_letter (source
->ts
.type
),
1958 else if (source
->ts
.type
== BT_CHARACTER
)
1959 f
->value
.function
.name
= gfc_get_string (PREFIX ("reshape_char%d"),
1962 f
->value
.function
.name
1963 = gfc_get_string (PREFIX ("reshape_%d"), source
->ts
.kind
);
1967 f
->value
.function
.name
= (source
->ts
.type
== BT_CHARACTER
1968 ? PREFIX ("reshape_char") : PREFIX ("reshape"));
1972 /* TODO: Make this work with a constant ORDER parameter. */
1973 if (shape
->expr_type
== EXPR_ARRAY
1974 && gfc_is_constant_expr (shape
)
1978 f
->shape
= gfc_get_shape (f
->rank
);
1979 c
= gfc_constructor_first (shape
->value
.constructor
);
1980 for (i
= 0; i
< f
->rank
; i
++)
1982 mpz_init_set (f
->shape
[i
], c
->expr
->value
.integer
);
1983 c
= gfc_constructor_next (c
);
1987 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
1988 so many runtime variations. */
1989 if (shape
->ts
.kind
!= gfc_index_integer_kind
)
1991 gfc_typespec ts
= shape
->ts
;
1992 ts
.kind
= gfc_index_integer_kind
;
1993 gfc_convert_type_warn (shape
, &ts
, 2, 0);
1995 if (order
&& order
->ts
.kind
!= gfc_index_integer_kind
)
1996 gfc_convert_type_warn (order
, &shape
->ts
, 2, 0);
2001 gfc_resolve_rrspacing (gfc_expr
*f
, gfc_expr
*x
)
2004 f
->value
.function
.name
= gfc_get_string ("__rrspacing_%d", x
->ts
.kind
);
2009 gfc_resolve_scale (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*i ATTRIBUTE_UNUSED
)
2012 f
->value
.function
.name
= gfc_get_string ("__scale_%d", x
->ts
.kind
);
2017 gfc_resolve_scan (gfc_expr
*f
, gfc_expr
*string
,
2018 gfc_expr
*set ATTRIBUTE_UNUSED
,
2019 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2021 f
->ts
.type
= BT_INTEGER
;
2023 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2025 f
->ts
.kind
= gfc_default_integer_kind
;
2026 f
->value
.function
.name
= gfc_get_string ("__scan_%d", string
->ts
.kind
);
2031 gfc_resolve_secnds (gfc_expr
*t1
, gfc_expr
*t0
)
2034 t1
->value
.function
.name
= gfc_get_string (PREFIX ("secnds"));
2039 gfc_resolve_set_exponent (gfc_expr
*f
, gfc_expr
*x
,
2040 gfc_expr
*i ATTRIBUTE_UNUSED
)
2043 f
->value
.function
.name
= gfc_get_string ("__set_exponent_%d", x
->ts
.kind
);
2048 gfc_resolve_shape (gfc_expr
*f
, gfc_expr
*array
)
2050 f
->ts
.type
= BT_INTEGER
;
2051 f
->ts
.kind
= gfc_default_integer_kind
;
2053 f
->shape
= gfc_get_shape (1);
2054 mpz_init_set_ui (f
->shape
[0], array
->rank
);
2055 f
->value
.function
.name
= gfc_get_string (PREFIX ("shape_%d"), f
->ts
.kind
);
2060 gfc_resolve_sign (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b ATTRIBUTE_UNUSED
)
2063 f
->value
.function
.name
2064 = gfc_get_string ("__sign_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2069 gfc_resolve_signal (gfc_expr
*f
, gfc_expr
*number
, gfc_expr
*handler
)
2071 f
->ts
.type
= BT_INTEGER
;
2072 f
->ts
.kind
= gfc_c_int_kind
;
2074 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2075 if (handler
->ts
.type
== BT_INTEGER
)
2077 if (handler
->ts
.kind
!= gfc_c_int_kind
)
2078 gfc_convert_type (handler
, &f
->ts
, 2);
2079 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func_int"));
2082 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func"));
2084 if (number
->ts
.kind
!= gfc_c_int_kind
)
2085 gfc_convert_type (number
, &f
->ts
, 2);
2090 gfc_resolve_sin (gfc_expr
*f
, gfc_expr
*x
)
2093 f
->value
.function
.name
2094 = gfc_get_string ("__sin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2099 gfc_resolve_sinh (gfc_expr
*f
, gfc_expr
*x
)
2102 f
->value
.function
.name
2103 = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2108 gfc_resolve_size (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2109 gfc_expr
*dim ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2111 f
->ts
.type
= BT_INTEGER
;
2113 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2115 f
->ts
.kind
= gfc_default_integer_kind
;
2120 gfc_resolve_spacing (gfc_expr
*f
, gfc_expr
*x
)
2123 f
->value
.function
.name
= gfc_get_string ("__spacing_%d", x
->ts
.kind
);
2128 gfc_resolve_spread (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*dim
,
2131 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
2132 gfc_resolve_substring_charlen (source
);
2134 if (source
->ts
.type
== BT_CHARACTER
)
2135 check_charlen_present (source
);
2138 f
->rank
= source
->rank
+ 1;
2139 if (source
->rank
== 0)
2141 if (source
->ts
.type
== BT_CHARACTER
)
2142 f
->value
.function
.name
2143 = source
->ts
.kind
== 1 ? PREFIX ("spread_char_scalar")
2145 (PREFIX ("spread_char%d_scalar"),
2148 f
->value
.function
.name
= PREFIX ("spread_scalar");
2152 if (source
->ts
.type
== BT_CHARACTER
)
2153 f
->value
.function
.name
2154 = source
->ts
.kind
== 1 ? PREFIX ("spread_char")
2156 (PREFIX ("spread_char%d"),
2159 f
->value
.function
.name
= PREFIX ("spread");
2162 if (dim
&& gfc_is_constant_expr (dim
)
2163 && ncopies
&& gfc_is_constant_expr (ncopies
) && source
->shape
[0])
2166 idim
= mpz_get_ui (dim
->value
.integer
);
2167 f
->shape
= gfc_get_shape (f
->rank
);
2168 for (i
= 0; i
< (idim
- 1); i
++)
2169 mpz_init_set (f
->shape
[i
], source
->shape
[i
]);
2171 mpz_init_set (f
->shape
[idim
- 1], ncopies
->value
.integer
);
2173 for (i
= idim
; i
< f
->rank
; i
++)
2174 mpz_init_set (f
->shape
[i
], source
->shape
[i
-1]);
2178 gfc_resolve_dim_arg (dim
);
2179 gfc_resolve_index (ncopies
, 1);
2184 gfc_resolve_sqrt (gfc_expr
*f
, gfc_expr
*x
)
2187 f
->value
.function
.name
2188 = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2192 /* Resolve the g77 compatibility function STAT AND FSTAT. */
2195 gfc_resolve_stat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2196 gfc_expr
*a ATTRIBUTE_UNUSED
)
2198 f
->ts
.type
= BT_INTEGER
;
2199 f
->ts
.kind
= gfc_default_integer_kind
;
2200 f
->value
.function
.name
= gfc_get_string (PREFIX ("stat_i%d"), f
->ts
.kind
);
2205 gfc_resolve_lstat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2206 gfc_expr
*a ATTRIBUTE_UNUSED
)
2208 f
->ts
.type
= BT_INTEGER
;
2209 f
->ts
.kind
= gfc_default_integer_kind
;
2210 f
->value
.function
.name
= gfc_get_string (PREFIX ("lstat_i%d"), f
->ts
.kind
);
2215 gfc_resolve_fstat (gfc_expr
*f
, gfc_expr
*n
, gfc_expr
*a ATTRIBUTE_UNUSED
)
2217 f
->ts
.type
= BT_INTEGER
;
2218 f
->ts
.kind
= gfc_default_integer_kind
;
2219 if (n
->ts
.kind
!= f
->ts
.kind
)
2220 gfc_convert_type (n
, &f
->ts
, 2);
2222 f
->value
.function
.name
= gfc_get_string (PREFIX ("fstat_i%d"), f
->ts
.kind
);
2227 gfc_resolve_fgetc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2232 f
->ts
.type
= BT_INTEGER
;
2233 f
->ts
.kind
= gfc_c_int_kind
;
2234 if (u
->ts
.kind
!= gfc_c_int_kind
)
2236 ts
.type
= BT_INTEGER
;
2237 ts
.kind
= gfc_c_int_kind
;
2238 ts
.u
.derived
= NULL
;
2240 gfc_convert_type (u
, &ts
, 2);
2243 f
->value
.function
.name
= gfc_get_string (PREFIX ("fgetc"));
2248 gfc_resolve_fget (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2250 f
->ts
.type
= BT_INTEGER
;
2251 f
->ts
.kind
= gfc_c_int_kind
;
2252 f
->value
.function
.name
= gfc_get_string (PREFIX ("fget"));
2257 gfc_resolve_fputc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2262 f
->ts
.type
= BT_INTEGER
;
2263 f
->ts
.kind
= gfc_c_int_kind
;
2264 if (u
->ts
.kind
!= gfc_c_int_kind
)
2266 ts
.type
= BT_INTEGER
;
2267 ts
.kind
= gfc_c_int_kind
;
2268 ts
.u
.derived
= NULL
;
2270 gfc_convert_type (u
, &ts
, 2);
2273 f
->value
.function
.name
= gfc_get_string (PREFIX ("fputc"));
2278 gfc_resolve_fput (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2280 f
->ts
.type
= BT_INTEGER
;
2281 f
->ts
.kind
= gfc_c_int_kind
;
2282 f
->value
.function
.name
= gfc_get_string (PREFIX ("fput"));
2287 gfc_resolve_ftell (gfc_expr
*f
, gfc_expr
*u
)
2292 f
->ts
.type
= BT_INTEGER
;
2293 f
->ts
.kind
= gfc_index_integer_kind
;
2294 if (u
->ts
.kind
!= gfc_c_int_kind
)
2296 ts
.type
= BT_INTEGER
;
2297 ts
.kind
= gfc_c_int_kind
;
2298 ts
.u
.derived
= NULL
;
2300 gfc_convert_type (u
, &ts
, 2);
2303 f
->value
.function
.name
= gfc_get_string (PREFIX ("ftell"));
2308 gfc_resolve_sum (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2316 if (mask
->rank
== 0)
2321 resolve_mask_arg (mask
);
2328 f
->rank
= array
->rank
- 1;
2329 f
->shape
= gfc_copy_shape_excluding (array
->shape
, array
->rank
, dim
);
2330 gfc_resolve_dim_arg (dim
);
2333 f
->value
.function
.name
2334 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
2335 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
2340 gfc_resolve_symlnk (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
2341 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
2343 f
->ts
.type
= BT_INTEGER
;
2344 f
->ts
.kind
= gfc_default_integer_kind
;
2345 f
->value
.function
.name
= gfc_get_string (PREFIX ("symlnk_i%d"), f
->ts
.kind
);
2349 /* Resolve the g77 compatibility function SYSTEM. */
2352 gfc_resolve_system (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
2354 f
->ts
.type
= BT_INTEGER
;
2356 f
->value
.function
.name
= gfc_get_string (PREFIX ("system"));
2361 gfc_resolve_tan (gfc_expr
*f
, gfc_expr
*x
)
2364 f
->value
.function
.name
2365 = gfc_get_string ("__tan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2370 gfc_resolve_tanh (gfc_expr
*f
, gfc_expr
*x
)
2373 f
->value
.function
.name
2374 = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2379 gfc_resolve_time (gfc_expr
*f
)
2381 f
->ts
.type
= BT_INTEGER
;
2383 f
->value
.function
.name
= gfc_get_string (PREFIX ("time_func"));
2388 gfc_resolve_time8 (gfc_expr
*f
)
2390 f
->ts
.type
= BT_INTEGER
;
2392 f
->value
.function
.name
= gfc_get_string (PREFIX ("time8_func"));
2397 gfc_resolve_transfer (gfc_expr
*f
, gfc_expr
*source ATTRIBUTE_UNUSED
,
2398 gfc_expr
*mold
, gfc_expr
*size
)
2400 /* TODO: Make this do something meaningful. */
2401 static char transfer0
[] = "__transfer0", transfer1
[] = "__transfer1";
2403 if (mold
->ts
.type
== BT_CHARACTER
2404 && !mold
->ts
.u
.cl
->length
2405 && gfc_is_constant_expr (mold
))
2408 if (mold
->expr_type
== EXPR_CONSTANT
)
2410 len
= mold
->value
.character
.length
;
2411 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
2416 gfc_constructor
*c
= gfc_constructor_first (mold
->value
.constructor
);
2417 len
= c
->expr
->value
.character
.length
;
2418 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
2425 if (size
== NULL
&& mold
->rank
== 0)
2428 f
->value
.function
.name
= transfer0
;
2433 f
->value
.function
.name
= transfer1
;
2434 if (size
&& gfc_is_constant_expr (size
))
2436 f
->shape
= gfc_get_shape (1);
2437 mpz_init_set (f
->shape
[0], size
->value
.integer
);
2444 gfc_resolve_transpose (gfc_expr
*f
, gfc_expr
*matrix
)
2447 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ref
)
2448 gfc_resolve_substring_charlen (matrix
);
2454 f
->shape
= gfc_get_shape (2);
2455 mpz_init_set (f
->shape
[0], matrix
->shape
[1]);
2456 mpz_init_set (f
->shape
[1], matrix
->shape
[0]);
2459 switch (matrix
->ts
.kind
)
2465 switch (matrix
->ts
.type
)
2469 f
->value
.function
.name
2470 = gfc_get_string (PREFIX ("transpose_%c%d"),
2471 gfc_type_letter (matrix
->ts
.type
),
2477 /* Use the integer routines for real and logical cases. This
2478 assumes they all have the same alignment requirements. */
2479 f
->value
.function
.name
2480 = gfc_get_string (PREFIX ("transpose_i%d"), matrix
->ts
.kind
);
2484 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ts
.kind
== 4)
2485 f
->value
.function
.name
= PREFIX ("transpose_char4");
2487 f
->value
.function
.name
= PREFIX ("transpose");
2493 f
->value
.function
.name
= (matrix
->ts
.type
== BT_CHARACTER
2494 ? PREFIX ("transpose_char")
2495 : PREFIX ("transpose"));
2502 gfc_resolve_trim (gfc_expr
*f
, gfc_expr
*string
)
2504 f
->ts
.type
= BT_CHARACTER
;
2505 f
->ts
.kind
= string
->ts
.kind
;
2506 f
->value
.function
.name
= gfc_get_string ("__trim_%d", string
->ts
.kind
);
2511 gfc_resolve_ubound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2513 static char ubound
[] = "__ubound";
2515 f
->ts
.type
= BT_INTEGER
;
2517 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2519 f
->ts
.kind
= gfc_default_integer_kind
;
2524 f
->shape
= gfc_get_shape (1);
2525 mpz_init_set_ui (f
->shape
[0], array
->rank
);
2528 f
->value
.function
.name
= ubound
;
2532 /* Resolve the g77 compatibility function UMASK. */
2535 gfc_resolve_umask (gfc_expr
*f
, gfc_expr
*n
)
2537 f
->ts
.type
= BT_INTEGER
;
2538 f
->ts
.kind
= n
->ts
.kind
;
2539 f
->value
.function
.name
= gfc_get_string (PREFIX ("umask_i%d"), n
->ts
.kind
);
2543 /* Resolve the g77 compatibility function UNLINK. */
2546 gfc_resolve_unlink (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
2548 f
->ts
.type
= BT_INTEGER
;
2550 f
->value
.function
.name
= gfc_get_string (PREFIX ("unlink"));
2555 gfc_resolve_ttynam (gfc_expr
*f
, gfc_expr
*unit
)
2560 f
->ts
.type
= BT_CHARACTER
;
2561 f
->ts
.kind
= gfc_default_character_kind
;
2563 if (unit
->ts
.kind
!= gfc_c_int_kind
)
2565 ts
.type
= BT_INTEGER
;
2566 ts
.kind
= gfc_c_int_kind
;
2567 ts
.u
.derived
= NULL
;
2569 gfc_convert_type (unit
, &ts
, 2);
2572 f
->value
.function
.name
= gfc_get_string (PREFIX ("ttynam"));
2577 gfc_resolve_unpack (gfc_expr
*f
, gfc_expr
*vector
, gfc_expr
*mask
,
2578 gfc_expr
*field ATTRIBUTE_UNUSED
)
2580 if (vector
->ts
.type
== BT_CHARACTER
&& vector
->ref
)
2581 gfc_resolve_substring_charlen (vector
);
2584 f
->rank
= mask
->rank
;
2585 resolve_mask_arg (mask
);
2587 if (vector
->ts
.type
== BT_CHARACTER
)
2589 if (vector
->ts
.kind
== 1)
2590 f
->value
.function
.name
2591 = gfc_get_string (PREFIX ("unpack%d_char"), field
->rank
> 0 ? 1 : 0);
2593 f
->value
.function
.name
2594 = gfc_get_string (PREFIX ("unpack%d_char%d"),
2595 field
->rank
> 0 ? 1 : 0, vector
->ts
.kind
);
2598 f
->value
.function
.name
2599 = gfc_get_string (PREFIX ("unpack%d"), field
->rank
> 0 ? 1 : 0);
2604 gfc_resolve_verify (gfc_expr
*f
, gfc_expr
*string
,
2605 gfc_expr
*set ATTRIBUTE_UNUSED
,
2606 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2608 f
->ts
.type
= BT_INTEGER
;
2610 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2612 f
->ts
.kind
= gfc_default_integer_kind
;
2613 f
->value
.function
.name
= gfc_get_string ("__verify_%d", string
->ts
.kind
);
2618 gfc_resolve_xor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
2620 f
->ts
.type
= i
->ts
.type
;
2621 f
->ts
.kind
= gfc_kind_max (i
, j
);
2623 if (i
->ts
.kind
!= j
->ts
.kind
)
2625 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
2626 gfc_convert_type (j
, &i
->ts
, 2);
2628 gfc_convert_type (i
, &j
->ts
, 2);
2631 f
->value
.function
.name
2632 = gfc_get_string ("__xor_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
2636 /* Intrinsic subroutine resolution. */
2639 gfc_resolve_alarm_sub (gfc_code
*c
)
2642 gfc_expr
*seconds
, *handler
;
2646 seconds
= c
->ext
.actual
->expr
;
2647 handler
= c
->ext
.actual
->next
->expr
;
2648 ts
.type
= BT_INTEGER
;
2649 ts
.kind
= gfc_c_int_kind
;
2651 /* handler can be either BT_INTEGER or BT_PROCEDURE.
2652 In all cases, the status argument is of default integer kind
2653 (enforced in check.c) so that the function suffix is fixed. */
2654 if (handler
->ts
.type
== BT_INTEGER
)
2656 if (handler
->ts
.kind
!= gfc_c_int_kind
)
2657 gfc_convert_type (handler
, &ts
, 2);
2658 name
= gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
2659 gfc_default_integer_kind
);
2662 name
= gfc_get_string (PREFIX ("alarm_sub_i%d"),
2663 gfc_default_integer_kind
);
2665 if (seconds
->ts
.kind
!= gfc_c_int_kind
)
2666 gfc_convert_type (seconds
, &ts
, 2);
2668 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2672 gfc_resolve_cpu_time (gfc_code
*c
)
2675 name
= gfc_get_string (PREFIX ("cpu_time_%d"), c
->ext
.actual
->expr
->ts
.kind
);
2676 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2680 /* Create a formal arglist based on an actual one and set the INTENTs given. */
2682 static gfc_formal_arglist
*
2683 create_formal_for_intents (gfc_actual_arglist
* actual
, const sym_intent
* ints
)
2685 gfc_formal_arglist
* head
;
2686 gfc_formal_arglist
* tail
;
2692 head
= tail
= gfc_get_formal_arglist ();
2693 for (i
= 0; actual
; actual
= actual
->next
, tail
= tail
->next
, ++i
)
2697 sym
= gfc_new_symbol ("dummyarg", NULL
);
2698 sym
->ts
= actual
->expr
->ts
;
2700 sym
->attr
.intent
= ints
[i
];
2704 tail
->next
= gfc_get_formal_arglist ();
2712 gfc_resolve_mvbits (gfc_code
*c
)
2714 static const sym_intent INTENTS
[] = {INTENT_IN
, INTENT_IN
, INTENT_IN
,
2715 INTENT_INOUT
, INTENT_IN
};
2721 /* FROMPOS, LEN and TOPOS are restricted to small values. As such,
2722 they will be converted so that they fit into a C int. */
2723 ts
.type
= BT_INTEGER
;
2724 ts
.kind
= gfc_c_int_kind
;
2725 if (c
->ext
.actual
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
2726 gfc_convert_type (c
->ext
.actual
->next
->expr
, &ts
, 2);
2727 if (c
->ext
.actual
->next
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
2728 gfc_convert_type (c
->ext
.actual
->next
->next
->expr
, &ts
, 2);
2729 if (c
->ext
.actual
->next
->next
->next
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
2730 gfc_convert_type (c
->ext
.actual
->next
->next
->next
->next
->expr
, &ts
, 2);
2732 /* TO and FROM are guaranteed to have the same kind parameter. */
2733 name
= gfc_get_string (PREFIX ("mvbits_i%d"),
2734 c
->ext
.actual
->expr
->ts
.kind
);
2735 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2736 /* Mark as elemental subroutine as this does not happen automatically. */
2737 c
->resolved_sym
->attr
.elemental
= 1;
2739 /* Create a dummy formal arglist so the INTENTs are known later for purpose
2740 of creating temporaries. */
2741 c
->resolved_sym
->formal
= create_formal_for_intents (c
->ext
.actual
, INTENTS
);
2746 gfc_resolve_random_number (gfc_code
*c
)
2751 kind
= c
->ext
.actual
->expr
->ts
.kind
;
2752 if (c
->ext
.actual
->expr
->rank
== 0)
2753 name
= gfc_get_string (PREFIX ("random_r%d"), kind
);
2755 name
= gfc_get_string (PREFIX ("arandom_r%d"), kind
);
2757 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2762 gfc_resolve_random_seed (gfc_code
*c
)
2766 name
= gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind
);
2767 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2772 gfc_resolve_rename_sub (gfc_code
*c
)
2777 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
2778 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
2780 kind
= gfc_default_integer_kind
;
2782 name
= gfc_get_string (PREFIX ("rename_i%d_sub"), kind
);
2783 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2788 gfc_resolve_kill_sub (gfc_code
*c
)
2793 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
2794 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
2796 kind
= gfc_default_integer_kind
;
2798 name
= gfc_get_string (PREFIX ("kill_i%d_sub"), kind
);
2799 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2804 gfc_resolve_link_sub (gfc_code
*c
)
2809 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
2810 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
2812 kind
= gfc_default_integer_kind
;
2814 name
= gfc_get_string (PREFIX ("link_i%d_sub"), kind
);
2815 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2820 gfc_resolve_symlnk_sub (gfc_code
*c
)
2825 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
2826 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
2828 kind
= gfc_default_integer_kind
;
2830 name
= gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind
);
2831 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2835 /* G77 compatibility subroutines dtime() and etime(). */
2838 gfc_resolve_dtime_sub (gfc_code
*c
)
2841 name
= gfc_get_string (PREFIX ("dtime_sub"));
2842 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2846 gfc_resolve_etime_sub (gfc_code
*c
)
2849 name
= gfc_get_string (PREFIX ("etime_sub"));
2850 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2854 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
2857 gfc_resolve_itime (gfc_code
*c
)
2860 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
2861 gfc_default_integer_kind
));
2865 gfc_resolve_idate (gfc_code
*c
)
2868 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
2869 gfc_default_integer_kind
));
2873 gfc_resolve_ltime (gfc_code
*c
)
2876 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
2877 gfc_default_integer_kind
));
2881 gfc_resolve_gmtime (gfc_code
*c
)
2884 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
2885 gfc_default_integer_kind
));
2889 /* G77 compatibility subroutine second(). */
2892 gfc_resolve_second_sub (gfc_code
*c
)
2895 name
= gfc_get_string (PREFIX ("second_sub"));
2896 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2901 gfc_resolve_sleep_sub (gfc_code
*c
)
2906 if (c
->ext
.actual
->expr
!= NULL
)
2907 kind
= c
->ext
.actual
->expr
->ts
.kind
;
2909 kind
= gfc_default_integer_kind
;
2911 name
= gfc_get_string (PREFIX ("sleep_i%d_sub"), kind
);
2912 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2916 /* G77 compatibility function srand(). */
2919 gfc_resolve_srand (gfc_code
*c
)
2922 name
= gfc_get_string (PREFIX ("srand"));
2923 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2927 /* Resolve the getarg intrinsic subroutine. */
2930 gfc_resolve_getarg (gfc_code
*c
)
2934 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_default_integer_kind
)
2939 ts
.type
= BT_INTEGER
;
2940 ts
.kind
= gfc_default_integer_kind
;
2942 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
2945 name
= gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind
);
2946 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2950 /* Resolve the getcwd intrinsic subroutine. */
2953 gfc_resolve_getcwd_sub (gfc_code
*c
)
2958 if (c
->ext
.actual
->next
->expr
!= NULL
)
2959 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
2961 kind
= gfc_default_integer_kind
;
2963 name
= gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind
);
2964 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2968 /* Resolve the get_command intrinsic subroutine. */
2971 gfc_resolve_get_command (gfc_code
*c
)
2975 kind
= gfc_default_integer_kind
;
2976 name
= gfc_get_string (PREFIX ("get_command_i%d"), kind
);
2977 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2981 /* Resolve the get_command_argument intrinsic subroutine. */
2984 gfc_resolve_get_command_argument (gfc_code
*c
)
2988 kind
= gfc_default_integer_kind
;
2989 name
= gfc_get_string (PREFIX ("get_command_argument_i%d"), kind
);
2990 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2994 /* Resolve the get_environment_variable intrinsic subroutine. */
2997 gfc_resolve_get_environment_variable (gfc_code
*code
)
3001 kind
= gfc_default_integer_kind
;
3002 name
= gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind
);
3003 code
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3008 gfc_resolve_signal_sub (gfc_code
*c
)
3011 gfc_expr
*number
, *handler
, *status
;
3015 number
= c
->ext
.actual
->expr
;
3016 handler
= c
->ext
.actual
->next
->expr
;
3017 status
= c
->ext
.actual
->next
->next
->expr
;
3018 ts
.type
= BT_INTEGER
;
3019 ts
.kind
= gfc_c_int_kind
;
3021 /* handler can be either BT_INTEGER or BT_PROCEDURE */
3022 if (handler
->ts
.type
== BT_INTEGER
)
3024 if (handler
->ts
.kind
!= gfc_c_int_kind
)
3025 gfc_convert_type (handler
, &ts
, 2);
3026 name
= gfc_get_string (PREFIX ("signal_sub_int"));
3029 name
= gfc_get_string (PREFIX ("signal_sub"));
3031 if (number
->ts
.kind
!= gfc_c_int_kind
)
3032 gfc_convert_type (number
, &ts
, 2);
3033 if (status
!= NULL
&& status
->ts
.kind
!= gfc_c_int_kind
)
3034 gfc_convert_type (status
, &ts
, 2);
3036 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3040 /* Resolve the SYSTEM intrinsic subroutine. */
3043 gfc_resolve_system_sub (gfc_code
*c
)
3046 name
= gfc_get_string (PREFIX ("system_sub"));
3047 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3051 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
3054 gfc_resolve_system_clock (gfc_code
*c
)
3059 if (c
->ext
.actual
->expr
!= NULL
)
3060 kind
= c
->ext
.actual
->expr
->ts
.kind
;
3061 else if (c
->ext
.actual
->next
->expr
!= NULL
)
3062 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3063 else if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3064 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3066 kind
= gfc_default_integer_kind
;
3068 name
= gfc_get_string (PREFIX ("system_clock_%d"), kind
);
3069 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3073 /* Resolve the EXIT intrinsic subroutine. */
3076 gfc_resolve_exit (gfc_code
*c
)
3083 /* The STATUS argument has to be of default kind. If it is not,
3085 ts
.type
= BT_INTEGER
;
3086 ts
.kind
= gfc_default_integer_kind
;
3087 n
= c
->ext
.actual
->expr
;
3088 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3089 gfc_convert_type (n
, &ts
, 2);
3091 name
= gfc_get_string (PREFIX ("exit_i%d"), ts
.kind
);
3092 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3096 /* Resolve the FLUSH intrinsic subroutine. */
3099 gfc_resolve_flush (gfc_code
*c
)
3106 ts
.type
= BT_INTEGER
;
3107 ts
.kind
= gfc_default_integer_kind
;
3108 n
= c
->ext
.actual
->expr
;
3109 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3110 gfc_convert_type (n
, &ts
, 2);
3112 name
= gfc_get_string (PREFIX ("flush_i%d"), ts
.kind
);
3113 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3118 gfc_resolve_free (gfc_code
*c
)
3124 ts
.type
= BT_INTEGER
;
3125 ts
.kind
= gfc_index_integer_kind
;
3126 n
= c
->ext
.actual
->expr
;
3127 if (n
->ts
.kind
!= ts
.kind
)
3128 gfc_convert_type (n
, &ts
, 2);
3130 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("free"));
3135 gfc_resolve_ctime_sub (gfc_code
*c
)
3140 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3141 if (c
->ext
.actual
->expr
->ts
.kind
!= 8)
3143 ts
.type
= BT_INTEGER
;
3145 ts
.u
.derived
= NULL
;
3147 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3150 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3155 gfc_resolve_fdate_sub (gfc_code
*c
)
3157 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3162 gfc_resolve_gerror (gfc_code
*c
)
3164 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3169 gfc_resolve_getlog (gfc_code
*c
)
3171 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3176 gfc_resolve_hostnm_sub (gfc_code
*c
)
3181 if (c
->ext
.actual
->next
->expr
!= NULL
)
3182 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3184 kind
= gfc_default_integer_kind
;
3186 name
= gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind
);
3187 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3192 gfc_resolve_perror (gfc_code
*c
)
3194 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3197 /* Resolve the STAT and FSTAT intrinsic subroutines. */
3200 gfc_resolve_stat_sub (gfc_code
*c
)
3203 name
= gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind
);
3204 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3209 gfc_resolve_lstat_sub (gfc_code
*c
)
3212 name
= gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind
);
3213 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3218 gfc_resolve_fstat_sub (gfc_code
*c
)
3224 u
= c
->ext
.actual
->expr
;
3225 ts
= &c
->ext
.actual
->next
->expr
->ts
;
3226 if (u
->ts
.kind
!= ts
->kind
)
3227 gfc_convert_type (u
, ts
, 2);
3228 name
= gfc_get_string (PREFIX ("fstat_i%d_sub"), ts
->kind
);
3229 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3234 gfc_resolve_fgetc_sub (gfc_code
*c
)
3241 u
= c
->ext
.actual
->expr
;
3242 st
= c
->ext
.actual
->next
->next
->expr
;
3244 if (u
->ts
.kind
!= gfc_c_int_kind
)
3246 ts
.type
= BT_INTEGER
;
3247 ts
.kind
= gfc_c_int_kind
;
3248 ts
.u
.derived
= NULL
;
3250 gfc_convert_type (u
, &ts
, 2);
3254 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), st
->ts
.kind
);
3256 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind
);
3258 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3263 gfc_resolve_fget_sub (gfc_code
*c
)
3268 st
= c
->ext
.actual
->next
->expr
;
3270 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), st
->ts
.kind
);
3272 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind
);
3274 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3279 gfc_resolve_fputc_sub (gfc_code
*c
)
3286 u
= c
->ext
.actual
->expr
;
3287 st
= c
->ext
.actual
->next
->next
->expr
;
3289 if (u
->ts
.kind
!= gfc_c_int_kind
)
3291 ts
.type
= BT_INTEGER
;
3292 ts
.kind
= gfc_c_int_kind
;
3293 ts
.u
.derived
= NULL
;
3295 gfc_convert_type (u
, &ts
, 2);
3299 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), st
->ts
.kind
);
3301 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind
);
3303 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3308 gfc_resolve_fput_sub (gfc_code
*c
)
3313 st
= c
->ext
.actual
->next
->expr
;
3315 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), st
->ts
.kind
);
3317 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind
);
3319 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3324 gfc_resolve_fseek_sub (gfc_code
*c
)
3332 unit
= c
->ext
.actual
->expr
;
3333 offset
= c
->ext
.actual
->next
->expr
;
3334 whence
= c
->ext
.actual
->next
->next
->expr
;
3336 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3338 ts
.type
= BT_INTEGER
;
3339 ts
.kind
= gfc_c_int_kind
;
3340 ts
.u
.derived
= NULL
;
3342 gfc_convert_type (unit
, &ts
, 2);
3345 if (offset
->ts
.kind
!= gfc_intio_kind
)
3347 ts
.type
= BT_INTEGER
;
3348 ts
.kind
= gfc_intio_kind
;
3349 ts
.u
.derived
= NULL
;
3351 gfc_convert_type (offset
, &ts
, 2);
3354 if (whence
->ts
.kind
!= gfc_c_int_kind
)
3356 ts
.type
= BT_INTEGER
;
3357 ts
.kind
= gfc_c_int_kind
;
3358 ts
.u
.derived
= NULL
;
3360 gfc_convert_type (whence
, &ts
, 2);
3363 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
3367 gfc_resolve_ftell_sub (gfc_code
*c
)
3375 unit
= c
->ext
.actual
->expr
;
3376 offset
= c
->ext
.actual
->next
->expr
;
3378 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3380 ts
.type
= BT_INTEGER
;
3381 ts
.kind
= gfc_c_int_kind
;
3382 ts
.u
.derived
= NULL
;
3384 gfc_convert_type (unit
, &ts
, 2);
3387 name
= gfc_get_string (PREFIX ("ftell_i%d_sub"), offset
->ts
.kind
);
3388 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3393 gfc_resolve_ttynam_sub (gfc_code
*c
)
3398 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
3400 ts
.type
= BT_INTEGER
;
3401 ts
.kind
= gfc_c_int_kind
;
3402 ts
.u
.derived
= NULL
;
3404 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3407 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
3411 /* Resolve the UMASK intrinsic subroutine. */
3414 gfc_resolve_umask_sub (gfc_code
*c
)
3419 if (c
->ext
.actual
->next
->expr
!= NULL
)
3420 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3422 kind
= gfc_default_integer_kind
;
3424 name
= gfc_get_string (PREFIX ("umask_i%d_sub"), kind
);
3425 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3428 /* Resolve the UNLINK intrinsic subroutine. */
3431 gfc_resolve_unlink_sub (gfc_code
*c
)
3436 if (c
->ext
.actual
->next
->expr
!= NULL
)
3437 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3439 kind
= gfc_default_integer_kind
;
3441 name
= gfc_get_string (PREFIX ("unlink_i%d_sub"), kind
);
3442 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);