1 /* Intrinsic function resolution.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004 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. */
36 #include "intrinsic.h"
39 /* String pool subroutines. This are used to provide static locations
40 for the string constants that represent library function names. */
42 typedef struct string_node
44 struct string_node *next;
51 static string_node *string_head[HASH_SIZE];
54 /* Return a hash code based on the name. */
57 hash (const char *name)
63 h = 5311966 * h + *name++;
71 /* Given printf-like arguments, return a static address of the
72 resulting string. If the name is not in the table, it is added. */
75 gfc_get_string (const char *format, ...)
82 va_start (ap, format);
83 vsprintf (temp_name, format, ap);
89 for (p = string_head[h]; p; p = p->next)
90 if (strcmp (p->string, temp_name) == 0)
94 p = gfc_getmem (sizeof (string_node) + strlen (temp_name));
96 strcpy (p->string, temp_name);
98 p->next = string_head[h];
112 for (h = 0; h < HASH_SIZE; h++)
114 for (p = string_head[h]; p; p = q)
123 /********************** Resolution functions **********************/
127 gfc_resolve_abs (gfc_expr * f, gfc_expr * a)
131 if (f->ts.type == BT_COMPLEX)
132 f->ts.type = BT_REAL;
134 f->value.function.name =
135 gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
140 gfc_resolve_acos (gfc_expr * f, gfc_expr * x)
144 f->value.function.name =
145 gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
150 gfc_resolve_aimag (gfc_expr * f, gfc_expr * x)
153 f->ts.type = BT_REAL;
154 f->ts.kind = x->ts.kind;
155 f->value.function.name =
156 gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
161 gfc_resolve_aint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
164 f->ts.type = a->ts.type;
165 f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
167 /* The resolved name is only used for specific intrinsics where
168 the return kind is the same as the arg kind. */
169 f->value.function.name =
170 gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
175 gfc_resolve_dint (gfc_expr * f, gfc_expr * a)
177 gfc_resolve_aint (f, a, NULL);
182 gfc_resolve_all (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
189 gfc_resolve_index (dim, 1);
190 f->rank = mask->rank - 1;
193 f->value.function.name =
194 gfc_get_string ("__all_%c%d", gfc_type_letter (mask->ts.type),
200 gfc_resolve_anint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
203 f->ts.type = a->ts.type;
204 f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
206 /* The resolved name is only used for specific intrinsics where
207 the return kind is the same as the arg kind. */
208 f->value.function.name =
209 gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
214 gfc_resolve_dnint (gfc_expr * f, gfc_expr * a)
216 gfc_resolve_anint (f, a, NULL);
221 gfc_resolve_any (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
228 gfc_resolve_index (dim, 1);
229 f->rank = mask->rank - 1;
232 f->value.function.name =
233 gfc_get_string ("__any_%c%d", gfc_type_letter (mask->ts.type),
239 gfc_resolve_asin (gfc_expr * f, gfc_expr * x)
243 f->value.function.name =
244 gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
249 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);
259 gfc_resolve_atan2 (gfc_expr * f, gfc_expr * x,
260 gfc_expr * y ATTRIBUTE_UNUSED)
264 f->value.function.name =
265 gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
270 gfc_resolve_btest (gfc_expr * f, gfc_expr * i, gfc_expr * pos)
273 f->ts.type = BT_LOGICAL;
274 f->ts.kind = gfc_default_logical_kind ();
276 f->value.function.name = gfc_get_string ("__btest_%d_%d", i->ts.kind,
282 gfc_resolve_ceiling (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
285 f->ts.type = BT_INTEGER;
286 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind ()
287 : mpz_get_si (kind->value.integer);
289 f->value.function.name =
290 gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind,
291 gfc_type_letter (a->ts.type), a->ts.kind);
296 gfc_resolve_char (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
299 f->ts.type = BT_CHARACTER;
300 f->ts.kind = (kind == NULL) ? gfc_default_character_kind ()
301 : mpz_get_si (kind->value.integer);
303 f->value.function.name =
304 gfc_get_string ("__char_%d_%c%d", f->ts.kind,
305 gfc_type_letter (a->ts.type), a->ts.kind);
310 gfc_resolve_cmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y, gfc_expr * kind)
313 f->ts.type = BT_COMPLEX;
314 f->ts.kind = (kind == NULL) ? gfc_default_real_kind ()
315 : mpz_get_si (kind->value.integer);
318 f->value.function.name =
319 gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind,
320 gfc_type_letter (x->ts.type), x->ts.kind);
322 f->value.function.name =
323 gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
324 gfc_type_letter (x->ts.type), x->ts.kind,
325 gfc_type_letter (y->ts.type), y->ts.kind);
329 gfc_resolve_dcmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y)
331 gfc_resolve_cmplx (f, x, y, gfc_int_expr (gfc_default_double_kind ()));
335 gfc_resolve_conjg (gfc_expr * f, gfc_expr * x)
339 f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind);
344 gfc_resolve_cos (gfc_expr * f, gfc_expr * x)
348 f->value.function.name =
349 gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
354 gfc_resolve_cosh (gfc_expr * f, gfc_expr * x)
358 f->value.function.name =
359 gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
364 gfc_resolve_count (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
367 f->ts.type = BT_INTEGER;
368 f->ts.kind = gfc_default_integer_kind ();
372 f->rank = mask->rank - 1;
373 gfc_resolve_index (dim, 1);
376 f->value.function.name =
377 gfc_get_string ("__count_%d_%c%d", f->ts.kind,
378 gfc_type_letter (mask->ts.type), mask->ts.kind);
383 gfc_resolve_cshift (gfc_expr * f, gfc_expr * array,
390 f->rank = array->rank;
399 gfc_resolve_index (dim, 1);
400 /* Convert dim to shift's kind, so we don't need so many variations. */
401 if (dim->ts.kind != shift->ts.kind)
402 gfc_convert_type (dim, &shift->ts, 2);
404 f->value.function.name =
405 gfc_get_string ("__cshift%d_%d", n, shift->ts.kind);
410 gfc_resolve_dble (gfc_expr * f, gfc_expr * a)
413 f->ts.type = BT_REAL;
414 f->ts.kind = gfc_default_double_kind ();
415 f->value.function.name =
416 gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
421 gfc_resolve_dim (gfc_expr * f, gfc_expr * x,
422 gfc_expr * y ATTRIBUTE_UNUSED)
426 f->value.function.name =
427 gfc_get_string ("__dim_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
432 gfc_resolve_dot_product (gfc_expr * f, gfc_expr * a, gfc_expr * b)
436 if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
438 f->ts.type = BT_LOGICAL;
439 f->ts.kind = gfc_default_logical_kind ();
443 temp.expr_type = EXPR_OP;
444 gfc_clear_ts (&temp.ts);
445 temp.operator = INTRINSIC_NONE;
448 gfc_type_convert_binary (&temp);
452 f->value.function.name =
453 gfc_get_string ("__dot_product_%c%d", gfc_type_letter (f->ts.type),
459 gfc_resolve_dprod (gfc_expr * f,
460 gfc_expr * a ATTRIBUTE_UNUSED,
461 gfc_expr * b ATTRIBUTE_UNUSED)
463 f->ts.kind = gfc_default_double_kind ();
464 f->ts.type = BT_REAL;
466 f->value.function.name = gfc_get_string ("__dprod_r%d", f->ts.kind);
471 gfc_resolve_eoshift (gfc_expr * f, gfc_expr * array,
479 f->rank = array->rank;
484 if (boundary && boundary->rank > 0)
487 /* Convert dim to the same type as shift, so we don't need quite so many
489 if (dim != NULL && dim->ts.kind != shift->ts.kind)
490 gfc_convert_type (dim, &shift->ts, 2);
492 f->value.function.name =
493 gfc_get_string ("__eoshift%d_%d", n, shift->ts.kind);
498 gfc_resolve_exp (gfc_expr * f, gfc_expr * x)
502 f->value.function.name =
503 gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
508 gfc_resolve_exponent (gfc_expr * f, gfc_expr * x)
511 f->ts.type = BT_INTEGER;
512 f->ts.kind = gfc_default_integer_kind ();
514 f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind);
519 gfc_resolve_floor (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
522 f->ts.type = BT_INTEGER;
523 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind ()
524 : mpz_get_si (kind->value.integer);
526 f->value.function.name =
527 gfc_get_string ("__floor%d_%c%d", f->ts.kind,
528 gfc_type_letter (a->ts.type), a->ts.kind);
533 gfc_resolve_fraction (gfc_expr * f, gfc_expr * x)
537 f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind);
542 gfc_resolve_iand (gfc_expr * f, gfc_expr * i, gfc_expr * j ATTRIBUTE_UNUSED)
546 f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind);
551 gfc_resolve_ibclr (gfc_expr * f, gfc_expr * i, gfc_expr * pos ATTRIBUTE_UNUSED)
555 f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind);
560 gfc_resolve_ibits (gfc_expr * f, gfc_expr * i,
561 gfc_expr * pos ATTRIBUTE_UNUSED,
562 gfc_expr * len ATTRIBUTE_UNUSED)
566 f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind);
571 gfc_resolve_ibset (gfc_expr * f, gfc_expr * i,
572 gfc_expr * pos ATTRIBUTE_UNUSED)
576 f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind);
581 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,
600 gfc_expr * j ATTRIBUTE_UNUSED)
604 f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind);
609 gfc_resolve_ior (gfc_expr * f, gfc_expr * i,
610 gfc_expr * j ATTRIBUTE_UNUSED)
614 f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind);
619 gfc_resolve_int (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
622 f->ts.type = BT_INTEGER;
623 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind ()
624 : mpz_get_si (kind->value.integer);
626 f->value.function.name =
627 gfc_get_string ("__int_%d_%c%d", f->ts.kind, gfc_type_letter (a->ts.type),
633 gfc_resolve_ishft (gfc_expr * f, gfc_expr * i, gfc_expr * shift)
637 f->value.function.name =
638 gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
643 gfc_resolve_ishftc (gfc_expr * f, gfc_expr * i, gfc_expr * shift,
648 s_kind = (size == NULL) ? gfc_default_integer_kind () : shift->ts.kind;
651 f->value.function.name =
652 gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
657 gfc_resolve_lbound (gfc_expr * f, gfc_expr * array ATTRIBUTE_UNUSED,
660 static char lbound[] = "__lbound";
662 f->ts.type = BT_INTEGER;
663 f->ts.kind = gfc_default_integer_kind ();
665 f->rank = (dim == NULL) ? 1 : 0;
666 f->value.function.name = lbound;
671 gfc_resolve_len (gfc_expr * f, gfc_expr * string)
674 f->ts.type = BT_INTEGER;
675 f->ts.kind = gfc_default_integer_kind ();
676 f->value.function.name = gfc_get_string ("__len_%d", string->ts.kind);
681 gfc_resolve_len_trim (gfc_expr * f, gfc_expr * string)
684 f->ts.type = BT_INTEGER;
685 f->ts.kind = gfc_default_integer_kind ();
686 f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
691 gfc_resolve_log (gfc_expr * f, gfc_expr * x)
695 f->value.function.name =
696 gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
701 gfc_resolve_log10 (gfc_expr * f, gfc_expr * x)
705 f->value.function.name =
706 gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
711 gfc_resolve_logical (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
714 f->ts.type = BT_LOGICAL;
715 f->ts.kind = (kind == NULL) ? gfc_default_logical_kind ()
716 : mpz_get_si (kind->value.integer);
719 f->value.function.name =
720 gfc_get_string ("__logical_%d_%c%d", f->ts.kind,
721 gfc_type_letter (a->ts.type), a->ts.kind);
726 gfc_resolve_matmul (gfc_expr * f, gfc_expr * a, gfc_expr * b)
730 if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
732 f->ts.type = BT_LOGICAL;
733 f->ts.kind = gfc_default_logical_kind ();
737 temp.expr_type = EXPR_OP;
738 gfc_clear_ts (&temp.ts);
739 temp.operator = INTRINSIC_NONE;
742 gfc_type_convert_binary (&temp);
746 f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
748 f->value.function.name =
749 gfc_get_string ("__matmul_%c%d", gfc_type_letter (f->ts.type),
755 gfc_resolve_minmax (const char * name, gfc_expr * f, gfc_actual_arglist * args)
757 gfc_actual_arglist *a;
759 f->ts.type = args->expr->ts.type;
760 f->ts.kind = args->expr->ts.kind;
761 /* Find the largest type kind. */
762 for (a = args->next; a; a = a->next)
764 if (a->expr->ts.kind > f->ts.kind)
765 f->ts.kind = a->expr->ts.kind;
768 /* Convert all parameters to the required kind. */
769 for (a = args; a; a = a->next)
771 if (a->expr->ts.kind != f->ts.kind)
772 gfc_convert_type (a->expr, &f->ts, 2);
775 f->value.function.name =
776 gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind);
781 gfc_resolve_max (gfc_expr * f, gfc_actual_arglist * args)
783 gfc_resolve_minmax ("__max_%c%d", f, args);
788 gfc_resolve_maxloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
793 f->ts.type = BT_INTEGER;
794 f->ts.kind = gfc_default_integer_kind ();
800 f->rank = array->rank - 1;
801 gfc_resolve_index (dim, 1);
804 name = mask ? "mmaxloc" : "maxloc";
805 f->value.function.name =
806 gfc_get_string ("__%s%d_%d_%c%d", name, dim != NULL, f->ts.kind,
807 gfc_type_letter (array->ts.type), array->ts.kind);
812 gfc_resolve_maxval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
820 f->rank = array->rank - 1;
821 gfc_resolve_index (dim, 1);
824 f->value.function.name =
825 gfc_get_string ("__%s_%c%d", mask ? "mmaxval" : "maxval",
826 gfc_type_letter (array->ts.type), array->ts.kind);
831 gfc_resolve_merge (gfc_expr * f, gfc_expr * tsource,
832 gfc_expr * fsource ATTRIBUTE_UNUSED,
833 gfc_expr * mask ATTRIBUTE_UNUSED)
837 f->value.function.name =
838 gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
844 gfc_resolve_min (gfc_expr * f, gfc_actual_arglist * args)
846 gfc_resolve_minmax ("__min_%c%d", f, args);
851 gfc_resolve_minloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
856 f->ts.type = BT_INTEGER;
857 f->ts.kind = gfc_default_integer_kind ();
863 f->rank = array->rank - 1;
864 gfc_resolve_index (dim, 1);
867 name = mask ? "mminloc" : "minloc";
868 f->value.function.name =
869 gfc_get_string ("__%s%d_%d_%c%d", name, dim != NULL, f->ts.kind,
870 gfc_type_letter (array->ts.type), array->ts.kind);
874 gfc_resolve_minval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
882 f->rank = array->rank - 1;
883 gfc_resolve_index (dim, 1);
886 f->value.function.name =
887 gfc_get_string ("__%s_%c%d", mask ? "mminval" : "minval",
888 gfc_type_letter (array->ts.type), array->ts.kind);
893 gfc_resolve_mod (gfc_expr * f, gfc_expr * a,
894 gfc_expr * p ATTRIBUTE_UNUSED)
898 f->value.function.name =
899 gfc_get_string ("__mod_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
904 gfc_resolve_modulo (gfc_expr * f, gfc_expr * a,
905 gfc_expr * p ATTRIBUTE_UNUSED)
909 f->value.function.name =
910 gfc_get_string ("__modulo_%c%d", gfc_type_letter (a->ts.type),
915 gfc_resolve_nearest (gfc_expr * f, gfc_expr * a,
916 gfc_expr *p ATTRIBUTE_UNUSED)
920 f->value.function.name =
921 gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
926 gfc_resolve_nint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
929 f->ts.type = BT_INTEGER;
930 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind ()
931 : mpz_get_si (kind->value.integer);
933 f->value.function.name =
934 gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
939 gfc_resolve_not (gfc_expr * f, gfc_expr * i)
943 f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
948 gfc_resolve_pack (gfc_expr * f,
949 gfc_expr * array ATTRIBUTE_UNUSED,
950 gfc_expr * mask ATTRIBUTE_UNUSED,
951 gfc_expr * vector ATTRIBUTE_UNUSED)
953 static char pack[] = "__pack";
958 f->value.function.name = pack;
963 gfc_resolve_product (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
971 f->rank = array->rank - 1;
972 gfc_resolve_index (dim, 1);
975 f->value.function.name =
976 gfc_get_string ("__%s_%c%d", mask ? "mproduct" : "product",
977 gfc_type_letter (array->ts.type), array->ts.kind);
982 gfc_resolve_real (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
985 f->ts.type = BT_REAL;
988 f->ts.kind = mpz_get_si (kind->value.integer);
990 f->ts.kind = (a->ts.type == BT_COMPLEX) ?
991 a->ts.kind : gfc_default_real_kind ();
993 f->value.function.name =
994 gfc_get_string ("__real_%d_%c%d", f->ts.kind,
995 gfc_type_letter (a->ts.type), a->ts.kind);
1000 gfc_resolve_repeat (gfc_expr * f, gfc_expr * string,
1001 gfc_expr * ncopies ATTRIBUTE_UNUSED)
1004 f->ts.type = BT_CHARACTER;
1005 f->ts.kind = string->ts.kind;
1006 f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
1011 gfc_resolve_reshape (gfc_expr * f, gfc_expr * source, gfc_expr * shape,
1012 gfc_expr * pad ATTRIBUTE_UNUSED,
1013 gfc_expr * order ATTRIBUTE_UNUSED)
1015 static char reshape0[] = "__reshape";
1022 gfc_array_size (shape, &rank);
1023 f->rank = mpz_get_si (rank);
1025 switch (source->ts.type)
1028 kind = source->ts.kind * 2;
1034 kind = source->ts.kind;
1047 f->value.function.name =
1048 gfc_get_string ("__reshape_%d", source->ts.kind);
1052 f->value.function.name = reshape0;
1056 /* TODO: Make this work with a constant ORDER parameter. */
1057 if (shape->expr_type == EXPR_ARRAY
1058 && gfc_is_constant_expr (shape)
1062 f->shape = gfc_get_shape (f->rank);
1063 c = shape->value.constructor;
1064 for (i = 0; i < f->rank; i++)
1066 mpz_init_set (f->shape[i], c->expr->value.integer);
1074 gfc_resolve_rrspacing (gfc_expr * f, gfc_expr * x)
1078 f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
1083 gfc_resolve_scale (gfc_expr * f, gfc_expr * x,
1084 gfc_expr * y ATTRIBUTE_UNUSED)
1088 f->value.function.name = gfc_get_string ("__scale_%d_%d", x->ts.kind,
1094 gfc_resolve_scan (gfc_expr * f, gfc_expr * string,
1095 gfc_expr * set ATTRIBUTE_UNUSED,
1096 gfc_expr * back ATTRIBUTE_UNUSED)
1099 f->ts.type = BT_INTEGER;
1100 f->ts.kind = gfc_default_integer_kind ();
1101 f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
1106 gfc_resolve_set_exponent (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1110 f->value.function.name =
1111 gfc_get_string ("__set_exponent_%d_%d", x->ts.kind, i->ts.kind);
1116 gfc_resolve_shape (gfc_expr * f, gfc_expr * array)
1119 f->ts.type = BT_INTEGER;
1120 f->ts.kind = gfc_default_integer_kind ();
1122 f->value.function.name = gfc_get_string ("__shape_%d", f->ts.kind);
1123 f->shape = gfc_get_shape (1);
1124 mpz_init_set_ui (f->shape[0], array->rank);
1129 gfc_resolve_sign (gfc_expr * f, gfc_expr * a, gfc_expr * b ATTRIBUTE_UNUSED)
1133 f->value.function.name =
1134 gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
1139 gfc_resolve_sin (gfc_expr * f, gfc_expr * x)
1143 f->value.function.name =
1144 gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1149 gfc_resolve_sinh (gfc_expr * f, gfc_expr * x)
1153 f->value.function.name =
1154 gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1159 gfc_resolve_spacing (gfc_expr * f, gfc_expr * x)
1163 f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
1168 gfc_resolve_spread (gfc_expr * f, gfc_expr * source,
1172 static char spread[] = "__spread";
1175 f->rank = source->rank + 1;
1176 f->value.function.name = spread;
1178 gfc_resolve_index (dim, 1);
1179 gfc_resolve_index (ncopies, 1);
1184 gfc_resolve_sqrt (gfc_expr * f, gfc_expr * x)
1188 f->value.function.name =
1189 gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1194 gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1202 f->rank = array->rank - 1;
1203 gfc_resolve_index (dim, 1);
1206 f->value.function.name =
1207 gfc_get_string ("__%s_%c%d", mask ? "msum" : "sum",
1208 gfc_type_letter (array->ts.type), array->ts.kind);
1213 gfc_resolve_tan (gfc_expr * f, gfc_expr * x)
1217 f->value.function.name =
1218 gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1223 gfc_resolve_tanh (gfc_expr * f, gfc_expr * x)
1227 f->value.function.name =
1228 gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1233 gfc_resolve_transfer (gfc_expr * f, gfc_expr * source ATTRIBUTE_UNUSED,
1234 gfc_expr * mold, gfc_expr * size)
1236 /* TODO: Make this do something meaningful. */
1237 static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
1241 if (size == NULL && mold->rank == 0)
1244 f->value.function.name = transfer0;
1249 f->value.function.name = transfer1;
1255 gfc_resolve_transpose (gfc_expr * f, gfc_expr * matrix)
1257 static char transpose0[] = "__transpose";
1263 switch (matrix->ts.type)
1266 kind = matrix->ts.kind * 2;
1272 kind = matrix->ts.kind;
1286 f->value.function.name =
1287 gfc_get_string ("__transpose_%d", kind);
1291 f->value.function.name = transpose0;
1297 gfc_resolve_trim (gfc_expr * f, gfc_expr * string)
1300 f->ts.type = BT_CHARACTER;
1301 f->ts.kind = string->ts.kind;
1302 f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
1307 gfc_resolve_ubound (gfc_expr * f, gfc_expr * array ATTRIBUTE_UNUSED,
1310 static char ubound[] = "__ubound";
1312 f->ts.type = BT_INTEGER;
1313 f->ts.kind = gfc_default_integer_kind ();
1315 f->rank = (dim == NULL) ? 1 : 0;
1316 f->value.function.name = ubound;
1321 gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask,
1322 gfc_expr * field ATTRIBUTE_UNUSED)
1325 f->ts.type = vector->ts.type;
1326 f->ts.kind = vector->ts.kind;
1327 f->rank = mask->rank;
1329 f->value.function.name =
1330 gfc_get_string ("__unpack%d", field->rank > 0 ? 1 : 0);
1335 gfc_resolve_verify (gfc_expr * f, gfc_expr * string,
1336 gfc_expr * set ATTRIBUTE_UNUSED,
1337 gfc_expr * back ATTRIBUTE_UNUSED)
1340 f->ts.type = BT_INTEGER;
1341 f->ts.kind = gfc_default_integer_kind ();
1342 f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
1346 /* Intrinsic subroutine resolution. */
1349 gfc_resolve_cpu_time (gfc_code * c ATTRIBUTE_UNUSED)
1353 name = gfc_get_string (PREFIX("cpu_time_%d"),
1354 c->ext.actual->expr->ts.kind);
1355 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1360 gfc_resolve_random_number (gfc_code * c ATTRIBUTE_UNUSED)
1365 kind = c->ext.actual->expr->ts.kind;
1366 name = gfc_get_string ((c->ext.actual->expr->rank == 0) ?
1367 PREFIX("random_r%d") : PREFIX("arandom_r%d"),
1369 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1372 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
1375 gfc_resolve_system_clock (gfc_code * c)
1380 if (c->ext.actual->expr != NULL)
1381 kind = c->ext.actual->expr->ts.kind;
1382 else if (c->ext.actual->next->expr != NULL)
1383 kind = c->ext.actual->next->expr->ts.kind;
1384 else if (c->ext.actual->next->next->expr != NULL)
1385 kind = c->ext.actual->next->next->expr->ts.kind;
1387 kind = gfc_default_integer_kind ();
1389 name = gfc_get_string (PREFIX("system_clock_%d"), kind);
1390 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1395 gfc_iresolve_init_1 (void)
1399 for (i = 0; i < HASH_SIZE; i++)
1400 string_head[i] = NULL;
1405 gfc_iresolve_done_1 (void)