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
);
144 /********************** Resolution functions **********************/
148 gfc_resolve_abs (gfc_expr
*f
, gfc_expr
*a
)
151 if (f
->ts
.type
== BT_COMPLEX
)
152 f
->ts
.type
= BT_REAL
;
154 f
->value
.function
.name
155 = gfc_get_string ("__abs_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
160 gfc_resolve_access (gfc_expr
*f
, gfc_expr
*name ATTRIBUTE_UNUSED
,
161 gfc_expr
*mode ATTRIBUTE_UNUSED
)
163 f
->ts
.type
= BT_INTEGER
;
164 f
->ts
.kind
= gfc_c_int_kind
;
165 f
->value
.function
.name
= PREFIX ("access_func");
170 gfc_resolve_adjustl (gfc_expr
*f
, gfc_expr
*string
)
172 f
->ts
.type
= BT_CHARACTER
;
173 f
->ts
.kind
= string
->ts
.kind
;
174 f
->value
.function
.name
= gfc_get_string ("__adjustl_s%d", f
->ts
.kind
);
179 gfc_resolve_adjustr (gfc_expr
*f
, gfc_expr
*string
)
181 f
->ts
.type
= BT_CHARACTER
;
182 f
->ts
.kind
= string
->ts
.kind
;
183 f
->value
.function
.name
= gfc_get_string ("__adjustr_s%d", f
->ts
.kind
);
188 gfc_resolve_char_achar (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*kind
,
191 f
->ts
.type
= BT_CHARACTER
;
192 f
->ts
.kind
= (kind
== NULL
)
193 ? gfc_default_character_kind
: mpz_get_si (kind
->value
.integer
);
194 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
195 f
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
197 f
->value
.function
.name
= gfc_get_string (name
, f
->ts
.kind
,
198 gfc_type_letter (x
->ts
.type
),
204 gfc_resolve_achar (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*kind
)
206 gfc_resolve_char_achar (f
, x
, kind
, "__achar_%d_%c%d");
211 gfc_resolve_acos (gfc_expr
*f
, gfc_expr
*x
)
214 f
->value
.function
.name
215 = gfc_get_string ("__acos_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
220 gfc_resolve_acosh (gfc_expr
*f
, gfc_expr
*x
)
223 f
->value
.function
.name
224 = gfc_get_string ("__acosh_%c%d", gfc_type_letter (x
->ts
.type
),
230 gfc_resolve_aimag (gfc_expr
*f
, gfc_expr
*x
)
232 f
->ts
.type
= BT_REAL
;
233 f
->ts
.kind
= x
->ts
.kind
;
234 f
->value
.function
.name
235 = gfc_get_string ("__aimag_%c%d", gfc_type_letter (x
->ts
.type
),
241 gfc_resolve_and (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
243 f
->ts
.type
= i
->ts
.type
;
244 f
->ts
.kind
= gfc_kind_max (i
, j
);
246 if (i
->ts
.kind
!= j
->ts
.kind
)
248 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
249 gfc_convert_type (j
, &i
->ts
, 2);
251 gfc_convert_type (i
, &j
->ts
, 2);
254 f
->value
.function
.name
255 = gfc_get_string ("__and_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
260 gfc_resolve_aint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
265 f
->ts
.type
= a
->ts
.type
;
266 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
268 if (a
->ts
.kind
!= f
->ts
.kind
)
270 ts
.type
= f
->ts
.type
;
271 ts
.kind
= f
->ts
.kind
;
272 gfc_convert_type (a
, &ts
, 2);
274 /* The resolved name is only used for specific intrinsics where
275 the return kind is the same as the arg kind. */
276 f
->value
.function
.name
277 = gfc_get_string ("__aint_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
282 gfc_resolve_dint (gfc_expr
*f
, gfc_expr
*a
)
284 gfc_resolve_aint (f
, a
, NULL
);
289 gfc_resolve_all (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
)
295 gfc_resolve_dim_arg (dim
);
296 f
->rank
= mask
->rank
- 1;
297 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
300 f
->value
.function
.name
301 = gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask
->ts
.type
),
307 gfc_resolve_anint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
312 f
->ts
.type
= a
->ts
.type
;
313 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
315 if (a
->ts
.kind
!= f
->ts
.kind
)
317 ts
.type
= f
->ts
.type
;
318 ts
.kind
= f
->ts
.kind
;
319 gfc_convert_type (a
, &ts
, 2);
322 /* The resolved name is only used for specific intrinsics where
323 the return kind is the same as the arg kind. */
324 f
->value
.function
.name
325 = gfc_get_string ("__anint_%c%d", gfc_type_letter (a
->ts
.type
),
331 gfc_resolve_dnint (gfc_expr
*f
, gfc_expr
*a
)
333 gfc_resolve_anint (f
, a
, NULL
);
338 gfc_resolve_any (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
)
344 gfc_resolve_dim_arg (dim
);
345 f
->rank
= mask
->rank
- 1;
346 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
349 f
->value
.function
.name
350 = gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask
->ts
.type
),
356 gfc_resolve_asin (gfc_expr
*f
, gfc_expr
*x
)
359 f
->value
.function
.name
360 = gfc_get_string ("__asin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
364 gfc_resolve_asinh (gfc_expr
*f
, gfc_expr
*x
)
367 f
->value
.function
.name
368 = gfc_get_string ("__asinh_%c%d", gfc_type_letter (x
->ts
.type
),
373 gfc_resolve_atan (gfc_expr
*f
, gfc_expr
*x
)
376 f
->value
.function
.name
377 = gfc_get_string ("__atan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
381 gfc_resolve_atanh (gfc_expr
*f
, gfc_expr
*x
)
384 f
->value
.function
.name
385 = gfc_get_string ("__atanh_%c%d", gfc_type_letter (x
->ts
.type
),
390 gfc_resolve_atan2 (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
393 f
->value
.function
.name
394 = gfc_get_string ("__atan2_%c%d", gfc_type_letter (x
->ts
.type
),
399 /* Resolve the BESYN and BESJN intrinsics. */
402 gfc_resolve_besn (gfc_expr
*f
, gfc_expr
*n
, gfc_expr
*x
)
408 if (n
->ts
.kind
!= gfc_c_int_kind
)
410 ts
.type
= BT_INTEGER
;
411 ts
.kind
= gfc_c_int_kind
;
412 gfc_convert_type (n
, &ts
, 2);
414 f
->value
.function
.name
= gfc_get_string ("<intrinsic>");
419 gfc_resolve_btest (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos
)
421 f
->ts
.type
= BT_LOGICAL
;
422 f
->ts
.kind
= gfc_default_logical_kind
;
423 f
->value
.function
.name
424 = gfc_get_string ("__btest_%d_%d", i
->ts
.kind
, pos
->ts
.kind
);
429 gfc_resolve_ceiling (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
431 f
->ts
.type
= BT_INTEGER
;
432 f
->ts
.kind
= (kind
== NULL
)
433 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
434 f
->value
.function
.name
435 = gfc_get_string ("__ceiling_%d_%c%d", f
->ts
.kind
,
436 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
441 gfc_resolve_char (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
443 gfc_resolve_char_achar (f
, a
, kind
, "__char_%d_%c%d");
448 gfc_resolve_chdir (gfc_expr
*f
, gfc_expr
*d ATTRIBUTE_UNUSED
)
450 f
->ts
.type
= BT_INTEGER
;
451 f
->ts
.kind
= gfc_default_integer_kind
;
452 f
->value
.function
.name
= gfc_get_string (PREFIX ("chdir_i%d"), f
->ts
.kind
);
457 gfc_resolve_chdir_sub (gfc_code
*c
)
462 if (c
->ext
.actual
->next
->expr
!= NULL
)
463 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
465 kind
= gfc_default_integer_kind
;
467 name
= gfc_get_string (PREFIX ("chdir_i%d_sub"), kind
);
468 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
473 gfc_resolve_chmod (gfc_expr
*f
, gfc_expr
*name ATTRIBUTE_UNUSED
,
474 gfc_expr
*mode ATTRIBUTE_UNUSED
)
476 f
->ts
.type
= BT_INTEGER
;
477 f
->ts
.kind
= gfc_c_int_kind
;
478 f
->value
.function
.name
= PREFIX ("chmod_func");
483 gfc_resolve_chmod_sub (gfc_code
*c
)
488 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
489 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
491 kind
= gfc_default_integer_kind
;
493 name
= gfc_get_string (PREFIX ("chmod_i%d_sub"), kind
);
494 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
499 gfc_resolve_cmplx (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*kind
)
501 f
->ts
.type
= BT_COMPLEX
;
502 f
->ts
.kind
= (kind
== NULL
)
503 ? gfc_default_real_kind
: mpz_get_si (kind
->value
.integer
);
506 f
->value
.function
.name
507 = gfc_get_string ("__cmplx0_%d_%c%d", f
->ts
.kind
,
508 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
510 f
->value
.function
.name
511 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f
->ts
.kind
,
512 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
,
513 gfc_type_letter (y
->ts
.type
), y
->ts
.kind
);
518 gfc_resolve_dcmplx (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
)
520 gfc_resolve_cmplx (f
, x
, y
, gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
521 gfc_default_double_kind
));
526 gfc_resolve_complex (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
)
530 if (x
->ts
.type
== BT_INTEGER
)
532 if (y
->ts
.type
== BT_INTEGER
)
533 kind
= gfc_default_real_kind
;
539 if (y
->ts
.type
== BT_REAL
)
540 kind
= (x
->ts
.kind
> y
->ts
.kind
) ? x
->ts
.kind
: y
->ts
.kind
;
545 f
->ts
.type
= BT_COMPLEX
;
547 f
->value
.function
.name
548 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f
->ts
.kind
,
549 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
,
550 gfc_type_letter (y
->ts
.type
), y
->ts
.kind
);
555 gfc_resolve_conjg (gfc_expr
*f
, gfc_expr
*x
)
558 f
->value
.function
.name
= gfc_get_string ("__conjg_%d", x
->ts
.kind
);
563 gfc_resolve_cos (gfc_expr
*f
, gfc_expr
*x
)
566 f
->value
.function
.name
567 = gfc_get_string ("__cos_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
572 gfc_resolve_cosh (gfc_expr
*f
, gfc_expr
*x
)
575 f
->value
.function
.name
576 = gfc_get_string ("__cosh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
581 gfc_resolve_count (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
583 f
->ts
.type
= BT_INTEGER
;
585 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
587 f
->ts
.kind
= gfc_default_integer_kind
;
591 f
->rank
= mask
->rank
- 1;
592 gfc_resolve_dim_arg (dim
);
593 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
596 resolve_mask_arg (mask
);
598 f
->value
.function
.name
599 = gfc_get_string (PREFIX ("count_%d_%c"), f
->ts
.kind
,
600 gfc_type_letter (mask
->ts
.type
));
605 gfc_resolve_cshift (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*shift
,
610 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
611 gfc_resolve_substring_charlen (array
);
614 f
->rank
= array
->rank
;
615 f
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
622 /* If dim kind is greater than default integer we need to use the larger. */
623 m
= gfc_default_integer_kind
;
625 m
= m
< dim
->ts
.kind
? dim
->ts
.kind
: m
;
627 /* Convert shift to at least m, so we don't need
628 kind=1 and kind=2 versions of the library functions. */
629 if (shift
->ts
.kind
< m
)
633 ts
.type
= BT_INTEGER
;
635 gfc_convert_type_warn (shift
, &ts
, 2, 0);
640 if (dim
->expr_type
!= EXPR_CONSTANT
&& dim
->symtree
!= NULL
641 && dim
->symtree
->n
.sym
->attr
.optional
)
643 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
644 dim
->representation
.length
= shift
->ts
.kind
;
648 gfc_resolve_dim_arg (dim
);
649 /* Convert dim to shift's kind to reduce variations. */
650 if (dim
->ts
.kind
!= shift
->ts
.kind
)
651 gfc_convert_type_warn (dim
, &shift
->ts
, 2, 0);
655 if (array
->ts
.type
== BT_CHARACTER
)
657 if (array
->ts
.kind
== gfc_default_character_kind
)
658 f
->value
.function
.name
659 = gfc_get_string (PREFIX ("cshift%d_%d_char"), n
, shift
->ts
.kind
);
661 f
->value
.function
.name
662 = gfc_get_string (PREFIX ("cshift%d_%d_char%d"), n
, shift
->ts
.kind
,
666 f
->value
.function
.name
667 = gfc_get_string (PREFIX ("cshift%d_%d"), n
, shift
->ts
.kind
);
672 gfc_resolve_ctime (gfc_expr
*f
, gfc_expr
*time
)
677 f
->ts
.type
= BT_CHARACTER
;
678 f
->ts
.kind
= gfc_default_character_kind
;
680 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
681 if (time
->ts
.kind
!= 8)
683 ts
.type
= BT_INTEGER
;
687 gfc_convert_type (time
, &ts
, 2);
690 f
->value
.function
.name
= gfc_get_string (PREFIX ("ctime"));
695 gfc_resolve_dble (gfc_expr
*f
, gfc_expr
*a
)
697 f
->ts
.type
= BT_REAL
;
698 f
->ts
.kind
= gfc_default_double_kind
;
699 f
->value
.function
.name
700 = gfc_get_string ("__dble_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
705 gfc_resolve_dim (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
707 f
->ts
.type
= a
->ts
.type
;
709 f
->ts
.kind
= gfc_kind_max (a
,p
);
711 f
->ts
.kind
= a
->ts
.kind
;
713 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
715 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
716 gfc_convert_type (p
, &a
->ts
, 2);
718 gfc_convert_type (a
, &p
->ts
, 2);
721 f
->value
.function
.name
722 = gfc_get_string ("__dim_%c%d", gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
727 gfc_resolve_dot_product (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b
)
731 temp
.expr_type
= EXPR_OP
;
732 gfc_clear_ts (&temp
.ts
);
733 temp
.value
.op
.op
= INTRINSIC_NONE
;
734 temp
.value
.op
.op1
= a
;
735 temp
.value
.op
.op2
= b
;
736 gfc_type_convert_binary (&temp
, 1);
738 f
->value
.function
.name
739 = gfc_get_string (PREFIX ("dot_product_%c%d"),
740 gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
745 gfc_resolve_dprod (gfc_expr
*f
, gfc_expr
*a ATTRIBUTE_UNUSED
,
746 gfc_expr
*b ATTRIBUTE_UNUSED
)
748 f
->ts
.kind
= gfc_default_double_kind
;
749 f
->ts
.type
= BT_REAL
;
750 f
->value
.function
.name
= gfc_get_string ("__dprod_r%d", f
->ts
.kind
);
755 gfc_resolve_eoshift (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*shift
,
756 gfc_expr
*boundary
, gfc_expr
*dim
)
760 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
761 gfc_resolve_substring_charlen (array
);
764 f
->rank
= array
->rank
;
765 f
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
770 if (boundary
&& boundary
->rank
> 0)
773 /* If dim kind is greater than default integer we need to use the larger. */
774 m
= gfc_default_integer_kind
;
776 m
= m
< dim
->ts
.kind
? dim
->ts
.kind
: m
;
778 /* Convert shift to at least m, so we don't need
779 kind=1 and kind=2 versions of the library functions. */
780 if (shift
->ts
.kind
< m
)
784 ts
.type
= BT_INTEGER
;
786 gfc_convert_type_warn (shift
, &ts
, 2, 0);
791 if (dim
->expr_type
!= EXPR_CONSTANT
&& dim
->symtree
!= NULL
792 && dim
->symtree
->n
.sym
->attr
.optional
)
794 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
795 dim
->representation
.length
= shift
->ts
.kind
;
799 gfc_resolve_dim_arg (dim
);
800 /* Convert dim to shift's kind to reduce variations. */
801 if (dim
->ts
.kind
!= shift
->ts
.kind
)
802 gfc_convert_type_warn (dim
, &shift
->ts
, 2, 0);
806 if (array
->ts
.type
== BT_CHARACTER
)
808 if (array
->ts
.kind
== gfc_default_character_kind
)
809 f
->value
.function
.name
810 = gfc_get_string (PREFIX ("eoshift%d_%d_char"), n
, shift
->ts
.kind
);
812 f
->value
.function
.name
813 = gfc_get_string (PREFIX ("eoshift%d_%d_char%d"), n
, shift
->ts
.kind
,
817 f
->value
.function
.name
818 = gfc_get_string (PREFIX ("eoshift%d_%d"), n
, shift
->ts
.kind
);
823 gfc_resolve_exp (gfc_expr
*f
, gfc_expr
*x
)
826 f
->value
.function
.name
827 = gfc_get_string ("__exp_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
832 gfc_resolve_exponent (gfc_expr
*f
, gfc_expr
*x
)
834 f
->ts
.type
= BT_INTEGER
;
835 f
->ts
.kind
= gfc_default_integer_kind
;
836 f
->value
.function
.name
= gfc_get_string ("__exponent_%d", x
->ts
.kind
);
840 /* Resolve the EXTENDS_TYPE_OF intrinsic function. */
843 gfc_resolve_extends_type_of (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*mo
)
848 /* Prevent double resolution. */
849 if (f
->ts
.type
== BT_LOGICAL
)
852 /* Replace the first argument with the corresponding vtab. */
853 if (a
->ts
.type
== BT_CLASS
)
854 gfc_add_component_ref (a
, "$vptr");
855 else if (a
->ts
.type
== BT_DERIVED
)
857 vtab
= gfc_find_derived_vtab (a
->ts
.u
.derived
);
858 /* Clear the old expr. */
859 gfc_free_ref_list (a
->ref
);
860 memset (a
, '\0', sizeof (gfc_expr
));
861 /* Construct a new one. */
862 a
->expr_type
= EXPR_VARIABLE
;
863 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
868 /* Replace the second argument with the corresponding vtab. */
869 if (mo
->ts
.type
== BT_CLASS
)
870 gfc_add_component_ref (mo
, "$vptr");
871 else if (mo
->ts
.type
== BT_DERIVED
)
873 vtab
= gfc_find_derived_vtab (mo
->ts
.u
.derived
);
874 /* Clear the old expr. */
875 gfc_free_ref_list (mo
->ref
);
876 memset (mo
, '\0', sizeof (gfc_expr
));
877 /* Construct a new one. */
878 mo
->expr_type
= EXPR_VARIABLE
;
879 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
884 f
->ts
.type
= BT_LOGICAL
;
886 /* Call library function. */
887 f
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
892 gfc_resolve_fdate (gfc_expr
*f
)
894 f
->ts
.type
= BT_CHARACTER
;
895 f
->ts
.kind
= gfc_default_character_kind
;
896 f
->value
.function
.name
= gfc_get_string (PREFIX ("fdate"));
901 gfc_resolve_floor (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
903 f
->ts
.type
= BT_INTEGER
;
904 f
->ts
.kind
= (kind
== NULL
)
905 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
906 f
->value
.function
.name
907 = gfc_get_string ("__floor%d_%c%d", f
->ts
.kind
,
908 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
913 gfc_resolve_fnum (gfc_expr
*f
, gfc_expr
*n
)
915 f
->ts
.type
= BT_INTEGER
;
916 f
->ts
.kind
= gfc_default_integer_kind
;
917 if (n
->ts
.kind
!= f
->ts
.kind
)
918 gfc_convert_type (n
, &f
->ts
, 2);
919 f
->value
.function
.name
= gfc_get_string (PREFIX ("fnum_i%d"), f
->ts
.kind
);
924 gfc_resolve_fraction (gfc_expr
*f
, gfc_expr
*x
)
927 f
->value
.function
.name
= gfc_get_string ("__fraction_%d", x
->ts
.kind
);
931 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
934 gfc_resolve_g77_math1 (gfc_expr
*f
, gfc_expr
*x
)
937 f
->value
.function
.name
= gfc_get_string ("<intrinsic>");
942 gfc_resolve_gamma (gfc_expr
*f
, gfc_expr
*x
)
945 f
->value
.function
.name
946 = gfc_get_string ("__tgamma_%d", x
->ts
.kind
);
951 gfc_resolve_getcwd (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
953 f
->ts
.type
= BT_INTEGER
;
955 f
->value
.function
.name
= gfc_get_string (PREFIX ("getcwd"));
960 gfc_resolve_getgid (gfc_expr
*f
)
962 f
->ts
.type
= BT_INTEGER
;
964 f
->value
.function
.name
= gfc_get_string (PREFIX ("getgid"));
969 gfc_resolve_getpid (gfc_expr
*f
)
971 f
->ts
.type
= BT_INTEGER
;
973 f
->value
.function
.name
= gfc_get_string (PREFIX ("getpid"));
978 gfc_resolve_getuid (gfc_expr
*f
)
980 f
->ts
.type
= BT_INTEGER
;
982 f
->value
.function
.name
= gfc_get_string (PREFIX ("getuid"));
987 gfc_resolve_hostnm (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
989 f
->ts
.type
= BT_INTEGER
;
991 f
->value
.function
.name
= gfc_get_string (PREFIX ("hostnm"));
996 gfc_resolve_hypot (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
999 f
->value
.function
.name
= gfc_get_string ("__hypot_r%d", x
->ts
.kind
);
1004 gfc_resolve_iand (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1006 /* If the kind of i and j are different, then g77 cross-promoted the
1007 kinds to the largest value. The Fortran 95 standard requires the
1009 if (i
->ts
.kind
!= j
->ts
.kind
)
1011 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1012 gfc_convert_type (j
, &i
->ts
, 2);
1014 gfc_convert_type (i
, &j
->ts
, 2);
1018 f
->value
.function
.name
= gfc_get_string ("__iand_%d", i
->ts
.kind
);
1023 gfc_resolve_ibclr (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
)
1026 f
->value
.function
.name
= gfc_get_string ("__ibclr_%d", i
->ts
.kind
);
1031 gfc_resolve_ibits (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
,
1032 gfc_expr
*len ATTRIBUTE_UNUSED
)
1035 f
->value
.function
.name
= gfc_get_string ("__ibits_%d", i
->ts
.kind
);
1040 gfc_resolve_ibset (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
)
1043 f
->value
.function
.name
= gfc_get_string ("__ibset_%d", i
->ts
.kind
);
1048 gfc_resolve_iachar (gfc_expr
*f
, gfc_expr
*c
, gfc_expr
*kind
)
1050 f
->ts
.type
= BT_INTEGER
;
1052 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1054 f
->ts
.kind
= gfc_default_integer_kind
;
1055 f
->value
.function
.name
= gfc_get_string ("__ichar_%d", c
->ts
.kind
);
1060 gfc_resolve_ichar (gfc_expr
*f
, gfc_expr
*c
, gfc_expr
*kind
)
1062 f
->ts
.type
= BT_INTEGER
;
1064 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1066 f
->ts
.kind
= gfc_default_integer_kind
;
1067 f
->value
.function
.name
= gfc_get_string ("__ichar_%d", c
->ts
.kind
);
1072 gfc_resolve_idnint (gfc_expr
*f
, gfc_expr
*a
)
1074 gfc_resolve_nint (f
, a
, NULL
);
1079 gfc_resolve_ierrno (gfc_expr
*f
)
1081 f
->ts
.type
= BT_INTEGER
;
1082 f
->ts
.kind
= gfc_default_integer_kind
;
1083 f
->value
.function
.name
= gfc_get_string (PREFIX ("ierrno_i%d"), f
->ts
.kind
);
1088 gfc_resolve_ieor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1090 /* If the kind of i and j are different, then g77 cross-promoted the
1091 kinds to the largest value. The Fortran 95 standard requires the
1093 if (i
->ts
.kind
!= j
->ts
.kind
)
1095 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1096 gfc_convert_type (j
, &i
->ts
, 2);
1098 gfc_convert_type (i
, &j
->ts
, 2);
1102 f
->value
.function
.name
= gfc_get_string ("__ieor_%d", i
->ts
.kind
);
1107 gfc_resolve_ior (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1109 /* If the kind of i and j are different, then g77 cross-promoted the
1110 kinds to the largest value. The Fortran 95 standard requires the
1112 if (i
->ts
.kind
!= j
->ts
.kind
)
1114 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1115 gfc_convert_type (j
, &i
->ts
, 2);
1117 gfc_convert_type (i
, &j
->ts
, 2);
1121 f
->value
.function
.name
= gfc_get_string ("__ior_%d", i
->ts
.kind
);
1126 gfc_resolve_index_func (gfc_expr
*f
, gfc_expr
*str
,
1127 gfc_expr
*sub_str ATTRIBUTE_UNUSED
, gfc_expr
*back
,
1133 f
->ts
.type
= BT_INTEGER
;
1135 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1137 f
->ts
.kind
= gfc_default_integer_kind
;
1139 if (back
&& back
->ts
.kind
!= gfc_default_integer_kind
)
1141 ts
.type
= BT_LOGICAL
;
1142 ts
.kind
= gfc_default_integer_kind
;
1143 ts
.u
.derived
= NULL
;
1145 gfc_convert_type (back
, &ts
, 2);
1148 f
->value
.function
.name
1149 = gfc_get_string ("__index_%d_i%d", str
->ts
.kind
, f
->ts
.kind
);
1154 gfc_resolve_int (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1156 f
->ts
.type
= BT_INTEGER
;
1157 f
->ts
.kind
= (kind
== NULL
)
1158 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.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_int2 (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_int8 (gfc_expr
*f
, gfc_expr
*a
)
1179 f
->ts
.type
= BT_INTEGER
;
1181 f
->value
.function
.name
1182 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1183 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1188 gfc_resolve_long (gfc_expr
*f
, gfc_expr
*a
)
1190 f
->ts
.type
= BT_INTEGER
;
1192 f
->value
.function
.name
1193 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1194 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1199 gfc_resolve_isatty (gfc_expr
*f
, gfc_expr
*u
)
1204 f
->ts
.type
= BT_LOGICAL
;
1205 f
->ts
.kind
= gfc_default_integer_kind
;
1206 if (u
->ts
.kind
!= gfc_c_int_kind
)
1208 ts
.type
= BT_INTEGER
;
1209 ts
.kind
= gfc_c_int_kind
;
1210 ts
.u
.derived
= NULL
;
1212 gfc_convert_type (u
, &ts
, 2);
1215 f
->value
.function
.name
= gfc_get_string (PREFIX ("isatty_l%d"), f
->ts
.kind
);
1220 gfc_resolve_ishft (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1223 f
->value
.function
.name
1224 = gfc_get_string ("__ishft_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1229 gfc_resolve_rshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1232 f
->value
.function
.name
1233 = gfc_get_string ("__rshift_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1238 gfc_resolve_lshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1241 f
->value
.function
.name
1242 = gfc_get_string ("__lshift_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1247 gfc_resolve_ishftc (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
1251 s_kind
= (size
== NULL
) ? gfc_default_integer_kind
: size
->ts
.kind
;
1254 f
->value
.function
.name
1255 = gfc_get_string ("__ishftc_%d_%d_%d", i
->ts
.kind
, shift
->ts
.kind
, s_kind
);
1260 gfc_resolve_kill (gfc_expr
*f
, gfc_expr
*p ATTRIBUTE_UNUSED
,
1261 gfc_expr
*s ATTRIBUTE_UNUSED
)
1263 f
->ts
.type
= BT_INTEGER
;
1264 f
->ts
.kind
= gfc_default_integer_kind
;
1265 f
->value
.function
.name
= gfc_get_string (PREFIX ("kill_i%d"), f
->ts
.kind
);
1270 gfc_resolve_lbound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
1272 resolve_bound (f
, array
, dim
, kind
, "__lbound", false);
1277 gfc_resolve_lcobound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
1279 resolve_bound (f
, array
, dim
, kind
, "__lcobound", true);
1284 gfc_resolve_len (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
1292 = gfc_get_string ("__len_%d_i%d", string
->ts
.kind
,
1293 gfc_default_integer_kind
);
1298 gfc_resolve_len_trim (gfc_expr
*f
, gfc_expr
*string
, gfc_expr
*kind
)
1300 f
->ts
.type
= BT_INTEGER
;
1302 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1304 f
->ts
.kind
= gfc_default_integer_kind
;
1305 f
->value
.function
.name
= gfc_get_string ("__len_trim%d", string
->ts
.kind
);
1310 gfc_resolve_lgamma (gfc_expr
*f
, gfc_expr
*x
)
1313 f
->value
.function
.name
1314 = gfc_get_string ("__lgamma_%d", x
->ts
.kind
);
1319 gfc_resolve_link (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
1320 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
1322 f
->ts
.type
= BT_INTEGER
;
1323 f
->ts
.kind
= gfc_default_integer_kind
;
1324 f
->value
.function
.name
= gfc_get_string (PREFIX ("link_i%d"), f
->ts
.kind
);
1329 gfc_resolve_loc (gfc_expr
*f
, gfc_expr
*x
)
1331 f
->ts
.type
= BT_INTEGER
;
1332 f
->ts
.kind
= gfc_index_integer_kind
;
1333 f
->value
.function
.name
= gfc_get_string ("__loc_%d", x
->ts
.kind
);
1338 gfc_resolve_log (gfc_expr
*f
, gfc_expr
*x
)
1341 f
->value
.function
.name
1342 = gfc_get_string ("__log_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1347 gfc_resolve_log10 (gfc_expr
*f
, gfc_expr
*x
)
1350 f
->value
.function
.name
1351 = gfc_get_string ("__log10_%c%d", gfc_type_letter (x
->ts
.type
),
1357 gfc_resolve_logical (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1359 f
->ts
.type
= BT_LOGICAL
;
1360 f
->ts
.kind
= (kind
== NULL
)
1361 ? gfc_default_logical_kind
: mpz_get_si (kind
->value
.integer
);
1364 f
->value
.function
.name
1365 = gfc_get_string ("__logical_%d_%c%d", f
->ts
.kind
,
1366 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1371 gfc_resolve_malloc (gfc_expr
*f
, gfc_expr
*size
)
1373 if (size
->ts
.kind
< gfc_index_integer_kind
)
1378 ts
.type
= BT_INTEGER
;
1379 ts
.kind
= gfc_index_integer_kind
;
1380 gfc_convert_type_warn (size
, &ts
, 2, 0);
1383 f
->ts
.type
= BT_INTEGER
;
1384 f
->ts
.kind
= gfc_index_integer_kind
;
1385 f
->value
.function
.name
= gfc_get_string (PREFIX ("malloc"));
1390 gfc_resolve_matmul (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b
)
1394 if (a
->ts
.type
== BT_LOGICAL
&& b
->ts
.type
== BT_LOGICAL
)
1396 f
->ts
.type
= BT_LOGICAL
;
1397 f
->ts
.kind
= gfc_default_logical_kind
;
1401 temp
.expr_type
= EXPR_OP
;
1402 gfc_clear_ts (&temp
.ts
);
1403 temp
.value
.op
.op
= INTRINSIC_NONE
;
1404 temp
.value
.op
.op1
= a
;
1405 temp
.value
.op
.op2
= b
;
1406 gfc_type_convert_binary (&temp
, 1);
1410 f
->rank
= (a
->rank
== 2 && b
->rank
== 2) ? 2 : 1;
1412 if (a
->rank
== 2 && b
->rank
== 2)
1414 if (a
->shape
&& b
->shape
)
1416 f
->shape
= gfc_get_shape (f
->rank
);
1417 mpz_init_set (f
->shape
[0], a
->shape
[0]);
1418 mpz_init_set (f
->shape
[1], b
->shape
[1]);
1421 else if (a
->rank
== 1)
1425 f
->shape
= gfc_get_shape (f
->rank
);
1426 mpz_init_set (f
->shape
[0], b
->shape
[1]);
1431 /* b->rank == 1 and a->rank == 2 here, all other cases have
1432 been caught in check.c. */
1435 f
->shape
= gfc_get_shape (f
->rank
);
1436 mpz_init_set (f
->shape
[0], a
->shape
[0]);
1440 f
->value
.function
.name
1441 = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f
->ts
.type
),
1447 gfc_resolve_minmax (const char *name
, gfc_expr
*f
, gfc_actual_arglist
*args
)
1449 gfc_actual_arglist
*a
;
1451 f
->ts
.type
= args
->expr
->ts
.type
;
1452 f
->ts
.kind
= args
->expr
->ts
.kind
;
1453 /* Find the largest type kind. */
1454 for (a
= args
->next
; a
; a
= a
->next
)
1456 if (a
->expr
->ts
.kind
> f
->ts
.kind
)
1457 f
->ts
.kind
= a
->expr
->ts
.kind
;
1460 /* Convert all parameters to the required kind. */
1461 for (a
= args
; a
; a
= a
->next
)
1463 if (a
->expr
->ts
.kind
!= f
->ts
.kind
)
1464 gfc_convert_type (a
->expr
, &f
->ts
, 2);
1467 f
->value
.function
.name
1468 = gfc_get_string (name
, gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
1473 gfc_resolve_max (gfc_expr
*f
, gfc_actual_arglist
*args
)
1475 gfc_resolve_minmax ("__max_%c%d", f
, args
);
1480 gfc_resolve_maxloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1486 f
->ts
.type
= BT_INTEGER
;
1487 f
->ts
.kind
= gfc_default_integer_kind
;
1492 f
->shape
= gfc_get_shape (1);
1493 mpz_init_set_si (f
->shape
[0], array
->rank
);
1497 f
->rank
= array
->rank
- 1;
1498 gfc_resolve_dim_arg (dim
);
1499 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1501 idim
= (int) mpz_get_si (dim
->value
.integer
);
1502 f
->shape
= gfc_get_shape (f
->rank
);
1503 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1505 if (i
== (idim
- 1))
1507 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1514 if (mask
->rank
== 0)
1519 resolve_mask_arg (mask
);
1524 f
->value
.function
.name
1525 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name
, dim
!= NULL
, f
->ts
.kind
,
1526 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1531 gfc_resolve_maxval (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1541 f
->rank
= array
->rank
- 1;
1542 gfc_resolve_dim_arg (dim
);
1544 if (f
->rank
&& array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1546 idim
= (int) mpz_get_si (dim
->value
.integer
);
1547 f
->shape
= gfc_get_shape (f
->rank
);
1548 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1550 if (i
== (idim
- 1))
1552 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1559 if (mask
->rank
== 0)
1564 resolve_mask_arg (mask
);
1569 f
->value
.function
.name
1570 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
1571 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1576 gfc_resolve_mclock (gfc_expr
*f
)
1578 f
->ts
.type
= BT_INTEGER
;
1580 f
->value
.function
.name
= PREFIX ("mclock");
1585 gfc_resolve_mclock8 (gfc_expr
*f
)
1587 f
->ts
.type
= BT_INTEGER
;
1589 f
->value
.function
.name
= PREFIX ("mclock8");
1594 gfc_resolve_merge (gfc_expr
*f
, gfc_expr
*tsource
,
1595 gfc_expr
*fsource ATTRIBUTE_UNUSED
,
1596 gfc_expr
*mask ATTRIBUTE_UNUSED
)
1598 if (tsource
->ts
.type
== BT_CHARACTER
&& tsource
->ref
)
1599 gfc_resolve_substring_charlen (tsource
);
1601 if (fsource
->ts
.type
== BT_CHARACTER
&& fsource
->ref
)
1602 gfc_resolve_substring_charlen (fsource
);
1604 if (tsource
->ts
.type
== BT_CHARACTER
)
1605 check_charlen_present (tsource
);
1607 f
->ts
= tsource
->ts
;
1608 f
->value
.function
.name
1609 = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource
->ts
.type
),
1615 gfc_resolve_min (gfc_expr
*f
, gfc_actual_arglist
*args
)
1617 gfc_resolve_minmax ("__min_%c%d", f
, args
);
1622 gfc_resolve_minloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1628 f
->ts
.type
= BT_INTEGER
;
1629 f
->ts
.kind
= gfc_default_integer_kind
;
1634 f
->shape
= gfc_get_shape (1);
1635 mpz_init_set_si (f
->shape
[0], array
->rank
);
1639 f
->rank
= array
->rank
- 1;
1640 gfc_resolve_dim_arg (dim
);
1641 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1643 idim
= (int) mpz_get_si (dim
->value
.integer
);
1644 f
->shape
= gfc_get_shape (f
->rank
);
1645 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1647 if (i
== (idim
- 1))
1649 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1656 if (mask
->rank
== 0)
1661 resolve_mask_arg (mask
);
1666 f
->value
.function
.name
1667 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name
, dim
!= NULL
, f
->ts
.kind
,
1668 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1673 gfc_resolve_minval (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1683 f
->rank
= array
->rank
- 1;
1684 gfc_resolve_dim_arg (dim
);
1686 if (f
->rank
&& array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1688 idim
= (int) mpz_get_si (dim
->value
.integer
);
1689 f
->shape
= gfc_get_shape (f
->rank
);
1690 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1692 if (i
== (idim
- 1))
1694 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1701 if (mask
->rank
== 0)
1706 resolve_mask_arg (mask
);
1711 f
->value
.function
.name
1712 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
1713 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1718 gfc_resolve_mod (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
1720 f
->ts
.type
= a
->ts
.type
;
1722 f
->ts
.kind
= gfc_kind_max (a
,p
);
1724 f
->ts
.kind
= a
->ts
.kind
;
1726 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
1728 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
1729 gfc_convert_type (p
, &a
->ts
, 2);
1731 gfc_convert_type (a
, &p
->ts
, 2);
1734 f
->value
.function
.name
1735 = gfc_get_string ("__mod_%c%d", gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
1740 gfc_resolve_modulo (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
1742 f
->ts
.type
= a
->ts
.type
;
1744 f
->ts
.kind
= gfc_kind_max (a
,p
);
1746 f
->ts
.kind
= a
->ts
.kind
;
1748 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
1750 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
1751 gfc_convert_type (p
, &a
->ts
, 2);
1753 gfc_convert_type (a
, &p
->ts
, 2);
1756 f
->value
.function
.name
1757 = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f
->ts
.type
),
1762 gfc_resolve_nearest (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
1764 if (p
->ts
.kind
!= a
->ts
.kind
)
1765 gfc_convert_type (p
, &a
->ts
, 2);
1768 f
->value
.function
.name
1769 = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a
->ts
.type
),
1774 gfc_resolve_nint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1776 f
->ts
.type
= BT_INTEGER
;
1777 f
->ts
.kind
= (kind
== NULL
)
1778 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
1779 f
->value
.function
.name
1780 = gfc_get_string ("__nint_%d_%d", f
->ts
.kind
, a
->ts
.kind
);
1785 gfc_resolve_not (gfc_expr
*f
, gfc_expr
*i
)
1788 f
->value
.function
.name
= gfc_get_string ("__not_%d", i
->ts
.kind
);
1793 gfc_resolve_or (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1795 f
->ts
.type
= i
->ts
.type
;
1796 f
->ts
.kind
= gfc_kind_max (i
, j
);
1798 if (i
->ts
.kind
!= j
->ts
.kind
)
1800 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1801 gfc_convert_type (j
, &i
->ts
, 2);
1803 gfc_convert_type (i
, &j
->ts
, 2);
1806 f
->value
.function
.name
1807 = gfc_get_string ("__or_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
1812 gfc_resolve_pack (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*mask
,
1813 gfc_expr
*vector ATTRIBUTE_UNUSED
)
1815 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
1816 gfc_resolve_substring_charlen (array
);
1821 resolve_mask_arg (mask
);
1823 if (mask
->rank
!= 0)
1825 if (array
->ts
.type
== BT_CHARACTER
)
1826 f
->value
.function
.name
1827 = array
->ts
.kind
== 1 ? PREFIX ("pack_char")
1829 (PREFIX ("pack_char%d"),
1832 f
->value
.function
.name
= PREFIX ("pack");
1836 if (array
->ts
.type
== BT_CHARACTER
)
1837 f
->value
.function
.name
1838 = array
->ts
.kind
== 1 ? PREFIX ("pack_s_char")
1840 (PREFIX ("pack_s_char%d"),
1843 f
->value
.function
.name
= PREFIX ("pack_s");
1849 gfc_resolve_product (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1858 f
->rank
= array
->rank
- 1;
1859 f
->shape
= gfc_copy_shape_excluding (array
->shape
, array
->rank
, dim
);
1860 gfc_resolve_dim_arg (dim
);
1865 if (mask
->rank
== 0)
1870 resolve_mask_arg (mask
);
1875 f
->value
.function
.name
1876 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
1877 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1882 gfc_resolve_real (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1884 f
->ts
.type
= BT_REAL
;
1887 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1889 f
->ts
.kind
= (a
->ts
.type
== BT_COMPLEX
)
1890 ? a
->ts
.kind
: gfc_default_real_kind
;
1892 f
->value
.function
.name
1893 = gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
1894 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1899 gfc_resolve_realpart (gfc_expr
*f
, gfc_expr
*a
)
1901 f
->ts
.type
= BT_REAL
;
1902 f
->ts
.kind
= a
->ts
.kind
;
1903 f
->value
.function
.name
1904 = gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
1905 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1910 gfc_resolve_rename (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
1911 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
1913 f
->ts
.type
= BT_INTEGER
;
1914 f
->ts
.kind
= gfc_default_integer_kind
;
1915 f
->value
.function
.name
= gfc_get_string (PREFIX ("rename_i%d"), f
->ts
.kind
);
1920 gfc_resolve_repeat (gfc_expr
*f
, gfc_expr
*string
,
1921 gfc_expr
*ncopies ATTRIBUTE_UNUSED
)
1923 f
->ts
.type
= BT_CHARACTER
;
1924 f
->ts
.kind
= string
->ts
.kind
;
1925 f
->value
.function
.name
= gfc_get_string ("__repeat_%d", string
->ts
.kind
);
1930 gfc_resolve_reshape (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*shape
,
1931 gfc_expr
*pad ATTRIBUTE_UNUSED
,
1932 gfc_expr
*order ATTRIBUTE_UNUSED
)
1938 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
1939 gfc_resolve_substring_charlen (source
);
1943 gfc_array_size (shape
, &rank
);
1944 f
->rank
= mpz_get_si (rank
);
1946 switch (source
->ts
.type
)
1953 kind
= source
->ts
.kind
;
1967 if (source
->ts
.type
== BT_COMPLEX
|| source
->ts
.type
== BT_REAL
)
1968 f
->value
.function
.name
1969 = gfc_get_string (PREFIX ("reshape_%c%d"),
1970 gfc_type_letter (source
->ts
.type
),
1972 else if (source
->ts
.type
== BT_CHARACTER
)
1973 f
->value
.function
.name
= gfc_get_string (PREFIX ("reshape_char%d"),
1976 f
->value
.function
.name
1977 = gfc_get_string (PREFIX ("reshape_%d"), source
->ts
.kind
);
1981 f
->value
.function
.name
= (source
->ts
.type
== BT_CHARACTER
1982 ? PREFIX ("reshape_char") : PREFIX ("reshape"));
1986 /* TODO: Make this work with a constant ORDER parameter. */
1987 if (shape
->expr_type
== EXPR_ARRAY
1988 && gfc_is_constant_expr (shape
)
1992 f
->shape
= gfc_get_shape (f
->rank
);
1993 c
= gfc_constructor_first (shape
->value
.constructor
);
1994 for (i
= 0; i
< f
->rank
; i
++)
1996 mpz_init_set (f
->shape
[i
], c
->expr
->value
.integer
);
1997 c
= gfc_constructor_next (c
);
2001 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
2002 so many runtime variations. */
2003 if (shape
->ts
.kind
!= gfc_index_integer_kind
)
2005 gfc_typespec ts
= shape
->ts
;
2006 ts
.kind
= gfc_index_integer_kind
;
2007 gfc_convert_type_warn (shape
, &ts
, 2, 0);
2009 if (order
&& order
->ts
.kind
!= gfc_index_integer_kind
)
2010 gfc_convert_type_warn (order
, &shape
->ts
, 2, 0);
2015 gfc_resolve_rrspacing (gfc_expr
*f
, gfc_expr
*x
)
2018 f
->value
.function
.name
= gfc_get_string ("__rrspacing_%d", x
->ts
.kind
);
2023 gfc_resolve_scale (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*i ATTRIBUTE_UNUSED
)
2026 f
->value
.function
.name
= gfc_get_string ("__scale_%d", x
->ts
.kind
);
2031 gfc_resolve_scan (gfc_expr
*f
, gfc_expr
*string
,
2032 gfc_expr
*set ATTRIBUTE_UNUSED
,
2033 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2035 f
->ts
.type
= BT_INTEGER
;
2037 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2039 f
->ts
.kind
= gfc_default_integer_kind
;
2040 f
->value
.function
.name
= gfc_get_string ("__scan_%d", string
->ts
.kind
);
2045 gfc_resolve_secnds (gfc_expr
*t1
, gfc_expr
*t0
)
2048 t1
->value
.function
.name
= gfc_get_string (PREFIX ("secnds"));
2053 gfc_resolve_set_exponent (gfc_expr
*f
, gfc_expr
*x
,
2054 gfc_expr
*i ATTRIBUTE_UNUSED
)
2057 f
->value
.function
.name
= gfc_get_string ("__set_exponent_%d", x
->ts
.kind
);
2062 gfc_resolve_shape (gfc_expr
*f
, gfc_expr
*array
)
2064 f
->ts
.type
= BT_INTEGER
;
2065 f
->ts
.kind
= gfc_default_integer_kind
;
2067 f
->shape
= gfc_get_shape (1);
2068 mpz_init_set_ui (f
->shape
[0], array
->rank
);
2069 f
->value
.function
.name
= gfc_get_string (PREFIX ("shape_%d"), f
->ts
.kind
);
2074 gfc_resolve_sign (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b ATTRIBUTE_UNUSED
)
2077 f
->value
.function
.name
2078 = gfc_get_string ("__sign_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2083 gfc_resolve_signal (gfc_expr
*f
, gfc_expr
*number
, gfc_expr
*handler
)
2085 f
->ts
.type
= BT_INTEGER
;
2086 f
->ts
.kind
= gfc_c_int_kind
;
2088 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2089 if (handler
->ts
.type
== BT_INTEGER
)
2091 if (handler
->ts
.kind
!= gfc_c_int_kind
)
2092 gfc_convert_type (handler
, &f
->ts
, 2);
2093 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func_int"));
2096 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func"));
2098 if (number
->ts
.kind
!= gfc_c_int_kind
)
2099 gfc_convert_type (number
, &f
->ts
, 2);
2104 gfc_resolve_sin (gfc_expr
*f
, gfc_expr
*x
)
2107 f
->value
.function
.name
2108 = gfc_get_string ("__sin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2113 gfc_resolve_sinh (gfc_expr
*f
, gfc_expr
*x
)
2116 f
->value
.function
.name
2117 = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2122 gfc_resolve_size (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2123 gfc_expr
*dim ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2125 f
->ts
.type
= BT_INTEGER
;
2127 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2129 f
->ts
.kind
= gfc_default_integer_kind
;
2134 gfc_resolve_spacing (gfc_expr
*f
, gfc_expr
*x
)
2137 f
->value
.function
.name
= gfc_get_string ("__spacing_%d", x
->ts
.kind
);
2142 gfc_resolve_spread (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*dim
,
2145 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
2146 gfc_resolve_substring_charlen (source
);
2148 if (source
->ts
.type
== BT_CHARACTER
)
2149 check_charlen_present (source
);
2152 f
->rank
= source
->rank
+ 1;
2153 if (source
->rank
== 0)
2155 if (source
->ts
.type
== BT_CHARACTER
)
2156 f
->value
.function
.name
2157 = source
->ts
.kind
== 1 ? PREFIX ("spread_char_scalar")
2159 (PREFIX ("spread_char%d_scalar"),
2162 f
->value
.function
.name
= PREFIX ("spread_scalar");
2166 if (source
->ts
.type
== BT_CHARACTER
)
2167 f
->value
.function
.name
2168 = source
->ts
.kind
== 1 ? PREFIX ("spread_char")
2170 (PREFIX ("spread_char%d"),
2173 f
->value
.function
.name
= PREFIX ("spread");
2176 if (dim
&& gfc_is_constant_expr (dim
)
2177 && ncopies
&& gfc_is_constant_expr (ncopies
) && source
->shape
[0])
2180 idim
= mpz_get_ui (dim
->value
.integer
);
2181 f
->shape
= gfc_get_shape (f
->rank
);
2182 for (i
= 0; i
< (idim
- 1); i
++)
2183 mpz_init_set (f
->shape
[i
], source
->shape
[i
]);
2185 mpz_init_set (f
->shape
[idim
- 1], ncopies
->value
.integer
);
2187 for (i
= idim
; i
< f
->rank
; i
++)
2188 mpz_init_set (f
->shape
[i
], source
->shape
[i
-1]);
2192 gfc_resolve_dim_arg (dim
);
2193 gfc_resolve_index (ncopies
, 1);
2198 gfc_resolve_sqrt (gfc_expr
*f
, gfc_expr
*x
)
2201 f
->value
.function
.name
2202 = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2206 /* Resolve the g77 compatibility function STAT AND FSTAT. */
2209 gfc_resolve_stat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2210 gfc_expr
*a ATTRIBUTE_UNUSED
)
2212 f
->ts
.type
= BT_INTEGER
;
2213 f
->ts
.kind
= gfc_default_integer_kind
;
2214 f
->value
.function
.name
= gfc_get_string (PREFIX ("stat_i%d"), f
->ts
.kind
);
2219 gfc_resolve_lstat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2220 gfc_expr
*a ATTRIBUTE_UNUSED
)
2222 f
->ts
.type
= BT_INTEGER
;
2223 f
->ts
.kind
= gfc_default_integer_kind
;
2224 f
->value
.function
.name
= gfc_get_string (PREFIX ("lstat_i%d"), f
->ts
.kind
);
2229 gfc_resolve_fstat (gfc_expr
*f
, gfc_expr
*n
, gfc_expr
*a ATTRIBUTE_UNUSED
)
2231 f
->ts
.type
= BT_INTEGER
;
2232 f
->ts
.kind
= gfc_default_integer_kind
;
2233 if (n
->ts
.kind
!= f
->ts
.kind
)
2234 gfc_convert_type (n
, &f
->ts
, 2);
2236 f
->value
.function
.name
= gfc_get_string (PREFIX ("fstat_i%d"), f
->ts
.kind
);
2241 gfc_resolve_fgetc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2246 f
->ts
.type
= BT_INTEGER
;
2247 f
->ts
.kind
= gfc_c_int_kind
;
2248 if (u
->ts
.kind
!= gfc_c_int_kind
)
2250 ts
.type
= BT_INTEGER
;
2251 ts
.kind
= gfc_c_int_kind
;
2252 ts
.u
.derived
= NULL
;
2254 gfc_convert_type (u
, &ts
, 2);
2257 f
->value
.function
.name
= gfc_get_string (PREFIX ("fgetc"));
2262 gfc_resolve_fget (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2264 f
->ts
.type
= BT_INTEGER
;
2265 f
->ts
.kind
= gfc_c_int_kind
;
2266 f
->value
.function
.name
= gfc_get_string (PREFIX ("fget"));
2271 gfc_resolve_fputc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2276 f
->ts
.type
= BT_INTEGER
;
2277 f
->ts
.kind
= gfc_c_int_kind
;
2278 if (u
->ts
.kind
!= gfc_c_int_kind
)
2280 ts
.type
= BT_INTEGER
;
2281 ts
.kind
= gfc_c_int_kind
;
2282 ts
.u
.derived
= NULL
;
2284 gfc_convert_type (u
, &ts
, 2);
2287 f
->value
.function
.name
= gfc_get_string (PREFIX ("fputc"));
2292 gfc_resolve_fput (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2294 f
->ts
.type
= BT_INTEGER
;
2295 f
->ts
.kind
= gfc_c_int_kind
;
2296 f
->value
.function
.name
= gfc_get_string (PREFIX ("fput"));
2301 gfc_resolve_ftell (gfc_expr
*f
, gfc_expr
*u
)
2306 f
->ts
.type
= BT_INTEGER
;
2307 f
->ts
.kind
= gfc_index_integer_kind
;
2308 if (u
->ts
.kind
!= gfc_c_int_kind
)
2310 ts
.type
= BT_INTEGER
;
2311 ts
.kind
= gfc_c_int_kind
;
2312 ts
.u
.derived
= NULL
;
2314 gfc_convert_type (u
, &ts
, 2);
2317 f
->value
.function
.name
= gfc_get_string (PREFIX ("ftell"));
2322 gfc_resolve_storage_size (gfc_expr
*f
, gfc_expr
*a ATTRIBUTE_UNUSED
,
2325 f
->ts
.type
= BT_INTEGER
;
2327 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2329 f
->ts
.kind
= gfc_default_integer_kind
;
2334 gfc_resolve_sum (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2342 if (mask
->rank
== 0)
2347 resolve_mask_arg (mask
);
2354 f
->rank
= array
->rank
- 1;
2355 f
->shape
= gfc_copy_shape_excluding (array
->shape
, array
->rank
, dim
);
2356 gfc_resolve_dim_arg (dim
);
2359 f
->value
.function
.name
2360 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
2361 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
2366 gfc_resolve_symlnk (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
2367 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
2369 f
->ts
.type
= BT_INTEGER
;
2370 f
->ts
.kind
= gfc_default_integer_kind
;
2371 f
->value
.function
.name
= gfc_get_string (PREFIX ("symlnk_i%d"), f
->ts
.kind
);
2375 /* Resolve the g77 compatibility function SYSTEM. */
2378 gfc_resolve_system (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
2380 f
->ts
.type
= BT_INTEGER
;
2382 f
->value
.function
.name
= gfc_get_string (PREFIX ("system"));
2387 gfc_resolve_tan (gfc_expr
*f
, gfc_expr
*x
)
2390 f
->value
.function
.name
2391 = gfc_get_string ("__tan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2396 gfc_resolve_tanh (gfc_expr
*f
, gfc_expr
*x
)
2399 f
->value
.function
.name
2400 = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2405 gfc_resolve_image_index (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2406 gfc_expr
*sub ATTRIBUTE_UNUSED
)
2408 static char this_image
[] = "__image_index";
2409 f
->ts
.kind
= gfc_default_integer_kind
;
2410 f
->value
.function
.name
= this_image
;
2415 gfc_resolve_this_image (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
)
2417 resolve_bound (f
, array
, dim
, NULL
, "__this_image", true);
2422 gfc_resolve_time (gfc_expr
*f
)
2424 f
->ts
.type
= BT_INTEGER
;
2426 f
->value
.function
.name
= gfc_get_string (PREFIX ("time_func"));
2431 gfc_resolve_time8 (gfc_expr
*f
)
2433 f
->ts
.type
= BT_INTEGER
;
2435 f
->value
.function
.name
= gfc_get_string (PREFIX ("time8_func"));
2440 gfc_resolve_transfer (gfc_expr
*f
, gfc_expr
*source ATTRIBUTE_UNUSED
,
2441 gfc_expr
*mold
, gfc_expr
*size
)
2443 /* TODO: Make this do something meaningful. */
2444 static char transfer0
[] = "__transfer0", transfer1
[] = "__transfer1";
2446 if (mold
->ts
.type
== BT_CHARACTER
2447 && !mold
->ts
.u
.cl
->length
2448 && gfc_is_constant_expr (mold
))
2451 if (mold
->expr_type
== EXPR_CONSTANT
)
2453 len
= mold
->value
.character
.length
;
2454 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
2459 gfc_constructor
*c
= gfc_constructor_first (mold
->value
.constructor
);
2460 len
= c
->expr
->value
.character
.length
;
2461 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
2468 if (size
== NULL
&& mold
->rank
== 0)
2471 f
->value
.function
.name
= transfer0
;
2476 f
->value
.function
.name
= transfer1
;
2477 if (size
&& gfc_is_constant_expr (size
))
2479 f
->shape
= gfc_get_shape (1);
2480 mpz_init_set (f
->shape
[0], size
->value
.integer
);
2487 gfc_resolve_transpose (gfc_expr
*f
, gfc_expr
*matrix
)
2490 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ref
)
2491 gfc_resolve_substring_charlen (matrix
);
2497 f
->shape
= gfc_get_shape (2);
2498 mpz_init_set (f
->shape
[0], matrix
->shape
[1]);
2499 mpz_init_set (f
->shape
[1], matrix
->shape
[0]);
2502 switch (matrix
->ts
.kind
)
2508 switch (matrix
->ts
.type
)
2512 f
->value
.function
.name
2513 = gfc_get_string (PREFIX ("transpose_%c%d"),
2514 gfc_type_letter (matrix
->ts
.type
),
2520 /* Use the integer routines for real and logical cases. This
2521 assumes they all have the same alignment requirements. */
2522 f
->value
.function
.name
2523 = gfc_get_string (PREFIX ("transpose_i%d"), matrix
->ts
.kind
);
2527 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ts
.kind
== 4)
2528 f
->value
.function
.name
= PREFIX ("transpose_char4");
2530 f
->value
.function
.name
= PREFIX ("transpose");
2536 f
->value
.function
.name
= (matrix
->ts
.type
== BT_CHARACTER
2537 ? PREFIX ("transpose_char")
2538 : PREFIX ("transpose"));
2545 gfc_resolve_trim (gfc_expr
*f
, gfc_expr
*string
)
2547 f
->ts
.type
= BT_CHARACTER
;
2548 f
->ts
.kind
= string
->ts
.kind
;
2549 f
->value
.function
.name
= gfc_get_string ("__trim_%d", string
->ts
.kind
);
2554 gfc_resolve_ubound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2556 resolve_bound (f
, array
, dim
, kind
, "__ubound", false);
2561 gfc_resolve_ucobound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2563 resolve_bound (f
, array
, dim
, kind
, "__ucobound", true);
2567 /* Resolve the g77 compatibility function UMASK. */
2570 gfc_resolve_umask (gfc_expr
*f
, gfc_expr
*n
)
2572 f
->ts
.type
= BT_INTEGER
;
2573 f
->ts
.kind
= n
->ts
.kind
;
2574 f
->value
.function
.name
= gfc_get_string (PREFIX ("umask_i%d"), n
->ts
.kind
);
2578 /* Resolve the g77 compatibility function UNLINK. */
2581 gfc_resolve_unlink (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
2583 f
->ts
.type
= BT_INTEGER
;
2585 f
->value
.function
.name
= gfc_get_string (PREFIX ("unlink"));
2590 gfc_resolve_ttynam (gfc_expr
*f
, gfc_expr
*unit
)
2595 f
->ts
.type
= BT_CHARACTER
;
2596 f
->ts
.kind
= gfc_default_character_kind
;
2598 if (unit
->ts
.kind
!= gfc_c_int_kind
)
2600 ts
.type
= BT_INTEGER
;
2601 ts
.kind
= gfc_c_int_kind
;
2602 ts
.u
.derived
= NULL
;
2604 gfc_convert_type (unit
, &ts
, 2);
2607 f
->value
.function
.name
= gfc_get_string (PREFIX ("ttynam"));
2612 gfc_resolve_unpack (gfc_expr
*f
, gfc_expr
*vector
, gfc_expr
*mask
,
2613 gfc_expr
*field ATTRIBUTE_UNUSED
)
2615 if (vector
->ts
.type
== BT_CHARACTER
&& vector
->ref
)
2616 gfc_resolve_substring_charlen (vector
);
2619 f
->rank
= mask
->rank
;
2620 resolve_mask_arg (mask
);
2622 if (vector
->ts
.type
== BT_CHARACTER
)
2624 if (vector
->ts
.kind
== 1)
2625 f
->value
.function
.name
2626 = gfc_get_string (PREFIX ("unpack%d_char"), field
->rank
> 0 ? 1 : 0);
2628 f
->value
.function
.name
2629 = gfc_get_string (PREFIX ("unpack%d_char%d"),
2630 field
->rank
> 0 ? 1 : 0, vector
->ts
.kind
);
2633 f
->value
.function
.name
2634 = gfc_get_string (PREFIX ("unpack%d"), field
->rank
> 0 ? 1 : 0);
2639 gfc_resolve_verify (gfc_expr
*f
, gfc_expr
*string
,
2640 gfc_expr
*set ATTRIBUTE_UNUSED
,
2641 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2643 f
->ts
.type
= BT_INTEGER
;
2645 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2647 f
->ts
.kind
= gfc_default_integer_kind
;
2648 f
->value
.function
.name
= gfc_get_string ("__verify_%d", string
->ts
.kind
);
2653 gfc_resolve_xor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
2655 f
->ts
.type
= i
->ts
.type
;
2656 f
->ts
.kind
= gfc_kind_max (i
, j
);
2658 if (i
->ts
.kind
!= j
->ts
.kind
)
2660 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
2661 gfc_convert_type (j
, &i
->ts
, 2);
2663 gfc_convert_type (i
, &j
->ts
, 2);
2666 f
->value
.function
.name
2667 = gfc_get_string ("__xor_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
2671 /* Intrinsic subroutine resolution. */
2674 gfc_resolve_alarm_sub (gfc_code
*c
)
2677 gfc_expr
*seconds
, *handler
;
2681 seconds
= c
->ext
.actual
->expr
;
2682 handler
= c
->ext
.actual
->next
->expr
;
2683 ts
.type
= BT_INTEGER
;
2684 ts
.kind
= gfc_c_int_kind
;
2686 /* handler can be either BT_INTEGER or BT_PROCEDURE.
2687 In all cases, the status argument is of default integer kind
2688 (enforced in check.c) so that the function suffix is fixed. */
2689 if (handler
->ts
.type
== BT_INTEGER
)
2691 if (handler
->ts
.kind
!= gfc_c_int_kind
)
2692 gfc_convert_type (handler
, &ts
, 2);
2693 name
= gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
2694 gfc_default_integer_kind
);
2697 name
= gfc_get_string (PREFIX ("alarm_sub_i%d"),
2698 gfc_default_integer_kind
);
2700 if (seconds
->ts
.kind
!= gfc_c_int_kind
)
2701 gfc_convert_type (seconds
, &ts
, 2);
2703 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2707 gfc_resolve_cpu_time (gfc_code
*c
)
2710 name
= gfc_get_string (PREFIX ("cpu_time_%d"), c
->ext
.actual
->expr
->ts
.kind
);
2711 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2715 /* Create a formal arglist based on an actual one and set the INTENTs given. */
2717 static gfc_formal_arglist
*
2718 create_formal_for_intents (gfc_actual_arglist
* actual
, const sym_intent
* ints
)
2720 gfc_formal_arglist
* head
;
2721 gfc_formal_arglist
* tail
;
2727 head
= tail
= gfc_get_formal_arglist ();
2728 for (i
= 0; actual
; actual
= actual
->next
, tail
= tail
->next
, ++i
)
2732 sym
= gfc_new_symbol ("dummyarg", NULL
);
2733 sym
->ts
= actual
->expr
->ts
;
2735 sym
->attr
.intent
= ints
[i
];
2739 tail
->next
= gfc_get_formal_arglist ();
2747 gfc_resolve_mvbits (gfc_code
*c
)
2749 static const sym_intent INTENTS
[] = {INTENT_IN
, INTENT_IN
, INTENT_IN
,
2750 INTENT_INOUT
, INTENT_IN
};
2756 /* FROMPOS, LEN and TOPOS are restricted to small values. As such,
2757 they will be converted so that they fit into a C int. */
2758 ts
.type
= BT_INTEGER
;
2759 ts
.kind
= gfc_c_int_kind
;
2760 if (c
->ext
.actual
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
2761 gfc_convert_type (c
->ext
.actual
->next
->expr
, &ts
, 2);
2762 if (c
->ext
.actual
->next
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
2763 gfc_convert_type (c
->ext
.actual
->next
->next
->expr
, &ts
, 2);
2764 if (c
->ext
.actual
->next
->next
->next
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
2765 gfc_convert_type (c
->ext
.actual
->next
->next
->next
->next
->expr
, &ts
, 2);
2767 /* TO and FROM are guaranteed to have the same kind parameter. */
2768 name
= gfc_get_string (PREFIX ("mvbits_i%d"),
2769 c
->ext
.actual
->expr
->ts
.kind
);
2770 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2771 /* Mark as elemental subroutine as this does not happen automatically. */
2772 c
->resolved_sym
->attr
.elemental
= 1;
2774 /* Create a dummy formal arglist so the INTENTs are known later for purpose
2775 of creating temporaries. */
2776 c
->resolved_sym
->formal
= create_formal_for_intents (c
->ext
.actual
, INTENTS
);
2781 gfc_resolve_random_number (gfc_code
*c
)
2786 kind
= c
->ext
.actual
->expr
->ts
.kind
;
2787 if (c
->ext
.actual
->expr
->rank
== 0)
2788 name
= gfc_get_string (PREFIX ("random_r%d"), kind
);
2790 name
= gfc_get_string (PREFIX ("arandom_r%d"), kind
);
2792 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2797 gfc_resolve_random_seed (gfc_code
*c
)
2801 name
= gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind
);
2802 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2807 gfc_resolve_rename_sub (gfc_code
*c
)
2812 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
2813 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
2815 kind
= gfc_default_integer_kind
;
2817 name
= gfc_get_string (PREFIX ("rename_i%d_sub"), kind
);
2818 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2823 gfc_resolve_kill_sub (gfc_code
*c
)
2828 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
2829 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
2831 kind
= gfc_default_integer_kind
;
2833 name
= gfc_get_string (PREFIX ("kill_i%d_sub"), kind
);
2834 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2839 gfc_resolve_link_sub (gfc_code
*c
)
2844 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
2845 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
2847 kind
= gfc_default_integer_kind
;
2849 name
= gfc_get_string (PREFIX ("link_i%d_sub"), kind
);
2850 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2855 gfc_resolve_symlnk_sub (gfc_code
*c
)
2860 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
2861 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
2863 kind
= gfc_default_integer_kind
;
2865 name
= gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind
);
2866 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2870 /* G77 compatibility subroutines dtime() and etime(). */
2873 gfc_resolve_dtime_sub (gfc_code
*c
)
2876 name
= gfc_get_string (PREFIX ("dtime_sub"));
2877 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2881 gfc_resolve_etime_sub (gfc_code
*c
)
2884 name
= gfc_get_string (PREFIX ("etime_sub"));
2885 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2889 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
2892 gfc_resolve_itime (gfc_code
*c
)
2895 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
2896 gfc_default_integer_kind
));
2900 gfc_resolve_idate (gfc_code
*c
)
2903 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
2904 gfc_default_integer_kind
));
2908 gfc_resolve_ltime (gfc_code
*c
)
2911 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
2912 gfc_default_integer_kind
));
2916 gfc_resolve_gmtime (gfc_code
*c
)
2919 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
2920 gfc_default_integer_kind
));
2924 /* G77 compatibility subroutine second(). */
2927 gfc_resolve_second_sub (gfc_code
*c
)
2930 name
= gfc_get_string (PREFIX ("second_sub"));
2931 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2936 gfc_resolve_sleep_sub (gfc_code
*c
)
2941 if (c
->ext
.actual
->expr
!= NULL
)
2942 kind
= c
->ext
.actual
->expr
->ts
.kind
;
2944 kind
= gfc_default_integer_kind
;
2946 name
= gfc_get_string (PREFIX ("sleep_i%d_sub"), kind
);
2947 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2951 /* G77 compatibility function srand(). */
2954 gfc_resolve_srand (gfc_code
*c
)
2957 name
= gfc_get_string (PREFIX ("srand"));
2958 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2962 /* Resolve the getarg intrinsic subroutine. */
2965 gfc_resolve_getarg (gfc_code
*c
)
2969 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_default_integer_kind
)
2974 ts
.type
= BT_INTEGER
;
2975 ts
.kind
= gfc_default_integer_kind
;
2977 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
2980 name
= gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind
);
2981 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2985 /* Resolve the getcwd intrinsic subroutine. */
2988 gfc_resolve_getcwd_sub (gfc_code
*c
)
2993 if (c
->ext
.actual
->next
->expr
!= NULL
)
2994 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
2996 kind
= gfc_default_integer_kind
;
2998 name
= gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind
);
2999 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3003 /* Resolve the get_command intrinsic subroutine. */
3006 gfc_resolve_get_command (gfc_code
*c
)
3010 kind
= gfc_default_integer_kind
;
3011 name
= gfc_get_string (PREFIX ("get_command_i%d"), kind
);
3012 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3016 /* Resolve the get_command_argument intrinsic subroutine. */
3019 gfc_resolve_get_command_argument (gfc_code
*c
)
3023 kind
= gfc_default_integer_kind
;
3024 name
= gfc_get_string (PREFIX ("get_command_argument_i%d"), kind
);
3025 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3029 /* Resolve the get_environment_variable intrinsic subroutine. */
3032 gfc_resolve_get_environment_variable (gfc_code
*code
)
3036 kind
= gfc_default_integer_kind
;
3037 name
= gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind
);
3038 code
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3043 gfc_resolve_signal_sub (gfc_code
*c
)
3046 gfc_expr
*number
, *handler
, *status
;
3050 number
= c
->ext
.actual
->expr
;
3051 handler
= c
->ext
.actual
->next
->expr
;
3052 status
= c
->ext
.actual
->next
->next
->expr
;
3053 ts
.type
= BT_INTEGER
;
3054 ts
.kind
= gfc_c_int_kind
;
3056 /* handler can be either BT_INTEGER or BT_PROCEDURE */
3057 if (handler
->ts
.type
== BT_INTEGER
)
3059 if (handler
->ts
.kind
!= gfc_c_int_kind
)
3060 gfc_convert_type (handler
, &ts
, 2);
3061 name
= gfc_get_string (PREFIX ("signal_sub_int"));
3064 name
= gfc_get_string (PREFIX ("signal_sub"));
3066 if (number
->ts
.kind
!= gfc_c_int_kind
)
3067 gfc_convert_type (number
, &ts
, 2);
3068 if (status
!= NULL
&& status
->ts
.kind
!= gfc_c_int_kind
)
3069 gfc_convert_type (status
, &ts
, 2);
3071 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3075 /* Resolve the SYSTEM intrinsic subroutine. */
3078 gfc_resolve_system_sub (gfc_code
*c
)
3081 name
= gfc_get_string (PREFIX ("system_sub"));
3082 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3086 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
3089 gfc_resolve_system_clock (gfc_code
*c
)
3094 if (c
->ext
.actual
->expr
!= NULL
)
3095 kind
= c
->ext
.actual
->expr
->ts
.kind
;
3096 else if (c
->ext
.actual
->next
->expr
!= NULL
)
3097 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3098 else if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3099 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3101 kind
= gfc_default_integer_kind
;
3103 name
= gfc_get_string (PREFIX ("system_clock_%d"), kind
);
3104 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3108 /* Resolve the EXIT intrinsic subroutine. */
3111 gfc_resolve_exit (gfc_code
*c
)
3118 /* The STATUS argument has to be of default kind. If it is not,
3120 ts
.type
= BT_INTEGER
;
3121 ts
.kind
= gfc_default_integer_kind
;
3122 n
= c
->ext
.actual
->expr
;
3123 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3124 gfc_convert_type (n
, &ts
, 2);
3126 name
= gfc_get_string (PREFIX ("exit_i%d"), ts
.kind
);
3127 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3131 /* Resolve the FLUSH intrinsic subroutine. */
3134 gfc_resolve_flush (gfc_code
*c
)
3141 ts
.type
= BT_INTEGER
;
3142 ts
.kind
= gfc_default_integer_kind
;
3143 n
= c
->ext
.actual
->expr
;
3144 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3145 gfc_convert_type (n
, &ts
, 2);
3147 name
= gfc_get_string (PREFIX ("flush_i%d"), ts
.kind
);
3148 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3153 gfc_resolve_free (gfc_code
*c
)
3159 ts
.type
= BT_INTEGER
;
3160 ts
.kind
= gfc_index_integer_kind
;
3161 n
= c
->ext
.actual
->expr
;
3162 if (n
->ts
.kind
!= ts
.kind
)
3163 gfc_convert_type (n
, &ts
, 2);
3165 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("free"));
3170 gfc_resolve_ctime_sub (gfc_code
*c
)
3175 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3176 if (c
->ext
.actual
->expr
->ts
.kind
!= 8)
3178 ts
.type
= BT_INTEGER
;
3180 ts
.u
.derived
= NULL
;
3182 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3185 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3190 gfc_resolve_fdate_sub (gfc_code
*c
)
3192 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3197 gfc_resolve_gerror (gfc_code
*c
)
3199 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3204 gfc_resolve_getlog (gfc_code
*c
)
3206 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3211 gfc_resolve_hostnm_sub (gfc_code
*c
)
3216 if (c
->ext
.actual
->next
->expr
!= NULL
)
3217 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3219 kind
= gfc_default_integer_kind
;
3221 name
= gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind
);
3222 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3227 gfc_resolve_perror (gfc_code
*c
)
3229 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3232 /* Resolve the STAT and FSTAT intrinsic subroutines. */
3235 gfc_resolve_stat_sub (gfc_code
*c
)
3238 name
= gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind
);
3239 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3244 gfc_resolve_lstat_sub (gfc_code
*c
)
3247 name
= gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind
);
3248 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3253 gfc_resolve_fstat_sub (gfc_code
*c
)
3259 u
= c
->ext
.actual
->expr
;
3260 ts
= &c
->ext
.actual
->next
->expr
->ts
;
3261 if (u
->ts
.kind
!= ts
->kind
)
3262 gfc_convert_type (u
, ts
, 2);
3263 name
= gfc_get_string (PREFIX ("fstat_i%d_sub"), ts
->kind
);
3264 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3269 gfc_resolve_fgetc_sub (gfc_code
*c
)
3276 u
= c
->ext
.actual
->expr
;
3277 st
= c
->ext
.actual
->next
->next
->expr
;
3279 if (u
->ts
.kind
!= gfc_c_int_kind
)
3281 ts
.type
= BT_INTEGER
;
3282 ts
.kind
= gfc_c_int_kind
;
3283 ts
.u
.derived
= NULL
;
3285 gfc_convert_type (u
, &ts
, 2);
3289 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), st
->ts
.kind
);
3291 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind
);
3293 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3298 gfc_resolve_fget_sub (gfc_code
*c
)
3303 st
= c
->ext
.actual
->next
->expr
;
3305 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), st
->ts
.kind
);
3307 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind
);
3309 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3314 gfc_resolve_fputc_sub (gfc_code
*c
)
3321 u
= c
->ext
.actual
->expr
;
3322 st
= c
->ext
.actual
->next
->next
->expr
;
3324 if (u
->ts
.kind
!= gfc_c_int_kind
)
3326 ts
.type
= BT_INTEGER
;
3327 ts
.kind
= gfc_c_int_kind
;
3328 ts
.u
.derived
= NULL
;
3330 gfc_convert_type (u
, &ts
, 2);
3334 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), st
->ts
.kind
);
3336 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind
);
3338 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3343 gfc_resolve_fput_sub (gfc_code
*c
)
3348 st
= c
->ext
.actual
->next
->expr
;
3350 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), st
->ts
.kind
);
3352 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind
);
3354 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3359 gfc_resolve_fseek_sub (gfc_code
*c
)
3367 unit
= c
->ext
.actual
->expr
;
3368 offset
= c
->ext
.actual
->next
->expr
;
3369 whence
= c
->ext
.actual
->next
->next
->expr
;
3371 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3373 ts
.type
= BT_INTEGER
;
3374 ts
.kind
= gfc_c_int_kind
;
3375 ts
.u
.derived
= NULL
;
3377 gfc_convert_type (unit
, &ts
, 2);
3380 if (offset
->ts
.kind
!= gfc_intio_kind
)
3382 ts
.type
= BT_INTEGER
;
3383 ts
.kind
= gfc_intio_kind
;
3384 ts
.u
.derived
= NULL
;
3386 gfc_convert_type (offset
, &ts
, 2);
3389 if (whence
->ts
.kind
!= gfc_c_int_kind
)
3391 ts
.type
= BT_INTEGER
;
3392 ts
.kind
= gfc_c_int_kind
;
3393 ts
.u
.derived
= NULL
;
3395 gfc_convert_type (whence
, &ts
, 2);
3398 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
3402 gfc_resolve_ftell_sub (gfc_code
*c
)
3410 unit
= c
->ext
.actual
->expr
;
3411 offset
= c
->ext
.actual
->next
->expr
;
3413 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3415 ts
.type
= BT_INTEGER
;
3416 ts
.kind
= gfc_c_int_kind
;
3417 ts
.u
.derived
= NULL
;
3419 gfc_convert_type (unit
, &ts
, 2);
3422 name
= gfc_get_string (PREFIX ("ftell_i%d_sub"), offset
->ts
.kind
);
3423 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3428 gfc_resolve_ttynam_sub (gfc_code
*c
)
3433 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
3435 ts
.type
= BT_INTEGER
;
3436 ts
.kind
= gfc_c_int_kind
;
3437 ts
.u
.derived
= NULL
;
3439 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3442 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
3446 /* Resolve the UMASK intrinsic subroutine. */
3449 gfc_resolve_umask_sub (gfc_code
*c
)
3454 if (c
->ext
.actual
->next
->expr
!= NULL
)
3455 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3457 kind
= gfc_default_integer_kind
;
3459 name
= gfc_get_string (PREFIX ("umask_i%d_sub"), kind
);
3460 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3463 /* Resolve the UNLINK intrinsic subroutine. */
3466 gfc_resolve_unlink_sub (gfc_code
*c
)
3471 if (c
->ext
.actual
->next
->expr
!= NULL
)
3472 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3474 kind
= gfc_default_integer_kind
;
3476 name
= gfc_get_string (PREFIX ("unlink_i%d_sub"), kind
);
3477 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);