1 /* Intrinsic function resolution.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught & Katherine Holcomb
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
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"
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->expr_type == EXPR_CONSTANT && source->ts.cl == NULL)
69 source->ts.cl = gfc_get_charlen ();
70 source->ts.cl->next = gfc_current_ns->cl_list;
71 gfc_current_ns->cl_list = source->ts.cl;
72 source->ts.cl->length = gfc_int_expr (source->value.character.length);
77 /********************** Resolution functions **********************/
81 gfc_resolve_abs (gfc_expr * f, gfc_expr * a)
84 if (f->ts.type == BT_COMPLEX)
87 f->value.function.name =
88 gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
93 gfc_resolve_acos (gfc_expr * f, gfc_expr * x)
96 f->value.function.name =
97 gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
102 gfc_resolve_acosh (gfc_expr * f, gfc_expr * x)
105 f->value.function.name =
106 gfc_get_string ("__acosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
111 gfc_resolve_aimag (gfc_expr * f, gfc_expr * x)
113 f->ts.type = BT_REAL;
114 f->ts.kind = x->ts.kind;
115 f->value.function.name =
116 gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
121 gfc_resolve_and (gfc_expr * f, gfc_expr * i, gfc_expr * j)
123 f->ts.type = i->ts.type;
124 f->ts.kind = gfc_kind_max (i,j);
126 if (i->ts.kind != j->ts.kind)
128 if (i->ts.kind == gfc_kind_max (i,j))
129 gfc_convert_type(j, &i->ts, 2);
131 gfc_convert_type(i, &j->ts, 2);
134 f->value.function.name = gfc_get_string ("__and_%c%d",
135 gfc_type_letter (i->ts.type),
141 gfc_resolve_aint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
145 f->ts.type = a->ts.type;
146 f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
148 if (a->ts.kind != f->ts.kind)
150 ts.type = f->ts.type;
151 ts.kind = f->ts.kind;
152 gfc_convert_type (a, &ts, 2);
154 /* The resolved name is only used for specific intrinsics where
155 the return kind is the same as the arg kind. */
156 f->value.function.name =
157 gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
162 gfc_resolve_dint (gfc_expr * f, gfc_expr * a)
164 gfc_resolve_aint (f, a, NULL);
169 gfc_resolve_all (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
175 gfc_resolve_dim_arg (dim);
176 f->rank = mask->rank - 1;
177 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
180 f->value.function.name =
181 gfc_get_string (PREFIX("all_%c%d"), gfc_type_letter (mask->ts.type),
187 gfc_resolve_anint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
191 f->ts.type = a->ts.type;
192 f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
194 if (a->ts.kind != f->ts.kind)
196 ts.type = f->ts.type;
197 ts.kind = f->ts.kind;
198 gfc_convert_type (a, &ts, 2);
201 /* The resolved name is only used for specific intrinsics where
202 the return kind is the same as the arg kind. */
203 f->value.function.name =
204 gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
209 gfc_resolve_dnint (gfc_expr * f, gfc_expr * a)
211 gfc_resolve_anint (f, a, NULL);
216 gfc_resolve_any (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
222 gfc_resolve_dim_arg (dim);
223 f->rank = mask->rank - 1;
224 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
227 f->value.function.name =
228 gfc_get_string (PREFIX("any_%c%d"), gfc_type_letter (mask->ts.type),
234 gfc_resolve_asin (gfc_expr * f, gfc_expr * x)
237 f->value.function.name =
238 gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
242 gfc_resolve_asinh (gfc_expr * f, gfc_expr * x)
245 f->value.function.name =
246 gfc_get_string ("__asinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
250 gfc_resolve_atan (gfc_expr * f, gfc_expr * x)
253 f->value.function.name =
254 gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
258 gfc_resolve_atanh (gfc_expr * f, gfc_expr * x)
261 f->value.function.name =
262 gfc_get_string ("__atanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
266 gfc_resolve_atan2 (gfc_expr * f, gfc_expr * x,
267 gfc_expr * y ATTRIBUTE_UNUSED)
270 f->value.function.name =
271 gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
275 /* Resolve the BESYN and BESJN intrinsics. */
278 gfc_resolve_besn (gfc_expr * f, gfc_expr * n, gfc_expr * x)
283 if (n->ts.kind != gfc_c_int_kind)
285 ts.type = BT_INTEGER;
286 ts.kind = gfc_c_int_kind;
287 gfc_convert_type (n, &ts, 2);
289 f->value.function.name = gfc_get_string ("<intrinsic>");
294 gfc_resolve_btest (gfc_expr * f, gfc_expr * i, gfc_expr * pos)
296 f->ts.type = BT_LOGICAL;
297 f->ts.kind = gfc_default_logical_kind;
299 f->value.function.name = gfc_get_string ("__btest_%d_%d", i->ts.kind,
305 gfc_resolve_ceiling (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
307 f->ts.type = BT_INTEGER;
308 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
309 : mpz_get_si (kind->value.integer);
311 f->value.function.name =
312 gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind,
313 gfc_type_letter (a->ts.type), a->ts.kind);
318 gfc_resolve_char (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
320 f->ts.type = BT_CHARACTER;
321 f->ts.kind = (kind == NULL) ? gfc_default_character_kind
322 : mpz_get_si (kind->value.integer);
324 f->value.function.name =
325 gfc_get_string ("__char_%d_%c%d", f->ts.kind,
326 gfc_type_letter (a->ts.type), a->ts.kind);
331 gfc_resolve_chdir (gfc_expr * f, gfc_expr * d ATTRIBUTE_UNUSED)
333 f->ts.type = BT_INTEGER;
334 f->ts.kind = gfc_default_integer_kind;
335 f->value.function.name = gfc_get_string (PREFIX("chdir_i%d"), f->ts.kind);
340 gfc_resolve_chdir_sub (gfc_code * c)
345 if (c->ext.actual->next->expr != NULL)
346 kind = c->ext.actual->next->expr->ts.kind;
348 kind = gfc_default_integer_kind;
350 name = gfc_get_string (PREFIX("chdir_i%d_sub"), kind);
351 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
356 gfc_resolve_cmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y, gfc_expr * kind)
358 f->ts.type = BT_COMPLEX;
359 f->ts.kind = (kind == NULL) ? gfc_default_real_kind
360 : mpz_get_si (kind->value.integer);
363 f->value.function.name =
364 gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind,
365 gfc_type_letter (x->ts.type), x->ts.kind);
367 f->value.function.name =
368 gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
369 gfc_type_letter (x->ts.type), x->ts.kind,
370 gfc_type_letter (y->ts.type), y->ts.kind);
374 gfc_resolve_dcmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y)
376 gfc_resolve_cmplx (f, x, y, gfc_int_expr (gfc_default_double_kind));
380 gfc_resolve_complex (gfc_expr * f, gfc_expr * x, gfc_expr * y)
384 if (x->ts.type == BT_INTEGER)
386 if (y->ts.type == BT_INTEGER)
387 kind = gfc_default_real_kind;
393 if (y->ts.type == BT_REAL)
394 kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
399 f->ts.type = BT_COMPLEX;
402 f->value.function.name =
403 gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
404 gfc_type_letter (x->ts.type), x->ts.kind,
405 gfc_type_letter (y->ts.type), y->ts.kind);
410 gfc_resolve_conjg (gfc_expr * f, gfc_expr * x)
413 f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind);
418 gfc_resolve_cos (gfc_expr * f, gfc_expr * x)
421 f->value.function.name =
422 gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
427 gfc_resolve_cosh (gfc_expr * f, gfc_expr * x)
430 f->value.function.name =
431 gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
436 gfc_resolve_count (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
438 f->ts.type = BT_INTEGER;
439 f->ts.kind = gfc_default_integer_kind;
443 f->rank = mask->rank - 1;
444 gfc_resolve_dim_arg (dim);
445 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
448 f->value.function.name =
449 gfc_get_string (PREFIX("count_%d_%c%d"), f->ts.kind,
450 gfc_type_letter (mask->ts.type), mask->ts.kind);
455 gfc_resolve_cshift (gfc_expr * f, gfc_expr * array,
462 f->rank = array->rank;
463 f->shape = gfc_copy_shape (array->shape, array->rank);
470 /* Convert shift to at least gfc_default_integer_kind, so we don't need
471 kind=1 and kind=2 versions of the library functions. */
472 if (shift->ts.kind < gfc_default_integer_kind)
475 ts.type = BT_INTEGER;
476 ts.kind = gfc_default_integer_kind;
477 gfc_convert_type_warn (shift, &ts, 2, 0);
482 gfc_resolve_dim_arg (dim);
483 /* Convert dim to shift's kind, so we don't need so many variations. */
484 if (dim->ts.kind != shift->ts.kind)
485 gfc_convert_type_warn (dim, &shift->ts, 2, 0);
487 f->value.function.name =
488 gfc_get_string (PREFIX("cshift%d_%d%s"), n, shift->ts.kind,
489 array->ts.type == BT_CHARACTER ? "_char" : "");
494 gfc_resolve_ctime (gfc_expr * f, gfc_expr * time)
498 f->ts.type = BT_CHARACTER;
499 f->ts.kind = gfc_default_character_kind;
501 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
502 if (time->ts.kind != 8)
504 ts.type = BT_INTEGER;
508 gfc_convert_type (time, &ts, 2);
511 f->value.function.name = gfc_get_string (PREFIX("ctime"));
516 gfc_resolve_dble (gfc_expr * f, gfc_expr * a)
518 f->ts.type = BT_REAL;
519 f->ts.kind = gfc_default_double_kind;
520 f->value.function.name =
521 gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
526 gfc_resolve_dim (gfc_expr * f, gfc_expr * a, gfc_expr * p)
528 f->ts.type = a->ts.type;
530 f->ts.kind = gfc_kind_max (a,p);
532 f->ts.kind = a->ts.kind;
534 if (p != NULL && a->ts.kind != p->ts.kind)
536 if (a->ts.kind == gfc_kind_max (a,p))
537 gfc_convert_type(p, &a->ts, 2);
539 gfc_convert_type(a, &p->ts, 2);
542 f->value.function.name =
543 gfc_get_string ("__dim_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
548 gfc_resolve_dot_product (gfc_expr * f, gfc_expr * a, gfc_expr * b)
552 temp.expr_type = EXPR_OP;
553 gfc_clear_ts (&temp.ts);
554 temp.value.op.operator = INTRINSIC_NONE;
555 temp.value.op.op1 = a;
556 temp.value.op.op2 = b;
557 gfc_type_convert_binary (&temp);
560 f->value.function.name =
561 gfc_get_string (PREFIX("dot_product_%c%d"), gfc_type_letter (f->ts.type),
567 gfc_resolve_dprod (gfc_expr * f,
568 gfc_expr * a ATTRIBUTE_UNUSED,
569 gfc_expr * b ATTRIBUTE_UNUSED)
571 f->ts.kind = gfc_default_double_kind;
572 f->ts.type = BT_REAL;
574 f->value.function.name = gfc_get_string ("__dprod_r%d", f->ts.kind);
579 gfc_resolve_eoshift (gfc_expr * f, gfc_expr * array,
587 f->rank = array->rank;
588 f->shape = gfc_copy_shape (array->shape, array->rank);
593 if (boundary && boundary->rank > 0)
596 /* Convert shift to at least gfc_default_integer_kind, so we don't need
597 kind=1 and kind=2 versions of the library functions. */
598 if (shift->ts.kind < gfc_default_integer_kind)
601 ts.type = BT_INTEGER;
602 ts.kind = gfc_default_integer_kind;
603 gfc_convert_type_warn (shift, &ts, 2, 0);
608 gfc_resolve_dim_arg (dim);
609 /* Convert dim to shift's kind, so we don't need so many variations. */
610 if (dim->ts.kind != shift->ts.kind)
611 gfc_convert_type_warn (dim, &shift->ts, 2, 0);
614 f->value.function.name =
615 gfc_get_string (PREFIX("eoshift%d_%d%s"), n, shift->ts.kind,
616 array->ts.type == BT_CHARACTER ? "_char" : "");
621 gfc_resolve_exp (gfc_expr * f, gfc_expr * x)
624 f->value.function.name =
625 gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
630 gfc_resolve_exponent (gfc_expr * f, gfc_expr * x)
632 f->ts.type = BT_INTEGER;
633 f->ts.kind = gfc_default_integer_kind;
635 f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind);
640 gfc_resolve_fdate (gfc_expr * f)
642 f->ts.type = BT_CHARACTER;
643 f->ts.kind = gfc_default_character_kind;
644 f->value.function.name = gfc_get_string (PREFIX("fdate"));
649 gfc_resolve_floor (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
651 f->ts.type = BT_INTEGER;
652 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
653 : mpz_get_si (kind->value.integer);
655 f->value.function.name =
656 gfc_get_string ("__floor%d_%c%d", f->ts.kind,
657 gfc_type_letter (a->ts.type), a->ts.kind);
662 gfc_resolve_fnum (gfc_expr * f, gfc_expr * n)
664 f->ts.type = BT_INTEGER;
665 f->ts.kind = gfc_default_integer_kind;
666 if (n->ts.kind != f->ts.kind)
667 gfc_convert_type (n, &f->ts, 2);
668 f->value.function.name = gfc_get_string (PREFIX("fnum_i%d"), f->ts.kind);
673 gfc_resolve_fraction (gfc_expr * f, gfc_expr * x)
676 f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind);
680 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
683 gfc_resolve_g77_math1 (gfc_expr * f, gfc_expr * x)
686 f->value.function.name = gfc_get_string ("<intrinsic>");
691 gfc_resolve_getcwd (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
693 f->ts.type = BT_INTEGER;
695 f->value.function.name = gfc_get_string (PREFIX("getcwd"));
700 gfc_resolve_getgid (gfc_expr * f)
702 f->ts.type = BT_INTEGER;
704 f->value.function.name = gfc_get_string (PREFIX("getgid"));
709 gfc_resolve_getpid (gfc_expr * f)
711 f->ts.type = BT_INTEGER;
713 f->value.function.name = gfc_get_string (PREFIX("getpid"));
718 gfc_resolve_getuid (gfc_expr * f)
720 f->ts.type = BT_INTEGER;
722 f->value.function.name = gfc_get_string (PREFIX("getuid"));
726 gfc_resolve_hostnm (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
728 f->ts.type = BT_INTEGER;
730 f->value.function.name = gfc_get_string (PREFIX ("hostnm"));
734 gfc_resolve_iand (gfc_expr * f, gfc_expr * i, gfc_expr * j)
736 /* If the kind of i and j are different, then g77 cross-promoted the
737 kinds to the largest value. The Fortran 95 standard requires the
739 if (i->ts.kind != j->ts.kind)
741 if (i->ts.kind == gfc_kind_max (i,j))
742 gfc_convert_type(j, &i->ts, 2);
744 gfc_convert_type(i, &j->ts, 2);
748 f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind);
753 gfc_resolve_ibclr (gfc_expr * f, gfc_expr * i, gfc_expr * pos ATTRIBUTE_UNUSED)
756 f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind);
761 gfc_resolve_ibits (gfc_expr * f, gfc_expr * i,
762 gfc_expr * pos ATTRIBUTE_UNUSED,
763 gfc_expr * len ATTRIBUTE_UNUSED)
766 f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind);
771 gfc_resolve_ibset (gfc_expr * f, gfc_expr * i,
772 gfc_expr * pos ATTRIBUTE_UNUSED)
775 f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind);
780 gfc_resolve_ichar (gfc_expr * f, gfc_expr * c)
782 f->ts.type = BT_INTEGER;
783 f->ts.kind = gfc_default_integer_kind;
785 f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
790 gfc_resolve_idnint (gfc_expr * f, gfc_expr * a)
792 gfc_resolve_nint (f, a, NULL);
797 gfc_resolve_ierrno (gfc_expr * f)
799 f->ts.type = BT_INTEGER;
800 f->ts.kind = gfc_default_integer_kind;
801 f->value.function.name = gfc_get_string (PREFIX("ierrno_i%d"), f->ts.kind);
806 gfc_resolve_ieor (gfc_expr * f, gfc_expr * i, gfc_expr * j)
808 /* If the kind of i and j are different, then g77 cross-promoted the
809 kinds to the largest value. The Fortran 95 standard requires the
811 if (i->ts.kind != j->ts.kind)
813 if (i->ts.kind == gfc_kind_max (i,j))
814 gfc_convert_type(j, &i->ts, 2);
816 gfc_convert_type(i, &j->ts, 2);
820 f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind);
825 gfc_resolve_ior (gfc_expr * f, gfc_expr * i, gfc_expr * j)
827 /* If the kind of i and j are different, then g77 cross-promoted the
828 kinds to the largest value. The Fortran 95 standard requires the
830 if (i->ts.kind != j->ts.kind)
832 if (i->ts.kind == gfc_kind_max (i,j))
833 gfc_convert_type(j, &i->ts, 2);
835 gfc_convert_type(i, &j->ts, 2);
839 f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind);
844 gfc_resolve_int (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
846 f->ts.type = BT_INTEGER;
847 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
848 : mpz_get_si (kind->value.integer);
850 f->value.function.name =
851 gfc_get_string ("__int_%d_%c%d", f->ts.kind, gfc_type_letter (a->ts.type),
857 gfc_resolve_isatty (gfc_expr * f, gfc_expr * u)
861 f->ts.type = BT_LOGICAL;
862 f->ts.kind = gfc_default_integer_kind;
863 if (u->ts.kind != gfc_c_int_kind)
865 ts.type = BT_INTEGER;
866 ts.kind = gfc_c_int_kind;
869 gfc_convert_type (u, &ts, 2);
872 f->value.function.name = gfc_get_string (PREFIX("isatty_l%d"), f->ts.kind);
877 gfc_resolve_ishft (gfc_expr * f, gfc_expr * i, gfc_expr * shift)
880 f->value.function.name =
881 gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
886 gfc_resolve_ishftc (gfc_expr * f, gfc_expr * i, gfc_expr * shift,
891 s_kind = (size == NULL) ? gfc_default_integer_kind : shift->ts.kind;
894 f->value.function.name =
895 gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
900 gfc_resolve_kill (gfc_expr * f, ATTRIBUTE_UNUSED gfc_expr * p,
901 ATTRIBUTE_UNUSED gfc_expr * s)
903 f->ts.type = BT_INTEGER;
904 f->ts.kind = gfc_default_integer_kind;
906 f->value.function.name = gfc_get_string (PREFIX("kill_i%d"), f->ts.kind);
911 gfc_resolve_lbound (gfc_expr * f, gfc_expr * array,
914 static char lbound[] = "__lbound";
916 f->ts.type = BT_INTEGER;
917 f->ts.kind = gfc_default_integer_kind;
922 f->shape = gfc_get_shape (1);
923 mpz_init_set_ui (f->shape[0], array->rank);
926 f->value.function.name = lbound;
931 gfc_resolve_len (gfc_expr * f, gfc_expr * string)
933 f->ts.type = BT_INTEGER;
934 f->ts.kind = gfc_default_integer_kind;
935 f->value.function.name = gfc_get_string ("__len_%d", string->ts.kind);
940 gfc_resolve_len_trim (gfc_expr * f, gfc_expr * string)
942 f->ts.type = BT_INTEGER;
943 f->ts.kind = gfc_default_integer_kind;
944 f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
949 gfc_resolve_link (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
950 gfc_expr * p2 ATTRIBUTE_UNUSED)
952 f->ts.type = BT_INTEGER;
953 f->ts.kind = gfc_default_integer_kind;
954 f->value.function.name = gfc_get_string (PREFIX("link_i%d"), f->ts.kind);
959 gfc_resolve_loc (gfc_expr *f, gfc_expr *x)
961 f->ts.type= BT_INTEGER;
962 f->ts.kind = gfc_index_integer_kind;
963 f->value.function.name = gfc_get_string ("__loc_%d", x->ts.kind);
968 gfc_resolve_log (gfc_expr * f, gfc_expr * x)
971 f->value.function.name =
972 gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
977 gfc_resolve_log10 (gfc_expr * f, gfc_expr * x)
980 f->value.function.name =
981 gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
986 gfc_resolve_logical (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
988 f->ts.type = BT_LOGICAL;
989 f->ts.kind = (kind == NULL) ? gfc_default_logical_kind
990 : mpz_get_si (kind->value.integer);
993 f->value.function.name =
994 gfc_get_string ("__logical_%d_%c%d", f->ts.kind,
995 gfc_type_letter (a->ts.type), a->ts.kind);
1000 gfc_resolve_malloc (gfc_expr * f, gfc_expr * size)
1002 if (size->ts.kind < gfc_index_integer_kind)
1006 ts.type = BT_INTEGER;
1007 ts.kind = gfc_index_integer_kind;
1008 gfc_convert_type_warn (size, &ts, 2, 0);
1011 f->ts.type = BT_INTEGER;
1012 f->ts.kind = gfc_index_integer_kind;
1013 f->value.function.name = gfc_get_string (PREFIX("malloc"));
1018 gfc_resolve_matmul (gfc_expr * f, gfc_expr * a, gfc_expr * b)
1022 if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
1024 f->ts.type = BT_LOGICAL;
1025 f->ts.kind = gfc_default_logical_kind;
1029 temp.expr_type = EXPR_OP;
1030 gfc_clear_ts (&temp.ts);
1031 temp.value.op.operator = INTRINSIC_NONE;
1032 temp.value.op.op1 = a;
1033 temp.value.op.op2 = b;
1034 gfc_type_convert_binary (&temp);
1038 f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
1040 f->value.function.name =
1041 gfc_get_string (PREFIX("matmul_%c%d"), gfc_type_letter (f->ts.type),
1047 gfc_resolve_minmax (const char * name, gfc_expr * f, gfc_actual_arglist * args)
1049 gfc_actual_arglist *a;
1051 f->ts.type = args->expr->ts.type;
1052 f->ts.kind = args->expr->ts.kind;
1053 /* Find the largest type kind. */
1054 for (a = args->next; a; a = a->next)
1056 if (a->expr->ts.kind > f->ts.kind)
1057 f->ts.kind = a->expr->ts.kind;
1060 /* Convert all parameters to the required kind. */
1061 for (a = args; a; a = a->next)
1063 if (a->expr->ts.kind != f->ts.kind)
1064 gfc_convert_type (a->expr, &f->ts, 2);
1067 f->value.function.name =
1068 gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind);
1073 gfc_resolve_max (gfc_expr * f, gfc_actual_arglist * args)
1075 gfc_resolve_minmax ("__max_%c%d", f, args);
1080 gfc_resolve_maxloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1085 f->ts.type = BT_INTEGER;
1086 f->ts.kind = gfc_default_integer_kind;
1092 f->rank = array->rank - 1;
1093 gfc_resolve_dim_arg (dim);
1098 if (mask->rank == 0)
1103 /* The mask can be kind 4 or 8 for the array case. For the
1104 scalar case, coerce it to default kind unconditionally. */
1105 if ((mask->ts.kind < gfc_default_logical_kind)
1106 || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
1109 ts.type = BT_LOGICAL;
1110 ts.kind = gfc_default_logical_kind;
1111 gfc_convert_type_warn (mask, &ts, 2, 0);
1117 f->value.function.name =
1118 gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1119 gfc_type_letter (array->ts.type), array->ts.kind);
1124 gfc_resolve_maxval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1133 f->rank = array->rank - 1;
1134 gfc_resolve_dim_arg (dim);
1139 if (mask->rank == 0)
1144 /* The mask can be kind 4 or 8 for the array case. For the
1145 scalar case, coerce it to default kind unconditionally. */
1146 if ((mask->ts.kind < gfc_default_logical_kind)
1147 || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
1150 ts.type = BT_LOGICAL;
1151 ts.kind = gfc_default_logical_kind;
1152 gfc_convert_type_warn (mask, &ts, 2, 0);
1158 f->value.function.name =
1159 gfc_get_string (PREFIX("%s_%c%d"), name,
1160 gfc_type_letter (array->ts.type), array->ts.kind);
1165 gfc_resolve_merge (gfc_expr * f, gfc_expr * tsource,
1166 gfc_expr * fsource ATTRIBUTE_UNUSED,
1167 gfc_expr * mask ATTRIBUTE_UNUSED)
1169 if (tsource->ts.type == BT_CHARACTER)
1170 check_charlen_present (tsource);
1172 f->ts = tsource->ts;
1173 f->value.function.name =
1174 gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
1180 gfc_resolve_min (gfc_expr * f, gfc_actual_arglist * args)
1182 gfc_resolve_minmax ("__min_%c%d", f, args);
1187 gfc_resolve_minloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1192 f->ts.type = BT_INTEGER;
1193 f->ts.kind = gfc_default_integer_kind;
1199 f->rank = array->rank - 1;
1200 gfc_resolve_dim_arg (dim);
1205 if (mask->rank == 0)
1210 /* The mask can be kind 4 or 8 for the array case. For the
1211 scalar case, coerce it to default kind unconditionally. */
1212 if ((mask->ts.kind < gfc_default_logical_kind)
1213 || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
1216 ts.type = BT_LOGICAL;
1217 ts.kind = gfc_default_logical_kind;
1218 gfc_convert_type_warn (mask, &ts, 2, 0);
1224 f->value.function.name =
1225 gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1226 gfc_type_letter (array->ts.type), array->ts.kind);
1231 gfc_resolve_minval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1240 f->rank = array->rank - 1;
1241 gfc_resolve_dim_arg (dim);
1246 if (mask->rank == 0)
1251 /* The mask can be kind 4 or 8 for the array case. For the
1252 scalar case, coerce it to default kind unconditionally. */
1253 if ((mask->ts.kind < gfc_default_logical_kind)
1254 || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
1257 ts.type = BT_LOGICAL;
1258 ts.kind = gfc_default_logical_kind;
1259 gfc_convert_type_warn (mask, &ts, 2, 0);
1265 f->value.function.name =
1266 gfc_get_string (PREFIX("%s_%c%d"), name,
1267 gfc_type_letter (array->ts.type), array->ts.kind);
1272 gfc_resolve_mod (gfc_expr * f, gfc_expr * a, gfc_expr * p)
1274 f->ts.type = a->ts.type;
1276 f->ts.kind = gfc_kind_max (a,p);
1278 f->ts.kind = a->ts.kind;
1280 if (p != NULL && a->ts.kind != p->ts.kind)
1282 if (a->ts.kind == gfc_kind_max (a,p))
1283 gfc_convert_type(p, &a->ts, 2);
1285 gfc_convert_type(a, &p->ts, 2);
1288 f->value.function.name =
1289 gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
1294 gfc_resolve_modulo (gfc_expr * f, gfc_expr * a, gfc_expr * p)
1296 f->ts.type = a->ts.type;
1298 f->ts.kind = gfc_kind_max (a,p);
1300 f->ts.kind = a->ts.kind;
1302 if (p != NULL && a->ts.kind != p->ts.kind)
1304 if (a->ts.kind == gfc_kind_max (a,p))
1305 gfc_convert_type(p, &a->ts, 2);
1307 gfc_convert_type(a, &p->ts, 2);
1310 f->value.function.name =
1311 gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type),
1316 gfc_resolve_nearest (gfc_expr * f, gfc_expr * a, gfc_expr *p ATTRIBUTE_UNUSED)
1319 f->value.function.name =
1320 gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
1325 gfc_resolve_nint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
1327 f->ts.type = BT_INTEGER;
1328 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
1329 : mpz_get_si (kind->value.integer);
1331 f->value.function.name =
1332 gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
1337 gfc_resolve_not (gfc_expr * f, gfc_expr * i)
1340 f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
1345 gfc_resolve_or (gfc_expr * f, gfc_expr * i, gfc_expr * j)
1347 f->ts.type = i->ts.type;
1348 f->ts.kind = gfc_kind_max (i,j);
1350 if (i->ts.kind != j->ts.kind)
1352 if (i->ts.kind == gfc_kind_max (i,j))
1353 gfc_convert_type(j, &i->ts, 2);
1355 gfc_convert_type(i, &j->ts, 2);
1358 f->value.function.name = gfc_get_string ("__or_%c%d",
1359 gfc_type_letter (i->ts.type),
1365 gfc_resolve_pack (gfc_expr * f, gfc_expr * array, gfc_expr * mask,
1366 gfc_expr * vector ATTRIBUTE_UNUSED)
1371 if (mask->rank != 0)
1372 f->value.function.name = (array->ts.type == BT_CHARACTER
1373 ? PREFIX("pack_char")
1377 /* We convert mask to default logical only in the scalar case.
1378 In the array case we can simply read the array as if it were
1379 of type default logical. */
1380 if (mask->ts.kind != gfc_default_logical_kind)
1384 ts.type = BT_LOGICAL;
1385 ts.kind = gfc_default_logical_kind;
1386 gfc_convert_type (mask, &ts, 2);
1389 f->value.function.name = (array->ts.type == BT_CHARACTER
1390 ? PREFIX("pack_s_char")
1391 : PREFIX("pack_s"));
1397 gfc_resolve_product (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1406 f->rank = array->rank - 1;
1407 gfc_resolve_dim_arg (dim);
1412 if (mask->rank == 0)
1417 /* The mask can be kind 4 or 8 for the array case. For the
1418 scalar case, coerce it to default kind unconditionally. */
1419 if ((mask->ts.kind < gfc_default_logical_kind)
1420 || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
1423 ts.type = BT_LOGICAL;
1424 ts.kind = gfc_default_logical_kind;
1425 gfc_convert_type_warn (mask, &ts, 2, 0);
1431 f->value.function.name =
1432 gfc_get_string (PREFIX("%s_%c%d"), name,
1433 gfc_type_letter (array->ts.type), array->ts.kind);
1438 gfc_resolve_real (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
1440 f->ts.type = BT_REAL;
1443 f->ts.kind = mpz_get_si (kind->value.integer);
1445 f->ts.kind = (a->ts.type == BT_COMPLEX) ?
1446 a->ts.kind : gfc_default_real_kind;
1448 f->value.function.name =
1449 gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1450 gfc_type_letter (a->ts.type), a->ts.kind);
1455 gfc_resolve_realpart (gfc_expr * f, gfc_expr * a)
1457 f->ts.type = BT_REAL;
1458 f->ts.kind = a->ts.kind;
1459 f->value.function.name =
1460 gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1461 gfc_type_letter (a->ts.type), a->ts.kind);
1466 gfc_resolve_rename (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
1467 gfc_expr * p2 ATTRIBUTE_UNUSED)
1469 f->ts.type = BT_INTEGER;
1470 f->ts.kind = gfc_default_integer_kind;
1471 f->value.function.name = gfc_get_string (PREFIX("rename_i%d"), f->ts.kind);
1476 gfc_resolve_repeat (gfc_expr * f, gfc_expr * string,
1477 gfc_expr * ncopies ATTRIBUTE_UNUSED)
1479 f->ts.type = BT_CHARACTER;
1480 f->ts.kind = string->ts.kind;
1481 f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
1486 gfc_resolve_reshape (gfc_expr * f, gfc_expr * source, gfc_expr * shape,
1487 gfc_expr * pad ATTRIBUTE_UNUSED,
1488 gfc_expr * order ATTRIBUTE_UNUSED)
1496 gfc_array_size (shape, &rank);
1497 f->rank = mpz_get_si (rank);
1499 switch (source->ts.type)
1505 kind = source->ts.kind;
1519 if (source->ts.type == BT_COMPLEX)
1520 f->value.function.name =
1521 gfc_get_string (PREFIX("reshape_%c%d"),
1522 gfc_type_letter (BT_COMPLEX), source->ts.kind);
1523 else if (source->ts.type == BT_REAL && (kind == 10 || kind == 16))
1524 f->value.function.name =
1525 gfc_get_string (PREFIX("reshape_%c%d"),
1526 gfc_type_letter (BT_REAL), source->ts.kind);
1528 f->value.function.name =
1529 gfc_get_string (PREFIX("reshape_%d"), source->ts.kind);
1534 f->value.function.name = (source->ts.type == BT_CHARACTER
1535 ? PREFIX("reshape_char")
1536 : PREFIX("reshape"));
1540 /* TODO: Make this work with a constant ORDER parameter. */
1541 if (shape->expr_type == EXPR_ARRAY
1542 && gfc_is_constant_expr (shape)
1546 f->shape = gfc_get_shape (f->rank);
1547 c = shape->value.constructor;
1548 for (i = 0; i < f->rank; i++)
1550 mpz_init_set (f->shape[i], c->expr->value.integer);
1555 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
1556 so many runtime variations. */
1557 if (shape->ts.kind != gfc_index_integer_kind)
1559 gfc_typespec ts = shape->ts;
1560 ts.kind = gfc_index_integer_kind;
1561 gfc_convert_type_warn (shape, &ts, 2, 0);
1563 if (order && order->ts.kind != gfc_index_integer_kind)
1564 gfc_convert_type_warn (order, &shape->ts, 2, 0);
1569 gfc_resolve_rrspacing (gfc_expr * f, gfc_expr * x)
1572 f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
1577 gfc_resolve_scale (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1581 /* The implementation calls scalbn which takes an int as the
1583 if (i->ts.kind != gfc_c_int_kind)
1587 ts.type = BT_INTEGER;
1588 ts.kind = gfc_default_integer_kind;
1590 gfc_convert_type_warn (i, &ts, 2, 0);
1593 f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
1598 gfc_resolve_scan (gfc_expr * f, gfc_expr * string,
1599 gfc_expr * set ATTRIBUTE_UNUSED,
1600 gfc_expr * back ATTRIBUTE_UNUSED)
1602 f->ts.type = BT_INTEGER;
1603 f->ts.kind = gfc_default_integer_kind;
1604 f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
1609 gfc_resolve_secnds (gfc_expr * t1, gfc_expr * t0)
1612 t1->value.function.name =
1613 gfc_get_string (PREFIX("secnds"));
1618 gfc_resolve_set_exponent (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1622 /* The library implementation uses GFC_INTEGER_4 unconditionally,
1623 convert type so we don't have to implement all possible
1625 if (i->ts.kind != 4)
1629 ts.type = BT_INTEGER;
1630 ts.kind = gfc_default_integer_kind;
1632 gfc_convert_type_warn (i, &ts, 2, 0);
1635 f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
1640 gfc_resolve_shape (gfc_expr * f, gfc_expr * array)
1642 f->ts.type = BT_INTEGER;
1643 f->ts.kind = gfc_default_integer_kind;
1645 f->value.function.name = gfc_get_string (PREFIX("shape_%d"), f->ts.kind);
1646 f->shape = gfc_get_shape (1);
1647 mpz_init_set_ui (f->shape[0], array->rank);
1652 gfc_resolve_sign (gfc_expr * f, gfc_expr * a, gfc_expr * b ATTRIBUTE_UNUSED)
1655 f->value.function.name =
1656 gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
1661 gfc_resolve_signal (gfc_expr * f, gfc_expr *number, gfc_expr *handler)
1663 f->ts.type = BT_INTEGER;
1664 f->ts.kind = gfc_c_int_kind;
1666 /* handler can be either BT_INTEGER or BT_PROCEDURE */
1667 if (handler->ts.type == BT_INTEGER)
1669 if (handler->ts.kind != gfc_c_int_kind)
1670 gfc_convert_type (handler, &f->ts, 2);
1671 f->value.function.name = gfc_get_string (PREFIX("signal_func_int"));
1674 f->value.function.name = gfc_get_string (PREFIX("signal_func"));
1676 if (number->ts.kind != gfc_c_int_kind)
1677 gfc_convert_type (number, &f->ts, 2);
1682 gfc_resolve_sin (gfc_expr * f, gfc_expr * x)
1685 f->value.function.name =
1686 gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1691 gfc_resolve_sinh (gfc_expr * f, gfc_expr * x)
1694 f->value.function.name =
1695 gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1700 gfc_resolve_spacing (gfc_expr * f, gfc_expr * x)
1703 f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
1708 gfc_resolve_spread (gfc_expr * f, gfc_expr * source,
1712 if (source->ts.type == BT_CHARACTER)
1713 check_charlen_present (source);
1716 f->rank = source->rank + 1;
1717 if (source->rank == 0)
1718 f->value.function.name = (source->ts.type == BT_CHARACTER
1719 ? PREFIX("spread_char_scalar")
1720 : PREFIX("spread_scalar"));
1722 f->value.function.name = (source->ts.type == BT_CHARACTER
1723 ? PREFIX("spread_char")
1724 : PREFIX("spread"));
1726 gfc_resolve_dim_arg (dim);
1727 gfc_resolve_index (ncopies, 1);
1732 gfc_resolve_sqrt (gfc_expr * f, gfc_expr * x)
1735 f->value.function.name =
1736 gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1740 /* Resolve the g77 compatibility function STAT AND FSTAT. */
1743 gfc_resolve_stat (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED,
1744 gfc_expr * a ATTRIBUTE_UNUSED)
1746 f->ts.type = BT_INTEGER;
1747 f->ts.kind = gfc_default_integer_kind;
1748 f->value.function.name = gfc_get_string (PREFIX("stat_i%d"), f->ts.kind);
1753 gfc_resolve_fstat (gfc_expr * f, gfc_expr * n, gfc_expr * a ATTRIBUTE_UNUSED)
1755 f->ts.type = BT_INTEGER;
1756 f->ts.kind = gfc_default_integer_kind;
1757 if (n->ts.kind != f->ts.kind)
1758 gfc_convert_type (n, &f->ts, 2);
1760 f->value.function.name = gfc_get_string (PREFIX("fstat_i%d"), f->ts.kind);
1765 gfc_resolve_fgetc (gfc_expr * f, gfc_expr * u, gfc_expr * c ATTRIBUTE_UNUSED)
1769 f->ts.type = BT_INTEGER;
1770 f->ts.kind = gfc_c_int_kind;
1771 if (u->ts.kind != gfc_c_int_kind)
1773 ts.type = BT_INTEGER;
1774 ts.kind = gfc_c_int_kind;
1777 gfc_convert_type (u, &ts, 2);
1780 f->value.function.name = gfc_get_string (PREFIX("fgetc"));
1785 gfc_resolve_fget (gfc_expr * f, gfc_expr * c ATTRIBUTE_UNUSED)
1787 f->ts.type = BT_INTEGER;
1788 f->ts.kind = gfc_c_int_kind;
1789 f->value.function.name = gfc_get_string (PREFIX("fget"));
1794 gfc_resolve_fputc (gfc_expr * f, gfc_expr * u, gfc_expr * c ATTRIBUTE_UNUSED)
1798 f->ts.type = BT_INTEGER;
1799 f->ts.kind = gfc_c_int_kind;
1800 if (u->ts.kind != gfc_c_int_kind)
1802 ts.type = BT_INTEGER;
1803 ts.kind = gfc_c_int_kind;
1806 gfc_convert_type (u, &ts, 2);
1809 f->value.function.name = gfc_get_string (PREFIX("fputc"));
1814 gfc_resolve_fput (gfc_expr * f, gfc_expr * c ATTRIBUTE_UNUSED)
1816 f->ts.type = BT_INTEGER;
1817 f->ts.kind = gfc_c_int_kind;
1818 f->value.function.name = gfc_get_string (PREFIX("fput"));
1823 gfc_resolve_ftell (gfc_expr * f, gfc_expr * u)
1827 f->ts.type = BT_INTEGER;
1828 f->ts.kind = gfc_index_integer_kind;
1829 if (u->ts.kind != gfc_c_int_kind)
1831 ts.type = BT_INTEGER;
1832 ts.kind = gfc_c_int_kind;
1835 gfc_convert_type (u, &ts, 2);
1838 f->value.function.name = gfc_get_string (PREFIX("ftell"));
1843 gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1852 if (mask->rank == 0)
1857 /* The mask can be kind 4 or 8 for the array case. For the
1858 scalar case, coerce it to default kind unconditionally. */
1859 if ((mask->ts.kind < gfc_default_logical_kind)
1860 || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
1863 ts.type = BT_LOGICAL;
1864 ts.kind = gfc_default_logical_kind;
1865 gfc_convert_type_warn (mask, &ts, 2, 0);
1873 f->rank = array->rank - 1;
1874 gfc_resolve_dim_arg (dim);
1877 f->value.function.name =
1878 gfc_get_string (PREFIX("%s_%c%d"), name,
1879 gfc_type_letter (array->ts.type), array->ts.kind);
1884 gfc_resolve_symlnk (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
1885 gfc_expr * p2 ATTRIBUTE_UNUSED)
1887 f->ts.type = BT_INTEGER;
1888 f->ts.kind = gfc_default_integer_kind;
1889 f->value.function.name = gfc_get_string (PREFIX("symlnk_i%d"), f->ts.kind);
1893 /* Resolve the g77 compatibility function SYSTEM. */
1896 gfc_resolve_system (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
1898 f->ts.type = BT_INTEGER;
1900 f->value.function.name = gfc_get_string (PREFIX("system"));
1905 gfc_resolve_tan (gfc_expr * f, gfc_expr * x)
1908 f->value.function.name =
1909 gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1914 gfc_resolve_tanh (gfc_expr * f, gfc_expr * x)
1917 f->value.function.name =
1918 gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1923 gfc_resolve_time (gfc_expr * f)
1925 f->ts.type = BT_INTEGER;
1927 f->value.function.name = gfc_get_string (PREFIX("time_func"));
1932 gfc_resolve_time8 (gfc_expr * f)
1934 f->ts.type = BT_INTEGER;
1936 f->value.function.name = gfc_get_string (PREFIX("time8_func"));
1941 gfc_resolve_transfer (gfc_expr * f, gfc_expr * source ATTRIBUTE_UNUSED,
1942 gfc_expr * mold, gfc_expr * size)
1944 /* TODO: Make this do something meaningful. */
1945 static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
1949 if (size == NULL && mold->rank == 0)
1952 f->value.function.name = transfer0;
1957 f->value.function.name = transfer1;
1958 if (size && gfc_is_constant_expr (size))
1960 f->shape = gfc_get_shape (1);
1961 mpz_init_set (f->shape[0], size->value.integer);
1968 gfc_resolve_transpose (gfc_expr * f, gfc_expr * matrix)
1976 f->shape = gfc_get_shape (2);
1977 mpz_init_set (f->shape[0], matrix->shape[1]);
1978 mpz_init_set (f->shape[1], matrix->shape[0]);
1981 kind = matrix->ts.kind;
1989 switch (matrix->ts.type)
1992 f->value.function.name =
1993 gfc_get_string (PREFIX("transpose_c%d"), kind);
1997 /* There is no kind=10 integer type and on 32-bit targets
1998 there is usually no kind=16 integer type. We need to
1999 call the real version. */
2000 if (kind == 10 || kind == 16)
2002 f->value.function.name =
2003 gfc_get_string (PREFIX("transpose_r%d"), kind);
2011 /* Use the integer routines for real and logical cases. This
2012 assumes they all have the same alignment requirements. */
2013 f->value.function.name =
2014 gfc_get_string (PREFIX("transpose_i%d"), kind);
2018 f->value.function.name = PREFIX("transpose");
2024 f->value.function.name = (matrix->ts.type == BT_CHARACTER
2025 ? PREFIX("transpose_char")
2026 : PREFIX("transpose"));
2033 gfc_resolve_trim (gfc_expr * f, gfc_expr * string)
2035 f->ts.type = BT_CHARACTER;
2036 f->ts.kind = string->ts.kind;
2037 f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
2042 gfc_resolve_ubound (gfc_expr * f, gfc_expr * array,
2045 static char ubound[] = "__ubound";
2047 f->ts.type = BT_INTEGER;
2048 f->ts.kind = gfc_default_integer_kind;
2053 f->shape = gfc_get_shape (1);
2054 mpz_init_set_ui (f->shape[0], array->rank);
2057 f->value.function.name = ubound;
2061 /* Resolve the g77 compatibility function UMASK. */
2064 gfc_resolve_umask (gfc_expr * f, gfc_expr * n)
2066 f->ts.type = BT_INTEGER;
2067 f->ts.kind = n->ts.kind;
2068 f->value.function.name = gfc_get_string (PREFIX("umask_i%d"), n->ts.kind);
2072 /* Resolve the g77 compatibility function UNLINK. */
2075 gfc_resolve_unlink (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
2077 f->ts.type = BT_INTEGER;
2079 f->value.function.name = gfc_get_string (PREFIX("unlink"));
2084 gfc_resolve_ttynam (gfc_expr * f, gfc_expr * unit)
2088 f->ts.type = BT_CHARACTER;
2089 f->ts.kind = gfc_default_character_kind;
2091 if (unit->ts.kind != gfc_c_int_kind)
2093 ts.type = BT_INTEGER;
2094 ts.kind = gfc_c_int_kind;
2097 gfc_convert_type (unit, &ts, 2);
2100 f->value.function.name = gfc_get_string (PREFIX("ttynam"));
2105 gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask,
2106 gfc_expr * field ATTRIBUTE_UNUSED)
2109 f->rank = mask->rank;
2111 f->value.function.name =
2112 gfc_get_string (PREFIX("unpack%d%s"), field->rank > 0 ? 1 : 0,
2113 vector->ts.type == BT_CHARACTER ? "_char" : "");
2118 gfc_resolve_verify (gfc_expr * f, gfc_expr * string,
2119 gfc_expr * set ATTRIBUTE_UNUSED,
2120 gfc_expr * back ATTRIBUTE_UNUSED)
2122 f->ts.type = BT_INTEGER;
2123 f->ts.kind = gfc_default_integer_kind;
2124 f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
2129 gfc_resolve_xor (gfc_expr * f, gfc_expr * i, gfc_expr * j)
2131 f->ts.type = i->ts.type;
2132 f->ts.kind = gfc_kind_max (i,j);
2134 if (i->ts.kind != j->ts.kind)
2136 if (i->ts.kind == gfc_kind_max (i,j))
2137 gfc_convert_type(j, &i->ts, 2);
2139 gfc_convert_type(i, &j->ts, 2);
2142 f->value.function.name = gfc_get_string ("__xor_%c%d",
2143 gfc_type_letter (i->ts.type),
2148 /* Intrinsic subroutine resolution. */
2151 gfc_resolve_alarm_sub (gfc_code * c)
2154 gfc_expr *seconds, *handler, *status;
2157 seconds = c->ext.actual->expr;
2158 handler = c->ext.actual->next->expr;
2159 status = c->ext.actual->next->next->expr;
2160 ts.type = BT_INTEGER;
2161 ts.kind = gfc_c_int_kind;
2163 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2164 if (handler->ts.type == BT_INTEGER)
2166 if (handler->ts.kind != gfc_c_int_kind)
2167 gfc_convert_type (handler, &ts, 2);
2168 name = gfc_get_string (PREFIX("alarm_sub_int"));
2171 name = gfc_get_string (PREFIX("alarm_sub"));
2173 if (seconds->ts.kind != gfc_c_int_kind)
2174 gfc_convert_type (seconds, &ts, 2);
2175 if (status != NULL && status->ts.kind != gfc_c_int_kind)
2176 gfc_convert_type (status, &ts, 2);
2178 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2182 gfc_resolve_cpu_time (gfc_code * c ATTRIBUTE_UNUSED)
2186 name = gfc_get_string (PREFIX("cpu_time_%d"),
2187 c->ext.actual->expr->ts.kind);
2188 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2193 gfc_resolve_mvbits (gfc_code * c)
2198 kind = c->ext.actual->expr->ts.kind;
2199 name = gfc_get_string (PREFIX("mvbits_i%d"), kind);
2201 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2206 gfc_resolve_random_number (gfc_code * c ATTRIBUTE_UNUSED)
2211 kind = c->ext.actual->expr->ts.kind;
2212 if (c->ext.actual->expr->rank == 0)
2213 name = gfc_get_string (PREFIX("random_r%d"), kind);
2215 name = gfc_get_string (PREFIX("arandom_r%d"), kind);
2217 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2222 gfc_resolve_rename_sub (gfc_code * c)
2227 if (c->ext.actual->next->next->expr != NULL)
2228 kind = c->ext.actual->next->next->expr->ts.kind;
2230 kind = gfc_default_integer_kind;
2232 name = gfc_get_string (PREFIX("rename_i%d_sub"), kind);
2233 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2238 gfc_resolve_kill_sub (gfc_code * c)
2243 if (c->ext.actual->next->next->expr != NULL)
2244 kind = c->ext.actual->next->next->expr->ts.kind;
2246 kind = gfc_default_integer_kind;
2248 name = gfc_get_string (PREFIX("kill_i%d_sub"), kind);
2249 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2254 gfc_resolve_link_sub (gfc_code * c)
2259 if (c->ext.actual->next->next->expr != NULL)
2260 kind = c->ext.actual->next->next->expr->ts.kind;
2262 kind = gfc_default_integer_kind;
2264 name = gfc_get_string (PREFIX("link_i%d_sub"), kind);
2265 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2270 gfc_resolve_symlnk_sub (gfc_code * c)
2275 if (c->ext.actual->next->next->expr != NULL)
2276 kind = c->ext.actual->next->next->expr->ts.kind;
2278 kind = gfc_default_integer_kind;
2280 name = gfc_get_string (PREFIX("symlnk_i%d_sub"), kind);
2281 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2285 /* G77 compatibility subroutines etime() and dtime(). */
2288 gfc_resolve_etime_sub (gfc_code * c)
2292 name = gfc_get_string (PREFIX("etime_sub"));
2293 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2297 /* G77 compatibility subroutine second(). */
2300 gfc_resolve_second_sub (gfc_code * c)
2304 name = gfc_get_string (PREFIX("second_sub"));
2305 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2310 gfc_resolve_sleep_sub (gfc_code * c)
2315 if (c->ext.actual->expr != NULL)
2316 kind = c->ext.actual->expr->ts.kind;
2318 kind = gfc_default_integer_kind;
2320 name = gfc_get_string (PREFIX("sleep_i%d_sub"), kind);
2321 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2325 /* G77 compatibility function srand(). */
2328 gfc_resolve_srand (gfc_code * c)
2331 name = gfc_get_string (PREFIX("srand"));
2332 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2336 /* Resolve the getarg intrinsic subroutine. */
2339 gfc_resolve_getarg (gfc_code * c)
2344 kind = gfc_default_integer_kind;
2345 name = gfc_get_string (PREFIX("getarg_i%d"), kind);
2346 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2349 /* Resolve the getcwd intrinsic subroutine. */
2352 gfc_resolve_getcwd_sub (gfc_code * c)
2357 if (c->ext.actual->next->expr != NULL)
2358 kind = c->ext.actual->next->expr->ts.kind;
2360 kind = gfc_default_integer_kind;
2362 name = gfc_get_string (PREFIX("getcwd_i%d_sub"), kind);
2363 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2367 /* Resolve the get_command intrinsic subroutine. */
2370 gfc_resolve_get_command (gfc_code * c)
2375 kind = gfc_default_integer_kind;
2376 name = gfc_get_string (PREFIX("get_command_i%d"), kind);
2377 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2381 /* Resolve the get_command_argument intrinsic subroutine. */
2384 gfc_resolve_get_command_argument (gfc_code * c)
2389 kind = gfc_default_integer_kind;
2390 name = gfc_get_string (PREFIX("get_command_argument_i%d"), kind);
2391 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2394 /* Resolve the get_environment_variable intrinsic subroutine. */
2397 gfc_resolve_get_environment_variable (gfc_code * code)
2402 kind = gfc_default_integer_kind;
2403 name = gfc_get_string (PREFIX("get_environment_variable_i%d"), kind);
2404 code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2408 gfc_resolve_signal_sub (gfc_code * c)
2411 gfc_expr *number, *handler, *status;
2414 number = c->ext.actual->expr;
2415 handler = c->ext.actual->next->expr;
2416 status = c->ext.actual->next->next->expr;
2417 ts.type = BT_INTEGER;
2418 ts.kind = gfc_c_int_kind;
2420 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2421 if (handler->ts.type == BT_INTEGER)
2423 if (handler->ts.kind != gfc_c_int_kind)
2424 gfc_convert_type (handler, &ts, 2);
2425 name = gfc_get_string (PREFIX("signal_sub_int"));
2428 name = gfc_get_string (PREFIX("signal_sub"));
2430 if (number->ts.kind != gfc_c_int_kind)
2431 gfc_convert_type (number, &ts, 2);
2432 if (status != NULL && status->ts.kind != gfc_c_int_kind)
2433 gfc_convert_type (status, &ts, 2);
2435 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2438 /* Resolve the SYSTEM intrinsic subroutine. */
2441 gfc_resolve_system_sub (gfc_code * c)
2445 name = gfc_get_string (PREFIX("system_sub"));
2446 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2449 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
2452 gfc_resolve_system_clock (gfc_code * c)
2457 if (c->ext.actual->expr != NULL)
2458 kind = c->ext.actual->expr->ts.kind;
2459 else if (c->ext.actual->next->expr != NULL)
2460 kind = c->ext.actual->next->expr->ts.kind;
2461 else if (c->ext.actual->next->next->expr != NULL)
2462 kind = c->ext.actual->next->next->expr->ts.kind;
2464 kind = gfc_default_integer_kind;
2466 name = gfc_get_string (PREFIX("system_clock_%d"), kind);
2467 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2470 /* Resolve the EXIT intrinsic subroutine. */
2473 gfc_resolve_exit (gfc_code * c)
2478 if (c->ext.actual->expr != NULL)
2479 kind = c->ext.actual->expr->ts.kind;
2481 kind = gfc_default_integer_kind;
2483 name = gfc_get_string (PREFIX("exit_i%d"), kind);
2484 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2487 /* Resolve the FLUSH intrinsic subroutine. */
2490 gfc_resolve_flush (gfc_code * c)
2496 ts.type = BT_INTEGER;
2497 ts.kind = gfc_default_integer_kind;
2498 n = c->ext.actual->expr;
2500 && n->ts.kind != ts.kind)
2501 gfc_convert_type (n, &ts, 2);
2503 name = gfc_get_string (PREFIX("flush_i%d"), ts.kind);
2504 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2509 gfc_resolve_free (gfc_code * c)
2514 ts.type = BT_INTEGER;
2515 ts.kind = gfc_index_integer_kind;
2516 n = c->ext.actual->expr;
2517 if (n->ts.kind != ts.kind)
2518 gfc_convert_type (n, &ts, 2);
2520 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("free"));
2525 gfc_resolve_ctime_sub (gfc_code * c)
2529 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
2530 if (c->ext.actual->expr->ts.kind != 8)
2532 ts.type = BT_INTEGER;
2536 gfc_convert_type (c->ext.actual->expr, &ts, 2);
2539 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("ctime_sub"));
2544 gfc_resolve_fdate_sub (gfc_code * c)
2546 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
2551 gfc_resolve_gerror (gfc_code * c)
2553 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
2558 gfc_resolve_getlog (gfc_code * c)
2560 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
2565 gfc_resolve_hostnm_sub (gfc_code * c)
2570 if (c->ext.actual->next->expr != NULL)
2571 kind = c->ext.actual->next->expr->ts.kind;
2573 kind = gfc_default_integer_kind;
2575 name = gfc_get_string (PREFIX("hostnm_i%d_sub"), kind);
2576 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2581 gfc_resolve_perror (gfc_code * c)
2583 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
2586 /* Resolve the STAT and FSTAT intrinsic subroutines. */
2589 gfc_resolve_stat_sub (gfc_code * c)
2593 name = gfc_get_string (PREFIX("stat_i%d_sub"), gfc_default_integer_kind);
2594 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2599 gfc_resolve_fstat_sub (gfc_code * c)
2605 u = c->ext.actual->expr;
2606 ts = &c->ext.actual->next->expr->ts;
2607 if (u->ts.kind != ts->kind)
2608 gfc_convert_type (u, ts, 2);
2609 name = gfc_get_string (PREFIX("fstat_i%d_sub"), ts->kind);
2610 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2615 gfc_resolve_fgetc_sub (gfc_code * c)
2621 u = c->ext.actual->expr;
2622 st = c->ext.actual->next->next->expr;
2624 if (u->ts.kind != gfc_c_int_kind)
2626 ts.type = BT_INTEGER;
2627 ts.kind = gfc_c_int_kind;
2630 gfc_convert_type (u, &ts, 2);
2634 name = gfc_get_string (PREFIX("fgetc_i%d_sub"), st->ts.kind);
2636 name = gfc_get_string (PREFIX("fgetc_i%d_sub"), gfc_default_integer_kind);
2638 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2643 gfc_resolve_fget_sub (gfc_code * c)
2648 st = c->ext.actual->next->expr;
2650 name = gfc_get_string (PREFIX("fget_i%d_sub"), st->ts.kind);
2652 name = gfc_get_string (PREFIX("fget_i%d_sub"), gfc_default_integer_kind);
2654 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2659 gfc_resolve_fputc_sub (gfc_code * c)
2665 u = c->ext.actual->expr;
2666 st = c->ext.actual->next->next->expr;
2668 if (u->ts.kind != gfc_c_int_kind)
2670 ts.type = BT_INTEGER;
2671 ts.kind = gfc_c_int_kind;
2674 gfc_convert_type (u, &ts, 2);
2678 name = gfc_get_string (PREFIX("fputc_i%d_sub"), st->ts.kind);
2680 name = gfc_get_string (PREFIX("fputc_i%d_sub"), gfc_default_integer_kind);
2682 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2687 gfc_resolve_fput_sub (gfc_code * c)
2692 st = c->ext.actual->next->expr;
2694 name = gfc_get_string (PREFIX("fput_i%d_sub"), st->ts.kind);
2696 name = gfc_get_string (PREFIX("fput_i%d_sub"), gfc_default_integer_kind);
2698 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2703 gfc_resolve_ftell_sub (gfc_code * c)
2710 unit = c->ext.actual->expr;
2711 offset = c->ext.actual->next->expr;
2713 if (unit->ts.kind != gfc_c_int_kind)
2715 ts.type = BT_INTEGER;
2716 ts.kind = gfc_c_int_kind;
2719 gfc_convert_type (unit, &ts, 2);
2722 name = gfc_get_string (PREFIX("ftell_i%d_sub"), offset->ts.kind);
2723 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2728 gfc_resolve_ttynam_sub (gfc_code * c)
2732 if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
2734 ts.type = BT_INTEGER;
2735 ts.kind = gfc_c_int_kind;
2738 gfc_convert_type (c->ext.actual->expr, &ts, 2);
2741 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("ttynam_sub"));
2745 /* Resolve the UMASK intrinsic subroutine. */
2748 gfc_resolve_umask_sub (gfc_code * c)
2753 if (c->ext.actual->next->expr != NULL)
2754 kind = c->ext.actual->next->expr->ts.kind;
2756 kind = gfc_default_integer_kind;
2758 name = gfc_get_string (PREFIX("umask_i%d_sub"), kind);
2759 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2762 /* Resolve the UNLINK intrinsic subroutine. */
2765 gfc_resolve_unlink_sub (gfc_code * c)
2770 if (c->ext.actual->next->expr != NULL)
2771 kind = c->ext.actual->next->expr->ts.kind;
2773 kind = gfc_default_integer_kind;
2775 name = gfc_get_string (PREFIX("unlink_i%d_sub"), kind);
2776 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);