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;
191 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
194 f->value.function.name =
195 gfc_get_string ("__all_%c%d", gfc_type_letter (mask->ts.type),
201 gfc_resolve_anint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
204 f->ts.type = a->ts.type;
205 f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
207 /* The resolved name is only used for specific intrinsics where
208 the return kind is the same as the arg kind. */
209 f->value.function.name =
210 gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
215 gfc_resolve_dnint (gfc_expr * f, gfc_expr * a)
217 gfc_resolve_anint (f, a, NULL);
222 gfc_resolve_any (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
229 gfc_resolve_index (dim, 1);
230 f->rank = mask->rank - 1;
231 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
234 f->value.function.name =
235 gfc_get_string ("__any_%c%d", gfc_type_letter (mask->ts.type),
241 gfc_resolve_asin (gfc_expr * f, gfc_expr * x)
245 f->value.function.name =
246 gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
251 gfc_resolve_atan (gfc_expr * f, gfc_expr * x)
255 f->value.function.name =
256 gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
261 gfc_resolve_atan2 (gfc_expr * f, gfc_expr * x,
262 gfc_expr * y ATTRIBUTE_UNUSED)
266 f->value.function.name =
267 gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
271 /* Resolve the BESYN and BESJN intrinsics. */
274 gfc_resolve_besn (gfc_expr * f, gfc_expr * n, gfc_expr * x)
279 if (n->ts.kind != gfc_c_int_kind)
281 ts.type = BT_INTEGER;
282 ts.kind = gfc_c_int_kind;
283 gfc_convert_type (n, &ts, 2);
285 f->value.function.name = gfc_get_string ("<intrinsic>");
290 gfc_resolve_btest (gfc_expr * f, gfc_expr * i, gfc_expr * pos)
293 f->ts.type = BT_LOGICAL;
294 f->ts.kind = gfc_default_logical_kind;
296 f->value.function.name = gfc_get_string ("__btest_%d_%d", i->ts.kind,
302 gfc_resolve_ceiling (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
305 f->ts.type = BT_INTEGER;
306 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
307 : mpz_get_si (kind->value.integer);
309 f->value.function.name =
310 gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind,
311 gfc_type_letter (a->ts.type), a->ts.kind);
316 gfc_resolve_char (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
319 f->ts.type = BT_CHARACTER;
320 f->ts.kind = (kind == NULL) ? gfc_default_character_kind
321 : mpz_get_si (kind->value.integer);
323 f->value.function.name =
324 gfc_get_string ("__char_%d_%c%d", f->ts.kind,
325 gfc_type_letter (a->ts.type), a->ts.kind);
330 gfc_resolve_cmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y, gfc_expr * kind)
333 f->ts.type = BT_COMPLEX;
334 f->ts.kind = (kind == NULL) ? gfc_default_real_kind
335 : mpz_get_si (kind->value.integer);
338 f->value.function.name =
339 gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind,
340 gfc_type_letter (x->ts.type), x->ts.kind);
342 f->value.function.name =
343 gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
344 gfc_type_letter (x->ts.type), x->ts.kind,
345 gfc_type_letter (y->ts.type), y->ts.kind);
349 gfc_resolve_dcmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y)
351 gfc_resolve_cmplx (f, x, y, gfc_int_expr (gfc_default_double_kind));
355 gfc_resolve_conjg (gfc_expr * f, gfc_expr * x)
359 f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind);
364 gfc_resolve_cos (gfc_expr * f, gfc_expr * x)
368 f->value.function.name =
369 gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
374 gfc_resolve_cosh (gfc_expr * f, gfc_expr * x)
378 f->value.function.name =
379 gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
384 gfc_resolve_count (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
387 f->ts.type = BT_INTEGER;
388 f->ts.kind = gfc_default_integer_kind;
392 f->rank = mask->rank - 1;
393 gfc_resolve_index (dim, 1);
394 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
397 f->value.function.name =
398 gfc_get_string ("__count_%d_%c%d", f->ts.kind,
399 gfc_type_letter (mask->ts.type), mask->ts.kind);
404 gfc_resolve_cshift (gfc_expr * f, gfc_expr * array,
411 f->rank = array->rank;
412 f->shape = gfc_copy_shape (array->shape, array->rank);
421 gfc_resolve_index (dim, 1);
422 /* Convert dim to shift's kind, so we don't need so many variations. */
423 if (dim->ts.kind != shift->ts.kind)
424 gfc_convert_type (dim, &shift->ts, 2);
426 f->value.function.name =
427 gfc_get_string ("__cshift%d_%d", n, shift->ts.kind);
432 gfc_resolve_dble (gfc_expr * f, gfc_expr * a)
435 f->ts.type = BT_REAL;
436 f->ts.kind = gfc_default_double_kind;
437 f->value.function.name =
438 gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
443 gfc_resolve_dim (gfc_expr * f, gfc_expr * x,
444 gfc_expr * y ATTRIBUTE_UNUSED)
448 f->value.function.name =
449 gfc_get_string ("__dim_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
454 gfc_resolve_dot_product (gfc_expr * f, gfc_expr * a, gfc_expr * b)
458 if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
460 f->ts.type = BT_LOGICAL;
461 f->ts.kind = gfc_default_logical_kind;
465 temp.expr_type = EXPR_OP;
466 gfc_clear_ts (&temp.ts);
467 temp.operator = INTRINSIC_NONE;
470 gfc_type_convert_binary (&temp);
474 f->value.function.name =
475 gfc_get_string ("__dot_product_%c%d", gfc_type_letter (f->ts.type),
481 gfc_resolve_dprod (gfc_expr * f,
482 gfc_expr * a ATTRIBUTE_UNUSED,
483 gfc_expr * b ATTRIBUTE_UNUSED)
485 f->ts.kind = gfc_default_double_kind;
486 f->ts.type = BT_REAL;
488 f->value.function.name = gfc_get_string ("__dprod_r%d", f->ts.kind);
493 gfc_resolve_eoshift (gfc_expr * f, gfc_expr * array,
501 f->rank = array->rank;
502 f->shape = gfc_copy_shape (array->shape, array->rank);
507 if (boundary && boundary->rank > 0)
510 /* Convert dim to the same type as shift, so we don't need quite so many
512 if (dim != NULL && dim->ts.kind != shift->ts.kind)
513 gfc_convert_type (dim, &shift->ts, 2);
515 f->value.function.name =
516 gfc_get_string ("__eoshift%d_%d", n, shift->ts.kind);
521 gfc_resolve_exp (gfc_expr * f, gfc_expr * x)
525 f->value.function.name =
526 gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
531 gfc_resolve_exponent (gfc_expr * f, gfc_expr * x)
534 f->ts.type = BT_INTEGER;
535 f->ts.kind = gfc_default_integer_kind;
537 f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind);
542 gfc_resolve_floor (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
545 f->ts.type = BT_INTEGER;
546 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
547 : mpz_get_si (kind->value.integer);
549 f->value.function.name =
550 gfc_get_string ("__floor%d_%c%d", f->ts.kind,
551 gfc_type_letter (a->ts.type), a->ts.kind);
556 gfc_resolve_fnum (gfc_expr * f, gfc_expr * n)
559 f->ts.type = BT_INTEGER;
560 f->ts.kind = gfc_default_integer_kind;
561 if (n->ts.kind != f->ts.kind)
562 gfc_convert_type (n, &f->ts, 2);
563 f->value.function.name = gfc_get_string (PREFIX("fnum_i%d"), f->ts.kind);
568 gfc_resolve_fraction (gfc_expr * f, gfc_expr * x)
572 f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind);
576 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
579 gfc_resolve_g77_math1 (gfc_expr * f, gfc_expr * x)
582 f->value.function.name = gfc_get_string ("<intrinsic>");
587 gfc_resolve_getcwd (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
589 f->ts.type = BT_INTEGER;
591 f->value.function.name = gfc_get_string (PREFIX("getcwd"));
596 gfc_resolve_getgid (gfc_expr * f)
598 f->ts.type = BT_INTEGER;
600 f->value.function.name = gfc_get_string (PREFIX("getgid"));
605 gfc_resolve_getpid (gfc_expr * f)
607 f->ts.type = BT_INTEGER;
609 f->value.function.name = gfc_get_string (PREFIX("getpid"));
614 gfc_resolve_getuid (gfc_expr * f)
616 f->ts.type = BT_INTEGER;
618 f->value.function.name = gfc_get_string (PREFIX("getuid"));
622 gfc_resolve_iand (gfc_expr * f, gfc_expr * i, gfc_expr * j ATTRIBUTE_UNUSED)
626 f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind);
631 gfc_resolve_ibclr (gfc_expr * f, gfc_expr * i, gfc_expr * pos ATTRIBUTE_UNUSED)
635 f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind);
640 gfc_resolve_ibits (gfc_expr * f, gfc_expr * i,
641 gfc_expr * pos ATTRIBUTE_UNUSED,
642 gfc_expr * len ATTRIBUTE_UNUSED)
646 f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind);
651 gfc_resolve_ibset (gfc_expr * f, gfc_expr * i,
652 gfc_expr * pos ATTRIBUTE_UNUSED)
656 f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind);
661 gfc_resolve_ichar (gfc_expr * f, gfc_expr * c)
664 f->ts.type = BT_INTEGER;
665 f->ts.kind = gfc_default_integer_kind;
667 f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
672 gfc_resolve_idnint (gfc_expr * f, gfc_expr * a)
674 gfc_resolve_nint (f, a, NULL);
679 gfc_resolve_ieor (gfc_expr * f, gfc_expr * i,
680 gfc_expr * j ATTRIBUTE_UNUSED)
684 f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind);
689 gfc_resolve_ior (gfc_expr * f, gfc_expr * i,
690 gfc_expr * j ATTRIBUTE_UNUSED)
694 f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind);
699 gfc_resolve_int (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
702 f->ts.type = BT_INTEGER;
703 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
704 : mpz_get_si (kind->value.integer);
706 f->value.function.name =
707 gfc_get_string ("__int_%d_%c%d", f->ts.kind, gfc_type_letter (a->ts.type),
713 gfc_resolve_ishft (gfc_expr * f, gfc_expr * i, gfc_expr * shift)
717 f->value.function.name =
718 gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
723 gfc_resolve_ishftc (gfc_expr * f, gfc_expr * i, gfc_expr * shift,
728 s_kind = (size == NULL) ? gfc_default_integer_kind : shift->ts.kind;
731 f->value.function.name =
732 gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
737 gfc_resolve_lbound (gfc_expr * f, gfc_expr * array,
740 static char lbound[] = "__lbound";
742 f->ts.type = BT_INTEGER;
743 f->ts.kind = gfc_default_integer_kind;
748 f->shape = gfc_get_shape (1);
749 mpz_init_set_ui (f->shape[0], array->rank);
752 f->value.function.name = lbound;
757 gfc_resolve_len (gfc_expr * f, gfc_expr * string)
760 f->ts.type = BT_INTEGER;
761 f->ts.kind = gfc_default_integer_kind;
762 f->value.function.name = gfc_get_string ("__len_%d", string->ts.kind);
767 gfc_resolve_len_trim (gfc_expr * f, gfc_expr * string)
770 f->ts.type = BT_INTEGER;
771 f->ts.kind = gfc_default_integer_kind;
772 f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
777 gfc_resolve_log (gfc_expr * f, gfc_expr * x)
781 f->value.function.name =
782 gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
787 gfc_resolve_log10 (gfc_expr * f, gfc_expr * x)
791 f->value.function.name =
792 gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
797 gfc_resolve_logical (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
800 f->ts.type = BT_LOGICAL;
801 f->ts.kind = (kind == NULL) ? gfc_default_logical_kind
802 : mpz_get_si (kind->value.integer);
805 f->value.function.name =
806 gfc_get_string ("__logical_%d_%c%d", f->ts.kind,
807 gfc_type_letter (a->ts.type), a->ts.kind);
812 gfc_resolve_matmul (gfc_expr * f, gfc_expr * a, gfc_expr * b)
816 if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
818 f->ts.type = BT_LOGICAL;
819 f->ts.kind = gfc_default_logical_kind;
823 temp.expr_type = EXPR_OP;
824 gfc_clear_ts (&temp.ts);
825 temp.operator = INTRINSIC_NONE;
828 gfc_type_convert_binary (&temp);
832 f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
834 f->value.function.name =
835 gfc_get_string ("__matmul_%c%d", gfc_type_letter (f->ts.type),
841 gfc_resolve_minmax (const char * name, gfc_expr * f, gfc_actual_arglist * args)
843 gfc_actual_arglist *a;
845 f->ts.type = args->expr->ts.type;
846 f->ts.kind = args->expr->ts.kind;
847 /* Find the largest type kind. */
848 for (a = args->next; a; a = a->next)
850 if (a->expr->ts.kind > f->ts.kind)
851 f->ts.kind = a->expr->ts.kind;
854 /* Convert all parameters to the required kind. */
855 for (a = args; a; a = a->next)
857 if (a->expr->ts.kind != f->ts.kind)
858 gfc_convert_type (a->expr, &f->ts, 2);
861 f->value.function.name =
862 gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind);
867 gfc_resolve_max (gfc_expr * f, gfc_actual_arglist * args)
869 gfc_resolve_minmax ("__max_%c%d", f, args);
874 gfc_resolve_maxloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
879 f->ts.type = BT_INTEGER;
880 f->ts.kind = gfc_default_integer_kind;
886 f->rank = array->rank - 1;
887 gfc_resolve_index (dim, 1);
890 name = mask ? "mmaxloc" : "maxloc";
891 f->value.function.name =
892 gfc_get_string ("__%s%d_%d_%c%d", name, dim != NULL, f->ts.kind,
893 gfc_type_letter (array->ts.type), array->ts.kind);
898 gfc_resolve_maxval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
906 f->rank = array->rank - 1;
907 gfc_resolve_index (dim, 1);
910 f->value.function.name =
911 gfc_get_string ("__%s_%c%d", mask ? "mmaxval" : "maxval",
912 gfc_type_letter (array->ts.type), array->ts.kind);
917 gfc_resolve_merge (gfc_expr * f, gfc_expr * tsource,
918 gfc_expr * fsource ATTRIBUTE_UNUSED,
919 gfc_expr * mask ATTRIBUTE_UNUSED)
923 f->value.function.name =
924 gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
930 gfc_resolve_min (gfc_expr * f, gfc_actual_arglist * args)
932 gfc_resolve_minmax ("__min_%c%d", f, args);
937 gfc_resolve_minloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
942 f->ts.type = BT_INTEGER;
943 f->ts.kind = gfc_default_integer_kind;
949 f->rank = array->rank - 1;
950 gfc_resolve_index (dim, 1);
953 name = mask ? "mminloc" : "minloc";
954 f->value.function.name =
955 gfc_get_string ("__%s%d_%d_%c%d", name, dim != NULL, f->ts.kind,
956 gfc_type_letter (array->ts.type), array->ts.kind);
961 gfc_resolve_minval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
969 f->rank = array->rank - 1;
970 gfc_resolve_index (dim, 1);
973 f->value.function.name =
974 gfc_get_string ("__%s_%c%d", mask ? "mminval" : "minval",
975 gfc_type_letter (array->ts.type), array->ts.kind);
980 gfc_resolve_mod (gfc_expr * f, gfc_expr * a,
981 gfc_expr * p ATTRIBUTE_UNUSED)
985 f->value.function.name =
986 gfc_get_string ("__mod_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
991 gfc_resolve_modulo (gfc_expr * f, gfc_expr * a,
992 gfc_expr * p ATTRIBUTE_UNUSED)
996 f->value.function.name =
997 gfc_get_string ("__modulo_%c%d", gfc_type_letter (a->ts.type),
1002 gfc_resolve_nearest (gfc_expr * f, gfc_expr * a,
1003 gfc_expr *p ATTRIBUTE_UNUSED)
1007 f->value.function.name =
1008 gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
1013 gfc_resolve_nint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
1016 f->ts.type = BT_INTEGER;
1017 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
1018 : mpz_get_si (kind->value.integer);
1020 f->value.function.name =
1021 gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
1026 gfc_resolve_not (gfc_expr * f, gfc_expr * i)
1030 f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
1035 gfc_resolve_pack (gfc_expr * f,
1036 gfc_expr * array ATTRIBUTE_UNUSED,
1038 gfc_expr * vector ATTRIBUTE_UNUSED)
1040 static char pack[] = "__pack",
1041 pack_s[] = "__pack_s";
1046 if (mask->rank != 0)
1047 f->value.function.name = pack;
1050 /* We convert mask to default logical only in the scalar case.
1051 In the array case we can simply read the array as if it were
1052 of type default logical. */
1053 if (mask->ts.kind != gfc_default_logical_kind)
1057 ts.type = BT_LOGICAL;
1058 ts.kind = gfc_default_logical_kind;
1059 gfc_convert_type (mask, &ts, 2);
1062 f->value.function.name = pack_s;
1068 gfc_resolve_product (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1076 f->rank = array->rank - 1;
1077 gfc_resolve_index (dim, 1);
1080 f->value.function.name =
1081 gfc_get_string ("__%s_%c%d", mask ? "mproduct" : "product",
1082 gfc_type_letter (array->ts.type), array->ts.kind);
1087 gfc_resolve_real (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
1090 f->ts.type = BT_REAL;
1093 f->ts.kind = mpz_get_si (kind->value.integer);
1095 f->ts.kind = (a->ts.type == BT_COMPLEX) ?
1096 a->ts.kind : gfc_default_real_kind;
1098 f->value.function.name =
1099 gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1100 gfc_type_letter (a->ts.type), a->ts.kind);
1105 gfc_resolve_repeat (gfc_expr * f, gfc_expr * string,
1106 gfc_expr * ncopies ATTRIBUTE_UNUSED)
1109 f->ts.type = BT_CHARACTER;
1110 f->ts.kind = string->ts.kind;
1111 f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
1116 gfc_resolve_reshape (gfc_expr * f, gfc_expr * source, gfc_expr * shape,
1117 gfc_expr * pad ATTRIBUTE_UNUSED,
1118 gfc_expr * order ATTRIBUTE_UNUSED)
1120 static char reshape0[] = "__reshape";
1127 gfc_array_size (shape, &rank);
1128 f->rank = mpz_get_si (rank);
1130 switch (source->ts.type)
1133 kind = source->ts.kind * 2;
1139 kind = source->ts.kind;
1152 f->value.function.name =
1153 gfc_get_string ("__reshape_%d", source->ts.kind);
1157 f->value.function.name = reshape0;
1161 /* TODO: Make this work with a constant ORDER parameter. */
1162 if (shape->expr_type == EXPR_ARRAY
1163 && gfc_is_constant_expr (shape)
1167 f->shape = gfc_get_shape (f->rank);
1168 c = shape->value.constructor;
1169 for (i = 0; i < f->rank; i++)
1171 mpz_init_set (f->shape[i], c->expr->value.integer);
1179 gfc_resolve_rrspacing (gfc_expr * f, gfc_expr * x)
1183 f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
1188 gfc_resolve_scale (gfc_expr * f, gfc_expr * x,
1189 gfc_expr * y ATTRIBUTE_UNUSED)
1193 f->value.function.name = gfc_get_string ("__scale_%d_%d", x->ts.kind,
1199 gfc_resolve_scan (gfc_expr * f, gfc_expr * string,
1200 gfc_expr * set ATTRIBUTE_UNUSED,
1201 gfc_expr * back ATTRIBUTE_UNUSED)
1204 f->ts.type = BT_INTEGER;
1205 f->ts.kind = gfc_default_integer_kind;
1206 f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
1211 gfc_resolve_set_exponent (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1215 f->value.function.name =
1216 gfc_get_string ("__set_exponent_%d_%d", x->ts.kind, i->ts.kind);
1221 gfc_resolve_shape (gfc_expr * f, gfc_expr * array)
1224 f->ts.type = BT_INTEGER;
1225 f->ts.kind = gfc_default_integer_kind;
1227 f->value.function.name = gfc_get_string ("__shape_%d", f->ts.kind);
1228 f->shape = gfc_get_shape (1);
1229 mpz_init_set_ui (f->shape[0], array->rank);
1234 gfc_resolve_sign (gfc_expr * f, gfc_expr * a, gfc_expr * b ATTRIBUTE_UNUSED)
1238 f->value.function.name =
1239 gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
1244 gfc_resolve_sin (gfc_expr * f, gfc_expr * x)
1248 f->value.function.name =
1249 gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1254 gfc_resolve_sinh (gfc_expr * f, gfc_expr * x)
1258 f->value.function.name =
1259 gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1264 gfc_resolve_spacing (gfc_expr * f, gfc_expr * x)
1268 f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
1273 gfc_resolve_spread (gfc_expr * f, gfc_expr * source,
1277 static char spread[] = "__spread";
1280 f->rank = source->rank + 1;
1281 f->value.function.name = spread;
1283 gfc_resolve_index (dim, 1);
1284 gfc_resolve_index (ncopies, 1);
1289 gfc_resolve_sqrt (gfc_expr * f, gfc_expr * x)
1293 f->value.function.name =
1294 gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1298 /* Resolve the g77 compatibility function STAT AND FSTAT. */
1301 gfc_resolve_stat (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED,
1302 gfc_expr * a ATTRIBUTE_UNUSED)
1305 f->ts.type = BT_INTEGER;
1306 f->ts.kind = gfc_default_integer_kind;
1307 f->value.function.name = gfc_get_string (PREFIX("stat_i%d"), f->ts.kind);
1312 gfc_resolve_fstat (gfc_expr * f, gfc_expr * n, gfc_expr * a ATTRIBUTE_UNUSED)
1315 f->ts.type = BT_INTEGER;
1316 f->ts.kind = gfc_default_integer_kind;
1317 if (n->ts.kind != f->ts.kind)
1318 gfc_convert_type (n, &f->ts, 2);
1320 f->value.function.name = gfc_get_string (PREFIX("fstat_i%d"), f->ts.kind);
1325 gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1333 f->rank = array->rank - 1;
1334 gfc_resolve_index (dim, 1);
1337 f->value.function.name =
1338 gfc_get_string ("__%s_%c%d", mask ? "msum" : "sum",
1339 gfc_type_letter (array->ts.type), array->ts.kind);
1343 /* Resolve the g77 compatibility function SYSTEM. */
1346 gfc_resolve_system (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
1348 f->ts.type = BT_INTEGER;
1350 f->value.function.name = gfc_get_string (PREFIX("system"));
1355 gfc_resolve_tan (gfc_expr * f, gfc_expr * x)
1359 f->value.function.name =
1360 gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1365 gfc_resolve_tanh (gfc_expr * f, gfc_expr * x)
1369 f->value.function.name =
1370 gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1375 gfc_resolve_transfer (gfc_expr * f, gfc_expr * source ATTRIBUTE_UNUSED,
1376 gfc_expr * mold, gfc_expr * size)
1378 /* TODO: Make this do something meaningful. */
1379 static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
1383 if (size == NULL && mold->rank == 0)
1386 f->value.function.name = transfer0;
1391 f->value.function.name = transfer1;
1397 gfc_resolve_transpose (gfc_expr * f, gfc_expr * matrix)
1399 static char transpose0[] = "__transpose";
1406 f->shape = gfc_get_shape (2);
1407 mpz_init_set (f->shape[0], matrix->shape[1]);
1408 mpz_init_set (f->shape[1], matrix->shape[0]);
1411 switch (matrix->ts.type)
1414 kind = matrix->ts.kind * 2;
1420 kind = matrix->ts.kind;
1434 f->value.function.name =
1435 gfc_get_string ("__transpose_%d", kind);
1439 f->value.function.name = transpose0;
1445 gfc_resolve_trim (gfc_expr * f, gfc_expr * string)
1448 f->ts.type = BT_CHARACTER;
1449 f->ts.kind = string->ts.kind;
1450 f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
1455 gfc_resolve_ubound (gfc_expr * f, gfc_expr * array,
1458 static char ubound[] = "__ubound";
1460 f->ts.type = BT_INTEGER;
1461 f->ts.kind = gfc_default_integer_kind;
1466 f->shape = gfc_get_shape (1);
1467 mpz_init_set_ui (f->shape[0], array->rank);
1470 f->value.function.name = ubound;
1474 /* Resolve the g77 compatibility function UMASK. */
1477 gfc_resolve_umask (gfc_expr * f, gfc_expr * n)
1480 f->ts.type = BT_INTEGER;
1481 f->ts.kind = n->ts.kind;
1482 f->value.function.name = gfc_get_string (PREFIX("umask_i%d"), n->ts.kind);
1486 /* Resolve the g77 compatibility function UNLINK. */
1489 gfc_resolve_unlink (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
1492 f->ts.type = BT_INTEGER;
1494 f->value.function.name = gfc_get_string (PREFIX("unlink"));
1498 gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask,
1499 gfc_expr * field ATTRIBUTE_UNUSED)
1502 f->ts.type = vector->ts.type;
1503 f->ts.kind = vector->ts.kind;
1504 f->rank = mask->rank;
1506 f->value.function.name =
1507 gfc_get_string ("__unpack%d", field->rank > 0 ? 1 : 0);
1512 gfc_resolve_verify (gfc_expr * f, gfc_expr * string,
1513 gfc_expr * set ATTRIBUTE_UNUSED,
1514 gfc_expr * back ATTRIBUTE_UNUSED)
1517 f->ts.type = BT_INTEGER;
1518 f->ts.kind = gfc_default_integer_kind;
1519 f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
1523 /* Intrinsic subroutine resolution. */
1526 gfc_resolve_cpu_time (gfc_code * c ATTRIBUTE_UNUSED)
1530 name = gfc_get_string (PREFIX("cpu_time_%d"),
1531 c->ext.actual->expr->ts.kind);
1532 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1537 gfc_resolve_mvbits (gfc_code * c)
1542 kind = c->ext.actual->expr->ts.kind;
1543 name = gfc_get_string (PREFIX("mvbits_i%d"), kind);
1545 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1550 gfc_resolve_random_number (gfc_code * c ATTRIBUTE_UNUSED)
1555 kind = c->ext.actual->expr->ts.kind;
1556 if (c->ext.actual->expr->rank == 0)
1557 name = gfc_get_string (PREFIX("random_r%d"), kind);
1559 name = gfc_get_string (PREFIX("arandom_r%d"), kind);
1561 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1565 /* G77 compatibility subroutines etime() and dtime(). */
1568 gfc_resolve_etime_sub (gfc_code * c)
1572 name = gfc_get_string (PREFIX("etime_sub"));
1573 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1577 /* G77 compatibility subroutine second(). */
1580 gfc_resolve_second_sub (gfc_code * c)
1584 name = gfc_get_string (PREFIX("second_sub"));
1585 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1589 /* G77 compatibility function srand(). */
1592 gfc_resolve_srand (gfc_code * c)
1595 name = gfc_get_string (PREFIX("srand"));
1596 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1600 /* Resolve the getarg intrinsic subroutine. */
1603 gfc_resolve_getarg (gfc_code * c)
1608 kind = gfc_default_integer_kind;
1609 name = gfc_get_string (PREFIX("getarg_i%d"), kind);
1610 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1613 /* Resolve the getcwd intrinsic subroutine. */
1616 gfc_resolve_getcwd_sub (gfc_code * c)
1621 if (c->ext.actual->next->expr != NULL)
1622 kind = c->ext.actual->next->expr->ts.kind;
1624 kind = gfc_default_integer_kind;
1626 name = gfc_get_string (PREFIX("getcwd_i%d_sub"), kind);
1627 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1631 /* Resolve the get_command intrinsic subroutine. */
1634 gfc_resolve_get_command (gfc_code * c)
1639 kind = gfc_default_integer_kind;
1640 name = gfc_get_string (PREFIX("get_command_i%d"), kind);
1641 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1645 /* Resolve the get_command_argument intrinsic subroutine. */
1648 gfc_resolve_get_command_argument (gfc_code * c)
1653 kind = gfc_default_integer_kind;
1654 name = gfc_get_string (PREFIX("get_command_argument_i%d"), kind);
1655 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1658 /* Resolve the get_environment_variable intrinsic subroutine. */
1661 gfc_resolve_get_environment_variable (gfc_code * code)
1666 kind = gfc_default_integer_kind;
1667 name = gfc_get_string (PREFIX("get_environment_variable_i%d"), kind);
1668 code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1671 /* Resolve the SYSTEM intrinsic subroutine. */
1674 gfc_resolve_system_sub (gfc_code * c)
1678 name = gfc_get_string (PREFIX("system_sub"));
1679 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1682 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
1685 gfc_resolve_system_clock (gfc_code * c)
1690 if (c->ext.actual->expr != NULL)
1691 kind = c->ext.actual->expr->ts.kind;
1692 else if (c->ext.actual->next->expr != NULL)
1693 kind = c->ext.actual->next->expr->ts.kind;
1694 else if (c->ext.actual->next->next->expr != NULL)
1695 kind = c->ext.actual->next->next->expr->ts.kind;
1697 kind = gfc_default_integer_kind;
1699 name = gfc_get_string (PREFIX("system_clock_%d"), kind);
1700 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1703 /* Resolve the EXIT intrinsic subroutine. */
1706 gfc_resolve_exit (gfc_code * c)
1711 if (c->ext.actual->expr != NULL)
1712 kind = c->ext.actual->expr->ts.kind;
1714 kind = gfc_default_integer_kind;
1716 name = gfc_get_string (PREFIX("exit_i%d"), kind);
1717 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1720 /* Resolve the FLUSH intrinsic subroutine. */
1723 gfc_resolve_flush (gfc_code * c)
1729 ts.type = BT_INTEGER;
1730 ts.kind = gfc_default_integer_kind;
1731 n = c->ext.actual->expr;
1733 && n->ts.kind != ts.kind)
1734 gfc_convert_type (n, &ts, 2);
1736 name = gfc_get_string (PREFIX("flush_i%d"), ts.kind);
1737 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1740 /* Resolve the STAT and FSTAT intrinsic subroutines. */
1743 gfc_resolve_stat_sub (gfc_code * c)
1747 name = gfc_get_string (PREFIX("stat_i%d_sub"), gfc_default_integer_kind);
1748 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1753 gfc_resolve_fstat_sub (gfc_code * c)
1759 u = c->ext.actual->expr;
1760 ts = &c->ext.actual->next->expr->ts;
1761 if (u->ts.kind != ts->kind)
1762 gfc_convert_type (u, ts, 2);
1763 name = gfc_get_string (PREFIX("fstat_i%d_sub"), ts->kind);
1764 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1767 /* Resolve the UMASK intrinsic subroutine. */
1770 gfc_resolve_umask_sub (gfc_code * c)
1775 if (c->ext.actual->next->expr != NULL)
1776 kind = c->ext.actual->next->expr->ts.kind;
1778 kind = gfc_default_integer_kind;
1780 name = gfc_get_string (PREFIX("umask_i%d_sub"), kind);
1781 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1784 /* Resolve the UNLINK intrinsic subroutine. */
1787 gfc_resolve_unlink_sub (gfc_code * c)
1792 if (c->ext.actual->next->expr != NULL)
1793 kind = c->ext.actual->next->expr->ts.kind;
1795 kind = gfc_default_integer_kind;
1797 name = gfc_get_string (PREFIX("unlink_i%d_sub"), kind);
1798 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1803 gfc_iresolve_init_1 (void)
1807 for (i = 0; i < HASH_SIZE; i++)
1808 string_head[i] = NULL;
1813 gfc_iresolve_done_1 (void)