1 /* Intrinsic function resolution.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught & Katherine Holcomb
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
23 /* Assign name and types to intrinsic procedures. For functions, the
24 first argument to a resolution function is an expression pointer to
25 the original function node and the rest are pointers to the
26 arguments of the function call. For subroutines, a pointer to the
27 code node is passed. The result type and library subroutine name
28 are generally set according to the function arguments. */
32 #include "coretypes.h"
35 #include "intrinsic.h"
37 /* Given printf-like arguments, return a stable version of the result string.
39 We already have a working, optimized string hashing table in the form of
40 the identifier table. Reusing this table is likely not to be wasted,
41 since if the function name makes it to the gimple output of the frontend,
42 we'll have to create the identifier anyway. */
45 gfc_get_string (const char *format
, ...)
51 va_start (ap
, format
);
52 vsnprintf (temp_name
, sizeof (temp_name
), format
, ap
);
54 temp_name
[sizeof (temp_name
) - 1] = 0;
56 ident
= get_identifier (temp_name
);
57 return IDENTIFIER_POINTER (ident
);
60 /* MERGE and SPREAD need to have source charlen's present for passing
61 to the result expression. */
63 check_charlen_present (gfc_expr
*source
)
65 if (source
->ts
.cl
== NULL
)
67 source
->ts
.cl
= gfc_get_charlen ();
68 source
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
69 gfc_current_ns
->cl_list
= source
->ts
.cl
;
72 if (source
->expr_type
== EXPR_CONSTANT
)
74 source
->ts
.cl
->length
= gfc_int_expr (source
->value
.character
.length
);
77 else if (source
->expr_type
== EXPR_ARRAY
)
78 source
->ts
.cl
->length
=
79 gfc_int_expr (source
->value
.constructor
->expr
->value
.character
.length
);
82 /* Helper function for resolving the "mask" argument. */
85 resolve_mask_arg (gfc_expr
*mask
)
93 /* For the scalar case, coerce the mask to kind=4 unconditionally
94 (because this is the only kind we have a library function
97 if (mask
->ts
.kind
!= 4)
101 gfc_convert_type (mask
, &ts
, 2);
106 /* In the library, we access the mask with a GFC_LOGICAL_1
107 argument. No need to waste memory if we are about to create
108 a temporary array. */
109 if (mask
->expr_type
== EXPR_OP
&& mask
->ts
.kind
!= 1)
111 ts
.type
= BT_LOGICAL
;
113 gfc_convert_type (mask
, &ts
, 2);
118 /********************** Resolution functions **********************/
122 gfc_resolve_abs (gfc_expr
*f
, gfc_expr
*a
)
125 if (f
->ts
.type
== BT_COMPLEX
)
126 f
->ts
.type
= BT_REAL
;
128 f
->value
.function
.name
129 = gfc_get_string ("__abs_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
134 gfc_resolve_access (gfc_expr
*f
, gfc_expr
*name ATTRIBUTE_UNUSED
,
135 gfc_expr
*mode ATTRIBUTE_UNUSED
)
137 f
->ts
.type
= BT_INTEGER
;
138 f
->ts
.kind
= gfc_c_int_kind
;
139 f
->value
.function
.name
= PREFIX ("access_func");
144 gfc_resolve_adjustl (gfc_expr
*f
, gfc_expr
*string
)
146 f
->ts
.type
= BT_CHARACTER
;
147 f
->ts
.kind
= string
->ts
.kind
;
148 f
->value
.function
.name
= gfc_get_string ("__adjustl_s%d", f
->ts
.kind
);
153 gfc_resolve_adjustr (gfc_expr
*f
, gfc_expr
*string
)
155 f
->ts
.type
= BT_CHARACTER
;
156 f
->ts
.kind
= string
->ts
.kind
;
157 f
->value
.function
.name
= gfc_get_string ("__adjustr_s%d", f
->ts
.kind
);
162 gfc_resolve_char_achar (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*kind
,
165 f
->ts
.type
= BT_CHARACTER
;
166 f
->ts
.kind
= (kind
== NULL
)
167 ? gfc_default_character_kind
: mpz_get_si (kind
->value
.integer
);
168 f
->ts
.cl
= gfc_get_charlen ();
169 f
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
170 gfc_current_ns
->cl_list
= f
->ts
.cl
;
171 f
->ts
.cl
->length
= gfc_int_expr (1);
173 f
->value
.function
.name
= gfc_get_string (name
, f
->ts
.kind
,
174 gfc_type_letter (x
->ts
.type
),
180 gfc_resolve_achar (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*kind
)
182 gfc_resolve_char_achar (f
, x
, kind
, "__achar_%d_%c%d");
187 gfc_resolve_acos (gfc_expr
*f
, gfc_expr
*x
)
190 f
->value
.function
.name
191 = gfc_get_string ("__acos_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
196 gfc_resolve_acosh (gfc_expr
*f
, gfc_expr
*x
)
199 f
->value
.function
.name
200 = gfc_get_string ("__acosh_%c%d", gfc_type_letter (x
->ts
.type
),
206 gfc_resolve_aimag (gfc_expr
*f
, gfc_expr
*x
)
208 f
->ts
.type
= BT_REAL
;
209 f
->ts
.kind
= x
->ts
.kind
;
210 f
->value
.function
.name
211 = gfc_get_string ("__aimag_%c%d", gfc_type_letter (x
->ts
.type
),
217 gfc_resolve_and (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
219 f
->ts
.type
= i
->ts
.type
;
220 f
->ts
.kind
= gfc_kind_max (i
, j
);
222 if (i
->ts
.kind
!= j
->ts
.kind
)
224 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
225 gfc_convert_type (j
, &i
->ts
, 2);
227 gfc_convert_type (i
, &j
->ts
, 2);
230 f
->value
.function
.name
231 = gfc_get_string ("__and_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
236 gfc_resolve_aint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
241 f
->ts
.type
= a
->ts
.type
;
242 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
244 if (a
->ts
.kind
!= f
->ts
.kind
)
246 ts
.type
= f
->ts
.type
;
247 ts
.kind
= f
->ts
.kind
;
248 gfc_convert_type (a
, &ts
, 2);
250 /* The resolved name is only used for specific intrinsics where
251 the return kind is the same as the arg kind. */
252 f
->value
.function
.name
253 = gfc_get_string ("__aint_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
258 gfc_resolve_dint (gfc_expr
*f
, gfc_expr
*a
)
260 gfc_resolve_aint (f
, a
, NULL
);
265 gfc_resolve_all (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
)
271 gfc_resolve_dim_arg (dim
);
272 f
->rank
= mask
->rank
- 1;
273 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
276 f
->value
.function
.name
277 = gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask
->ts
.type
),
283 gfc_resolve_anint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
288 f
->ts
.type
= a
->ts
.type
;
289 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
291 if (a
->ts
.kind
!= f
->ts
.kind
)
293 ts
.type
= f
->ts
.type
;
294 ts
.kind
= f
->ts
.kind
;
295 gfc_convert_type (a
, &ts
, 2);
298 /* The resolved name is only used for specific intrinsics where
299 the return kind is the same as the arg kind. */
300 f
->value
.function
.name
301 = gfc_get_string ("__anint_%c%d", gfc_type_letter (a
->ts
.type
),
307 gfc_resolve_dnint (gfc_expr
*f
, gfc_expr
*a
)
309 gfc_resolve_anint (f
, a
, NULL
);
314 gfc_resolve_any (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
)
320 gfc_resolve_dim_arg (dim
);
321 f
->rank
= mask
->rank
- 1;
322 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
325 f
->value
.function
.name
326 = gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask
->ts
.type
),
332 gfc_resolve_asin (gfc_expr
*f
, gfc_expr
*x
)
335 f
->value
.function
.name
336 = gfc_get_string ("__asin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
340 gfc_resolve_asinh (gfc_expr
*f
, gfc_expr
*x
)
343 f
->value
.function
.name
344 = gfc_get_string ("__asinh_%c%d", gfc_type_letter (x
->ts
.type
),
349 gfc_resolve_atan (gfc_expr
*f
, gfc_expr
*x
)
352 f
->value
.function
.name
353 = gfc_get_string ("__atan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
357 gfc_resolve_atanh (gfc_expr
*f
, gfc_expr
*x
)
360 f
->value
.function
.name
361 = gfc_get_string ("__atanh_%c%d", gfc_type_letter (x
->ts
.type
),
366 gfc_resolve_atan2 (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
369 f
->value
.function
.name
370 = gfc_get_string ("__atan2_%c%d", gfc_type_letter (x
->ts
.type
),
375 /* Resolve the BESYN and BESJN intrinsics. */
378 gfc_resolve_besn (gfc_expr
*f
, gfc_expr
*n
, gfc_expr
*x
)
384 if (n
->ts
.kind
!= gfc_c_int_kind
)
386 ts
.type
= BT_INTEGER
;
387 ts
.kind
= gfc_c_int_kind
;
388 gfc_convert_type (n
, &ts
, 2);
390 f
->value
.function
.name
= gfc_get_string ("<intrinsic>");
395 gfc_resolve_btest (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos
)
397 f
->ts
.type
= BT_LOGICAL
;
398 f
->ts
.kind
= gfc_default_logical_kind
;
399 f
->value
.function
.name
400 = gfc_get_string ("__btest_%d_%d", i
->ts
.kind
, pos
->ts
.kind
);
405 gfc_resolve_ceiling (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
407 f
->ts
.type
= BT_INTEGER
;
408 f
->ts
.kind
= (kind
== NULL
)
409 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
410 f
->value
.function
.name
411 = gfc_get_string ("__ceiling_%d_%c%d", f
->ts
.kind
,
412 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
417 gfc_resolve_char (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
419 gfc_resolve_char_achar (f
, a
, kind
, "__char_%d_%c%d");
424 gfc_resolve_chdir (gfc_expr
*f
, gfc_expr
*d ATTRIBUTE_UNUSED
)
426 f
->ts
.type
= BT_INTEGER
;
427 f
->ts
.kind
= gfc_default_integer_kind
;
428 f
->value
.function
.name
= gfc_get_string (PREFIX ("chdir_i%d"), f
->ts
.kind
);
433 gfc_resolve_chdir_sub (gfc_code
*c
)
438 if (c
->ext
.actual
->next
->expr
!= NULL
)
439 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
441 kind
= gfc_default_integer_kind
;
443 name
= gfc_get_string (PREFIX ("chdir_i%d_sub"), kind
);
444 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
449 gfc_resolve_chmod (gfc_expr
*f
, gfc_expr
*name ATTRIBUTE_UNUSED
,
450 gfc_expr
*mode ATTRIBUTE_UNUSED
)
452 f
->ts
.type
= BT_INTEGER
;
453 f
->ts
.kind
= gfc_c_int_kind
;
454 f
->value
.function
.name
= PREFIX ("chmod_func");
459 gfc_resolve_chmod_sub (gfc_code
*c
)
464 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
465 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
467 kind
= gfc_default_integer_kind
;
469 name
= gfc_get_string (PREFIX ("chmod_i%d_sub"), kind
);
470 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
475 gfc_resolve_cmplx (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*kind
)
477 f
->ts
.type
= BT_COMPLEX
;
478 f
->ts
.kind
= (kind
== NULL
)
479 ? gfc_default_real_kind
: mpz_get_si (kind
->value
.integer
);
482 f
->value
.function
.name
483 = gfc_get_string ("__cmplx0_%d_%c%d", f
->ts
.kind
,
484 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
486 f
->value
.function
.name
487 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f
->ts
.kind
,
488 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
,
489 gfc_type_letter (y
->ts
.type
), y
->ts
.kind
);
494 gfc_resolve_dcmplx (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
)
496 gfc_resolve_cmplx (f
, x
, y
, gfc_int_expr (gfc_default_double_kind
));
501 gfc_resolve_complex (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y
)
505 if (x
->ts
.type
== BT_INTEGER
)
507 if (y
->ts
.type
== BT_INTEGER
)
508 kind
= gfc_default_real_kind
;
514 if (y
->ts
.type
== BT_REAL
)
515 kind
= (x
->ts
.kind
> y
->ts
.kind
) ? x
->ts
.kind
: y
->ts
.kind
;
520 f
->ts
.type
= BT_COMPLEX
;
522 f
->value
.function
.name
523 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f
->ts
.kind
,
524 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
,
525 gfc_type_letter (y
->ts
.type
), y
->ts
.kind
);
530 gfc_resolve_conjg (gfc_expr
*f
, gfc_expr
*x
)
533 f
->value
.function
.name
= gfc_get_string ("__conjg_%d", x
->ts
.kind
);
538 gfc_resolve_cos (gfc_expr
*f
, gfc_expr
*x
)
541 f
->value
.function
.name
542 = gfc_get_string ("__cos_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
547 gfc_resolve_cosh (gfc_expr
*f
, gfc_expr
*x
)
550 f
->value
.function
.name
551 = gfc_get_string ("__cosh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
556 gfc_resolve_count (gfc_expr
*f
, gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
558 f
->ts
.type
= BT_INTEGER
;
560 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
562 f
->ts
.kind
= gfc_default_integer_kind
;
566 f
->rank
= mask
->rank
- 1;
567 gfc_resolve_dim_arg (dim
);
568 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
571 resolve_mask_arg (mask
);
573 f
->value
.function
.name
574 = gfc_get_string (PREFIX ("count_%d_%c"), f
->ts
.kind
,
575 gfc_type_letter (mask
->ts
.type
));
580 gfc_resolve_cshift (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*shift
,
585 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
586 gfc_resolve_substring_charlen (array
);
589 f
->rank
= array
->rank
;
590 f
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
597 /* If dim kind is greater than default integer we need to use the larger. */
598 m
= gfc_default_integer_kind
;
600 m
= m
< dim
->ts
.kind
? dim
->ts
.kind
: m
;
602 /* Convert shift to at least m, so we don't need
603 kind=1 and kind=2 versions of the library functions. */
604 if (shift
->ts
.kind
< m
)
608 ts
.type
= BT_INTEGER
;
610 gfc_convert_type_warn (shift
, &ts
, 2, 0);
615 if (dim
->expr_type
!= EXPR_CONSTANT
&& dim
->symtree
!= NULL
616 && dim
->symtree
->n
.sym
->attr
.optional
)
618 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
619 dim
->representation
.length
= shift
->ts
.kind
;
623 gfc_resolve_dim_arg (dim
);
624 /* Convert dim to shift's kind to reduce variations. */
625 if (dim
->ts
.kind
!= shift
->ts
.kind
)
626 gfc_convert_type_warn (dim
, &shift
->ts
, 2, 0);
630 if (array
->ts
.type
== BT_CHARACTER
)
632 if (array
->ts
.kind
== gfc_default_character_kind
)
633 f
->value
.function
.name
634 = gfc_get_string (PREFIX ("cshift%d_%d_char"), n
, shift
->ts
.kind
);
636 f
->value
.function
.name
637 = gfc_get_string (PREFIX ("cshift%d_%d_char%d"), n
, shift
->ts
.kind
,
641 f
->value
.function
.name
642 = gfc_get_string (PREFIX ("cshift%d_%d"), n
, shift
->ts
.kind
);
647 gfc_resolve_ctime (gfc_expr
*f
, gfc_expr
*time
)
652 f
->ts
.type
= BT_CHARACTER
;
653 f
->ts
.kind
= gfc_default_character_kind
;
655 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
656 if (time
->ts
.kind
!= 8)
658 ts
.type
= BT_INTEGER
;
662 gfc_convert_type (time
, &ts
, 2);
665 f
->value
.function
.name
= gfc_get_string (PREFIX ("ctime"));
670 gfc_resolve_dble (gfc_expr
*f
, gfc_expr
*a
)
672 f
->ts
.type
= BT_REAL
;
673 f
->ts
.kind
= gfc_default_double_kind
;
674 f
->value
.function
.name
675 = gfc_get_string ("__dble_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
680 gfc_resolve_dim (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
682 f
->ts
.type
= a
->ts
.type
;
684 f
->ts
.kind
= gfc_kind_max (a
,p
);
686 f
->ts
.kind
= a
->ts
.kind
;
688 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
690 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
691 gfc_convert_type (p
, &a
->ts
, 2);
693 gfc_convert_type (a
, &p
->ts
, 2);
696 f
->value
.function
.name
697 = gfc_get_string ("__dim_%c%d", gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
702 gfc_resolve_dot_product (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b
)
706 temp
.expr_type
= EXPR_OP
;
707 gfc_clear_ts (&temp
.ts
);
708 temp
.value
.op
.op
= INTRINSIC_NONE
;
709 temp
.value
.op
.op1
= a
;
710 temp
.value
.op
.op2
= b
;
711 gfc_type_convert_binary (&temp
);
713 f
->value
.function
.name
714 = gfc_get_string (PREFIX ("dot_product_%c%d"),
715 gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
720 gfc_resolve_dprod (gfc_expr
*f
, gfc_expr
*a ATTRIBUTE_UNUSED
,
721 gfc_expr
*b ATTRIBUTE_UNUSED
)
723 f
->ts
.kind
= gfc_default_double_kind
;
724 f
->ts
.type
= BT_REAL
;
725 f
->value
.function
.name
= gfc_get_string ("__dprod_r%d", f
->ts
.kind
);
730 gfc_resolve_eoshift (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*shift
,
731 gfc_expr
*boundary
, gfc_expr
*dim
)
735 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
736 gfc_resolve_substring_charlen (array
);
739 f
->rank
= array
->rank
;
740 f
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
745 if (boundary
&& boundary
->rank
> 0)
748 /* If dim kind is greater than default integer we need to use the larger. */
749 m
= gfc_default_integer_kind
;
751 m
= m
< dim
->ts
.kind
? dim
->ts
.kind
: m
;
753 /* Convert shift to at least m, so we don't need
754 kind=1 and kind=2 versions of the library functions. */
755 if (shift
->ts
.kind
< m
)
759 ts
.type
= BT_INTEGER
;
761 gfc_convert_type_warn (shift
, &ts
, 2, 0);
766 if (dim
->expr_type
!= EXPR_CONSTANT
&& dim
->symtree
!= NULL
767 && dim
->symtree
->n
.sym
->attr
.optional
)
769 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
770 dim
->representation
.length
= shift
->ts
.kind
;
774 gfc_resolve_dim_arg (dim
);
775 /* Convert dim to shift's kind to reduce variations. */
776 if (dim
->ts
.kind
!= shift
->ts
.kind
)
777 gfc_convert_type_warn (dim
, &shift
->ts
, 2, 0);
781 if (array
->ts
.type
== BT_CHARACTER
)
783 if (array
->ts
.kind
== gfc_default_character_kind
)
784 f
->value
.function
.name
785 = gfc_get_string (PREFIX ("eoshift%d_%d_char"), n
, shift
->ts
.kind
);
787 f
->value
.function
.name
788 = gfc_get_string (PREFIX ("eoshift%d_%d_char%d"), n
, shift
->ts
.kind
,
792 f
->value
.function
.name
793 = gfc_get_string (PREFIX ("eoshift%d_%d"), n
, shift
->ts
.kind
);
798 gfc_resolve_exp (gfc_expr
*f
, gfc_expr
*x
)
801 f
->value
.function
.name
802 = gfc_get_string ("__exp_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
807 gfc_resolve_exponent (gfc_expr
*f
, gfc_expr
*x
)
809 f
->ts
.type
= BT_INTEGER
;
810 f
->ts
.kind
= gfc_default_integer_kind
;
811 f
->value
.function
.name
= gfc_get_string ("__exponent_%d", x
->ts
.kind
);
816 gfc_resolve_fdate (gfc_expr
*f
)
818 f
->ts
.type
= BT_CHARACTER
;
819 f
->ts
.kind
= gfc_default_character_kind
;
820 f
->value
.function
.name
= gfc_get_string (PREFIX ("fdate"));
825 gfc_resolve_floor (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
827 f
->ts
.type
= BT_INTEGER
;
828 f
->ts
.kind
= (kind
== NULL
)
829 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
830 f
->value
.function
.name
831 = gfc_get_string ("__floor%d_%c%d", f
->ts
.kind
,
832 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
837 gfc_resolve_fnum (gfc_expr
*f
, gfc_expr
*n
)
839 f
->ts
.type
= BT_INTEGER
;
840 f
->ts
.kind
= gfc_default_integer_kind
;
841 if (n
->ts
.kind
!= f
->ts
.kind
)
842 gfc_convert_type (n
, &f
->ts
, 2);
843 f
->value
.function
.name
= gfc_get_string (PREFIX ("fnum_i%d"), f
->ts
.kind
);
848 gfc_resolve_fraction (gfc_expr
*f
, gfc_expr
*x
)
851 f
->value
.function
.name
= gfc_get_string ("__fraction_%d", x
->ts
.kind
);
855 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
858 gfc_resolve_g77_math1 (gfc_expr
*f
, gfc_expr
*x
)
861 f
->value
.function
.name
= gfc_get_string ("<intrinsic>");
866 gfc_resolve_gamma (gfc_expr
*f
, gfc_expr
*x
)
869 f
->value
.function
.name
870 = gfc_get_string ("__gamma_%d", x
->ts
.kind
);
875 gfc_resolve_getcwd (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
877 f
->ts
.type
= BT_INTEGER
;
879 f
->value
.function
.name
= gfc_get_string (PREFIX ("getcwd"));
884 gfc_resolve_getgid (gfc_expr
*f
)
886 f
->ts
.type
= BT_INTEGER
;
888 f
->value
.function
.name
= gfc_get_string (PREFIX ("getgid"));
893 gfc_resolve_getpid (gfc_expr
*f
)
895 f
->ts
.type
= BT_INTEGER
;
897 f
->value
.function
.name
= gfc_get_string (PREFIX ("getpid"));
902 gfc_resolve_getuid (gfc_expr
*f
)
904 f
->ts
.type
= BT_INTEGER
;
906 f
->value
.function
.name
= gfc_get_string (PREFIX ("getuid"));
911 gfc_resolve_hostnm (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
913 f
->ts
.type
= BT_INTEGER
;
915 f
->value
.function
.name
= gfc_get_string (PREFIX ("hostnm"));
920 gfc_resolve_hypot (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*y ATTRIBUTE_UNUSED
)
923 f
->value
.function
.name
= gfc_get_string ("__hypot_r%d", x
->ts
.kind
);
928 gfc_resolve_iand (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
930 /* If the kind of i and j are different, then g77 cross-promoted the
931 kinds to the largest value. The Fortran 95 standard requires the
933 if (i
->ts
.kind
!= j
->ts
.kind
)
935 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
936 gfc_convert_type (j
, &i
->ts
, 2);
938 gfc_convert_type (i
, &j
->ts
, 2);
942 f
->value
.function
.name
= gfc_get_string ("__iand_%d", i
->ts
.kind
);
947 gfc_resolve_ibclr (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
)
950 f
->value
.function
.name
= gfc_get_string ("__ibclr_%d", i
->ts
.kind
);
955 gfc_resolve_ibits (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
,
956 gfc_expr
*len ATTRIBUTE_UNUSED
)
959 f
->value
.function
.name
= gfc_get_string ("__ibits_%d", i
->ts
.kind
);
964 gfc_resolve_ibset (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*pos ATTRIBUTE_UNUSED
)
967 f
->value
.function
.name
= gfc_get_string ("__ibset_%d", i
->ts
.kind
);
972 gfc_resolve_iachar (gfc_expr
*f
, gfc_expr
*c
, gfc_expr
*kind
)
974 f
->ts
.type
= BT_INTEGER
;
976 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
978 f
->ts
.kind
= gfc_default_integer_kind
;
979 f
->value
.function
.name
= gfc_get_string ("__ichar_%d", c
->ts
.kind
);
984 gfc_resolve_ichar (gfc_expr
*f
, gfc_expr
*c
, gfc_expr
*kind
)
986 f
->ts
.type
= BT_INTEGER
;
988 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
990 f
->ts
.kind
= gfc_default_integer_kind
;
991 f
->value
.function
.name
= gfc_get_string ("__ichar_%d", c
->ts
.kind
);
996 gfc_resolve_idnint (gfc_expr
*f
, gfc_expr
*a
)
998 gfc_resolve_nint (f
, a
, NULL
);
1003 gfc_resolve_ierrno (gfc_expr
*f
)
1005 f
->ts
.type
= BT_INTEGER
;
1006 f
->ts
.kind
= gfc_default_integer_kind
;
1007 f
->value
.function
.name
= gfc_get_string (PREFIX ("ierrno_i%d"), f
->ts
.kind
);
1012 gfc_resolve_ieor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1014 /* If the kind of i and j are different, then g77 cross-promoted the
1015 kinds to the largest value. The Fortran 95 standard requires the
1017 if (i
->ts
.kind
!= j
->ts
.kind
)
1019 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1020 gfc_convert_type (j
, &i
->ts
, 2);
1022 gfc_convert_type (i
, &j
->ts
, 2);
1026 f
->value
.function
.name
= gfc_get_string ("__ieor_%d", i
->ts
.kind
);
1031 gfc_resolve_ior (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1033 /* If the kind of i and j are different, then g77 cross-promoted the
1034 kinds to the largest value. The Fortran 95 standard requires the
1036 if (i
->ts
.kind
!= j
->ts
.kind
)
1038 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1039 gfc_convert_type (j
, &i
->ts
, 2);
1041 gfc_convert_type (i
, &j
->ts
, 2);
1045 f
->value
.function
.name
= gfc_get_string ("__ior_%d", i
->ts
.kind
);
1050 gfc_resolve_index_func (gfc_expr
*f
, gfc_expr
*str
,
1051 gfc_expr
*sub_str ATTRIBUTE_UNUSED
, gfc_expr
*back
,
1057 f
->ts
.type
= BT_INTEGER
;
1059 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1061 f
->ts
.kind
= gfc_default_integer_kind
;
1063 if (back
&& back
->ts
.kind
!= gfc_default_integer_kind
)
1065 ts
.type
= BT_LOGICAL
;
1066 ts
.kind
= gfc_default_integer_kind
;
1069 gfc_convert_type (back
, &ts
, 2);
1072 f
->value
.function
.name
1073 = gfc_get_string ("__index_%d_i%d", str
->ts
.kind
, f
->ts
.kind
);
1078 gfc_resolve_int (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1080 f
->ts
.type
= BT_INTEGER
;
1081 f
->ts
.kind
= (kind
== NULL
)
1082 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
1083 f
->value
.function
.name
1084 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1085 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1090 gfc_resolve_int2 (gfc_expr
*f
, gfc_expr
*a
)
1092 f
->ts
.type
= BT_INTEGER
;
1094 f
->value
.function
.name
1095 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1096 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1101 gfc_resolve_int8 (gfc_expr
*f
, gfc_expr
*a
)
1103 f
->ts
.type
= BT_INTEGER
;
1105 f
->value
.function
.name
1106 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1107 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1112 gfc_resolve_long (gfc_expr
*f
, gfc_expr
*a
)
1114 f
->ts
.type
= BT_INTEGER
;
1116 f
->value
.function
.name
1117 = gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
,
1118 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1123 gfc_resolve_isatty (gfc_expr
*f
, gfc_expr
*u
)
1128 f
->ts
.type
= BT_LOGICAL
;
1129 f
->ts
.kind
= gfc_default_integer_kind
;
1130 if (u
->ts
.kind
!= gfc_c_int_kind
)
1132 ts
.type
= BT_INTEGER
;
1133 ts
.kind
= gfc_c_int_kind
;
1136 gfc_convert_type (u
, &ts
, 2);
1139 f
->value
.function
.name
= gfc_get_string (PREFIX ("isatty_l%d"), f
->ts
.kind
);
1144 gfc_resolve_ishft (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1147 f
->value
.function
.name
1148 = gfc_get_string ("__ishft_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1153 gfc_resolve_rshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1156 f
->value
.function
.name
1157 = gfc_get_string ("__rshift_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1162 gfc_resolve_lshift (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
)
1165 f
->value
.function
.name
1166 = gfc_get_string ("__lshift_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
1171 gfc_resolve_ishftc (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*shift
, gfc_expr
*size
)
1175 s_kind
= (size
== NULL
) ? gfc_default_integer_kind
: size
->ts
.kind
;
1178 f
->value
.function
.name
1179 = gfc_get_string ("__ishftc_%d_%d_%d", i
->ts
.kind
, shift
->ts
.kind
, s_kind
);
1184 gfc_resolve_kill (gfc_expr
*f
, gfc_expr
*p ATTRIBUTE_UNUSED
,
1185 gfc_expr
*s ATTRIBUTE_UNUSED
)
1187 f
->ts
.type
= BT_INTEGER
;
1188 f
->ts
.kind
= gfc_default_integer_kind
;
1189 f
->value
.function
.name
= gfc_get_string (PREFIX ("kill_i%d"), f
->ts
.kind
);
1194 gfc_resolve_lbound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
1196 static char lbound
[] = "__lbound";
1198 f
->ts
.type
= BT_INTEGER
;
1200 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1202 f
->ts
.kind
= gfc_default_integer_kind
;
1207 f
->shape
= gfc_get_shape (1);
1208 mpz_init_set_ui (f
->shape
[0], array
->rank
);
1211 f
->value
.function
.name
= lbound
;
1216 gfc_resolve_len (gfc_expr
*f
, gfc_expr
*string
, gfc_expr
*kind
)
1218 f
->ts
.type
= BT_INTEGER
;
1220 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1222 f
->ts
.kind
= gfc_default_integer_kind
;
1223 f
->value
.function
.name
1224 = gfc_get_string ("__len_%d_i%d", string
->ts
.kind
,
1225 gfc_default_integer_kind
);
1230 gfc_resolve_len_trim (gfc_expr
*f
, gfc_expr
*string
, gfc_expr
*kind
)
1232 f
->ts
.type
= BT_INTEGER
;
1234 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1236 f
->ts
.kind
= gfc_default_integer_kind
;
1237 f
->value
.function
.name
= gfc_get_string ("__len_trim%d", string
->ts
.kind
);
1242 gfc_resolve_lgamma (gfc_expr
*f
, gfc_expr
*x
)
1245 f
->value
.function
.name
1246 = gfc_get_string ("__lgamma_%d", x
->ts
.kind
);
1251 gfc_resolve_link (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
1252 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
1254 f
->ts
.type
= BT_INTEGER
;
1255 f
->ts
.kind
= gfc_default_integer_kind
;
1256 f
->value
.function
.name
= gfc_get_string (PREFIX ("link_i%d"), f
->ts
.kind
);
1261 gfc_resolve_loc (gfc_expr
*f
, gfc_expr
*x
)
1263 f
->ts
.type
= BT_INTEGER
;
1264 f
->ts
.kind
= gfc_index_integer_kind
;
1265 f
->value
.function
.name
= gfc_get_string ("__loc_%d", x
->ts
.kind
);
1270 gfc_resolve_log (gfc_expr
*f
, gfc_expr
*x
)
1273 f
->value
.function
.name
1274 = gfc_get_string ("__log_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1279 gfc_resolve_log10 (gfc_expr
*f
, gfc_expr
*x
)
1282 f
->value
.function
.name
1283 = gfc_get_string ("__log10_%c%d", gfc_type_letter (x
->ts
.type
),
1289 gfc_resolve_logical (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1291 f
->ts
.type
= BT_LOGICAL
;
1292 f
->ts
.kind
= (kind
== NULL
)
1293 ? gfc_default_logical_kind
: mpz_get_si (kind
->value
.integer
);
1296 f
->value
.function
.name
1297 = gfc_get_string ("__logical_%d_%c%d", f
->ts
.kind
,
1298 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1303 gfc_resolve_malloc (gfc_expr
*f
, gfc_expr
*size
)
1305 if (size
->ts
.kind
< gfc_index_integer_kind
)
1310 ts
.type
= BT_INTEGER
;
1311 ts
.kind
= gfc_index_integer_kind
;
1312 gfc_convert_type_warn (size
, &ts
, 2, 0);
1315 f
->ts
.type
= BT_INTEGER
;
1316 f
->ts
.kind
= gfc_index_integer_kind
;
1317 f
->value
.function
.name
= gfc_get_string (PREFIX ("malloc"));
1322 gfc_resolve_matmul (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b
)
1326 if (a
->ts
.type
== BT_LOGICAL
&& b
->ts
.type
== BT_LOGICAL
)
1328 f
->ts
.type
= BT_LOGICAL
;
1329 f
->ts
.kind
= gfc_default_logical_kind
;
1333 temp
.expr_type
= EXPR_OP
;
1334 gfc_clear_ts (&temp
.ts
);
1335 temp
.value
.op
.op
= INTRINSIC_NONE
;
1336 temp
.value
.op
.op1
= a
;
1337 temp
.value
.op
.op2
= b
;
1338 gfc_type_convert_binary (&temp
);
1342 f
->rank
= (a
->rank
== 2 && b
->rank
== 2) ? 2 : 1;
1344 if (a
->rank
== 2 && b
->rank
== 2)
1346 if (a
->shape
&& b
->shape
)
1348 f
->shape
= gfc_get_shape (f
->rank
);
1349 mpz_init_set (f
->shape
[0], a
->shape
[0]);
1350 mpz_init_set (f
->shape
[1], b
->shape
[1]);
1353 else if (a
->rank
== 1)
1357 f
->shape
= gfc_get_shape (f
->rank
);
1358 mpz_init_set (f
->shape
[0], b
->shape
[1]);
1363 /* b->rank == 1 and a->rank == 2 here, all other cases have
1364 been caught in check.c. */
1367 f
->shape
= gfc_get_shape (f
->rank
);
1368 mpz_init_set (f
->shape
[0], a
->shape
[0]);
1372 f
->value
.function
.name
1373 = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f
->ts
.type
),
1379 gfc_resolve_minmax (const char *name
, gfc_expr
*f
, gfc_actual_arglist
*args
)
1381 gfc_actual_arglist
*a
;
1383 f
->ts
.type
= args
->expr
->ts
.type
;
1384 f
->ts
.kind
= args
->expr
->ts
.kind
;
1385 /* Find the largest type kind. */
1386 for (a
= args
->next
; a
; a
= a
->next
)
1388 if (a
->expr
->ts
.kind
> f
->ts
.kind
)
1389 f
->ts
.kind
= a
->expr
->ts
.kind
;
1392 /* Convert all parameters to the required kind. */
1393 for (a
= args
; a
; a
= a
->next
)
1395 if (a
->expr
->ts
.kind
!= f
->ts
.kind
)
1396 gfc_convert_type (a
->expr
, &f
->ts
, 2);
1399 f
->value
.function
.name
1400 = gfc_get_string (name
, gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
1405 gfc_resolve_max (gfc_expr
*f
, gfc_actual_arglist
*args
)
1407 gfc_resolve_minmax ("__max_%c%d", f
, args
);
1412 gfc_resolve_maxloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1418 f
->ts
.type
= BT_INTEGER
;
1419 f
->ts
.kind
= gfc_default_integer_kind
;
1424 f
->shape
= gfc_get_shape (1);
1425 mpz_init_set_si (f
->shape
[0], array
->rank
);
1429 f
->rank
= array
->rank
- 1;
1430 gfc_resolve_dim_arg (dim
);
1431 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1433 idim
= (int) mpz_get_si (dim
->value
.integer
);
1434 f
->shape
= gfc_get_shape (f
->rank
);
1435 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1437 if (i
== (idim
- 1))
1439 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1446 if (mask
->rank
== 0)
1451 resolve_mask_arg (mask
);
1456 f
->value
.function
.name
1457 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name
, dim
!= NULL
, f
->ts
.kind
,
1458 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1463 gfc_resolve_maxval (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1473 f
->rank
= array
->rank
- 1;
1474 gfc_resolve_dim_arg (dim
);
1476 if (f
->rank
&& array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1478 idim
= (int) mpz_get_si (dim
->value
.integer
);
1479 f
->shape
= gfc_get_shape (f
->rank
);
1480 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1482 if (i
== (idim
- 1))
1484 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1491 if (mask
->rank
== 0)
1496 resolve_mask_arg (mask
);
1501 f
->value
.function
.name
1502 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
1503 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1508 gfc_resolve_mclock (gfc_expr
*f
)
1510 f
->ts
.type
= BT_INTEGER
;
1512 f
->value
.function
.name
= PREFIX ("mclock");
1517 gfc_resolve_mclock8 (gfc_expr
*f
)
1519 f
->ts
.type
= BT_INTEGER
;
1521 f
->value
.function
.name
= PREFIX ("mclock8");
1526 gfc_resolve_merge (gfc_expr
*f
, gfc_expr
*tsource
,
1527 gfc_expr
*fsource ATTRIBUTE_UNUSED
,
1528 gfc_expr
*mask ATTRIBUTE_UNUSED
)
1530 if (tsource
->ts
.type
== BT_CHARACTER
&& tsource
->ref
)
1531 gfc_resolve_substring_charlen (tsource
);
1533 if (fsource
->ts
.type
== BT_CHARACTER
&& fsource
->ref
)
1534 gfc_resolve_substring_charlen (fsource
);
1536 if (tsource
->ts
.type
== BT_CHARACTER
)
1537 check_charlen_present (tsource
);
1539 f
->ts
= tsource
->ts
;
1540 f
->value
.function
.name
1541 = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource
->ts
.type
),
1547 gfc_resolve_min (gfc_expr
*f
, gfc_actual_arglist
*args
)
1549 gfc_resolve_minmax ("__min_%c%d", f
, args
);
1554 gfc_resolve_minloc (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1560 f
->ts
.type
= BT_INTEGER
;
1561 f
->ts
.kind
= gfc_default_integer_kind
;
1566 f
->shape
= gfc_get_shape (1);
1567 mpz_init_set_si (f
->shape
[0], array
->rank
);
1571 f
->rank
= array
->rank
- 1;
1572 gfc_resolve_dim_arg (dim
);
1573 if (array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1575 idim
= (int) mpz_get_si (dim
->value
.integer
);
1576 f
->shape
= gfc_get_shape (f
->rank
);
1577 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1579 if (i
== (idim
- 1))
1581 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1588 if (mask
->rank
== 0)
1593 resolve_mask_arg (mask
);
1598 f
->value
.function
.name
1599 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name
, dim
!= NULL
, f
->ts
.kind
,
1600 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1605 gfc_resolve_minval (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1615 f
->rank
= array
->rank
- 1;
1616 gfc_resolve_dim_arg (dim
);
1618 if (f
->rank
&& array
->shape
&& dim
->expr_type
== EXPR_CONSTANT
)
1620 idim
= (int) mpz_get_si (dim
->value
.integer
);
1621 f
->shape
= gfc_get_shape (f
->rank
);
1622 for (i
= 0, j
= 0; i
< f
->rank
; i
++, j
++)
1624 if (i
== (idim
- 1))
1626 mpz_init_set (f
->shape
[i
], array
->shape
[j
]);
1633 if (mask
->rank
== 0)
1638 resolve_mask_arg (mask
);
1643 f
->value
.function
.name
1644 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
1645 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1650 gfc_resolve_mod (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
1652 f
->ts
.type
= a
->ts
.type
;
1654 f
->ts
.kind
= gfc_kind_max (a
,p
);
1656 f
->ts
.kind
= a
->ts
.kind
;
1658 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
1660 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
1661 gfc_convert_type (p
, &a
->ts
, 2);
1663 gfc_convert_type (a
, &p
->ts
, 2);
1666 f
->value
.function
.name
1667 = gfc_get_string ("__mod_%c%d", gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
1672 gfc_resolve_modulo (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
1674 f
->ts
.type
= a
->ts
.type
;
1676 f
->ts
.kind
= gfc_kind_max (a
,p
);
1678 f
->ts
.kind
= a
->ts
.kind
;
1680 if (p
!= NULL
&& a
->ts
.kind
!= p
->ts
.kind
)
1682 if (a
->ts
.kind
== gfc_kind_max (a
,p
))
1683 gfc_convert_type (p
, &a
->ts
, 2);
1685 gfc_convert_type (a
, &p
->ts
, 2);
1688 f
->value
.function
.name
1689 = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f
->ts
.type
),
1694 gfc_resolve_nearest (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*p
)
1696 if (p
->ts
.kind
!= a
->ts
.kind
)
1697 gfc_convert_type (p
, &a
->ts
, 2);
1700 f
->value
.function
.name
1701 = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a
->ts
.type
),
1706 gfc_resolve_nint (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1708 f
->ts
.type
= BT_INTEGER
;
1709 f
->ts
.kind
= (kind
== NULL
)
1710 ? gfc_default_integer_kind
: mpz_get_si (kind
->value
.integer
);
1711 f
->value
.function
.name
1712 = gfc_get_string ("__nint_%d_%d", f
->ts
.kind
, a
->ts
.kind
);
1717 gfc_resolve_not (gfc_expr
*f
, gfc_expr
*i
)
1720 f
->value
.function
.name
= gfc_get_string ("__not_%d", i
->ts
.kind
);
1725 gfc_resolve_or (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
1727 f
->ts
.type
= i
->ts
.type
;
1728 f
->ts
.kind
= gfc_kind_max (i
, j
);
1730 if (i
->ts
.kind
!= j
->ts
.kind
)
1732 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
1733 gfc_convert_type (j
, &i
->ts
, 2);
1735 gfc_convert_type (i
, &j
->ts
, 2);
1738 f
->value
.function
.name
1739 = gfc_get_string ("__or_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
1744 gfc_resolve_pack (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*mask
,
1745 gfc_expr
*vector ATTRIBUTE_UNUSED
)
1747 if (array
->ts
.type
== BT_CHARACTER
&& array
->ref
)
1748 gfc_resolve_substring_charlen (array
);
1753 resolve_mask_arg (mask
);
1755 if (mask
->rank
!= 0)
1757 if (array
->ts
.type
== BT_CHARACTER
)
1758 f
->value
.function
.name
1759 = array
->ts
.kind
== 1 ? PREFIX ("pack_char")
1761 (PREFIX ("pack_char%d"),
1764 f
->value
.function
.name
= PREFIX ("pack");
1768 if (array
->ts
.type
== BT_CHARACTER
)
1769 f
->value
.function
.name
1770 = array
->ts
.kind
== 1 ? PREFIX ("pack_s_char")
1772 (PREFIX ("pack_s_char%d"),
1775 f
->value
.function
.name
= PREFIX ("pack_s");
1781 gfc_resolve_product (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
,
1790 f
->rank
= array
->rank
- 1;
1791 f
->shape
= gfc_copy_shape_excluding (array
->shape
, array
->rank
, dim
);
1792 gfc_resolve_dim_arg (dim
);
1797 if (mask
->rank
== 0)
1802 resolve_mask_arg (mask
);
1807 f
->value
.function
.name
1808 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
1809 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1814 gfc_resolve_real (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*kind
)
1816 f
->ts
.type
= BT_REAL
;
1819 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1821 f
->ts
.kind
= (a
->ts
.type
== BT_COMPLEX
)
1822 ? a
->ts
.kind
: gfc_default_real_kind
;
1824 f
->value
.function
.name
1825 = gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
1826 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1831 gfc_resolve_realpart (gfc_expr
*f
, gfc_expr
*a
)
1833 f
->ts
.type
= BT_REAL
;
1834 f
->ts
.kind
= a
->ts
.kind
;
1835 f
->value
.function
.name
1836 = gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
1837 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1842 gfc_resolve_rename (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
1843 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
1845 f
->ts
.type
= BT_INTEGER
;
1846 f
->ts
.kind
= gfc_default_integer_kind
;
1847 f
->value
.function
.name
= gfc_get_string (PREFIX ("rename_i%d"), f
->ts
.kind
);
1852 gfc_resolve_repeat (gfc_expr
*f
, gfc_expr
*string
,
1853 gfc_expr
*ncopies ATTRIBUTE_UNUSED
)
1855 f
->ts
.type
= BT_CHARACTER
;
1856 f
->ts
.kind
= string
->ts
.kind
;
1857 f
->value
.function
.name
= gfc_get_string ("__repeat_%d", string
->ts
.kind
);
1862 gfc_resolve_reshape (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*shape
,
1863 gfc_expr
*pad ATTRIBUTE_UNUSED
,
1864 gfc_expr
*order ATTRIBUTE_UNUSED
)
1870 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
1871 gfc_resolve_substring_charlen (source
);
1875 gfc_array_size (shape
, &rank
);
1876 f
->rank
= mpz_get_si (rank
);
1878 switch (source
->ts
.type
)
1885 kind
= source
->ts
.kind
;
1899 if (source
->ts
.type
== BT_COMPLEX
|| source
->ts
.type
== BT_REAL
)
1900 f
->value
.function
.name
1901 = gfc_get_string (PREFIX ("reshape_%c%d"),
1902 gfc_type_letter (source
->ts
.type
),
1904 else if (source
->ts
.type
== BT_CHARACTER
)
1905 f
->value
.function
.name
= gfc_get_string (PREFIX ("reshape_char%d"),
1908 f
->value
.function
.name
1909 = gfc_get_string (PREFIX ("reshape_%d"), source
->ts
.kind
);
1913 f
->value
.function
.name
= (source
->ts
.type
== BT_CHARACTER
1914 ? PREFIX ("reshape_char") : PREFIX ("reshape"));
1918 /* TODO: Make this work with a constant ORDER parameter. */
1919 if (shape
->expr_type
== EXPR_ARRAY
1920 && gfc_is_constant_expr (shape
)
1924 f
->shape
= gfc_get_shape (f
->rank
);
1925 c
= shape
->value
.constructor
;
1926 for (i
= 0; i
< f
->rank
; i
++)
1928 mpz_init_set (f
->shape
[i
], c
->expr
->value
.integer
);
1933 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
1934 so many runtime variations. */
1935 if (shape
->ts
.kind
!= gfc_index_integer_kind
)
1937 gfc_typespec ts
= shape
->ts
;
1938 ts
.kind
= gfc_index_integer_kind
;
1939 gfc_convert_type_warn (shape
, &ts
, 2, 0);
1941 if (order
&& order
->ts
.kind
!= gfc_index_integer_kind
)
1942 gfc_convert_type_warn (order
, &shape
->ts
, 2, 0);
1947 gfc_resolve_rrspacing (gfc_expr
*f
, gfc_expr
*x
)
1950 f
->value
.function
.name
= gfc_get_string ("__rrspacing_%d", x
->ts
.kind
);
1955 gfc_resolve_scale (gfc_expr
*f
, gfc_expr
*x
, gfc_expr
*i ATTRIBUTE_UNUSED
)
1958 f
->value
.function
.name
= gfc_get_string ("__scale_%d", x
->ts
.kind
);
1963 gfc_resolve_scan (gfc_expr
*f
, gfc_expr
*string
,
1964 gfc_expr
*set ATTRIBUTE_UNUSED
,
1965 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
1967 f
->ts
.type
= BT_INTEGER
;
1969 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1971 f
->ts
.kind
= gfc_default_integer_kind
;
1972 f
->value
.function
.name
= gfc_get_string ("__scan_%d", string
->ts
.kind
);
1977 gfc_resolve_secnds (gfc_expr
*t1
, gfc_expr
*t0
)
1980 t1
->value
.function
.name
= gfc_get_string (PREFIX ("secnds"));
1985 gfc_resolve_set_exponent (gfc_expr
*f
, gfc_expr
*x
,
1986 gfc_expr
*i ATTRIBUTE_UNUSED
)
1989 f
->value
.function
.name
= gfc_get_string ("__set_exponent_%d", x
->ts
.kind
);
1994 gfc_resolve_shape (gfc_expr
*f
, gfc_expr
*array
)
1996 f
->ts
.type
= BT_INTEGER
;
1997 f
->ts
.kind
= gfc_default_integer_kind
;
1999 f
->shape
= gfc_get_shape (1);
2000 mpz_init_set_ui (f
->shape
[0], array
->rank
);
2001 f
->value
.function
.name
= gfc_get_string (PREFIX ("shape_%d"), f
->ts
.kind
);
2006 gfc_resolve_sign (gfc_expr
*f
, gfc_expr
*a
, gfc_expr
*b ATTRIBUTE_UNUSED
)
2009 f
->value
.function
.name
2010 = gfc_get_string ("__sign_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
2015 gfc_resolve_signal (gfc_expr
*f
, gfc_expr
*number
, gfc_expr
*handler
)
2017 f
->ts
.type
= BT_INTEGER
;
2018 f
->ts
.kind
= gfc_c_int_kind
;
2020 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2021 if (handler
->ts
.type
== BT_INTEGER
)
2023 if (handler
->ts
.kind
!= gfc_c_int_kind
)
2024 gfc_convert_type (handler
, &f
->ts
, 2);
2025 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func_int"));
2028 f
->value
.function
.name
= gfc_get_string (PREFIX ("signal_func"));
2030 if (number
->ts
.kind
!= gfc_c_int_kind
)
2031 gfc_convert_type (number
, &f
->ts
, 2);
2036 gfc_resolve_sin (gfc_expr
*f
, gfc_expr
*x
)
2039 f
->value
.function
.name
2040 = gfc_get_string ("__sin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2045 gfc_resolve_sinh (gfc_expr
*f
, gfc_expr
*x
)
2048 f
->value
.function
.name
2049 = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2054 gfc_resolve_size (gfc_expr
*f
, gfc_expr
*array ATTRIBUTE_UNUSED
,
2055 gfc_expr
*dim ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2057 f
->ts
.type
= BT_INTEGER
;
2059 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2061 f
->ts
.kind
= gfc_default_integer_kind
;
2066 gfc_resolve_spacing (gfc_expr
*f
, gfc_expr
*x
)
2069 f
->value
.function
.name
= gfc_get_string ("__spacing_%d", x
->ts
.kind
);
2074 gfc_resolve_spread (gfc_expr
*f
, gfc_expr
*source
, gfc_expr
*dim
,
2077 if (source
->ts
.type
== BT_CHARACTER
&& source
->ref
)
2078 gfc_resolve_substring_charlen (source
);
2080 if (source
->ts
.type
== BT_CHARACTER
)
2081 check_charlen_present (source
);
2084 f
->rank
= source
->rank
+ 1;
2085 if (source
->rank
== 0)
2087 if (source
->ts
.type
== BT_CHARACTER
)
2088 f
->value
.function
.name
2089 = source
->ts
.kind
== 1 ? PREFIX ("spread_char_scalar")
2091 (PREFIX ("spread_char%d_scalar"),
2094 f
->value
.function
.name
= PREFIX ("spread_scalar");
2098 if (source
->ts
.type
== BT_CHARACTER
)
2099 f
->value
.function
.name
2100 = source
->ts
.kind
== 1 ? PREFIX ("spread_char")
2102 (PREFIX ("spread_char%d"),
2105 f
->value
.function
.name
= PREFIX ("spread");
2108 if (dim
&& gfc_is_constant_expr (dim
)
2109 && ncopies
&& gfc_is_constant_expr (ncopies
) && source
->shape
[0])
2112 idim
= mpz_get_ui (dim
->value
.integer
);
2113 f
->shape
= gfc_get_shape (f
->rank
);
2114 for (i
= 0; i
< (idim
- 1); i
++)
2115 mpz_init_set (f
->shape
[i
], source
->shape
[i
]);
2117 mpz_init_set (f
->shape
[idim
- 1], ncopies
->value
.integer
);
2119 for (i
= idim
; i
< f
->rank
; i
++)
2120 mpz_init_set (f
->shape
[i
], source
->shape
[i
-1]);
2124 gfc_resolve_dim_arg (dim
);
2125 gfc_resolve_index (ncopies
, 1);
2130 gfc_resolve_sqrt (gfc_expr
*f
, gfc_expr
*x
)
2133 f
->value
.function
.name
2134 = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2138 /* Resolve the g77 compatibility function STAT AND FSTAT. */
2141 gfc_resolve_stat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2142 gfc_expr
*a ATTRIBUTE_UNUSED
)
2144 f
->ts
.type
= BT_INTEGER
;
2145 f
->ts
.kind
= gfc_default_integer_kind
;
2146 f
->value
.function
.name
= gfc_get_string (PREFIX ("stat_i%d"), f
->ts
.kind
);
2151 gfc_resolve_lstat (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
,
2152 gfc_expr
*a ATTRIBUTE_UNUSED
)
2154 f
->ts
.type
= BT_INTEGER
;
2155 f
->ts
.kind
= gfc_default_integer_kind
;
2156 f
->value
.function
.name
= gfc_get_string (PREFIX ("lstat_i%d"), f
->ts
.kind
);
2161 gfc_resolve_fstat (gfc_expr
*f
, gfc_expr
*n
, gfc_expr
*a ATTRIBUTE_UNUSED
)
2163 f
->ts
.type
= BT_INTEGER
;
2164 f
->ts
.kind
= gfc_default_integer_kind
;
2165 if (n
->ts
.kind
!= f
->ts
.kind
)
2166 gfc_convert_type (n
, &f
->ts
, 2);
2168 f
->value
.function
.name
= gfc_get_string (PREFIX ("fstat_i%d"), f
->ts
.kind
);
2173 gfc_resolve_fgetc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2178 f
->ts
.type
= BT_INTEGER
;
2179 f
->ts
.kind
= gfc_c_int_kind
;
2180 if (u
->ts
.kind
!= gfc_c_int_kind
)
2182 ts
.type
= BT_INTEGER
;
2183 ts
.kind
= gfc_c_int_kind
;
2186 gfc_convert_type (u
, &ts
, 2);
2189 f
->value
.function
.name
= gfc_get_string (PREFIX ("fgetc"));
2194 gfc_resolve_fget (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2196 f
->ts
.type
= BT_INTEGER
;
2197 f
->ts
.kind
= gfc_c_int_kind
;
2198 f
->value
.function
.name
= gfc_get_string (PREFIX ("fget"));
2203 gfc_resolve_fputc (gfc_expr
*f
, gfc_expr
*u
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2208 f
->ts
.type
= BT_INTEGER
;
2209 f
->ts
.kind
= gfc_c_int_kind
;
2210 if (u
->ts
.kind
!= gfc_c_int_kind
)
2212 ts
.type
= BT_INTEGER
;
2213 ts
.kind
= gfc_c_int_kind
;
2216 gfc_convert_type (u
, &ts
, 2);
2219 f
->value
.function
.name
= gfc_get_string (PREFIX ("fputc"));
2224 gfc_resolve_fput (gfc_expr
*f
, gfc_expr
*c ATTRIBUTE_UNUSED
)
2226 f
->ts
.type
= BT_INTEGER
;
2227 f
->ts
.kind
= gfc_c_int_kind
;
2228 f
->value
.function
.name
= gfc_get_string (PREFIX ("fput"));
2233 gfc_resolve_ftell (gfc_expr
*f
, gfc_expr
*u
)
2238 f
->ts
.type
= BT_INTEGER
;
2239 f
->ts
.kind
= gfc_index_integer_kind
;
2240 if (u
->ts
.kind
!= gfc_c_int_kind
)
2242 ts
.type
= BT_INTEGER
;
2243 ts
.kind
= gfc_c_int_kind
;
2246 gfc_convert_type (u
, &ts
, 2);
2249 f
->value
.function
.name
= gfc_get_string (PREFIX ("ftell"));
2254 gfc_resolve_sum (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2262 if (mask
->rank
== 0)
2267 resolve_mask_arg (mask
);
2274 f
->rank
= array
->rank
- 1;
2275 f
->shape
= gfc_copy_shape_excluding (array
->shape
, array
->rank
, dim
);
2276 gfc_resolve_dim_arg (dim
);
2279 f
->value
.function
.name
2280 = gfc_get_string (PREFIX ("%s_%c%d"), name
,
2281 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
2286 gfc_resolve_symlnk (gfc_expr
*f
, gfc_expr
*p1 ATTRIBUTE_UNUSED
,
2287 gfc_expr
*p2 ATTRIBUTE_UNUSED
)
2289 f
->ts
.type
= BT_INTEGER
;
2290 f
->ts
.kind
= gfc_default_integer_kind
;
2291 f
->value
.function
.name
= gfc_get_string (PREFIX ("symlnk_i%d"), f
->ts
.kind
);
2295 /* Resolve the g77 compatibility function SYSTEM. */
2298 gfc_resolve_system (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
2300 f
->ts
.type
= BT_INTEGER
;
2302 f
->value
.function
.name
= gfc_get_string (PREFIX ("system"));
2307 gfc_resolve_tan (gfc_expr
*f
, gfc_expr
*x
)
2310 f
->value
.function
.name
2311 = gfc_get_string ("__tan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2316 gfc_resolve_tanh (gfc_expr
*f
, gfc_expr
*x
)
2319 f
->value
.function
.name
2320 = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
2325 gfc_resolve_time (gfc_expr
*f
)
2327 f
->ts
.type
= BT_INTEGER
;
2329 f
->value
.function
.name
= gfc_get_string (PREFIX ("time_func"));
2334 gfc_resolve_time8 (gfc_expr
*f
)
2336 f
->ts
.type
= BT_INTEGER
;
2338 f
->value
.function
.name
= gfc_get_string (PREFIX ("time8_func"));
2343 gfc_resolve_transfer (gfc_expr
*f
, gfc_expr
*source ATTRIBUTE_UNUSED
,
2344 gfc_expr
*mold
, gfc_expr
*size
)
2346 /* TODO: Make this do something meaningful. */
2347 static char transfer0
[] = "__transfer0", transfer1
[] = "__transfer1";
2349 if (mold
->ts
.type
== BT_CHARACTER
&& !mold
->ts
.cl
->length
2350 && !(mold
->expr_type
== EXPR_VARIABLE
&& mold
->symtree
->n
.sym
->attr
.dummy
))
2351 mold
->ts
.cl
->length
= gfc_int_expr (mold
->value
.character
.length
);
2355 if (size
== NULL
&& mold
->rank
== 0)
2358 f
->value
.function
.name
= transfer0
;
2363 f
->value
.function
.name
= transfer1
;
2364 if (size
&& gfc_is_constant_expr (size
))
2366 f
->shape
= gfc_get_shape (1);
2367 mpz_init_set (f
->shape
[0], size
->value
.integer
);
2374 gfc_resolve_transpose (gfc_expr
*f
, gfc_expr
*matrix
)
2377 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ref
)
2378 gfc_resolve_substring_charlen (matrix
);
2384 f
->shape
= gfc_get_shape (2);
2385 mpz_init_set (f
->shape
[0], matrix
->shape
[1]);
2386 mpz_init_set (f
->shape
[1], matrix
->shape
[0]);
2389 switch (matrix
->ts
.kind
)
2395 switch (matrix
->ts
.type
)
2399 f
->value
.function
.name
2400 = gfc_get_string (PREFIX ("transpose_%c%d"),
2401 gfc_type_letter (matrix
->ts
.type
),
2407 /* Use the integer routines for real and logical cases. This
2408 assumes they all have the same alignment requirements. */
2409 f
->value
.function
.name
2410 = gfc_get_string (PREFIX ("transpose_i%d"), matrix
->ts
.kind
);
2414 if (matrix
->ts
.type
== BT_CHARACTER
&& matrix
->ts
.kind
== 4)
2415 f
->value
.function
.name
= PREFIX ("transpose_char4");
2417 f
->value
.function
.name
= PREFIX ("transpose");
2423 f
->value
.function
.name
= (matrix
->ts
.type
== BT_CHARACTER
2424 ? PREFIX ("transpose_char")
2425 : PREFIX ("transpose"));
2432 gfc_resolve_trim (gfc_expr
*f
, gfc_expr
*string
)
2434 f
->ts
.type
= BT_CHARACTER
;
2435 f
->ts
.kind
= string
->ts
.kind
;
2436 f
->value
.function
.name
= gfc_get_string ("__trim_%d", string
->ts
.kind
);
2441 gfc_resolve_ubound (gfc_expr
*f
, gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2443 static char ubound
[] = "__ubound";
2445 f
->ts
.type
= BT_INTEGER
;
2447 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2449 f
->ts
.kind
= gfc_default_integer_kind
;
2454 f
->shape
= gfc_get_shape (1);
2455 mpz_init_set_ui (f
->shape
[0], array
->rank
);
2458 f
->value
.function
.name
= ubound
;
2462 /* Resolve the g77 compatibility function UMASK. */
2465 gfc_resolve_umask (gfc_expr
*f
, gfc_expr
*n
)
2467 f
->ts
.type
= BT_INTEGER
;
2468 f
->ts
.kind
= n
->ts
.kind
;
2469 f
->value
.function
.name
= gfc_get_string (PREFIX ("umask_i%d"), n
->ts
.kind
);
2473 /* Resolve the g77 compatibility function UNLINK. */
2476 gfc_resolve_unlink (gfc_expr
*f
, gfc_expr
*n ATTRIBUTE_UNUSED
)
2478 f
->ts
.type
= BT_INTEGER
;
2480 f
->value
.function
.name
= gfc_get_string (PREFIX ("unlink"));
2485 gfc_resolve_ttynam (gfc_expr
*f
, gfc_expr
*unit
)
2490 f
->ts
.type
= BT_CHARACTER
;
2491 f
->ts
.kind
= gfc_default_character_kind
;
2493 if (unit
->ts
.kind
!= gfc_c_int_kind
)
2495 ts
.type
= BT_INTEGER
;
2496 ts
.kind
= gfc_c_int_kind
;
2499 gfc_convert_type (unit
, &ts
, 2);
2502 f
->value
.function
.name
= gfc_get_string (PREFIX ("ttynam"));
2507 gfc_resolve_unpack (gfc_expr
*f
, gfc_expr
*vector
, gfc_expr
*mask
,
2508 gfc_expr
*field ATTRIBUTE_UNUSED
)
2510 if (vector
->ts
.type
== BT_CHARACTER
&& vector
->ref
)
2511 gfc_resolve_substring_charlen (vector
);
2514 f
->rank
= mask
->rank
;
2515 resolve_mask_arg (mask
);
2517 if (vector
->ts
.type
== BT_CHARACTER
)
2519 if (vector
->ts
.kind
== 1)
2520 f
->value
.function
.name
2521 = gfc_get_string (PREFIX ("unpack%d_char"), field
->rank
> 0 ? 1 : 0);
2523 f
->value
.function
.name
2524 = gfc_get_string (PREFIX ("unpack%d_char%d"),
2525 field
->rank
> 0 ? 1 : 0, vector
->ts
.kind
);
2528 f
->value
.function
.name
2529 = gfc_get_string (PREFIX ("unpack%d"), field
->rank
> 0 ? 1 : 0);
2534 gfc_resolve_verify (gfc_expr
*f
, gfc_expr
*string
,
2535 gfc_expr
*set ATTRIBUTE_UNUSED
,
2536 gfc_expr
*back ATTRIBUTE_UNUSED
, gfc_expr
*kind
)
2538 f
->ts
.type
= BT_INTEGER
;
2540 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
2542 f
->ts
.kind
= gfc_default_integer_kind
;
2543 f
->value
.function
.name
= gfc_get_string ("__verify_%d", string
->ts
.kind
);
2548 gfc_resolve_xor (gfc_expr
*f
, gfc_expr
*i
, gfc_expr
*j
)
2550 f
->ts
.type
= i
->ts
.type
;
2551 f
->ts
.kind
= gfc_kind_max (i
, j
);
2553 if (i
->ts
.kind
!= j
->ts
.kind
)
2555 if (i
->ts
.kind
== gfc_kind_max (i
, j
))
2556 gfc_convert_type (j
, &i
->ts
, 2);
2558 gfc_convert_type (i
, &j
->ts
, 2);
2561 f
->value
.function
.name
2562 = gfc_get_string ("__xor_%c%d", gfc_type_letter (i
->ts
.type
), f
->ts
.kind
);
2566 /* Intrinsic subroutine resolution. */
2569 gfc_resolve_alarm_sub (gfc_code
*c
)
2572 gfc_expr
*seconds
, *handler
, *status
;
2576 seconds
= c
->ext
.actual
->expr
;
2577 handler
= c
->ext
.actual
->next
->expr
;
2578 status
= c
->ext
.actual
->next
->next
->expr
;
2579 ts
.type
= BT_INTEGER
;
2580 ts
.kind
= gfc_c_int_kind
;
2582 /* handler can be either BT_INTEGER or BT_PROCEDURE.
2583 In all cases, the status argument is of default integer kind
2584 (enforced in check.c) so that the function suffix is fixed. */
2585 if (handler
->ts
.type
== BT_INTEGER
)
2587 if (handler
->ts
.kind
!= gfc_c_int_kind
)
2588 gfc_convert_type (handler
, &ts
, 2);
2589 name
= gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
2590 gfc_default_integer_kind
);
2593 name
= gfc_get_string (PREFIX ("alarm_sub_i%d"),
2594 gfc_default_integer_kind
);
2596 if (seconds
->ts
.kind
!= gfc_c_int_kind
)
2597 gfc_convert_type (seconds
, &ts
, 2);
2599 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2603 gfc_resolve_cpu_time (gfc_code
*c
)
2606 name
= gfc_get_string (PREFIX ("cpu_time_%d"), c
->ext
.actual
->expr
->ts
.kind
);
2607 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2611 /* Create a formal arglist based on an actual one and set the INTENTs given. */
2613 static gfc_formal_arglist
*
2614 create_formal_for_intents (gfc_actual_arglist
* actual
, const sym_intent
* ints
)
2616 gfc_formal_arglist
* head
;
2617 gfc_formal_arglist
* tail
;
2623 head
= tail
= gfc_get_formal_arglist ();
2624 for (i
= 0; actual
; actual
= actual
->next
, tail
= tail
->next
, ++i
)
2628 sym
= gfc_new_symbol ("dummyarg", NULL
);
2629 sym
->ts
= actual
->expr
->ts
;
2631 sym
->attr
.intent
= ints
[i
];
2635 tail
->next
= gfc_get_formal_arglist ();
2643 gfc_resolve_mvbits (gfc_code
*c
)
2645 static const sym_intent INTENTS
[] = {INTENT_IN
, INTENT_IN
, INTENT_IN
,
2646 INTENT_INOUT
, INTENT_IN
};
2652 /* FROMPOS, LEN and TOPOS are restricted to small values. As such,
2653 they will be converted so that they fit into a C int. */
2654 ts
.type
= BT_INTEGER
;
2655 ts
.kind
= gfc_c_int_kind
;
2656 if (c
->ext
.actual
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
2657 gfc_convert_type (c
->ext
.actual
->next
->expr
, &ts
, 2);
2658 if (c
->ext
.actual
->next
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
2659 gfc_convert_type (c
->ext
.actual
->next
->next
->expr
, &ts
, 2);
2660 if (c
->ext
.actual
->next
->next
->next
->next
->expr
->ts
.kind
!= gfc_c_int_kind
)
2661 gfc_convert_type (c
->ext
.actual
->next
->next
->next
->next
->expr
, &ts
, 2);
2663 /* TO and FROM are guaranteed to have the same kind parameter. */
2664 name
= gfc_get_string (PREFIX ("mvbits_i%d"),
2665 c
->ext
.actual
->expr
->ts
.kind
);
2666 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2667 /* Mark as elemental subroutine as this does not happen automatically. */
2668 c
->resolved_sym
->attr
.elemental
= 1;
2670 /* Create a dummy formal arglist so the INTENTs are known later for purpose
2671 of creating temporaries. */
2672 c
->resolved_sym
->formal
= create_formal_for_intents (c
->ext
.actual
, INTENTS
);
2677 gfc_resolve_random_number (gfc_code
*c
)
2682 kind
= c
->ext
.actual
->expr
->ts
.kind
;
2683 if (c
->ext
.actual
->expr
->rank
== 0)
2684 name
= gfc_get_string (PREFIX ("random_r%d"), kind
);
2686 name
= gfc_get_string (PREFIX ("arandom_r%d"), kind
);
2688 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2693 gfc_resolve_random_seed (gfc_code
*c
)
2697 name
= gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind
);
2698 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2703 gfc_resolve_rename_sub (gfc_code
*c
)
2708 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
2709 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
2711 kind
= gfc_default_integer_kind
;
2713 name
= gfc_get_string (PREFIX ("rename_i%d_sub"), kind
);
2714 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2719 gfc_resolve_kill_sub (gfc_code
*c
)
2724 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
2725 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
2727 kind
= gfc_default_integer_kind
;
2729 name
= gfc_get_string (PREFIX ("kill_i%d_sub"), kind
);
2730 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2735 gfc_resolve_link_sub (gfc_code
*c
)
2740 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
2741 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
2743 kind
= gfc_default_integer_kind
;
2745 name
= gfc_get_string (PREFIX ("link_i%d_sub"), kind
);
2746 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2751 gfc_resolve_symlnk_sub (gfc_code
*c
)
2756 if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
2757 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
2759 kind
= gfc_default_integer_kind
;
2761 name
= gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind
);
2762 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2766 /* G77 compatibility subroutines dtime() and etime(). */
2769 gfc_resolve_dtime_sub (gfc_code
*c
)
2772 name
= gfc_get_string (PREFIX ("dtime_sub"));
2773 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2777 gfc_resolve_etime_sub (gfc_code
*c
)
2780 name
= gfc_get_string (PREFIX ("etime_sub"));
2781 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2785 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
2788 gfc_resolve_itime (gfc_code
*c
)
2791 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
2792 gfc_default_integer_kind
));
2796 gfc_resolve_idate (gfc_code
*c
)
2799 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
2800 gfc_default_integer_kind
));
2804 gfc_resolve_ltime (gfc_code
*c
)
2807 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
2808 gfc_default_integer_kind
));
2812 gfc_resolve_gmtime (gfc_code
*c
)
2815 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
2816 gfc_default_integer_kind
));
2820 /* G77 compatibility subroutine second(). */
2823 gfc_resolve_second_sub (gfc_code
*c
)
2826 name
= gfc_get_string (PREFIX ("second_sub"));
2827 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2832 gfc_resolve_sleep_sub (gfc_code
*c
)
2837 if (c
->ext
.actual
->expr
!= NULL
)
2838 kind
= c
->ext
.actual
->expr
->ts
.kind
;
2840 kind
= gfc_default_integer_kind
;
2842 name
= gfc_get_string (PREFIX ("sleep_i%d_sub"), kind
);
2843 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2847 /* G77 compatibility function srand(). */
2850 gfc_resolve_srand (gfc_code
*c
)
2853 name
= gfc_get_string (PREFIX ("srand"));
2854 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2858 /* Resolve the getarg intrinsic subroutine. */
2861 gfc_resolve_getarg (gfc_code
*c
)
2865 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_default_integer_kind
)
2870 ts
.type
= BT_INTEGER
;
2871 ts
.kind
= gfc_default_integer_kind
;
2873 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
2876 name
= gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind
);
2877 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2881 /* Resolve the getcwd intrinsic subroutine. */
2884 gfc_resolve_getcwd_sub (gfc_code
*c
)
2889 if (c
->ext
.actual
->next
->expr
!= NULL
)
2890 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
2892 kind
= gfc_default_integer_kind
;
2894 name
= gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind
);
2895 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2899 /* Resolve the get_command intrinsic subroutine. */
2902 gfc_resolve_get_command (gfc_code
*c
)
2906 kind
= gfc_default_integer_kind
;
2907 name
= gfc_get_string (PREFIX ("get_command_i%d"), kind
);
2908 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2912 /* Resolve the get_command_argument intrinsic subroutine. */
2915 gfc_resolve_get_command_argument (gfc_code
*c
)
2919 kind
= gfc_default_integer_kind
;
2920 name
= gfc_get_string (PREFIX ("get_command_argument_i%d"), kind
);
2921 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2925 /* Resolve the get_environment_variable intrinsic subroutine. */
2928 gfc_resolve_get_environment_variable (gfc_code
*code
)
2932 kind
= gfc_default_integer_kind
;
2933 name
= gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind
);
2934 code
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2939 gfc_resolve_signal_sub (gfc_code
*c
)
2942 gfc_expr
*number
, *handler
, *status
;
2946 number
= c
->ext
.actual
->expr
;
2947 handler
= c
->ext
.actual
->next
->expr
;
2948 status
= c
->ext
.actual
->next
->next
->expr
;
2949 ts
.type
= BT_INTEGER
;
2950 ts
.kind
= gfc_c_int_kind
;
2952 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2953 if (handler
->ts
.type
== BT_INTEGER
)
2955 if (handler
->ts
.kind
!= gfc_c_int_kind
)
2956 gfc_convert_type (handler
, &ts
, 2);
2957 name
= gfc_get_string (PREFIX ("signal_sub_int"));
2960 name
= gfc_get_string (PREFIX ("signal_sub"));
2962 if (number
->ts
.kind
!= gfc_c_int_kind
)
2963 gfc_convert_type (number
, &ts
, 2);
2964 if (status
!= NULL
&& status
->ts
.kind
!= gfc_c_int_kind
)
2965 gfc_convert_type (status
, &ts
, 2);
2967 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2971 /* Resolve the SYSTEM intrinsic subroutine. */
2974 gfc_resolve_system_sub (gfc_code
*c
)
2977 name
= gfc_get_string (PREFIX ("system_sub"));
2978 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
2982 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
2985 gfc_resolve_system_clock (gfc_code
*c
)
2990 if (c
->ext
.actual
->expr
!= NULL
)
2991 kind
= c
->ext
.actual
->expr
->ts
.kind
;
2992 else if (c
->ext
.actual
->next
->expr
!= NULL
)
2993 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
2994 else if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
2995 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
2997 kind
= gfc_default_integer_kind
;
2999 name
= gfc_get_string (PREFIX ("system_clock_%d"), kind
);
3000 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3004 /* Resolve the EXIT intrinsic subroutine. */
3007 gfc_resolve_exit (gfc_code
*c
)
3014 /* The STATUS argument has to be of default kind. If it is not,
3016 ts
.type
= BT_INTEGER
;
3017 ts
.kind
= gfc_default_integer_kind
;
3018 n
= c
->ext
.actual
->expr
;
3019 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3020 gfc_convert_type (n
, &ts
, 2);
3022 name
= gfc_get_string (PREFIX ("exit_i%d"), ts
.kind
);
3023 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3027 /* Resolve the FLUSH intrinsic subroutine. */
3030 gfc_resolve_flush (gfc_code
*c
)
3037 ts
.type
= BT_INTEGER
;
3038 ts
.kind
= gfc_default_integer_kind
;
3039 n
= c
->ext
.actual
->expr
;
3040 if (n
!= NULL
&& n
->ts
.kind
!= ts
.kind
)
3041 gfc_convert_type (n
, &ts
, 2);
3043 name
= gfc_get_string (PREFIX ("flush_i%d"), ts
.kind
);
3044 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3049 gfc_resolve_free (gfc_code
*c
)
3055 ts
.type
= BT_INTEGER
;
3056 ts
.kind
= gfc_index_integer_kind
;
3057 n
= c
->ext
.actual
->expr
;
3058 if (n
->ts
.kind
!= ts
.kind
)
3059 gfc_convert_type (n
, &ts
, 2);
3061 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("free"));
3066 gfc_resolve_ctime_sub (gfc_code
*c
)
3071 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3072 if (c
->ext
.actual
->expr
->ts
.kind
!= 8)
3074 ts
.type
= BT_INTEGER
;
3078 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3081 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3086 gfc_resolve_fdate_sub (gfc_code
*c
)
3088 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3093 gfc_resolve_gerror (gfc_code
*c
)
3095 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3100 gfc_resolve_getlog (gfc_code
*c
)
3102 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3107 gfc_resolve_hostnm_sub (gfc_code
*c
)
3112 if (c
->ext
.actual
->next
->expr
!= NULL
)
3113 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3115 kind
= gfc_default_integer_kind
;
3117 name
= gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind
);
3118 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3123 gfc_resolve_perror (gfc_code
*c
)
3125 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3128 /* Resolve the STAT and FSTAT intrinsic subroutines. */
3131 gfc_resolve_stat_sub (gfc_code
*c
)
3134 name
= gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind
);
3135 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3140 gfc_resolve_lstat_sub (gfc_code
*c
)
3143 name
= gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind
);
3144 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3149 gfc_resolve_fstat_sub (gfc_code
*c
)
3155 u
= c
->ext
.actual
->expr
;
3156 ts
= &c
->ext
.actual
->next
->expr
->ts
;
3157 if (u
->ts
.kind
!= ts
->kind
)
3158 gfc_convert_type (u
, ts
, 2);
3159 name
= gfc_get_string (PREFIX ("fstat_i%d_sub"), ts
->kind
);
3160 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3165 gfc_resolve_fgetc_sub (gfc_code
*c
)
3172 u
= c
->ext
.actual
->expr
;
3173 st
= c
->ext
.actual
->next
->next
->expr
;
3175 if (u
->ts
.kind
!= gfc_c_int_kind
)
3177 ts
.type
= BT_INTEGER
;
3178 ts
.kind
= gfc_c_int_kind
;
3181 gfc_convert_type (u
, &ts
, 2);
3185 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), st
->ts
.kind
);
3187 name
= gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind
);
3189 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3194 gfc_resolve_fget_sub (gfc_code
*c
)
3199 st
= c
->ext
.actual
->next
->expr
;
3201 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), st
->ts
.kind
);
3203 name
= gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind
);
3205 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3210 gfc_resolve_fputc_sub (gfc_code
*c
)
3217 u
= c
->ext
.actual
->expr
;
3218 st
= c
->ext
.actual
->next
->next
->expr
;
3220 if (u
->ts
.kind
!= gfc_c_int_kind
)
3222 ts
.type
= BT_INTEGER
;
3223 ts
.kind
= gfc_c_int_kind
;
3226 gfc_convert_type (u
, &ts
, 2);
3230 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), st
->ts
.kind
);
3232 name
= gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind
);
3234 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3239 gfc_resolve_fput_sub (gfc_code
*c
)
3244 st
= c
->ext
.actual
->next
->expr
;
3246 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), st
->ts
.kind
);
3248 name
= gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind
);
3250 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3255 gfc_resolve_fseek_sub (gfc_code
*c
)
3264 unit
= c
->ext
.actual
->expr
;
3265 offset
= c
->ext
.actual
->next
->expr
;
3266 whence
= c
->ext
.actual
->next
->next
->expr
;
3267 status
= c
->ext
.actual
->next
->next
->next
->expr
;
3269 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3271 ts
.type
= BT_INTEGER
;
3272 ts
.kind
= gfc_c_int_kind
;
3275 gfc_convert_type (unit
, &ts
, 2);
3278 if (offset
->ts
.kind
!= gfc_intio_kind
)
3280 ts
.type
= BT_INTEGER
;
3281 ts
.kind
= gfc_intio_kind
;
3284 gfc_convert_type (offset
, &ts
, 2);
3287 if (whence
->ts
.kind
!= gfc_c_int_kind
)
3289 ts
.type
= BT_INTEGER
;
3290 ts
.kind
= gfc_c_int_kind
;
3293 gfc_convert_type (whence
, &ts
, 2);
3296 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
3300 gfc_resolve_ftell_sub (gfc_code
*c
)
3308 unit
= c
->ext
.actual
->expr
;
3309 offset
= c
->ext
.actual
->next
->expr
;
3311 if (unit
->ts
.kind
!= gfc_c_int_kind
)
3313 ts
.type
= BT_INTEGER
;
3314 ts
.kind
= gfc_c_int_kind
;
3317 gfc_convert_type (unit
, &ts
, 2);
3320 name
= gfc_get_string (PREFIX ("ftell_i%d_sub"), offset
->ts
.kind
);
3321 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3326 gfc_resolve_ttynam_sub (gfc_code
*c
)
3331 if (c
->ext
.actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
3333 ts
.type
= BT_INTEGER
;
3334 ts
.kind
= gfc_c_int_kind
;
3337 gfc_convert_type (c
->ext
.actual
->expr
, &ts
, 2);
3340 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
3344 /* Resolve the UMASK intrinsic subroutine. */
3347 gfc_resolve_umask_sub (gfc_code
*c
)
3352 if (c
->ext
.actual
->next
->expr
!= NULL
)
3353 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3355 kind
= gfc_default_integer_kind
;
3357 name
= gfc_get_string (PREFIX ("umask_i%d_sub"), kind
);
3358 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
3361 /* Resolve the UNLINK intrinsic subroutine. */
3364 gfc_resolve_unlink_sub (gfc_code
*c
)
3369 if (c
->ext
.actual
->next
->expr
!= NULL
)
3370 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
3372 kind
= gfc_default_integer_kind
;
3374 name
= gfc_get_string (PREFIX ("unlink_i%d_sub"), kind
);
3375 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);