1 /* Intrinsic function resolution.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught & Katherine Holcomb
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
24 /* Assign name and types to intrinsic procedures. For functions, the
25 first argument to a resolution function is an expression pointer to
26 the original function node and the rest are pointers to the
27 arguments of the function call. For subroutines, a pointer to the
28 code node is passed. The result type and library subroutine name
29 are generally set according to the function arguments. */
33 #include "coretypes.h"
36 #include "intrinsic.h"
37 #include "constructor.h"
40 /* Given printf-like arguments, return a stable version of the result string.
42 We already have a working, optimized string hashing table in the form of
43 the identifier table. Reusing this table is likely not to be wasted,
44 since if the function name makes it to the gimple output of the frontend,
45 we'll have to create the identifier anyway. */
48 gfc_get_string (const char *format, ...)
54 va_start (ap, format);
55 vsnprintf (temp_name, sizeof (temp_name), format, ap);
57 temp_name[sizeof (temp_name) - 1] = 0;
59 ident = get_identifier (temp_name);
60 return IDENTIFIER_POINTER (ident);
63 /* MERGE and SPREAD need to have source charlen's present for passing
64 to the result expression. */
66 check_charlen_present (gfc_expr *source)
68 if (source->ts.u.cl == NULL)
69 source->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
71 if (source->expr_type == EXPR_CONSTANT)
73 source->ts.u.cl->length
74 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
75 source->value.character.length);
78 else if (source->expr_type == EXPR_ARRAY)
80 gfc_constructor *c = gfc_constructor_first (source->value.constructor);
81 source->ts.u.cl->length
82 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
83 c->expr->value.character.length);
87 /* Helper function for resolving the "mask" argument. */
90 resolve_mask_arg (gfc_expr *mask)
98 /* For the scalar case, coerce the mask to kind=4 unconditionally
99 (because this is the only kind we have a library function
102 if (mask->ts.kind != 4)
104 ts.type = BT_LOGICAL;
106 gfc_convert_type (mask, &ts, 2);
111 /* In the library, we access the mask with a GFC_LOGICAL_1
112 argument. No need to waste memory if we are about to create
113 a temporary array. */
114 if (mask->expr_type == EXPR_OP && mask->ts.kind != 1)
116 ts.type = BT_LOGICAL;
118 gfc_convert_type_warn (mask, &ts, 2, 0);
125 resolve_bound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind,
126 const char *name, bool coarray)
128 f->ts.type = BT_INTEGER;
130 f->ts.kind = mpz_get_si (kind->value.integer);
132 f->ts.kind = gfc_default_integer_kind;
137 f->shape = gfc_get_shape (1);
138 mpz_init_set_ui (f->shape[0], coarray ? gfc_get_corank (array)
142 f->value.function.name = xstrdup (name);
147 resolve_transformational (const char *name, gfc_expr *f, gfc_expr *array,
148 gfc_expr *dim, gfc_expr *mask)
161 resolve_mask_arg (mask);
168 f->rank = array->rank - 1;
169 f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
170 gfc_resolve_dim_arg (dim);
173 f->value.function.name
174 = gfc_get_string (PREFIX ("%s%s_%c%d"), prefix, name,
175 gfc_type_letter (array->ts.type), array->ts.kind);
179 /********************** Resolution functions **********************/
183 gfc_resolve_abs (gfc_expr *f, gfc_expr *a)
186 if (f->ts.type == BT_COMPLEX)
187 f->ts.type = BT_REAL;
189 f->value.function.name
190 = gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
195 gfc_resolve_access (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
196 gfc_expr *mode ATTRIBUTE_UNUSED)
198 f->ts.type = BT_INTEGER;
199 f->ts.kind = gfc_c_int_kind;
200 f->value.function.name = PREFIX ("access_func");
205 gfc_resolve_adjustl (gfc_expr *f, gfc_expr *string)
207 f->ts.type = BT_CHARACTER;
208 f->ts.kind = string->ts.kind;
209 f->value.function.name = gfc_get_string ("__adjustl_s%d", f->ts.kind);
214 gfc_resolve_adjustr (gfc_expr *f, gfc_expr *string)
216 f->ts.type = BT_CHARACTER;
217 f->ts.kind = string->ts.kind;
218 f->value.function.name = gfc_get_string ("__adjustr_s%d", f->ts.kind);
223 gfc_resolve_char_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind,
226 f->ts.type = BT_CHARACTER;
227 f->ts.kind = (kind == NULL)
228 ? gfc_default_character_kind : mpz_get_si (kind->value.integer);
229 f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
230 f->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
232 f->value.function.name = gfc_get_string (name, f->ts.kind,
233 gfc_type_letter (x->ts.type),
239 gfc_resolve_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind)
241 gfc_resolve_char_achar (f, x, kind, "__achar_%d_%c%d");
246 gfc_resolve_acos (gfc_expr *f, gfc_expr *x)
249 f->value.function.name
250 = gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
255 gfc_resolve_acosh (gfc_expr *f, gfc_expr *x)
258 f->value.function.name
259 = gfc_get_string ("__acosh_%c%d", gfc_type_letter (x->ts.type),
265 gfc_resolve_aimag (gfc_expr *f, gfc_expr *x)
267 f->ts.type = BT_REAL;
268 f->ts.kind = x->ts.kind;
269 f->value.function.name
270 = gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type),
276 gfc_resolve_and (gfc_expr *f, gfc_expr *i, gfc_expr *j)
278 f->ts.type = i->ts.type;
279 f->ts.kind = gfc_kind_max (i, j);
281 if (i->ts.kind != j->ts.kind)
283 if (i->ts.kind == gfc_kind_max (i, j))
284 gfc_convert_type (j, &i->ts, 2);
286 gfc_convert_type (i, &j->ts, 2);
289 f->value.function.name
290 = gfc_get_string ("__and_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
295 gfc_resolve_aint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
300 f->ts.type = a->ts.type;
301 f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
303 if (a->ts.kind != f->ts.kind)
305 ts.type = f->ts.type;
306 ts.kind = f->ts.kind;
307 gfc_convert_type (a, &ts, 2);
309 /* The resolved name is only used for specific intrinsics where
310 the return kind is the same as the arg kind. */
311 f->value.function.name
312 = gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
317 gfc_resolve_dint (gfc_expr *f, gfc_expr *a)
319 gfc_resolve_aint (f, a, NULL);
324 gfc_resolve_all (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
330 gfc_resolve_dim_arg (dim);
331 f->rank = mask->rank - 1;
332 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
335 f->value.function.name
336 = gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask->ts.type),
342 gfc_resolve_anint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
347 f->ts.type = a->ts.type;
348 f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
350 if (a->ts.kind != f->ts.kind)
352 ts.type = f->ts.type;
353 ts.kind = f->ts.kind;
354 gfc_convert_type (a, &ts, 2);
357 /* The resolved name is only used for specific intrinsics where
358 the return kind is the same as the arg kind. */
359 f->value.function.name
360 = gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type),
366 gfc_resolve_dnint (gfc_expr *f, gfc_expr *a)
368 gfc_resolve_anint (f, a, NULL);
373 gfc_resolve_any (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
379 gfc_resolve_dim_arg (dim);
380 f->rank = mask->rank - 1;
381 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
384 f->value.function.name
385 = gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask->ts.type),
391 gfc_resolve_asin (gfc_expr *f, gfc_expr *x)
394 f->value.function.name
395 = gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
399 gfc_resolve_asinh (gfc_expr *f, gfc_expr *x)
402 f->value.function.name
403 = gfc_get_string ("__asinh_%c%d", gfc_type_letter (x->ts.type),
408 gfc_resolve_atan (gfc_expr *f, gfc_expr *x)
411 f->value.function.name
412 = gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
416 gfc_resolve_atanh (gfc_expr *f, gfc_expr *x)
419 f->value.function.name
420 = gfc_get_string ("__atanh_%c%d", gfc_type_letter (x->ts.type),
425 gfc_resolve_atan2 (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
428 f->value.function.name
429 = gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type),
434 /* Resolve the BESYN and BESJN intrinsics. */
437 gfc_resolve_besn (gfc_expr *f, gfc_expr *n, gfc_expr *x)
443 if (n->ts.kind != gfc_c_int_kind)
445 ts.type = BT_INTEGER;
446 ts.kind = gfc_c_int_kind;
447 gfc_convert_type (n, &ts, 2);
449 f->value.function.name = gfc_get_string ("<intrinsic>");
454 gfc_resolve_bessel_n2 (gfc_expr *f, gfc_expr *n1, gfc_expr *n2, gfc_expr *x)
461 if (n1->expr_type == EXPR_CONSTANT && n2->expr_type == EXPR_CONSTANT)
463 f->shape = gfc_get_shape (1);
464 mpz_init (f->shape[0]);
465 mpz_sub (f->shape[0], n2->value.integer, n1->value.integer);
466 mpz_add_ui (f->shape[0], f->shape[0], 1);
469 if (n1->ts.kind != gfc_c_int_kind)
471 ts.type = BT_INTEGER;
472 ts.kind = gfc_c_int_kind;
473 gfc_convert_type (n1, &ts, 2);
476 if (n2->ts.kind != gfc_c_int_kind)
478 ts.type = BT_INTEGER;
479 ts.kind = gfc_c_int_kind;
480 gfc_convert_type (n2, &ts, 2);
483 if (f->value.function.isym->id == GFC_ISYM_JN2)
484 f->value.function.name = gfc_get_string (PREFIX ("bessel_jn_r%d"),
487 f->value.function.name = gfc_get_string (PREFIX ("bessel_yn_r%d"),
493 gfc_resolve_btest (gfc_expr *f, gfc_expr *i, gfc_expr *pos)
495 f->ts.type = BT_LOGICAL;
496 f->ts.kind = gfc_default_logical_kind;
497 f->value.function.name
498 = gfc_get_string ("__btest_%d_%d", i->ts.kind, pos->ts.kind);
503 gfc_resolve_ceiling (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
505 f->ts.type = BT_INTEGER;
506 f->ts.kind = (kind == NULL)
507 ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
508 f->value.function.name
509 = gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind,
510 gfc_type_letter (a->ts.type), a->ts.kind);
515 gfc_resolve_char (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
517 gfc_resolve_char_achar (f, a, kind, "__char_%d_%c%d");
522 gfc_resolve_chdir (gfc_expr *f, gfc_expr *d ATTRIBUTE_UNUSED)
524 f->ts.type = BT_INTEGER;
525 f->ts.kind = gfc_default_integer_kind;
526 f->value.function.name = gfc_get_string (PREFIX ("chdir_i%d"), f->ts.kind);
531 gfc_resolve_chdir_sub (gfc_code *c)
536 if (c->ext.actual->next->expr != NULL)
537 kind = c->ext.actual->next->expr->ts.kind;
539 kind = gfc_default_integer_kind;
541 name = gfc_get_string (PREFIX ("chdir_i%d_sub"), kind);
542 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
547 gfc_resolve_chmod (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
548 gfc_expr *mode ATTRIBUTE_UNUSED)
550 f->ts.type = BT_INTEGER;
551 f->ts.kind = gfc_c_int_kind;
552 f->value.function.name = PREFIX ("chmod_func");
557 gfc_resolve_chmod_sub (gfc_code *c)
562 if (c->ext.actual->next->next->expr != NULL)
563 kind = c->ext.actual->next->next->expr->ts.kind;
565 kind = gfc_default_integer_kind;
567 name = gfc_get_string (PREFIX ("chmod_i%d_sub"), kind);
568 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
573 gfc_resolve_cmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y, gfc_expr *kind)
575 f->ts.type = BT_COMPLEX;
576 f->ts.kind = (kind == NULL)
577 ? gfc_default_real_kind : mpz_get_si (kind->value.integer);
580 f->value.function.name
581 = gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind,
582 gfc_type_letter (x->ts.type), x->ts.kind);
584 f->value.function.name
585 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
586 gfc_type_letter (x->ts.type), x->ts.kind,
587 gfc_type_letter (y->ts.type), y->ts.kind);
592 gfc_resolve_dcmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y)
594 gfc_resolve_cmplx (f, x, y, gfc_get_int_expr (gfc_default_integer_kind, NULL,
595 gfc_default_double_kind));
600 gfc_resolve_complex (gfc_expr *f, gfc_expr *x, gfc_expr *y)
604 if (x->ts.type == BT_INTEGER)
606 if (y->ts.type == BT_INTEGER)
607 kind = gfc_default_real_kind;
613 if (y->ts.type == BT_REAL)
614 kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
619 f->ts.type = BT_COMPLEX;
621 f->value.function.name
622 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
623 gfc_type_letter (x->ts.type), x->ts.kind,
624 gfc_type_letter (y->ts.type), y->ts.kind);
629 gfc_resolve_conjg (gfc_expr *f, gfc_expr *x)
632 f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind);
637 gfc_resolve_cos (gfc_expr *f, gfc_expr *x)
640 f->value.function.name
641 = gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
646 gfc_resolve_cosh (gfc_expr *f, gfc_expr *x)
649 f->value.function.name
650 = gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
655 gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
657 f->ts.type = BT_INTEGER;
659 f->ts.kind = mpz_get_si (kind->value.integer);
661 f->ts.kind = gfc_default_integer_kind;
665 f->rank = mask->rank - 1;
666 gfc_resolve_dim_arg (dim);
667 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
670 resolve_mask_arg (mask);
672 f->value.function.name
673 = gfc_get_string (PREFIX ("count_%d_%c"), f->ts.kind,
674 gfc_type_letter (mask->ts.type));
679 gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
684 if (array->ts.type == BT_CHARACTER && array->ref)
685 gfc_resolve_substring_charlen (array);
688 f->rank = array->rank;
689 f->shape = gfc_copy_shape (array->shape, array->rank);
696 /* If dim kind is greater than default integer we need to use the larger. */
697 m = gfc_default_integer_kind;
699 m = m < dim->ts.kind ? dim->ts.kind : m;
701 /* Convert shift to at least m, so we don't need
702 kind=1 and kind=2 versions of the library functions. */
703 if (shift->ts.kind < m)
707 ts.type = BT_INTEGER;
709 gfc_convert_type_warn (shift, &ts, 2, 0);
714 if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL
715 && dim->symtree->n.sym->attr.optional)
717 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
718 dim->representation.length = shift->ts.kind;
722 gfc_resolve_dim_arg (dim);
723 /* Convert dim to shift's kind to reduce variations. */
724 if (dim->ts.kind != shift->ts.kind)
725 gfc_convert_type_warn (dim, &shift->ts, 2, 0);
729 if (array->ts.type == BT_CHARACTER)
731 if (array->ts.kind == gfc_default_character_kind)
732 f->value.function.name
733 = gfc_get_string (PREFIX ("cshift%d_%d_char"), n, shift->ts.kind);
735 f->value.function.name
736 = gfc_get_string (PREFIX ("cshift%d_%d_char%d"), n, shift->ts.kind,
740 f->value.function.name
741 = gfc_get_string (PREFIX ("cshift%d_%d"), n, shift->ts.kind);
746 gfc_resolve_ctime (gfc_expr *f, gfc_expr *time)
751 f->ts.type = BT_CHARACTER;
752 f->ts.kind = gfc_default_character_kind;
754 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
755 if (time->ts.kind != 8)
757 ts.type = BT_INTEGER;
761 gfc_convert_type (time, &ts, 2);
764 f->value.function.name = gfc_get_string (PREFIX ("ctime"));
769 gfc_resolve_dble (gfc_expr *f, gfc_expr *a)
771 f->ts.type = BT_REAL;
772 f->ts.kind = gfc_default_double_kind;
773 f->value.function.name
774 = gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
779 gfc_resolve_dim (gfc_expr *f, gfc_expr *a, gfc_expr *p)
781 f->ts.type = a->ts.type;
783 f->ts.kind = gfc_kind_max (a,p);
785 f->ts.kind = a->ts.kind;
787 if (p != NULL && a->ts.kind != p->ts.kind)
789 if (a->ts.kind == gfc_kind_max (a,p))
790 gfc_convert_type (p, &a->ts, 2);
792 gfc_convert_type (a, &p->ts, 2);
795 f->value.function.name
796 = gfc_get_string ("__dim_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
801 gfc_resolve_dot_product (gfc_expr *f, gfc_expr *a, gfc_expr *b)
805 temp.expr_type = EXPR_OP;
806 gfc_clear_ts (&temp.ts);
807 temp.value.op.op = INTRINSIC_NONE;
808 temp.value.op.op1 = a;
809 temp.value.op.op2 = b;
810 gfc_type_convert_binary (&temp, 1);
812 f->value.function.name
813 = gfc_get_string (PREFIX ("dot_product_%c%d"),
814 gfc_type_letter (f->ts.type), f->ts.kind);
819 gfc_resolve_dprod (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
820 gfc_expr *b ATTRIBUTE_UNUSED)
822 f->ts.kind = gfc_default_double_kind;
823 f->ts.type = BT_REAL;
824 f->value.function.name = gfc_get_string ("__dprod_r%d", f->ts.kind);
829 gfc_resolve_dshift (gfc_expr *f, gfc_expr *i, gfc_expr *j ATTRIBUTE_UNUSED,
830 gfc_expr *shift ATTRIBUTE_UNUSED)
833 if (f->value.function.isym->id == GFC_ISYM_DSHIFTL)
834 f->value.function.name = gfc_get_string ("dshiftl_i%d", f->ts.kind);
835 else if (f->value.function.isym->id == GFC_ISYM_DSHIFTR)
836 f->value.function.name = gfc_get_string ("dshiftr_i%d", f->ts.kind);
843 gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
844 gfc_expr *boundary, gfc_expr *dim)
848 if (array->ts.type == BT_CHARACTER && array->ref)
849 gfc_resolve_substring_charlen (array);
852 f->rank = array->rank;
853 f->shape = gfc_copy_shape (array->shape, array->rank);
858 if (boundary && boundary->rank > 0)
861 /* If dim kind is greater than default integer we need to use the larger. */
862 m = gfc_default_integer_kind;
864 m = m < dim->ts.kind ? dim->ts.kind : m;
866 /* Convert shift to at least m, so we don't need
867 kind=1 and kind=2 versions of the library functions. */
868 if (shift->ts.kind < m)
872 ts.type = BT_INTEGER;
874 gfc_convert_type_warn (shift, &ts, 2, 0);
879 if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL
880 && dim->symtree->n.sym->attr.optional)
882 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
883 dim->representation.length = shift->ts.kind;
887 gfc_resolve_dim_arg (dim);
888 /* Convert dim to shift's kind to reduce variations. */
889 if (dim->ts.kind != shift->ts.kind)
890 gfc_convert_type_warn (dim, &shift->ts, 2, 0);
894 if (array->ts.type == BT_CHARACTER)
896 if (array->ts.kind == gfc_default_character_kind)
897 f->value.function.name
898 = gfc_get_string (PREFIX ("eoshift%d_%d_char"), n, shift->ts.kind);
900 f->value.function.name
901 = gfc_get_string (PREFIX ("eoshift%d_%d_char%d"), n, shift->ts.kind,
905 f->value.function.name
906 = gfc_get_string (PREFIX ("eoshift%d_%d"), n, shift->ts.kind);
911 gfc_resolve_exp (gfc_expr *f, gfc_expr *x)
914 f->value.function.name
915 = gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
920 gfc_resolve_exponent (gfc_expr *f, gfc_expr *x)
922 f->ts.type = BT_INTEGER;
923 f->ts.kind = gfc_default_integer_kind;
924 f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind);
928 /* Resolve the EXTENDS_TYPE_OF intrinsic function. */
931 gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
936 /* Prevent double resolution. */
937 if (f->ts.type == BT_LOGICAL)
940 /* Replace the first argument with the corresponding vtab. */
941 if (a->ts.type == BT_CLASS)
942 gfc_add_vptr_component (a);
943 else if (a->ts.type == BT_DERIVED)
945 vtab = gfc_find_derived_vtab (a->ts.u.derived);
946 /* Clear the old expr. */
947 gfc_free_ref_list (a->ref);
948 memset (a, '\0', sizeof (gfc_expr));
949 /* Construct a new one. */
950 a->expr_type = EXPR_VARIABLE;
951 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
956 /* Replace the second argument with the corresponding vtab. */
957 if (mo->ts.type == BT_CLASS)
958 gfc_add_vptr_component (mo);
959 else if (mo->ts.type == BT_DERIVED)
961 vtab = gfc_find_derived_vtab (mo->ts.u.derived);
962 /* Clear the old expr. */
963 gfc_free_ref_list (mo->ref);
964 memset (mo, '\0', sizeof (gfc_expr));
965 /* Construct a new one. */
966 mo->expr_type = EXPR_VARIABLE;
967 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
972 f->ts.type = BT_LOGICAL;
975 f->value.function.isym->formal->ts = a->ts;
976 f->value.function.isym->formal->next->ts = mo->ts;
978 /* Call library function. */
979 f->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
984 gfc_resolve_fdate (gfc_expr *f)
986 f->ts.type = BT_CHARACTER;
987 f->ts.kind = gfc_default_character_kind;
988 f->value.function.name = gfc_get_string (PREFIX ("fdate"));
993 gfc_resolve_floor (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
995 f->ts.type = BT_INTEGER;
996 f->ts.kind = (kind == NULL)
997 ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
998 f->value.function.name
999 = gfc_get_string ("__floor%d_%c%d", f->ts.kind,
1000 gfc_type_letter (a->ts.type), a->ts.kind);
1005 gfc_resolve_fnum (gfc_expr *f, gfc_expr *n)
1007 f->ts.type = BT_INTEGER;
1008 f->ts.kind = gfc_default_integer_kind;
1009 if (n->ts.kind != f->ts.kind)
1010 gfc_convert_type (n, &f->ts, 2);
1011 f->value.function.name = gfc_get_string (PREFIX ("fnum_i%d"), f->ts.kind);
1016 gfc_resolve_fraction (gfc_expr *f, gfc_expr *x)
1019 f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind);
1023 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
1026 gfc_resolve_g77_math1 (gfc_expr *f, gfc_expr *x)
1029 f->value.function.name = gfc_get_string ("<intrinsic>");
1034 gfc_resolve_gamma (gfc_expr *f, gfc_expr *x)
1037 f->value.function.name
1038 = gfc_get_string ("__tgamma_%d", x->ts.kind);
1043 gfc_resolve_getcwd (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
1045 f->ts.type = BT_INTEGER;
1047 f->value.function.name = gfc_get_string (PREFIX ("getcwd"));
1052 gfc_resolve_getgid (gfc_expr *f)
1054 f->ts.type = BT_INTEGER;
1056 f->value.function.name = gfc_get_string (PREFIX ("getgid"));
1061 gfc_resolve_getpid (gfc_expr *f)
1063 f->ts.type = BT_INTEGER;
1065 f->value.function.name = gfc_get_string (PREFIX ("getpid"));
1070 gfc_resolve_getuid (gfc_expr *f)
1072 f->ts.type = BT_INTEGER;
1074 f->value.function.name = gfc_get_string (PREFIX ("getuid"));
1079 gfc_resolve_hostnm (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
1081 f->ts.type = BT_INTEGER;
1083 f->value.function.name = gfc_get_string (PREFIX ("hostnm"));
1088 gfc_resolve_hypot (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
1091 f->value.function.name = gfc_get_string ("__hypot_r%d", x->ts.kind);
1096 gfc_resolve_iall (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
1098 resolve_transformational ("iall", f, array, dim, mask);
1103 gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1105 /* If the kind of i and j are different, then g77 cross-promoted the
1106 kinds to the largest value. The Fortran 95 standard requires the
1108 if (i->ts.kind != j->ts.kind)
1110 if (i->ts.kind == gfc_kind_max (i, j))
1111 gfc_convert_type (j, &i->ts, 2);
1113 gfc_convert_type (i, &j->ts, 2);
1117 f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind);
1122 gfc_resolve_iany (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
1124 resolve_transformational ("iany", f, array, dim, mask);
1129 gfc_resolve_ibclr (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
1132 f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind);
1137 gfc_resolve_ibits (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED,
1138 gfc_expr *len ATTRIBUTE_UNUSED)
1141 f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind);
1146 gfc_resolve_ibset (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
1149 f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind);
1154 gfc_resolve_iachar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
1156 f->ts.type = BT_INTEGER;
1158 f->ts.kind = mpz_get_si (kind->value.integer);
1160 f->ts.kind = gfc_default_integer_kind;
1161 f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
1166 gfc_resolve_ichar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
1168 f->ts.type = BT_INTEGER;
1170 f->ts.kind = mpz_get_si (kind->value.integer);
1172 f->ts.kind = gfc_default_integer_kind;
1173 f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
1178 gfc_resolve_idnint (gfc_expr *f, gfc_expr *a)
1180 gfc_resolve_nint (f, a, NULL);
1185 gfc_resolve_ierrno (gfc_expr *f)
1187 f->ts.type = BT_INTEGER;
1188 f->ts.kind = gfc_default_integer_kind;
1189 f->value.function.name = gfc_get_string (PREFIX ("ierrno_i%d"), f->ts.kind);
1194 gfc_resolve_ieor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1196 /* If the kind of i and j are different, then g77 cross-promoted the
1197 kinds to the largest value. The Fortran 95 standard requires the
1199 if (i->ts.kind != j->ts.kind)
1201 if (i->ts.kind == gfc_kind_max (i, j))
1202 gfc_convert_type (j, &i->ts, 2);
1204 gfc_convert_type (i, &j->ts, 2);
1208 f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind);
1213 gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1215 /* If the kind of i and j are different, then g77 cross-promoted the
1216 kinds to the largest value. The Fortran 95 standard requires the
1218 if (i->ts.kind != j->ts.kind)
1220 if (i->ts.kind == gfc_kind_max (i, j))
1221 gfc_convert_type (j, &i->ts, 2);
1223 gfc_convert_type (i, &j->ts, 2);
1227 f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind);
1232 gfc_resolve_index_func (gfc_expr *f, gfc_expr *str,
1233 gfc_expr *sub_str ATTRIBUTE_UNUSED, gfc_expr *back,
1239 f->ts.type = BT_INTEGER;
1241 f->ts.kind = mpz_get_si (kind->value.integer);
1243 f->ts.kind = gfc_default_integer_kind;
1245 if (back && back->ts.kind != gfc_default_integer_kind)
1247 ts.type = BT_LOGICAL;
1248 ts.kind = gfc_default_integer_kind;
1249 ts.u.derived = NULL;
1251 gfc_convert_type (back, &ts, 2);
1254 f->value.function.name
1255 = gfc_get_string ("__index_%d_i%d", str->ts.kind, f->ts.kind);
1260 gfc_resolve_int (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1262 f->ts.type = BT_INTEGER;
1263 f->ts.kind = (kind == NULL)
1264 ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
1265 f->value.function.name
1266 = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1267 gfc_type_letter (a->ts.type), a->ts.kind);
1272 gfc_resolve_int2 (gfc_expr *f, gfc_expr *a)
1274 f->ts.type = BT_INTEGER;
1276 f->value.function.name
1277 = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1278 gfc_type_letter (a->ts.type), a->ts.kind);
1283 gfc_resolve_int8 (gfc_expr *f, gfc_expr *a)
1285 f->ts.type = BT_INTEGER;
1287 f->value.function.name
1288 = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1289 gfc_type_letter (a->ts.type), a->ts.kind);
1294 gfc_resolve_long (gfc_expr *f, gfc_expr *a)
1296 f->ts.type = BT_INTEGER;
1298 f->value.function.name
1299 = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1300 gfc_type_letter (a->ts.type), a->ts.kind);
1305 gfc_resolve_iparity (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
1307 resolve_transformational ("iparity", f, array, dim, mask);
1312 gfc_resolve_isatty (gfc_expr *f, gfc_expr *u)
1317 f->ts.type = BT_LOGICAL;
1318 f->ts.kind = gfc_default_integer_kind;
1319 if (u->ts.kind != gfc_c_int_kind)
1321 ts.type = BT_INTEGER;
1322 ts.kind = gfc_c_int_kind;
1323 ts.u.derived = NULL;
1325 gfc_convert_type (u, &ts, 2);
1328 f->value.function.name = gfc_get_string (PREFIX ("isatty_l%d"), f->ts.kind);
1333 gfc_resolve_ishft (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1336 f->value.function.name
1337 = gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
1342 gfc_resolve_rshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1345 f->value.function.name
1346 = gfc_get_string ("__rshift_%d_%d", i->ts.kind, shift->ts.kind);
1351 gfc_resolve_lshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1354 f->value.function.name
1355 = gfc_get_string ("__lshift_%d_%d", i->ts.kind, shift->ts.kind);
1360 gfc_resolve_ishftc (gfc_expr *f, gfc_expr *i, gfc_expr *shift, gfc_expr *size)
1364 s_kind = (size == NULL) ? gfc_default_integer_kind : size->ts.kind;
1367 f->value.function.name
1368 = gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
1373 gfc_resolve_kill (gfc_expr *f, gfc_expr *p ATTRIBUTE_UNUSED,
1374 gfc_expr *s ATTRIBUTE_UNUSED)
1376 f->ts.type = BT_INTEGER;
1377 f->ts.kind = gfc_default_integer_kind;
1378 f->value.function.name = gfc_get_string (PREFIX ("kill_i%d"), f->ts.kind);
1383 gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
1385 resolve_bound (f, array, dim, kind, "__lbound", false);
1390 gfc_resolve_lcobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
1392 resolve_bound (f, array, dim, kind, "__lcobound", true);
1397 gfc_resolve_len (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
1399 f->ts.type = BT_INTEGER;
1401 f->ts.kind = mpz_get_si (kind->value.integer);
1403 f->ts.kind = gfc_default_integer_kind;
1404 f->value.function.name
1405 = gfc_get_string ("__len_%d_i%d", string->ts.kind,
1406 gfc_default_integer_kind);
1411 gfc_resolve_len_trim (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
1413 f->ts.type = BT_INTEGER;
1415 f->ts.kind = mpz_get_si (kind->value.integer);
1417 f->ts.kind = gfc_default_integer_kind;
1418 f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
1423 gfc_resolve_lgamma (gfc_expr *f, gfc_expr *x)
1426 f->value.function.name
1427 = gfc_get_string ("__lgamma_%d", x->ts.kind);
1432 gfc_resolve_link (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
1433 gfc_expr *p2 ATTRIBUTE_UNUSED)
1435 f->ts.type = BT_INTEGER;
1436 f->ts.kind = gfc_default_integer_kind;
1437 f->value.function.name = gfc_get_string (PREFIX ("link_i%d"), f->ts.kind);
1442 gfc_resolve_loc (gfc_expr *f, gfc_expr *x)
1444 f->ts.type= BT_INTEGER;
1445 f->ts.kind = gfc_index_integer_kind;
1446 f->value.function.name = gfc_get_string ("__loc_%d", x->ts.kind);
1451 gfc_resolve_log (gfc_expr *f, gfc_expr *x)
1454 f->value.function.name
1455 = gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1460 gfc_resolve_log10 (gfc_expr *f, gfc_expr *x)
1463 f->value.function.name
1464 = gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type),
1470 gfc_resolve_logical (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1472 f->ts.type = BT_LOGICAL;
1473 f->ts.kind = (kind == NULL)
1474 ? gfc_default_logical_kind : mpz_get_si (kind->value.integer);
1477 f->value.function.name
1478 = gfc_get_string ("__logical_%d_%c%d", f->ts.kind,
1479 gfc_type_letter (a->ts.type), a->ts.kind);
1484 gfc_resolve_malloc (gfc_expr *f, gfc_expr *size)
1486 if (size->ts.kind < gfc_index_integer_kind)
1491 ts.type = BT_INTEGER;
1492 ts.kind = gfc_index_integer_kind;
1493 gfc_convert_type_warn (size, &ts, 2, 0);
1496 f->ts.type = BT_INTEGER;
1497 f->ts.kind = gfc_index_integer_kind;
1498 f->value.function.name = gfc_get_string (PREFIX ("malloc"));
1503 gfc_resolve_matmul (gfc_expr *f, gfc_expr *a, gfc_expr *b)
1507 if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
1509 f->ts.type = BT_LOGICAL;
1510 f->ts.kind = gfc_default_logical_kind;
1514 temp.expr_type = EXPR_OP;
1515 gfc_clear_ts (&temp.ts);
1516 temp.value.op.op = INTRINSIC_NONE;
1517 temp.value.op.op1 = a;
1518 temp.value.op.op2 = b;
1519 gfc_type_convert_binary (&temp, 1);
1523 f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
1525 if (a->rank == 2 && b->rank == 2)
1527 if (a->shape && b->shape)
1529 f->shape = gfc_get_shape (f->rank);
1530 mpz_init_set (f->shape[0], a->shape[0]);
1531 mpz_init_set (f->shape[1], b->shape[1]);
1534 else if (a->rank == 1)
1538 f->shape = gfc_get_shape (f->rank);
1539 mpz_init_set (f->shape[0], b->shape[1]);
1544 /* b->rank == 1 and a->rank == 2 here, all other cases have
1545 been caught in check.c. */
1548 f->shape = gfc_get_shape (f->rank);
1549 mpz_init_set (f->shape[0], a->shape[0]);
1553 f->value.function.name
1554 = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f->ts.type),
1560 gfc_resolve_minmax (const char *name, gfc_expr *f, gfc_actual_arglist *args)
1562 gfc_actual_arglist *a;
1564 f->ts.type = args->expr->ts.type;
1565 f->ts.kind = args->expr->ts.kind;
1566 /* Find the largest type kind. */
1567 for (a = args->next; a; a = a->next)
1569 if (a->expr->ts.kind > f->ts.kind)
1570 f->ts.kind = a->expr->ts.kind;
1573 /* Convert all parameters to the required kind. */
1574 for (a = args; a; a = a->next)
1576 if (a->expr->ts.kind != f->ts.kind)
1577 gfc_convert_type (a->expr, &f->ts, 2);
1580 f->value.function.name
1581 = gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind);
1586 gfc_resolve_max (gfc_expr *f, gfc_actual_arglist *args)
1588 gfc_resolve_minmax ("__max_%c%d", f, args);
1593 gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1599 f->ts.type = BT_INTEGER;
1600 f->ts.kind = gfc_default_integer_kind;
1605 f->shape = gfc_get_shape (1);
1606 mpz_init_set_si (f->shape[0], array->rank);
1610 f->rank = array->rank - 1;
1611 gfc_resolve_dim_arg (dim);
1612 if (array->shape && dim->expr_type == EXPR_CONSTANT)
1614 idim = (int) mpz_get_si (dim->value.integer);
1615 f->shape = gfc_get_shape (f->rank);
1616 for (i = 0, j = 0; i < f->rank; i++, j++)
1618 if (i == (idim - 1))
1620 mpz_init_set (f->shape[i], array->shape[j]);
1627 if (mask->rank == 0)
1632 resolve_mask_arg (mask);
1637 f->value.function.name
1638 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1639 gfc_type_letter (array->ts.type), array->ts.kind);
1644 gfc_resolve_maxval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1654 f->rank = array->rank - 1;
1655 gfc_resolve_dim_arg (dim);
1657 if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
1659 idim = (int) mpz_get_si (dim->value.integer);
1660 f->shape = gfc_get_shape (f->rank);
1661 for (i = 0, j = 0; i < f->rank; i++, j++)
1663 if (i == (idim - 1))
1665 mpz_init_set (f->shape[i], array->shape[j]);
1672 if (mask->rank == 0)
1677 resolve_mask_arg (mask);
1682 f->value.function.name
1683 = gfc_get_string (PREFIX ("%s_%c%d"), name,
1684 gfc_type_letter (array->ts.type), array->ts.kind);
1689 gfc_resolve_mclock (gfc_expr *f)
1691 f->ts.type = BT_INTEGER;
1693 f->value.function.name = PREFIX ("mclock");
1698 gfc_resolve_mclock8 (gfc_expr *f)
1700 f->ts.type = BT_INTEGER;
1702 f->value.function.name = PREFIX ("mclock8");
1707 gfc_resolve_mask (gfc_expr *f, gfc_expr *i ATTRIBUTE_UNUSED,
1710 f->ts.type = BT_INTEGER;
1711 f->ts.kind = kind ? mpz_get_si (kind->value.integer)
1712 : gfc_default_integer_kind;
1714 if (f->value.function.isym->id == GFC_ISYM_MASKL)
1715 f->value.function.name = gfc_get_string ("__maskl_i%d", f->ts.kind);
1717 f->value.function.name = gfc_get_string ("__maskr_i%d", f->ts.kind);
1722 gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource,
1723 gfc_expr *fsource ATTRIBUTE_UNUSED,
1724 gfc_expr *mask ATTRIBUTE_UNUSED)
1726 if (tsource->ts.type == BT_CHARACTER && tsource->ref)
1727 gfc_resolve_substring_charlen (tsource);
1729 if (fsource->ts.type == BT_CHARACTER && fsource->ref)
1730 gfc_resolve_substring_charlen (fsource);
1732 if (tsource->ts.type == BT_CHARACTER)
1733 check_charlen_present (tsource);
1735 f->ts = tsource->ts;
1736 f->value.function.name
1737 = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
1743 gfc_resolve_merge_bits (gfc_expr *f, gfc_expr *i,
1744 gfc_expr *j ATTRIBUTE_UNUSED,
1745 gfc_expr *mask ATTRIBUTE_UNUSED)
1748 f->value.function.name = gfc_get_string ("__merge_bits_i%d", i->ts.kind);
1753 gfc_resolve_min (gfc_expr *f, gfc_actual_arglist *args)
1755 gfc_resolve_minmax ("__min_%c%d", f, args);
1760 gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1766 f->ts.type = BT_INTEGER;
1767 f->ts.kind = gfc_default_integer_kind;
1772 f->shape = gfc_get_shape (1);
1773 mpz_init_set_si (f->shape[0], array->rank);
1777 f->rank = array->rank - 1;
1778 gfc_resolve_dim_arg (dim);
1779 if (array->shape && dim->expr_type == EXPR_CONSTANT)
1781 idim = (int) mpz_get_si (dim->value.integer);
1782 f->shape = gfc_get_shape (f->rank);
1783 for (i = 0, j = 0; i < f->rank; i++, j++)
1785 if (i == (idim - 1))
1787 mpz_init_set (f->shape[i], array->shape[j]);
1794 if (mask->rank == 0)
1799 resolve_mask_arg (mask);
1804 f->value.function.name
1805 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1806 gfc_type_letter (array->ts.type), array->ts.kind);
1811 gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1821 f->rank = array->rank - 1;
1822 gfc_resolve_dim_arg (dim);
1824 if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
1826 idim = (int) mpz_get_si (dim->value.integer);
1827 f->shape = gfc_get_shape (f->rank);
1828 for (i = 0, j = 0; i < f->rank; i++, j++)
1830 if (i == (idim - 1))
1832 mpz_init_set (f->shape[i], array->shape[j]);
1839 if (mask->rank == 0)
1844 resolve_mask_arg (mask);
1849 f->value.function.name
1850 = gfc_get_string (PREFIX ("%s_%c%d"), name,
1851 gfc_type_letter (array->ts.type), array->ts.kind);
1856 gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p)
1858 f->ts.type = a->ts.type;
1860 f->ts.kind = gfc_kind_max (a,p);
1862 f->ts.kind = a->ts.kind;
1864 if (p != NULL && a->ts.kind != p->ts.kind)
1866 if (a->ts.kind == gfc_kind_max (a,p))
1867 gfc_convert_type (p, &a->ts, 2);
1869 gfc_convert_type (a, &p->ts, 2);
1872 f->value.function.name
1873 = gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
1878 gfc_resolve_modulo (gfc_expr *f, gfc_expr *a, gfc_expr *p)
1880 f->ts.type = a->ts.type;
1882 f->ts.kind = gfc_kind_max (a,p);
1884 f->ts.kind = a->ts.kind;
1886 if (p != NULL && a->ts.kind != p->ts.kind)
1888 if (a->ts.kind == gfc_kind_max (a,p))
1889 gfc_convert_type (p, &a->ts, 2);
1891 gfc_convert_type (a, &p->ts, 2);
1894 f->value.function.name
1895 = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type),
1900 gfc_resolve_nearest (gfc_expr *f, gfc_expr *a, gfc_expr *p)
1902 if (p->ts.kind != a->ts.kind)
1903 gfc_convert_type (p, &a->ts, 2);
1906 f->value.function.name
1907 = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
1912 gfc_resolve_nint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1914 f->ts.type = BT_INTEGER;
1915 f->ts.kind = (kind == NULL)
1916 ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
1917 f->value.function.name
1918 = gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
1923 gfc_resolve_norm2 (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
1925 resolve_transformational ("norm2", f, array, dim, NULL);
1930 gfc_resolve_not (gfc_expr *f, gfc_expr *i)
1933 f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
1938 gfc_resolve_or (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1940 f->ts.type = i->ts.type;
1941 f->ts.kind = gfc_kind_max (i, j);
1943 if (i->ts.kind != j->ts.kind)
1945 if (i->ts.kind == gfc_kind_max (i, j))
1946 gfc_convert_type (j, &i->ts, 2);
1948 gfc_convert_type (i, &j->ts, 2);
1951 f->value.function.name
1952 = gfc_get_string ("__or_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
1957 gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
1958 gfc_expr *vector ATTRIBUTE_UNUSED)
1960 if (array->ts.type == BT_CHARACTER && array->ref)
1961 gfc_resolve_substring_charlen (array);
1966 resolve_mask_arg (mask);
1968 if (mask->rank != 0)
1970 if (array->ts.type == BT_CHARACTER)
1971 f->value.function.name
1972 = array->ts.kind == 1 ? PREFIX ("pack_char")
1974 (PREFIX ("pack_char%d"),
1977 f->value.function.name = PREFIX ("pack");
1981 if (array->ts.type == BT_CHARACTER)
1982 f->value.function.name
1983 = array->ts.kind == 1 ? PREFIX ("pack_s_char")
1985 (PREFIX ("pack_s_char%d"),
1988 f->value.function.name = PREFIX ("pack_s");
1994 gfc_resolve_parity (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
1996 resolve_transformational ("parity", f, array, dim, NULL);
2001 gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
2004 resolve_transformational ("product", f, array, dim, mask);
2009 gfc_resolve_real (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
2011 f->ts.type = BT_REAL;
2014 f->ts.kind = mpz_get_si (kind->value.integer);
2016 f->ts.kind = (a->ts.type == BT_COMPLEX)
2017 ? a->ts.kind : gfc_default_real_kind;
2019 f->value.function.name
2020 = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
2021 gfc_type_letter (a->ts.type), a->ts.kind);
2026 gfc_resolve_realpart (gfc_expr *f, gfc_expr *a)
2028 f->ts.type = BT_REAL;
2029 f->ts.kind = a->ts.kind;
2030 f->value.function.name
2031 = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
2032 gfc_type_letter (a->ts.type), a->ts.kind);
2037 gfc_resolve_rename (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
2038 gfc_expr *p2 ATTRIBUTE_UNUSED)
2040 f->ts.type = BT_INTEGER;
2041 f->ts.kind = gfc_default_integer_kind;
2042 f->value.function.name = gfc_get_string (PREFIX ("rename_i%d"), f->ts.kind);
2047 gfc_resolve_repeat (gfc_expr *f, gfc_expr *string,
2052 f->ts.type = BT_CHARACTER;
2053 f->ts.kind = string->ts.kind;
2054 f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
2056 /* If possible, generate a character length. */
2057 if (f->ts.u.cl == NULL)
2058 f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2061 if (string->expr_type == EXPR_CONSTANT)
2063 len = string->value.character.length;
2064 tmp = gfc_get_int_expr (gfc_default_integer_kind, NULL , len);
2066 else if (string->ts.u.cl && string->ts.u.cl->length)
2068 tmp = gfc_copy_expr (string->ts.u.cl->length);
2072 f->ts.u.cl->length = gfc_multiply (tmp, gfc_copy_expr (ncopies));
2077 gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
2078 gfc_expr *pad ATTRIBUTE_UNUSED,
2079 gfc_expr *order ATTRIBUTE_UNUSED)
2085 if (source->ts.type == BT_CHARACTER && source->ref)
2086 gfc_resolve_substring_charlen (source);
2090 gfc_array_size (shape, &rank);
2091 f->rank = mpz_get_si (rank);
2093 switch (source->ts.type)
2100 kind = source->ts.kind;
2114 if (source->ts.type == BT_COMPLEX || source->ts.type == BT_REAL)
2115 f->value.function.name
2116 = gfc_get_string (PREFIX ("reshape_%c%d"),
2117 gfc_type_letter (source->ts.type),
2119 else if (source->ts.type == BT_CHARACTER)
2120 f->value.function.name = gfc_get_string (PREFIX ("reshape_char%d"),
2123 f->value.function.name
2124 = gfc_get_string (PREFIX ("reshape_%d"), source->ts.kind);
2128 f->value.function.name = (source->ts.type == BT_CHARACTER
2129 ? PREFIX ("reshape_char") : PREFIX ("reshape"));
2133 /* TODO: Make this work with a constant ORDER parameter. */
2134 if (shape->expr_type == EXPR_ARRAY
2135 && gfc_is_constant_expr (shape)
2139 f->shape = gfc_get_shape (f->rank);
2140 c = gfc_constructor_first (shape->value.constructor);
2141 for (i = 0; i < f->rank; i++)
2143 mpz_init_set (f->shape[i], c->expr->value.integer);
2144 c = gfc_constructor_next (c);
2148 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
2149 so many runtime variations. */
2150 if (shape->ts.kind != gfc_index_integer_kind)
2152 gfc_typespec ts = shape->ts;
2153 ts.kind = gfc_index_integer_kind;
2154 gfc_convert_type_warn (shape, &ts, 2, 0);
2156 if (order && order->ts.kind != gfc_index_integer_kind)
2157 gfc_convert_type_warn (order, &shape->ts, 2, 0);
2162 gfc_resolve_rrspacing (gfc_expr *f, gfc_expr *x)
2165 f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
2170 gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i ATTRIBUTE_UNUSED)
2173 f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
2178 gfc_resolve_scan (gfc_expr *f, gfc_expr *string,
2179 gfc_expr *set ATTRIBUTE_UNUSED,
2180 gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
2182 f->ts.type = BT_INTEGER;
2184 f->ts.kind = mpz_get_si (kind->value.integer);
2186 f->ts.kind = gfc_default_integer_kind;
2187 f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
2192 gfc_resolve_secnds (gfc_expr *t1, gfc_expr *t0)
2195 t1->value.function.name = gfc_get_string (PREFIX ("secnds"));
2200 gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x,
2201 gfc_expr *i ATTRIBUTE_UNUSED)
2204 f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
2209 gfc_resolve_shape (gfc_expr *f, gfc_expr *array, gfc_expr *kind)
2211 f->ts.type = BT_INTEGER;
2214 f->ts.kind = mpz_get_si (kind->value.integer);
2216 f->ts.kind = gfc_default_integer_kind;
2219 f->shape = gfc_get_shape (1);
2220 mpz_init_set_ui (f->shape[0], array->rank);
2221 f->value.function.name = gfc_get_string (PREFIX ("shape_%d"), f->ts.kind);
2226 gfc_resolve_shift (gfc_expr *f, gfc_expr *i, gfc_expr *shift ATTRIBUTE_UNUSED)
2229 if (f->value.function.isym->id == GFC_ISYM_SHIFTA)
2230 f->value.function.name = gfc_get_string ("shifta_i%d", f->ts.kind);
2231 else if (f->value.function.isym->id == GFC_ISYM_SHIFTL)
2232 f->value.function.name = gfc_get_string ("shiftl_i%d", f->ts.kind);
2233 else if (f->value.function.isym->id == GFC_ISYM_SHIFTR)
2234 f->value.function.name = gfc_get_string ("shiftr_i%d", f->ts.kind);
2241 gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b ATTRIBUTE_UNUSED)
2244 f->value.function.name
2245 = gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
2250 gfc_resolve_signal (gfc_expr *f, gfc_expr *number, gfc_expr *handler)
2252 f->ts.type = BT_INTEGER;
2253 f->ts.kind = gfc_c_int_kind;
2255 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2256 if (handler->ts.type == BT_INTEGER)
2258 if (handler->ts.kind != gfc_c_int_kind)
2259 gfc_convert_type (handler, &f->ts, 2);
2260 f->value.function.name = gfc_get_string (PREFIX ("signal_func_int"));
2263 f->value.function.name = gfc_get_string (PREFIX ("signal_func"));
2265 if (number->ts.kind != gfc_c_int_kind)
2266 gfc_convert_type (number, &f->ts, 2);
2271 gfc_resolve_sin (gfc_expr *f, gfc_expr *x)
2274 f->value.function.name
2275 = gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2280 gfc_resolve_sinh (gfc_expr *f, gfc_expr *x)
2283 f->value.function.name
2284 = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2289 gfc_resolve_size (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2290 gfc_expr *dim ATTRIBUTE_UNUSED, gfc_expr *kind)
2292 f->ts.type = BT_INTEGER;
2294 f->ts.kind = mpz_get_si (kind->value.integer);
2296 f->ts.kind = gfc_default_integer_kind;
2301 gfc_resolve_spacing (gfc_expr *f, gfc_expr *x)
2304 f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
2309 gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim,
2312 if (source->ts.type == BT_CHARACTER && source->ref)
2313 gfc_resolve_substring_charlen (source);
2315 if (source->ts.type == BT_CHARACTER)
2316 check_charlen_present (source);
2319 f->rank = source->rank + 1;
2320 if (source->rank == 0)
2322 if (source->ts.type == BT_CHARACTER)
2323 f->value.function.name
2324 = source->ts.kind == 1 ? PREFIX ("spread_char_scalar")
2326 (PREFIX ("spread_char%d_scalar"),
2329 f->value.function.name = PREFIX ("spread_scalar");
2333 if (source->ts.type == BT_CHARACTER)
2334 f->value.function.name
2335 = source->ts.kind == 1 ? PREFIX ("spread_char")
2337 (PREFIX ("spread_char%d"),
2340 f->value.function.name = PREFIX ("spread");
2343 if (dim && gfc_is_constant_expr (dim)
2344 && ncopies && gfc_is_constant_expr (ncopies) && source->shape[0])
2347 idim = mpz_get_ui (dim->value.integer);
2348 f->shape = gfc_get_shape (f->rank);
2349 for (i = 0; i < (idim - 1); i++)
2350 mpz_init_set (f->shape[i], source->shape[i]);
2352 mpz_init_set (f->shape[idim - 1], ncopies->value.integer);
2354 for (i = idim; i < f->rank ; i++)
2355 mpz_init_set (f->shape[i], source->shape[i-1]);
2359 gfc_resolve_dim_arg (dim);
2360 gfc_resolve_index (ncopies, 1);
2365 gfc_resolve_sqrt (gfc_expr *f, gfc_expr *x)
2368 f->value.function.name
2369 = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2373 /* Resolve the g77 compatibility function STAT AND FSTAT. */
2376 gfc_resolve_stat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2377 gfc_expr *a ATTRIBUTE_UNUSED)
2379 f->ts.type = BT_INTEGER;
2380 f->ts.kind = gfc_default_integer_kind;
2381 f->value.function.name = gfc_get_string (PREFIX ("stat_i%d"), f->ts.kind);
2386 gfc_resolve_lstat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2387 gfc_expr *a ATTRIBUTE_UNUSED)
2389 f->ts.type = BT_INTEGER;
2390 f->ts.kind = gfc_default_integer_kind;
2391 f->value.function.name = gfc_get_string (PREFIX ("lstat_i%d"), f->ts.kind);
2396 gfc_resolve_fstat (gfc_expr *f, gfc_expr *n, gfc_expr *a ATTRIBUTE_UNUSED)
2398 f->ts.type = BT_INTEGER;
2399 f->ts.kind = gfc_default_integer_kind;
2400 if (n->ts.kind != f->ts.kind)
2401 gfc_convert_type (n, &f->ts, 2);
2403 f->value.function.name = gfc_get_string (PREFIX ("fstat_i%d"), f->ts.kind);
2408 gfc_resolve_fgetc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2413 f->ts.type = BT_INTEGER;
2414 f->ts.kind = gfc_c_int_kind;
2415 if (u->ts.kind != gfc_c_int_kind)
2417 ts.type = BT_INTEGER;
2418 ts.kind = gfc_c_int_kind;
2419 ts.u.derived = NULL;
2421 gfc_convert_type (u, &ts, 2);
2424 f->value.function.name = gfc_get_string (PREFIX ("fgetc"));
2429 gfc_resolve_fget (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2431 f->ts.type = BT_INTEGER;
2432 f->ts.kind = gfc_c_int_kind;
2433 f->value.function.name = gfc_get_string (PREFIX ("fget"));
2438 gfc_resolve_fputc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2443 f->ts.type = BT_INTEGER;
2444 f->ts.kind = gfc_c_int_kind;
2445 if (u->ts.kind != gfc_c_int_kind)
2447 ts.type = BT_INTEGER;
2448 ts.kind = gfc_c_int_kind;
2449 ts.u.derived = NULL;
2451 gfc_convert_type (u, &ts, 2);
2454 f->value.function.name = gfc_get_string (PREFIX ("fputc"));
2459 gfc_resolve_fput (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2461 f->ts.type = BT_INTEGER;
2462 f->ts.kind = gfc_c_int_kind;
2463 f->value.function.name = gfc_get_string (PREFIX ("fput"));
2468 gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
2473 f->ts.type = BT_INTEGER;
2474 f->ts.kind = gfc_index_integer_kind;
2475 if (u->ts.kind != gfc_c_int_kind)
2477 ts.type = BT_INTEGER;
2478 ts.kind = gfc_c_int_kind;
2479 ts.u.derived = NULL;
2481 gfc_convert_type (u, &ts, 2);
2484 f->value.function.name = gfc_get_string (PREFIX ("ftell"));
2489 gfc_resolve_storage_size (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
2492 f->ts.type = BT_INTEGER;
2494 f->ts.kind = mpz_get_si (kind->value.integer);
2496 f->ts.kind = gfc_default_integer_kind;
2501 gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
2503 resolve_transformational ("sum", f, array, dim, mask);
2508 gfc_resolve_symlnk (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
2509 gfc_expr *p2 ATTRIBUTE_UNUSED)
2511 f->ts.type = BT_INTEGER;
2512 f->ts.kind = gfc_default_integer_kind;
2513 f->value.function.name = gfc_get_string (PREFIX ("symlnk_i%d"), f->ts.kind);
2517 /* Resolve the g77 compatibility function SYSTEM. */
2520 gfc_resolve_system (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
2522 f->ts.type = BT_INTEGER;
2524 f->value.function.name = gfc_get_string (PREFIX ("system"));
2529 gfc_resolve_tan (gfc_expr *f, gfc_expr *x)
2532 f->value.function.name
2533 = gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2538 gfc_resolve_tanh (gfc_expr *f, gfc_expr *x)
2541 f->value.function.name
2542 = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2547 gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2548 gfc_expr *sub ATTRIBUTE_UNUSED)
2550 static char image_index[] = "__image_index";
2551 f->ts.type = BT_INTEGER;
2552 f->ts.kind = gfc_default_integer_kind;
2553 f->value.function.name = image_index;
2558 gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
2560 static char this_image[] = "__this_image";
2562 resolve_bound (f, array, dim, NULL, "__this_image", true);
2565 f->ts.type = BT_INTEGER;
2566 f->ts.kind = gfc_default_integer_kind;
2567 f->value.function.name = this_image;
2573 gfc_resolve_time (gfc_expr *f)
2575 f->ts.type = BT_INTEGER;
2577 f->value.function.name = gfc_get_string (PREFIX ("time_func"));
2582 gfc_resolve_time8 (gfc_expr *f)
2584 f->ts.type = BT_INTEGER;
2586 f->value.function.name = gfc_get_string (PREFIX ("time8_func"));
2591 gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
2592 gfc_expr *mold, gfc_expr *size)
2594 /* TODO: Make this do something meaningful. */
2595 static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
2597 if (mold->ts.type == BT_CHARACTER
2598 && !mold->ts.u.cl->length
2599 && gfc_is_constant_expr (mold))
2602 if (mold->expr_type == EXPR_CONSTANT)
2604 len = mold->value.character.length;
2605 mold->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
2610 gfc_constructor *c = gfc_constructor_first (mold->value.constructor);
2611 len = c->expr->value.character.length;
2612 mold->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
2619 if (size == NULL && mold->rank == 0)
2622 f->value.function.name = transfer0;
2627 f->value.function.name = transfer1;
2628 if (size && gfc_is_constant_expr (size))
2630 f->shape = gfc_get_shape (1);
2631 mpz_init_set (f->shape[0], size->value.integer);
2638 gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
2641 if (matrix->ts.type == BT_CHARACTER && matrix->ref)
2642 gfc_resolve_substring_charlen (matrix);
2648 f->shape = gfc_get_shape (2);
2649 mpz_init_set (f->shape[0], matrix->shape[1]);
2650 mpz_init_set (f->shape[1], matrix->shape[0]);
2653 switch (matrix->ts.kind)
2659 switch (matrix->ts.type)
2663 f->value.function.name
2664 = gfc_get_string (PREFIX ("transpose_%c%d"),
2665 gfc_type_letter (matrix->ts.type),
2671 /* Use the integer routines for real and logical cases. This
2672 assumes they all have the same alignment requirements. */
2673 f->value.function.name
2674 = gfc_get_string (PREFIX ("transpose_i%d"), matrix->ts.kind);
2678 if (matrix->ts.type == BT_CHARACTER && matrix->ts.kind == 4)
2679 f->value.function.name = PREFIX ("transpose_char4");
2681 f->value.function.name = PREFIX ("transpose");
2687 f->value.function.name = (matrix->ts.type == BT_CHARACTER
2688 ? PREFIX ("transpose_char")
2689 : PREFIX ("transpose"));
2696 gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
2698 f->ts.type = BT_CHARACTER;
2699 f->ts.kind = string->ts.kind;
2700 f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
2705 gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2707 resolve_bound (f, array, dim, kind, "__ubound", false);
2712 gfc_resolve_ucobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2714 resolve_bound (f, array, dim, kind, "__ucobound", true);
2718 /* Resolve the g77 compatibility function UMASK. */
2721 gfc_resolve_umask (gfc_expr *f, gfc_expr *n)
2723 f->ts.type = BT_INTEGER;
2724 f->ts.kind = n->ts.kind;
2725 f->value.function.name = gfc_get_string (PREFIX ("umask_i%d"), n->ts.kind);
2729 /* Resolve the g77 compatibility function UNLINK. */
2732 gfc_resolve_unlink (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
2734 f->ts.type = BT_INTEGER;
2736 f->value.function.name = gfc_get_string (PREFIX ("unlink"));
2741 gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit)
2746 f->ts.type = BT_CHARACTER;
2747 f->ts.kind = gfc_default_character_kind;
2749 if (unit->ts.kind != gfc_c_int_kind)
2751 ts.type = BT_INTEGER;
2752 ts.kind = gfc_c_int_kind;
2753 ts.u.derived = NULL;
2755 gfc_convert_type (unit, &ts, 2);
2758 f->value.function.name = gfc_get_string (PREFIX ("ttynam"));
2763 gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
2764 gfc_expr *field ATTRIBUTE_UNUSED)
2766 if (vector->ts.type == BT_CHARACTER && vector->ref)
2767 gfc_resolve_substring_charlen (vector);
2770 f->rank = mask->rank;
2771 resolve_mask_arg (mask);
2773 if (vector->ts.type == BT_CHARACTER)
2775 if (vector->ts.kind == 1)
2776 f->value.function.name
2777 = gfc_get_string (PREFIX ("unpack%d_char"), field->rank > 0 ? 1 : 0);
2779 f->value.function.name
2780 = gfc_get_string (PREFIX ("unpack%d_char%d"),
2781 field->rank > 0 ? 1 : 0, vector->ts.kind);
2784 f->value.function.name
2785 = gfc_get_string (PREFIX ("unpack%d"), field->rank > 0 ? 1 : 0);
2790 gfc_resolve_verify (gfc_expr *f, gfc_expr *string,
2791 gfc_expr *set ATTRIBUTE_UNUSED,
2792 gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
2794 f->ts.type = BT_INTEGER;
2796 f->ts.kind = mpz_get_si (kind->value.integer);
2798 f->ts.kind = gfc_default_integer_kind;
2799 f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
2804 gfc_resolve_xor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
2806 f->ts.type = i->ts.type;
2807 f->ts.kind = gfc_kind_max (i, j);
2809 if (i->ts.kind != j->ts.kind)
2811 if (i->ts.kind == gfc_kind_max (i, j))
2812 gfc_convert_type (j, &i->ts, 2);
2814 gfc_convert_type (i, &j->ts, 2);
2817 f->value.function.name
2818 = gfc_get_string ("__xor_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
2822 /* Intrinsic subroutine resolution. */
2825 gfc_resolve_alarm_sub (gfc_code *c)
2828 gfc_expr *seconds, *handler;
2832 seconds = c->ext.actual->expr;
2833 handler = c->ext.actual->next->expr;
2834 ts.type = BT_INTEGER;
2835 ts.kind = gfc_c_int_kind;
2837 /* handler can be either BT_INTEGER or BT_PROCEDURE.
2838 In all cases, the status argument is of default integer kind
2839 (enforced in check.c) so that the function suffix is fixed. */
2840 if (handler->ts.type == BT_INTEGER)
2842 if (handler->ts.kind != gfc_c_int_kind)
2843 gfc_convert_type (handler, &ts, 2);
2844 name = gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
2845 gfc_default_integer_kind);
2848 name = gfc_get_string (PREFIX ("alarm_sub_i%d"),
2849 gfc_default_integer_kind);
2851 if (seconds->ts.kind != gfc_c_int_kind)
2852 gfc_convert_type (seconds, &ts, 2);
2854 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2858 gfc_resolve_cpu_time (gfc_code *c)
2861 name = gfc_get_string (PREFIX ("cpu_time_%d"), c->ext.actual->expr->ts.kind);
2862 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2866 /* Create a formal arglist based on an actual one and set the INTENTs given. */
2868 static gfc_formal_arglist*
2869 create_formal_for_intents (gfc_actual_arglist* actual, const sym_intent* ints)
2871 gfc_formal_arglist* head;
2872 gfc_formal_arglist* tail;
2878 head = tail = gfc_get_formal_arglist ();
2879 for (i = 0; actual; actual = actual->next, tail = tail->next, ++i)
2883 sym = gfc_new_symbol ("dummyarg", NULL);
2884 sym->ts = actual->expr->ts;
2886 sym->attr.intent = ints[i];
2890 tail->next = gfc_get_formal_arglist ();
2898 gfc_resolve_atomic_def (gfc_code *c)
2900 const char *name = "atomic_define";
2901 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2906 gfc_resolve_atomic_ref (gfc_code *c)
2908 const char *name = "atomic_ref";
2909 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2914 gfc_resolve_mvbits (gfc_code *c)
2916 static const sym_intent INTENTS[] = {INTENT_IN, INTENT_IN, INTENT_IN,
2917 INTENT_INOUT, INTENT_IN};
2923 /* FROMPOS, LEN and TOPOS are restricted to small values. As such,
2924 they will be converted so that they fit into a C int. */
2925 ts.type = BT_INTEGER;
2926 ts.kind = gfc_c_int_kind;
2927 if (c->ext.actual->next->expr->ts.kind != gfc_c_int_kind)
2928 gfc_convert_type (c->ext.actual->next->expr, &ts, 2);
2929 if (c->ext.actual->next->next->expr->ts.kind != gfc_c_int_kind)
2930 gfc_convert_type (c->ext.actual->next->next->expr, &ts, 2);
2931 if (c->ext.actual->next->next->next->next->expr->ts.kind != gfc_c_int_kind)
2932 gfc_convert_type (c->ext.actual->next->next->next->next->expr, &ts, 2);
2934 /* TO and FROM are guaranteed to have the same kind parameter. */
2935 name = gfc_get_string (PREFIX ("mvbits_i%d"),
2936 c->ext.actual->expr->ts.kind);
2937 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2938 /* Mark as elemental subroutine as this does not happen automatically. */
2939 c->resolved_sym->attr.elemental = 1;
2941 /* Create a dummy formal arglist so the INTENTs are known later for purpose
2942 of creating temporaries. */
2943 c->resolved_sym->formal = create_formal_for_intents (c->ext.actual, INTENTS);
2948 gfc_resolve_random_number (gfc_code *c)
2953 kind = c->ext.actual->expr->ts.kind;
2954 if (c->ext.actual->expr->rank == 0)
2955 name = gfc_get_string (PREFIX ("random_r%d"), kind);
2957 name = gfc_get_string (PREFIX ("arandom_r%d"), kind);
2959 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2964 gfc_resolve_random_seed (gfc_code *c)
2968 name = gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind);
2969 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2974 gfc_resolve_rename_sub (gfc_code *c)
2979 if (c->ext.actual->next->next->expr != NULL)
2980 kind = c->ext.actual->next->next->expr->ts.kind;
2982 kind = gfc_default_integer_kind;
2984 name = gfc_get_string (PREFIX ("rename_i%d_sub"), kind);
2985 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2990 gfc_resolve_kill_sub (gfc_code *c)
2995 if (c->ext.actual->next->next->expr != NULL)
2996 kind = c->ext.actual->next->next->expr->ts.kind;
2998 kind = gfc_default_integer_kind;
3000 name = gfc_get_string (PREFIX ("kill_i%d_sub"), kind);
3001 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3006 gfc_resolve_link_sub (gfc_code *c)
3011 if (c->ext.actual->next->next->expr != NULL)
3012 kind = c->ext.actual->next->next->expr->ts.kind;
3014 kind = gfc_default_integer_kind;
3016 name = gfc_get_string (PREFIX ("link_i%d_sub"), kind);
3017 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3022 gfc_resolve_symlnk_sub (gfc_code *c)
3027 if (c->ext.actual->next->next->expr != NULL)
3028 kind = c->ext.actual->next->next->expr->ts.kind;
3030 kind = gfc_default_integer_kind;
3032 name = gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind);
3033 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3037 /* G77 compatibility subroutines dtime() and etime(). */
3040 gfc_resolve_dtime_sub (gfc_code *c)
3043 name = gfc_get_string (PREFIX ("dtime_sub"));
3044 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3048 gfc_resolve_etime_sub (gfc_code *c)
3051 name = gfc_get_string (PREFIX ("etime_sub"));
3052 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3056 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
3059 gfc_resolve_itime (gfc_code *c)
3062 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
3063 gfc_default_integer_kind));
3067 gfc_resolve_idate (gfc_code *c)
3070 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
3071 gfc_default_integer_kind));
3075 gfc_resolve_ltime (gfc_code *c)
3078 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
3079 gfc_default_integer_kind));
3083 gfc_resolve_gmtime (gfc_code *c)
3086 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
3087 gfc_default_integer_kind));
3091 /* G77 compatibility subroutine second(). */
3094 gfc_resolve_second_sub (gfc_code *c)
3097 name = gfc_get_string (PREFIX ("second_sub"));
3098 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3103 gfc_resolve_sleep_sub (gfc_code *c)
3108 if (c->ext.actual->expr != NULL)
3109 kind = c->ext.actual->expr->ts.kind;
3111 kind = gfc_default_integer_kind;
3113 name = gfc_get_string (PREFIX ("sleep_i%d_sub"), kind);
3114 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3118 /* G77 compatibility function srand(). */
3121 gfc_resolve_srand (gfc_code *c)
3124 name = gfc_get_string (PREFIX ("srand"));
3125 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3129 /* Resolve the getarg intrinsic subroutine. */
3132 gfc_resolve_getarg (gfc_code *c)
3136 if (c->ext.actual->expr->ts.kind != gfc_default_integer_kind)
3141 ts.type = BT_INTEGER;
3142 ts.kind = gfc_default_integer_kind;
3144 gfc_convert_type (c->ext.actual->expr, &ts, 2);
3147 name = gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind);
3148 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3152 /* Resolve the getcwd intrinsic subroutine. */
3155 gfc_resolve_getcwd_sub (gfc_code *c)
3160 if (c->ext.actual->next->expr != NULL)
3161 kind = c->ext.actual->next->expr->ts.kind;
3163 kind = gfc_default_integer_kind;
3165 name = gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind);
3166 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3170 /* Resolve the get_command intrinsic subroutine. */
3173 gfc_resolve_get_command (gfc_code *c)
3177 kind = gfc_default_integer_kind;
3178 name = gfc_get_string (PREFIX ("get_command_i%d"), kind);
3179 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3183 /* Resolve the get_command_argument intrinsic subroutine. */
3186 gfc_resolve_get_command_argument (gfc_code *c)
3190 kind = gfc_default_integer_kind;
3191 name = gfc_get_string (PREFIX ("get_command_argument_i%d"), kind);
3192 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3196 /* Resolve the get_environment_variable intrinsic subroutine. */
3199 gfc_resolve_get_environment_variable (gfc_code *code)
3203 kind = gfc_default_integer_kind;
3204 name = gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind);
3205 code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3210 gfc_resolve_signal_sub (gfc_code *c)
3213 gfc_expr *number, *handler, *status;
3217 number = c->ext.actual->expr;
3218 handler = c->ext.actual->next->expr;
3219 status = c->ext.actual->next->next->expr;
3220 ts.type = BT_INTEGER;
3221 ts.kind = gfc_c_int_kind;
3223 /* handler can be either BT_INTEGER or BT_PROCEDURE */
3224 if (handler->ts.type == BT_INTEGER)
3226 if (handler->ts.kind != gfc_c_int_kind)
3227 gfc_convert_type (handler, &ts, 2);
3228 name = gfc_get_string (PREFIX ("signal_sub_int"));
3231 name = gfc_get_string (PREFIX ("signal_sub"));
3233 if (number->ts.kind != gfc_c_int_kind)
3234 gfc_convert_type (number, &ts, 2);
3235 if (status != NULL && status->ts.kind != gfc_c_int_kind)
3236 gfc_convert_type (status, &ts, 2);
3238 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3242 /* Resolve the SYSTEM intrinsic subroutine. */
3245 gfc_resolve_system_sub (gfc_code *c)
3248 name = gfc_get_string (PREFIX ("system_sub"));
3249 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3253 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
3256 gfc_resolve_system_clock (gfc_code *c)
3261 if (c->ext.actual->expr != NULL)
3262 kind = c->ext.actual->expr->ts.kind;
3263 else if (c->ext.actual->next->expr != NULL)
3264 kind = c->ext.actual->next->expr->ts.kind;
3265 else if (c->ext.actual->next->next->expr != NULL)
3266 kind = c->ext.actual->next->next->expr->ts.kind;
3268 kind = gfc_default_integer_kind;
3270 name = gfc_get_string (PREFIX ("system_clock_%d"), kind);
3271 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3275 /* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine. */
3277 gfc_resolve_execute_command_line (gfc_code *c)
3280 name = gfc_get_string (PREFIX ("execute_command_line_i%d"),
3281 gfc_default_integer_kind);
3282 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3286 /* Resolve the EXIT intrinsic subroutine. */
3289 gfc_resolve_exit (gfc_code *c)
3296 /* The STATUS argument has to be of default kind. If it is not,
3298 ts.type = BT_INTEGER;
3299 ts.kind = gfc_default_integer_kind;
3300 n = c->ext.actual->expr;
3301 if (n != NULL && n->ts.kind != ts.kind)
3302 gfc_convert_type (n, &ts, 2);
3304 name = gfc_get_string (PREFIX ("exit_i%d"), ts.kind);
3305 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3309 /* Resolve the FLUSH intrinsic subroutine. */
3312 gfc_resolve_flush (gfc_code *c)
3319 ts.type = BT_INTEGER;
3320 ts.kind = gfc_default_integer_kind;
3321 n = c->ext.actual->expr;
3322 if (n != NULL && n->ts.kind != ts.kind)
3323 gfc_convert_type (n, &ts, 2);
3325 name = gfc_get_string (PREFIX ("flush_i%d"), ts.kind);
3326 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3331 gfc_resolve_free (gfc_code *c)
3337 ts.type = BT_INTEGER;
3338 ts.kind = gfc_index_integer_kind;
3339 n = c->ext.actual->expr;
3340 if (n->ts.kind != ts.kind)
3341 gfc_convert_type (n, &ts, 2);
3343 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("free"));
3348 gfc_resolve_ctime_sub (gfc_code *c)
3353 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3354 if (c->ext.actual->expr->ts.kind != 8)
3356 ts.type = BT_INTEGER;
3358 ts.u.derived = NULL;
3360 gfc_convert_type (c->ext.actual->expr, &ts, 2);
3363 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3368 gfc_resolve_fdate_sub (gfc_code *c)
3370 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3375 gfc_resolve_gerror (gfc_code *c)
3377 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3382 gfc_resolve_getlog (gfc_code *c)
3384 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3389 gfc_resolve_hostnm_sub (gfc_code *c)
3394 if (c->ext.actual->next->expr != NULL)
3395 kind = c->ext.actual->next->expr->ts.kind;
3397 kind = gfc_default_integer_kind;
3399 name = gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind);
3400 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3405 gfc_resolve_perror (gfc_code *c)
3407 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3410 /* Resolve the STAT and FSTAT intrinsic subroutines. */
3413 gfc_resolve_stat_sub (gfc_code *c)
3416 name = gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind);
3417 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3422 gfc_resolve_lstat_sub (gfc_code *c)
3425 name = gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind);
3426 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3431 gfc_resolve_fstat_sub (gfc_code *c)
3437 u = c->ext.actual->expr;
3438 ts = &c->ext.actual->next->expr->ts;
3439 if (u->ts.kind != ts->kind)
3440 gfc_convert_type (u, ts, 2);
3441 name = gfc_get_string (PREFIX ("fstat_i%d_sub"), ts->kind);
3442 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3447 gfc_resolve_fgetc_sub (gfc_code *c)
3454 u = c->ext.actual->expr;
3455 st = c->ext.actual->next->next->expr;
3457 if (u->ts.kind != gfc_c_int_kind)
3459 ts.type = BT_INTEGER;
3460 ts.kind = gfc_c_int_kind;
3461 ts.u.derived = NULL;
3463 gfc_convert_type (u, &ts, 2);
3467 name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), st->ts.kind);
3469 name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind);
3471 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3476 gfc_resolve_fget_sub (gfc_code *c)
3481 st = c->ext.actual->next->expr;
3483 name = gfc_get_string (PREFIX ("fget_i%d_sub"), st->ts.kind);
3485 name = gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind);
3487 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3492 gfc_resolve_fputc_sub (gfc_code *c)
3499 u = c->ext.actual->expr;
3500 st = c->ext.actual->next->next->expr;
3502 if (u->ts.kind != gfc_c_int_kind)
3504 ts.type = BT_INTEGER;
3505 ts.kind = gfc_c_int_kind;
3506 ts.u.derived = NULL;
3508 gfc_convert_type (u, &ts, 2);
3512 name = gfc_get_string (PREFIX ("fputc_i%d_sub"), st->ts.kind);
3514 name = gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind);
3516 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3521 gfc_resolve_fput_sub (gfc_code *c)
3526 st = c->ext.actual->next->expr;
3528 name = gfc_get_string (PREFIX ("fput_i%d_sub"), st->ts.kind);
3530 name = gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind);
3532 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3537 gfc_resolve_fseek_sub (gfc_code *c)
3545 unit = c->ext.actual->expr;
3546 offset = c->ext.actual->next->expr;
3547 whence = c->ext.actual->next->next->expr;
3549 if (unit->ts.kind != gfc_c_int_kind)
3551 ts.type = BT_INTEGER;
3552 ts.kind = gfc_c_int_kind;
3553 ts.u.derived = NULL;
3555 gfc_convert_type (unit, &ts, 2);
3558 if (offset->ts.kind != gfc_intio_kind)
3560 ts.type = BT_INTEGER;
3561 ts.kind = gfc_intio_kind;
3562 ts.u.derived = NULL;
3564 gfc_convert_type (offset, &ts, 2);
3567 if (whence->ts.kind != gfc_c_int_kind)
3569 ts.type = BT_INTEGER;
3570 ts.kind = gfc_c_int_kind;
3571 ts.u.derived = NULL;
3573 gfc_convert_type (whence, &ts, 2);
3576 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
3580 gfc_resolve_ftell_sub (gfc_code *c)
3588 unit = c->ext.actual->expr;
3589 offset = c->ext.actual->next->expr;
3591 if (unit->ts.kind != gfc_c_int_kind)
3593 ts.type = BT_INTEGER;
3594 ts.kind = gfc_c_int_kind;
3595 ts.u.derived = NULL;
3597 gfc_convert_type (unit, &ts, 2);
3600 name = gfc_get_string (PREFIX ("ftell_i%d_sub"), offset->ts.kind);
3601 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3606 gfc_resolve_ttynam_sub (gfc_code *c)
3611 if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
3613 ts.type = BT_INTEGER;
3614 ts.kind = gfc_c_int_kind;
3615 ts.u.derived = NULL;
3617 gfc_convert_type (c->ext.actual->expr, &ts, 2);
3620 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
3624 /* Resolve the UMASK intrinsic subroutine. */
3627 gfc_resolve_umask_sub (gfc_code *c)
3632 if (c->ext.actual->next->expr != NULL)
3633 kind = c->ext.actual->next->expr->ts.kind;
3635 kind = gfc_default_integer_kind;
3637 name = gfc_get_string (PREFIX ("umask_i%d_sub"), kind);
3638 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3641 /* Resolve the UNLINK intrinsic subroutine. */
3644 gfc_resolve_unlink_sub (gfc_code *c)
3649 if (c->ext.actual->next->expr != NULL)
3650 kind = c->ext.actual->next->expr->ts.kind;
3652 kind = gfc_default_integer_kind;
3654 name = gfc_get_string (PREFIX ("unlink_i%d_sub"), kind);
3655 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);