1 /* Intrinsic function resolution.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught & Katherine Holcomb
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
23 /* Assign name and types to intrinsic procedures. For functions, the
24 first argument to a resolution function is an expression pointer to
25 the original function node and the rest are pointers to the
26 arguments of the function call. For subroutines, a pointer to the
27 code node is passed. The result type and library subroutine name
28 are generally set according to the function arguments. */
32 #include "coretypes.h"
35 #include "intrinsic.h"
37 /* Given printf-like arguments, return a stable version of the result string.
39 We already have a working, optimized string hashing table in the form of
40 the identifier table. Reusing this table is likely not to be wasted,
41 since if the function name makes it to the gimple output of the frontend,
42 we'll have to create the identifier anyway. */
45 gfc_get_string (const char *format
, ...)
51 va_start (ap
, format
);
52 vsnprintf (temp_name
, sizeof (temp_name
), format
, ap
);
54 temp_name
[sizeof (temp_name
) - 1] = 0;
56 ident
= get_identifier (temp_name
);
57 return IDENTIFIER_POINTER (ident
);
60 /* MERGE and SPREAD need to have source charlen's present for passing
61 to the result expression. */
63 check_charlen_present (gfc_expr
*source
)
65 if (source
->ts
.cl
== NULL
)
67 source
->ts
.cl
= gfc_get_charlen ();
68 source
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
69 gfc_current_ns
->cl_list
= source
->ts
.cl
;
72 if (source
->expr_type
== EXPR_CONSTANT
)
74 source
->ts
.cl
->length
= gfc_int_expr (source
->value
.character
.length
);
77 else if (source
->expr_type
== EXPR_ARRAY
)
79 source
->ts
.cl
->length
=
80 gfc_int_expr (source
->value
.constructor
->expr
->value
.character
.length
);
85 /* Helper function for resolving the "mask" argument. */
88 resolve_mask_arg (gfc_expr
*mask
)
96 /* For the scalar case, coerce the mask to kind=4 unconditionally
97 (because this is the only kind we have a library function
100 if (mask
->ts
.kind
!= 4)
102 ts
.type
= BT_LOGICAL
;
104 gfc_convert_type (mask
, &ts
, 2);
109 /* In the library, we access the mask with a GFC_LOGICAL_1
110 argument. No need to waste memory if we are about to create
111 a temporary array. */
112 if (mask
->expr_type
== EXPR_OP
)
114 ts
.type
= BT_LOGICAL
;
116 gfc_convert_type (mask
, &ts
, 2);
121 /********************** Resolution functions **********************/
125 gfc_resolve_abs (gfc_expr
*f
, gfc_expr
*a
)
128 if (f
->ts
.type
== BT_COMPLEX
)
129 f
->ts
.type
= BT_REAL
;
131 f
->value
.function
.name
132 = gfc_get_string ("__abs_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
137 gfc_resolve_access (gfc_expr
*f
, gfc_expr
*name ATTRIBUTE_UNUSED
,
138 gfc_expr
*mode ATTRIBUTE_UNUSED
)
140 f
->ts
.type
= BT_INTEGER
;
141 f
->ts
.kind
= gfc_c_int_kind
;
142 f
->value
.function
.name
= PREFIX ("access_func");
147 gfc_resolve_char_achar (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*kind
,
150 f
->ts
.type
= BT_CHARACTER
;
151 f
->ts
.kind
= (kind
== NULL
)
152 ? gfc_default_character_kind
: mpz_get_si (kind
->value
.integer
);
153 f
->ts
.cl
= gfc_get_charlen ();
154 f
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
155 gfc_current_ns
->cl_list
= f
->ts
.cl
;
156 f
->ts
.cl
->length
= gfc_int_expr (1);
158 f
->value
.function
.name
= gfc_get_string (name
, f
->ts
.kind
,
159 gfc_type_letter (x
->ts
.type
),
165 gfc_resolve_achar (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*kind
)
167 gfc_resolve_char_achar (f
, x
, kind
, "__achar_%d_%c%d");
172 gfc_resolve_acos (gfc_expr
*f
, gfc_expr
*x
)
175 f
->value
.function
.name
176 = gfc_get_string ("__acos_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
181 gfc_resolve_acosh (gfc_expr
*f
, gfc_expr
*x
)
184 f
->value
.function
.name
185 = gfc_get_string ("__acosh_%c%d", gfc_type_letter (x
->ts
.type
),
191 gfc_resolve_aimag (gfc_expr
*f
, gfc_expr
*x
)
193 f
->ts
.type
= BT_REAL
;
194 f
->ts
.kind
= x
->ts
.kind
;
195 f
->value
.function
.name
196 = gfc_get_string ("__aimag_%c%d", gfc_type_letter (x
->ts
.type
),
202 gfc_resolve_and (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
204 f
->ts
.type
= i
->ts
.type
;
205 f
->ts
.kind
= gfc_kind_max (i
, j
);
207 if (i
->ts
.kind
!= j
->ts
.kind
)
209 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
210 gfc_convert_type (j
, &i
->ts
, 2);
212 gfc_convert_type (i
, &j
->ts
, 2);
215 f
->value
.function
.name
216 = gfc_get_string ("__and_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
221 gfc_resolve_aint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
226 f
->ts
.type
= a
->ts
.type
;
227 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
229 if (a
->ts
.kind
!= f
->ts
.kind
)
231 ts
.type
= f
->ts
.type
;
232 ts
.kind
= f
->ts
.kind
;
233 gfc_convert_type (a
, &ts
, 2);
235 /* The resolved name is only used for specific intrinsics where
236 the return kind is the same as the arg kind. */
237 f
->value
.function
.name
238 = gfc_get_string ("__aint_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
243 gfc_resolve_dint (gfc_expr
*f
, gfc_expr
*a
)
245 gfc_resolve_aint (f
, a
, NULL
);
250 gfc_resolve_all (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
)
256 gfc_resolve_dim_arg (dim
);
257 f
->rank
= mask
->rank
- 1;
258 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
261 f
->value
.function
.name
262 = gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask
->ts
.type
),
268 gfc_resolve_anint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
273 f
->ts
.type
= a
->ts
.type
;
274 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
276 if (a
->ts
.kind
!= f
->ts
.kind
)
278 ts
.type
= f
->ts
.type
;
279 ts
.kind
= f
->ts
.kind
;
280 gfc_convert_type (a
, &ts
, 2);
283 /* The resolved name is only used for specific intrinsics where
284 the return kind is the same as the arg kind. */
285 f
->value
.function
.name
286 = gfc_get_string ("__anint_%c%d", gfc_type_letter (a
->ts
.type
),
292 gfc_resolve_dnint (gfc_expr
*f
, gfc_expr
*a
)
294 gfc_resolve_anint (f
, a
, NULL
);
299 gfc_resolve_any (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
)
305 gfc_resolve_dim_arg (dim
);
306 f
->rank
= mask
->rank
- 1;
307 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
310 f
->value
.function
.name
311 = gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask
->ts
.type
),
317 gfc_resolve_asin (gfc_expr
*f
, gfc_expr
*x
)
320 f
->value
.function
.name
321 = gfc_get_string ("__asin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
325 gfc_resolve_asinh (gfc_expr
*f
, gfc_expr
*x
)
328 f
->value
.function
.name
329 = gfc_get_string ("__asinh_%c%d", gfc_type_letter (x
->ts
.type
),
334 gfc_resolve_atan (gfc_expr
*f
, gfc_expr
*x
)
337 f
->value
.function
.name
338 = gfc_get_string ("__atan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
342 gfc_resolve_atanh (gfc_expr
*f
, gfc_expr
*x
)
345 f
->value
.function
.name
346 = gfc_get_string ("__atanh_%c%d", gfc_type_letter (x
->ts
.type
),
351 gfc_resolve_atan2 (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
354 f
->value
.function
.name
355 = gfc_get_string ("__atan2_%c%d", gfc_type_letter (x
->ts
.type
),
360 /* Resolve the BESYN and BESJN intrinsics. */
363 gfc_resolve_besn (gfc_expr
*f
, gfc_expr
*n
, gfc_expr
*x
)
369 if (n
->ts
.kind
!= gfc_c_int_kind
)
371 ts
.type
= BT_INTEGER
;
372 ts
.kind
= gfc_c_int_kind
;
373 gfc_convert_type (n
, &ts
, 2);
375 f
->value
.function
.name
= gfc_get_string ("<intrinsic>");
380 gfc_resolve_btest (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos
)
382 f
->ts
.type
= BT_LOGICAL
;
383 f
->ts
.kind
= gfc_default_logical_kind
;
384 f
->value
.function
.name
385 = gfc_get_string ("__btest_%d_%d", i
->ts
.kind
, pos
->ts
.kind
);
390 gfc_resolve_ceiling (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
392 f
->ts
.type
= BT_INTEGER
;
393 f
->ts
.kind
= (kind
== NULL
)
394 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
395 f
->value
.function
.name
396 = gfc_get_string ("__ceiling_%d_%c%d", f
->ts
.kind
,
397 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
402 gfc_resolve_char (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
404 gfc_resolve_char_achar (f
, a
, kind
, "__char_%d_%c%d");
409 gfc_resolve_chdir (gfc_expr
*f
, gfc_expr
*d ATTRIBUTE_UNUSED
)
411 f
->ts
.type
= BT_INTEGER
;
412 f
->ts
.kind
= gfc_default_integer_kind
;
413 f
->value
.function
.name
= gfc_get_string (PREFIX ("chdir_i%d"), f
->ts
.kind
);
418 gfc_resolve_chdir_sub (gfc_code
*c
)
423 if (c
->ext
.actual
->next
->expr
!= NULL
)
424 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
426 kind
= gfc_default_integer_kind
;
428 name
= gfc_get_string (PREFIX ("chdir_i%d_sub"), kind
);
429 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
434 gfc_resolve_chmod (gfc_expr
*f
, gfc_expr
*name ATTRIBUTE_UNUSED
,
435 gfc_expr
*mode ATTRIBUTE_UNUSED
)
437 f
->ts
.type
= BT_INTEGER
;
438 f
->ts
.kind
= gfc_c_int_kind
;
439 f
->value
.function
.name
= PREFIX ("chmod_func");
444 gfc_resolve_chmod_sub (gfc_code
*c
)
449 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
450 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
452 kind
= gfc_default_integer_kind
;
454 name
= gfc_get_string (PREFIX ("chmod_i%d_sub"), kind
);
455 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
460 gfc_resolve_cmplx (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*kind
)
462 f
->ts
.type
= BT_COMPLEX
;
463 f
->ts
.kind
= (kind
== NULL
)
464 ? gfc_default_real_kind
: mpz_get_si (kind
->value
.integer
);
467 f
->value
.function
.name
468 = gfc_get_string ("__cmplx0_%d_%c%d", f
->ts
.kind
,
469 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
471 f
->value
.function
.name
472 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f
->ts
.kind
,
473 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
,
474 gfc_type_letter (y
->ts
.type
), y
->ts
.kind
);
479 gfc_resolve_dcmplx (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
)
481 gfc_resolve_cmplx (f
, x
, y
, gfc_int_expr (gfc_default_double_kind
));
486 gfc_resolve_complex (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
)
490 if (x
->ts
.type
== BT_INTEGER
)
492 if (y
->ts
.type
== BT_INTEGER
)
493 kind
= gfc_default_real_kind
;
499 if (y
->ts
.type
== BT_REAL
)
500 kind
= (x
->ts
.kind
> y
->ts
.kind
) ? x
->ts
.kind
: y
->ts
.kind
;
505 f
->ts
.type
= BT_COMPLEX
;
507 f
->value
.function
.name
508 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f
->ts
.kind
,
509 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
,
510 gfc_type_letter (y
->ts
.type
), y
->ts
.kind
);
515 gfc_resolve_conjg (gfc_expr
*f
, gfc_expr
*x
)
518 f
->value
.function
.name
= gfc_get_string ("__conjg_%d", x
->ts
.kind
);
523 gfc_resolve_cos (gfc_expr
*f
, gfc_expr
*x
)
526 f
->value
.function
.name
527 = gfc_get_string ("__cos_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
532 gfc_resolve_cosh (gfc_expr
*f
, gfc_expr
*x
)
535 f
->value
.function
.name
536 = gfc_get_string ("__cosh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
541 gfc_resolve_count (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
543 f
->ts
.type
= BT_INTEGER
;
545 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
547 f
->ts
.kind
= gfc_default_integer_kind
;
551 f
->rank
= mask
->rank
- 1;
552 gfc_resolve_dim_arg (dim
);
553 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
556 resolve_mask_arg (mask
);
558 f
->value
.function
.name
559 = gfc_get_string (PREFIX ("count_%d_%c"), f
->ts
.kind
,
560 gfc_type_letter (mask
->ts
.type
));
565 gfc_resolve_cshift (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*shift
,
570 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
571 gfc_resolve_substring_charlen (array
);
574 f
->rank
= array
->rank
;
575 f
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
582 /* If dim kind is greater than default integer we need to use the larger. */
583 m
= gfc_default_integer_kind
;
585 m
= m
< dim
->ts
.kind
? dim
->ts
.kind
: m
;
587 /* Convert shift to at least m, so we don't need
588 kind=1 and kind=2 versions of the library functions. */
589 if (shift
->ts
.kind
< m
)
593 ts
.type
= BT_INTEGER
;
595 gfc_convert_type_warn (shift
, &ts
, 2, 0);
600 if (dim
->expr_type
!= EXPR_CONSTANT
&& dim
->symtree
!= NULL
601 && dim
->symtree
->n
.sym
->attr
.optional
)
603 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
604 dim
->representation
.length
= shift
->ts
.kind
;
608 gfc_resolve_dim_arg (dim
);
609 /* Convert dim to shift's kind to reduce variations. */
610 if (dim
->ts
.kind
!= shift
->ts
.kind
)
611 gfc_convert_type_warn (dim
, &shift
->ts
, 2, 0);
615 f
->value
.function
.name
616 = gfc_get_string (PREFIX ("cshift%d_%d%s"), n
, shift
->ts
.kind
,
617 array
->ts
.type
== BT_CHARACTER
? "_char" : "");
622 gfc_resolve_ctime (gfc_expr
*f
, gfc_expr
*time
)
627 f
->ts
.type
= BT_CHARACTER
;
628 f
->ts
.kind
= gfc_default_character_kind
;
630 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
631 if (time
->ts
.kind
!= 8)
633 ts
.type
= BT_INTEGER
;
637 gfc_convert_type (time
, &ts
, 2);
640 f
->value
.function
.name
= gfc_get_string (PREFIX ("ctime"));
645 gfc_resolve_dble (gfc_expr
*f
, gfc_expr
*a
)
647 f
->ts
.type
= BT_REAL
;
648 f
->ts
.kind
= gfc_default_double_kind
;
649 f
->value
.function
.name
650 = gfc_get_string ("__dble_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
655 gfc_resolve_dim (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
657 f
->ts
.type
= a
->ts
.type
;
659 f
->ts
.kind
= gfc_kind_max (a
,p
);
661 f
->ts
.kind
= a
->ts
.kind
;
663 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
665 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
666 gfc_convert_type (p
, &a
->ts
, 2);
668 gfc_convert_type (a
, &p
->ts
, 2);
671 f
->value
.function
.name
672 = gfc_get_string ("__dim_%c%d", gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
677 gfc_resolve_dot_product (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b
)
681 temp
.expr_type
= EXPR_OP
;
682 gfc_clear_ts (&temp
.ts
);
683 temp
.value
.op
.operator = INTRINSIC_NONE
;
684 temp
.value
.op
.op1
= a
;
685 temp
.value
.op
.op2
= b
;
686 gfc_type_convert_binary (&temp
);
688 f
->value
.function
.name
689 = gfc_get_string (PREFIX ("dot_product_%c%d"),
690 gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
695 gfc_resolve_dprod (gfc_expr
*f
, gfc_expr
*a ATTRIBUTE_UNUSED
,
696 gfc_expr
*b ATTRIBUTE_UNUSED
)
698 f
->ts
.kind
= gfc_default_double_kind
;
699 f
->ts
.type
= BT_REAL
;
700 f
->value
.function
.name
= gfc_get_string ("__dprod_r%d", f
->ts
.kind
);
705 gfc_resolve_eoshift (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*shift
,
706 gfc_expr
*boundary
, gfc_expr
*dim
)
710 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
711 gfc_resolve_substring_charlen (array
);
714 f
->rank
= array
->rank
;
715 f
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
720 if (boundary
&& boundary
->rank
> 0)
723 /* If dim kind is greater than default integer we need to use the larger. */
724 m
= gfc_default_integer_kind
;
726 m
= m
< dim
->ts
.kind
? dim
->ts
.kind
: m
;
728 /* Convert shift to at least m, so we don't need
729 kind=1 and kind=2 versions of the library functions. */
730 if (shift
->ts
.kind
< m
)
734 ts
.type
= BT_INTEGER
;
736 gfc_convert_type_warn (shift
, &ts
, 2, 0);
741 if (dim
->expr_type
!= EXPR_CONSTANT
&& dim
->symtree
!= NULL
742 && dim
->symtree
->n
.sym
->attr
.optional
)
744 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
745 dim
->representation
.length
= shift
->ts
.kind
;
749 gfc_resolve_dim_arg (dim
);
750 /* Convert dim to shift's kind to reduce variations. */
751 if (dim
->ts
.kind
!= shift
->ts
.kind
)
752 gfc_convert_type_warn (dim
, &shift
->ts
, 2, 0);
756 f
->value
.function
.name
757 = gfc_get_string (PREFIX ("eoshift%d_%d%s"), n
, shift
->ts
.kind
,
758 array
->ts
.type
== BT_CHARACTER
? "_char" : "");
763 gfc_resolve_exp (gfc_expr
*f
, gfc_expr
*x
)
766 f
->value
.function
.name
767 = gfc_get_string ("__exp_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
772 gfc_resolve_exponent (gfc_expr
*f
, gfc_expr
*x
)
774 f
->ts
.type
= BT_INTEGER
;
775 f
->ts
.kind
= gfc_default_integer_kind
;
776 f
->value
.function
.name
= gfc_get_string ("__exponent_%d", x
->ts
.kind
);
781 gfc_resolve_fdate (gfc_expr
*f
)
783 f
->ts
.type
= BT_CHARACTER
;
784 f
->ts
.kind
= gfc_default_character_kind
;
785 f
->value
.function
.name
= gfc_get_string (PREFIX ("fdate"));
790 gfc_resolve_floor (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
792 f
->ts
.type
= BT_INTEGER
;
793 f
->ts
.kind
= (kind
== NULL
)
794 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
795 f
->value
.function
.name
796 = gfc_get_string ("__floor%d_%c%d", f
->ts
.kind
,
797 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
802 gfc_resolve_fnum (gfc_expr
*f
, gfc_expr
*n
)
804 f
->ts
.type
= BT_INTEGER
;
805 f
->ts
.kind
= gfc_default_integer_kind
;
806 if (n
->ts
.kind
!= f
->ts
.kind
)
807 gfc_convert_type (n
, &f
->ts
, 2);
808 f
->value
.function
.name
= gfc_get_string (PREFIX ("fnum_i%d"), f
->ts
.kind
);
813 gfc_resolve_fraction (gfc_expr
*f
, gfc_expr
*x
)
816 f
->value
.function
.name
= gfc_get_string ("__fraction_%d", x
->ts
.kind
);
820 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
823 gfc_resolve_g77_math1 (gfc_expr
*f
, gfc_expr
*x
)
826 f
->value
.function
.name
= gfc_get_string ("<intrinsic>");
831 gfc_resolve_gamma (gfc_expr
*f
, gfc_expr
*x
)
834 f
->value
.function
.name
835 = gfc_get_string ("__gamma_%d", x
->ts
.kind
);
840 gfc_resolve_getcwd (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
842 f
->ts
.type
= BT_INTEGER
;
844 f
->value
.function
.name
= gfc_get_string (PREFIX ("getcwd"));
849 gfc_resolve_getgid (gfc_expr
*f
)
851 f
->ts
.type
= BT_INTEGER
;
853 f
->value
.function
.name
= gfc_get_string (PREFIX ("getgid"));
858 gfc_resolve_getpid (gfc_expr
*f
)
860 f
->ts
.type
= BT_INTEGER
;
862 f
->value
.function
.name
= gfc_get_string (PREFIX ("getpid"));
867 gfc_resolve_getuid (gfc_expr
*f
)
869 f
->ts
.type
= BT_INTEGER
;
871 f
->value
.function
.name
= gfc_get_string (PREFIX ("getuid"));
876 gfc_resolve_hostnm (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
878 f
->ts
.type
= BT_INTEGER
;
880 f
->value
.function
.name
= gfc_get_string (PREFIX ("hostnm"));
885 gfc_resolve_hypot (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
888 f
->value
.function
.name
= gfc_get_string ("__hypot_r%d", x
->ts
.kind
);
893 gfc_resolve_iand (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
895 /* If the kind of i and j are different, then g77 cross-promoted the
896 kinds to the largest value. The Fortran 95 standard requires the
898 if (i
->ts
.kind
!= j
->ts
.kind
)
900 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
901 gfc_convert_type (j
, &i
->ts
, 2);
903 gfc_convert_type (i
, &j
->ts
, 2);
907 f
->value
.function
.name
= gfc_get_string ("__iand_%d", i
->ts
.kind
);
912 gfc_resolve_ibclr (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
)
915 f
->value
.function
.name
= gfc_get_string ("__ibclr_%d", i
->ts
.kind
);
920 gfc_resolve_ibits (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
,
921 gfc_expr
*len ATTRIBUTE_UNUSED
)
924 f
->value
.function
.name
= gfc_get_string ("__ibits_%d", i
->ts
.kind
);
929 gfc_resolve_ibset (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
)
932 f
->value
.function
.name
= gfc_get_string ("__ibset_%d", i
->ts
.kind
);
937 gfc_resolve_iachar (gfc_expr
*f
, gfc_expr
*c
, gfc_expr
*kind
)
939 f
->ts
.type
= BT_INTEGER
;
941 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
943 f
->ts
.kind
= gfc_default_integer_kind
;
944 f
->value
.function
.name
= gfc_get_string ("__ichar_%d", c
->ts
.kind
);
949 gfc_resolve_ichar (gfc_expr
*f
, gfc_expr
*c
, gfc_expr
*kind
)
951 f
->ts
.type
= BT_INTEGER
;
953 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
955 f
->ts
.kind
= gfc_default_integer_kind
;
956 f
->value
.function
.name
= gfc_get_string ("__ichar_%d", c
->ts
.kind
);
961 gfc_resolve_idnint (gfc_expr
*f
, gfc_expr
*a
)
963 gfc_resolve_nint (f
, a
, NULL
);
968 gfc_resolve_ierrno (gfc_expr
*f
)
970 f
->ts
.type
= BT_INTEGER
;
971 f
->ts
.kind
= gfc_default_integer_kind
;
972 f
->value
.function
.name
= gfc_get_string (PREFIX ("ierrno_i%d"), f
->ts
.kind
);
977 gfc_resolve_ieor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
979 /* If the kind of i and j are different, then g77 cross-promoted the
980 kinds to the largest value. The Fortran 95 standard requires the
982 if (i
->ts
.kind
!= j
->ts
.kind
)
984 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
985 gfc_convert_type (j
, &i
->ts
, 2);
987 gfc_convert_type (i
, &j
->ts
, 2);
991 f
->value
.function
.name
= gfc_get_string ("__ieor_%d", i
->ts
.kind
);
996 gfc_resolve_ior (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
998 /* If the kind of i and j are different, then g77 cross-promoted the
999 kinds to the largest value. The Fortran 95 standard requires the
1001 if (i
->ts
.kind
!= j
->ts
.kind
)
1003 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1004 gfc_convert_type (j
, &i
->ts
, 2);
1006 gfc_convert_type (i
, &j
->ts
, 2);
1010 f
->value
.function
.name
= gfc_get_string ("__ior_%d", i
->ts
.kind
);
1015 gfc_resolve_index_func (gfc_expr
*f
, gfc_expr
*str
,
1016 gfc_expr
*sub_str ATTRIBUTE_UNUSED
, gfc_expr
*back
,
1022 f
->ts
.type
= BT_INTEGER
;
1024 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1026 f
->ts
.kind
= gfc_default_integer_kind
;
1028 if (back
&& back
->ts
.kind
!= gfc_default_integer_kind
)
1030 ts
.type
= BT_LOGICAL
;
1031 ts
.kind
= gfc_default_integer_kind
;
1034 gfc_convert_type (back
, &ts
, 2);
1037 f
->value
.function
.name
1038 = gfc_get_string ("__index_%d_i%d", str
->ts
.kind
, f
->ts
.kind
);
1043 gfc_resolve_int (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1045 f
->ts
.type
= BT_INTEGER
;
1046 f
->ts
.kind
= (kind
== NULL
)
1047 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
1048 f
->value
.function
.name
1049 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1050 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1055 gfc_resolve_int2 (gfc_expr
*f
, gfc_expr
*a
)
1057 f
->ts
.type
= BT_INTEGER
;
1059 f
->value
.function
.name
1060 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1061 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1066 gfc_resolve_int8 (gfc_expr
*f
, gfc_expr
*a
)
1068 f
->ts
.type
= BT_INTEGER
;
1070 f
->value
.function
.name
1071 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1072 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1077 gfc_resolve_long (gfc_expr
*f
, gfc_expr
*a
)
1079 f
->ts
.type
= BT_INTEGER
;
1081 f
->value
.function
.name
1082 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1083 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1088 gfc_resolve_isatty (gfc_expr
*f
, gfc_expr
*u
)
1093 f
->ts
.type
= BT_LOGICAL
;
1094 f
->ts
.kind
= gfc_default_integer_kind
;
1095 if (u
->ts
.kind
!= gfc_c_int_kind
)
1097 ts
.type
= BT_INTEGER
;
1098 ts
.kind
= gfc_c_int_kind
;
1101 gfc_convert_type (u
, &ts
, 2);
1104 f
->value
.function
.name
= gfc_get_string (PREFIX ("isatty_l%d"), f
->ts
.kind
);
1109 gfc_resolve_ishft (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1112 f
->value
.function
.name
1113 = gfc_get_string ("__ishft_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1118 gfc_resolve_rshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1121 f
->value
.function
.name
1122 = gfc_get_string ("__rshift_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1127 gfc_resolve_lshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1130 f
->value
.function
.name
1131 = gfc_get_string ("__lshift_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1136 gfc_resolve_ishftc (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
1140 s_kind
= (size
== NULL
) ? gfc_default_integer_kind
: size
->ts
.kind
;
1143 f
->value
.function
.name
1144 = gfc_get_string ("__ishftc_%d_%d_%d", i
->ts
.kind
, shift
->ts
.kind
, s_kind
);
1149 gfc_resolve_kill (gfc_expr
*f
, gfc_expr
*p ATTRIBUTE_UNUSED
,
1150 gfc_expr
*s ATTRIBUTE_UNUSED
)
1152 f
->ts
.type
= BT_INTEGER
;
1153 f
->ts
.kind
= gfc_default_integer_kind
;
1154 f
->value
.function
.name
= gfc_get_string (PREFIX ("kill_i%d"), f
->ts
.kind
);
1159 gfc_resolve_lbound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
1161 static char lbound
[] = "__lbound";
1163 f
->ts
.type
= BT_INTEGER
;
1165 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1167 f
->ts
.kind
= gfc_default_integer_kind
;
1172 f
->shape
= gfc_get_shape (1);
1173 mpz_init_set_ui (f
->shape
[0], array
->rank
);
1176 f
->value
.function
.name
= lbound
;
1181 gfc_resolve_len (gfc_expr
*f
, gfc_expr
*string
, gfc_expr
*kind
)
1183 f
->ts
.type
= BT_INTEGER
;
1185 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1187 f
->ts
.kind
= gfc_default_integer_kind
;
1188 f
->value
.function
.name
1189 = gfc_get_string ("__len_%d_i%d", string
->ts
.kind
,
1190 gfc_default_integer_kind
);
1195 gfc_resolve_len_trim (gfc_expr
*f
, gfc_expr
*string
, gfc_expr
*kind
)
1197 f
->ts
.type
= BT_INTEGER
;
1199 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1201 f
->ts
.kind
= gfc_default_integer_kind
;
1202 f
->value
.function
.name
= gfc_get_string ("__len_trim%d", string
->ts
.kind
);
1207 gfc_resolve_lgamma (gfc_expr
*f
, gfc_expr
*x
)
1210 f
->value
.function
.name
1211 = gfc_get_string ("__lgamma_%d", x
->ts
.kind
);
1216 gfc_resolve_link (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
1217 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
1219 f
->ts
.type
= BT_INTEGER
;
1220 f
->ts
.kind
= gfc_default_integer_kind
;
1221 f
->value
.function
.name
= gfc_get_string (PREFIX ("link_i%d"), f
->ts
.kind
);
1226 gfc_resolve_loc (gfc_expr
*f
, gfc_expr
*x
)
1228 f
->ts
.type
= BT_INTEGER
;
1229 f
->ts
.kind
= gfc_index_integer_kind
;
1230 f
->value
.function
.name
= gfc_get_string ("__loc_%d", x
->ts
.kind
);
1235 gfc_resolve_log (gfc_expr
*f
, gfc_expr
*x
)
1238 f
->value
.function
.name
1239 = gfc_get_string ("__log_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1244 gfc_resolve_log10 (gfc_expr
*f
, gfc_expr
*x
)
1247 f
->value
.function
.name
1248 = gfc_get_string ("__log10_%c%d", gfc_type_letter (x
->ts
.type
),
1254 gfc_resolve_logical (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1256 f
->ts
.type
= BT_LOGICAL
;
1257 f
->ts
.kind
= (kind
== NULL
)
1258 ? gfc_default_logical_kind
: mpz_get_si (kind
->value
.integer
);
1261 f
->value
.function
.name
1262 = gfc_get_string ("__logical_%d_%c%d", f
->ts
.kind
,
1263 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1268 gfc_resolve_malloc (gfc_expr
*f
, gfc_expr
*size
)
1270 if (size
->ts
.kind
< gfc_index_integer_kind
)
1275 ts
.type
= BT_INTEGER
;
1276 ts
.kind
= gfc_index_integer_kind
;
1277 gfc_convert_type_warn (size
, &ts
, 2, 0);
1280 f
->ts
.type
= BT_INTEGER
;
1281 f
->ts
.kind
= gfc_index_integer_kind
;
1282 f
->value
.function
.name
= gfc_get_string (PREFIX ("malloc"));
1287 gfc_resolve_matmul (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b
)
1291 if (a
->ts
.type
== BT_LOGICAL
&& b
->ts
.type
== BT_LOGICAL
)
1293 f
->ts
.type
= BT_LOGICAL
;
1294 f
->ts
.kind
= gfc_default_logical_kind
;
1298 temp
.expr_type
= EXPR_OP
;
1299 gfc_clear_ts (&temp
.ts
);
1300 temp
.value
.op
.operator = INTRINSIC_NONE
;
1301 temp
.value
.op
.op1
= a
;
1302 temp
.value
.op
.op2
= b
;
1303 gfc_type_convert_binary (&temp
);
1307 f
->rank
= (a
->rank
== 2 && b
->rank
== 2) ? 2 : 1;
1309 f
->value
.function
.name
1310 = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f
->ts
.type
),
1316 gfc_resolve_minmax (const char *name
, gfc_expr
*f
, gfc_actual_arglist
*args
)
1318 gfc_actual_arglist
*a
;
1320 f
->ts
.type
= args
->expr
->ts
.type
;
1321 f
->ts
.kind
= args
->expr
->ts
.kind
;
1322 /* Find the largest type kind. */
1323 for (a
= args
->next
; a
; a
= a
->next
)
1325 if (a
->expr
->ts
.kind
> f
->ts
.kind
)
1326 f
->ts
.kind
= a
->expr
->ts
.kind
;
1329 /* Convert all parameters to the required kind. */
1330 for (a
= args
; a
; a
= a
->next
)
1332 if (a
->expr
->ts
.kind
!= f
->ts
.kind
)
1333 gfc_convert_type (a
->expr
, &f
->ts
, 2);
1336 f
->value
.function
.name
1337 = gfc_get_string (name
, gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
1342 gfc_resolve_max (gfc_expr
*f
, gfc_actual_arglist
*args
)
1344 gfc_resolve_minmax ("__max_%c%d", f
, args
);
1349 gfc_resolve_maxloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1355 f
->ts
.type
= BT_INTEGER
;
1356 f
->ts
.kind
= gfc_default_integer_kind
;
1361 f
->shape
= gfc_get_shape (1);
1362 mpz_init_set_si (f
->shape
[0], array
->rank
);
1366 f
->rank
= array
->rank
- 1;
1367 gfc_resolve_dim_arg (dim
);
1368 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1370 idim
= (int) mpz_get_si (dim
->value
.integer
);
1371 f
->shape
= gfc_get_shape (f
->rank
);
1372 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1374 if (i
== (idim
- 1))
1376 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1383 if (mask
->rank
== 0)
1388 resolve_mask_arg (mask
);
1393 f
->value
.function
.name
1394 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name
, dim
!= NULL
, f
->ts
.kind
,
1395 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1400 gfc_resolve_maxval (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1410 f
->rank
= array
->rank
- 1;
1411 gfc_resolve_dim_arg (dim
);
1413 if (f
->rank
&& array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1415 idim
= (int) mpz_get_si (dim
->value
.integer
);
1416 f
->shape
= gfc_get_shape (f
->rank
);
1417 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1419 if (i
== (idim
- 1))
1421 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1428 if (mask
->rank
== 0)
1433 resolve_mask_arg (mask
);
1438 f
->value
.function
.name
1439 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
1440 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1445 gfc_resolve_mclock (gfc_expr
*f
)
1447 f
->ts
.type
= BT_INTEGER
;
1449 f
->value
.function
.name
= PREFIX ("mclock");
1454 gfc_resolve_mclock8 (gfc_expr
*f
)
1456 f
->ts
.type
= BT_INTEGER
;
1458 f
->value
.function
.name
= PREFIX ("mclock8");
1463 gfc_resolve_merge (gfc_expr
*f
, gfc_expr
*tsource
,
1464 gfc_expr
*fsource ATTRIBUTE_UNUSED
,
1465 gfc_expr
*mask ATTRIBUTE_UNUSED
)
1467 if (tsource
->ts
.type
== BT_CHARACTER
&& tsource
->ref
)
1468 gfc_resolve_substring_charlen (tsource
);
1470 if (fsource
->ts
.type
== BT_CHARACTER
&& fsource
->ref
)
1471 gfc_resolve_substring_charlen (fsource
);
1473 if (tsource
->ts
.type
== BT_CHARACTER
)
1474 check_charlen_present (tsource
);
1476 f
->ts
= tsource
->ts
;
1477 f
->value
.function
.name
1478 = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource
->ts
.type
),
1484 gfc_resolve_min (gfc_expr
*f
, gfc_actual_arglist
*args
)
1486 gfc_resolve_minmax ("__min_%c%d", f
, args
);
1491 gfc_resolve_minloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1497 f
->ts
.type
= BT_INTEGER
;
1498 f
->ts
.kind
= gfc_default_integer_kind
;
1503 f
->shape
= gfc_get_shape (1);
1504 mpz_init_set_si (f
->shape
[0], array
->rank
);
1508 f
->rank
= array
->rank
- 1;
1509 gfc_resolve_dim_arg (dim
);
1510 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1512 idim
= (int) mpz_get_si (dim
->value
.integer
);
1513 f
->shape
= gfc_get_shape (f
->rank
);
1514 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1516 if (i
== (idim
- 1))
1518 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1525 if (mask
->rank
== 0)
1530 resolve_mask_arg (mask
);
1535 f
->value
.function
.name
1536 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name
, dim
!= NULL
, f
->ts
.kind
,
1537 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1542 gfc_resolve_minval (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1552 f
->rank
= array
->rank
- 1;
1553 gfc_resolve_dim_arg (dim
);
1555 if (f
->rank
&& array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1557 idim
= (int) mpz_get_si (dim
->value
.integer
);
1558 f
->shape
= gfc_get_shape (f
->rank
);
1559 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1561 if (i
== (idim
- 1))
1563 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1570 if (mask
->rank
== 0)
1575 resolve_mask_arg (mask
);
1580 f
->value
.function
.name
1581 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
1582 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1587 gfc_resolve_mod (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
1589 f
->ts
.type
= a
->ts
.type
;
1591 f
->ts
.kind
= gfc_kind_max (a
,p
);
1593 f
->ts
.kind
= a
->ts
.kind
;
1595 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
1597 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
1598 gfc_convert_type (p
, &a
->ts
, 2);
1600 gfc_convert_type (a
, &p
->ts
, 2);
1603 f
->value
.function
.name
1604 = gfc_get_string ("__mod_%c%d", gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
1609 gfc_resolve_modulo (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
1611 f
->ts
.type
= a
->ts
.type
;
1613 f
->ts
.kind
= gfc_kind_max (a
,p
);
1615 f
->ts
.kind
= a
->ts
.kind
;
1617 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
1619 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
1620 gfc_convert_type (p
, &a
->ts
, 2);
1622 gfc_convert_type (a
, &p
->ts
, 2);
1625 f
->value
.function
.name
1626 = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f
->ts
.type
),
1631 gfc_resolve_nearest (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
1633 if (p
->ts
.kind
!= a
->ts
.kind
)
1634 gfc_convert_type (p
, &a
->ts
, 2);
1637 f
->value
.function
.name
1638 = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a
->ts
.type
),
1643 gfc_resolve_nint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1645 f
->ts
.type
= BT_INTEGER
;
1646 f
->ts
.kind
= (kind
== NULL
)
1647 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
1648 f
->value
.function
.name
1649 = gfc_get_string ("__nint_%d_%d", f
->ts
.kind
, a
->ts
.kind
);
1654 gfc_resolve_not (gfc_expr
*f
, gfc_expr
*i
)
1657 f
->value
.function
.name
= gfc_get_string ("__not_%d", i
->ts
.kind
);
1662 gfc_resolve_or (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1664 f
->ts
.type
= i
->ts
.type
;
1665 f
->ts
.kind
= gfc_kind_max (i
, j
);
1667 if (i
->ts
.kind
!= j
->ts
.kind
)
1669 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1670 gfc_convert_type (j
, &i
->ts
, 2);
1672 gfc_convert_type (i
, &j
->ts
, 2);
1675 f
->value
.function
.name
1676 = gfc_get_string ("__or_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
1681 gfc_resolve_pack (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*mask
,
1682 gfc_expr
*vector ATTRIBUTE_UNUSED
)
1684 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
1685 gfc_resolve_substring_charlen (array
);
1690 resolve_mask_arg (mask
);
1692 if (mask
->rank
!= 0)
1693 f
->value
.function
.name
= (array
->ts
.type
== BT_CHARACTER
1694 ? PREFIX ("pack_char") : PREFIX ("pack"));
1696 f
->value
.function
.name
= (array
->ts
.type
== BT_CHARACTER
1697 ? PREFIX ("pack_s_char") : PREFIX ("pack_s"));
1702 gfc_resolve_product (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1711 f
->rank
= array
->rank
- 1;
1712 gfc_resolve_dim_arg (dim
);
1717 if (mask
->rank
== 0)
1722 resolve_mask_arg (mask
);
1727 f
->value
.function
.name
1728 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
1729 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1734 gfc_resolve_real (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1736 f
->ts
.type
= BT_REAL
;
1739 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1741 f
->ts
.kind
= (a
->ts
.type
== BT_COMPLEX
)
1742 ? a
->ts
.kind
: gfc_default_real_kind
;
1744 f
->value
.function
.name
1745 = gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
1746 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1751 gfc_resolve_realpart (gfc_expr
*f
, gfc_expr
*a
)
1753 f
->ts
.type
= BT_REAL
;
1754 f
->ts
.kind
= a
->ts
.kind
;
1755 f
->value
.function
.name
1756 = gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
1757 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1762 gfc_resolve_rename (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
1763 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
1765 f
->ts
.type
= BT_INTEGER
;
1766 f
->ts
.kind
= gfc_default_integer_kind
;
1767 f
->value
.function
.name
= gfc_get_string (PREFIX ("rename_i%d"), f
->ts
.kind
);
1772 gfc_resolve_repeat (gfc_expr
*f
, gfc_expr
*string
,
1773 gfc_expr
*ncopies ATTRIBUTE_UNUSED
)
1775 f
->ts
.type
= BT_CHARACTER
;
1776 f
->ts
.kind
= string
->ts
.kind
;
1777 f
->value
.function
.name
= gfc_get_string ("__repeat_%d", string
->ts
.kind
);
1782 gfc_resolve_reshape (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*shape
,
1783 gfc_expr
*pad ATTRIBUTE_UNUSED
,
1784 gfc_expr
*order ATTRIBUTE_UNUSED
)
1790 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
1791 gfc_resolve_substring_charlen (source
);
1795 gfc_array_size (shape
, &rank
);
1796 f
->rank
= mpz_get_si (rank
);
1798 switch (source
->ts
.type
)
1804 kind
= source
->ts
.kind
;
1818 if (source
->ts
.type
== BT_COMPLEX
|| source
->ts
.type
== BT_REAL
)
1819 f
->value
.function
.name
1820 = gfc_get_string (PREFIX ("reshape_%c%d"),
1821 gfc_type_letter (source
->ts
.type
),
1824 f
->value
.function
.name
1825 = gfc_get_string (PREFIX ("reshape_%d"), source
->ts
.kind
);
1830 f
->value
.function
.name
= (source
->ts
.type
== BT_CHARACTER
1831 ? PREFIX ("reshape_char") : PREFIX ("reshape"));
1835 /* TODO: Make this work with a constant ORDER parameter. */
1836 if (shape
->expr_type
== EXPR_ARRAY
1837 && gfc_is_constant_expr (shape
)
1841 f
->shape
= gfc_get_shape (f
->rank
);
1842 c
= shape
->value
.constructor
;
1843 for (i
= 0; i
< f
->rank
; i
++)
1845 mpz_init_set (f
->shape
[i
], c
->expr
->value
.integer
);
1850 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
1851 so many runtime variations. */
1852 if (shape
->ts
.kind
!= gfc_index_integer_kind
)
1854 gfc_typespec ts
= shape
->ts
;
1855 ts
.kind
= gfc_index_integer_kind
;
1856 gfc_convert_type_warn (shape
, &ts
, 2, 0);
1858 if (order
&& order
->ts
.kind
!= gfc_index_integer_kind
)
1859 gfc_convert_type_warn (order
, &shape
->ts
, 2, 0);
1864 gfc_resolve_rrspacing (gfc_expr
*f
, gfc_expr
*x
)
1867 f
->value
.function
.name
= gfc_get_string ("__rrspacing_%d", x
->ts
.kind
);
1872 gfc_resolve_scale (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*i ATTRIBUTE_UNUSED
)
1875 f
->value
.function
.name
= gfc_get_string ("__scale_%d", x
->ts
.kind
);
1880 gfc_resolve_scan (gfc_expr
*f
, gfc_expr
*string
,
1881 gfc_expr
*set ATTRIBUTE_UNUSED
,
1882 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
1884 f
->ts
.type
= BT_INTEGER
;
1886 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1888 f
->ts
.kind
= gfc_default_integer_kind
;
1889 f
->value
.function
.name
= gfc_get_string ("__scan_%d", string
->ts
.kind
);
1894 gfc_resolve_secnds (gfc_expr
*t1
, gfc_expr
*t0
)
1897 t1
->value
.function
.name
= gfc_get_string (PREFIX ("secnds"));
1902 gfc_resolve_set_exponent (gfc_expr
*f
, gfc_expr
*x
,
1903 gfc_expr
*i ATTRIBUTE_UNUSED
)
1906 f
->value
.function
.name
= gfc_get_string ("__set_exponent_%d", x
->ts
.kind
);
1911 gfc_resolve_shape (gfc_expr
*f
, gfc_expr
*array
)
1913 f
->ts
.type
= BT_INTEGER
;
1914 f
->ts
.kind
= gfc_default_integer_kind
;
1916 f
->shape
= gfc_get_shape (1);
1917 mpz_init_set_ui (f
->shape
[0], array
->rank
);
1918 f
->value
.function
.name
= gfc_get_string (PREFIX ("shape_%d"), f
->ts
.kind
);
1923 gfc_resolve_sign (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b ATTRIBUTE_UNUSED
)
1926 f
->value
.function
.name
1927 = gfc_get_string ("__sign_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1932 gfc_resolve_signal (gfc_expr
*f
, gfc_expr
*number
, gfc_expr
*handler
)
1934 f
->ts
.type
= BT_INTEGER
;
1935 f
->ts
.kind
= gfc_c_int_kind
;
1937 /* handler can be either BT_INTEGER or BT_PROCEDURE */
1938 if (handler
->ts
.type
== BT_INTEGER
)
1940 if (handler
->ts
.kind
!= gfc_c_int_kind
)
1941 gfc_convert_type (handler
, &f
->ts
, 2);
1942 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func_int"));
1945 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func"));
1947 if (number
->ts
.kind
!= gfc_c_int_kind
)
1948 gfc_convert_type (number
, &f
->ts
, 2);
1953 gfc_resolve_sin (gfc_expr
*f
, gfc_expr
*x
)
1956 f
->value
.function
.name
1957 = gfc_get_string ("__sin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1962 gfc_resolve_sinh (gfc_expr
*f
, gfc_expr
*x
)
1965 f
->value
.function
.name
1966 = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1971 gfc_resolve_size (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
1972 gfc_expr
*dim ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
1974 f
->ts
.type
= BT_INTEGER
;
1976 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1978 f
->ts
.kind
= gfc_default_integer_kind
;
1983 gfc_resolve_spacing (gfc_expr
*f
, gfc_expr
*x
)
1986 f
->value
.function
.name
= gfc_get_string ("__spacing_%d", x
->ts
.kind
);
1991 gfc_resolve_spread (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*dim
,
1994 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
1995 gfc_resolve_substring_charlen (source
);
1997 if (source
->ts
.type
== BT_CHARACTER
)
1998 check_charlen_present (source
);
2001 f
->rank
= source
->rank
+ 1;
2002 if (source
->rank
== 0)
2003 f
->value
.function
.name
= (source
->ts
.type
== BT_CHARACTER
2004 ? PREFIX ("spread_char_scalar")
2005 : PREFIX ("spread_scalar"));
2007 f
->value
.function
.name
= (source
->ts
.type
== BT_CHARACTER
2008 ? PREFIX ("spread_char")
2009 : PREFIX ("spread"));
2011 if (dim
&& gfc_is_constant_expr (dim
)
2012 && ncopies
&& gfc_is_constant_expr (ncopies
) && source
->shape
[0])
2015 idim
= mpz_get_ui (dim
->value
.integer
);
2016 f
->shape
= gfc_get_shape (f
->rank
);
2017 for (i
= 0; i
< (idim
- 1); i
++)
2018 mpz_init_set (f
->shape
[i
], source
->shape
[i
]);
2020 mpz_init_set (f
->shape
[idim
- 1], ncopies
->value
.integer
);
2022 for (i
= idim
; i
< f
->rank
; i
++)
2023 mpz_init_set (f
->shape
[i
], source
->shape
[i
-1]);
2027 gfc_resolve_dim_arg (dim
);
2028 gfc_resolve_index (ncopies
, 1);
2033 gfc_resolve_sqrt (gfc_expr
*f
, gfc_expr
*x
)
2036 f
->value
.function
.name
2037 = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2041 /* Resolve the g77 compatibility function STAT AND FSTAT. */
2044 gfc_resolve_stat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2045 gfc_expr
*a ATTRIBUTE_UNUSED
)
2047 f
->ts
.type
= BT_INTEGER
;
2048 f
->ts
.kind
= gfc_default_integer_kind
;
2049 f
->value
.function
.name
= gfc_get_string (PREFIX ("stat_i%d"), f
->ts
.kind
);
2054 gfc_resolve_lstat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2055 gfc_expr
*a ATTRIBUTE_UNUSED
)
2057 f
->ts
.type
= BT_INTEGER
;
2058 f
->ts
.kind
= gfc_default_integer_kind
;
2059 f
->value
.function
.name
= gfc_get_string (PREFIX ("lstat_i%d"), f
->ts
.kind
);
2064 gfc_resolve_fstat (gfc_expr
*f
, gfc_expr
*n
, gfc_expr
*a ATTRIBUTE_UNUSED
)
2066 f
->ts
.type
= BT_INTEGER
;
2067 f
->ts
.kind
= gfc_default_integer_kind
;
2068 if (n
->ts
.kind
!= f
->ts
.kind
)
2069 gfc_convert_type (n
, &f
->ts
, 2);
2071 f
->value
.function
.name
= gfc_get_string (PREFIX ("fstat_i%d"), f
->ts
.kind
);
2076 gfc_resolve_fgetc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2081 f
->ts
.type
= BT_INTEGER
;
2082 f
->ts
.kind
= gfc_c_int_kind
;
2083 if (u
->ts
.kind
!= gfc_c_int_kind
)
2085 ts
.type
= BT_INTEGER
;
2086 ts
.kind
= gfc_c_int_kind
;
2089 gfc_convert_type (u
, &ts
, 2);
2092 f
->value
.function
.name
= gfc_get_string (PREFIX ("fgetc"));
2097 gfc_resolve_fget (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2099 f
->ts
.type
= BT_INTEGER
;
2100 f
->ts
.kind
= gfc_c_int_kind
;
2101 f
->value
.function
.name
= gfc_get_string (PREFIX ("fget"));
2106 gfc_resolve_fputc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2111 f
->ts
.type
= BT_INTEGER
;
2112 f
->ts
.kind
= gfc_c_int_kind
;
2113 if (u
->ts
.kind
!= gfc_c_int_kind
)
2115 ts
.type
= BT_INTEGER
;
2116 ts
.kind
= gfc_c_int_kind
;
2119 gfc_convert_type (u
, &ts
, 2);
2122 f
->value
.function
.name
= gfc_get_string (PREFIX ("fputc"));
2127 gfc_resolve_fput (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2129 f
->ts
.type
= BT_INTEGER
;
2130 f
->ts
.kind
= gfc_c_int_kind
;
2131 f
->value
.function
.name
= gfc_get_string (PREFIX ("fput"));
2136 gfc_resolve_ftell (gfc_expr
*f
, gfc_expr
*u
)
2141 f
->ts
.type
= BT_INTEGER
;
2142 f
->ts
.kind
= gfc_index_integer_kind
;
2143 if (u
->ts
.kind
!= gfc_c_int_kind
)
2145 ts
.type
= BT_INTEGER
;
2146 ts
.kind
= gfc_c_int_kind
;
2149 gfc_convert_type (u
, &ts
, 2);
2152 f
->value
.function
.name
= gfc_get_string (PREFIX ("ftell"));
2157 gfc_resolve_sum (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2165 if (mask
->rank
== 0)
2170 resolve_mask_arg (mask
);
2177 f
->rank
= array
->rank
- 1;
2178 gfc_resolve_dim_arg (dim
);
2181 f
->value
.function
.name
2182 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
2183 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
2188 gfc_resolve_symlnk (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
2189 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
2191 f
->ts
.type
= BT_INTEGER
;
2192 f
->ts
.kind
= gfc_default_integer_kind
;
2193 f
->value
.function
.name
= gfc_get_string (PREFIX ("symlnk_i%d"), f
->ts
.kind
);
2197 /* Resolve the g77 compatibility function SYSTEM. */
2200 gfc_resolve_system (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
2202 f
->ts
.type
= BT_INTEGER
;
2204 f
->value
.function
.name
= gfc_get_string (PREFIX ("system"));
2209 gfc_resolve_tan (gfc_expr
*f
, gfc_expr
*x
)
2212 f
->value
.function
.name
2213 = gfc_get_string ("__tan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2218 gfc_resolve_tanh (gfc_expr
*f
, gfc_expr
*x
)
2221 f
->value
.function
.name
2222 = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2227 gfc_resolve_time (gfc_expr
*f
)
2229 f
->ts
.type
= BT_INTEGER
;
2231 f
->value
.function
.name
= gfc_get_string (PREFIX ("time_func"));
2236 gfc_resolve_time8 (gfc_expr
*f
)
2238 f
->ts
.type
= BT_INTEGER
;
2240 f
->value
.function
.name
= gfc_get_string (PREFIX ("time8_func"));
2245 gfc_resolve_transfer (gfc_expr
*f
, gfc_expr
*source ATTRIBUTE_UNUSED
,
2246 gfc_expr
*mold
, gfc_expr
*size
)
2248 /* TODO: Make this do something meaningful. */
2249 static char transfer0
[] = "__transfer0", transfer1
[] = "__transfer1";
2251 if (mold
->ts
.type
== BT_CHARACTER
&& !mold
->ts
.cl
->length
2252 && !(mold
->expr_type
== EXPR_VARIABLE
&& mold
->symtree
->n
.sym
->attr
.dummy
))
2253 mold
->ts
.cl
->length
= gfc_int_expr (mold
->value
.character
.length
);
2257 if (size
== NULL
&& mold
->rank
== 0)
2260 f
->value
.function
.name
= transfer0
;
2265 f
->value
.function
.name
= transfer1
;
2266 if (size
&& gfc_is_constant_expr (size
))
2268 f
->shape
= gfc_get_shape (1);
2269 mpz_init_set (f
->shape
[0], size
->value
.integer
);
2276 gfc_resolve_transpose (gfc_expr
*f
, gfc_expr
*matrix
)
2279 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ref
)
2280 gfc_resolve_substring_charlen (matrix
);
2286 f
->shape
= gfc_get_shape (2);
2287 mpz_init_set (f
->shape
[0], matrix
->shape
[1]);
2288 mpz_init_set (f
->shape
[1], matrix
->shape
[0]);
2291 switch (matrix
->ts
.kind
)
2297 switch (matrix
->ts
.type
)
2301 f
->value
.function
.name
2302 = gfc_get_string (PREFIX ("transpose_%c%d"),
2303 gfc_type_letter (matrix
->ts
.type
),
2309 /* Use the integer routines for real and logical cases. This
2310 assumes they all have the same alignment requirements. */
2311 f
->value
.function
.name
2312 = gfc_get_string (PREFIX ("transpose_i%d"), matrix
->ts
.kind
);
2316 f
->value
.function
.name
= PREFIX ("transpose");
2322 f
->value
.function
.name
= (matrix
->ts
.type
== BT_CHARACTER
2323 ? PREFIX ("transpose_char")
2324 : PREFIX ("transpose"));
2331 gfc_resolve_trim (gfc_expr
*f
, gfc_expr
*string
)
2333 f
->ts
.type
= BT_CHARACTER
;
2334 f
->ts
.kind
= string
->ts
.kind
;
2335 f
->value
.function
.name
= gfc_get_string ("__trim_%d", string
->ts
.kind
);
2340 gfc_resolve_ubound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2342 static char ubound
[] = "__ubound";
2344 f
->ts
.type
= BT_INTEGER
;
2346 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2348 f
->ts
.kind
= gfc_default_integer_kind
;
2353 f
->shape
= gfc_get_shape (1);
2354 mpz_init_set_ui (f
->shape
[0], array
->rank
);
2357 f
->value
.function
.name
= ubound
;
2361 /* Resolve the g77 compatibility function UMASK. */
2364 gfc_resolve_umask (gfc_expr
*f
, gfc_expr
*n
)
2366 f
->ts
.type
= BT_INTEGER
;
2367 f
->ts
.kind
= n
->ts
.kind
;
2368 f
->value
.function
.name
= gfc_get_string (PREFIX ("umask_i%d"), n
->ts
.kind
);
2372 /* Resolve the g77 compatibility function UNLINK. */
2375 gfc_resolve_unlink (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
2377 f
->ts
.type
= BT_INTEGER
;
2379 f
->value
.function
.name
= gfc_get_string (PREFIX ("unlink"));
2384 gfc_resolve_ttynam (gfc_expr
*f
, gfc_expr
*unit
)
2389 f
->ts
.type
= BT_CHARACTER
;
2390 f
->ts
.kind
= gfc_default_character_kind
;
2392 if (unit
->ts
.kind
!= gfc_c_int_kind
)
2394 ts
.type
= BT_INTEGER
;
2395 ts
.kind
= gfc_c_int_kind
;
2398 gfc_convert_type (unit
, &ts
, 2);
2401 f
->value
.function
.name
= gfc_get_string (PREFIX ("ttynam"));
2406 gfc_resolve_unpack (gfc_expr
*f
, gfc_expr
*vector
, gfc_expr
*mask
,
2407 gfc_expr
*field ATTRIBUTE_UNUSED
)
2409 if (vector
->ts
.type
== BT_CHARACTER
&& vector
->ref
)
2410 gfc_resolve_substring_charlen (vector
);
2413 f
->rank
= mask
->rank
;
2414 resolve_mask_arg (mask
);
2416 f
->value
.function
.name
2417 = gfc_get_string (PREFIX ("unpack%d%s"), field
->rank
> 0 ? 1 : 0,
2418 vector
->ts
.type
== BT_CHARACTER
? "_char" : "");
2423 gfc_resolve_verify (gfc_expr
*f
, gfc_expr
*string
,
2424 gfc_expr
*set ATTRIBUTE_UNUSED
,
2425 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2427 f
->ts
.type
= BT_INTEGER
;
2429 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2431 f
->ts
.kind
= gfc_default_integer_kind
;
2432 f
->value
.function
.name
= gfc_get_string ("__verify_%d", string
->ts
.kind
);
2437 gfc_resolve_xor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
2439 f
->ts
.type
= i
->ts
.type
;
2440 f
->ts
.kind
= gfc_kind_max (i
, j
);
2442 if (i
->ts
.kind
!= j
->ts
.kind
)
2444 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
2445 gfc_convert_type (j
, &i
->ts
, 2);
2447 gfc_convert_type (i
, &j
->ts
, 2);
2450 f
->value
.function
.name
2451 = gfc_get_string ("__xor_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
2455 /* Intrinsic subroutine resolution. */
2458 gfc_resolve_alarm_sub (gfc_code
*c
)
2461 gfc_expr
*seconds
, *handler
, *status
;
2465 seconds
= c
->ext
.actual
->expr
;
2466 handler
= c
->ext
.actual
->next
->expr
;
2467 status
= c
->ext
.actual
->next
->next
->expr
;
2468 ts
.type
= BT_INTEGER
;
2469 ts
.kind
= gfc_c_int_kind
;
2471 /* handler can be either BT_INTEGER or BT_PROCEDURE.
2472 In all cases, the status argument is of default integer kind
2473 (enforced in check.c) so that the function suffix is fixed. */
2474 if (handler
->ts
.type
== BT_INTEGER
)
2476 if (handler
->ts
.kind
!= gfc_c_int_kind
)
2477 gfc_convert_type (handler
, &ts
, 2);
2478 name
= gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
2479 gfc_default_integer_kind
);
2482 name
= gfc_get_string (PREFIX ("alarm_sub_i%d"),
2483 gfc_default_integer_kind
);
2485 if (seconds
->ts
.kind
!= gfc_c_int_kind
)
2486 gfc_convert_type (seconds
, &ts
, 2);
2488 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2492 gfc_resolve_cpu_time (gfc_code
*c
)
2495 name
= gfc_get_string (PREFIX ("cpu_time_%d"), c
->ext
.actual
->expr
->ts
.kind
);
2496 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2501 gfc_resolve_mvbits (gfc_code
*c
)
2507 /* FROMPOS, LEN and TOPOS are restricted to small values. As such,
2508 they will be converted so that they fit into a C int. */
2509 ts
.type
= BT_INTEGER
;
2510 ts
.kind
= gfc_c_int_kind
;
2511 if (c
->ext
.actual
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
2512 gfc_convert_type (c
->ext
.actual
->next
->expr
, &ts
, 2);
2513 if (c
->ext
.actual
->next
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
2514 gfc_convert_type (c
->ext
.actual
->next
->next
->expr
, &ts
, 2);
2515 if (c
->ext
.actual
->next
->next
->next
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
2516 gfc_convert_type (c
->ext
.actual
->next
->next
->next
->next
->expr
, &ts
, 2);
2518 /* TO and FROM are guaranteed to have the same kind parameter. */
2519 name
= gfc_get_string (PREFIX ("mvbits_i%d"),
2520 c
->ext
.actual
->expr
->ts
.kind
);
2521 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2522 /* Mark as elemental subroutine as this does not happen automatically. */
2523 c
->resolved_sym
->attr
.elemental
= 1;
2528 gfc_resolve_random_number (gfc_code
*c
)
2533 kind
= c
->ext
.actual
->expr
->ts
.kind
;
2534 if (c
->ext
.actual
->expr
->rank
== 0)
2535 name
= gfc_get_string (PREFIX ("random_r%d"), kind
);
2537 name
= gfc_get_string (PREFIX ("arandom_r%d"), kind
);
2539 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2544 gfc_resolve_random_seed (gfc_code
*c
)
2548 name
= gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind
);
2549 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2554 gfc_resolve_rename_sub (gfc_code
*c
)
2559 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
2560 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
2562 kind
= gfc_default_integer_kind
;
2564 name
= gfc_get_string (PREFIX ("rename_i%d_sub"), kind
);
2565 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2570 gfc_resolve_kill_sub (gfc_code
*c
)
2575 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
2576 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
2578 kind
= gfc_default_integer_kind
;
2580 name
= gfc_get_string (PREFIX ("kill_i%d_sub"), kind
);
2581 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2586 gfc_resolve_link_sub (gfc_code
*c
)
2591 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
2592 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
2594 kind
= gfc_default_integer_kind
;
2596 name
= gfc_get_string (PREFIX ("link_i%d_sub"), kind
);
2597 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2602 gfc_resolve_symlnk_sub (gfc_code
*c
)
2607 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
2608 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
2610 kind
= gfc_default_integer_kind
;
2612 name
= gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind
);
2613 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2617 /* G77 compatibility subroutines dtime() and etime(). */
2620 gfc_resolve_dtime_sub (gfc_code
*c
)
2623 name
= gfc_get_string (PREFIX ("dtime_sub"));
2624 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2628 gfc_resolve_etime_sub (gfc_code
*c
)
2631 name
= gfc_get_string (PREFIX ("etime_sub"));
2632 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2636 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
2639 gfc_resolve_itime (gfc_code
*c
)
2642 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
2643 gfc_default_integer_kind
));
2647 gfc_resolve_idate (gfc_code
*c
)
2650 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
2651 gfc_default_integer_kind
));
2655 gfc_resolve_ltime (gfc_code
*c
)
2658 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
2659 gfc_default_integer_kind
));
2663 gfc_resolve_gmtime (gfc_code
*c
)
2666 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
2667 gfc_default_integer_kind
));
2671 /* G77 compatibility subroutine second(). */
2674 gfc_resolve_second_sub (gfc_code
*c
)
2677 name
= gfc_get_string (PREFIX ("second_sub"));
2678 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2683 gfc_resolve_sleep_sub (gfc_code
*c
)
2688 if (c
->ext
.actual
->expr
!= NULL
)
2689 kind
= c
->ext
.actual
->expr
->ts
.kind
;
2691 kind
= gfc_default_integer_kind
;
2693 name
= gfc_get_string (PREFIX ("sleep_i%d_sub"), kind
);
2694 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2698 /* G77 compatibility function srand(). */
2701 gfc_resolve_srand (gfc_code
*c
)
2704 name
= gfc_get_string (PREFIX ("srand"));
2705 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2709 /* Resolve the getarg intrinsic subroutine. */
2712 gfc_resolve_getarg (gfc_code
*c
)
2716 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_default_integer_kind
)
2721 ts
.type
= BT_INTEGER
;
2722 ts
.kind
= gfc_default_integer_kind
;
2724 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
2727 name
= gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind
);
2728 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2732 /* Resolve the getcwd intrinsic subroutine. */
2735 gfc_resolve_getcwd_sub (gfc_code
*c
)
2740 if (c
->ext
.actual
->next
->expr
!= NULL
)
2741 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
2743 kind
= gfc_default_integer_kind
;
2745 name
= gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind
);
2746 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2750 /* Resolve the get_command intrinsic subroutine. */
2753 gfc_resolve_get_command (gfc_code
*c
)
2757 kind
= gfc_default_integer_kind
;
2758 name
= gfc_get_string (PREFIX ("get_command_i%d"), kind
);
2759 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2763 /* Resolve the get_command_argument intrinsic subroutine. */
2766 gfc_resolve_get_command_argument (gfc_code
*c
)
2770 kind
= gfc_default_integer_kind
;
2771 name
= gfc_get_string (PREFIX ("get_command_argument_i%d"), kind
);
2772 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2776 /* Resolve the get_environment_variable intrinsic subroutine. */
2779 gfc_resolve_get_environment_variable (gfc_code
*code
)
2783 kind
= gfc_default_integer_kind
;
2784 name
= gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind
);
2785 code
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2790 gfc_resolve_signal_sub (gfc_code
*c
)
2793 gfc_expr
*number
, *handler
, *status
;
2797 number
= c
->ext
.actual
->expr
;
2798 handler
= c
->ext
.actual
->next
->expr
;
2799 status
= c
->ext
.actual
->next
->next
->expr
;
2800 ts
.type
= BT_INTEGER
;
2801 ts
.kind
= gfc_c_int_kind
;
2803 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2804 if (handler
->ts
.type
== BT_INTEGER
)
2806 if (handler
->ts
.kind
!= gfc_c_int_kind
)
2807 gfc_convert_type (handler
, &ts
, 2);
2808 name
= gfc_get_string (PREFIX ("signal_sub_int"));
2811 name
= gfc_get_string (PREFIX ("signal_sub"));
2813 if (number
->ts
.kind
!= gfc_c_int_kind
)
2814 gfc_convert_type (number
, &ts
, 2);
2815 if (status
!= NULL
&& status
->ts
.kind
!= gfc_c_int_kind
)
2816 gfc_convert_type (status
, &ts
, 2);
2818 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2822 /* Resolve the SYSTEM intrinsic subroutine. */
2825 gfc_resolve_system_sub (gfc_code
*c
)
2828 name
= gfc_get_string (PREFIX ("system_sub"));
2829 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2833 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
2836 gfc_resolve_system_clock (gfc_code
*c
)
2841 if (c
->ext
.actual
->expr
!= NULL
)
2842 kind
= c
->ext
.actual
->expr
->ts
.kind
;
2843 else if (c
->ext
.actual
->next
->expr
!= NULL
)
2844 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
2845 else if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
2846 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
2848 kind
= gfc_default_integer_kind
;
2850 name
= gfc_get_string (PREFIX ("system_clock_%d"), kind
);
2851 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2855 /* Resolve the EXIT intrinsic subroutine. */
2858 gfc_resolve_exit (gfc_code
*c
)
2865 /* The STATUS argument has to be of default kind. If it is not,
2867 ts
.type
= BT_INTEGER
;
2868 ts
.kind
= gfc_default_integer_kind
;
2869 n
= c
->ext
.actual
->expr
;
2870 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
2871 gfc_convert_type (n
, &ts
, 2);
2873 name
= gfc_get_string (PREFIX ("exit_i%d"), ts
.kind
);
2874 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2878 /* Resolve the FLUSH intrinsic subroutine. */
2881 gfc_resolve_flush (gfc_code
*c
)
2888 ts
.type
= BT_INTEGER
;
2889 ts
.kind
= gfc_default_integer_kind
;
2890 n
= c
->ext
.actual
->expr
;
2891 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
2892 gfc_convert_type (n
, &ts
, 2);
2894 name
= gfc_get_string (PREFIX ("flush_i%d"), ts
.kind
);
2895 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2900 gfc_resolve_free (gfc_code
*c
)
2906 ts
.type
= BT_INTEGER
;
2907 ts
.kind
= gfc_index_integer_kind
;
2908 n
= c
->ext
.actual
->expr
;
2909 if (n
->ts
.kind
!= ts
.kind
)
2910 gfc_convert_type (n
, &ts
, 2);
2912 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("free"));
2917 gfc_resolve_ctime_sub (gfc_code
*c
)
2922 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
2923 if (c
->ext
.actual
->expr
->ts
.kind
!= 8)
2925 ts
.type
= BT_INTEGER
;
2929 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
2932 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
2937 gfc_resolve_fdate_sub (gfc_code
*c
)
2939 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
2944 gfc_resolve_gerror (gfc_code
*c
)
2946 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
2951 gfc_resolve_getlog (gfc_code
*c
)
2953 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
2958 gfc_resolve_hostnm_sub (gfc_code
*c
)
2963 if (c
->ext
.actual
->next
->expr
!= NULL
)
2964 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
2966 kind
= gfc_default_integer_kind
;
2968 name
= gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind
);
2969 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2974 gfc_resolve_perror (gfc_code
*c
)
2976 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
2979 /* Resolve the STAT and FSTAT intrinsic subroutines. */
2982 gfc_resolve_stat_sub (gfc_code
*c
)
2985 name
= gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind
);
2986 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2991 gfc_resolve_lstat_sub (gfc_code
*c
)
2994 name
= gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind
);
2995 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3000 gfc_resolve_fstat_sub (gfc_code
*c
)
3006 u
= c
->ext
.actual
->expr
;
3007 ts
= &c
->ext
.actual
->next
->expr
->ts
;
3008 if (u
->ts
.kind
!= ts
->kind
)
3009 gfc_convert_type (u
, ts
, 2);
3010 name
= gfc_get_string (PREFIX ("fstat_i%d_sub"), ts
->kind
);
3011 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3016 gfc_resolve_fgetc_sub (gfc_code
*c
)
3023 u
= c
->ext
.actual
->expr
;
3024 st
= c
->ext
.actual
->next
->next
->expr
;
3026 if (u
->ts
.kind
!= gfc_c_int_kind
)
3028 ts
.type
= BT_INTEGER
;
3029 ts
.kind
= gfc_c_int_kind
;
3032 gfc_convert_type (u
, &ts
, 2);
3036 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), st
->ts
.kind
);
3038 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind
);
3040 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3045 gfc_resolve_fget_sub (gfc_code
*c
)
3050 st
= c
->ext
.actual
->next
->expr
;
3052 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), st
->ts
.kind
);
3054 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind
);
3056 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3061 gfc_resolve_fputc_sub (gfc_code
*c
)
3068 u
= c
->ext
.actual
->expr
;
3069 st
= c
->ext
.actual
->next
->next
->expr
;
3071 if (u
->ts
.kind
!= gfc_c_int_kind
)
3073 ts
.type
= BT_INTEGER
;
3074 ts
.kind
= gfc_c_int_kind
;
3077 gfc_convert_type (u
, &ts
, 2);
3081 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), st
->ts
.kind
);
3083 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind
);
3085 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3090 gfc_resolve_fput_sub (gfc_code
*c
)
3095 st
= c
->ext
.actual
->next
->expr
;
3097 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), st
->ts
.kind
);
3099 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind
);
3101 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3106 gfc_resolve_fseek_sub (gfc_code
*c
)
3115 unit
= c
->ext
.actual
->expr
;
3116 offset
= c
->ext
.actual
->next
->expr
;
3117 whence
= c
->ext
.actual
->next
->next
->expr
;
3118 status
= c
->ext
.actual
->next
->next
->next
->expr
;
3120 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3122 ts
.type
= BT_INTEGER
;
3123 ts
.kind
= gfc_c_int_kind
;
3126 gfc_convert_type (unit
, &ts
, 2);
3129 if (offset
->ts
.kind
!= gfc_intio_kind
)
3131 ts
.type
= BT_INTEGER
;
3132 ts
.kind
= gfc_intio_kind
;
3135 gfc_convert_type (offset
, &ts
, 2);
3138 if (whence
->ts
.kind
!= gfc_c_int_kind
)
3140 ts
.type
= BT_INTEGER
;
3141 ts
.kind
= gfc_c_int_kind
;
3144 gfc_convert_type (whence
, &ts
, 2);
3147 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
3151 gfc_resolve_ftell_sub (gfc_code
*c
)
3159 unit
= c
->ext
.actual
->expr
;
3160 offset
= c
->ext
.actual
->next
->expr
;
3162 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3164 ts
.type
= BT_INTEGER
;
3165 ts
.kind
= gfc_c_int_kind
;
3168 gfc_convert_type (unit
, &ts
, 2);
3171 name
= gfc_get_string (PREFIX ("ftell_i%d_sub"), offset
->ts
.kind
);
3172 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3177 gfc_resolve_ttynam_sub (gfc_code
*c
)
3182 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
3184 ts
.type
= BT_INTEGER
;
3185 ts
.kind
= gfc_c_int_kind
;
3188 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3191 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
3195 /* Resolve the UMASK intrinsic subroutine. */
3198 gfc_resolve_umask_sub (gfc_code
*c
)
3203 if (c
->ext
.actual
->next
->expr
!= NULL
)
3204 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3206 kind
= gfc_default_integer_kind
;
3208 name
= gfc_get_string (PREFIX ("umask_i%d_sub"), kind
);
3209 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3212 /* Resolve the UNLINK intrinsic subroutine. */
3215 gfc_resolve_unlink_sub (gfc_code
*c
)
3220 if (c
->ext
.actual
->next
->expr
!= NULL
)
3221 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3223 kind
= gfc_default_integer_kind
;
3225 name
= gfc_get_string (PREFIX ("unlink_i%d_sub"), kind
);
3226 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);