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. */
37 #include "intrinsic.h"
40 /* String pool subroutines. This are used to provide static locations
41 for the string constants that represent library function names. */
43 typedef struct string_node
45 struct string_node *next;
52 static string_node *string_head[HASH_SIZE];
55 /* Return a hash code based on the name. */
58 hash (const char *name)
64 h = 5311966 * h + *name++;
72 /* Given printf-like arguments, return a static address of the
73 resulting string. If the name is not in the table, it is added. */
76 gfc_get_string (const char *format, ...)
83 va_start (ap, format);
84 vsprintf (temp_name, format, ap);
90 for (p = string_head[h]; p; p = p->next)
91 if (strcmp (p->string, temp_name) == 0)
95 p = gfc_getmem (sizeof (string_node) + strlen (temp_name));
97 strcpy (p->string, temp_name);
99 p->next = string_head[h];
113 for (h = 0; h < HASH_SIZE; h++)
115 for (p = string_head[h]; p; p = q)
124 /********************** Resolution functions **********************/
128 gfc_resolve_abs (gfc_expr * f, gfc_expr * a)
132 if (f->ts.type == BT_COMPLEX)
133 f->ts.type = BT_REAL;
135 f->value.function.name =
136 gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
141 gfc_resolve_acos (gfc_expr * f, gfc_expr * x)
145 f->value.function.name =
146 gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
151 gfc_resolve_aimag (gfc_expr * f, gfc_expr * x)
154 f->ts.type = BT_REAL;
155 f->ts.kind = x->ts.kind;
156 f->value.function.name =
157 gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
162 gfc_resolve_aint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
165 f->ts.type = a->ts.type;
166 f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
168 /* The resolved name is only used for specific intrinsics where
169 the return kind is the same as the arg kind. */
170 f->value.function.name =
171 gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
176 gfc_resolve_dint (gfc_expr * f, gfc_expr * a)
178 gfc_resolve_aint (f, a, NULL);
183 gfc_resolve_all (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
190 gfc_resolve_index (dim, 1);
191 f->rank = mask->rank - 1;
192 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
195 f->value.function.name =
196 gfc_get_string ("__all_%c%d", gfc_type_letter (mask->ts.type),
202 gfc_resolve_anint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
205 f->ts.type = a->ts.type;
206 f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
208 /* The resolved name is only used for specific intrinsics where
209 the return kind is the same as the arg kind. */
210 f->value.function.name =
211 gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
216 gfc_resolve_dnint (gfc_expr * f, gfc_expr * a)
218 gfc_resolve_anint (f, a, NULL);
223 gfc_resolve_any (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
230 gfc_resolve_index (dim, 1);
231 f->rank = mask->rank - 1;
232 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
235 f->value.function.name =
236 gfc_get_string ("__any_%c%d", gfc_type_letter (mask->ts.type),
242 gfc_resolve_asin (gfc_expr * f, gfc_expr * x)
246 f->value.function.name =
247 gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
252 gfc_resolve_atan (gfc_expr * f, gfc_expr * x)
256 f->value.function.name =
257 gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
262 gfc_resolve_atan2 (gfc_expr * f, gfc_expr * x,
263 gfc_expr * y ATTRIBUTE_UNUSED)
267 f->value.function.name =
268 gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
273 gfc_resolve_btest (gfc_expr * f, gfc_expr * i, gfc_expr * pos)
276 f->ts.type = BT_LOGICAL;
277 f->ts.kind = gfc_default_logical_kind;
279 f->value.function.name = gfc_get_string ("__btest_%d_%d", i->ts.kind,
285 gfc_resolve_ceiling (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
288 f->ts.type = BT_INTEGER;
289 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
290 : mpz_get_si (kind->value.integer);
292 f->value.function.name =
293 gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind,
294 gfc_type_letter (a->ts.type), a->ts.kind);
299 gfc_resolve_char (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
302 f->ts.type = BT_CHARACTER;
303 f->ts.kind = (kind == NULL) ? gfc_default_character_kind
304 : mpz_get_si (kind->value.integer);
306 f->value.function.name =
307 gfc_get_string ("__char_%d_%c%d", f->ts.kind,
308 gfc_type_letter (a->ts.type), a->ts.kind);
313 gfc_resolve_cmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y, gfc_expr * kind)
316 f->ts.type = BT_COMPLEX;
317 f->ts.kind = (kind == NULL) ? gfc_default_real_kind
318 : mpz_get_si (kind->value.integer);
321 f->value.function.name =
322 gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind,
323 gfc_type_letter (x->ts.type), x->ts.kind);
325 f->value.function.name =
326 gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
327 gfc_type_letter (x->ts.type), x->ts.kind,
328 gfc_type_letter (y->ts.type), y->ts.kind);
332 gfc_resolve_dcmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y)
334 gfc_resolve_cmplx (f, x, y, gfc_int_expr (gfc_default_double_kind));
338 gfc_resolve_conjg (gfc_expr * f, gfc_expr * x)
342 f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind);
347 gfc_resolve_cos (gfc_expr * f, gfc_expr * x)
351 f->value.function.name =
352 gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
357 gfc_resolve_cosh (gfc_expr * f, gfc_expr * x)
361 f->value.function.name =
362 gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
367 gfc_resolve_count (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
370 f->ts.type = BT_INTEGER;
371 f->ts.kind = gfc_default_integer_kind;
375 f->rank = mask->rank - 1;
376 gfc_resolve_index (dim, 1);
377 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
380 f->value.function.name =
381 gfc_get_string ("__count_%d_%c%d", f->ts.kind,
382 gfc_type_letter (mask->ts.type), mask->ts.kind);
387 gfc_resolve_cshift (gfc_expr * f, gfc_expr * array,
394 f->rank = array->rank;
395 f->shape = gfc_copy_shape (array->shape, array->rank);
404 gfc_resolve_index (dim, 1);
405 /* Convert dim to shift's kind, so we don't need so many variations. */
406 if (dim->ts.kind != shift->ts.kind)
407 gfc_convert_type (dim, &shift->ts, 2);
409 f->value.function.name =
410 gfc_get_string ("__cshift%d_%d", n, shift->ts.kind);
415 gfc_resolve_dble (gfc_expr * f, gfc_expr * a)
418 f->ts.type = BT_REAL;
419 f->ts.kind = gfc_default_double_kind;
420 f->value.function.name =
421 gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
426 gfc_resolve_dim (gfc_expr * f, gfc_expr * x,
427 gfc_expr * y ATTRIBUTE_UNUSED)
431 f->value.function.name =
432 gfc_get_string ("__dim_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
437 gfc_resolve_dot_product (gfc_expr * f, gfc_expr * a, gfc_expr * b)
441 if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
443 f->ts.type = BT_LOGICAL;
444 f->ts.kind = gfc_default_logical_kind;
448 temp.expr_type = EXPR_OP;
449 gfc_clear_ts (&temp.ts);
450 temp.operator = INTRINSIC_NONE;
453 gfc_type_convert_binary (&temp);
457 f->value.function.name =
458 gfc_get_string ("__dot_product_%c%d", gfc_type_letter (f->ts.type),
464 gfc_resolve_dprod (gfc_expr * f,
465 gfc_expr * a ATTRIBUTE_UNUSED,
466 gfc_expr * b ATTRIBUTE_UNUSED)
468 f->ts.kind = gfc_default_double_kind;
469 f->ts.type = BT_REAL;
471 f->value.function.name = gfc_get_string ("__dprod_r%d", f->ts.kind);
476 gfc_resolve_eoshift (gfc_expr * f, gfc_expr * array,
484 f->rank = array->rank;
485 f->shape = gfc_copy_shape (array->shape, array->rank);
490 if (boundary && boundary->rank > 0)
493 /* Convert dim to the same type as shift, so we don't need quite so many
495 if (dim != NULL && dim->ts.kind != shift->ts.kind)
496 gfc_convert_type (dim, &shift->ts, 2);
498 f->value.function.name =
499 gfc_get_string ("__eoshift%d_%d", n, shift->ts.kind);
504 gfc_resolve_exp (gfc_expr * f, gfc_expr * x)
508 f->value.function.name =
509 gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
514 gfc_resolve_exponent (gfc_expr * f, gfc_expr * x)
517 f->ts.type = BT_INTEGER;
518 f->ts.kind = gfc_default_integer_kind;
520 f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind);
525 gfc_resolve_floor (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
528 f->ts.type = BT_INTEGER;
529 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
530 : mpz_get_si (kind->value.integer);
532 f->value.function.name =
533 gfc_get_string ("__floor%d_%c%d", f->ts.kind,
534 gfc_type_letter (a->ts.type), a->ts.kind);
539 gfc_resolve_fraction (gfc_expr * f, gfc_expr * x)
543 f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind);
548 gfc_resolve_getgid (gfc_expr * f)
550 f->ts.type = BT_INTEGER;
552 f->value.function.name = gfc_get_string (PREFIX("getgid"));
557 gfc_resolve_getpid (gfc_expr * f)
559 f->ts.type = BT_INTEGER;
561 f->value.function.name = gfc_get_string (PREFIX("getpid"));
566 gfc_resolve_getuid (gfc_expr * f)
568 f->ts.type = BT_INTEGER;
570 f->value.function.name = gfc_get_string (PREFIX("getuid"));
574 gfc_resolve_iand (gfc_expr * f, gfc_expr * i, gfc_expr * j ATTRIBUTE_UNUSED)
578 f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind);
583 gfc_resolve_ibclr (gfc_expr * f, gfc_expr * i, gfc_expr * pos ATTRIBUTE_UNUSED)
587 f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind);
592 gfc_resolve_ibits (gfc_expr * f, gfc_expr * i,
593 gfc_expr * pos ATTRIBUTE_UNUSED,
594 gfc_expr * len ATTRIBUTE_UNUSED)
598 f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind);
603 gfc_resolve_ibset (gfc_expr * f, gfc_expr * i,
604 gfc_expr * pos ATTRIBUTE_UNUSED)
608 f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind);
613 gfc_resolve_ichar (gfc_expr * f, gfc_expr * c)
616 f->ts.type = BT_INTEGER;
617 f->ts.kind = gfc_default_integer_kind;
619 f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
624 gfc_resolve_idnint (gfc_expr * f, gfc_expr * a)
626 gfc_resolve_nint (f, a, NULL);
631 gfc_resolve_ieor (gfc_expr * f, gfc_expr * i,
632 gfc_expr * j ATTRIBUTE_UNUSED)
636 f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind);
641 gfc_resolve_ior (gfc_expr * f, gfc_expr * i,
642 gfc_expr * j ATTRIBUTE_UNUSED)
646 f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind);
651 gfc_resolve_int (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
654 f->ts.type = BT_INTEGER;
655 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
656 : mpz_get_si (kind->value.integer);
658 f->value.function.name =
659 gfc_get_string ("__int_%d_%c%d", f->ts.kind, gfc_type_letter (a->ts.type),
665 gfc_resolve_ishft (gfc_expr * f, gfc_expr * i, gfc_expr * shift)
669 f->value.function.name =
670 gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
675 gfc_resolve_ishftc (gfc_expr * f, gfc_expr * i, gfc_expr * shift,
680 s_kind = (size == NULL) ? gfc_default_integer_kind : shift->ts.kind;
683 f->value.function.name =
684 gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
689 gfc_resolve_lbound (gfc_expr * f, gfc_expr * array,
692 static char lbound[] = "__lbound";
694 f->ts.type = BT_INTEGER;
695 f->ts.kind = gfc_default_integer_kind;
700 f->shape = gfc_get_shape (1);
701 mpz_init_set_ui (f->shape[0], array->rank);
704 f->value.function.name = lbound;
709 gfc_resolve_len (gfc_expr * f, gfc_expr * string)
712 f->ts.type = BT_INTEGER;
713 f->ts.kind = gfc_default_integer_kind;
714 f->value.function.name = gfc_get_string ("__len_%d", string->ts.kind);
719 gfc_resolve_len_trim (gfc_expr * f, gfc_expr * string)
722 f->ts.type = BT_INTEGER;
723 f->ts.kind = gfc_default_integer_kind;
724 f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
729 gfc_resolve_log (gfc_expr * f, gfc_expr * x)
733 f->value.function.name =
734 gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
739 gfc_resolve_log10 (gfc_expr * f, gfc_expr * x)
743 f->value.function.name =
744 gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
749 gfc_resolve_logical (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
752 f->ts.type = BT_LOGICAL;
753 f->ts.kind = (kind == NULL) ? gfc_default_logical_kind
754 : mpz_get_si (kind->value.integer);
757 f->value.function.name =
758 gfc_get_string ("__logical_%d_%c%d", f->ts.kind,
759 gfc_type_letter (a->ts.type), a->ts.kind);
764 gfc_resolve_matmul (gfc_expr * f, gfc_expr * a, gfc_expr * b)
768 if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
770 f->ts.type = BT_LOGICAL;
771 f->ts.kind = gfc_default_logical_kind;
775 temp.expr_type = EXPR_OP;
776 gfc_clear_ts (&temp.ts);
777 temp.operator = INTRINSIC_NONE;
780 gfc_type_convert_binary (&temp);
784 f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
786 f->value.function.name =
787 gfc_get_string ("__matmul_%c%d", gfc_type_letter (f->ts.type),
793 gfc_resolve_minmax (const char * name, gfc_expr * f, gfc_actual_arglist * args)
795 gfc_actual_arglist *a;
797 f->ts.type = args->expr->ts.type;
798 f->ts.kind = args->expr->ts.kind;
799 /* Find the largest type kind. */
800 for (a = args->next; a; a = a->next)
802 if (a->expr->ts.kind > f->ts.kind)
803 f->ts.kind = a->expr->ts.kind;
806 /* Convert all parameters to the required kind. */
807 for (a = args; a; a = a->next)
809 if (a->expr->ts.kind != f->ts.kind)
810 gfc_convert_type (a->expr, &f->ts, 2);
813 f->value.function.name =
814 gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind);
819 gfc_resolve_max (gfc_expr * f, gfc_actual_arglist * args)
821 gfc_resolve_minmax ("__max_%c%d", f, args);
826 gfc_resolve_maxloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
831 f->ts.type = BT_INTEGER;
832 f->ts.kind = gfc_default_integer_kind;
838 f->rank = array->rank - 1;
839 gfc_resolve_index (dim, 1);
842 name = mask ? "mmaxloc" : "maxloc";
843 f->value.function.name =
844 gfc_get_string ("__%s%d_%d_%c%d", name, dim != NULL, f->ts.kind,
845 gfc_type_letter (array->ts.type), array->ts.kind);
850 gfc_resolve_maxval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
858 f->rank = array->rank - 1;
859 gfc_resolve_index (dim, 1);
862 f->value.function.name =
863 gfc_get_string ("__%s_%c%d", mask ? "mmaxval" : "maxval",
864 gfc_type_letter (array->ts.type), array->ts.kind);
869 gfc_resolve_merge (gfc_expr * f, gfc_expr * tsource,
870 gfc_expr * fsource ATTRIBUTE_UNUSED,
871 gfc_expr * mask ATTRIBUTE_UNUSED)
875 f->value.function.name =
876 gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
882 gfc_resolve_min (gfc_expr * f, gfc_actual_arglist * args)
884 gfc_resolve_minmax ("__min_%c%d", f, args);
889 gfc_resolve_minloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
894 f->ts.type = BT_INTEGER;
895 f->ts.kind = gfc_default_integer_kind;
901 f->rank = array->rank - 1;
902 gfc_resolve_index (dim, 1);
905 name = mask ? "mminloc" : "minloc";
906 f->value.function.name =
907 gfc_get_string ("__%s%d_%d_%c%d", name, dim != NULL, f->ts.kind,
908 gfc_type_letter (array->ts.type), array->ts.kind);
913 gfc_resolve_minval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
921 f->rank = array->rank - 1;
922 gfc_resolve_index (dim, 1);
925 f->value.function.name =
926 gfc_get_string ("__%s_%c%d", mask ? "mminval" : "minval",
927 gfc_type_letter (array->ts.type), array->ts.kind);
932 gfc_resolve_mod (gfc_expr * f, gfc_expr * a,
933 gfc_expr * p ATTRIBUTE_UNUSED)
937 f->value.function.name =
938 gfc_get_string ("__mod_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
943 gfc_resolve_modulo (gfc_expr * f, gfc_expr * a,
944 gfc_expr * p ATTRIBUTE_UNUSED)
948 f->value.function.name =
949 gfc_get_string ("__modulo_%c%d", gfc_type_letter (a->ts.type),
954 gfc_resolve_nearest (gfc_expr * f, gfc_expr * a,
955 gfc_expr *p ATTRIBUTE_UNUSED)
959 f->value.function.name =
960 gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
965 gfc_resolve_nint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
968 f->ts.type = BT_INTEGER;
969 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
970 : mpz_get_si (kind->value.integer);
972 f->value.function.name =
973 gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
978 gfc_resolve_not (gfc_expr * f, gfc_expr * i)
982 f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
987 gfc_resolve_pack (gfc_expr * f,
988 gfc_expr * array ATTRIBUTE_UNUSED,
989 gfc_expr * mask ATTRIBUTE_UNUSED,
990 gfc_expr * vector ATTRIBUTE_UNUSED)
992 static char pack[] = "__pack";
997 f->value.function.name = pack;
1002 gfc_resolve_product (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1010 f->rank = array->rank - 1;
1011 gfc_resolve_index (dim, 1);
1014 f->value.function.name =
1015 gfc_get_string ("__%s_%c%d", mask ? "mproduct" : "product",
1016 gfc_type_letter (array->ts.type), array->ts.kind);
1021 gfc_resolve_real (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
1024 f->ts.type = BT_REAL;
1027 f->ts.kind = mpz_get_si (kind->value.integer);
1029 f->ts.kind = (a->ts.type == BT_COMPLEX) ?
1030 a->ts.kind : gfc_default_real_kind;
1032 f->value.function.name =
1033 gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1034 gfc_type_letter (a->ts.type), a->ts.kind);
1039 gfc_resolve_repeat (gfc_expr * f, gfc_expr * string,
1040 gfc_expr * ncopies ATTRIBUTE_UNUSED)
1043 f->ts.type = BT_CHARACTER;
1044 f->ts.kind = string->ts.kind;
1045 f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
1050 gfc_resolve_reshape (gfc_expr * f, gfc_expr * source, gfc_expr * shape,
1051 gfc_expr * pad ATTRIBUTE_UNUSED,
1052 gfc_expr * order ATTRIBUTE_UNUSED)
1054 static char reshape0[] = "__reshape";
1061 gfc_array_size (shape, &rank);
1062 f->rank = mpz_get_si (rank);
1064 switch (source->ts.type)
1067 kind = source->ts.kind * 2;
1073 kind = source->ts.kind;
1086 f->value.function.name =
1087 gfc_get_string ("__reshape_%d", source->ts.kind);
1091 f->value.function.name = reshape0;
1095 /* TODO: Make this work with a constant ORDER parameter. */
1096 if (shape->expr_type == EXPR_ARRAY
1097 && gfc_is_constant_expr (shape)
1101 f->shape = gfc_get_shape (f->rank);
1102 c = shape->value.constructor;
1103 for (i = 0; i < f->rank; i++)
1105 mpz_init_set (f->shape[i], c->expr->value.integer);
1113 gfc_resolve_rrspacing (gfc_expr * f, gfc_expr * x)
1117 f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
1122 gfc_resolve_scale (gfc_expr * f, gfc_expr * x,
1123 gfc_expr * y ATTRIBUTE_UNUSED)
1127 f->value.function.name = gfc_get_string ("__scale_%d_%d", x->ts.kind,
1133 gfc_resolve_scan (gfc_expr * f, gfc_expr * string,
1134 gfc_expr * set ATTRIBUTE_UNUSED,
1135 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 f->value.function.name =
1150 gfc_get_string ("__set_exponent_%d_%d", x->ts.kind, i->ts.kind);
1155 gfc_resolve_shape (gfc_expr * f, gfc_expr * array)
1158 f->ts.type = BT_INTEGER;
1159 f->ts.kind = gfc_default_integer_kind;
1161 f->value.function.name = gfc_get_string ("__shape_%d", f->ts.kind);
1162 f->shape = gfc_get_shape (1);
1163 mpz_init_set_ui (f->shape[0], array->rank);
1168 gfc_resolve_sign (gfc_expr * f, gfc_expr * a, gfc_expr * b ATTRIBUTE_UNUSED)
1172 f->value.function.name =
1173 gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
1178 gfc_resolve_sin (gfc_expr * f, gfc_expr * x)
1182 f->value.function.name =
1183 gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1188 gfc_resolve_sinh (gfc_expr * f, gfc_expr * x)
1192 f->value.function.name =
1193 gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1198 gfc_resolve_spacing (gfc_expr * f, gfc_expr * x)
1202 f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
1207 gfc_resolve_spread (gfc_expr * f, gfc_expr * source,
1211 static char spread[] = "__spread";
1214 f->rank = source->rank + 1;
1215 f->value.function.name = spread;
1217 gfc_resolve_index (dim, 1);
1218 gfc_resolve_index (ncopies, 1);
1223 gfc_resolve_sqrt (gfc_expr * f, gfc_expr * x)
1227 f->value.function.name =
1228 gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1233 gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1241 f->rank = array->rank - 1;
1242 gfc_resolve_index (dim, 1);
1245 f->value.function.name =
1246 gfc_get_string ("__%s_%c%d", mask ? "msum" : "sum",
1247 gfc_type_letter (array->ts.type), array->ts.kind);
1252 gfc_resolve_tan (gfc_expr * f, gfc_expr * x)
1256 f->value.function.name =
1257 gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1262 gfc_resolve_tanh (gfc_expr * f, gfc_expr * x)
1266 f->value.function.name =
1267 gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1272 gfc_resolve_transfer (gfc_expr * f, gfc_expr * source ATTRIBUTE_UNUSED,
1273 gfc_expr * mold, gfc_expr * size)
1275 /* TODO: Make this do something meaningful. */
1276 static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
1280 if (size == NULL && mold->rank == 0)
1283 f->value.function.name = transfer0;
1288 f->value.function.name = transfer1;
1294 gfc_resolve_transpose (gfc_expr * f, gfc_expr * matrix)
1296 static char transpose0[] = "__transpose";
1303 f->shape = gfc_get_shape (2);
1304 mpz_init_set (f->shape[0], matrix->shape[1]);
1305 mpz_init_set (f->shape[1], matrix->shape[0]);
1308 switch (matrix->ts.type)
1311 kind = matrix->ts.kind * 2;
1317 kind = matrix->ts.kind;
1331 f->value.function.name =
1332 gfc_get_string ("__transpose_%d", kind);
1336 f->value.function.name = transpose0;
1342 gfc_resolve_trim (gfc_expr * f, gfc_expr * string)
1345 f->ts.type = BT_CHARACTER;
1346 f->ts.kind = string->ts.kind;
1347 f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
1352 gfc_resolve_ubound (gfc_expr * f, gfc_expr * array,
1355 static char ubound[] = "__ubound";
1357 f->ts.type = BT_INTEGER;
1358 f->ts.kind = gfc_default_integer_kind;
1363 f->shape = gfc_get_shape (1);
1364 mpz_init_set_ui (f->shape[0], array->rank);
1367 f->value.function.name = ubound;
1372 gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask,
1373 gfc_expr * field ATTRIBUTE_UNUSED)
1376 f->ts.type = vector->ts.type;
1377 f->ts.kind = vector->ts.kind;
1378 f->rank = mask->rank;
1380 f->value.function.name =
1381 gfc_get_string ("__unpack%d", field->rank > 0 ? 1 : 0);
1386 gfc_resolve_verify (gfc_expr * f, gfc_expr * string,
1387 gfc_expr * set ATTRIBUTE_UNUSED,
1388 gfc_expr * back ATTRIBUTE_UNUSED)
1391 f->ts.type = BT_INTEGER;
1392 f->ts.kind = gfc_default_integer_kind;
1393 f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
1397 /* Intrinsic subroutine resolution. */
1400 gfc_resolve_cpu_time (gfc_code * c ATTRIBUTE_UNUSED)
1404 name = gfc_get_string (PREFIX("cpu_time_%d"),
1405 c->ext.actual->expr->ts.kind);
1406 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1411 gfc_resolve_random_number (gfc_code * c ATTRIBUTE_UNUSED)
1416 kind = c->ext.actual->expr->ts.kind;
1417 if (c->ext.actual->expr->rank == 0)
1418 name = gfc_get_string (PREFIX("random_r%d"), kind);
1420 name = gfc_get_string (PREFIX("arandom_r%d"), kind);
1422 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1427 /* G77 compatibility subroutines etime() and dtime(). */
1430 gfc_resolve_etime_sub (gfc_code * c)
1434 name = gfc_get_string (PREFIX("etime_sub"));
1435 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1439 /* G77 compatibility subroutine second(). */
1442 gfc_resolve_second_sub (gfc_code * c)
1446 name = gfc_get_string (PREFIX("second_sub"));
1447 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1451 /* G77 compatibility function srand(). */
1454 gfc_resolve_srand (gfc_code * c)
1457 name = gfc_get_string (PREFIX("srand"));
1458 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1462 /* Resolve the getarg intrinsic subroutine. */
1465 gfc_resolve_getarg (gfc_code * c)
1470 kind = gfc_default_integer_kind;
1471 name = gfc_get_string (PREFIX("getarg_i%d"), kind);
1472 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1476 /* Resolve the get_command intrinsic subroutine. */
1479 gfc_resolve_get_command (gfc_code * c)
1484 kind = gfc_default_integer_kind;
1485 name = gfc_get_string (PREFIX("get_command_i%d"), kind);
1486 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1490 /* Resolve the get_command_argument intrinsic subroutine. */
1493 gfc_resolve_get_command_argument (gfc_code * c)
1498 kind = gfc_default_integer_kind;
1499 name = gfc_get_string (PREFIX("get_command_argument_i%d"), kind);
1500 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1503 /* Resolve the get_environment_variable intrinsic subroutine. */
1506 gfc_resolve_get_environment_variable (gfc_code * code)
1511 kind = gfc_default_integer_kind;
1512 name = gfc_get_string (PREFIX("get_environment_variable_i%d"), kind);
1513 code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1517 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
1520 gfc_resolve_system_clock (gfc_code * c)
1525 if (c->ext.actual->expr != NULL)
1526 kind = c->ext.actual->expr->ts.kind;
1527 else if (c->ext.actual->next->expr != NULL)
1528 kind = c->ext.actual->next->expr->ts.kind;
1529 else if (c->ext.actual->next->next->expr != NULL)
1530 kind = c->ext.actual->next->next->expr->ts.kind;
1532 kind = gfc_default_integer_kind;
1534 name = gfc_get_string (PREFIX("system_clock_%d"), kind);
1535 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1539 gfc_iresolve_init_1 (void)
1543 for (i = 0; i < HASH_SIZE; i++)
1544 string_head[i] = NULL;
1549 gfc_iresolve_done_1 (void)