1 /* Intrinsic function resolution.
2 Copyright (C) 2000-2013 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
)
2595 static char this_image
[] = "__this_image";
2597 resolve_bound (f
, array
, dim
, NULL
, "__this_image", true);
2600 f
->ts
.type
= BT_INTEGER
;
2601 f
->ts
.kind
= gfc_default_integer_kind
;
2602 f
->value
.function
.name
= this_image
;
2608 gfc_resolve_time (gfc_expr
*f
)
2610 f
->ts
.type
= BT_INTEGER
;
2612 f
->value
.function
.name
= gfc_get_string (PREFIX ("time_func"));
2617 gfc_resolve_time8 (gfc_expr
*f
)
2619 f
->ts
.type
= BT_INTEGER
;
2621 f
->value
.function
.name
= gfc_get_string (PREFIX ("time8_func"));
2626 gfc_resolve_transfer (gfc_expr
*f
, gfc_expr
*source ATTRIBUTE_UNUSED
,
2627 gfc_expr
*mold
, gfc_expr
*size
)
2629 /* TODO: Make this do something meaningful. */
2630 static char transfer0
[] = "__transfer0", transfer1
[] = "__transfer1";
2632 if (mold
->ts
.type
== BT_CHARACTER
2633 && !mold
->ts
.u
.cl
->length
2634 && gfc_is_constant_expr (mold
))
2637 if (mold
->expr_type
== EXPR_CONSTANT
)
2639 len
= mold
->value
.character
.length
;
2640 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
2645 gfc_constructor
*c
= gfc_constructor_first (mold
->value
.constructor
);
2646 len
= c
->expr
->value
.character
.length
;
2647 mold
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
2654 if (size
== NULL
&& mold
->rank
== 0)
2657 f
->value
.function
.name
= transfer0
;
2662 f
->value
.function
.name
= transfer1
;
2663 if (size
&& gfc_is_constant_expr (size
))
2665 f
->shape
= gfc_get_shape (1);
2666 mpz_init_set (f
->shape
[0], size
->value
.integer
);
2673 gfc_resolve_transpose (gfc_expr
*f
, gfc_expr
*matrix
)
2676 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ref
)
2677 gfc_resolve_substring_charlen (matrix
);
2683 f
->shape
= gfc_get_shape (2);
2684 mpz_init_set (f
->shape
[0], matrix
->shape
[1]);
2685 mpz_init_set (f
->shape
[1], matrix
->shape
[0]);
2688 switch (matrix
->ts
.kind
)
2694 switch (matrix
->ts
.type
)
2698 f
->value
.function
.name
2699 = gfc_get_string (PREFIX ("transpose_%c%d"),
2700 gfc_type_letter (matrix
->ts
.type
),
2706 /* Use the integer routines for real and logical cases. This
2707 assumes they all have the same alignment requirements. */
2708 f
->value
.function
.name
2709 = gfc_get_string (PREFIX ("transpose_i%d"), matrix
->ts
.kind
);
2713 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ts
.kind
== 4)
2714 f
->value
.function
.name
= PREFIX ("transpose_char4");
2716 f
->value
.function
.name
= PREFIX ("transpose");
2722 f
->value
.function
.name
= (matrix
->ts
.type
== BT_CHARACTER
2723 ? PREFIX ("transpose_char")
2724 : PREFIX ("transpose"));
2731 gfc_resolve_trim (gfc_expr
*f
, gfc_expr
*string
)
2733 f
->ts
.type
= BT_CHARACTER
;
2734 f
->ts
.kind
= string
->ts
.kind
;
2735 f
->value
.function
.name
= gfc_get_string ("__trim_%d", string
->ts
.kind
);
2740 gfc_resolve_ubound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2742 resolve_bound (f
, array
, dim
, kind
, "__ubound", false);
2747 gfc_resolve_ucobound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2749 resolve_bound (f
, array
, dim
, kind
, "__ucobound", true);
2753 /* Resolve the g77 compatibility function UMASK. */
2756 gfc_resolve_umask (gfc_expr
*f
, gfc_expr
*n
)
2758 f
->ts
.type
= BT_INTEGER
;
2759 f
->ts
.kind
= n
->ts
.kind
;
2760 f
->value
.function
.name
= gfc_get_string (PREFIX ("umask_i%d"), n
->ts
.kind
);
2764 /* Resolve the g77 compatibility function UNLINK. */
2767 gfc_resolve_unlink (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
2769 f
->ts
.type
= BT_INTEGER
;
2771 f
->value
.function
.name
= gfc_get_string (PREFIX ("unlink"));
2776 gfc_resolve_ttynam (gfc_expr
*f
, gfc_expr
*unit
)
2781 f
->ts
.type
= BT_CHARACTER
;
2782 f
->ts
.kind
= gfc_default_character_kind
;
2784 if (unit
->ts
.kind
!= gfc_c_int_kind
)
2786 ts
.type
= BT_INTEGER
;
2787 ts
.kind
= gfc_c_int_kind
;
2788 ts
.u
.derived
= NULL
;
2790 gfc_convert_type (unit
, &ts
, 2);
2793 f
->value
.function
.name
= gfc_get_string (PREFIX ("ttynam"));
2798 gfc_resolve_unpack (gfc_expr
*f
, gfc_expr
*vector
, gfc_expr
*mask
,
2799 gfc_expr
*field ATTRIBUTE_UNUSED
)
2801 if (vector
->ts
.type
== BT_CHARACTER
&& vector
->ref
)
2802 gfc_resolve_substring_charlen (vector
);
2805 f
->rank
= mask
->rank
;
2806 resolve_mask_arg (mask
);
2808 if (vector
->ts
.type
== BT_CHARACTER
)
2810 if (vector
->ts
.kind
== 1)
2811 f
->value
.function
.name
2812 = gfc_get_string (PREFIX ("unpack%d_char"), field
->rank
> 0 ? 1 : 0);
2814 f
->value
.function
.name
2815 = gfc_get_string (PREFIX ("unpack%d_char%d"),
2816 field
->rank
> 0 ? 1 : 0, vector
->ts
.kind
);
2819 f
->value
.function
.name
2820 = gfc_get_string (PREFIX ("unpack%d"), field
->rank
> 0 ? 1 : 0);
2825 gfc_resolve_verify (gfc_expr
*f
, gfc_expr
*string
,
2826 gfc_expr
*set ATTRIBUTE_UNUSED
,
2827 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2829 f
->ts
.type
= BT_INTEGER
;
2831 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2833 f
->ts
.kind
= gfc_default_integer_kind
;
2834 f
->value
.function
.name
= gfc_get_string ("__verify_%d", string
->ts
.kind
);
2839 gfc_resolve_xor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
2841 f
->ts
.type
= i
->ts
.type
;
2842 f
->ts
.kind
= gfc_kind_max (i
, j
);
2844 if (i
->ts
.kind
!= j
->ts
.kind
)
2846 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
2847 gfc_convert_type (j
, &i
->ts
, 2);
2849 gfc_convert_type (i
, &j
->ts
, 2);
2852 f
->value
.function
.name
2853 = gfc_get_string ("__xor_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
2857 /* Intrinsic subroutine resolution. */
2860 gfc_resolve_alarm_sub (gfc_code
*c
)
2863 gfc_expr
*seconds
, *handler
;
2867 seconds
= c
->ext
.actual
->expr
;
2868 handler
= c
->ext
.actual
->next
->expr
;
2869 ts
.type
= BT_INTEGER
;
2870 ts
.kind
= gfc_c_int_kind
;
2872 /* handler can be either BT_INTEGER or BT_PROCEDURE.
2873 In all cases, the status argument is of default integer kind
2874 (enforced in check.c) so that the function suffix is fixed. */
2875 if (handler
->ts
.type
== BT_INTEGER
)
2877 if (handler
->ts
.kind
!= gfc_c_int_kind
)
2878 gfc_convert_type (handler
, &ts
, 2);
2879 name
= gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
2880 gfc_default_integer_kind
);
2883 name
= gfc_get_string (PREFIX ("alarm_sub_i%d"),
2884 gfc_default_integer_kind
);
2886 if (seconds
->ts
.kind
!= gfc_c_int_kind
)
2887 gfc_convert_type (seconds
, &ts
, 2);
2889 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2893 gfc_resolve_cpu_time (gfc_code
*c
)
2896 name
= gfc_get_string (PREFIX ("cpu_time_%d"), c
->ext
.actual
->expr
->ts
.kind
);
2897 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2901 /* Create a formal arglist based on an actual one and set the INTENTs given. */
2903 static gfc_formal_arglist
*
2904 create_formal_for_intents (gfc_actual_arglist
* actual
, const sym_intent
* ints
)
2906 gfc_formal_arglist
* head
;
2907 gfc_formal_arglist
* tail
;
2913 head
= tail
= gfc_get_formal_arglist ();
2914 for (i
= 0; actual
; actual
= actual
->next
, tail
= tail
->next
, ++i
)
2918 sym
= gfc_new_symbol ("dummyarg", NULL
);
2919 sym
->ts
= actual
->expr
->ts
;
2921 sym
->attr
.intent
= ints
[i
];
2925 tail
->next
= gfc_get_formal_arglist ();
2933 gfc_resolve_atomic_def (gfc_code
*c
)
2935 const char *name
= "atomic_define";
2936 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2941 gfc_resolve_atomic_ref (gfc_code
*c
)
2943 const char *name
= "atomic_ref";
2944 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2949 gfc_resolve_mvbits (gfc_code
*c
)
2951 static const sym_intent INTENTS
[] = {INTENT_IN
, INTENT_IN
, INTENT_IN
,
2952 INTENT_INOUT
, INTENT_IN
};
2958 /* FROMPOS, LEN and TOPOS are restricted to small values. As such,
2959 they will be converted so that they fit into a C int. */
2960 ts
.type
= BT_INTEGER
;
2961 ts
.kind
= gfc_c_int_kind
;
2962 if (c
->ext
.actual
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
2963 gfc_convert_type (c
->ext
.actual
->next
->expr
, &ts
, 2);
2964 if (c
->ext
.actual
->next
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
2965 gfc_convert_type (c
->ext
.actual
->next
->next
->expr
, &ts
, 2);
2966 if (c
->ext
.actual
->next
->next
->next
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
2967 gfc_convert_type (c
->ext
.actual
->next
->next
->next
->next
->expr
, &ts
, 2);
2969 /* TO and FROM are guaranteed to have the same kind parameter. */
2970 name
= gfc_get_string (PREFIX ("mvbits_i%d"),
2971 c
->ext
.actual
->expr
->ts
.kind
);
2972 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2973 /* Mark as elemental subroutine as this does not happen automatically. */
2974 c
->resolved_sym
->attr
.elemental
= 1;
2976 /* Create a dummy formal arglist so the INTENTs are known later for purpose
2977 of creating temporaries. */
2978 c
->resolved_sym
->formal
= create_formal_for_intents (c
->ext
.actual
, INTENTS
);
2983 gfc_resolve_random_number (gfc_code
*c
)
2988 kind
= c
->ext
.actual
->expr
->ts
.kind
;
2989 if (c
->ext
.actual
->expr
->rank
== 0)
2990 name
= gfc_get_string (PREFIX ("random_r%d"), kind
);
2992 name
= gfc_get_string (PREFIX ("arandom_r%d"), kind
);
2994 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2999 gfc_resolve_random_seed (gfc_code
*c
)
3003 name
= gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind
);
3004 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3009 gfc_resolve_rename_sub (gfc_code
*c
)
3014 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3015 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3017 kind
= gfc_default_integer_kind
;
3019 name
= gfc_get_string (PREFIX ("rename_i%d_sub"), kind
);
3020 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3025 gfc_resolve_kill_sub (gfc_code
*c
)
3030 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3031 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3033 kind
= gfc_default_integer_kind
;
3035 name
= gfc_get_string (PREFIX ("kill_i%d_sub"), kind
);
3036 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3041 gfc_resolve_link_sub (gfc_code
*c
)
3046 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3047 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3049 kind
= gfc_default_integer_kind
;
3051 name
= gfc_get_string (PREFIX ("link_i%d_sub"), kind
);
3052 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3057 gfc_resolve_symlnk_sub (gfc_code
*c
)
3062 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3063 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3065 kind
= gfc_default_integer_kind
;
3067 name
= gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind
);
3068 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3072 /* G77 compatibility subroutines dtime() and etime(). */
3075 gfc_resolve_dtime_sub (gfc_code
*c
)
3078 name
= gfc_get_string (PREFIX ("dtime_sub"));
3079 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3083 gfc_resolve_etime_sub (gfc_code
*c
)
3086 name
= gfc_get_string (PREFIX ("etime_sub"));
3087 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3091 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
3094 gfc_resolve_itime (gfc_code
*c
)
3097 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
3098 gfc_default_integer_kind
));
3102 gfc_resolve_idate (gfc_code
*c
)
3105 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
3106 gfc_default_integer_kind
));
3110 gfc_resolve_ltime (gfc_code
*c
)
3113 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
3114 gfc_default_integer_kind
));
3118 gfc_resolve_gmtime (gfc_code
*c
)
3121 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
3122 gfc_default_integer_kind
));
3126 /* G77 compatibility subroutine second(). */
3129 gfc_resolve_second_sub (gfc_code
*c
)
3132 name
= gfc_get_string (PREFIX ("second_sub"));
3133 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3138 gfc_resolve_sleep_sub (gfc_code
*c
)
3143 if (c
->ext
.actual
->expr
!= NULL
)
3144 kind
= c
->ext
.actual
->expr
->ts
.kind
;
3146 kind
= gfc_default_integer_kind
;
3148 name
= gfc_get_string (PREFIX ("sleep_i%d_sub"), kind
);
3149 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3153 /* G77 compatibility function srand(). */
3156 gfc_resolve_srand (gfc_code
*c
)
3159 name
= gfc_get_string (PREFIX ("srand"));
3160 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3164 /* Resolve the getarg intrinsic subroutine. */
3167 gfc_resolve_getarg (gfc_code
*c
)
3171 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_default_integer_kind
)
3176 ts
.type
= BT_INTEGER
;
3177 ts
.kind
= gfc_default_integer_kind
;
3179 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3182 name
= gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind
);
3183 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3187 /* Resolve the getcwd intrinsic subroutine. */
3190 gfc_resolve_getcwd_sub (gfc_code
*c
)
3195 if (c
->ext
.actual
->next
->expr
!= NULL
)
3196 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3198 kind
= gfc_default_integer_kind
;
3200 name
= gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind
);
3201 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3205 /* Resolve the get_command intrinsic subroutine. */
3208 gfc_resolve_get_command (gfc_code
*c
)
3212 kind
= gfc_default_integer_kind
;
3213 name
= gfc_get_string (PREFIX ("get_command_i%d"), kind
);
3214 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3218 /* Resolve the get_command_argument intrinsic subroutine. */
3221 gfc_resolve_get_command_argument (gfc_code
*c
)
3225 kind
= gfc_default_integer_kind
;
3226 name
= gfc_get_string (PREFIX ("get_command_argument_i%d"), kind
);
3227 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3231 /* Resolve the get_environment_variable intrinsic subroutine. */
3234 gfc_resolve_get_environment_variable (gfc_code
*code
)
3238 kind
= gfc_default_integer_kind
;
3239 name
= gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind
);
3240 code
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3245 gfc_resolve_signal_sub (gfc_code
*c
)
3248 gfc_expr
*number
, *handler
, *status
;
3252 number
= c
->ext
.actual
->expr
;
3253 handler
= c
->ext
.actual
->next
->expr
;
3254 status
= c
->ext
.actual
->next
->next
->expr
;
3255 ts
.type
= BT_INTEGER
;
3256 ts
.kind
= gfc_c_int_kind
;
3258 /* handler can be either BT_INTEGER or BT_PROCEDURE */
3259 if (handler
->ts
.type
== BT_INTEGER
)
3261 if (handler
->ts
.kind
!= gfc_c_int_kind
)
3262 gfc_convert_type (handler
, &ts
, 2);
3263 name
= gfc_get_string (PREFIX ("signal_sub_int"));
3266 name
= gfc_get_string (PREFIX ("signal_sub"));
3268 if (number
->ts
.kind
!= gfc_c_int_kind
)
3269 gfc_convert_type (number
, &ts
, 2);
3270 if (status
!= NULL
&& status
->ts
.kind
!= gfc_c_int_kind
)
3271 gfc_convert_type (status
, &ts
, 2);
3273 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3277 /* Resolve the SYSTEM intrinsic subroutine. */
3280 gfc_resolve_system_sub (gfc_code
*c
)
3283 name
= gfc_get_string (PREFIX ("system_sub"));
3284 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3288 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
3291 gfc_resolve_system_clock (gfc_code
*c
)
3296 if (c
->ext
.actual
->expr
!= NULL
)
3297 kind
= c
->ext
.actual
->expr
->ts
.kind
;
3298 else if (c
->ext
.actual
->next
->expr
!= NULL
)
3299 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3300 else if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
3301 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
3303 kind
= gfc_default_integer_kind
;
3305 name
= gfc_get_string (PREFIX ("system_clock_%d"), kind
);
3306 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3310 /* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine. */
3312 gfc_resolve_execute_command_line (gfc_code
*c
)
3315 name
= gfc_get_string (PREFIX ("execute_command_line_i%d"),
3316 gfc_default_integer_kind
);
3317 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3321 /* Resolve the EXIT intrinsic subroutine. */
3324 gfc_resolve_exit (gfc_code
*c
)
3331 /* The STATUS argument has to be of default kind. If it is not,
3333 ts
.type
= BT_INTEGER
;
3334 ts
.kind
= gfc_default_integer_kind
;
3335 n
= c
->ext
.actual
->expr
;
3336 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3337 gfc_convert_type (n
, &ts
, 2);
3339 name
= gfc_get_string (PREFIX ("exit_i%d"), ts
.kind
);
3340 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3344 /* Resolve the FLUSH intrinsic subroutine. */
3347 gfc_resolve_flush (gfc_code
*c
)
3354 ts
.type
= BT_INTEGER
;
3355 ts
.kind
= gfc_default_integer_kind
;
3356 n
= c
->ext
.actual
->expr
;
3357 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3358 gfc_convert_type (n
, &ts
, 2);
3360 name
= gfc_get_string (PREFIX ("flush_i%d"), ts
.kind
);
3361 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3366 gfc_resolve_free (gfc_code
*c
)
3372 ts
.type
= BT_INTEGER
;
3373 ts
.kind
= gfc_index_integer_kind
;
3374 n
= c
->ext
.actual
->expr
;
3375 if (n
->ts
.kind
!= ts
.kind
)
3376 gfc_convert_type (n
, &ts
, 2);
3378 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("free"));
3383 gfc_resolve_ctime_sub (gfc_code
*c
)
3388 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3389 if (c
->ext
.actual
->expr
->ts
.kind
!= 8)
3391 ts
.type
= BT_INTEGER
;
3393 ts
.u
.derived
= NULL
;
3395 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3398 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3403 gfc_resolve_fdate_sub (gfc_code
*c
)
3405 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3410 gfc_resolve_gerror (gfc_code
*c
)
3412 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3417 gfc_resolve_getlog (gfc_code
*c
)
3419 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3424 gfc_resolve_hostnm_sub (gfc_code
*c
)
3429 if (c
->ext
.actual
->next
->expr
!= NULL
)
3430 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3432 kind
= gfc_default_integer_kind
;
3434 name
= gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind
);
3435 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3440 gfc_resolve_perror (gfc_code
*c
)
3442 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3445 /* Resolve the STAT and FSTAT intrinsic subroutines. */
3448 gfc_resolve_stat_sub (gfc_code
*c
)
3451 name
= gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind
);
3452 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3457 gfc_resolve_lstat_sub (gfc_code
*c
)
3460 name
= gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind
);
3461 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3466 gfc_resolve_fstat_sub (gfc_code
*c
)
3472 u
= c
->ext
.actual
->expr
;
3473 ts
= &c
->ext
.actual
->next
->expr
->ts
;
3474 if (u
->ts
.kind
!= ts
->kind
)
3475 gfc_convert_type (u
, ts
, 2);
3476 name
= gfc_get_string (PREFIX ("fstat_i%d_sub"), ts
->kind
);
3477 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3482 gfc_resolve_fgetc_sub (gfc_code
*c
)
3489 u
= c
->ext
.actual
->expr
;
3490 st
= c
->ext
.actual
->next
->next
->expr
;
3492 if (u
->ts
.kind
!= gfc_c_int_kind
)
3494 ts
.type
= BT_INTEGER
;
3495 ts
.kind
= gfc_c_int_kind
;
3496 ts
.u
.derived
= NULL
;
3498 gfc_convert_type (u
, &ts
, 2);
3502 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), st
->ts
.kind
);
3504 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind
);
3506 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3511 gfc_resolve_fget_sub (gfc_code
*c
)
3516 st
= c
->ext
.actual
->next
->expr
;
3518 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), st
->ts
.kind
);
3520 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind
);
3522 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3527 gfc_resolve_fputc_sub (gfc_code
*c
)
3534 u
= c
->ext
.actual
->expr
;
3535 st
= c
->ext
.actual
->next
->next
->expr
;
3537 if (u
->ts
.kind
!= gfc_c_int_kind
)
3539 ts
.type
= BT_INTEGER
;
3540 ts
.kind
= gfc_c_int_kind
;
3541 ts
.u
.derived
= NULL
;
3543 gfc_convert_type (u
, &ts
, 2);
3547 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), st
->ts
.kind
);
3549 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind
);
3551 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3556 gfc_resolve_fput_sub (gfc_code
*c
)
3561 st
= c
->ext
.actual
->next
->expr
;
3563 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), st
->ts
.kind
);
3565 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind
);
3567 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3572 gfc_resolve_fseek_sub (gfc_code
*c
)
3580 unit
= c
->ext
.actual
->expr
;
3581 offset
= c
->ext
.actual
->next
->expr
;
3582 whence
= c
->ext
.actual
->next
->next
->expr
;
3584 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3586 ts
.type
= BT_INTEGER
;
3587 ts
.kind
= gfc_c_int_kind
;
3588 ts
.u
.derived
= NULL
;
3590 gfc_convert_type (unit
, &ts
, 2);
3593 if (offset
->ts
.kind
!= gfc_intio_kind
)
3595 ts
.type
= BT_INTEGER
;
3596 ts
.kind
= gfc_intio_kind
;
3597 ts
.u
.derived
= NULL
;
3599 gfc_convert_type (offset
, &ts
, 2);
3602 if (whence
->ts
.kind
!= gfc_c_int_kind
)
3604 ts
.type
= BT_INTEGER
;
3605 ts
.kind
= gfc_c_int_kind
;
3606 ts
.u
.derived
= NULL
;
3608 gfc_convert_type (whence
, &ts
, 2);
3611 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
3615 gfc_resolve_ftell_sub (gfc_code
*c
)
3623 unit
= c
->ext
.actual
->expr
;
3624 offset
= c
->ext
.actual
->next
->expr
;
3626 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3628 ts
.type
= BT_INTEGER
;
3629 ts
.kind
= gfc_c_int_kind
;
3630 ts
.u
.derived
= NULL
;
3632 gfc_convert_type (unit
, &ts
, 2);
3635 name
= gfc_get_string (PREFIX ("ftell_i%d_sub"), offset
->ts
.kind
);
3636 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3641 gfc_resolve_ttynam_sub (gfc_code
*c
)
3646 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
3648 ts
.type
= BT_INTEGER
;
3649 ts
.kind
= gfc_c_int_kind
;
3650 ts
.u
.derived
= NULL
;
3652 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3655 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
3659 /* Resolve the UMASK intrinsic subroutine. */
3662 gfc_resolve_umask_sub (gfc_code
*c
)
3667 if (c
->ext
.actual
->next
->expr
!= NULL
)
3668 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3670 kind
= gfc_default_integer_kind
;
3672 name
= gfc_get_string (PREFIX ("umask_i%d_sub"), kind
);
3673 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3676 /* Resolve the UNLINK intrinsic subroutine. */
3679 gfc_resolve_unlink_sub (gfc_code
*c
)
3684 if (c
->ext
.actual
->next
->expr
!= NULL
)
3685 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3687 kind
= gfc_default_integer_kind
;
3689 name
= gfc_get_string (PREFIX ("unlink_i%d_sub"), kind
);
3690 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);