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"
39 /* Given printf-like arguments, return a stable version of the result string.
41 We already have a working, optimized string hashing table in the form of
42 the identifier table. Reusing this table is likely not to be wasted,
43 since if the function name makes it to the gimple output of the frontend,
44 we'll have to create the identifier anyway. */
47 gfc_get_string (const char *format, ...)
53 va_start (ap, format);
54 vsnprintf (temp_name, sizeof (temp_name), format, ap);
56 temp_name[sizeof (temp_name) - 1] = 0;
58 ident = get_identifier (temp_name);
59 return IDENTIFIER_POINTER (ident);
62 /* MERGE and SPREAD need to have source charlen's present for passing
63 to the result expression. */
65 check_charlen_present (gfc_expr *source)
67 if (source->ts.u.cl == NULL)
68 source->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
70 if (source->expr_type == EXPR_CONSTANT)
72 source->ts.u.cl->length
73 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
74 source->value.character.length);
77 else if (source->expr_type == EXPR_ARRAY)
79 gfc_constructor *c = gfc_constructor_first (source->value.constructor);
80 source->ts.u.cl->length
81 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
82 c->expr->value.character.length);
86 /* Helper function for resolving the "mask" argument. */
89 resolve_mask_arg (gfc_expr *mask)
97 /* For the scalar case, coerce the mask to kind=4 unconditionally
98 (because this is the only kind we have a library function
101 if (mask->ts.kind != 4)
103 ts.type = BT_LOGICAL;
105 gfc_convert_type (mask, &ts, 2);
110 /* In the library, we access the mask with a GFC_LOGICAL_1
111 argument. No need to waste memory if we are about to create
112 a temporary array. */
113 if (mask->expr_type == EXPR_OP && mask->ts.kind != 1)
115 ts.type = BT_LOGICAL;
117 gfc_convert_type_warn (mask, &ts, 2, 0);
124 resolve_bound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind,
125 const char *name, bool coarray)
127 f->ts.type = BT_INTEGER;
129 f->ts.kind = mpz_get_si (kind->value.integer);
131 f->ts.kind = gfc_default_integer_kind;
136 f->shape = gfc_get_shape (1);
137 mpz_init_set_ui (f->shape[0], coarray ? gfc_get_corank (array)
141 f->value.function.name = xstrdup (name);
146 resolve_transformational (const char *name, gfc_expr *f, gfc_expr *array,
147 gfc_expr *dim, gfc_expr *mask)
160 resolve_mask_arg (mask);
167 f->rank = array->rank - 1;
168 f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
169 gfc_resolve_dim_arg (dim);
172 f->value.function.name
173 = gfc_get_string (PREFIX ("%s%s_%c%d"), prefix, name,
174 gfc_type_letter (array->ts.type), array->ts.kind);
178 /********************** Resolution functions **********************/
182 gfc_resolve_abs (gfc_expr *f, gfc_expr *a)
185 if (f->ts.type == BT_COMPLEX)
186 f->ts.type = BT_REAL;
188 f->value.function.name
189 = gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
194 gfc_resolve_access (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
195 gfc_expr *mode ATTRIBUTE_UNUSED)
197 f->ts.type = BT_INTEGER;
198 f->ts.kind = gfc_c_int_kind;
199 f->value.function.name = PREFIX ("access_func");
204 gfc_resolve_adjustl (gfc_expr *f, gfc_expr *string)
206 f->ts.type = BT_CHARACTER;
207 f->ts.kind = string->ts.kind;
208 f->value.function.name = gfc_get_string ("__adjustl_s%d", f->ts.kind);
213 gfc_resolve_adjustr (gfc_expr *f, gfc_expr *string)
215 f->ts.type = BT_CHARACTER;
216 f->ts.kind = string->ts.kind;
217 f->value.function.name = gfc_get_string ("__adjustr_s%d", f->ts.kind);
222 gfc_resolve_char_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind,
225 f->ts.type = BT_CHARACTER;
226 f->ts.kind = (kind == NULL)
227 ? gfc_default_character_kind : mpz_get_si (kind->value.integer);
228 f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
229 f->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
231 f->value.function.name = gfc_get_string (name, f->ts.kind,
232 gfc_type_letter (x->ts.type),
238 gfc_resolve_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind)
240 gfc_resolve_char_achar (f, x, kind, "__achar_%d_%c%d");
245 gfc_resolve_acos (gfc_expr *f, gfc_expr *x)
248 f->value.function.name
249 = gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
254 gfc_resolve_acosh (gfc_expr *f, gfc_expr *x)
257 f->value.function.name
258 = gfc_get_string ("__acosh_%c%d", gfc_type_letter (x->ts.type),
264 gfc_resolve_aimag (gfc_expr *f, gfc_expr *x)
266 f->ts.type = BT_REAL;
267 f->ts.kind = x->ts.kind;
268 f->value.function.name
269 = gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type),
275 gfc_resolve_and (gfc_expr *f, gfc_expr *i, gfc_expr *j)
277 f->ts.type = i->ts.type;
278 f->ts.kind = gfc_kind_max (i, j);
280 if (i->ts.kind != j->ts.kind)
282 if (i->ts.kind == gfc_kind_max (i, j))
283 gfc_convert_type (j, &i->ts, 2);
285 gfc_convert_type (i, &j->ts, 2);
288 f->value.function.name
289 = gfc_get_string ("__and_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
294 gfc_resolve_aint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
299 f->ts.type = a->ts.type;
300 f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
302 if (a->ts.kind != f->ts.kind)
304 ts.type = f->ts.type;
305 ts.kind = f->ts.kind;
306 gfc_convert_type (a, &ts, 2);
308 /* The resolved name is only used for specific intrinsics where
309 the return kind is the same as the arg kind. */
310 f->value.function.name
311 = gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
316 gfc_resolve_dint (gfc_expr *f, gfc_expr *a)
318 gfc_resolve_aint (f, a, NULL);
323 gfc_resolve_all (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
329 gfc_resolve_dim_arg (dim);
330 f->rank = mask->rank - 1;
331 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
334 f->value.function.name
335 = gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask->ts.type),
341 gfc_resolve_anint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
346 f->ts.type = a->ts.type;
347 f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
349 if (a->ts.kind != f->ts.kind)
351 ts.type = f->ts.type;
352 ts.kind = f->ts.kind;
353 gfc_convert_type (a, &ts, 2);
356 /* The resolved name is only used for specific intrinsics where
357 the return kind is the same as the arg kind. */
358 f->value.function.name
359 = gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type),
365 gfc_resolve_dnint (gfc_expr *f, gfc_expr *a)
367 gfc_resolve_anint (f, a, NULL);
372 gfc_resolve_any (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
378 gfc_resolve_dim_arg (dim);
379 f->rank = mask->rank - 1;
380 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
383 f->value.function.name
384 = gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask->ts.type),
390 gfc_resolve_asin (gfc_expr *f, gfc_expr *x)
393 f->value.function.name
394 = gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
398 gfc_resolve_asinh (gfc_expr *f, gfc_expr *x)
401 f->value.function.name
402 = gfc_get_string ("__asinh_%c%d", gfc_type_letter (x->ts.type),
407 gfc_resolve_atan (gfc_expr *f, gfc_expr *x)
410 f->value.function.name
411 = gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
415 gfc_resolve_atanh (gfc_expr *f, gfc_expr *x)
418 f->value.function.name
419 = gfc_get_string ("__atanh_%c%d", gfc_type_letter (x->ts.type),
424 gfc_resolve_atan2 (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
427 f->value.function.name
428 = gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type),
433 /* Resolve the BESYN and BESJN intrinsics. */
436 gfc_resolve_besn (gfc_expr *f, gfc_expr *n, gfc_expr *x)
442 if (n->ts.kind != gfc_c_int_kind)
444 ts.type = BT_INTEGER;
445 ts.kind = gfc_c_int_kind;
446 gfc_convert_type (n, &ts, 2);
448 f->value.function.name = gfc_get_string ("<intrinsic>");
453 gfc_resolve_bessel_n2 (gfc_expr *f, gfc_expr *n1, gfc_expr *n2, gfc_expr *x)
460 if (n1->expr_type == EXPR_CONSTANT && n2->expr_type == EXPR_CONSTANT)
462 f->shape = gfc_get_shape (1);
463 mpz_init (f->shape[0]);
464 mpz_sub (f->shape[0], n2->value.integer, n1->value.integer);
465 mpz_add_ui (f->shape[0], f->shape[0], 1);
468 if (n1->ts.kind != gfc_c_int_kind)
470 ts.type = BT_INTEGER;
471 ts.kind = gfc_c_int_kind;
472 gfc_convert_type (n1, &ts, 2);
475 if (n2->ts.kind != gfc_c_int_kind)
477 ts.type = BT_INTEGER;
478 ts.kind = gfc_c_int_kind;
479 gfc_convert_type (n2, &ts, 2);
482 if (f->value.function.isym->id == GFC_ISYM_JN2)
483 f->value.function.name = gfc_get_string (PREFIX ("bessel_jn_r%d"),
486 f->value.function.name = gfc_get_string (PREFIX ("bessel_yn_r%d"),
492 gfc_resolve_btest (gfc_expr *f, gfc_expr *i, gfc_expr *pos)
494 f->ts.type = BT_LOGICAL;
495 f->ts.kind = gfc_default_logical_kind;
496 f->value.function.name
497 = gfc_get_string ("__btest_%d_%d", i->ts.kind, pos->ts.kind);
502 gfc_resolve_ceiling (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
504 f->ts.type = BT_INTEGER;
505 f->ts.kind = (kind == NULL)
506 ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
507 f->value.function.name
508 = gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind,
509 gfc_type_letter (a->ts.type), a->ts.kind);
514 gfc_resolve_char (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
516 gfc_resolve_char_achar (f, a, kind, "__char_%d_%c%d");
521 gfc_resolve_chdir (gfc_expr *f, gfc_expr *d ATTRIBUTE_UNUSED)
523 f->ts.type = BT_INTEGER;
524 f->ts.kind = gfc_default_integer_kind;
525 f->value.function.name = gfc_get_string (PREFIX ("chdir_i%d"), f->ts.kind);
530 gfc_resolve_chdir_sub (gfc_code *c)
535 if (c->ext.actual->next->expr != NULL)
536 kind = c->ext.actual->next->expr->ts.kind;
538 kind = gfc_default_integer_kind;
540 name = gfc_get_string (PREFIX ("chdir_i%d_sub"), kind);
541 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
546 gfc_resolve_chmod (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
547 gfc_expr *mode ATTRIBUTE_UNUSED)
549 f->ts.type = BT_INTEGER;
550 f->ts.kind = gfc_c_int_kind;
551 f->value.function.name = PREFIX ("chmod_func");
556 gfc_resolve_chmod_sub (gfc_code *c)
561 if (c->ext.actual->next->next->expr != NULL)
562 kind = c->ext.actual->next->next->expr->ts.kind;
564 kind = gfc_default_integer_kind;
566 name = gfc_get_string (PREFIX ("chmod_i%d_sub"), kind);
567 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
572 gfc_resolve_cmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y, gfc_expr *kind)
574 f->ts.type = BT_COMPLEX;
575 f->ts.kind = (kind == NULL)
576 ? gfc_default_real_kind : mpz_get_si (kind->value.integer);
579 f->value.function.name
580 = gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind,
581 gfc_type_letter (x->ts.type), x->ts.kind);
583 f->value.function.name
584 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
585 gfc_type_letter (x->ts.type), x->ts.kind,
586 gfc_type_letter (y->ts.type), y->ts.kind);
591 gfc_resolve_dcmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y)
593 gfc_resolve_cmplx (f, x, y, gfc_get_int_expr (gfc_default_integer_kind, NULL,
594 gfc_default_double_kind));
599 gfc_resolve_complex (gfc_expr *f, gfc_expr *x, gfc_expr *y)
603 if (x->ts.type == BT_INTEGER)
605 if (y->ts.type == BT_INTEGER)
606 kind = gfc_default_real_kind;
612 if (y->ts.type == BT_REAL)
613 kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
618 f->ts.type = BT_COMPLEX;
620 f->value.function.name
621 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
622 gfc_type_letter (x->ts.type), x->ts.kind,
623 gfc_type_letter (y->ts.type), y->ts.kind);
628 gfc_resolve_conjg (gfc_expr *f, gfc_expr *x)
631 f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind);
636 gfc_resolve_cos (gfc_expr *f, gfc_expr *x)
639 f->value.function.name
640 = gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
645 gfc_resolve_cosh (gfc_expr *f, gfc_expr *x)
648 f->value.function.name
649 = gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
654 gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
656 f->ts.type = BT_INTEGER;
658 f->ts.kind = mpz_get_si (kind->value.integer);
660 f->ts.kind = gfc_default_integer_kind;
664 f->rank = mask->rank - 1;
665 gfc_resolve_dim_arg (dim);
666 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
669 resolve_mask_arg (mask);
671 f->value.function.name
672 = gfc_get_string (PREFIX ("count_%d_%c"), f->ts.kind,
673 gfc_type_letter (mask->ts.type));
678 gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
683 if (array->ts.type == BT_CHARACTER && array->ref)
684 gfc_resolve_substring_charlen (array);
687 f->rank = array->rank;
688 f->shape = gfc_copy_shape (array->shape, array->rank);
695 /* If dim kind is greater than default integer we need to use the larger. */
696 m = gfc_default_integer_kind;
698 m = m < dim->ts.kind ? dim->ts.kind : m;
700 /* Convert shift to at least m, so we don't need
701 kind=1 and kind=2 versions of the library functions. */
702 if (shift->ts.kind < m)
706 ts.type = BT_INTEGER;
708 gfc_convert_type_warn (shift, &ts, 2, 0);
713 if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL
714 && dim->symtree->n.sym->attr.optional)
716 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
717 dim->representation.length = shift->ts.kind;
721 gfc_resolve_dim_arg (dim);
722 /* Convert dim to shift's kind to reduce variations. */
723 if (dim->ts.kind != shift->ts.kind)
724 gfc_convert_type_warn (dim, &shift->ts, 2, 0);
728 if (array->ts.type == BT_CHARACTER)
730 if (array->ts.kind == gfc_default_character_kind)
731 f->value.function.name
732 = gfc_get_string (PREFIX ("cshift%d_%d_char"), n, shift->ts.kind);
734 f->value.function.name
735 = gfc_get_string (PREFIX ("cshift%d_%d_char%d"), n, shift->ts.kind,
739 f->value.function.name
740 = gfc_get_string (PREFIX ("cshift%d_%d"), n, shift->ts.kind);
745 gfc_resolve_ctime (gfc_expr *f, gfc_expr *time)
750 f->ts.type = BT_CHARACTER;
751 f->ts.kind = gfc_default_character_kind;
753 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
754 if (time->ts.kind != 8)
756 ts.type = BT_INTEGER;
760 gfc_convert_type (time, &ts, 2);
763 f->value.function.name = gfc_get_string (PREFIX ("ctime"));
768 gfc_resolve_dble (gfc_expr *f, gfc_expr *a)
770 f->ts.type = BT_REAL;
771 f->ts.kind = gfc_default_double_kind;
772 f->value.function.name
773 = gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
778 gfc_resolve_dim (gfc_expr *f, gfc_expr *a, gfc_expr *p)
780 f->ts.type = a->ts.type;
782 f->ts.kind = gfc_kind_max (a,p);
784 f->ts.kind = a->ts.kind;
786 if (p != NULL && a->ts.kind != p->ts.kind)
788 if (a->ts.kind == gfc_kind_max (a,p))
789 gfc_convert_type (p, &a->ts, 2);
791 gfc_convert_type (a, &p->ts, 2);
794 f->value.function.name
795 = gfc_get_string ("__dim_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
800 gfc_resolve_dot_product (gfc_expr *f, gfc_expr *a, gfc_expr *b)
804 temp.expr_type = EXPR_OP;
805 gfc_clear_ts (&temp.ts);
806 temp.value.op.op = INTRINSIC_NONE;
807 temp.value.op.op1 = a;
808 temp.value.op.op2 = b;
809 gfc_type_convert_binary (&temp, 1);
811 f->value.function.name
812 = gfc_get_string (PREFIX ("dot_product_%c%d"),
813 gfc_type_letter (f->ts.type), f->ts.kind);
818 gfc_resolve_dprod (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
819 gfc_expr *b ATTRIBUTE_UNUSED)
821 f->ts.kind = gfc_default_double_kind;
822 f->ts.type = BT_REAL;
823 f->value.function.name = gfc_get_string ("__dprod_r%d", f->ts.kind);
828 gfc_resolve_dshift (gfc_expr *f, gfc_expr *i, gfc_expr *j ATTRIBUTE_UNUSED,
829 gfc_expr *shift ATTRIBUTE_UNUSED)
832 if (f->value.function.isym->id == GFC_ISYM_DSHIFTL)
833 f->value.function.name = gfc_get_string ("dshiftl_i%d", f->ts.kind);
834 else if (f->value.function.isym->id == GFC_ISYM_DSHIFTR)
835 f->value.function.name = gfc_get_string ("dshiftr_i%d", f->ts.kind);
842 gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
843 gfc_expr *boundary, gfc_expr *dim)
847 if (array->ts.type == BT_CHARACTER && array->ref)
848 gfc_resolve_substring_charlen (array);
851 f->rank = array->rank;
852 f->shape = gfc_copy_shape (array->shape, array->rank);
857 if (boundary && boundary->rank > 0)
860 /* If dim kind is greater than default integer we need to use the larger. */
861 m = gfc_default_integer_kind;
863 m = m < dim->ts.kind ? dim->ts.kind : m;
865 /* Convert shift to at least m, so we don't need
866 kind=1 and kind=2 versions of the library functions. */
867 if (shift->ts.kind < m)
871 ts.type = BT_INTEGER;
873 gfc_convert_type_warn (shift, &ts, 2, 0);
878 if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL
879 && dim->symtree->n.sym->attr.optional)
881 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
882 dim->representation.length = shift->ts.kind;
886 gfc_resolve_dim_arg (dim);
887 /* Convert dim to shift's kind to reduce variations. */
888 if (dim->ts.kind != shift->ts.kind)
889 gfc_convert_type_warn (dim, &shift->ts, 2, 0);
893 if (array->ts.type == BT_CHARACTER)
895 if (array->ts.kind == gfc_default_character_kind)
896 f->value.function.name
897 = gfc_get_string (PREFIX ("eoshift%d_%d_char"), n, shift->ts.kind);
899 f->value.function.name
900 = gfc_get_string (PREFIX ("eoshift%d_%d_char%d"), n, shift->ts.kind,
904 f->value.function.name
905 = gfc_get_string (PREFIX ("eoshift%d_%d"), n, shift->ts.kind);
910 gfc_resolve_exp (gfc_expr *f, gfc_expr *x)
913 f->value.function.name
914 = gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
919 gfc_resolve_exponent (gfc_expr *f, gfc_expr *x)
921 f->ts.type = BT_INTEGER;
922 f->ts.kind = gfc_default_integer_kind;
923 f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind);
927 /* Resolve the EXTENDS_TYPE_OF intrinsic function. */
930 gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
935 /* Prevent double resolution. */
936 if (f->ts.type == BT_LOGICAL)
939 /* Replace the first argument with the corresponding vtab. */
940 if (a->ts.type == BT_CLASS)
941 gfc_add_vptr_component (a);
942 else if (a->ts.type == BT_DERIVED)
944 vtab = gfc_find_derived_vtab (a->ts.u.derived);
945 /* Clear the old expr. */
946 gfc_free_ref_list (a->ref);
947 memset (a, '\0', sizeof (gfc_expr));
948 /* Construct a new one. */
949 a->expr_type = EXPR_VARIABLE;
950 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
955 /* Replace the second argument with the corresponding vtab. */
956 if (mo->ts.type == BT_CLASS)
957 gfc_add_vptr_component (mo);
958 else if (mo->ts.type == BT_DERIVED)
960 vtab = gfc_find_derived_vtab (mo->ts.u.derived);
961 /* Clear the old expr. */
962 gfc_free_ref_list (mo->ref);
963 memset (mo, '\0', sizeof (gfc_expr));
964 /* Construct a new one. */
965 mo->expr_type = EXPR_VARIABLE;
966 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
971 f->ts.type = BT_LOGICAL;
974 f->value.function.isym->formal->ts = a->ts;
975 f->value.function.isym->formal->next->ts = mo->ts;
977 /* Call library function. */
978 f->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
983 gfc_resolve_fdate (gfc_expr *f)
985 f->ts.type = BT_CHARACTER;
986 f->ts.kind = gfc_default_character_kind;
987 f->value.function.name = gfc_get_string (PREFIX ("fdate"));
992 gfc_resolve_floor (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
994 f->ts.type = BT_INTEGER;
995 f->ts.kind = (kind == NULL)
996 ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
997 f->value.function.name
998 = gfc_get_string ("__floor%d_%c%d", f->ts.kind,
999 gfc_type_letter (a->ts.type), a->ts.kind);
1004 gfc_resolve_fnum (gfc_expr *f, gfc_expr *n)
1006 f->ts.type = BT_INTEGER;
1007 f->ts.kind = gfc_default_integer_kind;
1008 if (n->ts.kind != f->ts.kind)
1009 gfc_convert_type (n, &f->ts, 2);
1010 f->value.function.name = gfc_get_string (PREFIX ("fnum_i%d"), f->ts.kind);
1015 gfc_resolve_fraction (gfc_expr *f, gfc_expr *x)
1018 f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind);
1022 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
1025 gfc_resolve_g77_math1 (gfc_expr *f, gfc_expr *x)
1028 f->value.function.name = gfc_get_string ("<intrinsic>");
1033 gfc_resolve_gamma (gfc_expr *f, gfc_expr *x)
1036 f->value.function.name
1037 = gfc_get_string ("__tgamma_%d", x->ts.kind);
1042 gfc_resolve_getcwd (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
1044 f->ts.type = BT_INTEGER;
1046 f->value.function.name = gfc_get_string (PREFIX ("getcwd"));
1051 gfc_resolve_getgid (gfc_expr *f)
1053 f->ts.type = BT_INTEGER;
1055 f->value.function.name = gfc_get_string (PREFIX ("getgid"));
1060 gfc_resolve_getpid (gfc_expr *f)
1062 f->ts.type = BT_INTEGER;
1064 f->value.function.name = gfc_get_string (PREFIX ("getpid"));
1069 gfc_resolve_getuid (gfc_expr *f)
1071 f->ts.type = BT_INTEGER;
1073 f->value.function.name = gfc_get_string (PREFIX ("getuid"));
1078 gfc_resolve_hostnm (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
1080 f->ts.type = BT_INTEGER;
1082 f->value.function.name = gfc_get_string (PREFIX ("hostnm"));
1087 gfc_resolve_hypot (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
1090 f->value.function.name = gfc_get_string ("__hypot_r%d", x->ts.kind);
1095 gfc_resolve_iall (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
1097 resolve_transformational ("iall", f, array, dim, mask);
1102 gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1104 /* If the kind of i and j are different, then g77 cross-promoted the
1105 kinds to the largest value. The Fortran 95 standard requires the
1107 if (i->ts.kind != j->ts.kind)
1109 if (i->ts.kind == gfc_kind_max (i, j))
1110 gfc_convert_type (j, &i->ts, 2);
1112 gfc_convert_type (i, &j->ts, 2);
1116 f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind);
1121 gfc_resolve_iany (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
1123 resolve_transformational ("iany", f, array, dim, mask);
1128 gfc_resolve_ibclr (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
1131 f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind);
1136 gfc_resolve_ibits (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED,
1137 gfc_expr *len ATTRIBUTE_UNUSED)
1140 f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind);
1145 gfc_resolve_ibset (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
1148 f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind);
1153 gfc_resolve_iachar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
1155 f->ts.type = BT_INTEGER;
1157 f->ts.kind = mpz_get_si (kind->value.integer);
1159 f->ts.kind = gfc_default_integer_kind;
1160 f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
1165 gfc_resolve_ichar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
1167 f->ts.type = BT_INTEGER;
1169 f->ts.kind = mpz_get_si (kind->value.integer);
1171 f->ts.kind = gfc_default_integer_kind;
1172 f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
1177 gfc_resolve_idnint (gfc_expr *f, gfc_expr *a)
1179 gfc_resolve_nint (f, a, NULL);
1184 gfc_resolve_ierrno (gfc_expr *f)
1186 f->ts.type = BT_INTEGER;
1187 f->ts.kind = gfc_default_integer_kind;
1188 f->value.function.name = gfc_get_string (PREFIX ("ierrno_i%d"), f->ts.kind);
1193 gfc_resolve_ieor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1195 /* If the kind of i and j are different, then g77 cross-promoted the
1196 kinds to the largest value. The Fortran 95 standard requires the
1198 if (i->ts.kind != j->ts.kind)
1200 if (i->ts.kind == gfc_kind_max (i, j))
1201 gfc_convert_type (j, &i->ts, 2);
1203 gfc_convert_type (i, &j->ts, 2);
1207 f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind);
1212 gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1214 /* If the kind of i and j are different, then g77 cross-promoted the
1215 kinds to the largest value. The Fortran 95 standard requires the
1217 if (i->ts.kind != j->ts.kind)
1219 if (i->ts.kind == gfc_kind_max (i, j))
1220 gfc_convert_type (j, &i->ts, 2);
1222 gfc_convert_type (i, &j->ts, 2);
1226 f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind);
1231 gfc_resolve_index_func (gfc_expr *f, gfc_expr *str,
1232 gfc_expr *sub_str ATTRIBUTE_UNUSED, gfc_expr *back,
1238 f->ts.type = BT_INTEGER;
1240 f->ts.kind = mpz_get_si (kind->value.integer);
1242 f->ts.kind = gfc_default_integer_kind;
1244 if (back && back->ts.kind != gfc_default_integer_kind)
1246 ts.type = BT_LOGICAL;
1247 ts.kind = gfc_default_integer_kind;
1248 ts.u.derived = NULL;
1250 gfc_convert_type (back, &ts, 2);
1253 f->value.function.name
1254 = gfc_get_string ("__index_%d_i%d", str->ts.kind, f->ts.kind);
1259 gfc_resolve_int (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1261 f->ts.type = BT_INTEGER;
1262 f->ts.kind = (kind == NULL)
1263 ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
1264 f->value.function.name
1265 = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1266 gfc_type_letter (a->ts.type), a->ts.kind);
1271 gfc_resolve_int2 (gfc_expr *f, gfc_expr *a)
1273 f->ts.type = BT_INTEGER;
1275 f->value.function.name
1276 = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1277 gfc_type_letter (a->ts.type), a->ts.kind);
1282 gfc_resolve_int8 (gfc_expr *f, gfc_expr *a)
1284 f->ts.type = BT_INTEGER;
1286 f->value.function.name
1287 = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1288 gfc_type_letter (a->ts.type), a->ts.kind);
1293 gfc_resolve_long (gfc_expr *f, gfc_expr *a)
1295 f->ts.type = BT_INTEGER;
1297 f->value.function.name
1298 = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1299 gfc_type_letter (a->ts.type), a->ts.kind);
1304 gfc_resolve_iparity (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
1306 resolve_transformational ("iparity", f, array, dim, mask);
1311 gfc_resolve_isatty (gfc_expr *f, gfc_expr *u)
1316 f->ts.type = BT_LOGICAL;
1317 f->ts.kind = gfc_default_integer_kind;
1318 if (u->ts.kind != gfc_c_int_kind)
1320 ts.type = BT_INTEGER;
1321 ts.kind = gfc_c_int_kind;
1322 ts.u.derived = NULL;
1324 gfc_convert_type (u, &ts, 2);
1327 f->value.function.name = gfc_get_string (PREFIX ("isatty_l%d"), f->ts.kind);
1332 gfc_resolve_ishft (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1335 f->value.function.name
1336 = gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
1341 gfc_resolve_rshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1344 f->value.function.name
1345 = gfc_get_string ("__rshift_%d_%d", i->ts.kind, shift->ts.kind);
1350 gfc_resolve_lshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1353 f->value.function.name
1354 = gfc_get_string ("__lshift_%d_%d", i->ts.kind, shift->ts.kind);
1359 gfc_resolve_ishftc (gfc_expr *f, gfc_expr *i, gfc_expr *shift, gfc_expr *size)
1363 s_kind = (size == NULL) ? gfc_default_integer_kind : size->ts.kind;
1366 f->value.function.name
1367 = gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
1372 gfc_resolve_kill (gfc_expr *f, gfc_expr *p ATTRIBUTE_UNUSED,
1373 gfc_expr *s ATTRIBUTE_UNUSED)
1375 f->ts.type = BT_INTEGER;
1376 f->ts.kind = gfc_default_integer_kind;
1377 f->value.function.name = gfc_get_string (PREFIX ("kill_i%d"), f->ts.kind);
1382 gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
1384 resolve_bound (f, array, dim, kind, "__lbound", false);
1389 gfc_resolve_lcobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
1391 resolve_bound (f, array, dim, kind, "__lcobound", true);
1396 gfc_resolve_len (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
1398 f->ts.type = BT_INTEGER;
1400 f->ts.kind = mpz_get_si (kind->value.integer);
1402 f->ts.kind = gfc_default_integer_kind;
1403 f->value.function.name
1404 = gfc_get_string ("__len_%d_i%d", string->ts.kind,
1405 gfc_default_integer_kind);
1410 gfc_resolve_len_trim (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
1412 f->ts.type = BT_INTEGER;
1414 f->ts.kind = mpz_get_si (kind->value.integer);
1416 f->ts.kind = gfc_default_integer_kind;
1417 f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
1422 gfc_resolve_lgamma (gfc_expr *f, gfc_expr *x)
1425 f->value.function.name
1426 = gfc_get_string ("__lgamma_%d", x->ts.kind);
1431 gfc_resolve_link (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
1432 gfc_expr *p2 ATTRIBUTE_UNUSED)
1434 f->ts.type = BT_INTEGER;
1435 f->ts.kind = gfc_default_integer_kind;
1436 f->value.function.name = gfc_get_string (PREFIX ("link_i%d"), f->ts.kind);
1441 gfc_resolve_loc (gfc_expr *f, gfc_expr *x)
1443 f->ts.type= BT_INTEGER;
1444 f->ts.kind = gfc_index_integer_kind;
1445 f->value.function.name = gfc_get_string ("__loc_%d", x->ts.kind);
1450 gfc_resolve_log (gfc_expr *f, gfc_expr *x)
1453 f->value.function.name
1454 = gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1459 gfc_resolve_log10 (gfc_expr *f, gfc_expr *x)
1462 f->value.function.name
1463 = gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type),
1469 gfc_resolve_logical (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1471 f->ts.type = BT_LOGICAL;
1472 f->ts.kind = (kind == NULL)
1473 ? gfc_default_logical_kind : mpz_get_si (kind->value.integer);
1476 f->value.function.name
1477 = gfc_get_string ("__logical_%d_%c%d", f->ts.kind,
1478 gfc_type_letter (a->ts.type), a->ts.kind);
1483 gfc_resolve_malloc (gfc_expr *f, gfc_expr *size)
1485 if (size->ts.kind < gfc_index_integer_kind)
1490 ts.type = BT_INTEGER;
1491 ts.kind = gfc_index_integer_kind;
1492 gfc_convert_type_warn (size, &ts, 2, 0);
1495 f->ts.type = BT_INTEGER;
1496 f->ts.kind = gfc_index_integer_kind;
1497 f->value.function.name = gfc_get_string (PREFIX ("malloc"));
1502 gfc_resolve_matmul (gfc_expr *f, gfc_expr *a, gfc_expr *b)
1506 if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
1508 f->ts.type = BT_LOGICAL;
1509 f->ts.kind = gfc_default_logical_kind;
1513 temp.expr_type = EXPR_OP;
1514 gfc_clear_ts (&temp.ts);
1515 temp.value.op.op = INTRINSIC_NONE;
1516 temp.value.op.op1 = a;
1517 temp.value.op.op2 = b;
1518 gfc_type_convert_binary (&temp, 1);
1522 f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
1524 if (a->rank == 2 && b->rank == 2)
1526 if (a->shape && b->shape)
1528 f->shape = gfc_get_shape (f->rank);
1529 mpz_init_set (f->shape[0], a->shape[0]);
1530 mpz_init_set (f->shape[1], b->shape[1]);
1533 else if (a->rank == 1)
1537 f->shape = gfc_get_shape (f->rank);
1538 mpz_init_set (f->shape[0], b->shape[1]);
1543 /* b->rank == 1 and a->rank == 2 here, all other cases have
1544 been caught in check.c. */
1547 f->shape = gfc_get_shape (f->rank);
1548 mpz_init_set (f->shape[0], a->shape[0]);
1552 f->value.function.name
1553 = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f->ts.type),
1559 gfc_resolve_minmax (const char *name, gfc_expr *f, gfc_actual_arglist *args)
1561 gfc_actual_arglist *a;
1563 f->ts.type = args->expr->ts.type;
1564 f->ts.kind = args->expr->ts.kind;
1565 /* Find the largest type kind. */
1566 for (a = args->next; a; a = a->next)
1568 if (a->expr->ts.kind > f->ts.kind)
1569 f->ts.kind = a->expr->ts.kind;
1572 /* Convert all parameters to the required kind. */
1573 for (a = args; a; a = a->next)
1575 if (a->expr->ts.kind != f->ts.kind)
1576 gfc_convert_type (a->expr, &f->ts, 2);
1579 f->value.function.name
1580 = gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind);
1585 gfc_resolve_max (gfc_expr *f, gfc_actual_arglist *args)
1587 gfc_resolve_minmax ("__max_%c%d", f, args);
1592 gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1598 f->ts.type = BT_INTEGER;
1599 f->ts.kind = gfc_default_integer_kind;
1604 f->shape = gfc_get_shape (1);
1605 mpz_init_set_si (f->shape[0], array->rank);
1609 f->rank = array->rank - 1;
1610 gfc_resolve_dim_arg (dim);
1611 if (array->shape && dim->expr_type == EXPR_CONSTANT)
1613 idim = (int) mpz_get_si (dim->value.integer);
1614 f->shape = gfc_get_shape (f->rank);
1615 for (i = 0, j = 0; i < f->rank; i++, j++)
1617 if (i == (idim - 1))
1619 mpz_init_set (f->shape[i], array->shape[j]);
1626 if (mask->rank == 0)
1631 resolve_mask_arg (mask);
1636 f->value.function.name
1637 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1638 gfc_type_letter (array->ts.type), array->ts.kind);
1643 gfc_resolve_maxval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1653 f->rank = array->rank - 1;
1654 gfc_resolve_dim_arg (dim);
1656 if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
1658 idim = (int) mpz_get_si (dim->value.integer);
1659 f->shape = gfc_get_shape (f->rank);
1660 for (i = 0, j = 0; i < f->rank; i++, j++)
1662 if (i == (idim - 1))
1664 mpz_init_set (f->shape[i], array->shape[j]);
1671 if (mask->rank == 0)
1676 resolve_mask_arg (mask);
1681 f->value.function.name
1682 = gfc_get_string (PREFIX ("%s_%c%d"), name,
1683 gfc_type_letter (array->ts.type), array->ts.kind);
1688 gfc_resolve_mclock (gfc_expr *f)
1690 f->ts.type = BT_INTEGER;
1692 f->value.function.name = PREFIX ("mclock");
1697 gfc_resolve_mclock8 (gfc_expr *f)
1699 f->ts.type = BT_INTEGER;
1701 f->value.function.name = PREFIX ("mclock8");
1706 gfc_resolve_mask (gfc_expr *f, gfc_expr *i ATTRIBUTE_UNUSED,
1709 f->ts.type = BT_INTEGER;
1710 f->ts.kind = kind ? mpz_get_si (kind->value.integer)
1711 : gfc_default_integer_kind;
1713 if (f->value.function.isym->id == GFC_ISYM_MASKL)
1714 f->value.function.name = gfc_get_string ("__maskl_i%d", f->ts.kind);
1716 f->value.function.name = gfc_get_string ("__maskr_i%d", f->ts.kind);
1721 gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource,
1722 gfc_expr *fsource ATTRIBUTE_UNUSED,
1723 gfc_expr *mask ATTRIBUTE_UNUSED)
1725 if (tsource->ts.type == BT_CHARACTER && tsource->ref)
1726 gfc_resolve_substring_charlen (tsource);
1728 if (fsource->ts.type == BT_CHARACTER && fsource->ref)
1729 gfc_resolve_substring_charlen (fsource);
1731 if (tsource->ts.type == BT_CHARACTER)
1732 check_charlen_present (tsource);
1734 f->ts = tsource->ts;
1735 f->value.function.name
1736 = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
1742 gfc_resolve_merge_bits (gfc_expr *f, gfc_expr *i,
1743 gfc_expr *j ATTRIBUTE_UNUSED,
1744 gfc_expr *mask ATTRIBUTE_UNUSED)
1747 f->value.function.name = gfc_get_string ("__merge_bits_i%d", i->ts.kind);
1752 gfc_resolve_min (gfc_expr *f, gfc_actual_arglist *args)
1754 gfc_resolve_minmax ("__min_%c%d", f, args);
1759 gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1765 f->ts.type = BT_INTEGER;
1766 f->ts.kind = gfc_default_integer_kind;
1771 f->shape = gfc_get_shape (1);
1772 mpz_init_set_si (f->shape[0], array->rank);
1776 f->rank = array->rank - 1;
1777 gfc_resolve_dim_arg (dim);
1778 if (array->shape && dim->expr_type == EXPR_CONSTANT)
1780 idim = (int) mpz_get_si (dim->value.integer);
1781 f->shape = gfc_get_shape (f->rank);
1782 for (i = 0, j = 0; i < f->rank; i++, j++)
1784 if (i == (idim - 1))
1786 mpz_init_set (f->shape[i], array->shape[j]);
1793 if (mask->rank == 0)
1798 resolve_mask_arg (mask);
1803 f->value.function.name
1804 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1805 gfc_type_letter (array->ts.type), array->ts.kind);
1810 gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1820 f->rank = array->rank - 1;
1821 gfc_resolve_dim_arg (dim);
1823 if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
1825 idim = (int) mpz_get_si (dim->value.integer);
1826 f->shape = gfc_get_shape (f->rank);
1827 for (i = 0, j = 0; i < f->rank; i++, j++)
1829 if (i == (idim - 1))
1831 mpz_init_set (f->shape[i], array->shape[j]);
1838 if (mask->rank == 0)
1843 resolve_mask_arg (mask);
1848 f->value.function.name
1849 = gfc_get_string (PREFIX ("%s_%c%d"), name,
1850 gfc_type_letter (array->ts.type), array->ts.kind);
1855 gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p)
1857 f->ts.type = a->ts.type;
1859 f->ts.kind = gfc_kind_max (a,p);
1861 f->ts.kind = a->ts.kind;
1863 if (p != NULL && a->ts.kind != p->ts.kind)
1865 if (a->ts.kind == gfc_kind_max (a,p))
1866 gfc_convert_type (p, &a->ts, 2);
1868 gfc_convert_type (a, &p->ts, 2);
1871 f->value.function.name
1872 = gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
1877 gfc_resolve_modulo (gfc_expr *f, gfc_expr *a, gfc_expr *p)
1879 f->ts.type = a->ts.type;
1881 f->ts.kind = gfc_kind_max (a,p);
1883 f->ts.kind = a->ts.kind;
1885 if (p != NULL && a->ts.kind != p->ts.kind)
1887 if (a->ts.kind == gfc_kind_max (a,p))
1888 gfc_convert_type (p, &a->ts, 2);
1890 gfc_convert_type (a, &p->ts, 2);
1893 f->value.function.name
1894 = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type),
1899 gfc_resolve_nearest (gfc_expr *f, gfc_expr *a, gfc_expr *p)
1901 if (p->ts.kind != a->ts.kind)
1902 gfc_convert_type (p, &a->ts, 2);
1905 f->value.function.name
1906 = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
1911 gfc_resolve_nint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1913 f->ts.type = BT_INTEGER;
1914 f->ts.kind = (kind == NULL)
1915 ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
1916 f->value.function.name
1917 = gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
1922 gfc_resolve_norm2 (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
1924 resolve_transformational ("norm2", f, array, dim, NULL);
1929 gfc_resolve_not (gfc_expr *f, gfc_expr *i)
1932 f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
1937 gfc_resolve_or (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1939 f->ts.type = i->ts.type;
1940 f->ts.kind = gfc_kind_max (i, j);
1942 if (i->ts.kind != j->ts.kind)
1944 if (i->ts.kind == gfc_kind_max (i, j))
1945 gfc_convert_type (j, &i->ts, 2);
1947 gfc_convert_type (i, &j->ts, 2);
1950 f->value.function.name
1951 = gfc_get_string ("__or_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
1956 gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
1957 gfc_expr *vector ATTRIBUTE_UNUSED)
1959 if (array->ts.type == BT_CHARACTER && array->ref)
1960 gfc_resolve_substring_charlen (array);
1965 resolve_mask_arg (mask);
1967 if (mask->rank != 0)
1969 if (array->ts.type == BT_CHARACTER)
1970 f->value.function.name
1971 = array->ts.kind == 1 ? PREFIX ("pack_char")
1973 (PREFIX ("pack_char%d"),
1976 f->value.function.name = PREFIX ("pack");
1980 if (array->ts.type == BT_CHARACTER)
1981 f->value.function.name
1982 = array->ts.kind == 1 ? PREFIX ("pack_s_char")
1984 (PREFIX ("pack_s_char%d"),
1987 f->value.function.name = PREFIX ("pack_s");
1993 gfc_resolve_parity (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
1995 resolve_transformational ("parity", f, array, dim, NULL);
2000 gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
2003 resolve_transformational ("product", f, array, dim, mask);
2008 gfc_resolve_real (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
2010 f->ts.type = BT_REAL;
2013 f->ts.kind = mpz_get_si (kind->value.integer);
2015 f->ts.kind = (a->ts.type == BT_COMPLEX)
2016 ? a->ts.kind : gfc_default_real_kind;
2018 f->value.function.name
2019 = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
2020 gfc_type_letter (a->ts.type), a->ts.kind);
2025 gfc_resolve_realpart (gfc_expr *f, gfc_expr *a)
2027 f->ts.type = BT_REAL;
2028 f->ts.kind = a->ts.kind;
2029 f->value.function.name
2030 = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
2031 gfc_type_letter (a->ts.type), a->ts.kind);
2036 gfc_resolve_rename (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
2037 gfc_expr *p2 ATTRIBUTE_UNUSED)
2039 f->ts.type = BT_INTEGER;
2040 f->ts.kind = gfc_default_integer_kind;
2041 f->value.function.name = gfc_get_string (PREFIX ("rename_i%d"), f->ts.kind);
2046 gfc_resolve_repeat (gfc_expr *f, gfc_expr *string,
2047 gfc_expr *ncopies ATTRIBUTE_UNUSED)
2049 f->ts.type = BT_CHARACTER;
2050 f->ts.kind = string->ts.kind;
2051 f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
2056 gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
2057 gfc_expr *pad ATTRIBUTE_UNUSED,
2058 gfc_expr *order ATTRIBUTE_UNUSED)
2064 if (source->ts.type == BT_CHARACTER && source->ref)
2065 gfc_resolve_substring_charlen (source);
2069 gfc_array_size (shape, &rank);
2070 f->rank = mpz_get_si (rank);
2072 switch (source->ts.type)
2079 kind = source->ts.kind;
2093 if (source->ts.type == BT_COMPLEX || source->ts.type == BT_REAL)
2094 f->value.function.name
2095 = gfc_get_string (PREFIX ("reshape_%c%d"),
2096 gfc_type_letter (source->ts.type),
2098 else if (source->ts.type == BT_CHARACTER)
2099 f->value.function.name = gfc_get_string (PREFIX ("reshape_char%d"),
2102 f->value.function.name
2103 = gfc_get_string (PREFIX ("reshape_%d"), source->ts.kind);
2107 f->value.function.name = (source->ts.type == BT_CHARACTER
2108 ? PREFIX ("reshape_char") : PREFIX ("reshape"));
2112 /* TODO: Make this work with a constant ORDER parameter. */
2113 if (shape->expr_type == EXPR_ARRAY
2114 && gfc_is_constant_expr (shape)
2118 f->shape = gfc_get_shape (f->rank);
2119 c = gfc_constructor_first (shape->value.constructor);
2120 for (i = 0; i < f->rank; i++)
2122 mpz_init_set (f->shape[i], c->expr->value.integer);
2123 c = gfc_constructor_next (c);
2127 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
2128 so many runtime variations. */
2129 if (shape->ts.kind != gfc_index_integer_kind)
2131 gfc_typespec ts = shape->ts;
2132 ts.kind = gfc_index_integer_kind;
2133 gfc_convert_type_warn (shape, &ts, 2, 0);
2135 if (order && order->ts.kind != gfc_index_integer_kind)
2136 gfc_convert_type_warn (order, &shape->ts, 2, 0);
2141 gfc_resolve_rrspacing (gfc_expr *f, gfc_expr *x)
2144 f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
2149 gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i ATTRIBUTE_UNUSED)
2152 f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
2157 gfc_resolve_scan (gfc_expr *f, gfc_expr *string,
2158 gfc_expr *set ATTRIBUTE_UNUSED,
2159 gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
2161 f->ts.type = BT_INTEGER;
2163 f->ts.kind = mpz_get_si (kind->value.integer);
2165 f->ts.kind = gfc_default_integer_kind;
2166 f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
2171 gfc_resolve_secnds (gfc_expr *t1, gfc_expr *t0)
2174 t1->value.function.name = gfc_get_string (PREFIX ("secnds"));
2179 gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x,
2180 gfc_expr *i ATTRIBUTE_UNUSED)
2183 f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
2188 gfc_resolve_shape (gfc_expr *f, gfc_expr *array)
2190 f->ts.type = BT_INTEGER;
2191 f->ts.kind = gfc_default_integer_kind;
2193 f->shape = gfc_get_shape (1);
2194 mpz_init_set_ui (f->shape[0], array->rank);
2195 f->value.function.name = gfc_get_string (PREFIX ("shape_%d"), f->ts.kind);
2200 gfc_resolve_shift (gfc_expr *f, gfc_expr *i, gfc_expr *shift ATTRIBUTE_UNUSED)
2203 if (f->value.function.isym->id == GFC_ISYM_SHIFTA)
2204 f->value.function.name = gfc_get_string ("shifta_i%d", f->ts.kind);
2205 else if (f->value.function.isym->id == GFC_ISYM_SHIFTL)
2206 f->value.function.name = gfc_get_string ("shiftl_i%d", f->ts.kind);
2207 else if (f->value.function.isym->id == GFC_ISYM_SHIFTR)
2208 f->value.function.name = gfc_get_string ("shiftr_i%d", f->ts.kind);
2215 gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b ATTRIBUTE_UNUSED)
2218 f->value.function.name
2219 = gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
2224 gfc_resolve_signal (gfc_expr *f, gfc_expr *number, gfc_expr *handler)
2226 f->ts.type = BT_INTEGER;
2227 f->ts.kind = gfc_c_int_kind;
2229 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2230 if (handler->ts.type == BT_INTEGER)
2232 if (handler->ts.kind != gfc_c_int_kind)
2233 gfc_convert_type (handler, &f->ts, 2);
2234 f->value.function.name = gfc_get_string (PREFIX ("signal_func_int"));
2237 f->value.function.name = gfc_get_string (PREFIX ("signal_func"));
2239 if (number->ts.kind != gfc_c_int_kind)
2240 gfc_convert_type (number, &f->ts, 2);
2245 gfc_resolve_sin (gfc_expr *f, gfc_expr *x)
2248 f->value.function.name
2249 = gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2254 gfc_resolve_sinh (gfc_expr *f, gfc_expr *x)
2257 f->value.function.name
2258 = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2263 gfc_resolve_size (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2264 gfc_expr *dim ATTRIBUTE_UNUSED, gfc_expr *kind)
2266 f->ts.type = BT_INTEGER;
2268 f->ts.kind = mpz_get_si (kind->value.integer);
2270 f->ts.kind = gfc_default_integer_kind;
2275 gfc_resolve_spacing (gfc_expr *f, gfc_expr *x)
2278 f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
2283 gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim,
2286 if (source->ts.type == BT_CHARACTER && source->ref)
2287 gfc_resolve_substring_charlen (source);
2289 if (source->ts.type == BT_CHARACTER)
2290 check_charlen_present (source);
2293 f->rank = source->rank + 1;
2294 if (source->rank == 0)
2296 if (source->ts.type == BT_CHARACTER)
2297 f->value.function.name
2298 = source->ts.kind == 1 ? PREFIX ("spread_char_scalar")
2300 (PREFIX ("spread_char%d_scalar"),
2303 f->value.function.name = PREFIX ("spread_scalar");
2307 if (source->ts.type == BT_CHARACTER)
2308 f->value.function.name
2309 = source->ts.kind == 1 ? PREFIX ("spread_char")
2311 (PREFIX ("spread_char%d"),
2314 f->value.function.name = PREFIX ("spread");
2317 if (dim && gfc_is_constant_expr (dim)
2318 && ncopies && gfc_is_constant_expr (ncopies) && source->shape[0])
2321 idim = mpz_get_ui (dim->value.integer);
2322 f->shape = gfc_get_shape (f->rank);
2323 for (i = 0; i < (idim - 1); i++)
2324 mpz_init_set (f->shape[i], source->shape[i]);
2326 mpz_init_set (f->shape[idim - 1], ncopies->value.integer);
2328 for (i = idim; i < f->rank ; i++)
2329 mpz_init_set (f->shape[i], source->shape[i-1]);
2333 gfc_resolve_dim_arg (dim);
2334 gfc_resolve_index (ncopies, 1);
2339 gfc_resolve_sqrt (gfc_expr *f, gfc_expr *x)
2342 f->value.function.name
2343 = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2347 /* Resolve the g77 compatibility function STAT AND FSTAT. */
2350 gfc_resolve_stat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2351 gfc_expr *a ATTRIBUTE_UNUSED)
2353 f->ts.type = BT_INTEGER;
2354 f->ts.kind = gfc_default_integer_kind;
2355 f->value.function.name = gfc_get_string (PREFIX ("stat_i%d"), f->ts.kind);
2360 gfc_resolve_lstat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2361 gfc_expr *a ATTRIBUTE_UNUSED)
2363 f->ts.type = BT_INTEGER;
2364 f->ts.kind = gfc_default_integer_kind;
2365 f->value.function.name = gfc_get_string (PREFIX ("lstat_i%d"), f->ts.kind);
2370 gfc_resolve_fstat (gfc_expr *f, gfc_expr *n, gfc_expr *a ATTRIBUTE_UNUSED)
2372 f->ts.type = BT_INTEGER;
2373 f->ts.kind = gfc_default_integer_kind;
2374 if (n->ts.kind != f->ts.kind)
2375 gfc_convert_type (n, &f->ts, 2);
2377 f->value.function.name = gfc_get_string (PREFIX ("fstat_i%d"), f->ts.kind);
2382 gfc_resolve_fgetc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2387 f->ts.type = BT_INTEGER;
2388 f->ts.kind = gfc_c_int_kind;
2389 if (u->ts.kind != gfc_c_int_kind)
2391 ts.type = BT_INTEGER;
2392 ts.kind = gfc_c_int_kind;
2393 ts.u.derived = NULL;
2395 gfc_convert_type (u, &ts, 2);
2398 f->value.function.name = gfc_get_string (PREFIX ("fgetc"));
2403 gfc_resolve_fget (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2405 f->ts.type = BT_INTEGER;
2406 f->ts.kind = gfc_c_int_kind;
2407 f->value.function.name = gfc_get_string (PREFIX ("fget"));
2412 gfc_resolve_fputc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2417 f->ts.type = BT_INTEGER;
2418 f->ts.kind = gfc_c_int_kind;
2419 if (u->ts.kind != gfc_c_int_kind)
2421 ts.type = BT_INTEGER;
2422 ts.kind = gfc_c_int_kind;
2423 ts.u.derived = NULL;
2425 gfc_convert_type (u, &ts, 2);
2428 f->value.function.name = gfc_get_string (PREFIX ("fputc"));
2433 gfc_resolve_fput (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2435 f->ts.type = BT_INTEGER;
2436 f->ts.kind = gfc_c_int_kind;
2437 f->value.function.name = gfc_get_string (PREFIX ("fput"));
2442 gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
2447 f->ts.type = BT_INTEGER;
2448 f->ts.kind = gfc_index_integer_kind;
2449 if (u->ts.kind != gfc_c_int_kind)
2451 ts.type = BT_INTEGER;
2452 ts.kind = gfc_c_int_kind;
2453 ts.u.derived = NULL;
2455 gfc_convert_type (u, &ts, 2);
2458 f->value.function.name = gfc_get_string (PREFIX ("ftell"));
2463 gfc_resolve_storage_size (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
2466 f->ts.type = BT_INTEGER;
2468 f->ts.kind = mpz_get_si (kind->value.integer);
2470 f->ts.kind = gfc_default_integer_kind;
2475 gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
2477 resolve_transformational ("sum", f, array, dim, mask);
2482 gfc_resolve_symlnk (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
2483 gfc_expr *p2 ATTRIBUTE_UNUSED)
2485 f->ts.type = BT_INTEGER;
2486 f->ts.kind = gfc_default_integer_kind;
2487 f->value.function.name = gfc_get_string (PREFIX ("symlnk_i%d"), f->ts.kind);
2491 /* Resolve the g77 compatibility function SYSTEM. */
2494 gfc_resolve_system (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
2496 f->ts.type = BT_INTEGER;
2498 f->value.function.name = gfc_get_string (PREFIX ("system"));
2503 gfc_resolve_tan (gfc_expr *f, gfc_expr *x)
2506 f->value.function.name
2507 = gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2512 gfc_resolve_tanh (gfc_expr *f, gfc_expr *x)
2515 f->value.function.name
2516 = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2521 gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2522 gfc_expr *sub ATTRIBUTE_UNUSED)
2524 static char this_image[] = "__image_index";
2525 f->ts.kind = gfc_default_integer_kind;
2526 f->value.function.name = this_image;
2531 gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
2533 resolve_bound (f, array, dim, NULL, "__this_image", true);
2538 gfc_resolve_time (gfc_expr *f)
2540 f->ts.type = BT_INTEGER;
2542 f->value.function.name = gfc_get_string (PREFIX ("time_func"));
2547 gfc_resolve_time8 (gfc_expr *f)
2549 f->ts.type = BT_INTEGER;
2551 f->value.function.name = gfc_get_string (PREFIX ("time8_func"));
2556 gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
2557 gfc_expr *mold, gfc_expr *size)
2559 /* TODO: Make this do something meaningful. */
2560 static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
2562 if (mold->ts.type == BT_CHARACTER
2563 && !mold->ts.u.cl->length
2564 && gfc_is_constant_expr (mold))
2567 if (mold->expr_type == EXPR_CONSTANT)
2569 len = mold->value.character.length;
2570 mold->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
2575 gfc_constructor *c = gfc_constructor_first (mold->value.constructor);
2576 len = c->expr->value.character.length;
2577 mold->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
2584 if (size == NULL && mold->rank == 0)
2587 f->value.function.name = transfer0;
2592 f->value.function.name = transfer1;
2593 if (size && gfc_is_constant_expr (size))
2595 f->shape = gfc_get_shape (1);
2596 mpz_init_set (f->shape[0], size->value.integer);
2603 gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
2606 if (matrix->ts.type == BT_CHARACTER && matrix->ref)
2607 gfc_resolve_substring_charlen (matrix);
2613 f->shape = gfc_get_shape (2);
2614 mpz_init_set (f->shape[0], matrix->shape[1]);
2615 mpz_init_set (f->shape[1], matrix->shape[0]);
2618 switch (matrix->ts.kind)
2624 switch (matrix->ts.type)
2628 f->value.function.name
2629 = gfc_get_string (PREFIX ("transpose_%c%d"),
2630 gfc_type_letter (matrix->ts.type),
2636 /* Use the integer routines for real and logical cases. This
2637 assumes they all have the same alignment requirements. */
2638 f->value.function.name
2639 = gfc_get_string (PREFIX ("transpose_i%d"), matrix->ts.kind);
2643 if (matrix->ts.type == BT_CHARACTER && matrix->ts.kind == 4)
2644 f->value.function.name = PREFIX ("transpose_char4");
2646 f->value.function.name = PREFIX ("transpose");
2652 f->value.function.name = (matrix->ts.type == BT_CHARACTER
2653 ? PREFIX ("transpose_char")
2654 : PREFIX ("transpose"));
2661 gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
2663 f->ts.type = BT_CHARACTER;
2664 f->ts.kind = string->ts.kind;
2665 f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
2670 gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2672 resolve_bound (f, array, dim, kind, "__ubound", false);
2677 gfc_resolve_ucobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2679 resolve_bound (f, array, dim, kind, "__ucobound", true);
2683 /* Resolve the g77 compatibility function UMASK. */
2686 gfc_resolve_umask (gfc_expr *f, gfc_expr *n)
2688 f->ts.type = BT_INTEGER;
2689 f->ts.kind = n->ts.kind;
2690 f->value.function.name = gfc_get_string (PREFIX ("umask_i%d"), n->ts.kind);
2694 /* Resolve the g77 compatibility function UNLINK. */
2697 gfc_resolve_unlink (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
2699 f->ts.type = BT_INTEGER;
2701 f->value.function.name = gfc_get_string (PREFIX ("unlink"));
2706 gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit)
2711 f->ts.type = BT_CHARACTER;
2712 f->ts.kind = gfc_default_character_kind;
2714 if (unit->ts.kind != gfc_c_int_kind)
2716 ts.type = BT_INTEGER;
2717 ts.kind = gfc_c_int_kind;
2718 ts.u.derived = NULL;
2720 gfc_convert_type (unit, &ts, 2);
2723 f->value.function.name = gfc_get_string (PREFIX ("ttynam"));
2728 gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
2729 gfc_expr *field ATTRIBUTE_UNUSED)
2731 if (vector->ts.type == BT_CHARACTER && vector->ref)
2732 gfc_resolve_substring_charlen (vector);
2735 f->rank = mask->rank;
2736 resolve_mask_arg (mask);
2738 if (vector->ts.type == BT_CHARACTER)
2740 if (vector->ts.kind == 1)
2741 f->value.function.name
2742 = gfc_get_string (PREFIX ("unpack%d_char"), field->rank > 0 ? 1 : 0);
2744 f->value.function.name
2745 = gfc_get_string (PREFIX ("unpack%d_char%d"),
2746 field->rank > 0 ? 1 : 0, vector->ts.kind);
2749 f->value.function.name
2750 = gfc_get_string (PREFIX ("unpack%d"), field->rank > 0 ? 1 : 0);
2755 gfc_resolve_verify (gfc_expr *f, gfc_expr *string,
2756 gfc_expr *set ATTRIBUTE_UNUSED,
2757 gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
2759 f->ts.type = BT_INTEGER;
2761 f->ts.kind = mpz_get_si (kind->value.integer);
2763 f->ts.kind = gfc_default_integer_kind;
2764 f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
2769 gfc_resolve_xor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
2771 f->ts.type = i->ts.type;
2772 f->ts.kind = gfc_kind_max (i, j);
2774 if (i->ts.kind != j->ts.kind)
2776 if (i->ts.kind == gfc_kind_max (i, j))
2777 gfc_convert_type (j, &i->ts, 2);
2779 gfc_convert_type (i, &j->ts, 2);
2782 f->value.function.name
2783 = gfc_get_string ("__xor_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
2787 /* Intrinsic subroutine resolution. */
2790 gfc_resolve_alarm_sub (gfc_code *c)
2793 gfc_expr *seconds, *handler;
2797 seconds = c->ext.actual->expr;
2798 handler = c->ext.actual->next->expr;
2799 ts.type = BT_INTEGER;
2800 ts.kind = gfc_c_int_kind;
2802 /* handler can be either BT_INTEGER or BT_PROCEDURE.
2803 In all cases, the status argument is of default integer kind
2804 (enforced in check.c) so that the function suffix is fixed. */
2805 if (handler->ts.type == BT_INTEGER)
2807 if (handler->ts.kind != gfc_c_int_kind)
2808 gfc_convert_type (handler, &ts, 2);
2809 name = gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
2810 gfc_default_integer_kind);
2813 name = gfc_get_string (PREFIX ("alarm_sub_i%d"),
2814 gfc_default_integer_kind);
2816 if (seconds->ts.kind != gfc_c_int_kind)
2817 gfc_convert_type (seconds, &ts, 2);
2819 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2823 gfc_resolve_cpu_time (gfc_code *c)
2826 name = gfc_get_string (PREFIX ("cpu_time_%d"), c->ext.actual->expr->ts.kind);
2827 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2831 /* Create a formal arglist based on an actual one and set the INTENTs given. */
2833 static gfc_formal_arglist*
2834 create_formal_for_intents (gfc_actual_arglist* actual, const sym_intent* ints)
2836 gfc_formal_arglist* head;
2837 gfc_formal_arglist* tail;
2843 head = tail = gfc_get_formal_arglist ();
2844 for (i = 0; actual; actual = actual->next, tail = tail->next, ++i)
2848 sym = gfc_new_symbol ("dummyarg", NULL);
2849 sym->ts = actual->expr->ts;
2851 sym->attr.intent = ints[i];
2855 tail->next = gfc_get_formal_arglist ();
2863 gfc_resolve_mvbits (gfc_code *c)
2865 static const sym_intent INTENTS[] = {INTENT_IN, INTENT_IN, INTENT_IN,
2866 INTENT_INOUT, INTENT_IN};
2872 /* FROMPOS, LEN and TOPOS are restricted to small values. As such,
2873 they will be converted so that they fit into a C int. */
2874 ts.type = BT_INTEGER;
2875 ts.kind = gfc_c_int_kind;
2876 if (c->ext.actual->next->expr->ts.kind != gfc_c_int_kind)
2877 gfc_convert_type (c->ext.actual->next->expr, &ts, 2);
2878 if (c->ext.actual->next->next->expr->ts.kind != gfc_c_int_kind)
2879 gfc_convert_type (c->ext.actual->next->next->expr, &ts, 2);
2880 if (c->ext.actual->next->next->next->next->expr->ts.kind != gfc_c_int_kind)
2881 gfc_convert_type (c->ext.actual->next->next->next->next->expr, &ts, 2);
2883 /* TO and FROM are guaranteed to have the same kind parameter. */
2884 name = gfc_get_string (PREFIX ("mvbits_i%d"),
2885 c->ext.actual->expr->ts.kind);
2886 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2887 /* Mark as elemental subroutine as this does not happen automatically. */
2888 c->resolved_sym->attr.elemental = 1;
2890 /* Create a dummy formal arglist so the INTENTs are known later for purpose
2891 of creating temporaries. */
2892 c->resolved_sym->formal = create_formal_for_intents (c->ext.actual, INTENTS);
2897 gfc_resolve_random_number (gfc_code *c)
2902 kind = c->ext.actual->expr->ts.kind;
2903 if (c->ext.actual->expr->rank == 0)
2904 name = gfc_get_string (PREFIX ("random_r%d"), kind);
2906 name = gfc_get_string (PREFIX ("arandom_r%d"), kind);
2908 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2913 gfc_resolve_random_seed (gfc_code *c)
2917 name = gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind);
2918 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2923 gfc_resolve_rename_sub (gfc_code *c)
2928 if (c->ext.actual->next->next->expr != NULL)
2929 kind = c->ext.actual->next->next->expr->ts.kind;
2931 kind = gfc_default_integer_kind;
2933 name = gfc_get_string (PREFIX ("rename_i%d_sub"), kind);
2934 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2939 gfc_resolve_kill_sub (gfc_code *c)
2944 if (c->ext.actual->next->next->expr != NULL)
2945 kind = c->ext.actual->next->next->expr->ts.kind;
2947 kind = gfc_default_integer_kind;
2949 name = gfc_get_string (PREFIX ("kill_i%d_sub"), kind);
2950 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2955 gfc_resolve_link_sub (gfc_code *c)
2960 if (c->ext.actual->next->next->expr != NULL)
2961 kind = c->ext.actual->next->next->expr->ts.kind;
2963 kind = gfc_default_integer_kind;
2965 name = gfc_get_string (PREFIX ("link_i%d_sub"), kind);
2966 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2971 gfc_resolve_symlnk_sub (gfc_code *c)
2976 if (c->ext.actual->next->next->expr != NULL)
2977 kind = c->ext.actual->next->next->expr->ts.kind;
2979 kind = gfc_default_integer_kind;
2981 name = gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind);
2982 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2986 /* G77 compatibility subroutines dtime() and etime(). */
2989 gfc_resolve_dtime_sub (gfc_code *c)
2992 name = gfc_get_string (PREFIX ("dtime_sub"));
2993 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2997 gfc_resolve_etime_sub (gfc_code *c)
3000 name = gfc_get_string (PREFIX ("etime_sub"));
3001 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3005 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
3008 gfc_resolve_itime (gfc_code *c)
3011 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
3012 gfc_default_integer_kind));
3016 gfc_resolve_idate (gfc_code *c)
3019 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
3020 gfc_default_integer_kind));
3024 gfc_resolve_ltime (gfc_code *c)
3027 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
3028 gfc_default_integer_kind));
3032 gfc_resolve_gmtime (gfc_code *c)
3035 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
3036 gfc_default_integer_kind));
3040 /* G77 compatibility subroutine second(). */
3043 gfc_resolve_second_sub (gfc_code *c)
3046 name = gfc_get_string (PREFIX ("second_sub"));
3047 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3052 gfc_resolve_sleep_sub (gfc_code *c)
3057 if (c->ext.actual->expr != NULL)
3058 kind = c->ext.actual->expr->ts.kind;
3060 kind = gfc_default_integer_kind;
3062 name = gfc_get_string (PREFIX ("sleep_i%d_sub"), kind);
3063 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3067 /* G77 compatibility function srand(). */
3070 gfc_resolve_srand (gfc_code *c)
3073 name = gfc_get_string (PREFIX ("srand"));
3074 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3078 /* Resolve the getarg intrinsic subroutine. */
3081 gfc_resolve_getarg (gfc_code *c)
3085 if (c->ext.actual->expr->ts.kind != gfc_default_integer_kind)
3090 ts.type = BT_INTEGER;
3091 ts.kind = gfc_default_integer_kind;
3093 gfc_convert_type (c->ext.actual->expr, &ts, 2);
3096 name = gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind);
3097 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3101 /* Resolve the getcwd intrinsic subroutine. */
3104 gfc_resolve_getcwd_sub (gfc_code *c)
3109 if (c->ext.actual->next->expr != NULL)
3110 kind = c->ext.actual->next->expr->ts.kind;
3112 kind = gfc_default_integer_kind;
3114 name = gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind);
3115 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3119 /* Resolve the get_command intrinsic subroutine. */
3122 gfc_resolve_get_command (gfc_code *c)
3126 kind = gfc_default_integer_kind;
3127 name = gfc_get_string (PREFIX ("get_command_i%d"), kind);
3128 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3132 /* Resolve the get_command_argument intrinsic subroutine. */
3135 gfc_resolve_get_command_argument (gfc_code *c)
3139 kind = gfc_default_integer_kind;
3140 name = gfc_get_string (PREFIX ("get_command_argument_i%d"), kind);
3141 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3145 /* Resolve the get_environment_variable intrinsic subroutine. */
3148 gfc_resolve_get_environment_variable (gfc_code *code)
3152 kind = gfc_default_integer_kind;
3153 name = gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind);
3154 code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3159 gfc_resolve_signal_sub (gfc_code *c)
3162 gfc_expr *number, *handler, *status;
3166 number = c->ext.actual->expr;
3167 handler = c->ext.actual->next->expr;
3168 status = c->ext.actual->next->next->expr;
3169 ts.type = BT_INTEGER;
3170 ts.kind = gfc_c_int_kind;
3172 /* handler can be either BT_INTEGER or BT_PROCEDURE */
3173 if (handler->ts.type == BT_INTEGER)
3175 if (handler->ts.kind != gfc_c_int_kind)
3176 gfc_convert_type (handler, &ts, 2);
3177 name = gfc_get_string (PREFIX ("signal_sub_int"));
3180 name = gfc_get_string (PREFIX ("signal_sub"));
3182 if (number->ts.kind != gfc_c_int_kind)
3183 gfc_convert_type (number, &ts, 2);
3184 if (status != NULL && status->ts.kind != gfc_c_int_kind)
3185 gfc_convert_type (status, &ts, 2);
3187 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3191 /* Resolve the SYSTEM intrinsic subroutine. */
3194 gfc_resolve_system_sub (gfc_code *c)
3197 name = gfc_get_string (PREFIX ("system_sub"));
3198 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3202 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
3205 gfc_resolve_system_clock (gfc_code *c)
3210 if (c->ext.actual->expr != NULL)
3211 kind = c->ext.actual->expr->ts.kind;
3212 else if (c->ext.actual->next->expr != NULL)
3213 kind = c->ext.actual->next->expr->ts.kind;
3214 else if (c->ext.actual->next->next->expr != NULL)
3215 kind = c->ext.actual->next->next->expr->ts.kind;
3217 kind = gfc_default_integer_kind;
3219 name = gfc_get_string (PREFIX ("system_clock_%d"), kind);
3220 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3224 /* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine. */
3226 gfc_resolve_execute_command_line (gfc_code *c)
3229 name = gfc_get_string (PREFIX ("execute_command_line_i%d"),
3230 gfc_default_integer_kind);
3231 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3235 /* Resolve the EXIT intrinsic subroutine. */
3238 gfc_resolve_exit (gfc_code *c)
3245 /* The STATUS argument has to be of default kind. If it is not,
3247 ts.type = BT_INTEGER;
3248 ts.kind = gfc_default_integer_kind;
3249 n = c->ext.actual->expr;
3250 if (n != NULL && n->ts.kind != ts.kind)
3251 gfc_convert_type (n, &ts, 2);
3253 name = gfc_get_string (PREFIX ("exit_i%d"), ts.kind);
3254 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3258 /* Resolve the FLUSH intrinsic subroutine. */
3261 gfc_resolve_flush (gfc_code *c)
3268 ts.type = BT_INTEGER;
3269 ts.kind = gfc_default_integer_kind;
3270 n = c->ext.actual->expr;
3271 if (n != NULL && n->ts.kind != ts.kind)
3272 gfc_convert_type (n, &ts, 2);
3274 name = gfc_get_string (PREFIX ("flush_i%d"), ts.kind);
3275 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3280 gfc_resolve_free (gfc_code *c)
3286 ts.type = BT_INTEGER;
3287 ts.kind = gfc_index_integer_kind;
3288 n = c->ext.actual->expr;
3289 if (n->ts.kind != ts.kind)
3290 gfc_convert_type (n, &ts, 2);
3292 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("free"));
3297 gfc_resolve_ctime_sub (gfc_code *c)
3302 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3303 if (c->ext.actual->expr->ts.kind != 8)
3305 ts.type = BT_INTEGER;
3307 ts.u.derived = NULL;
3309 gfc_convert_type (c->ext.actual->expr, &ts, 2);
3312 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3317 gfc_resolve_fdate_sub (gfc_code *c)
3319 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3324 gfc_resolve_gerror (gfc_code *c)
3326 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3331 gfc_resolve_getlog (gfc_code *c)
3333 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3338 gfc_resolve_hostnm_sub (gfc_code *c)
3343 if (c->ext.actual->next->expr != NULL)
3344 kind = c->ext.actual->next->expr->ts.kind;
3346 kind = gfc_default_integer_kind;
3348 name = gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind);
3349 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3354 gfc_resolve_perror (gfc_code *c)
3356 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3359 /* Resolve the STAT and FSTAT intrinsic subroutines. */
3362 gfc_resolve_stat_sub (gfc_code *c)
3365 name = gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind);
3366 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3371 gfc_resolve_lstat_sub (gfc_code *c)
3374 name = gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind);
3375 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3380 gfc_resolve_fstat_sub (gfc_code *c)
3386 u = c->ext.actual->expr;
3387 ts = &c->ext.actual->next->expr->ts;
3388 if (u->ts.kind != ts->kind)
3389 gfc_convert_type (u, ts, 2);
3390 name = gfc_get_string (PREFIX ("fstat_i%d_sub"), ts->kind);
3391 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3396 gfc_resolve_fgetc_sub (gfc_code *c)
3403 u = c->ext.actual->expr;
3404 st = c->ext.actual->next->next->expr;
3406 if (u->ts.kind != gfc_c_int_kind)
3408 ts.type = BT_INTEGER;
3409 ts.kind = gfc_c_int_kind;
3410 ts.u.derived = NULL;
3412 gfc_convert_type (u, &ts, 2);
3416 name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), st->ts.kind);
3418 name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind);
3420 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3425 gfc_resolve_fget_sub (gfc_code *c)
3430 st = c->ext.actual->next->expr;
3432 name = gfc_get_string (PREFIX ("fget_i%d_sub"), st->ts.kind);
3434 name = gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind);
3436 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3441 gfc_resolve_fputc_sub (gfc_code *c)
3448 u = c->ext.actual->expr;
3449 st = c->ext.actual->next->next->expr;
3451 if (u->ts.kind != gfc_c_int_kind)
3453 ts.type = BT_INTEGER;
3454 ts.kind = gfc_c_int_kind;
3455 ts.u.derived = NULL;
3457 gfc_convert_type (u, &ts, 2);
3461 name = gfc_get_string (PREFIX ("fputc_i%d_sub"), st->ts.kind);
3463 name = gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind);
3465 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3470 gfc_resolve_fput_sub (gfc_code *c)
3475 st = c->ext.actual->next->expr;
3477 name = gfc_get_string (PREFIX ("fput_i%d_sub"), st->ts.kind);
3479 name = gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind);
3481 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3486 gfc_resolve_fseek_sub (gfc_code *c)
3494 unit = c->ext.actual->expr;
3495 offset = c->ext.actual->next->expr;
3496 whence = c->ext.actual->next->next->expr;
3498 if (unit->ts.kind != gfc_c_int_kind)
3500 ts.type = BT_INTEGER;
3501 ts.kind = gfc_c_int_kind;
3502 ts.u.derived = NULL;
3504 gfc_convert_type (unit, &ts, 2);
3507 if (offset->ts.kind != gfc_intio_kind)
3509 ts.type = BT_INTEGER;
3510 ts.kind = gfc_intio_kind;
3511 ts.u.derived = NULL;
3513 gfc_convert_type (offset, &ts, 2);
3516 if (whence->ts.kind != gfc_c_int_kind)
3518 ts.type = BT_INTEGER;
3519 ts.kind = gfc_c_int_kind;
3520 ts.u.derived = NULL;
3522 gfc_convert_type (whence, &ts, 2);
3525 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
3529 gfc_resolve_ftell_sub (gfc_code *c)
3537 unit = c->ext.actual->expr;
3538 offset = c->ext.actual->next->expr;
3540 if (unit->ts.kind != gfc_c_int_kind)
3542 ts.type = BT_INTEGER;
3543 ts.kind = gfc_c_int_kind;
3544 ts.u.derived = NULL;
3546 gfc_convert_type (unit, &ts, 2);
3549 name = gfc_get_string (PREFIX ("ftell_i%d_sub"), offset->ts.kind);
3550 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3555 gfc_resolve_ttynam_sub (gfc_code *c)
3560 if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
3562 ts.type = BT_INTEGER;
3563 ts.kind = gfc_c_int_kind;
3564 ts.u.derived = NULL;
3566 gfc_convert_type (c->ext.actual->expr, &ts, 2);
3569 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
3573 /* Resolve the UMASK intrinsic subroutine. */
3576 gfc_resolve_umask_sub (gfc_code *c)
3581 if (c->ext.actual->next->expr != NULL)
3582 kind = c->ext.actual->next->expr->ts.kind;
3584 kind = gfc_default_integer_kind;
3586 name = gfc_get_string (PREFIX ("umask_i%d_sub"), kind);
3587 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3590 /* Resolve the UNLINK intrinsic subroutine. */
3593 gfc_resolve_unlink_sub (gfc_code *c)
3598 if (c->ext.actual->next->expr != NULL)
3599 kind = c->ext.actual->next->expr->ts.kind;
3601 kind = gfc_default_integer_kind;
3603 name = gfc_get_string (PREFIX ("unlink_i%d_sub"), kind);
3604 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);