1 /* Intrinsic function resolution.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
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 2, 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 COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
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"
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
->expr_type
== EXPR_CONSTANT
&& source
->ts
.cl
== NULL
)
69 source
->ts
.cl
= gfc_get_charlen ();
70 source
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
71 gfc_current_ns
->cl_list
= source
->ts
.cl
;
72 source
->ts
.cl
->length
= gfc_int_expr (source
->value
.character
.length
);
77 /********************** Resolution functions **********************/
81 gfc_resolve_abs (gfc_expr
* f
, gfc_expr
* a
)
84 if (f
->ts
.type
== BT_COMPLEX
)
87 f
->value
.function
.name
=
88 gfc_get_string ("__abs_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
93 gfc_resolve_acos (gfc_expr
* f
, gfc_expr
* x
)
96 f
->value
.function
.name
=
97 gfc_get_string ("__acos_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
102 gfc_resolve_acosh (gfc_expr
* f
, gfc_expr
* x
)
105 f
->value
.function
.name
=
106 gfc_get_string ("__acosh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
111 gfc_resolve_aimag (gfc_expr
* f
, gfc_expr
* x
)
113 f
->ts
.type
= BT_REAL
;
114 f
->ts
.kind
= x
->ts
.kind
;
115 f
->value
.function
.name
=
116 gfc_get_string ("__aimag_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
121 gfc_resolve_aint (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
125 f
->ts
.type
= a
->ts
.type
;
126 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
128 if (a
->ts
.kind
!= f
->ts
.kind
)
130 ts
.type
= f
->ts
.type
;
131 ts
.kind
= f
->ts
.kind
;
132 gfc_convert_type (a
, &ts
, 2);
134 /* The resolved name is only used for specific intrinsics where
135 the return kind is the same as the arg kind. */
136 f
->value
.function
.name
=
137 gfc_get_string ("__aint_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
142 gfc_resolve_dint (gfc_expr
* f
, gfc_expr
* a
)
144 gfc_resolve_aint (f
, a
, NULL
);
149 gfc_resolve_all (gfc_expr
* f
, gfc_expr
* mask
, gfc_expr
* dim
)
155 gfc_resolve_dim_arg (dim
);
156 f
->rank
= mask
->rank
- 1;
157 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
160 f
->value
.function
.name
=
161 gfc_get_string (PREFIX("all_%c%d"), gfc_type_letter (mask
->ts
.type
),
167 gfc_resolve_anint (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
171 f
->ts
.type
= a
->ts
.type
;
172 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
174 if (a
->ts
.kind
!= f
->ts
.kind
)
176 ts
.type
= f
->ts
.type
;
177 ts
.kind
= f
->ts
.kind
;
178 gfc_convert_type (a
, &ts
, 2);
181 /* The resolved name is only used for specific intrinsics where
182 the return kind is the same as the arg kind. */
183 f
->value
.function
.name
=
184 gfc_get_string ("__anint_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
189 gfc_resolve_dnint (gfc_expr
* f
, gfc_expr
* a
)
191 gfc_resolve_anint (f
, a
, NULL
);
196 gfc_resolve_any (gfc_expr
* f
, gfc_expr
* mask
, gfc_expr
* dim
)
202 gfc_resolve_dim_arg (dim
);
203 f
->rank
= mask
->rank
- 1;
204 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
207 f
->value
.function
.name
=
208 gfc_get_string (PREFIX("any_%c%d"), gfc_type_letter (mask
->ts
.type
),
214 gfc_resolve_asin (gfc_expr
* f
, gfc_expr
* x
)
217 f
->value
.function
.name
=
218 gfc_get_string ("__asin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
222 gfc_resolve_asinh (gfc_expr
* f
, gfc_expr
* x
)
225 f
->value
.function
.name
=
226 gfc_get_string ("__asinh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
230 gfc_resolve_atan (gfc_expr
* f
, gfc_expr
* x
)
233 f
->value
.function
.name
=
234 gfc_get_string ("__atan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
238 gfc_resolve_atanh (gfc_expr
* f
, gfc_expr
* x
)
241 f
->value
.function
.name
=
242 gfc_get_string ("__atanh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
246 gfc_resolve_atan2 (gfc_expr
* f
, gfc_expr
* x
,
247 gfc_expr
* y ATTRIBUTE_UNUSED
)
250 f
->value
.function
.name
=
251 gfc_get_string ("__atan2_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
255 /* Resolve the BESYN and BESJN intrinsics. */
258 gfc_resolve_besn (gfc_expr
* f
, gfc_expr
* n
, gfc_expr
* x
)
263 if (n
->ts
.kind
!= gfc_c_int_kind
)
265 ts
.type
= BT_INTEGER
;
266 ts
.kind
= gfc_c_int_kind
;
267 gfc_convert_type (n
, &ts
, 2);
269 f
->value
.function
.name
= gfc_get_string ("<intrinsic>");
274 gfc_resolve_btest (gfc_expr
* f
, gfc_expr
* i
, gfc_expr
* pos
)
276 f
->ts
.type
= BT_LOGICAL
;
277 f
->ts
.kind
= gfc_default_logical_kind
;
279 f
->value
.function
.name
= gfc_get_string ("__btest_%d_%d", i
->ts
.kind
,
285 gfc_resolve_ceiling (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
287 f
->ts
.type
= BT_INTEGER
;
288 f
->ts
.kind
= (kind
== NULL
) ? gfc_default_integer_kind
289 : mpz_get_si (kind
->value
.integer
);
291 f
->value
.function
.name
=
292 gfc_get_string ("__ceiling_%d_%c%d", f
->ts
.kind
,
293 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
298 gfc_resolve_char (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
300 f
->ts
.type
= BT_CHARACTER
;
301 f
->ts
.kind
= (kind
== NULL
) ? gfc_default_character_kind
302 : mpz_get_si (kind
->value
.integer
);
304 f
->value
.function
.name
=
305 gfc_get_string ("__char_%d_%c%d", f
->ts
.kind
,
306 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
311 gfc_resolve_chdir (gfc_expr
* f
, gfc_expr
* d ATTRIBUTE_UNUSED
)
313 f
->ts
.type
= BT_INTEGER
;
314 f
->ts
.kind
= gfc_default_integer_kind
;
315 f
->value
.function
.name
= gfc_get_string (PREFIX("chdir_i%d"), f
->ts
.kind
);
320 gfc_resolve_chdir_sub (gfc_code
* c
)
325 if (c
->ext
.actual
->next
->expr
!= NULL
)
326 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
328 kind
= gfc_default_integer_kind
;
330 name
= gfc_get_string (PREFIX("chdir_i%d_sub"), kind
);
331 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
336 gfc_resolve_cmplx (gfc_expr
* f
, gfc_expr
* x
, gfc_expr
* y
, gfc_expr
* kind
)
338 f
->ts
.type
= BT_COMPLEX
;
339 f
->ts
.kind
= (kind
== NULL
) ? gfc_default_real_kind
340 : mpz_get_si (kind
->value
.integer
);
343 f
->value
.function
.name
=
344 gfc_get_string ("__cmplx0_%d_%c%d", f
->ts
.kind
,
345 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
347 f
->value
.function
.name
=
348 gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f
->ts
.kind
,
349 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
,
350 gfc_type_letter (y
->ts
.type
), y
->ts
.kind
);
354 gfc_resolve_dcmplx (gfc_expr
* f
, gfc_expr
* x
, gfc_expr
* y
)
356 gfc_resolve_cmplx (f
, x
, y
, gfc_int_expr (gfc_default_double_kind
));
360 gfc_resolve_conjg (gfc_expr
* f
, gfc_expr
* x
)
363 f
->value
.function
.name
= gfc_get_string ("__conjg_%d", x
->ts
.kind
);
368 gfc_resolve_cos (gfc_expr
* f
, gfc_expr
* x
)
371 f
->value
.function
.name
=
372 gfc_get_string ("__cos_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
377 gfc_resolve_cosh (gfc_expr
* f
, gfc_expr
* x
)
380 f
->value
.function
.name
=
381 gfc_get_string ("__cosh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
386 gfc_resolve_count (gfc_expr
* f
, gfc_expr
* mask
, gfc_expr
* dim
)
388 f
->ts
.type
= BT_INTEGER
;
389 f
->ts
.kind
= gfc_default_integer_kind
;
393 f
->rank
= mask
->rank
- 1;
394 gfc_resolve_dim_arg (dim
);
395 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
398 f
->value
.function
.name
=
399 gfc_get_string (PREFIX("count_%d_%c%d"), f
->ts
.kind
,
400 gfc_type_letter (mask
->ts
.type
), mask
->ts
.kind
);
405 gfc_resolve_cshift (gfc_expr
* f
, gfc_expr
* array
,
412 f
->rank
= array
->rank
;
413 f
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
420 /* Convert shift to at least gfc_default_integer_kind, so we don't need
421 kind=1 and kind=2 versions of the library functions. */
422 if (shift
->ts
.kind
< gfc_default_integer_kind
)
425 ts
.type
= BT_INTEGER
;
426 ts
.kind
= gfc_default_integer_kind
;
427 gfc_convert_type_warn (shift
, &ts
, 2, 0);
432 gfc_resolve_dim_arg (dim
);
433 /* Convert dim to shift's kind, so we don't need so many variations. */
434 if (dim
->ts
.kind
!= shift
->ts
.kind
)
435 gfc_convert_type_warn (dim
, &shift
->ts
, 2, 0);
437 f
->value
.function
.name
=
438 gfc_get_string (PREFIX("cshift%d_%d%s"), n
, shift
->ts
.kind
,
439 array
->ts
.type
== BT_CHARACTER
? "_char" : "");
444 gfc_resolve_dble (gfc_expr
* f
, gfc_expr
* a
)
446 f
->ts
.type
= BT_REAL
;
447 f
->ts
.kind
= gfc_default_double_kind
;
448 f
->value
.function
.name
=
449 gfc_get_string ("__dble_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
454 gfc_resolve_dim (gfc_expr
* f
, gfc_expr
* x
,
455 gfc_expr
* y ATTRIBUTE_UNUSED
)
458 f
->value
.function
.name
=
459 gfc_get_string ("__dim_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
464 gfc_resolve_dot_product (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* b
)
468 if (a
->ts
.type
== BT_LOGICAL
&& b
->ts
.type
== BT_LOGICAL
)
470 f
->ts
.type
= BT_LOGICAL
;
471 f
->ts
.kind
= gfc_default_logical_kind
;
475 temp
.expr_type
= EXPR_OP
;
476 gfc_clear_ts (&temp
.ts
);
477 temp
.value
.op
.operator = INTRINSIC_NONE
;
478 temp
.value
.op
.op1
= a
;
479 temp
.value
.op
.op2
= b
;
480 gfc_type_convert_binary (&temp
);
484 f
->value
.function
.name
=
485 gfc_get_string (PREFIX("dot_product_%c%d"), gfc_type_letter (f
->ts
.type
),
491 gfc_resolve_dprod (gfc_expr
* f
,
492 gfc_expr
* a ATTRIBUTE_UNUSED
,
493 gfc_expr
* b ATTRIBUTE_UNUSED
)
495 f
->ts
.kind
= gfc_default_double_kind
;
496 f
->ts
.type
= BT_REAL
;
498 f
->value
.function
.name
= gfc_get_string ("__dprod_r%d", f
->ts
.kind
);
503 gfc_resolve_eoshift (gfc_expr
* f
, gfc_expr
* array
,
511 f
->rank
= array
->rank
;
512 f
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
517 if (boundary
&& boundary
->rank
> 0)
520 /* Convert shift to at least gfc_default_integer_kind, so we don't need
521 kind=1 and kind=2 versions of the library functions. */
522 if (shift
->ts
.kind
< gfc_default_integer_kind
)
525 ts
.type
= BT_INTEGER
;
526 ts
.kind
= gfc_default_integer_kind
;
527 gfc_convert_type_warn (shift
, &ts
, 2, 0);
532 gfc_resolve_dim_arg (dim
);
533 /* Convert dim to shift's kind, so we don't need so many variations. */
534 if (dim
->ts
.kind
!= shift
->ts
.kind
)
535 gfc_convert_type_warn (dim
, &shift
->ts
, 2, 0);
538 f
->value
.function
.name
=
539 gfc_get_string (PREFIX("eoshift%d_%d%s"), n
, shift
->ts
.kind
,
540 array
->ts
.type
== BT_CHARACTER
? "_char" : "");
545 gfc_resolve_exp (gfc_expr
* f
, gfc_expr
* x
)
548 f
->value
.function
.name
=
549 gfc_get_string ("__exp_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
554 gfc_resolve_exponent (gfc_expr
* f
, gfc_expr
* x
)
556 f
->ts
.type
= BT_INTEGER
;
557 f
->ts
.kind
= gfc_default_integer_kind
;
559 f
->value
.function
.name
= gfc_get_string ("__exponent_%d", x
->ts
.kind
);
564 gfc_resolve_floor (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
566 f
->ts
.type
= BT_INTEGER
;
567 f
->ts
.kind
= (kind
== NULL
) ? gfc_default_integer_kind
568 : mpz_get_si (kind
->value
.integer
);
570 f
->value
.function
.name
=
571 gfc_get_string ("__floor%d_%c%d", f
->ts
.kind
,
572 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
577 gfc_resolve_fnum (gfc_expr
* f
, gfc_expr
* n
)
579 f
->ts
.type
= BT_INTEGER
;
580 f
->ts
.kind
= gfc_default_integer_kind
;
581 if (n
->ts
.kind
!= f
->ts
.kind
)
582 gfc_convert_type (n
, &f
->ts
, 2);
583 f
->value
.function
.name
= gfc_get_string (PREFIX("fnum_i%d"), f
->ts
.kind
);
588 gfc_resolve_fraction (gfc_expr
* f
, gfc_expr
* x
)
591 f
->value
.function
.name
= gfc_get_string ("__fraction_%d", x
->ts
.kind
);
595 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
598 gfc_resolve_g77_math1 (gfc_expr
* f
, gfc_expr
* x
)
601 f
->value
.function
.name
= gfc_get_string ("<intrinsic>");
606 gfc_resolve_getcwd (gfc_expr
* f
, gfc_expr
* n ATTRIBUTE_UNUSED
)
608 f
->ts
.type
= BT_INTEGER
;
610 f
->value
.function
.name
= gfc_get_string (PREFIX("getcwd"));
615 gfc_resolve_getgid (gfc_expr
* f
)
617 f
->ts
.type
= BT_INTEGER
;
619 f
->value
.function
.name
= gfc_get_string (PREFIX("getgid"));
624 gfc_resolve_getpid (gfc_expr
* f
)
626 f
->ts
.type
= BT_INTEGER
;
628 f
->value
.function
.name
= gfc_get_string (PREFIX("getpid"));
633 gfc_resolve_getuid (gfc_expr
* f
)
635 f
->ts
.type
= BT_INTEGER
;
637 f
->value
.function
.name
= gfc_get_string (PREFIX("getuid"));
641 gfc_resolve_hostnm (gfc_expr
* f
, gfc_expr
* n ATTRIBUTE_UNUSED
)
643 f
->ts
.type
= BT_INTEGER
;
645 f
->value
.function
.name
= gfc_get_string (PREFIX ("hostnm"));
649 gfc_resolve_iand (gfc_expr
* f
, gfc_expr
* i
, gfc_expr
* j
)
651 /* If the kind of i and j are different, then g77 cross-promoted the
652 kinds to the largest value. The Fortran 95 standard requires the
654 if (i
->ts
.kind
!= j
->ts
.kind
)
656 if (i
->ts
.kind
== gfc_kind_max (i
,j
))
657 gfc_convert_type(j
, &i
->ts
, 2);
659 gfc_convert_type(i
, &j
->ts
, 2);
663 f
->value
.function
.name
= gfc_get_string ("__iand_%d", i
->ts
.kind
);
668 gfc_resolve_ibclr (gfc_expr
* f
, gfc_expr
* i
, gfc_expr
* pos ATTRIBUTE_UNUSED
)
671 f
->value
.function
.name
= gfc_get_string ("__ibclr_%d", i
->ts
.kind
);
676 gfc_resolve_ibits (gfc_expr
* f
, gfc_expr
* i
,
677 gfc_expr
* pos ATTRIBUTE_UNUSED
,
678 gfc_expr
* len ATTRIBUTE_UNUSED
)
681 f
->value
.function
.name
= gfc_get_string ("__ibits_%d", i
->ts
.kind
);
686 gfc_resolve_ibset (gfc_expr
* f
, gfc_expr
* i
,
687 gfc_expr
* pos ATTRIBUTE_UNUSED
)
690 f
->value
.function
.name
= gfc_get_string ("__ibset_%d", i
->ts
.kind
);
695 gfc_resolve_ichar (gfc_expr
* f
, gfc_expr
* c
)
697 f
->ts
.type
= BT_INTEGER
;
698 f
->ts
.kind
= gfc_default_integer_kind
;
700 f
->value
.function
.name
= gfc_get_string ("__ichar_%d", c
->ts
.kind
);
705 gfc_resolve_idnint (gfc_expr
* f
, gfc_expr
* a
)
707 gfc_resolve_nint (f
, a
, NULL
);
712 gfc_resolve_ierrno (gfc_expr
* f
)
714 f
->ts
.type
= BT_INTEGER
;
715 f
->ts
.kind
= gfc_default_integer_kind
;
716 f
->value
.function
.name
= gfc_get_string (PREFIX("ierrno_i%d"), f
->ts
.kind
);
721 gfc_resolve_ieor (gfc_expr
* f
, gfc_expr
* i
, gfc_expr
* j
)
723 /* If the kind of i and j are different, then g77 cross-promoted the
724 kinds to the largest value. The Fortran 95 standard requires the
726 if (i
->ts
.kind
!= j
->ts
.kind
)
728 if (i
->ts
.kind
== gfc_kind_max (i
,j
))
729 gfc_convert_type(j
, &i
->ts
, 2);
731 gfc_convert_type(i
, &j
->ts
, 2);
735 f
->value
.function
.name
= gfc_get_string ("__ieor_%d", i
->ts
.kind
);
740 gfc_resolve_ior (gfc_expr
* f
, gfc_expr
* i
, gfc_expr
* j
)
742 /* If the kind of i and j are different, then g77 cross-promoted the
743 kinds to the largest value. The Fortran 95 standard requires the
745 if (i
->ts
.kind
!= j
->ts
.kind
)
747 if (i
->ts
.kind
== gfc_kind_max (i
,j
))
748 gfc_convert_type(j
, &i
->ts
, 2);
750 gfc_convert_type(i
, &j
->ts
, 2);
754 f
->value
.function
.name
= gfc_get_string ("__ior_%d", i
->ts
.kind
);
759 gfc_resolve_int (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
761 f
->ts
.type
= BT_INTEGER
;
762 f
->ts
.kind
= (kind
== NULL
) ? gfc_default_integer_kind
763 : mpz_get_si (kind
->value
.integer
);
765 f
->value
.function
.name
=
766 gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
, gfc_type_letter (a
->ts
.type
),
772 gfc_resolve_isatty (gfc_expr
* f
, gfc_expr
* u
)
776 f
->ts
.type
= BT_LOGICAL
;
777 f
->ts
.kind
= gfc_default_integer_kind
;
778 if (u
->ts
.kind
!= gfc_c_int_kind
)
780 ts
.type
= BT_INTEGER
;
781 ts
.kind
= gfc_c_int_kind
;
784 gfc_convert_type (u
, &ts
, 2);
787 f
->value
.function
.name
= gfc_get_string (PREFIX("isatty_l%d"), f
->ts
.kind
);
792 gfc_resolve_ishft (gfc_expr
* f
, gfc_expr
* i
, gfc_expr
* shift
)
795 f
->value
.function
.name
=
796 gfc_get_string ("__ishft_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
801 gfc_resolve_ishftc (gfc_expr
* f
, gfc_expr
* i
, gfc_expr
* shift
,
806 s_kind
= (size
== NULL
) ? gfc_default_integer_kind
: shift
->ts
.kind
;
809 f
->value
.function
.name
=
810 gfc_get_string ("__ishftc_%d_%d_%d", i
->ts
.kind
, shift
->ts
.kind
, s_kind
);
815 gfc_resolve_kill (gfc_expr
* f
, ATTRIBUTE_UNUSED gfc_expr
* p
,
816 ATTRIBUTE_UNUSED gfc_expr
* s
)
818 f
->ts
.type
= BT_INTEGER
;
819 f
->ts
.kind
= gfc_default_integer_kind
;
821 f
->value
.function
.name
= gfc_get_string (PREFIX("kill_i%d"), f
->ts
.kind
);
826 gfc_resolve_lbound (gfc_expr
* f
, gfc_expr
* array
,
829 static char lbound
[] = "__lbound";
831 f
->ts
.type
= BT_INTEGER
;
832 f
->ts
.kind
= gfc_default_integer_kind
;
837 f
->shape
= gfc_get_shape (1);
838 mpz_init_set_ui (f
->shape
[0], array
->rank
);
841 f
->value
.function
.name
= lbound
;
846 gfc_resolve_len (gfc_expr
* f
, gfc_expr
* string
)
848 f
->ts
.type
= BT_INTEGER
;
849 f
->ts
.kind
= gfc_default_integer_kind
;
850 f
->value
.function
.name
= gfc_get_string ("__len_%d", string
->ts
.kind
);
855 gfc_resolve_len_trim (gfc_expr
* f
, gfc_expr
* string
)
857 f
->ts
.type
= BT_INTEGER
;
858 f
->ts
.kind
= gfc_default_integer_kind
;
859 f
->value
.function
.name
= gfc_get_string ("__len_trim%d", string
->ts
.kind
);
864 gfc_resolve_link (gfc_expr
* f
, gfc_expr
* p1 ATTRIBUTE_UNUSED
,
865 gfc_expr
* p2 ATTRIBUTE_UNUSED
)
867 f
->ts
.type
= BT_INTEGER
;
868 f
->ts
.kind
= gfc_default_integer_kind
;
869 f
->value
.function
.name
= gfc_get_string (PREFIX("link_i%d"), f
->ts
.kind
);
874 gfc_resolve_loc (gfc_expr
*f
, gfc_expr
*x
)
876 f
->ts
.type
= BT_INTEGER
;
877 f
->ts
.kind
= gfc_index_integer_kind
;
878 f
->value
.function
.name
= gfc_get_string ("__loc_%d", x
->ts
.kind
);
883 gfc_resolve_log (gfc_expr
* f
, gfc_expr
* x
)
886 f
->value
.function
.name
=
887 gfc_get_string ("__log_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
892 gfc_resolve_log10 (gfc_expr
* f
, gfc_expr
* x
)
895 f
->value
.function
.name
=
896 gfc_get_string ("__log10_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
901 gfc_resolve_logical (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
903 f
->ts
.type
= BT_LOGICAL
;
904 f
->ts
.kind
= (kind
== NULL
) ? gfc_default_logical_kind
905 : mpz_get_si (kind
->value
.integer
);
908 f
->value
.function
.name
=
909 gfc_get_string ("__logical_%d_%c%d", f
->ts
.kind
,
910 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
915 gfc_resolve_matmul (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* b
)
919 if (a
->ts
.type
== BT_LOGICAL
&& b
->ts
.type
== BT_LOGICAL
)
921 f
->ts
.type
= BT_LOGICAL
;
922 f
->ts
.kind
= gfc_default_logical_kind
;
926 temp
.expr_type
= EXPR_OP
;
927 gfc_clear_ts (&temp
.ts
);
928 temp
.value
.op
.operator = INTRINSIC_NONE
;
929 temp
.value
.op
.op1
= a
;
930 temp
.value
.op
.op2
= b
;
931 gfc_type_convert_binary (&temp
);
935 f
->rank
= (a
->rank
== 2 && b
->rank
== 2) ? 2 : 1;
937 f
->value
.function
.name
=
938 gfc_get_string (PREFIX("matmul_%c%d"), gfc_type_letter (f
->ts
.type
),
944 gfc_resolve_minmax (const char * name
, gfc_expr
* f
, gfc_actual_arglist
* args
)
946 gfc_actual_arglist
*a
;
948 f
->ts
.type
= args
->expr
->ts
.type
;
949 f
->ts
.kind
= args
->expr
->ts
.kind
;
950 /* Find the largest type kind. */
951 for (a
= args
->next
; a
; a
= a
->next
)
953 if (a
->expr
->ts
.kind
> f
->ts
.kind
)
954 f
->ts
.kind
= a
->expr
->ts
.kind
;
957 /* Convert all parameters to the required kind. */
958 for (a
= args
; a
; a
= a
->next
)
960 if (a
->expr
->ts
.kind
!= f
->ts
.kind
)
961 gfc_convert_type (a
->expr
, &f
->ts
, 2);
964 f
->value
.function
.name
=
965 gfc_get_string (name
, gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
970 gfc_resolve_max (gfc_expr
* f
, gfc_actual_arglist
* args
)
972 gfc_resolve_minmax ("__max_%c%d", f
, args
);
977 gfc_resolve_maxloc (gfc_expr
* f
, gfc_expr
* array
, gfc_expr
* dim
,
982 f
->ts
.type
= BT_INTEGER
;
983 f
->ts
.kind
= gfc_default_integer_kind
;
989 f
->rank
= array
->rank
- 1;
990 gfc_resolve_dim_arg (dim
);
993 name
= mask
? "mmaxloc" : "maxloc";
994 f
->value
.function
.name
=
995 gfc_get_string (PREFIX("%s%d_%d_%c%d"), name
, dim
!= NULL
, f
->ts
.kind
,
996 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1001 gfc_resolve_maxval (gfc_expr
* f
, gfc_expr
* array
, gfc_expr
* dim
,
1008 f
->rank
= array
->rank
- 1;
1009 gfc_resolve_dim_arg (dim
);
1012 f
->value
.function
.name
=
1013 gfc_get_string (PREFIX("%s_%c%d"), mask
? "mmaxval" : "maxval",
1014 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1019 gfc_resolve_merge (gfc_expr
* f
, gfc_expr
* tsource
,
1020 gfc_expr
* fsource ATTRIBUTE_UNUSED
,
1021 gfc_expr
* mask ATTRIBUTE_UNUSED
)
1023 if (tsource
->ts
.type
== BT_CHARACTER
)
1024 check_charlen_present (tsource
);
1026 f
->ts
= tsource
->ts
;
1027 f
->value
.function
.name
=
1028 gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource
->ts
.type
),
1034 gfc_resolve_min (gfc_expr
* f
, gfc_actual_arglist
* args
)
1036 gfc_resolve_minmax ("__min_%c%d", f
, args
);
1041 gfc_resolve_minloc (gfc_expr
* f
, gfc_expr
* array
, gfc_expr
* dim
,
1046 f
->ts
.type
= BT_INTEGER
;
1047 f
->ts
.kind
= gfc_default_integer_kind
;
1053 f
->rank
= array
->rank
- 1;
1054 gfc_resolve_dim_arg (dim
);
1057 name
= mask
? "mminloc" : "minloc";
1058 f
->value
.function
.name
=
1059 gfc_get_string (PREFIX("%s%d_%d_%c%d"), name
, dim
!= NULL
, f
->ts
.kind
,
1060 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1065 gfc_resolve_minval (gfc_expr
* f
, gfc_expr
* array
, gfc_expr
* dim
,
1072 f
->rank
= array
->rank
- 1;
1073 gfc_resolve_dim_arg (dim
);
1076 f
->value
.function
.name
=
1077 gfc_get_string (PREFIX("%s_%c%d"), mask
? "mminval" : "minval",
1078 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1083 gfc_resolve_mod (gfc_expr
* f
, gfc_expr
* a
,
1084 gfc_expr
* p ATTRIBUTE_UNUSED
)
1087 f
->value
.function
.name
=
1088 gfc_get_string ("__mod_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1093 gfc_resolve_modulo (gfc_expr
* f
, gfc_expr
* a
,
1094 gfc_expr
* p ATTRIBUTE_UNUSED
)
1097 f
->value
.function
.name
=
1098 gfc_get_string ("__modulo_%c%d", gfc_type_letter (a
->ts
.type
),
1103 gfc_resolve_nearest (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
*p ATTRIBUTE_UNUSED
)
1106 f
->value
.function
.name
=
1107 gfc_get_string ("__nearest_%c%d", gfc_type_letter (a
->ts
.type
),
1112 gfc_resolve_nint (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
1114 f
->ts
.type
= BT_INTEGER
;
1115 f
->ts
.kind
= (kind
== NULL
) ? gfc_default_integer_kind
1116 : mpz_get_si (kind
->value
.integer
);
1118 f
->value
.function
.name
=
1119 gfc_get_string ("__nint_%d_%d", f
->ts
.kind
, a
->ts
.kind
);
1124 gfc_resolve_not (gfc_expr
* f
, gfc_expr
* i
)
1127 f
->value
.function
.name
= gfc_get_string ("__not_%d", i
->ts
.kind
);
1132 gfc_resolve_pack (gfc_expr
* f
, gfc_expr
* array
, gfc_expr
* mask
,
1133 gfc_expr
* vector ATTRIBUTE_UNUSED
)
1138 if (mask
->rank
!= 0)
1139 f
->value
.function
.name
= (array
->ts
.type
== BT_CHARACTER
1140 ? PREFIX("pack_char")
1144 /* We convert mask to default logical only in the scalar case.
1145 In the array case we can simply read the array as if it were
1146 of type default logical. */
1147 if (mask
->ts
.kind
!= gfc_default_logical_kind
)
1151 ts
.type
= BT_LOGICAL
;
1152 ts
.kind
= gfc_default_logical_kind
;
1153 gfc_convert_type (mask
, &ts
, 2);
1156 f
->value
.function
.name
= (array
->ts
.type
== BT_CHARACTER
1157 ? PREFIX("pack_s_char")
1158 : PREFIX("pack_s"));
1164 gfc_resolve_product (gfc_expr
* f
, gfc_expr
* array
, gfc_expr
* dim
,
1171 f
->rank
= array
->rank
- 1;
1172 gfc_resolve_dim_arg (dim
);
1175 f
->value
.function
.name
=
1176 gfc_get_string (PREFIX("%s_%c%d"), mask
? "mproduct" : "product",
1177 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1182 gfc_resolve_real (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
1184 f
->ts
.type
= BT_REAL
;
1187 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1189 f
->ts
.kind
= (a
->ts
.type
== BT_COMPLEX
) ?
1190 a
->ts
.kind
: gfc_default_real_kind
;
1192 f
->value
.function
.name
=
1193 gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
1194 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1199 gfc_resolve_realpart (gfc_expr
* f
, gfc_expr
* a
)
1201 f
->ts
.type
= BT_REAL
;
1202 f
->ts
.kind
= a
->ts
.kind
;
1203 f
->value
.function
.name
=
1204 gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
1205 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1210 gfc_resolve_rename (gfc_expr
* f
, gfc_expr
* p1 ATTRIBUTE_UNUSED
,
1211 gfc_expr
* p2 ATTRIBUTE_UNUSED
)
1213 f
->ts
.type
= BT_INTEGER
;
1214 f
->ts
.kind
= gfc_default_integer_kind
;
1215 f
->value
.function
.name
= gfc_get_string (PREFIX("rename_i%d"), f
->ts
.kind
);
1220 gfc_resolve_repeat (gfc_expr
* f
, gfc_expr
* string
,
1221 gfc_expr
* ncopies ATTRIBUTE_UNUSED
)
1223 f
->ts
.type
= BT_CHARACTER
;
1224 f
->ts
.kind
= string
->ts
.kind
;
1225 f
->value
.function
.name
= gfc_get_string ("__repeat_%d", string
->ts
.kind
);
1230 gfc_resolve_reshape (gfc_expr
* f
, gfc_expr
* source
, gfc_expr
* shape
,
1231 gfc_expr
* pad ATTRIBUTE_UNUSED
,
1232 gfc_expr
* order ATTRIBUTE_UNUSED
)
1240 gfc_array_size (shape
, &rank
);
1241 f
->rank
= mpz_get_si (rank
);
1243 switch (source
->ts
.type
)
1246 kind
= source
->ts
.kind
* 2;
1252 kind
= source
->ts
.kind
;
1266 if (source
->ts
.type
== BT_COMPLEX
)
1267 f
->value
.function
.name
=
1268 gfc_get_string (PREFIX("reshape_%c%d"),
1269 gfc_type_letter (BT_COMPLEX
), source
->ts
.kind
);
1271 f
->value
.function
.name
=
1272 gfc_get_string (PREFIX("reshape_%d"), source
->ts
.kind
);
1277 f
->value
.function
.name
= (source
->ts
.type
== BT_CHARACTER
1278 ? PREFIX("reshape_char")
1279 : PREFIX("reshape"));
1283 /* TODO: Make this work with a constant ORDER parameter. */
1284 if (shape
->expr_type
== EXPR_ARRAY
1285 && gfc_is_constant_expr (shape
)
1289 f
->shape
= gfc_get_shape (f
->rank
);
1290 c
= shape
->value
.constructor
;
1291 for (i
= 0; i
< f
->rank
; i
++)
1293 mpz_init_set (f
->shape
[i
], c
->expr
->value
.integer
);
1298 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
1299 so many runtime variations. */
1300 if (shape
->ts
.kind
!= gfc_index_integer_kind
)
1302 gfc_typespec ts
= shape
->ts
;
1303 ts
.kind
= gfc_index_integer_kind
;
1304 gfc_convert_type_warn (shape
, &ts
, 2, 0);
1306 if (order
&& order
->ts
.kind
!= gfc_index_integer_kind
)
1307 gfc_convert_type_warn (order
, &shape
->ts
, 2, 0);
1312 gfc_resolve_rrspacing (gfc_expr
* f
, gfc_expr
* x
)
1315 f
->value
.function
.name
= gfc_get_string ("__rrspacing_%d", x
->ts
.kind
);
1320 gfc_resolve_scale (gfc_expr
* f
, gfc_expr
* x
, gfc_expr
* i
)
1324 /* The implementation calls scalbn which takes an int as the
1326 if (i
->ts
.kind
!= gfc_c_int_kind
)
1330 ts
.type
= BT_INTEGER
;
1331 ts
.kind
= gfc_default_integer_kind
;
1333 gfc_convert_type_warn (i
, &ts
, 2, 0);
1336 f
->value
.function
.name
= gfc_get_string ("__scale_%d", x
->ts
.kind
);
1341 gfc_resolve_scan (gfc_expr
* f
, gfc_expr
* string
,
1342 gfc_expr
* set ATTRIBUTE_UNUSED
,
1343 gfc_expr
* back ATTRIBUTE_UNUSED
)
1345 f
->ts
.type
= BT_INTEGER
;
1346 f
->ts
.kind
= gfc_default_integer_kind
;
1347 f
->value
.function
.name
= gfc_get_string ("__scan_%d", string
->ts
.kind
);
1352 gfc_resolve_set_exponent (gfc_expr
* f
, gfc_expr
* x
, gfc_expr
* i
)
1356 /* The library implementation uses GFC_INTEGER_4 unconditionally,
1357 convert type so we don't have to implement all possible
1359 if (i
->ts
.kind
!= 4)
1363 ts
.type
= BT_INTEGER
;
1364 ts
.kind
= gfc_default_integer_kind
;
1366 gfc_convert_type_warn (i
, &ts
, 2, 0);
1369 f
->value
.function
.name
= gfc_get_string ("__set_exponent_%d", x
->ts
.kind
);
1374 gfc_resolve_shape (gfc_expr
* f
, gfc_expr
* array
)
1376 f
->ts
.type
= BT_INTEGER
;
1377 f
->ts
.kind
= gfc_default_integer_kind
;
1379 f
->value
.function
.name
= gfc_get_string (PREFIX("shape_%d"), f
->ts
.kind
);
1380 f
->shape
= gfc_get_shape (1);
1381 mpz_init_set_ui (f
->shape
[0], array
->rank
);
1386 gfc_resolve_sign (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* b ATTRIBUTE_UNUSED
)
1389 f
->value
.function
.name
=
1390 gfc_get_string ("__sign_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1395 gfc_resolve_sin (gfc_expr
* f
, gfc_expr
* x
)
1398 f
->value
.function
.name
=
1399 gfc_get_string ("__sin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1404 gfc_resolve_sinh (gfc_expr
* f
, gfc_expr
* x
)
1407 f
->value
.function
.name
=
1408 gfc_get_string ("__sinh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1413 gfc_resolve_spacing (gfc_expr
* f
, gfc_expr
* x
)
1416 f
->value
.function
.name
= gfc_get_string ("__spacing_%d", x
->ts
.kind
);
1421 gfc_resolve_spread (gfc_expr
* f
, gfc_expr
* source
,
1425 if (source
->ts
.type
== BT_CHARACTER
)
1426 check_charlen_present (source
);
1429 f
->rank
= source
->rank
+ 1;
1430 if (source
->rank
== 0)
1431 f
->value
.function
.name
= (source
->ts
.type
== BT_CHARACTER
1432 ? PREFIX("spread_char_scalar")
1433 : PREFIX("spread_scalar"));
1435 f
->value
.function
.name
= (source
->ts
.type
== BT_CHARACTER
1436 ? PREFIX("spread_char")
1437 : PREFIX("spread"));
1439 gfc_resolve_dim_arg (dim
);
1440 gfc_resolve_index (ncopies
, 1);
1445 gfc_resolve_sqrt (gfc_expr
* f
, gfc_expr
* x
)
1448 f
->value
.function
.name
=
1449 gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1453 /* Resolve the g77 compatibility function STAT AND FSTAT. */
1456 gfc_resolve_stat (gfc_expr
* f
, gfc_expr
* n ATTRIBUTE_UNUSED
,
1457 gfc_expr
* a ATTRIBUTE_UNUSED
)
1459 f
->ts
.type
= BT_INTEGER
;
1460 f
->ts
.kind
= gfc_default_integer_kind
;
1461 f
->value
.function
.name
= gfc_get_string (PREFIX("stat_i%d"), f
->ts
.kind
);
1466 gfc_resolve_fstat (gfc_expr
* f
, gfc_expr
* n
, gfc_expr
* a ATTRIBUTE_UNUSED
)
1468 f
->ts
.type
= BT_INTEGER
;
1469 f
->ts
.kind
= gfc_default_integer_kind
;
1470 if (n
->ts
.kind
!= f
->ts
.kind
)
1471 gfc_convert_type (n
, &f
->ts
, 2);
1473 f
->value
.function
.name
= gfc_get_string (PREFIX("fstat_i%d"), f
->ts
.kind
);
1478 gfc_resolve_sum (gfc_expr
* f
, gfc_expr
* array
, gfc_expr
* dim
,
1485 f
->rank
= array
->rank
- 1;
1486 gfc_resolve_dim_arg (dim
);
1489 f
->value
.function
.name
=
1490 gfc_get_string (PREFIX("%s_%c%d"), mask
? "msum" : "sum",
1491 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1496 gfc_resolve_symlnk (gfc_expr
* f
, gfc_expr
* p1 ATTRIBUTE_UNUSED
,
1497 gfc_expr
* p2 ATTRIBUTE_UNUSED
)
1499 f
->ts
.type
= BT_INTEGER
;
1500 f
->ts
.kind
= gfc_default_integer_kind
;
1501 f
->value
.function
.name
= gfc_get_string (PREFIX("symlnk_i%d"), f
->ts
.kind
);
1505 /* Resolve the g77 compatibility function SYSTEM. */
1508 gfc_resolve_system (gfc_expr
* f
, gfc_expr
* n ATTRIBUTE_UNUSED
)
1510 f
->ts
.type
= BT_INTEGER
;
1512 f
->value
.function
.name
= gfc_get_string (PREFIX("system"));
1517 gfc_resolve_tan (gfc_expr
* f
, gfc_expr
* x
)
1520 f
->value
.function
.name
=
1521 gfc_get_string ("__tan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1526 gfc_resolve_tanh (gfc_expr
* f
, gfc_expr
* x
)
1529 f
->value
.function
.name
=
1530 gfc_get_string ("__tanh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1535 gfc_resolve_time (gfc_expr
* f
)
1537 f
->ts
.type
= BT_INTEGER
;
1539 f
->value
.function
.name
= gfc_get_string (PREFIX("time_func"));
1544 gfc_resolve_time8 (gfc_expr
* f
)
1546 f
->ts
.type
= BT_INTEGER
;
1548 f
->value
.function
.name
= gfc_get_string (PREFIX("time8_func"));
1553 gfc_resolve_transfer (gfc_expr
* f
, gfc_expr
* source ATTRIBUTE_UNUSED
,
1554 gfc_expr
* mold
, gfc_expr
* size
)
1556 /* TODO: Make this do something meaningful. */
1557 static char transfer0
[] = "__transfer0", transfer1
[] = "__transfer1";
1561 if (size
== NULL
&& mold
->rank
== 0)
1564 f
->value
.function
.name
= transfer0
;
1569 f
->value
.function
.name
= transfer1
;
1575 gfc_resolve_transpose (gfc_expr
* f
, gfc_expr
* matrix
)
1583 f
->shape
= gfc_get_shape (2);
1584 mpz_init_set (f
->shape
[0], matrix
->shape
[1]);
1585 mpz_init_set (f
->shape
[1], matrix
->shape
[0]);
1588 kind
= matrix
->ts
.kind
;
1596 switch (matrix
->ts
.type
)
1599 f
->value
.function
.name
=
1600 gfc_get_string (PREFIX("transpose_c%d"), kind
);
1606 /* Use the integer routines for real and logical cases. This
1607 assumes they all have the same alignment requirements. */
1608 f
->value
.function
.name
=
1609 gfc_get_string (PREFIX("transpose_i%d"), kind
);
1613 f
->value
.function
.name
= PREFIX("transpose");
1619 f
->value
.function
.name
= (matrix
->ts
.type
== BT_CHARACTER
1620 ? PREFIX("transpose_char")
1621 : PREFIX("transpose"));
1628 gfc_resolve_trim (gfc_expr
* f
, gfc_expr
* string
)
1630 f
->ts
.type
= BT_CHARACTER
;
1631 f
->ts
.kind
= string
->ts
.kind
;
1632 f
->value
.function
.name
= gfc_get_string ("__trim_%d", string
->ts
.kind
);
1637 gfc_resolve_ubound (gfc_expr
* f
, gfc_expr
* array
,
1640 static char ubound
[] = "__ubound";
1642 f
->ts
.type
= BT_INTEGER
;
1643 f
->ts
.kind
= gfc_default_integer_kind
;
1648 f
->shape
= gfc_get_shape (1);
1649 mpz_init_set_ui (f
->shape
[0], array
->rank
);
1652 f
->value
.function
.name
= ubound
;
1656 /* Resolve the g77 compatibility function UMASK. */
1659 gfc_resolve_umask (gfc_expr
* f
, gfc_expr
* n
)
1661 f
->ts
.type
= BT_INTEGER
;
1662 f
->ts
.kind
= n
->ts
.kind
;
1663 f
->value
.function
.name
= gfc_get_string (PREFIX("umask_i%d"), n
->ts
.kind
);
1667 /* Resolve the g77 compatibility function UNLINK. */
1670 gfc_resolve_unlink (gfc_expr
* f
, gfc_expr
* n ATTRIBUTE_UNUSED
)
1672 f
->ts
.type
= BT_INTEGER
;
1674 f
->value
.function
.name
= gfc_get_string (PREFIX("unlink"));
1678 gfc_resolve_unpack (gfc_expr
* f
, gfc_expr
* vector
, gfc_expr
* mask
,
1679 gfc_expr
* field ATTRIBUTE_UNUSED
)
1682 f
->rank
= mask
->rank
;
1684 f
->value
.function
.name
=
1685 gfc_get_string (PREFIX("unpack%d%s"), field
->rank
> 0 ? 1 : 0,
1686 vector
->ts
.type
== BT_CHARACTER
? "_char" : "");
1691 gfc_resolve_verify (gfc_expr
* f
, gfc_expr
* string
,
1692 gfc_expr
* set ATTRIBUTE_UNUSED
,
1693 gfc_expr
* back ATTRIBUTE_UNUSED
)
1695 f
->ts
.type
= BT_INTEGER
;
1696 f
->ts
.kind
= gfc_default_integer_kind
;
1697 f
->value
.function
.name
= gfc_get_string ("__verify_%d", string
->ts
.kind
);
1701 /* Intrinsic subroutine resolution. */
1704 gfc_resolve_cpu_time (gfc_code
* c ATTRIBUTE_UNUSED
)
1708 name
= gfc_get_string (PREFIX("cpu_time_%d"),
1709 c
->ext
.actual
->expr
->ts
.kind
);
1710 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1715 gfc_resolve_mvbits (gfc_code
* c
)
1720 kind
= c
->ext
.actual
->expr
->ts
.kind
;
1721 name
= gfc_get_string (PREFIX("mvbits_i%d"), kind
);
1723 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1728 gfc_resolve_random_number (gfc_code
* c ATTRIBUTE_UNUSED
)
1733 kind
= c
->ext
.actual
->expr
->ts
.kind
;
1734 if (c
->ext
.actual
->expr
->rank
== 0)
1735 name
= gfc_get_string (PREFIX("random_r%d"), kind
);
1737 name
= gfc_get_string (PREFIX("arandom_r%d"), kind
);
1739 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1744 gfc_resolve_rename_sub (gfc_code
* c
)
1749 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
1750 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
1752 kind
= gfc_default_integer_kind
;
1754 name
= gfc_get_string (PREFIX("rename_i%d_sub"), kind
);
1755 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1760 gfc_resolve_kill_sub (gfc_code
* c
)
1765 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
1766 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
1768 kind
= gfc_default_integer_kind
;
1770 name
= gfc_get_string (PREFIX("kill_i%d_sub"), kind
);
1771 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1776 gfc_resolve_link_sub (gfc_code
* c
)
1781 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
1782 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
1784 kind
= gfc_default_integer_kind
;
1786 name
= gfc_get_string (PREFIX("link_i%d_sub"), kind
);
1787 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1792 gfc_resolve_symlnk_sub (gfc_code
* c
)
1797 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
1798 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
1800 kind
= gfc_default_integer_kind
;
1802 name
= gfc_get_string (PREFIX("symlnk_i%d_sub"), kind
);
1803 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1807 /* G77 compatibility subroutines etime() and dtime(). */
1810 gfc_resolve_etime_sub (gfc_code
* c
)
1814 name
= gfc_get_string (PREFIX("etime_sub"));
1815 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1819 /* G77 compatibility subroutine second(). */
1822 gfc_resolve_second_sub (gfc_code
* c
)
1826 name
= gfc_get_string (PREFIX("second_sub"));
1827 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1832 gfc_resolve_sleep_sub (gfc_code
* c
)
1837 if (c
->ext
.actual
->expr
!= NULL
)
1838 kind
= c
->ext
.actual
->expr
->ts
.kind
;
1840 kind
= gfc_default_integer_kind
;
1842 name
= gfc_get_string (PREFIX("sleep_i%d_sub"), kind
);
1843 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1847 /* G77 compatibility function srand(). */
1850 gfc_resolve_srand (gfc_code
* c
)
1853 name
= gfc_get_string (PREFIX("srand"));
1854 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1858 /* Resolve the getarg intrinsic subroutine. */
1861 gfc_resolve_getarg (gfc_code
* c
)
1866 kind
= gfc_default_integer_kind
;
1867 name
= gfc_get_string (PREFIX("getarg_i%d"), kind
);
1868 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1871 /* Resolve the getcwd intrinsic subroutine. */
1874 gfc_resolve_getcwd_sub (gfc_code
* c
)
1879 if (c
->ext
.actual
->next
->expr
!= NULL
)
1880 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
1882 kind
= gfc_default_integer_kind
;
1884 name
= gfc_get_string (PREFIX("getcwd_i%d_sub"), kind
);
1885 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1889 /* Resolve the get_command intrinsic subroutine. */
1892 gfc_resolve_get_command (gfc_code
* c
)
1897 kind
= gfc_default_integer_kind
;
1898 name
= gfc_get_string (PREFIX("get_command_i%d"), kind
);
1899 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1903 /* Resolve the get_command_argument intrinsic subroutine. */
1906 gfc_resolve_get_command_argument (gfc_code
* c
)
1911 kind
= gfc_default_integer_kind
;
1912 name
= gfc_get_string (PREFIX("get_command_argument_i%d"), kind
);
1913 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1916 /* Resolve the get_environment_variable intrinsic subroutine. */
1919 gfc_resolve_get_environment_variable (gfc_code
* code
)
1924 kind
= gfc_default_integer_kind
;
1925 name
= gfc_get_string (PREFIX("get_environment_variable_i%d"), kind
);
1926 code
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1929 /* Resolve the SYSTEM intrinsic subroutine. */
1932 gfc_resolve_system_sub (gfc_code
* c
)
1936 name
= gfc_get_string (PREFIX("system_sub"));
1937 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1940 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
1943 gfc_resolve_system_clock (gfc_code
* c
)
1948 if (c
->ext
.actual
->expr
!= NULL
)
1949 kind
= c
->ext
.actual
->expr
->ts
.kind
;
1950 else if (c
->ext
.actual
->next
->expr
!= NULL
)
1951 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
1952 else if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
1953 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
1955 kind
= gfc_default_integer_kind
;
1957 name
= gfc_get_string (PREFIX("system_clock_%d"), kind
);
1958 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1961 /* Resolve the EXIT intrinsic subroutine. */
1964 gfc_resolve_exit (gfc_code
* c
)
1969 if (c
->ext
.actual
->expr
!= NULL
)
1970 kind
= c
->ext
.actual
->expr
->ts
.kind
;
1972 kind
= gfc_default_integer_kind
;
1974 name
= gfc_get_string (PREFIX("exit_i%d"), kind
);
1975 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1978 /* Resolve the FLUSH intrinsic subroutine. */
1981 gfc_resolve_flush (gfc_code
* c
)
1987 ts
.type
= BT_INTEGER
;
1988 ts
.kind
= gfc_default_integer_kind
;
1989 n
= c
->ext
.actual
->expr
;
1991 && n
->ts
.kind
!= ts
.kind
)
1992 gfc_convert_type (n
, &ts
, 2);
1994 name
= gfc_get_string (PREFIX("flush_i%d"), ts
.kind
);
1995 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2000 gfc_resolve_gerror (gfc_code
* c
)
2002 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
2007 gfc_resolve_getlog (gfc_code
* c
)
2009 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
2014 gfc_resolve_hostnm_sub (gfc_code
* c
)
2019 if (c
->ext
.actual
->next
->expr
!= NULL
)
2020 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
2022 kind
= gfc_default_integer_kind
;
2024 name
= gfc_get_string (PREFIX("hostnm_i%d_sub"), kind
);
2025 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2030 gfc_resolve_perror (gfc_code
* c
)
2032 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
2035 /* Resolve the STAT and FSTAT intrinsic subroutines. */
2038 gfc_resolve_stat_sub (gfc_code
* c
)
2042 name
= gfc_get_string (PREFIX("stat_i%d_sub"), gfc_default_integer_kind
);
2043 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2048 gfc_resolve_fstat_sub (gfc_code
* c
)
2054 u
= c
->ext
.actual
->expr
;
2055 ts
= &c
->ext
.actual
->next
->expr
->ts
;
2056 if (u
->ts
.kind
!= ts
->kind
)
2057 gfc_convert_type (u
, ts
, 2);
2058 name
= gfc_get_string (PREFIX("fstat_i%d_sub"), ts
->kind
);
2059 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2064 gfc_resolve_ttynam_sub (gfc_code
* c
)
2068 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
2070 ts
.type
= BT_INTEGER
;
2071 ts
.kind
= gfc_c_int_kind
;
2074 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
2077 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX("ttynam_sub"));
2081 /* Resolve the UMASK intrinsic subroutine. */
2084 gfc_resolve_umask_sub (gfc_code
* c
)
2089 if (c
->ext
.actual
->next
->expr
!= NULL
)
2090 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
2092 kind
= gfc_default_integer_kind
;
2094 name
= gfc_get_string (PREFIX("umask_i%d_sub"), kind
);
2095 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2098 /* Resolve the UNLINK intrinsic subroutine. */
2101 gfc_resolve_unlink_sub (gfc_code
* c
)
2106 if (c
->ext
.actual
->next
->expr
!= NULL
)
2107 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
2109 kind
= gfc_default_integer_kind
;
2111 name
= gfc_get_string (PREFIX("unlink_i%d_sub"), kind
);
2112 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);