1 /* Intrinsic function resolution.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
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, 59 Temple Place - Suite 330, 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 /********************** Resolution functions **********************/
66 gfc_resolve_abs (gfc_expr * f, gfc_expr * a)
69 if (f->ts.type == BT_COMPLEX)
72 f->value.function.name =
73 gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
78 gfc_resolve_acos (gfc_expr * f, gfc_expr * x)
81 f->value.function.name =
82 gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
87 gfc_resolve_aimag (gfc_expr * f, gfc_expr * x)
90 f->ts.kind = x->ts.kind;
91 f->value.function.name =
92 gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
97 gfc_resolve_aint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
99 f->ts.type = a->ts.type;
100 f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
102 /* The resolved name is only used for specific intrinsics where
103 the return kind is the same as the arg kind. */
104 f->value.function.name =
105 gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
110 gfc_resolve_dint (gfc_expr * f, gfc_expr * a)
112 gfc_resolve_aint (f, a, NULL);
117 gfc_resolve_all (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
123 gfc_resolve_index (dim, 1);
124 f->rank = mask->rank - 1;
125 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
128 f->value.function.name =
129 gfc_get_string (PREFIX("all_%c%d"), gfc_type_letter (mask->ts.type),
135 gfc_resolve_anint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
137 f->ts.type = a->ts.type;
138 f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
140 /* The resolved name is only used for specific intrinsics where
141 the return kind is the same as the arg kind. */
142 f->value.function.name =
143 gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
148 gfc_resolve_dnint (gfc_expr * f, gfc_expr * a)
150 gfc_resolve_anint (f, a, NULL);
155 gfc_resolve_any (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
161 gfc_resolve_index (dim, 1);
162 f->rank = mask->rank - 1;
163 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
166 f->value.function.name =
167 gfc_get_string (PREFIX("any_%c%d"), gfc_type_letter (mask->ts.type),
173 gfc_resolve_asin (gfc_expr * f, gfc_expr * x)
176 f->value.function.name =
177 gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
182 gfc_resolve_atan (gfc_expr * f, gfc_expr * x)
185 f->value.function.name =
186 gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
191 gfc_resolve_atan2 (gfc_expr * f, gfc_expr * x,
192 gfc_expr * y ATTRIBUTE_UNUSED)
195 f->value.function.name =
196 gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
200 /* Resolve the BESYN and BESJN intrinsics. */
203 gfc_resolve_besn (gfc_expr * f, gfc_expr * n, gfc_expr * x)
208 if (n->ts.kind != gfc_c_int_kind)
210 ts.type = BT_INTEGER;
211 ts.kind = gfc_c_int_kind;
212 gfc_convert_type (n, &ts, 2);
214 f->value.function.name = gfc_get_string ("<intrinsic>");
219 gfc_resolve_btest (gfc_expr * f, gfc_expr * i, gfc_expr * pos)
221 f->ts.type = BT_LOGICAL;
222 f->ts.kind = gfc_default_logical_kind;
224 f->value.function.name = gfc_get_string ("__btest_%d_%d", i->ts.kind,
230 gfc_resolve_ceiling (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
232 f->ts.type = BT_INTEGER;
233 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
234 : mpz_get_si (kind->value.integer);
236 f->value.function.name =
237 gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind,
238 gfc_type_letter (a->ts.type), a->ts.kind);
243 gfc_resolve_char (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
245 f->ts.type = BT_CHARACTER;
246 f->ts.kind = (kind == NULL) ? gfc_default_character_kind
247 : mpz_get_si (kind->value.integer);
249 f->value.function.name =
250 gfc_get_string ("__char_%d_%c%d", f->ts.kind,
251 gfc_type_letter (a->ts.type), a->ts.kind);
256 gfc_resolve_cmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y, gfc_expr * kind)
258 f->ts.type = BT_COMPLEX;
259 f->ts.kind = (kind == NULL) ? gfc_default_real_kind
260 : mpz_get_si (kind->value.integer);
263 f->value.function.name =
264 gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind,
265 gfc_type_letter (x->ts.type), x->ts.kind);
267 f->value.function.name =
268 gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
269 gfc_type_letter (x->ts.type), x->ts.kind,
270 gfc_type_letter (y->ts.type), y->ts.kind);
274 gfc_resolve_dcmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y)
276 gfc_resolve_cmplx (f, x, y, gfc_int_expr (gfc_default_double_kind));
280 gfc_resolve_conjg (gfc_expr * f, gfc_expr * x)
283 f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind);
288 gfc_resolve_cos (gfc_expr * f, gfc_expr * x)
291 f->value.function.name =
292 gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
297 gfc_resolve_cosh (gfc_expr * f, gfc_expr * x)
300 f->value.function.name =
301 gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
306 gfc_resolve_count (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
308 f->ts.type = BT_INTEGER;
309 f->ts.kind = gfc_default_integer_kind;
313 f->rank = mask->rank - 1;
314 gfc_resolve_index (dim, 1);
315 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
318 f->value.function.name =
319 gfc_get_string (PREFIX("count_%d_%c%d"), f->ts.kind,
320 gfc_type_letter (mask->ts.type), mask->ts.kind);
325 gfc_resolve_cshift (gfc_expr * f, gfc_expr * array,
332 f->rank = array->rank;
333 f->shape = gfc_copy_shape (array->shape, array->rank);
342 gfc_resolve_index (dim, 1);
343 /* Convert dim to shift's kind, so we don't need so many variations. */
344 if (dim->ts.kind != shift->ts.kind)
345 gfc_convert_type_warn (dim, &shift->ts, 2, 0);
347 f->value.function.name =
348 gfc_get_string (PREFIX("cshift%d_%d"), n, shift->ts.kind);
353 gfc_resolve_dble (gfc_expr * f, gfc_expr * a)
355 f->ts.type = BT_REAL;
356 f->ts.kind = gfc_default_double_kind;
357 f->value.function.name =
358 gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
363 gfc_resolve_dim (gfc_expr * f, gfc_expr * x,
364 gfc_expr * y ATTRIBUTE_UNUSED)
367 f->value.function.name =
368 gfc_get_string ("__dim_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
373 gfc_resolve_dot_product (gfc_expr * f, gfc_expr * a, gfc_expr * b)
377 if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
379 f->ts.type = BT_LOGICAL;
380 f->ts.kind = gfc_default_logical_kind;
384 temp.expr_type = EXPR_OP;
385 gfc_clear_ts (&temp.ts);
386 temp.value.op.operator = INTRINSIC_NONE;
387 temp.value.op.op1 = a;
388 temp.value.op.op2 = b;
389 gfc_type_convert_binary (&temp);
393 f->value.function.name =
394 gfc_get_string (PREFIX("dot_product_%c%d"), gfc_type_letter (f->ts.type),
400 gfc_resolve_dprod (gfc_expr * f,
401 gfc_expr * a ATTRIBUTE_UNUSED,
402 gfc_expr * b ATTRIBUTE_UNUSED)
404 f->ts.kind = gfc_default_double_kind;
405 f->ts.type = BT_REAL;
407 f->value.function.name = gfc_get_string ("__dprod_r%d", f->ts.kind);
412 gfc_resolve_eoshift (gfc_expr * f, gfc_expr * array,
420 f->rank = array->rank;
421 f->shape = gfc_copy_shape (array->shape, array->rank);
426 if (boundary && boundary->rank > 0)
429 /* Convert dim to the same type as shift, so we don't need quite so many
431 if (dim != NULL && dim->ts.kind != shift->ts.kind)
432 gfc_convert_type_warn (dim, &shift->ts, 2, 0);
434 f->value.function.name =
435 gfc_get_string (PREFIX("eoshift%d_%d"), n, shift->ts.kind);
440 gfc_resolve_exp (gfc_expr * f, gfc_expr * x)
443 f->value.function.name =
444 gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
449 gfc_resolve_exponent (gfc_expr * f, gfc_expr * x)
451 f->ts.type = BT_INTEGER;
452 f->ts.kind = gfc_default_integer_kind;
454 f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind);
459 gfc_resolve_floor (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
461 f->ts.type = BT_INTEGER;
462 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
463 : mpz_get_si (kind->value.integer);
465 f->value.function.name =
466 gfc_get_string ("__floor%d_%c%d", f->ts.kind,
467 gfc_type_letter (a->ts.type), a->ts.kind);
472 gfc_resolve_fnum (gfc_expr * f, gfc_expr * n)
474 f->ts.type = BT_INTEGER;
475 f->ts.kind = gfc_default_integer_kind;
476 if (n->ts.kind != f->ts.kind)
477 gfc_convert_type (n, &f->ts, 2);
478 f->value.function.name = gfc_get_string (PREFIX("fnum_i%d"), f->ts.kind);
483 gfc_resolve_fraction (gfc_expr * f, gfc_expr * x)
486 f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind);
490 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
493 gfc_resolve_g77_math1 (gfc_expr * f, gfc_expr * x)
496 f->value.function.name = gfc_get_string ("<intrinsic>");
501 gfc_resolve_getcwd (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
503 f->ts.type = BT_INTEGER;
505 f->value.function.name = gfc_get_string (PREFIX("getcwd"));
510 gfc_resolve_getgid (gfc_expr * f)
512 f->ts.type = BT_INTEGER;
514 f->value.function.name = gfc_get_string (PREFIX("getgid"));
519 gfc_resolve_getpid (gfc_expr * f)
521 f->ts.type = BT_INTEGER;
523 f->value.function.name = gfc_get_string (PREFIX("getpid"));
528 gfc_resolve_getuid (gfc_expr * f)
530 f->ts.type = BT_INTEGER;
532 f->value.function.name = gfc_get_string (PREFIX("getuid"));
536 gfc_resolve_iand (gfc_expr * f, gfc_expr * i, gfc_expr * j)
538 /* If the kind of i and j are different, then g77 cross-promoted the
539 kinds to the largest value. The Fortran 95 standard requires the
541 if (i->ts.kind != j->ts.kind)
543 if (i->ts.kind == gfc_kind_max (i,j))
544 gfc_convert_type(j, &i->ts, 2);
546 gfc_convert_type(i, &j->ts, 2);
550 f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind);
555 gfc_resolve_ibclr (gfc_expr * f, gfc_expr * i, gfc_expr * pos ATTRIBUTE_UNUSED)
558 f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind);
563 gfc_resolve_ibits (gfc_expr * f, gfc_expr * i,
564 gfc_expr * pos ATTRIBUTE_UNUSED,
565 gfc_expr * len ATTRIBUTE_UNUSED)
568 f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind);
573 gfc_resolve_ibset (gfc_expr * f, gfc_expr * i,
574 gfc_expr * pos ATTRIBUTE_UNUSED)
577 f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind);
582 gfc_resolve_ichar (gfc_expr * f, gfc_expr * c)
584 f->ts.type = BT_INTEGER;
585 f->ts.kind = gfc_default_integer_kind;
587 f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
592 gfc_resolve_idnint (gfc_expr * f, gfc_expr * a)
594 gfc_resolve_nint (f, a, NULL);
599 gfc_resolve_ieor (gfc_expr * f, gfc_expr * i, gfc_expr * j)
601 /* If the kind of i and j are different, then g77 cross-promoted the
602 kinds to the largest value. The Fortran 95 standard requires the
604 if (i->ts.kind != j->ts.kind)
606 if (i->ts.kind == gfc_kind_max (i,j))
607 gfc_convert_type(j, &i->ts, 2);
609 gfc_convert_type(i, &j->ts, 2);
613 f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind);
618 gfc_resolve_ior (gfc_expr * f, gfc_expr * i, gfc_expr * j)
620 /* If the kind of i and j are different, then g77 cross-promoted the
621 kinds to the largest value. The Fortran 95 standard requires the
623 if (i->ts.kind != j->ts.kind)
625 if (i->ts.kind == gfc_kind_max (i,j))
626 gfc_convert_type(j, &i->ts, 2);
628 gfc_convert_type(i, &j->ts, 2);
632 f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind);
637 gfc_resolve_int (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
639 f->ts.type = BT_INTEGER;
640 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
641 : mpz_get_si (kind->value.integer);
643 f->value.function.name =
644 gfc_get_string ("__int_%d_%c%d", f->ts.kind, gfc_type_letter (a->ts.type),
650 gfc_resolve_ishft (gfc_expr * f, gfc_expr * i, gfc_expr * shift)
653 f->value.function.name =
654 gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
659 gfc_resolve_ishftc (gfc_expr * f, gfc_expr * i, gfc_expr * shift,
664 s_kind = (size == NULL) ? gfc_default_integer_kind : shift->ts.kind;
667 f->value.function.name =
668 gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
673 gfc_resolve_lbound (gfc_expr * f, gfc_expr * array,
676 static char lbound[] = "__lbound";
678 f->ts.type = BT_INTEGER;
679 f->ts.kind = gfc_default_integer_kind;
684 f->shape = gfc_get_shape (1);
685 mpz_init_set_ui (f->shape[0], array->rank);
688 f->value.function.name = lbound;
693 gfc_resolve_len (gfc_expr * f, gfc_expr * string)
695 f->ts.type = BT_INTEGER;
696 f->ts.kind = gfc_default_integer_kind;
697 f->value.function.name = gfc_get_string ("__len_%d", string->ts.kind);
702 gfc_resolve_len_trim (gfc_expr * f, gfc_expr * string)
704 f->ts.type = BT_INTEGER;
705 f->ts.kind = gfc_default_integer_kind;
706 f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
711 gfc_resolve_log (gfc_expr * f, gfc_expr * x)
714 f->value.function.name =
715 gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
720 gfc_resolve_log10 (gfc_expr * f, gfc_expr * x)
723 f->value.function.name =
724 gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
729 gfc_resolve_logical (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
731 f->ts.type = BT_LOGICAL;
732 f->ts.kind = (kind == NULL) ? gfc_default_logical_kind
733 : mpz_get_si (kind->value.integer);
736 f->value.function.name =
737 gfc_get_string ("__logical_%d_%c%d", f->ts.kind,
738 gfc_type_letter (a->ts.type), a->ts.kind);
743 gfc_resolve_matmul (gfc_expr * f, gfc_expr * a, gfc_expr * b)
747 if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
749 f->ts.type = BT_LOGICAL;
750 f->ts.kind = gfc_default_logical_kind;
754 temp.expr_type = EXPR_OP;
755 gfc_clear_ts (&temp.ts);
756 temp.value.op.operator = INTRINSIC_NONE;
757 temp.value.op.op1 = a;
758 temp.value.op.op2 = b;
759 gfc_type_convert_binary (&temp);
763 f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
765 f->value.function.name =
766 gfc_get_string (PREFIX("matmul_%c%d"), gfc_type_letter (f->ts.type),
772 gfc_resolve_minmax (const char * name, gfc_expr * f, gfc_actual_arglist * args)
774 gfc_actual_arglist *a;
776 f->ts.type = args->expr->ts.type;
777 f->ts.kind = args->expr->ts.kind;
778 /* Find the largest type kind. */
779 for (a = args->next; a; a = a->next)
781 if (a->expr->ts.kind > f->ts.kind)
782 f->ts.kind = a->expr->ts.kind;
785 /* Convert all parameters to the required kind. */
786 for (a = args; a; a = a->next)
788 if (a->expr->ts.kind != f->ts.kind)
789 gfc_convert_type (a->expr, &f->ts, 2);
792 f->value.function.name =
793 gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind);
798 gfc_resolve_max (gfc_expr * f, gfc_actual_arglist * args)
800 gfc_resolve_minmax ("__max_%c%d", f, args);
805 gfc_resolve_maxloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
810 f->ts.type = BT_INTEGER;
811 f->ts.kind = gfc_default_integer_kind;
817 f->rank = array->rank - 1;
818 gfc_resolve_index (dim, 1);
821 name = mask ? "mmaxloc" : "maxloc";
822 f->value.function.name =
823 gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
824 gfc_type_letter (array->ts.type), array->ts.kind);
829 gfc_resolve_maxval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
836 f->rank = array->rank - 1;
837 gfc_resolve_index (dim, 1);
840 f->value.function.name =
841 gfc_get_string (PREFIX("%s_%c%d"), mask ? "mmaxval" : "maxval",
842 gfc_type_letter (array->ts.type), array->ts.kind);
847 gfc_resolve_merge (gfc_expr * f, gfc_expr * tsource,
848 gfc_expr * fsource ATTRIBUTE_UNUSED,
849 gfc_expr * mask ATTRIBUTE_UNUSED)
852 f->value.function.name =
853 gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
859 gfc_resolve_min (gfc_expr * f, gfc_actual_arglist * args)
861 gfc_resolve_minmax ("__min_%c%d", f, args);
866 gfc_resolve_minloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
871 f->ts.type = BT_INTEGER;
872 f->ts.kind = gfc_default_integer_kind;
878 f->rank = array->rank - 1;
879 gfc_resolve_index (dim, 1);
882 name = mask ? "mminloc" : "minloc";
883 f->value.function.name =
884 gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
885 gfc_type_letter (array->ts.type), array->ts.kind);
890 gfc_resolve_minval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
897 f->rank = array->rank - 1;
898 gfc_resolve_index (dim, 1);
901 f->value.function.name =
902 gfc_get_string (PREFIX("%s_%c%d"), mask ? "mminval" : "minval",
903 gfc_type_letter (array->ts.type), array->ts.kind);
908 gfc_resolve_mod (gfc_expr * f, gfc_expr * a,
909 gfc_expr * p ATTRIBUTE_UNUSED)
912 f->value.function.name =
913 gfc_get_string ("__mod_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
918 gfc_resolve_modulo (gfc_expr * f, gfc_expr * a,
919 gfc_expr * p ATTRIBUTE_UNUSED)
922 f->value.function.name =
923 gfc_get_string ("__modulo_%c%d", gfc_type_letter (a->ts.type),
928 gfc_resolve_nearest (gfc_expr * f, gfc_expr * a, gfc_expr *p ATTRIBUTE_UNUSED)
931 f->value.function.name =
932 gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
937 gfc_resolve_nint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
939 f->ts.type = BT_INTEGER;
940 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
941 : mpz_get_si (kind->value.integer);
943 f->value.function.name =
944 gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
949 gfc_resolve_not (gfc_expr * f, gfc_expr * i)
952 f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
957 gfc_resolve_pack (gfc_expr * f,
958 gfc_expr * array ATTRIBUTE_UNUSED,
960 gfc_expr * vector ATTRIBUTE_UNUSED)
966 f->value.function.name = PREFIX("pack");
969 /* We convert mask to default logical only in the scalar case.
970 In the array case we can simply read the array as if it were
971 of type default logical. */
972 if (mask->ts.kind != gfc_default_logical_kind)
976 ts.type = BT_LOGICAL;
977 ts.kind = gfc_default_logical_kind;
978 gfc_convert_type (mask, &ts, 2);
981 f->value.function.name = PREFIX("pack_s");
987 gfc_resolve_product (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
994 f->rank = array->rank - 1;
995 gfc_resolve_index (dim, 1);
998 f->value.function.name =
999 gfc_get_string (PREFIX("%s_%c%d"), mask ? "mproduct" : "product",
1000 gfc_type_letter (array->ts.type), array->ts.kind);
1005 gfc_resolve_real (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
1007 f->ts.type = BT_REAL;
1010 f->ts.kind = mpz_get_si (kind->value.integer);
1012 f->ts.kind = (a->ts.type == BT_COMPLEX) ?
1013 a->ts.kind : gfc_default_real_kind;
1015 f->value.function.name =
1016 gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1017 gfc_type_letter (a->ts.type), a->ts.kind);
1022 gfc_resolve_repeat (gfc_expr * f, gfc_expr * string,
1023 gfc_expr * ncopies ATTRIBUTE_UNUSED)
1025 f->ts.type = BT_CHARACTER;
1026 f->ts.kind = string->ts.kind;
1027 f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
1032 gfc_resolve_reshape (gfc_expr * f, gfc_expr * source, gfc_expr * shape,
1033 gfc_expr * pad ATTRIBUTE_UNUSED,
1034 gfc_expr * order ATTRIBUTE_UNUSED)
1042 gfc_array_size (shape, &rank);
1043 f->rank = mpz_get_si (rank);
1045 switch (source->ts.type)
1048 kind = source->ts.kind * 2;
1054 kind = source->ts.kind;
1067 f->value.function.name =
1068 gfc_get_string (PREFIX("reshape_%d"), source->ts.kind);
1072 f->value.function.name = PREFIX("reshape");
1076 /* TODO: Make this work with a constant ORDER parameter. */
1077 if (shape->expr_type == EXPR_ARRAY
1078 && gfc_is_constant_expr (shape)
1082 f->shape = gfc_get_shape (f->rank);
1083 c = shape->value.constructor;
1084 for (i = 0; i < f->rank; i++)
1086 mpz_init_set (f->shape[i], c->expr->value.integer);
1091 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
1092 so many runtime variations. */
1093 if (shape->ts.kind != gfc_index_integer_kind)
1095 gfc_typespec ts = shape->ts;
1096 ts.kind = gfc_index_integer_kind;
1097 gfc_convert_type_warn (shape, &ts, 2, 0);
1099 if (order && order->ts.kind != gfc_index_integer_kind)
1100 gfc_convert_type_warn (order, &shape->ts, 2, 0);
1105 gfc_resolve_rrspacing (gfc_expr * f, gfc_expr * x)
1108 f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
1113 gfc_resolve_scale (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1117 /* The implementation calls scalbn which takes an int as the
1119 if (i->ts.kind != gfc_c_int_kind)
1123 ts.type = BT_INTEGER;
1124 ts.kind = gfc_default_integer_kind;
1126 gfc_convert_type_warn (i, &ts, 2, 0);
1129 f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
1134 gfc_resolve_scan (gfc_expr * f, gfc_expr * string,
1135 gfc_expr * set ATTRIBUTE_UNUSED,
1136 gfc_expr * back ATTRIBUTE_UNUSED)
1138 f->ts.type = BT_INTEGER;
1139 f->ts.kind = gfc_default_integer_kind;
1140 f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
1145 gfc_resolve_set_exponent (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1149 /* The library implementation uses GFC_INTEGER_4 unconditionally,
1150 convert type so we don't have to implement all possible
1152 if (i->ts.kind != 4)
1156 ts.type = BT_INTEGER;
1157 ts.kind = gfc_default_integer_kind;
1159 gfc_convert_type_warn (i, &ts, 2, 0);
1162 f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
1167 gfc_resolve_shape (gfc_expr * f, gfc_expr * array)
1169 f->ts.type = BT_INTEGER;
1170 f->ts.kind = gfc_default_integer_kind;
1172 f->value.function.name = gfc_get_string (PREFIX("shape_%d"), f->ts.kind);
1173 f->shape = gfc_get_shape (1);
1174 mpz_init_set_ui (f->shape[0], array->rank);
1179 gfc_resolve_sign (gfc_expr * f, gfc_expr * a, gfc_expr * b ATTRIBUTE_UNUSED)
1182 f->value.function.name =
1183 gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
1188 gfc_resolve_sin (gfc_expr * f, gfc_expr * x)
1191 f->value.function.name =
1192 gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1197 gfc_resolve_sinh (gfc_expr * f, gfc_expr * x)
1200 f->value.function.name =
1201 gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1206 gfc_resolve_spacing (gfc_expr * f, gfc_expr * x)
1209 f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
1214 gfc_resolve_spread (gfc_expr * f, gfc_expr * source,
1219 f->rank = source->rank + 1;
1220 f->value.function.name = PREFIX("spread");
1222 gfc_resolve_index (dim, 1);
1223 gfc_resolve_index (ncopies, 1);
1228 gfc_resolve_sqrt (gfc_expr * f, gfc_expr * x)
1231 f->value.function.name =
1232 gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1236 /* Resolve the g77 compatibility function STAT AND FSTAT. */
1239 gfc_resolve_stat (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED,
1240 gfc_expr * a ATTRIBUTE_UNUSED)
1242 f->ts.type = BT_INTEGER;
1243 f->ts.kind = gfc_default_integer_kind;
1244 f->value.function.name = gfc_get_string (PREFIX("stat_i%d"), f->ts.kind);
1249 gfc_resolve_fstat (gfc_expr * f, gfc_expr * n, gfc_expr * a ATTRIBUTE_UNUSED)
1251 f->ts.type = BT_INTEGER;
1252 f->ts.kind = gfc_default_integer_kind;
1253 if (n->ts.kind != f->ts.kind)
1254 gfc_convert_type (n, &f->ts, 2);
1256 f->value.function.name = gfc_get_string (PREFIX("fstat_i%d"), f->ts.kind);
1261 gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1268 f->rank = array->rank - 1;
1269 gfc_resolve_index (dim, 1);
1272 f->value.function.name =
1273 gfc_get_string (PREFIX("%s_%c%d"), mask ? "msum" : "sum",
1274 gfc_type_letter (array->ts.type), array->ts.kind);
1278 /* Resolve the g77 compatibility function SYSTEM. */
1281 gfc_resolve_system (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
1283 f->ts.type = BT_INTEGER;
1285 f->value.function.name = gfc_get_string (PREFIX("system"));
1290 gfc_resolve_tan (gfc_expr * f, gfc_expr * x)
1293 f->value.function.name =
1294 gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1299 gfc_resolve_tanh (gfc_expr * f, gfc_expr * x)
1302 f->value.function.name =
1303 gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1308 gfc_resolve_transfer (gfc_expr * f, gfc_expr * source ATTRIBUTE_UNUSED,
1309 gfc_expr * mold, gfc_expr * size)
1311 /* TODO: Make this do something meaningful. */
1312 static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
1316 if (size == NULL && mold->rank == 0)
1319 f->value.function.name = transfer0;
1324 f->value.function.name = transfer1;
1330 gfc_resolve_transpose (gfc_expr * f, gfc_expr * matrix)
1338 f->shape = gfc_get_shape (2);
1339 mpz_init_set (f->shape[0], matrix->shape[1]);
1340 mpz_init_set (f->shape[1], matrix->shape[0]);
1343 kind = matrix->ts.kind;
1349 switch (matrix->ts.type)
1352 f->value.function.name =
1353 gfc_get_string (PREFIX("transpose_c%d"), kind);
1359 /* Use the integer routines for real and logical cases. This
1360 assumes they all have the same alignment requirements. */
1361 f->value.function.name =
1362 gfc_get_string (PREFIX("transpose_i%d"), kind);
1366 f->value.function.name = PREFIX("transpose");
1372 f->value.function.name = PREFIX("transpose");
1378 gfc_resolve_trim (gfc_expr * f, gfc_expr * string)
1380 f->ts.type = BT_CHARACTER;
1381 f->ts.kind = string->ts.kind;
1382 f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
1387 gfc_resolve_ubound (gfc_expr * f, gfc_expr * array,
1390 static char ubound[] = "__ubound";
1392 f->ts.type = BT_INTEGER;
1393 f->ts.kind = gfc_default_integer_kind;
1398 f->shape = gfc_get_shape (1);
1399 mpz_init_set_ui (f->shape[0], array->rank);
1402 f->value.function.name = ubound;
1406 /* Resolve the g77 compatibility function UMASK. */
1409 gfc_resolve_umask (gfc_expr * f, gfc_expr * n)
1411 f->ts.type = BT_INTEGER;
1412 f->ts.kind = n->ts.kind;
1413 f->value.function.name = gfc_get_string (PREFIX("umask_i%d"), n->ts.kind);
1417 /* Resolve the g77 compatibility function UNLINK. */
1420 gfc_resolve_unlink (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
1422 f->ts.type = BT_INTEGER;
1424 f->value.function.name = gfc_get_string (PREFIX("unlink"));
1428 gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask,
1429 gfc_expr * field ATTRIBUTE_UNUSED)
1431 f->ts.type = vector->ts.type;
1432 f->ts.kind = vector->ts.kind;
1433 f->rank = mask->rank;
1435 f->value.function.name =
1436 gfc_get_string (PREFIX("unpack%d"), field->rank > 0 ? 1 : 0);
1441 gfc_resolve_verify (gfc_expr * f, gfc_expr * string,
1442 gfc_expr * set ATTRIBUTE_UNUSED,
1443 gfc_expr * back ATTRIBUTE_UNUSED)
1445 f->ts.type = BT_INTEGER;
1446 f->ts.kind = gfc_default_integer_kind;
1447 f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
1451 /* Intrinsic subroutine resolution. */
1454 gfc_resolve_cpu_time (gfc_code * c ATTRIBUTE_UNUSED)
1458 name = gfc_get_string (PREFIX("cpu_time_%d"),
1459 c->ext.actual->expr->ts.kind);
1460 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1465 gfc_resolve_mvbits (gfc_code * c)
1470 kind = c->ext.actual->expr->ts.kind;
1471 name = gfc_get_string (PREFIX("mvbits_i%d"), kind);
1473 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1478 gfc_resolve_random_number (gfc_code * c ATTRIBUTE_UNUSED)
1483 kind = c->ext.actual->expr->ts.kind;
1484 if (c->ext.actual->expr->rank == 0)
1485 name = gfc_get_string (PREFIX("random_r%d"), kind);
1487 name = gfc_get_string (PREFIX("arandom_r%d"), kind);
1489 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1493 /* G77 compatibility subroutines etime() and dtime(). */
1496 gfc_resolve_etime_sub (gfc_code * c)
1500 name = gfc_get_string (PREFIX("etime_sub"));
1501 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1505 /* G77 compatibility subroutine second(). */
1508 gfc_resolve_second_sub (gfc_code * c)
1512 name = gfc_get_string (PREFIX("second_sub"));
1513 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1517 /* G77 compatibility function srand(). */
1520 gfc_resolve_srand (gfc_code * c)
1523 name = gfc_get_string (PREFIX("srand"));
1524 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1528 /* Resolve the getarg intrinsic subroutine. */
1531 gfc_resolve_getarg (gfc_code * c)
1536 kind = gfc_default_integer_kind;
1537 name = gfc_get_string (PREFIX("getarg_i%d"), kind);
1538 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1541 /* Resolve the getcwd intrinsic subroutine. */
1544 gfc_resolve_getcwd_sub (gfc_code * c)
1549 if (c->ext.actual->next->expr != NULL)
1550 kind = c->ext.actual->next->expr->ts.kind;
1552 kind = gfc_default_integer_kind;
1554 name = gfc_get_string (PREFIX("getcwd_i%d_sub"), kind);
1555 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1559 /* Resolve the get_command intrinsic subroutine. */
1562 gfc_resolve_get_command (gfc_code * c)
1567 kind = gfc_default_integer_kind;
1568 name = gfc_get_string (PREFIX("get_command_i%d"), kind);
1569 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1573 /* Resolve the get_command_argument intrinsic subroutine. */
1576 gfc_resolve_get_command_argument (gfc_code * c)
1581 kind = gfc_default_integer_kind;
1582 name = gfc_get_string (PREFIX("get_command_argument_i%d"), kind);
1583 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1586 /* Resolve the get_environment_variable intrinsic subroutine. */
1589 gfc_resolve_get_environment_variable (gfc_code * code)
1594 kind = gfc_default_integer_kind;
1595 name = gfc_get_string (PREFIX("get_environment_variable_i%d"), kind);
1596 code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1599 /* Resolve the SYSTEM intrinsic subroutine. */
1602 gfc_resolve_system_sub (gfc_code * c)
1606 name = gfc_get_string (PREFIX("system_sub"));
1607 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1610 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
1613 gfc_resolve_system_clock (gfc_code * c)
1618 if (c->ext.actual->expr != NULL)
1619 kind = c->ext.actual->expr->ts.kind;
1620 else if (c->ext.actual->next->expr != NULL)
1621 kind = c->ext.actual->next->expr->ts.kind;
1622 else if (c->ext.actual->next->next->expr != NULL)
1623 kind = c->ext.actual->next->next->expr->ts.kind;
1625 kind = gfc_default_integer_kind;
1627 name = gfc_get_string (PREFIX("system_clock_%d"), kind);
1628 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1631 /* Resolve the EXIT intrinsic subroutine. */
1634 gfc_resolve_exit (gfc_code * c)
1639 if (c->ext.actual->expr != NULL)
1640 kind = c->ext.actual->expr->ts.kind;
1642 kind = gfc_default_integer_kind;
1644 name = gfc_get_string (PREFIX("exit_i%d"), kind);
1645 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1648 /* Resolve the FLUSH intrinsic subroutine. */
1651 gfc_resolve_flush (gfc_code * c)
1657 ts.type = BT_INTEGER;
1658 ts.kind = gfc_default_integer_kind;
1659 n = c->ext.actual->expr;
1661 && n->ts.kind != ts.kind)
1662 gfc_convert_type (n, &ts, 2);
1664 name = gfc_get_string (PREFIX("flush_i%d"), ts.kind);
1665 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1668 /* Resolve the STAT and FSTAT intrinsic subroutines. */
1671 gfc_resolve_stat_sub (gfc_code * c)
1675 name = gfc_get_string (PREFIX("stat_i%d_sub"), gfc_default_integer_kind);
1676 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1681 gfc_resolve_fstat_sub (gfc_code * c)
1687 u = c->ext.actual->expr;
1688 ts = &c->ext.actual->next->expr->ts;
1689 if (u->ts.kind != ts->kind)
1690 gfc_convert_type (u, ts, 2);
1691 name = gfc_get_string (PREFIX("fstat_i%d_sub"), ts->kind);
1692 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1695 /* Resolve the UMASK intrinsic subroutine. */
1698 gfc_resolve_umask_sub (gfc_code * c)
1703 if (c->ext.actual->next->expr != NULL)
1704 kind = c->ext.actual->next->expr->ts.kind;
1706 kind = gfc_default_integer_kind;
1708 name = gfc_get_string (PREFIX("umask_i%d_sub"), kind);
1709 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1712 /* Resolve the UNLINK intrinsic subroutine. */
1715 gfc_resolve_unlink_sub (gfc_code * c)
1720 if (c->ext.actual->next->expr != NULL)
1721 kind = c->ext.actual->next->expr->ts.kind;
1723 kind = gfc_default_integer_kind;
1725 name = gfc_get_string (PREFIX("unlink_i%d_sub"), kind);
1726 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);