1 /* Intrinsic function resolution.
2 Copyright (C) 2000-2014 Free Software Foundation, Inc.
3 Contributed by Andy Vaught & Katherine Holcomb
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
22 /* Assign name and types to intrinsic procedures. For functions, the
23 first argument to a resolution function is an expression pointer to
24 the original function node and the rest are pointers to the
25 arguments of the function call. For subroutines, a pointer to the
26 code node is passed. The result type and library subroutine name
27 are generally set according to the function arguments. */
31 #include "coretypes.h"
33 #include "stringpool.h"
35 #include "intrinsic.h"
36 #include "constructor.h"
39 /* Given printf-like arguments, return a stable version of the result string.
41 We already have a working, optimized string hashing table in the form of
42 the identifier table. Reusing this table is likely not to be wasted,
43 since if the function name makes it to the gimple output of the frontend,
44 we'll have to create the identifier anyway. */
47 gfc_get_string (const char *format
, ...)
53 va_start (ap
, format
);
54 vsnprintf (temp_name
, sizeof (temp_name
), format
, ap
);
56 temp_name
[sizeof (temp_name
) - 1] = 0;
58 ident
= get_identifier (temp_name
);
59 return IDENTIFIER_POINTER (ident
);
62 /* MERGE and SPREAD need to have source charlen's present for passing
63 to the result expression. */
65 check_charlen_present (gfc_expr
*source
)
67 if (source
->ts
.u
.cl
== NULL
)
68 source
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
70 if (source
->expr_type
== EXPR_CONSTANT
)
72 source
->ts
.u
.cl
->length
73 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
74 source
->value
.character
.length
);
77 else if (source
->expr_type
== EXPR_ARRAY
)
79 gfc_constructor
*c
= gfc_constructor_first (source
->value
.constructor
);
80 source
->ts
.u
.cl
->length
81 = gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
82 c
->expr
->value
.character
.length
);
86 /* Helper function for resolving the "mask" argument. */
89 resolve_mask_arg (gfc_expr
*mask
)
97 /* For the scalar case, coerce the mask to kind=4 unconditionally
98 (because this is the only kind we have a library function
101 if (mask
->ts
.kind
!= 4)
103 ts
.type
= BT_LOGICAL
;
105 gfc_convert_type (mask
, &ts
, 2);
110 /* In the library, we access the mask with a GFC_LOGICAL_1
111 argument. No need to waste memory if we are about to create
112 a temporary array. */
113 if (mask
->expr_type
== EXPR_OP
&& mask
->ts
.kind
!= 1)
115 ts
.type
= BT_LOGICAL
;
117 gfc_convert_type_warn (mask
, &ts
, 2, 0);
124 resolve_bound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
,
125 const char *name
, bool coarray
)
127 f
->ts
.type
= BT_INTEGER
;
129 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
131 f
->ts
.kind
= gfc_default_integer_kind
;
136 if (array
->rank
!= -1)
138 f
->shape
= gfc_get_shape (1);
139 mpz_init_set_ui (f
->shape
[0], coarray
? gfc_get_corank (array
)
144 f
->value
.function
.name
= gfc_get_string (name
);
149 resolve_transformational (const char *name
, gfc_expr
*f
, gfc_expr
*array
,
150 gfc_expr
*dim
, gfc_expr
*mask
)
163 resolve_mask_arg (mask
);
170 f
->rank
= array
->rank
- 1;
171 f
->shape
= gfc_copy_shape_excluding (array
->shape
, array
->rank
, dim
);
172 gfc_resolve_dim_arg (dim
);
175 f
->value
.function
.name
176 = gfc_get_string (PREFIX ("%s%s_%c%d"), prefix
, name
,
177 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
181 /********************** Resolution functions **********************/
185 gfc_resolve_abs (gfc_expr
*f
, gfc_expr
*a
)
188 if (f
->ts
.type
== BT_COMPLEX
)
189 f
->ts
.type
= BT_REAL
;
191 f
->value
.function
.name
192 = gfc_get_string ("__abs_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
197 gfc_resolve_access (gfc_expr
*f
, gfc_expr
*name ATTRIBUTE_UNUSED
,
198 gfc_expr
*mode ATTRIBUTE_UNUSED
)
200 f
->ts
.type
= BT_INTEGER
;
201 f
->ts
.kind
= gfc_c_int_kind
;
202 f
->value
.function
.name
= PREFIX ("access_func");
207 gfc_resolve_adjustl (gfc_expr
*f
, gfc_expr
*string
)
209 f
->ts
.type
= BT_CHARACTER
;
210 f
->ts
.kind
= string
->ts
.kind
;
211 f
->value
.function
.name
= gfc_get_string ("__adjustl_s%d", f
->ts
.kind
);
216 gfc_resolve_adjustr (gfc_expr
*f
, gfc_expr
*string
)
218 f
->ts
.type
= BT_CHARACTER
;
219 f
->ts
.kind
= string
->ts
.kind
;
220 f
->value
.function
.name
= gfc_get_string ("__adjustr_s%d", f
->ts
.kind
);
225 gfc_resolve_char_achar (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*kind
,
228 f
->ts
.type
= BT_CHARACTER
;
229 f
->ts
.kind
= (kind
== NULL
)
230 ? gfc_default_character_kind
: mpz_get_si (kind
->value
.integer
);
231 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
232 f
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
234 f
->value
.function
.name
= gfc_get_string (name
, f
->ts
.kind
,
235 gfc_type_letter (x
->ts
.type
),
241 gfc_resolve_achar (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*kind
)
243 gfc_resolve_char_achar (f
, x
, kind
, "__achar_%d_%c%d");
248 gfc_resolve_acos (gfc_expr
*f
, gfc_expr
*x
)
251 f
->value
.function
.name
252 = gfc_get_string ("__acos_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
257 gfc_resolve_acosh (gfc_expr
*f
, gfc_expr
*x
)
260 f
->value
.function
.name
261 = gfc_get_string ("__acosh_%c%d", gfc_type_letter (x
->ts
.type
),
267 gfc_resolve_aimag (gfc_expr
*f
, gfc_expr
*x
)
269 f
->ts
.type
= BT_REAL
;
270 f
->ts
.kind
= x
->ts
.kind
;
271 f
->value
.function
.name
272 = gfc_get_string ("__aimag_%c%d", gfc_type_letter (x
->ts
.type
),
278 gfc_resolve_and (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
280 f
->ts
.type
= i
->ts
.type
;
281 f
->ts
.kind
= gfc_kind_max (i
, j
);
283 if (i
->ts
.kind
!= j
->ts
.kind
)
285 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
286 gfc_convert_type (j
, &i
->ts
, 2);
288 gfc_convert_type (i
, &j
->ts
, 2);
291 f
->value
.function
.name
292 = gfc_get_string ("__and_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
297 gfc_resolve_aint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
302 f
->ts
.type
= a
->ts
.type
;
303 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
305 if (a
->ts
.kind
!= f
->ts
.kind
)
307 ts
.type
= f
->ts
.type
;
308 ts
.kind
= f
->ts
.kind
;
309 gfc_convert_type (a
, &ts
, 2);
311 /* The resolved name is only used for specific intrinsics where
312 the return kind is the same as the arg kind. */
313 f
->value
.function
.name
314 = gfc_get_string ("__aint_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
319 gfc_resolve_dint (gfc_expr
*f
, gfc_expr
*a
)
321 gfc_resolve_aint (f
, a
, NULL
);
326 gfc_resolve_all (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
)
332 gfc_resolve_dim_arg (dim
);
333 f
->rank
= mask
->rank
- 1;
334 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
337 f
->value
.function
.name
338 = gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask
->ts
.type
),
344 gfc_resolve_anint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
349 f
->ts
.type
= a
->ts
.type
;
350 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
352 if (a
->ts
.kind
!= f
->ts
.kind
)
354 ts
.type
= f
->ts
.type
;
355 ts
.kind
= f
->ts
.kind
;
356 gfc_convert_type (a
, &ts
, 2);
359 /* The resolved name is only used for specific intrinsics where
360 the return kind is the same as the arg kind. */
361 f
->value
.function
.name
362 = gfc_get_string ("__anint_%c%d", gfc_type_letter (a
->ts
.type
),
368 gfc_resolve_dnint (gfc_expr
*f
, gfc_expr
*a
)
370 gfc_resolve_anint (f
, a
, NULL
);
375 gfc_resolve_any (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
)
381 gfc_resolve_dim_arg (dim
);
382 f
->rank
= mask
->rank
- 1;
383 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
386 f
->value
.function
.name
387 = gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask
->ts
.type
),
393 gfc_resolve_asin (gfc_expr
*f
, gfc_expr
*x
)
396 f
->value
.function
.name
397 = gfc_get_string ("__asin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
401 gfc_resolve_asinh (gfc_expr
*f
, gfc_expr
*x
)
404 f
->value
.function
.name
405 = gfc_get_string ("__asinh_%c%d", gfc_type_letter (x
->ts
.type
),
410 gfc_resolve_atan (gfc_expr
*f
, gfc_expr
*x
)
413 f
->value
.function
.name
414 = gfc_get_string ("__atan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
418 gfc_resolve_atanh (gfc_expr
*f
, gfc_expr
*x
)
421 f
->value
.function
.name
422 = gfc_get_string ("__atanh_%c%d", gfc_type_letter (x
->ts
.type
),
427 gfc_resolve_atan2 (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
430 f
->value
.function
.name
431 = gfc_get_string ("__atan2_%c%d", gfc_type_letter (x
->ts
.type
),
436 /* Resolve the BESYN and BESJN intrinsics. */
439 gfc_resolve_besn (gfc_expr
*f
, gfc_expr
*n
, gfc_expr
*x
)
445 if (n
->ts
.kind
!= gfc_c_int_kind
)
447 ts
.type
= BT_INTEGER
;
448 ts
.kind
= gfc_c_int_kind
;
449 gfc_convert_type (n
, &ts
, 2);
451 f
->value
.function
.name
= gfc_get_string ("<intrinsic>");
456 gfc_resolve_bessel_n2 (gfc_expr
*f
, gfc_expr
*n1
, gfc_expr
*n2
, gfc_expr
*x
)
463 if (n1
->expr_type
== EXPR_CONSTANT
&& n2
->expr_type
== EXPR_CONSTANT
)
465 f
->shape
= gfc_get_shape (1);
466 mpz_init (f
->shape
[0]);
467 mpz_sub (f
->shape
[0], n2
->value
.integer
, n1
->value
.integer
);
468 mpz_add_ui (f
->shape
[0], f
->shape
[0], 1);
471 if (n1
->ts
.kind
!= gfc_c_int_kind
)
473 ts
.type
= BT_INTEGER
;
474 ts
.kind
= gfc_c_int_kind
;
475 gfc_convert_type (n1
, &ts
, 2);
478 if (n2
->ts
.kind
!= gfc_c_int_kind
)
480 ts
.type
= BT_INTEGER
;
481 ts
.kind
= gfc_c_int_kind
;
482 gfc_convert_type (n2
, &ts
, 2);
485 if (f
->value
.function
.isym
->id
== GFC_ISYM_JN2
)
486 f
->value
.function
.name
= gfc_get_string (PREFIX ("bessel_jn_r%d"),
489 f
->value
.function
.name
= gfc_get_string (PREFIX ("bessel_yn_r%d"),
495 gfc_resolve_btest (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos
)
497 f
->ts
.type
= BT_LOGICAL
;
498 f
->ts
.kind
= gfc_default_logical_kind
;
499 f
->value
.function
.name
500 = gfc_get_string ("__btest_%d_%d", i
->ts
.kind
, pos
->ts
.kind
);
505 gfc_resolve_c_loc (gfc_expr
*f
, gfc_expr
*x ATTRIBUTE_UNUSED
)
507 f
->ts
= f
->value
.function
.isym
->ts
;
512 gfc_resolve_c_funloc (gfc_expr
*f
, gfc_expr
*x ATTRIBUTE_UNUSED
)
514 f
->ts
= f
->value
.function
.isym
->ts
;
519 gfc_resolve_ceiling (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
521 f
->ts
.type
= BT_INTEGER
;
522 f
->ts
.kind
= (kind
== NULL
)
523 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
524 f
->value
.function
.name
525 = gfc_get_string ("__ceiling_%d_%c%d", f
->ts
.kind
,
526 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
531 gfc_resolve_char (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
533 gfc_resolve_char_achar (f
, a
, kind
, "__char_%d_%c%d");
538 gfc_resolve_chdir (gfc_expr
*f
, gfc_expr
*d ATTRIBUTE_UNUSED
)
540 f
->ts
.type
= BT_INTEGER
;
541 f
->ts
.kind
= gfc_default_integer_kind
;
542 f
->value
.function
.name
= gfc_get_string (PREFIX ("chdir_i%d"), f
->ts
.kind
);
547 gfc_resolve_chdir_sub (gfc_code
*c
)
552 if (c
->ext
.actual
->next
->expr
!= NULL
)
553 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
555 kind
= gfc_default_integer_kind
;
557 name
= gfc_get_string (PREFIX ("chdir_i%d_sub"), kind
);
558 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
563 gfc_resolve_chmod (gfc_expr
*f
, gfc_expr
*name ATTRIBUTE_UNUSED
,
564 gfc_expr
*mode ATTRIBUTE_UNUSED
)
566 f
->ts
.type
= BT_INTEGER
;
567 f
->ts
.kind
= gfc_c_int_kind
;
568 f
->value
.function
.name
= PREFIX ("chmod_func");
573 gfc_resolve_chmod_sub (gfc_code
*c
)
578 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
579 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
581 kind
= gfc_default_integer_kind
;
583 name
= gfc_get_string (PREFIX ("chmod_i%d_sub"), kind
);
584 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
589 gfc_resolve_cmplx (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*kind
)
591 f
->ts
.type
= BT_COMPLEX
;
592 f
->ts
.kind
= (kind
== NULL
)
593 ? gfc_default_real_kind
: mpz_get_si (kind
->value
.integer
);
596 f
->value
.function
.name
597 = gfc_get_string ("__cmplx0_%d_%c%d", f
->ts
.kind
,
598 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
600 f
->value
.function
.name
601 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f
->ts
.kind
,
602 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
,
603 gfc_type_letter (y
->ts
.type
), y
->ts
.kind
);
608 gfc_resolve_dcmplx (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
)
610 gfc_resolve_cmplx (f
, x
, y
, gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
611 gfc_default_double_kind
));
616 gfc_resolve_complex (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
)
620 if (x
->ts
.type
== BT_INTEGER
)
622 if (y
->ts
.type
== BT_INTEGER
)
623 kind
= gfc_default_real_kind
;
629 if (y
->ts
.type
== BT_REAL
)
630 kind
= (x
->ts
.kind
> y
->ts
.kind
) ? x
->ts
.kind
: y
->ts
.kind
;
635 f
->ts
.type
= BT_COMPLEX
;
637 f
->value
.function
.name
638 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f
->ts
.kind
,
639 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
,
640 gfc_type_letter (y
->ts
.type
), y
->ts
.kind
);
645 gfc_resolve_conjg (gfc_expr
*f
, gfc_expr
*x
)
648 f
->value
.function
.name
= gfc_get_string ("__conjg_%d", x
->ts
.kind
);
653 gfc_resolve_cos (gfc_expr
*f
, gfc_expr
*x
)
656 f
->value
.function
.name
657 = gfc_get_string ("__cos_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
662 gfc_resolve_cosh (gfc_expr
*f
, gfc_expr
*x
)
665 f
->value
.function
.name
666 = gfc_get_string ("__cosh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
671 gfc_resolve_count (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
673 f
->ts
.type
= BT_INTEGER
;
675 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
677 f
->ts
.kind
= gfc_default_integer_kind
;
681 f
->rank
= mask
->rank
- 1;
682 gfc_resolve_dim_arg (dim
);
683 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
686 resolve_mask_arg (mask
);
688 f
->value
.function
.name
689 = gfc_get_string (PREFIX ("count_%d_%c"), f
->ts
.kind
,
690 gfc_type_letter (mask
->ts
.type
));
695 gfc_resolve_cshift (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*shift
,
700 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
701 gfc_resolve_substring_charlen (array
);
704 f
->rank
= array
->rank
;
705 f
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
712 /* If dim kind is greater than default integer we need to use the larger. */
713 m
= gfc_default_integer_kind
;
715 m
= m
< dim
->ts
.kind
? dim
->ts
.kind
: m
;
717 /* Convert shift to at least m, so we don't need
718 kind=1 and kind=2 versions of the library functions. */
719 if (shift
->ts
.kind
< m
)
723 ts
.type
= BT_INTEGER
;
725 gfc_convert_type_warn (shift
, &ts
, 2, 0);
730 if (dim
->expr_type
!= EXPR_CONSTANT
&& dim
->symtree
!= NULL
731 && dim
->symtree
->n
.sym
->attr
.optional
)
733 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
734 dim
->representation
.length
= shift
->ts
.kind
;
738 gfc_resolve_dim_arg (dim
);
739 /* Convert dim to shift's kind to reduce variations. */
740 if (dim
->ts
.kind
!= shift
->ts
.kind
)
741 gfc_convert_type_warn (dim
, &shift
->ts
, 2, 0);
745 if (array
->ts
.type
== BT_CHARACTER
)
747 if (array
->ts
.kind
== gfc_default_character_kind
)
748 f
->value
.function
.name
749 = gfc_get_string (PREFIX ("cshift%d_%d_char"), n
, shift
->ts
.kind
);
751 f
->value
.function
.name
752 = gfc_get_string (PREFIX ("cshift%d_%d_char%d"), n
, shift
->ts
.kind
,
756 f
->value
.function
.name
757 = gfc_get_string (PREFIX ("cshift%d_%d"), n
, shift
->ts
.kind
);
762 gfc_resolve_ctime (gfc_expr
*f
, gfc_expr
*time
)
767 f
->ts
.type
= BT_CHARACTER
;
768 f
->ts
.kind
= gfc_default_character_kind
;
770 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
771 if (time
->ts
.kind
!= 8)
773 ts
.type
= BT_INTEGER
;
777 gfc_convert_type (time
, &ts
, 2);
780 f
->value
.function
.name
= gfc_get_string (PREFIX ("ctime"));
785 gfc_resolve_dble (gfc_expr
*f
, gfc_expr
*a
)
787 f
->ts
.type
= BT_REAL
;
788 f
->ts
.kind
= gfc_default_double_kind
;
789 f
->value
.function
.name
790 = gfc_get_string ("__dble_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
795 gfc_resolve_dim (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
797 f
->ts
.type
= a
->ts
.type
;
799 f
->ts
.kind
= gfc_kind_max (a
,p
);
801 f
->ts
.kind
= a
->ts
.kind
;
803 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
805 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
806 gfc_convert_type (p
, &a
->ts
, 2);
808 gfc_convert_type (a
, &p
->ts
, 2);
811 f
->value
.function
.name
812 = gfc_get_string ("__dim_%c%d", gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
817 gfc_resolve_dot_product (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b
)
821 temp
.expr_type
= EXPR_OP
;
822 gfc_clear_ts (&temp
.ts
);
823 temp
.value
.op
.op
= INTRINSIC_NONE
;
824 temp
.value
.op
.op1
= a
;
825 temp
.value
.op
.op2
= b
;
826 gfc_type_convert_binary (&temp
, 1);
828 f
->value
.function
.name
829 = gfc_get_string (PREFIX ("dot_product_%c%d"),
830 gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
835 gfc_resolve_dprod (gfc_expr
*f
, gfc_expr
*a ATTRIBUTE_UNUSED
,
836 gfc_expr
*b ATTRIBUTE_UNUSED
)
838 f
->ts
.kind
= gfc_default_double_kind
;
839 f
->ts
.type
= BT_REAL
;
840 f
->value
.function
.name
= gfc_get_string ("__dprod_r%d", f
->ts
.kind
);
845 gfc_resolve_dshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j ATTRIBUTE_UNUSED
,
846 gfc_expr
*shift ATTRIBUTE_UNUSED
)
849 if (f
->value
.function
.isym
->id
== GFC_ISYM_DSHIFTL
)
850 f
->value
.function
.name
= gfc_get_string ("dshiftl_i%d", f
->ts
.kind
);
851 else if (f
->value
.function
.isym
->id
== GFC_ISYM_DSHIFTR
)
852 f
->value
.function
.name
= gfc_get_string ("dshiftr_i%d", f
->ts
.kind
);
859 gfc_resolve_eoshift (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*shift
,
860 gfc_expr
*boundary
, gfc_expr
*dim
)
864 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
865 gfc_resolve_substring_charlen (array
);
868 f
->rank
= array
->rank
;
869 f
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
874 if (boundary
&& boundary
->rank
> 0)
877 /* If dim kind is greater than default integer we need to use the larger. */
878 m
= gfc_default_integer_kind
;
880 m
= m
< dim
->ts
.kind
? dim
->ts
.kind
: m
;
882 /* Convert shift to at least m, so we don't need
883 kind=1 and kind=2 versions of the library functions. */
884 if (shift
->ts
.kind
< m
)
888 ts
.type
= BT_INTEGER
;
890 gfc_convert_type_warn (shift
, &ts
, 2, 0);
895 if (dim
->expr_type
!= EXPR_CONSTANT
&& dim
->symtree
!= NULL
896 && dim
->symtree
->n
.sym
->attr
.optional
)
898 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
899 dim
->representation
.length
= shift
->ts
.kind
;
903 gfc_resolve_dim_arg (dim
);
904 /* Convert dim to shift's kind to reduce variations. */
905 if (dim
->ts
.kind
!= shift
->ts
.kind
)
906 gfc_convert_type_warn (dim
, &shift
->ts
, 2, 0);
910 if (array
->ts
.type
== BT_CHARACTER
)
912 if (array
->ts
.kind
== gfc_default_character_kind
)
913 f
->value
.function
.name
914 = gfc_get_string (PREFIX ("eoshift%d_%d_char"), n
, shift
->ts
.kind
);
916 f
->value
.function
.name
917 = gfc_get_string (PREFIX ("eoshift%d_%d_char%d"), n
, shift
->ts
.kind
,
921 f
->value
.function
.name
922 = gfc_get_string (PREFIX ("eoshift%d_%d"), n
, shift
->ts
.kind
);
927 gfc_resolve_exp (gfc_expr
*f
, gfc_expr
*x
)
930 f
->value
.function
.name
931 = gfc_get_string ("__exp_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
936 gfc_resolve_exponent (gfc_expr
*f
, gfc_expr
*x
)
938 f
->ts
.type
= BT_INTEGER
;
939 f
->ts
.kind
= gfc_default_integer_kind
;
940 f
->value
.function
.name
= gfc_get_string ("__exponent_%d", x
->ts
.kind
);
944 /* Resolve the EXTENDS_TYPE_OF intrinsic function. */
947 gfc_resolve_extends_type_of (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*mo
)
952 /* Prevent double resolution. */
953 if (f
->ts
.type
== BT_LOGICAL
)
956 /* Replace the first argument with the corresponding vtab. */
957 if (a
->ts
.type
== BT_CLASS
)
958 gfc_add_vptr_component (a
);
959 else if (a
->ts
.type
== BT_DERIVED
)
961 vtab
= gfc_find_derived_vtab (a
->ts
.u
.derived
);
962 /* Clear the old expr. */
963 gfc_free_ref_list (a
->ref
);
964 memset (a
, '\0', sizeof (gfc_expr
));
965 /* Construct a new one. */
966 a
->expr_type
= EXPR_VARIABLE
;
967 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
972 /* Replace the second argument with the corresponding vtab. */
973 if (mo
->ts
.type
== BT_CLASS
)
974 gfc_add_vptr_component (mo
);
975 else if (mo
->ts
.type
== BT_DERIVED
)
977 vtab
= gfc_find_derived_vtab (mo
->ts
.u
.derived
);
978 /* Clear the old expr. */
979 gfc_free_ref_list (mo
->ref
);
980 memset (mo
, '\0', sizeof (gfc_expr
));
981 /* Construct a new one. */
982 mo
->expr_type
= EXPR_VARIABLE
;
983 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
988 f
->ts
.type
= BT_LOGICAL
;
991 f
->value
.function
.isym
->formal
->ts
= a
->ts
;
992 f
->value
.function
.isym
->formal
->next
->ts
= mo
->ts
;
994 /* Call library function. */
995 f
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
1000 gfc_resolve_fdate (gfc_expr
*f
)
1002 f
->ts
.type
= BT_CHARACTER
;
1003 f
->ts
.kind
= gfc_default_character_kind
;
1004 f
->value
.function
.name
= gfc_get_string (PREFIX ("fdate"));
1009 gfc_resolve_floor (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1011 f
->ts
.type
= BT_INTEGER
;
1012 f
->ts
.kind
= (kind
== NULL
)
1013 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
1014 f
->value
.function
.name
1015 = gfc_get_string ("__floor%d_%c%d", f
->ts
.kind
,
1016 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1021 gfc_resolve_fnum (gfc_expr
*f
, gfc_expr
*n
)
1023 f
->ts
.type
= BT_INTEGER
;
1024 f
->ts
.kind
= gfc_default_integer_kind
;
1025 if (n
->ts
.kind
!= f
->ts
.kind
)
1026 gfc_convert_type (n
, &f
->ts
, 2);
1027 f
->value
.function
.name
= gfc_get_string (PREFIX ("fnum_i%d"), f
->ts
.kind
);
1032 gfc_resolve_fraction (gfc_expr
*f
, gfc_expr
*x
)
1035 f
->value
.function
.name
= gfc_get_string ("__fraction_%d", x
->ts
.kind
);
1039 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
1042 gfc_resolve_g77_math1 (gfc_expr
*f
, gfc_expr
*x
)
1045 f
->value
.function
.name
= gfc_get_string ("<intrinsic>");
1050 gfc_resolve_gamma (gfc_expr
*f
, gfc_expr
*x
)
1053 f
->value
.function
.name
1054 = gfc_get_string ("__tgamma_%d", x
->ts
.kind
);
1059 gfc_resolve_getcwd (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
1061 f
->ts
.type
= BT_INTEGER
;
1063 f
->value
.function
.name
= gfc_get_string (PREFIX ("getcwd"));
1068 gfc_resolve_getgid (gfc_expr
*f
)
1070 f
->ts
.type
= BT_INTEGER
;
1072 f
->value
.function
.name
= gfc_get_string (PREFIX ("getgid"));
1077 gfc_resolve_getpid (gfc_expr
*f
)
1079 f
->ts
.type
= BT_INTEGER
;
1081 f
->value
.function
.name
= gfc_get_string (PREFIX ("getpid"));
1086 gfc_resolve_getuid (gfc_expr
*f
)
1088 f
->ts
.type
= BT_INTEGER
;
1090 f
->value
.function
.name
= gfc_get_string (PREFIX ("getuid"));
1095 gfc_resolve_hostnm (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
1097 f
->ts
.type
= BT_INTEGER
;
1099 f
->value
.function
.name
= gfc_get_string (PREFIX ("hostnm"));
1104 gfc_resolve_hypot (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
1107 f
->value
.function
.name
= gfc_get_string ("__hypot_r%d", x
->ts
.kind
);
1112 gfc_resolve_iall (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
1114 resolve_transformational ("iall", f
, array
, dim
, mask
);
1119 gfc_resolve_iand (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1121 /* If the kind of i and j are different, then g77 cross-promoted the
1122 kinds to the largest value. The Fortran 95 standard requires the
1124 if (i
->ts
.kind
!= j
->ts
.kind
)
1126 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1127 gfc_convert_type (j
, &i
->ts
, 2);
1129 gfc_convert_type (i
, &j
->ts
, 2);
1133 f
->value
.function
.name
= gfc_get_string ("__iand_%d", i
->ts
.kind
);
1138 gfc_resolve_iany (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
1140 resolve_transformational ("iany", f
, array
, dim
, mask
);
1145 gfc_resolve_ibclr (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
)
1148 f
->value
.function
.name
= gfc_get_string ("__ibclr_%d", i
->ts
.kind
);
1153 gfc_resolve_ibits (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
,
1154 gfc_expr
*len ATTRIBUTE_UNUSED
)
1157 f
->value
.function
.name
= gfc_get_string ("__ibits_%d", i
->ts
.kind
);
1162 gfc_resolve_ibset (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
)
1165 f
->value
.function
.name
= gfc_get_string ("__ibset_%d", i
->ts
.kind
);
1170 gfc_resolve_iachar (gfc_expr
*f
, gfc_expr
*c
, gfc_expr
*kind
)
1172 f
->ts
.type
= BT_INTEGER
;
1174 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1176 f
->ts
.kind
= gfc_default_integer_kind
;
1177 f
->value
.function
.name
= gfc_get_string ("__ichar_%d", c
->ts
.kind
);
1182 gfc_resolve_ichar (gfc_expr
*f
, gfc_expr
*c
, gfc_expr
*kind
)
1184 f
->ts
.type
= BT_INTEGER
;
1186 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1188 f
->ts
.kind
= gfc_default_integer_kind
;
1189 f
->value
.function
.name
= gfc_get_string ("__ichar_%d", c
->ts
.kind
);
1194 gfc_resolve_idnint (gfc_expr
*f
, gfc_expr
*a
)
1196 gfc_resolve_nint (f
, a
, NULL
);
1201 gfc_resolve_ierrno (gfc_expr
*f
)
1203 f
->ts
.type
= BT_INTEGER
;
1204 f
->ts
.kind
= gfc_default_integer_kind
;
1205 f
->value
.function
.name
= gfc_get_string (PREFIX ("ierrno_i%d"), f
->ts
.kind
);
1210 gfc_resolve_ieor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1212 /* If the kind of i and j are different, then g77 cross-promoted the
1213 kinds to the largest value. The Fortran 95 standard requires the
1215 if (i
->ts
.kind
!= j
->ts
.kind
)
1217 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1218 gfc_convert_type (j
, &i
->ts
, 2);
1220 gfc_convert_type (i
, &j
->ts
, 2);
1224 f
->value
.function
.name
= gfc_get_string ("__ieor_%d", i
->ts
.kind
);
1229 gfc_resolve_ior (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1231 /* If the kind of i and j are different, then g77 cross-promoted the
1232 kinds to the largest value. The Fortran 95 standard requires the
1234 if (i
->ts
.kind
!= j
->ts
.kind
)
1236 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1237 gfc_convert_type (j
, &i
->ts
, 2);
1239 gfc_convert_type (i
, &j
->ts
, 2);
1243 f
->value
.function
.name
= gfc_get_string ("__ior_%d", i
->ts
.kind
);
1248 gfc_resolve_index_func (gfc_expr
*f
, gfc_expr
*str
,
1249 gfc_expr
*sub_str ATTRIBUTE_UNUSED
, gfc_expr
*back
,
1255 f
->ts
.type
= BT_INTEGER
;
1257 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1259 f
->ts
.kind
= gfc_default_integer_kind
;
1261 if (back
&& back
->ts
.kind
!= gfc_default_integer_kind
)
1263 ts
.type
= BT_LOGICAL
;
1264 ts
.kind
= gfc_default_integer_kind
;
1265 ts
.u
.derived
= NULL
;
1267 gfc_convert_type (back
, &ts
, 2);
1270 f
->value
.function
.name
1271 = gfc_get_string ("__index_%d_i%d", str
->ts
.kind
, f
->ts
.kind
);
1276 gfc_resolve_int (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1278 f
->ts
.type
= BT_INTEGER
;
1279 f
->ts
.kind
= (kind
== NULL
)
1280 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
1281 f
->value
.function
.name
1282 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1283 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1288 gfc_resolve_int2 (gfc_expr
*f
, gfc_expr
*a
)
1290 f
->ts
.type
= BT_INTEGER
;
1292 f
->value
.function
.name
1293 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1294 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1299 gfc_resolve_int8 (gfc_expr
*f
, gfc_expr
*a
)
1301 f
->ts
.type
= BT_INTEGER
;
1303 f
->value
.function
.name
1304 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1305 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1310 gfc_resolve_long (gfc_expr
*f
, gfc_expr
*a
)
1312 f
->ts
.type
= BT_INTEGER
;
1314 f
->value
.function
.name
1315 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1316 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1321 gfc_resolve_iparity (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
1323 resolve_transformational ("iparity", f
, array
, dim
, mask
);
1328 gfc_resolve_isatty (gfc_expr
*f
, gfc_expr
*u
)
1333 f
->ts
.type
= BT_LOGICAL
;
1334 f
->ts
.kind
= gfc_default_integer_kind
;
1335 if (u
->ts
.kind
!= gfc_c_int_kind
)
1337 ts
.type
= BT_INTEGER
;
1338 ts
.kind
= gfc_c_int_kind
;
1339 ts
.u
.derived
= NULL
;
1341 gfc_convert_type (u
, &ts
, 2);
1344 f
->value
.function
.name
= gfc_get_string (PREFIX ("isatty_l%d"), f
->ts
.kind
);
1349 gfc_resolve_ishft (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1352 f
->value
.function
.name
1353 = gfc_get_string ("__ishft_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1358 gfc_resolve_rshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1361 f
->value
.function
.name
1362 = gfc_get_string ("__rshift_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1367 gfc_resolve_lshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1370 f
->value
.function
.name
1371 = gfc_get_string ("__lshift_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1376 gfc_resolve_ishftc (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
1380 s_kind
= (size
== NULL
) ? gfc_default_integer_kind
: size
->ts
.kind
;
1383 f
->value
.function
.name
1384 = gfc_get_string ("__ishftc_%d_%d_%d", i
->ts
.kind
, shift
->ts
.kind
, s_kind
);
1389 gfc_resolve_kill (gfc_expr
*f
, gfc_expr
*p ATTRIBUTE_UNUSED
,
1390 gfc_expr
*s ATTRIBUTE_UNUSED
)
1392 f
->ts
.type
= BT_INTEGER
;
1393 f
->ts
.kind
= gfc_default_integer_kind
;
1394 f
->value
.function
.name
= gfc_get_string (PREFIX ("kill_i%d"), f
->ts
.kind
);
1399 gfc_resolve_lbound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
1401 resolve_bound (f
, array
, dim
, kind
, "__lbound", false);
1406 gfc_resolve_lcobound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
1408 resolve_bound (f
, array
, dim
, kind
, "__lcobound", true);
1413 gfc_resolve_len (gfc_expr
*f
, gfc_expr
*string
, gfc_expr
*kind
)
1415 f
->ts
.type
= BT_INTEGER
;
1417 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1419 f
->ts
.kind
= gfc_default_integer_kind
;
1420 f
->value
.function
.name
1421 = gfc_get_string ("__len_%d_i%d", string
->ts
.kind
,
1422 gfc_default_integer_kind
);
1427 gfc_resolve_len_trim (gfc_expr
*f
, gfc_expr
*string
, gfc_expr
*kind
)
1429 f
->ts
.type
= BT_INTEGER
;
1431 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1433 f
->ts
.kind
= gfc_default_integer_kind
;
1434 f
->value
.function
.name
= gfc_get_string ("__len_trim%d", string
->ts
.kind
);
1439 gfc_resolve_lgamma (gfc_expr
*f
, gfc_expr
*x
)
1442 f
->value
.function
.name
1443 = gfc_get_string ("__lgamma_%d", x
->ts
.kind
);
1448 gfc_resolve_link (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
1449 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
1451 f
->ts
.type
= BT_INTEGER
;
1452 f
->ts
.kind
= gfc_default_integer_kind
;
1453 f
->value
.function
.name
= gfc_get_string (PREFIX ("link_i%d"), f
->ts
.kind
);
1458 gfc_resolve_loc (gfc_expr
*f
, gfc_expr
*x
)
1460 f
->ts
.type
= BT_INTEGER
;
1461 f
->ts
.kind
= gfc_index_integer_kind
;
1462 f
->value
.function
.name
= gfc_get_string ("__loc_%d", x
->ts
.kind
);
1467 gfc_resolve_log (gfc_expr
*f
, gfc_expr
*x
)
1470 f
->value
.function
.name
1471 = gfc_get_string ("__log_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1476 gfc_resolve_log10 (gfc_expr
*f
, gfc_expr
*x
)
1479 f
->value
.function
.name
1480 = gfc_get_string ("__log10_%c%d", gfc_type_letter (x
->ts
.type
),
1486 gfc_resolve_logical (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1488 f
->ts
.type
= BT_LOGICAL
;
1489 f
->ts
.kind
= (kind
== NULL
)
1490 ? gfc_default_logical_kind
: mpz_get_si (kind
->value
.integer
);
1493 f
->value
.function
.name
1494 = gfc_get_string ("__logical_%d_%c%d", f
->ts
.kind
,
1495 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1500 gfc_resolve_malloc (gfc_expr
*f
, gfc_expr
*size
)
1502 if (size
->ts
.kind
< gfc_index_integer_kind
)
1507 ts
.type
= BT_INTEGER
;
1508 ts
.kind
= gfc_index_integer_kind
;
1509 gfc_convert_type_warn (size
, &ts
, 2, 0);
1512 f
->ts
.type
= BT_INTEGER
;
1513 f
->ts
.kind
= gfc_index_integer_kind
;
1514 f
->value
.function
.name
= gfc_get_string (PREFIX ("malloc"));
1519 gfc_resolve_matmul (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b
)
1523 if (a
->ts
.type
== BT_LOGICAL
&& b
->ts
.type
== BT_LOGICAL
)
1525 f
->ts
.type
= BT_LOGICAL
;
1526 f
->ts
.kind
= gfc_default_logical_kind
;
1530 temp
.expr_type
= EXPR_OP
;
1531 gfc_clear_ts (&temp
.ts
);
1532 temp
.value
.op
.op
= INTRINSIC_NONE
;
1533 temp
.value
.op
.op1
= a
;
1534 temp
.value
.op
.op2
= b
;
1535 gfc_type_convert_binary (&temp
, 1);
1539 f
->rank
= (a
->rank
== 2 && b
->rank
== 2) ? 2 : 1;
1541 if (a
->rank
== 2 && b
->rank
== 2)
1543 if (a
->shape
&& b
->shape
)
1545 f
->shape
= gfc_get_shape (f
->rank
);
1546 mpz_init_set (f
->shape
[0], a
->shape
[0]);
1547 mpz_init_set (f
->shape
[1], b
->shape
[1]);
1550 else if (a
->rank
== 1)
1554 f
->shape
= gfc_get_shape (f
->rank
);
1555 mpz_init_set (f
->shape
[0], b
->shape
[1]);
1560 /* b->rank == 1 and a->rank == 2 here, all other cases have
1561 been caught in check.c. */
1564 f
->shape
= gfc_get_shape (f
->rank
);
1565 mpz_init_set (f
->shape
[0], a
->shape
[0]);
1569 f
->value
.function
.name
1570 = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f
->ts
.type
),
1576 gfc_resolve_minmax (const char *name
, gfc_expr
*f
, gfc_actual_arglist
*args
)
1578 gfc_actual_arglist
*a
;
1580 f
->ts
.type
= args
->expr
->ts
.type
;
1581 f
->ts
.kind
= args
->expr
->ts
.kind
;
1582 /* Find the largest type kind. */
1583 for (a
= args
->next
; a
; a
= a
->next
)
1585 if (a
->expr
->ts
.kind
> f
->ts
.kind
)
1586 f
->ts
.kind
= a
->expr
->ts
.kind
;
1589 /* Convert all parameters to the required kind. */
1590 for (a
= args
; a
; a
= a
->next
)
1592 if (a
->expr
->ts
.kind
!= f
->ts
.kind
)
1593 gfc_convert_type (a
->expr
, &f
->ts
, 2);
1596 f
->value
.function
.name
1597 = gfc_get_string (name
, gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
1602 gfc_resolve_max (gfc_expr
*f
, gfc_actual_arglist
*args
)
1604 gfc_resolve_minmax ("__max_%c%d", f
, args
);
1609 gfc_resolve_maxloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1615 f
->ts
.type
= BT_INTEGER
;
1616 f
->ts
.kind
= gfc_default_integer_kind
;
1621 f
->shape
= gfc_get_shape (1);
1622 mpz_init_set_si (f
->shape
[0], array
->rank
);
1626 f
->rank
= array
->rank
- 1;
1627 gfc_resolve_dim_arg (dim
);
1628 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1630 idim
= (int) mpz_get_si (dim
->value
.integer
);
1631 f
->shape
= gfc_get_shape (f
->rank
);
1632 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1634 if (i
== (idim
- 1))
1636 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1643 if (mask
->rank
== 0)
1648 resolve_mask_arg (mask
);
1653 f
->value
.function
.name
1654 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name
, dim
!= NULL
, f
->ts
.kind
,
1655 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1660 gfc_resolve_maxval (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1670 f
->rank
= array
->rank
- 1;
1671 gfc_resolve_dim_arg (dim
);
1673 if (f
->rank
&& array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1675 idim
= (int) mpz_get_si (dim
->value
.integer
);
1676 f
->shape
= gfc_get_shape (f
->rank
);
1677 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1679 if (i
== (idim
- 1))
1681 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1688 if (mask
->rank
== 0)
1693 resolve_mask_arg (mask
);
1698 f
->value
.function
.name
1699 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
1700 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1705 gfc_resolve_mclock (gfc_expr
*f
)
1707 f
->ts
.type
= BT_INTEGER
;
1709 f
->value
.function
.name
= PREFIX ("mclock");
1714 gfc_resolve_mclock8 (gfc_expr
*f
)
1716 f
->ts
.type
= BT_INTEGER
;
1718 f
->value
.function
.name
= PREFIX ("mclock8");
1723 gfc_resolve_mask (gfc_expr
*f
, gfc_expr
*i ATTRIBUTE_UNUSED
,
1726 f
->ts
.type
= BT_INTEGER
;
1727 f
->ts
.kind
= kind
? mpz_get_si (kind
->value
.integer
)
1728 : gfc_default_integer_kind
;
1730 if (f
->value
.function
.isym
->id
== GFC_ISYM_MASKL
)
1731 f
->value
.function
.name
= gfc_get_string ("__maskl_i%d", f
->ts
.kind
);
1733 f
->value
.function
.name
= gfc_get_string ("__maskr_i%d", f
->ts
.kind
);
1738 gfc_resolve_merge (gfc_expr
*f
, gfc_expr
*tsource
,
1739 gfc_expr
*fsource ATTRIBUTE_UNUSED
,
1740 gfc_expr
*mask ATTRIBUTE_UNUSED
)
1742 if (tsource
->ts
.type
== BT_CHARACTER
&& tsource
->ref
)
1743 gfc_resolve_substring_charlen (tsource
);
1745 if (fsource
->ts
.type
== BT_CHARACTER
&& fsource
->ref
)
1746 gfc_resolve_substring_charlen (fsource
);
1748 if (tsource
->ts
.type
== BT_CHARACTER
)
1749 check_charlen_present (tsource
);
1751 f
->ts
= tsource
->ts
;
1752 f
->value
.function
.name
1753 = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource
->ts
.type
),
1759 gfc_resolve_merge_bits (gfc_expr
*f
, gfc_expr
*i
,
1760 gfc_expr
*j ATTRIBUTE_UNUSED
,
1761 gfc_expr
*mask ATTRIBUTE_UNUSED
)
1764 f
->value
.function
.name
= gfc_get_string ("__merge_bits_i%d", i
->ts
.kind
);
1769 gfc_resolve_min (gfc_expr
*f
, gfc_actual_arglist
*args
)
1771 gfc_resolve_minmax ("__min_%c%d", f
, args
);
1776 gfc_resolve_minloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1782 f
->ts
.type
= BT_INTEGER
;
1783 f
->ts
.kind
= gfc_default_integer_kind
;
1788 f
->shape
= gfc_get_shape (1);
1789 mpz_init_set_si (f
->shape
[0], array
->rank
);
1793 f
->rank
= array
->rank
- 1;
1794 gfc_resolve_dim_arg (dim
);
1795 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1797 idim
= (int) mpz_get_si (dim
->value
.integer
);
1798 f
->shape
= gfc_get_shape (f
->rank
);
1799 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1801 if (i
== (idim
- 1))
1803 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1810 if (mask
->rank
== 0)
1815 resolve_mask_arg (mask
);
1820 f
->value
.function
.name
1821 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name
, dim
!= NULL
, f
->ts
.kind
,
1822 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1827 gfc_resolve_minval (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1837 f
->rank
= array
->rank
- 1;
1838 gfc_resolve_dim_arg (dim
);
1840 if (f
->rank
&& array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1842 idim
= (int) mpz_get_si (dim
->value
.integer
);
1843 f
->shape
= gfc_get_shape (f
->rank
);
1844 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1846 if (i
== (idim
- 1))
1848 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1855 if (mask
->rank
== 0)
1860 resolve_mask_arg (mask
);
1865 f
->value
.function
.name
1866 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
1867 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1872 gfc_resolve_mod (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
1874 f
->ts
.type
= a
->ts
.type
;
1876 f
->ts
.kind
= gfc_kind_max (a
,p
);
1878 f
->ts
.kind
= a
->ts
.kind
;
1880 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
1882 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
1883 gfc_convert_type (p
, &a
->ts
, 2);
1885 gfc_convert_type (a
, &p
->ts
, 2);
1888 f
->value
.function
.name
1889 = gfc_get_string ("__mod_%c%d", gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
1894 gfc_resolve_modulo (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
1896 f
->ts
.type
= a
->ts
.type
;
1898 f
->ts
.kind
= gfc_kind_max (a
,p
);
1900 f
->ts
.kind
= a
->ts
.kind
;
1902 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
1904 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
1905 gfc_convert_type (p
, &a
->ts
, 2);
1907 gfc_convert_type (a
, &p
->ts
, 2);
1910 f
->value
.function
.name
1911 = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f
->ts
.type
),
1916 gfc_resolve_nearest (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
1918 if (p
->ts
.kind
!= a
->ts
.kind
)
1919 gfc_convert_type (p
, &a
->ts
, 2);
1922 f
->value
.function
.name
1923 = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a
->ts
.type
),
1928 gfc_resolve_nint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1930 f
->ts
.type
= BT_INTEGER
;
1931 f
->ts
.kind
= (kind
== NULL
)
1932 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
1933 f
->value
.function
.name
1934 = gfc_get_string ("__nint_%d_%d", f
->ts
.kind
, a
->ts
.kind
);
1939 gfc_resolve_norm2 (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
)
1941 resolve_transformational ("norm2", f
, array
, dim
, NULL
);
1946 gfc_resolve_not (gfc_expr
*f
, gfc_expr
*i
)
1949 f
->value
.function
.name
= gfc_get_string ("__not_%d", i
->ts
.kind
);
1954 gfc_resolve_or (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1956 f
->ts
.type
= i
->ts
.type
;
1957 f
->ts
.kind
= gfc_kind_max (i
, j
);
1959 if (i
->ts
.kind
!= j
->ts
.kind
)
1961 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1962 gfc_convert_type (j
, &i
->ts
, 2);
1964 gfc_convert_type (i
, &j
->ts
, 2);
1967 f
->value
.function
.name
1968 = gfc_get_string ("__or_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
1973 gfc_resolve_pack (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*mask
,
1974 gfc_expr
*vector ATTRIBUTE_UNUSED
)
1976 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
1977 gfc_resolve_substring_charlen (array
);
1982 resolve_mask_arg (mask
);
1984 if (mask
->rank
!= 0)
1986 if (array
->ts
.type
== BT_CHARACTER
)
1987 f
->value
.function
.name
1988 = array
->ts
.kind
== 1 ? PREFIX ("pack_char")
1990 (PREFIX ("pack_char%d"),
1993 f
->value
.function
.name
= PREFIX ("pack");
1997 if (array
->ts
.type
== BT_CHARACTER
)
1998 f
->value
.function
.name
1999 = array
->ts
.kind
== 1 ? PREFIX ("pack_s_char")
2001 (PREFIX ("pack_s_char%d"),
2004 f
->value
.function
.name
= PREFIX ("pack_s");
2010 gfc_resolve_parity (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
)
2012 resolve_transformational ("parity", f
, array
, dim
, NULL
);
2017 gfc_resolve_product (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
2020 resolve_transformational ("product", f
, array
, dim
, mask
);
2025 gfc_resolve_rank (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
)
2027 f
->ts
.type
= BT_INTEGER
;
2028 f
->ts
.kind
= gfc_default_integer_kind
;
2029 f
->value
.function
.name
= gfc_get_string ("__rank");
2034 gfc_resolve_real (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
2036 f
->ts
.type
= BT_REAL
;
2039 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2041 f
->ts
.kind
= (a
->ts
.type
== BT_COMPLEX
)
2042 ? a
->ts
.kind
: gfc_default_real_kind
;
2044 f
->value
.function
.name
2045 = gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
2046 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2051 gfc_resolve_realpart (gfc_expr
*f
, gfc_expr
*a
)
2053 f
->ts
.type
= BT_REAL
;
2054 f
->ts
.kind
= a
->ts
.kind
;
2055 f
->value
.function
.name
2056 = gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
2057 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2062 gfc_resolve_rename (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
2063 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
2065 f
->ts
.type
= BT_INTEGER
;
2066 f
->ts
.kind
= gfc_default_integer_kind
;
2067 f
->value
.function
.name
= gfc_get_string (PREFIX ("rename_i%d"), f
->ts
.kind
);
2072 gfc_resolve_repeat (gfc_expr
*f
, gfc_expr
*string
,
2077 f
->ts
.type
= BT_CHARACTER
;
2078 f
->ts
.kind
= string
->ts
.kind
;
2079 f
->value
.function
.name
= gfc_get_string ("__repeat_%d", string
->ts
.kind
);
2081 /* If possible, generate a character length. */
2082 if (f
->ts
.u
.cl
== NULL
)
2083 f
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2086 if (string
->expr_type
== EXPR_CONSTANT
)
2088 len
= string
->value
.character
.length
;
2089 tmp
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, len
);
2091 else if (string
->ts
.u
.cl
&& string
->ts
.u
.cl
->length
)
2093 tmp
= gfc_copy_expr (string
->ts
.u
.cl
->length
);
2097 f
->ts
.u
.cl
->length
= gfc_multiply (tmp
, gfc_copy_expr (ncopies
));
2102 gfc_resolve_reshape (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*shape
,
2103 gfc_expr
*pad ATTRIBUTE_UNUSED
,
2104 gfc_expr
*order ATTRIBUTE_UNUSED
)
2110 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
2111 gfc_resolve_substring_charlen (source
);
2115 gfc_array_size (shape
, &rank
);
2116 f
->rank
= mpz_get_si (rank
);
2118 switch (source
->ts
.type
)
2125 kind
= source
->ts
.kind
;
2139 if (source
->ts
.type
== BT_COMPLEX
|| source
->ts
.type
== BT_REAL
)
2140 f
->value
.function
.name
2141 = gfc_get_string (PREFIX ("reshape_%c%d"),
2142 gfc_type_letter (source
->ts
.type
),
2144 else if (source
->ts
.type
== BT_CHARACTER
)
2145 f
->value
.function
.name
= gfc_get_string (PREFIX ("reshape_char%d"),
2148 f
->value
.function
.name
2149 = gfc_get_string (PREFIX ("reshape_%d"), source
->ts
.kind
);
2153 f
->value
.function
.name
= (source
->ts
.type
== BT_CHARACTER
2154 ? PREFIX ("reshape_char") : PREFIX ("reshape"));
2158 if (shape
->expr_type
== EXPR_ARRAY
&& gfc_is_constant_expr (shape
))
2161 f
->shape
= gfc_get_shape (f
->rank
);
2162 c
= gfc_constructor_first (shape
->value
.constructor
);
2163 for (i
= 0; i
< f
->rank
; i
++)
2165 mpz_init_set (f
->shape
[i
], c
->expr
->value
.integer
);
2166 c
= gfc_constructor_next (c
);
2170 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
2171 so many runtime variations. */
2172 if (shape
->ts
.kind
!= gfc_index_integer_kind
)
2174 gfc_typespec ts
= shape
->ts
;
2175 ts
.kind
= gfc_index_integer_kind
;
2176 gfc_convert_type_warn (shape
, &ts
, 2, 0);
2178 if (order
&& order
->ts
.kind
!= gfc_index_integer_kind
)
2179 gfc_convert_type_warn (order
, &shape
->ts
, 2, 0);
2184 gfc_resolve_rrspacing (gfc_expr
*f
, gfc_expr
*x
)
2187 f
->value
.function
.name
= gfc_get_string ("__rrspacing_%d", x
->ts
.kind
);
2192 gfc_resolve_scale (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*i ATTRIBUTE_UNUSED
)
2195 f
->value
.function
.name
= gfc_get_string ("__scale_%d", x
->ts
.kind
);
2200 gfc_resolve_scan (gfc_expr
*f
, gfc_expr
*string
,
2201 gfc_expr
*set ATTRIBUTE_UNUSED
,
2202 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2204 f
->ts
.type
= BT_INTEGER
;
2206 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2208 f
->ts
.kind
= gfc_default_integer_kind
;
2209 f
->value
.function
.name
= gfc_get_string ("__scan_%d", string
->ts
.kind
);
2214 gfc_resolve_secnds (gfc_expr
*t1
, gfc_expr
*t0
)
2217 t1
->value
.function
.name
= gfc_get_string (PREFIX ("secnds"));
2222 gfc_resolve_set_exponent (gfc_expr
*f
, gfc_expr
*x
,
2223 gfc_expr
*i ATTRIBUTE_UNUSED
)
2226 f
->value
.function
.name
= gfc_get_string ("__set_exponent_%d", x
->ts
.kind
);
2231 gfc_resolve_shape (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*kind
)
2233 f
->ts
.type
= BT_INTEGER
;
2236 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2238 f
->ts
.kind
= gfc_default_integer_kind
;
2241 if (array
->rank
!= -1)
2243 f
->shape
= gfc_get_shape (1);
2244 mpz_init_set_ui (f
->shape
[0], array
->rank
);
2247 f
->value
.function
.name
= gfc_get_string (PREFIX ("shape_%d"), f
->ts
.kind
);
2252 gfc_resolve_shift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift ATTRIBUTE_UNUSED
)
2255 if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTA
)
2256 f
->value
.function
.name
= gfc_get_string ("shifta_i%d", f
->ts
.kind
);
2257 else if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTL
)
2258 f
->value
.function
.name
= gfc_get_string ("shiftl_i%d", f
->ts
.kind
);
2259 else if (f
->value
.function
.isym
->id
== GFC_ISYM_SHIFTR
)
2260 f
->value
.function
.name
= gfc_get_string ("shiftr_i%d", f
->ts
.kind
);
2267 gfc_resolve_sign (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b ATTRIBUTE_UNUSED
)
2270 f
->value
.function
.name
2271 = gfc_get_string ("__sign_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2276 gfc_resolve_signal (gfc_expr
*f
, gfc_expr
*number
, gfc_expr
*handler
)
2278 f
->ts
.type
= BT_INTEGER
;
2279 f
->ts
.kind
= gfc_c_int_kind
;
2281 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2282 if (handler
->ts
.type
== BT_INTEGER
)
2284 if (handler
->ts
.kind
!= gfc_c_int_kind
)
2285 gfc_convert_type (handler
, &f
->ts
, 2);
2286 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func_int"));
2289 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func"));
2291 if (number
->ts
.kind
!= gfc_c_int_kind
)
2292 gfc_convert_type (number
, &f
->ts
, 2);
2297 gfc_resolve_sin (gfc_expr
*f
, gfc_expr
*x
)
2300 f
->value
.function
.name
2301 = gfc_get_string ("__sin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2306 gfc_resolve_sinh (gfc_expr
*f
, gfc_expr
*x
)
2309 f
->value
.function
.name
2310 = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2315 gfc_resolve_size (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2316 gfc_expr
*dim ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2318 f
->ts
.type
= BT_INTEGER
;
2320 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2322 f
->ts
.kind
= gfc_default_integer_kind
;
2327 gfc_resolve_stride (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2328 gfc_expr
*dim ATTRIBUTE_UNUSED
)
2330 f
->ts
.type
= BT_INTEGER
;
2331 f
->ts
.kind
= gfc_index_integer_kind
;
2336 gfc_resolve_spacing (gfc_expr
*f
, gfc_expr
*x
)
2339 f
->value
.function
.name
= gfc_get_string ("__spacing_%d", x
->ts
.kind
);
2344 gfc_resolve_spread (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*dim
,
2347 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
2348 gfc_resolve_substring_charlen (source
);
2350 if (source
->ts
.type
== BT_CHARACTER
)
2351 check_charlen_present (source
);
2354 f
->rank
= source
->rank
+ 1;
2355 if (source
->rank
== 0)
2357 if (source
->ts
.type
== BT_CHARACTER
)
2358 f
->value
.function
.name
2359 = source
->ts
.kind
== 1 ? PREFIX ("spread_char_scalar")
2361 (PREFIX ("spread_char%d_scalar"),
2364 f
->value
.function
.name
= PREFIX ("spread_scalar");
2368 if (source
->ts
.type
== BT_CHARACTER
)
2369 f
->value
.function
.name
2370 = source
->ts
.kind
== 1 ? PREFIX ("spread_char")
2372 (PREFIX ("spread_char%d"),
2375 f
->value
.function
.name
= PREFIX ("spread");
2378 if (dim
&& gfc_is_constant_expr (dim
)
2379 && ncopies
&& gfc_is_constant_expr (ncopies
) && source
->shape
[0])
2382 idim
= mpz_get_ui (dim
->value
.integer
);
2383 f
->shape
= gfc_get_shape (f
->rank
);
2384 for (i
= 0; i
< (idim
- 1); i
++)
2385 mpz_init_set (f
->shape
[i
], source
->shape
[i
]);
2387 mpz_init_set (f
->shape
[idim
- 1], ncopies
->value
.integer
);
2389 for (i
= idim
; i
< f
->rank
; i
++)
2390 mpz_init_set (f
->shape
[i
], source
->shape
[i
-1]);
2394 gfc_resolve_dim_arg (dim
);
2395 gfc_resolve_index (ncopies
, 1);
2400 gfc_resolve_sqrt (gfc_expr
*f
, gfc_expr
*x
)
2403 f
->value
.function
.name
2404 = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2408 /* Resolve the g77 compatibility function STAT AND FSTAT. */
2411 gfc_resolve_stat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2412 gfc_expr
*a ATTRIBUTE_UNUSED
)
2414 f
->ts
.type
= BT_INTEGER
;
2415 f
->ts
.kind
= gfc_default_integer_kind
;
2416 f
->value
.function
.name
= gfc_get_string (PREFIX ("stat_i%d"), f
->ts
.kind
);
2421 gfc_resolve_lstat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2422 gfc_expr
*a ATTRIBUTE_UNUSED
)
2424 f
->ts
.type
= BT_INTEGER
;
2425 f
->ts
.kind
= gfc_default_integer_kind
;
2426 f
->value
.function
.name
= gfc_get_string (PREFIX ("lstat_i%d"), f
->ts
.kind
);
2431 gfc_resolve_fstat (gfc_expr
*f
, gfc_expr
*n
, gfc_expr
*a ATTRIBUTE_UNUSED
)
2433 f
->ts
.type
= BT_INTEGER
;
2434 f
->ts
.kind
= gfc_default_integer_kind
;
2435 if (n
->ts
.kind
!= f
->ts
.kind
)
2436 gfc_convert_type (n
, &f
->ts
, 2);
2438 f
->value
.function
.name
= gfc_get_string (PREFIX ("fstat_i%d"), f
->ts
.kind
);
2443 gfc_resolve_fgetc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2448 f
->ts
.type
= BT_INTEGER
;
2449 f
->ts
.kind
= gfc_c_int_kind
;
2450 if (u
->ts
.kind
!= gfc_c_int_kind
)
2452 ts
.type
= BT_INTEGER
;
2453 ts
.kind
= gfc_c_int_kind
;
2454 ts
.u
.derived
= NULL
;
2456 gfc_convert_type (u
, &ts
, 2);
2459 f
->value
.function
.name
= gfc_get_string (PREFIX ("fgetc"));
2464 gfc_resolve_fget (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2466 f
->ts
.type
= BT_INTEGER
;
2467 f
->ts
.kind
= gfc_c_int_kind
;
2468 f
->value
.function
.name
= gfc_get_string (PREFIX ("fget"));
2473 gfc_resolve_fputc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2478 f
->ts
.type
= BT_INTEGER
;
2479 f
->ts
.kind
= gfc_c_int_kind
;
2480 if (u
->ts
.kind
!= gfc_c_int_kind
)
2482 ts
.type
= BT_INTEGER
;
2483 ts
.kind
= gfc_c_int_kind
;
2484 ts
.u
.derived
= NULL
;
2486 gfc_convert_type (u
, &ts
, 2);
2489 f
->value
.function
.name
= gfc_get_string (PREFIX ("fputc"));
2494 gfc_resolve_fput (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2496 f
->ts
.type
= BT_INTEGER
;
2497 f
->ts
.kind
= gfc_c_int_kind
;
2498 f
->value
.function
.name
= gfc_get_string (PREFIX ("fput"));
2503 gfc_resolve_ftell (gfc_expr
*f
, gfc_expr
*u
)
2508 f
->ts
.type
= BT_INTEGER
;
2509 f
->ts
.kind
= gfc_intio_kind
;
2510 if (u
->ts
.kind
!= gfc_c_int_kind
)
2512 ts
.type
= BT_INTEGER
;
2513 ts
.kind
= gfc_c_int_kind
;
2514 ts
.u
.derived
= NULL
;
2516 gfc_convert_type (u
, &ts
, 2);
2519 f
->value
.function
.name
= gfc_get_string (PREFIX ("ftell2"));
2524 gfc_resolve_storage_size (gfc_expr
*f
, gfc_expr
*a ATTRIBUTE_UNUSED
,
2527 f
->ts
.type
= BT_INTEGER
;
2529 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2531 f
->ts
.kind
= gfc_default_integer_kind
;
2536 gfc_resolve_sum (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2538 resolve_transformational ("sum", f
, array
, dim
, mask
);
2543 gfc_resolve_symlnk (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
2544 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
2546 f
->ts
.type
= BT_INTEGER
;
2547 f
->ts
.kind
= gfc_default_integer_kind
;
2548 f
->value
.function
.name
= gfc_get_string (PREFIX ("symlnk_i%d"), f
->ts
.kind
);
2552 /* Resolve the g77 compatibility function SYSTEM. */
2555 gfc_resolve_system (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
2557 f
->ts
.type
= BT_INTEGER
;
2559 f
->value
.function
.name
= gfc_get_string (PREFIX ("system"));
2564 gfc_resolve_tan (gfc_expr
*f
, gfc_expr
*x
)
2567 f
->value
.function
.name
2568 = gfc_get_string ("__tan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2573 gfc_resolve_tanh (gfc_expr
*f
, gfc_expr
*x
)
2576 f
->value
.function
.name
2577 = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2582 gfc_resolve_image_index (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2583 gfc_expr
*sub ATTRIBUTE_UNUSED
)
2585 static char image_index
[] = "__image_index";
2586 f
->ts
.type
= BT_INTEGER
;
2587 f
->ts
.kind
= gfc_default_integer_kind
;
2588 f
->value
.function
.name
= image_index
;
2593 gfc_resolve_this_image (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
2594 gfc_expr
*distance ATTRIBUTE_UNUSED
)
2596 static char this_image
[] = "__this_image";
2597 if (array
&& gfc_is_coarray (array
))
2598 resolve_bound (f
, array
, dim
, NULL
, "__this_image", true);
2601 f
->ts
.type
= BT_INTEGER
;
2602 f
->ts
.kind
= gfc_default_integer_kind
;
2603 f
->value
.function
.name
= this_image
;
2609 gfc_resolve_time (gfc_expr
*f
)
2611 f
->ts
.type
= BT_INTEGER
;
2613 f
->value
.function
.name
= gfc_get_string (PREFIX ("time_func"));
2618 gfc_resolve_time8 (gfc_expr
*f
)
2620 f
->ts
.type
= BT_INTEGER
;
2622 f
->value
.function
.name
= gfc_get_string (PREFIX ("time8_func"));
2627 gfc_resolve_transfer (gfc_expr
*f
, gfc_expr
*source ATTRIBUTE_UNUSED
,
2628 gfc_expr
*mold
, gfc_expr
*size
)
2630 /* TODO: Make this do something meaningful. */
2631 static char transfer0
[] = "__transfer0", transfer1
[] = "__transfer1";
2633 if (mold
->ts
.type
== BT_CHARACTER
2634 && !mold
->ts
.u
.cl
->length
2635 && gfc_is_constant_expr (mold
))
2638 if (mold
->expr_type
== EXPR_CONSTANT
)
2640 len
= mold
->value
.character
.length
;
2641 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
2646 gfc_constructor
*c
= gfc_constructor_first (mold
->value
.constructor
);
2647 len
= c
->expr
->value
.character
.length
;
2648 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
2655 if (size
== NULL
&& mold
->rank
== 0)
2658 f
->value
.function
.name
= transfer0
;
2663 f
->value
.function
.name
= transfer1
;
2664 if (size
&& gfc_is_constant_expr (size
))
2666 f
->shape
= gfc_get_shape (1);
2667 mpz_init_set (f
->shape
[0], size
->value
.integer
);
2674 gfc_resolve_transpose (gfc_expr
*f
, gfc_expr
*matrix
)
2677 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ref
)
2678 gfc_resolve_substring_charlen (matrix
);
2684 f
->shape
= gfc_get_shape (2);
2685 mpz_init_set (f
->shape
[0], matrix
->shape
[1]);
2686 mpz_init_set (f
->shape
[1], matrix
->shape
[0]);
2689 switch (matrix
->ts
.kind
)
2695 switch (matrix
->ts
.type
)
2699 f
->value
.function
.name
2700 = gfc_get_string (PREFIX ("transpose_%c%d"),
2701 gfc_type_letter (matrix
->ts
.type
),
2707 /* Use the integer routines for real and logical cases. This
2708 assumes they all have the same alignment requirements. */
2709 f
->value
.function
.name
2710 = gfc_get_string (PREFIX ("transpose_i%d"), matrix
->ts
.kind
);
2714 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ts
.kind
== 4)
2715 f
->value
.function
.name
= PREFIX ("transpose_char4");
2717 f
->value
.function
.name
= PREFIX ("transpose");
2723 f
->value
.function
.name
= (matrix
->ts
.type
== BT_CHARACTER
2724 ? PREFIX ("transpose_char")
2725 : PREFIX ("transpose"));
2732 gfc_resolve_trim (gfc_expr
*f
, gfc_expr
*string
)
2734 f
->ts
.type
= BT_CHARACTER
;
2735 f
->ts
.kind
= string
->ts
.kind
;
2736 f
->value
.function
.name
= gfc_get_string ("__trim_%d", string
->ts
.kind
);
2741 gfc_resolve_ubound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2743 resolve_bound (f
, array
, dim
, kind
, "__ubound", false);
2748 gfc_resolve_ucobound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2750 resolve_bound (f
, array
, dim
, kind
, "__ucobound", true);
2754 /* Resolve the g77 compatibility function UMASK. */
2757 gfc_resolve_umask (gfc_expr
*f
, gfc_expr
*n
)
2759 f
->ts
.type
= BT_INTEGER
;
2760 f
->ts
.kind
= n
->ts
.kind
;
2761 f
->value
.function
.name
= gfc_get_string (PREFIX ("umask_i%d"), n
->ts
.kind
);
2765 /* Resolve the g77 compatibility function UNLINK. */
2768 gfc_resolve_unlink (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
2770 f
->ts
.type
= BT_INTEGER
;
2772 f
->value
.function
.name
= gfc_get_string (PREFIX ("unlink"));
2777 gfc_resolve_ttynam (gfc_expr
*f
, gfc_expr
*unit
)
2782 f
->ts
.type
= BT_CHARACTER
;
2783 f
->ts
.kind
= gfc_default_character_kind
;
2785 if (unit
->ts
.kind
!= gfc_c_int_kind
)
2787 ts
.type
= BT_INTEGER
;
2788 ts
.kind
= gfc_c_int_kind
;
2789 ts
.u
.derived
= NULL
;
2791 gfc_convert_type (unit
, &ts
, 2);
2794 f
->value
.function
.name
= gfc_get_string (PREFIX ("ttynam"));
2799 gfc_resolve_unpack (gfc_expr
*f
, gfc_expr
*vector
, gfc_expr
*mask
,
2800 gfc_expr
*field ATTRIBUTE_UNUSED
)
2802 if (vector
->ts
.type
== BT_CHARACTER
&& vector
->ref
)
2803 gfc_resolve_substring_charlen (vector
);
2806 f
->rank
= mask
->rank
;
2807 resolve_mask_arg (mask
);
2809 if (vector
->ts
.type
== BT_CHARACTER
)
2811 if (vector
->ts
.kind
== 1)
2812 f
->value
.function
.name
2813 = gfc_get_string (PREFIX ("unpack%d_char"), field
->rank
> 0 ? 1 : 0);
2815 f
->value
.function
.name
2816 = gfc_get_string (PREFIX ("unpack%d_char%d"),
2817 field
->rank
> 0 ? 1 : 0, vector
->ts
.kind
);
2820 f
->value
.function
.name
2821 = gfc_get_string (PREFIX ("unpack%d"), field
->rank
> 0 ? 1 : 0);
2826 gfc_resolve_verify (gfc_expr
*f
, gfc_expr
*string
,
2827 gfc_expr
*set ATTRIBUTE_UNUSED
,
2828 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2830 f
->ts
.type
= BT_INTEGER
;
2832 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2834 f
->ts
.kind
= gfc_default_integer_kind
;
2835 f
->value
.function
.name
= gfc_get_string ("__verify_%d", string
->ts
.kind
);
2840 gfc_resolve_xor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
2842 f
->ts
.type
= i
->ts
.type
;
2843 f
->ts
.kind
= gfc_kind_max (i
, j
);
2845 if (i
->ts
.kind
!= j
->ts
.kind
)
2847 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
2848 gfc_convert_type (j
, &i
->ts
, 2);
2850 gfc_convert_type (i
, &j
->ts
, 2);
2853 f
->value
.function
.name
2854 = gfc_get_string ("__xor_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
2858 /* Intrinsic subroutine resolution. */
2861 gfc_resolve_alarm_sub (gfc_code
*c
)
2864 gfc_expr
*seconds
, *handler
;
2868 seconds
= c
->ext
.actual
->expr
;
2869 handler
= c
->ext
.actual
->next
->expr
;
2870 ts
.type
= BT_INTEGER
;
2871 ts
.kind
= gfc_c_int_kind
;
2873 /* handler can be either BT_INTEGER or BT_PROCEDURE.
2874 In all cases, the status argument is of default integer kind
2875 (enforced in check.c) so that the function suffix is fixed. */
2876 if (handler
->ts
.type
== BT_INTEGER
)
2878 if (handler
->ts
.kind
!= gfc_c_int_kind
)
2879 gfc_convert_type (handler
, &ts
, 2);
2880 name
= gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
2881 gfc_default_integer_kind
);
2884 name
= gfc_get_string (PREFIX ("alarm_sub_i%d"),
2885 gfc_default_integer_kind
);
2887 if (seconds
->ts
.kind
!= gfc_c_int_kind
)
2888 gfc_convert_type (seconds
, &ts
, 2);
2890 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2894 gfc_resolve_cpu_time (gfc_code
*c
)
2897 name
= gfc_get_string (PREFIX ("cpu_time_%d"), c
->ext
.actual
->expr
->ts
.kind
);
2898 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2902 /* Create a formal arglist based on an actual one and set the INTENTs given. */
2904 static gfc_formal_arglist
*
2905 create_formal_for_intents (gfc_actual_arglist
* actual
, const sym_intent
* ints
)
2907 gfc_formal_arglist
* head
;
2908 gfc_formal_arglist
* tail
;
2914 head
= tail
= gfc_get_formal_arglist ();
2915 for (i
= 0; actual
; actual
= actual
->next
, tail
= tail
->next
, ++i
)
2919 sym
= gfc_new_symbol ("dummyarg", NULL
);
2920 sym
->ts
= actual
->expr
->ts
;
2922 sym
->attr
.intent
= ints
[i
];
2926 tail
->next
= gfc_get_formal_arglist ();
2934 gfc_resolve_atomic_def (gfc_code
*c
)
2936 const char *name
= "atomic_define";
2937 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2942 gfc_resolve_atomic_ref (gfc_code
*c
)
2944 const char *name
= "atomic_ref";
2945 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2950 gfc_resolve_mvbits (gfc_code
*c
)
2952 static const sym_intent INTENTS
[] = {INTENT_IN
, INTENT_IN
, INTENT_IN
,
2953 INTENT_INOUT
, INTENT_IN
};
2959 /* FROMPOS, LEN and TOPOS are restricted to small values. As such,
2960 they will be converted so that they fit into a C int. */
2961 ts
.type
= BT_INTEGER
;
2962 ts
.kind
= gfc_c_int_kind
;
2963 if (c
->ext
.actual
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
2964 gfc_convert_type (c
->ext
.actual
->next
->expr
, &ts
, 2);
2965 if (c
->ext
.actual
->next
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
2966 gfc_convert_type (c
->ext
.actual
->next
->next
->expr
, &ts
, 2);
2967 if (c
->ext
.actual
->next
->next
->next
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
2968 gfc_convert_type (c
->ext
.actual
->next
->next
->next
->next
->expr
, &ts
, 2);
2970 /* TO and FROM are guaranteed to have the same kind parameter. */
2971 name
= gfc_get_string (PREFIX ("mvbits_i%d"),
2972 c
->ext
.actual
->expr
->ts
.kind
);
2973 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2974 /* Mark as elemental subroutine as this does not happen automatically. */
2975 c
->resolved_sym
->attr
.elemental
= 1;
2977 /* Create a dummy formal arglist so the INTENTs are known later for purpose
2978 of creating temporaries. */
2979 c
->resolved_sym
->formal
= create_formal_for_intents (c
->ext
.actual
, INTENTS
);
2984 gfc_resolve_random_number (gfc_code
*c
)
2989 kind
= c
->ext
.actual
->expr
->ts
.kind
;
2990 if (c
->ext
.actual
->expr
->rank
== 0)
2991 name
= gfc_get_string (PREFIX ("random_r%d"), kind
);
2993 name
= gfc_get_string (PREFIX ("arandom_r%d"), kind
);
2995 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3000 gfc_resolve_random_seed (gfc_code
*c
)
3004 name
= gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind
);
3005 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3010 gfc_resolve_rename_sub (gfc_code
*c
)
3015 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3016 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3018 kind
= gfc_default_integer_kind
;
3020 name
= gfc_get_string (PREFIX ("rename_i%d_sub"), kind
);
3021 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3026 gfc_resolve_kill_sub (gfc_code
*c
)
3031 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3032 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3034 kind
= gfc_default_integer_kind
;
3036 name
= gfc_get_string (PREFIX ("kill_i%d_sub"), kind
);
3037 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3042 gfc_resolve_link_sub (gfc_code
*c
)
3047 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3048 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3050 kind
= gfc_default_integer_kind
;
3052 name
= gfc_get_string (PREFIX ("link_i%d_sub"), kind
);
3053 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3058 gfc_resolve_symlnk_sub (gfc_code
*c
)
3063 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3064 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3066 kind
= gfc_default_integer_kind
;
3068 name
= gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind
);
3069 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3073 /* G77 compatibility subroutines dtime() and etime(). */
3076 gfc_resolve_dtime_sub (gfc_code
*c
)
3079 name
= gfc_get_string (PREFIX ("dtime_sub"));
3080 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3084 gfc_resolve_etime_sub (gfc_code
*c
)
3087 name
= gfc_get_string (PREFIX ("etime_sub"));
3088 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3092 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
3095 gfc_resolve_itime (gfc_code
*c
)
3098 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
3099 gfc_default_integer_kind
));
3103 gfc_resolve_idate (gfc_code
*c
)
3106 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
3107 gfc_default_integer_kind
));
3111 gfc_resolve_ltime (gfc_code
*c
)
3114 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
3115 gfc_default_integer_kind
));
3119 gfc_resolve_gmtime (gfc_code
*c
)
3122 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
3123 gfc_default_integer_kind
));
3127 /* G77 compatibility subroutine second(). */
3130 gfc_resolve_second_sub (gfc_code
*c
)
3133 name
= gfc_get_string (PREFIX ("second_sub"));
3134 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3139 gfc_resolve_sleep_sub (gfc_code
*c
)
3144 if (c
->ext
.actual
->expr
!= NULL
)
3145 kind
= c
->ext
.actual
->expr
->ts
.kind
;
3147 kind
= gfc_default_integer_kind
;
3149 name
= gfc_get_string (PREFIX ("sleep_i%d_sub"), kind
);
3150 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3154 /* G77 compatibility function srand(). */
3157 gfc_resolve_srand (gfc_code
*c
)
3160 name
= gfc_get_string (PREFIX ("srand"));
3161 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3165 /* Resolve the getarg intrinsic subroutine. */
3168 gfc_resolve_getarg (gfc_code
*c
)
3172 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_default_integer_kind
)
3177 ts
.type
= BT_INTEGER
;
3178 ts
.kind
= gfc_default_integer_kind
;
3180 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3183 name
= gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind
);
3184 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3188 /* Resolve the getcwd intrinsic subroutine. */
3191 gfc_resolve_getcwd_sub (gfc_code
*c
)
3196 if (c
->ext
.actual
->next
->expr
!= NULL
)
3197 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3199 kind
= gfc_default_integer_kind
;
3201 name
= gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind
);
3202 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3206 /* Resolve the get_command intrinsic subroutine. */
3209 gfc_resolve_get_command (gfc_code
*c
)
3213 kind
= gfc_default_integer_kind
;
3214 name
= gfc_get_string (PREFIX ("get_command_i%d"), kind
);
3215 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3219 /* Resolve the get_command_argument intrinsic subroutine. */
3222 gfc_resolve_get_command_argument (gfc_code
*c
)
3226 kind
= gfc_default_integer_kind
;
3227 name
= gfc_get_string (PREFIX ("get_command_argument_i%d"), kind
);
3228 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3232 /* Resolve the get_environment_variable intrinsic subroutine. */
3235 gfc_resolve_get_environment_variable (gfc_code
*code
)
3239 kind
= gfc_default_integer_kind
;
3240 name
= gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind
);
3241 code
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3246 gfc_resolve_signal_sub (gfc_code
*c
)
3249 gfc_expr
*number
, *handler
, *status
;
3253 number
= c
->ext
.actual
->expr
;
3254 handler
= c
->ext
.actual
->next
->expr
;
3255 status
= c
->ext
.actual
->next
->next
->expr
;
3256 ts
.type
= BT_INTEGER
;
3257 ts
.kind
= gfc_c_int_kind
;
3259 /* handler can be either BT_INTEGER or BT_PROCEDURE */
3260 if (handler
->ts
.type
== BT_INTEGER
)
3262 if (handler
->ts
.kind
!= gfc_c_int_kind
)
3263 gfc_convert_type (handler
, &ts
, 2);
3264 name
= gfc_get_string (PREFIX ("signal_sub_int"));
3267 name
= gfc_get_string (PREFIX ("signal_sub"));
3269 if (number
->ts
.kind
!= gfc_c_int_kind
)
3270 gfc_convert_type (number
, &ts
, 2);
3271 if (status
!= NULL
&& status
->ts
.kind
!= gfc_c_int_kind
)
3272 gfc_convert_type (status
, &ts
, 2);
3274 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3278 /* Resolve the SYSTEM intrinsic subroutine. */
3281 gfc_resolve_system_sub (gfc_code
*c
)
3284 name
= gfc_get_string (PREFIX ("system_sub"));
3285 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3289 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
3292 gfc_resolve_system_clock (gfc_code
*c
)
3296 gfc_expr
*count
= c
->ext
.actual
->expr
;
3297 gfc_expr
*count_max
= c
->ext
.actual
->next
->next
->expr
;
3299 /* The INTEGER(8) version has higher precision, it is used if both COUNT
3300 and COUNT_MAX can hold 64-bit values, or are absent. */
3301 if ((!count
|| count
->ts
.kind
>= 8)
3302 && (!count_max
|| count_max
->ts
.kind
>= 8))
3305 kind
= gfc_default_integer_kind
;
3307 name
= gfc_get_string (PREFIX ("system_clock_%d"), kind
);
3308 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3312 /* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine. */
3314 gfc_resolve_execute_command_line (gfc_code
*c
)
3317 name
= gfc_get_string (PREFIX ("execute_command_line_i%d"),
3318 gfc_default_integer_kind
);
3319 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3323 /* Resolve the EXIT intrinsic subroutine. */
3326 gfc_resolve_exit (gfc_code
*c
)
3333 /* The STATUS argument has to be of default kind. If it is not,
3335 ts
.type
= BT_INTEGER
;
3336 ts
.kind
= gfc_default_integer_kind
;
3337 n
= c
->ext
.actual
->expr
;
3338 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3339 gfc_convert_type (n
, &ts
, 2);
3341 name
= gfc_get_string (PREFIX ("exit_i%d"), ts
.kind
);
3342 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3346 /* Resolve the FLUSH intrinsic subroutine. */
3349 gfc_resolve_flush (gfc_code
*c
)
3356 ts
.type
= BT_INTEGER
;
3357 ts
.kind
= gfc_default_integer_kind
;
3358 n
= c
->ext
.actual
->expr
;
3359 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3360 gfc_convert_type (n
, &ts
, 2);
3362 name
= gfc_get_string (PREFIX ("flush_i%d"), ts
.kind
);
3363 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3368 gfc_resolve_free (gfc_code
*c
)
3374 ts
.type
= BT_INTEGER
;
3375 ts
.kind
= gfc_index_integer_kind
;
3376 n
= c
->ext
.actual
->expr
;
3377 if (n
->ts
.kind
!= ts
.kind
)
3378 gfc_convert_type (n
, &ts
, 2);
3380 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("free"));
3385 gfc_resolve_ctime_sub (gfc_code
*c
)
3390 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3391 if (c
->ext
.actual
->expr
->ts
.kind
!= 8)
3393 ts
.type
= BT_INTEGER
;
3395 ts
.u
.derived
= NULL
;
3397 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3400 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3405 gfc_resolve_fdate_sub (gfc_code
*c
)
3407 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3412 gfc_resolve_gerror (gfc_code
*c
)
3414 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3419 gfc_resolve_getlog (gfc_code
*c
)
3421 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3426 gfc_resolve_hostnm_sub (gfc_code
*c
)
3431 if (c
->ext
.actual
->next
->expr
!= NULL
)
3432 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3434 kind
= gfc_default_integer_kind
;
3436 name
= gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind
);
3437 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3442 gfc_resolve_perror (gfc_code
*c
)
3444 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3447 /* Resolve the STAT and FSTAT intrinsic subroutines. */
3450 gfc_resolve_stat_sub (gfc_code
*c
)
3453 name
= gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind
);
3454 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3459 gfc_resolve_lstat_sub (gfc_code
*c
)
3462 name
= gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind
);
3463 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3468 gfc_resolve_fstat_sub (gfc_code
*c
)
3474 u
= c
->ext
.actual
->expr
;
3475 ts
= &c
->ext
.actual
->next
->expr
->ts
;
3476 if (u
->ts
.kind
!= ts
->kind
)
3477 gfc_convert_type (u
, ts
, 2);
3478 name
= gfc_get_string (PREFIX ("fstat_i%d_sub"), ts
->kind
);
3479 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3484 gfc_resolve_fgetc_sub (gfc_code
*c
)
3491 u
= c
->ext
.actual
->expr
;
3492 st
= c
->ext
.actual
->next
->next
->expr
;
3494 if (u
->ts
.kind
!= gfc_c_int_kind
)
3496 ts
.type
= BT_INTEGER
;
3497 ts
.kind
= gfc_c_int_kind
;
3498 ts
.u
.derived
= NULL
;
3500 gfc_convert_type (u
, &ts
, 2);
3504 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), st
->ts
.kind
);
3506 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind
);
3508 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3513 gfc_resolve_fget_sub (gfc_code
*c
)
3518 st
= c
->ext
.actual
->next
->expr
;
3520 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), st
->ts
.kind
);
3522 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind
);
3524 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3529 gfc_resolve_fputc_sub (gfc_code
*c
)
3536 u
= c
->ext
.actual
->expr
;
3537 st
= c
->ext
.actual
->next
->next
->expr
;
3539 if (u
->ts
.kind
!= gfc_c_int_kind
)
3541 ts
.type
= BT_INTEGER
;
3542 ts
.kind
= gfc_c_int_kind
;
3543 ts
.u
.derived
= NULL
;
3545 gfc_convert_type (u
, &ts
, 2);
3549 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), st
->ts
.kind
);
3551 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind
);
3553 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3558 gfc_resolve_fput_sub (gfc_code
*c
)
3563 st
= c
->ext
.actual
->next
->expr
;
3565 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), st
->ts
.kind
);
3567 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind
);
3569 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3574 gfc_resolve_fseek_sub (gfc_code
*c
)
3582 unit
= c
->ext
.actual
->expr
;
3583 offset
= c
->ext
.actual
->next
->expr
;
3584 whence
= c
->ext
.actual
->next
->next
->expr
;
3586 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3588 ts
.type
= BT_INTEGER
;
3589 ts
.kind
= gfc_c_int_kind
;
3590 ts
.u
.derived
= NULL
;
3592 gfc_convert_type (unit
, &ts
, 2);
3595 if (offset
->ts
.kind
!= gfc_intio_kind
)
3597 ts
.type
= BT_INTEGER
;
3598 ts
.kind
= gfc_intio_kind
;
3599 ts
.u
.derived
= NULL
;
3601 gfc_convert_type (offset
, &ts
, 2);
3604 if (whence
->ts
.kind
!= gfc_c_int_kind
)
3606 ts
.type
= BT_INTEGER
;
3607 ts
.kind
= gfc_c_int_kind
;
3608 ts
.u
.derived
= NULL
;
3610 gfc_convert_type (whence
, &ts
, 2);
3613 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
3617 gfc_resolve_ftell_sub (gfc_code
*c
)
3625 unit
= c
->ext
.actual
->expr
;
3626 offset
= c
->ext
.actual
->next
->expr
;
3628 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3630 ts
.type
= BT_INTEGER
;
3631 ts
.kind
= gfc_c_int_kind
;
3632 ts
.u
.derived
= NULL
;
3634 gfc_convert_type (unit
, &ts
, 2);
3637 name
= gfc_get_string (PREFIX ("ftell_i%d_sub"), offset
->ts
.kind
);
3638 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3643 gfc_resolve_ttynam_sub (gfc_code
*c
)
3648 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
3650 ts
.type
= BT_INTEGER
;
3651 ts
.kind
= gfc_c_int_kind
;
3652 ts
.u
.derived
= NULL
;
3654 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3657 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
3661 /* Resolve the UMASK intrinsic subroutine. */
3664 gfc_resolve_umask_sub (gfc_code
*c
)
3669 if (c
->ext
.actual
->next
->expr
!= NULL
)
3670 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3672 kind
= gfc_default_integer_kind
;
3674 name
= gfc_get_string (PREFIX ("umask_i%d_sub"), kind
);
3675 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3678 /* Resolve the UNLINK intrinsic subroutine. */
3681 gfc_resolve_unlink_sub (gfc_code
*c
)
3686 if (c
->ext
.actual
->next
->expr
!= NULL
)
3687 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3689 kind
= gfc_default_integer_kind
;
3691 name
= gfc_get_string (PREFIX ("unlink_i%d_sub"), kind
);
3692 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);