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, 51 Franklin Street, Fifth Floor, Boston, MA
24 /* Assign name and types to intrinsic procedures. For functions, the
25 first argument to a resolution function is an expression pointer to
26 the original function node and the rest are pointers to the
27 arguments of the function call. For subroutines, a pointer to the
28 code node is passed. The result type and library subroutine name
29 are generally set according to the function arguments. */
33 #include "coretypes.h"
36 #include "intrinsic.h"
39 /* Given printf-like arguments, return a stable version of the result string.
41 We already have a working, optimized string hashing table in the form of
42 the identifier table. Reusing this table is likely not to be wasted,
43 since if the function name makes it to the gimple output of the frontend,
44 we'll have to create the identifier anyway. */
47 gfc_get_string (const char *format, ...)
53 va_start (ap, format);
54 vsnprintf (temp_name, sizeof(temp_name), format, ap);
56 temp_name[sizeof(temp_name)-1] = 0;
58 ident = get_identifier (temp_name);
59 return IDENTIFIER_POINTER (ident);
62 /* MERGE and SPREAD need to have source charlen's present for passing
63 to the result expression. */
65 check_charlen_present (gfc_expr *source)
67 if (source->expr_type == EXPR_CONSTANT && source->ts.cl == NULL)
69 source->ts.cl = gfc_get_charlen ();
70 source->ts.cl->next = gfc_current_ns->cl_list;
71 gfc_current_ns->cl_list = source->ts.cl;
72 source->ts.cl->length = gfc_int_expr (source->value.character.length);
77 /********************** Resolution functions **********************/
81 gfc_resolve_abs (gfc_expr * f, gfc_expr * a)
84 if (f->ts.type == BT_COMPLEX)
87 f->value.function.name =
88 gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
93 gfc_resolve_acos (gfc_expr * f, gfc_expr * x)
96 f->value.function.name =
97 gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
102 gfc_resolve_acosh (gfc_expr * f, gfc_expr * x)
105 f->value.function.name =
106 gfc_get_string ("__acosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
111 gfc_resolve_aimag (gfc_expr * f, gfc_expr * x)
113 f->ts.type = BT_REAL;
114 f->ts.kind = x->ts.kind;
115 f->value.function.name =
116 gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
121 gfc_resolve_aint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
125 f->ts.type = a->ts.type;
126 f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
128 if (a->ts.kind != f->ts.kind)
130 ts.type = f->ts.type;
131 ts.kind = f->ts.kind;
132 gfc_convert_type (a, &ts, 2);
134 /* The resolved name is only used for specific intrinsics where
135 the return kind is the same as the arg kind. */
136 f->value.function.name =
137 gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
142 gfc_resolve_dint (gfc_expr * f, gfc_expr * a)
144 gfc_resolve_aint (f, a, NULL);
149 gfc_resolve_all (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
155 gfc_resolve_dim_arg (dim);
156 f->rank = mask->rank - 1;
157 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
160 f->value.function.name =
161 gfc_get_string (PREFIX("all_%c%d"), gfc_type_letter (mask->ts.type),
167 gfc_resolve_anint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
171 f->ts.type = a->ts.type;
172 f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
174 if (a->ts.kind != f->ts.kind)
176 ts.type = f->ts.type;
177 ts.kind = f->ts.kind;
178 gfc_convert_type (a, &ts, 2);
181 /* The resolved name is only used for specific intrinsics where
182 the return kind is the same as the arg kind. */
183 f->value.function.name =
184 gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
189 gfc_resolve_dnint (gfc_expr * f, gfc_expr * a)
191 gfc_resolve_anint (f, a, NULL);
196 gfc_resolve_any (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
202 gfc_resolve_dim_arg (dim);
203 f->rank = mask->rank - 1;
204 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
207 f->value.function.name =
208 gfc_get_string (PREFIX("any_%c%d"), gfc_type_letter (mask->ts.type),
214 gfc_resolve_asin (gfc_expr * f, gfc_expr * x)
217 f->value.function.name =
218 gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
222 gfc_resolve_asinh (gfc_expr * f, gfc_expr * x)
225 f->value.function.name =
226 gfc_get_string ("__asinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
230 gfc_resolve_atan (gfc_expr * f, gfc_expr * x)
233 f->value.function.name =
234 gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
238 gfc_resolve_atanh (gfc_expr * f, gfc_expr * x)
241 f->value.function.name =
242 gfc_get_string ("__atanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
246 gfc_resolve_atan2 (gfc_expr * f, gfc_expr * x,
247 gfc_expr * y ATTRIBUTE_UNUSED)
250 f->value.function.name =
251 gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
255 /* Resolve the BESYN and BESJN intrinsics. */
258 gfc_resolve_besn (gfc_expr * f, gfc_expr * n, gfc_expr * x)
263 if (n->ts.kind != gfc_c_int_kind)
265 ts.type = BT_INTEGER;
266 ts.kind = gfc_c_int_kind;
267 gfc_convert_type (n, &ts, 2);
269 f->value.function.name = gfc_get_string ("<intrinsic>");
274 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)
287 f->ts.type = BT_INTEGER;
288 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
289 : mpz_get_si (kind->value.integer);
291 f->value.function.name =
292 gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind,
293 gfc_type_letter (a->ts.type), a->ts.kind);
298 gfc_resolve_char (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
300 f->ts.type = BT_CHARACTER;
301 f->ts.kind = (kind == NULL) ? gfc_default_character_kind
302 : mpz_get_si (kind->value.integer);
304 f->value.function.name =
305 gfc_get_string ("__char_%d_%c%d", f->ts.kind,
306 gfc_type_letter (a->ts.type), a->ts.kind);
311 gfc_resolve_chdir (gfc_expr * f, gfc_expr * d ATTRIBUTE_UNUSED)
313 f->ts.type = BT_INTEGER;
314 f->ts.kind = gfc_default_integer_kind;
315 f->value.function.name = gfc_get_string (PREFIX("chdir_i%d"), f->ts.kind);
320 gfc_resolve_chdir_sub (gfc_code * c)
325 if (c->ext.actual->next->expr != NULL)
326 kind = c->ext.actual->next->expr->ts.kind;
328 kind = gfc_default_integer_kind;
330 name = gfc_get_string (PREFIX("chdir_i%d_sub"), kind);
331 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
336 gfc_resolve_cmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y, gfc_expr * kind)
338 f->ts.type = BT_COMPLEX;
339 f->ts.kind = (kind == NULL) ? gfc_default_real_kind
340 : mpz_get_si (kind->value.integer);
343 f->value.function.name =
344 gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind,
345 gfc_type_letter (x->ts.type), x->ts.kind);
347 f->value.function.name =
348 gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
349 gfc_type_letter (x->ts.type), x->ts.kind,
350 gfc_type_letter (y->ts.type), y->ts.kind);
354 gfc_resolve_dcmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y)
356 gfc_resolve_cmplx (f, x, y, gfc_int_expr (gfc_default_double_kind));
360 gfc_resolve_conjg (gfc_expr * f, gfc_expr * x)
363 f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind);
368 gfc_resolve_cos (gfc_expr * f, gfc_expr * x)
371 f->value.function.name =
372 gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
377 gfc_resolve_cosh (gfc_expr * f, gfc_expr * x)
380 f->value.function.name =
381 gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
386 gfc_resolve_count (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
388 f->ts.type = BT_INTEGER;
389 f->ts.kind = gfc_default_integer_kind;
393 f->rank = mask->rank - 1;
394 gfc_resolve_dim_arg (dim);
395 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
398 f->value.function.name =
399 gfc_get_string (PREFIX("count_%d_%c%d"), f->ts.kind,
400 gfc_type_letter (mask->ts.type), mask->ts.kind);
405 gfc_resolve_cshift (gfc_expr * f, gfc_expr * array,
412 f->rank = array->rank;
413 f->shape = gfc_copy_shape (array->shape, array->rank);
420 /* Convert shift to at least gfc_default_integer_kind, so we don't need
421 kind=1 and kind=2 versions of the library functions. */
422 if (shift->ts.kind < gfc_default_integer_kind)
425 ts.type = BT_INTEGER;
426 ts.kind = gfc_default_integer_kind;
427 gfc_convert_type_warn (shift, &ts, 2, 0);
432 gfc_resolve_dim_arg (dim);
433 /* Convert dim to shift's kind, so we don't need so many variations. */
434 if (dim->ts.kind != shift->ts.kind)
435 gfc_convert_type_warn (dim, &shift->ts, 2, 0);
437 f->value.function.name =
438 gfc_get_string (PREFIX("cshift%d_%d%s"), n, shift->ts.kind,
439 array->ts.type == BT_CHARACTER ? "_char" : "");
444 gfc_resolve_dble (gfc_expr * f, gfc_expr * a)
446 f->ts.type = BT_REAL;
447 f->ts.kind = gfc_default_double_kind;
448 f->value.function.name =
449 gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
454 gfc_resolve_dim (gfc_expr * f, gfc_expr * x,
455 gfc_expr * y ATTRIBUTE_UNUSED)
458 f->value.function.name =
459 gfc_get_string ("__dim_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
464 gfc_resolve_dot_product (gfc_expr * f, gfc_expr * a, gfc_expr * b)
468 if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
470 f->ts.type = BT_LOGICAL;
471 f->ts.kind = gfc_default_logical_kind;
475 temp.expr_type = EXPR_OP;
476 gfc_clear_ts (&temp.ts);
477 temp.value.op.operator = INTRINSIC_NONE;
478 temp.value.op.op1 = a;
479 temp.value.op.op2 = b;
480 gfc_type_convert_binary (&temp);
484 f->value.function.name =
485 gfc_get_string (PREFIX("dot_product_%c%d"), gfc_type_letter (f->ts.type),
491 gfc_resolve_dprod (gfc_expr * f,
492 gfc_expr * a ATTRIBUTE_UNUSED,
493 gfc_expr * b ATTRIBUTE_UNUSED)
495 f->ts.kind = gfc_default_double_kind;
496 f->ts.type = BT_REAL;
498 f->value.function.name = gfc_get_string ("__dprod_r%d", f->ts.kind);
503 gfc_resolve_eoshift (gfc_expr * f, gfc_expr * array,
511 f->rank = array->rank;
512 f->shape = gfc_copy_shape (array->shape, array->rank);
517 if (boundary && boundary->rank > 0)
520 /* Convert shift to at least gfc_default_integer_kind, so we don't need
521 kind=1 and kind=2 versions of the library functions. */
522 if (shift->ts.kind < gfc_default_integer_kind)
525 ts.type = BT_INTEGER;
526 ts.kind = gfc_default_integer_kind;
527 gfc_convert_type_warn (shift, &ts, 2, 0);
532 gfc_resolve_dim_arg (dim);
533 /* Convert dim to shift's kind, so we don't need so many variations. */
534 if (dim->ts.kind != shift->ts.kind)
535 gfc_convert_type_warn (dim, &shift->ts, 2, 0);
538 f->value.function.name =
539 gfc_get_string (PREFIX("eoshift%d_%d%s"), n, shift->ts.kind,
540 array->ts.type == BT_CHARACTER ? "_char" : "");
545 gfc_resolve_exp (gfc_expr * f, gfc_expr * x)
548 f->value.function.name =
549 gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
554 gfc_resolve_exponent (gfc_expr * f, gfc_expr * x)
556 f->ts.type = BT_INTEGER;
557 f->ts.kind = gfc_default_integer_kind;
559 f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind);
564 gfc_resolve_floor (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
566 f->ts.type = BT_INTEGER;
567 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
568 : mpz_get_si (kind->value.integer);
570 f->value.function.name =
571 gfc_get_string ("__floor%d_%c%d", f->ts.kind,
572 gfc_type_letter (a->ts.type), a->ts.kind);
577 gfc_resolve_fnum (gfc_expr * f, gfc_expr * n)
579 f->ts.type = BT_INTEGER;
580 f->ts.kind = gfc_default_integer_kind;
581 if (n->ts.kind != f->ts.kind)
582 gfc_convert_type (n, &f->ts, 2);
583 f->value.function.name = gfc_get_string (PREFIX("fnum_i%d"), f->ts.kind);
588 gfc_resolve_fraction (gfc_expr * f, gfc_expr * x)
591 f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind);
595 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
598 gfc_resolve_g77_math1 (gfc_expr * f, gfc_expr * x)
601 f->value.function.name = gfc_get_string ("<intrinsic>");
606 gfc_resolve_getcwd (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
608 f->ts.type = BT_INTEGER;
610 f->value.function.name = gfc_get_string (PREFIX("getcwd"));
615 gfc_resolve_getgid (gfc_expr * f)
617 f->ts.type = BT_INTEGER;
619 f->value.function.name = gfc_get_string (PREFIX("getgid"));
624 gfc_resolve_getpid (gfc_expr * f)
626 f->ts.type = BT_INTEGER;
628 f->value.function.name = gfc_get_string (PREFIX("getpid"));
633 gfc_resolve_getuid (gfc_expr * f)
635 f->ts.type = BT_INTEGER;
637 f->value.function.name = gfc_get_string (PREFIX("getuid"));
641 gfc_resolve_hostnm (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
643 f->ts.type = BT_INTEGER;
645 f->value.function.name = gfc_get_string (PREFIX ("hostnm"));
649 gfc_resolve_iand (gfc_expr * f, gfc_expr * i, gfc_expr * j)
651 /* If the kind of i and j are different, then g77 cross-promoted the
652 kinds to the largest value. The Fortran 95 standard requires the
654 if (i->ts.kind != j->ts.kind)
656 if (i->ts.kind == gfc_kind_max (i,j))
657 gfc_convert_type(j, &i->ts, 2);
659 gfc_convert_type(i, &j->ts, 2);
663 f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind);
668 gfc_resolve_ibclr (gfc_expr * f, gfc_expr * i, gfc_expr * pos ATTRIBUTE_UNUSED)
671 f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind);
676 gfc_resolve_ibits (gfc_expr * f, gfc_expr * i,
677 gfc_expr * pos ATTRIBUTE_UNUSED,
678 gfc_expr * len ATTRIBUTE_UNUSED)
681 f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind);
686 gfc_resolve_ibset (gfc_expr * f, gfc_expr * i,
687 gfc_expr * pos ATTRIBUTE_UNUSED)
690 f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind);
695 gfc_resolve_ichar (gfc_expr * f, gfc_expr * c)
697 f->ts.type = BT_INTEGER;
698 f->ts.kind = gfc_default_integer_kind;
700 f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
705 gfc_resolve_idnint (gfc_expr * f, gfc_expr * a)
707 gfc_resolve_nint (f, a, NULL);
712 gfc_resolve_ierrno (gfc_expr * f)
714 f->ts.type = BT_INTEGER;
715 f->ts.kind = gfc_default_integer_kind;
716 f->value.function.name = gfc_get_string (PREFIX("ierrno_i%d"), f->ts.kind);
721 gfc_resolve_ieor (gfc_expr * f, gfc_expr * i, gfc_expr * j)
723 /* If the kind of i and j are different, then g77 cross-promoted the
724 kinds to the largest value. The Fortran 95 standard requires the
726 if (i->ts.kind != j->ts.kind)
728 if (i->ts.kind == gfc_kind_max (i,j))
729 gfc_convert_type(j, &i->ts, 2);
731 gfc_convert_type(i, &j->ts, 2);
735 f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind);
740 gfc_resolve_ior (gfc_expr * f, gfc_expr * i, gfc_expr * j)
742 /* If the kind of i and j are different, then g77 cross-promoted the
743 kinds to the largest value. The Fortran 95 standard requires the
745 if (i->ts.kind != j->ts.kind)
747 if (i->ts.kind == gfc_kind_max (i,j))
748 gfc_convert_type(j, &i->ts, 2);
750 gfc_convert_type(i, &j->ts, 2);
754 f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind);
759 gfc_resolve_int (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
761 f->ts.type = BT_INTEGER;
762 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
763 : mpz_get_si (kind->value.integer);
765 f->value.function.name =
766 gfc_get_string ("__int_%d_%c%d", f->ts.kind, gfc_type_letter (a->ts.type),
772 gfc_resolve_isatty (gfc_expr * f, gfc_expr * u)
776 f->ts.type = BT_LOGICAL;
777 f->ts.kind = gfc_default_integer_kind;
778 if (u->ts.kind != gfc_c_int_kind)
780 ts.type = BT_INTEGER;
781 ts.kind = gfc_c_int_kind;
784 gfc_convert_type (u, &ts, 2);
787 f->value.function.name = gfc_get_string (PREFIX("isatty_l%d"), f->ts.kind);
792 gfc_resolve_ishft (gfc_expr * f, gfc_expr * i, gfc_expr * shift)
795 f->value.function.name =
796 gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
801 gfc_resolve_ishftc (gfc_expr * f, gfc_expr * i, gfc_expr * shift,
806 s_kind = (size == NULL) ? gfc_default_integer_kind : shift->ts.kind;
809 f->value.function.name =
810 gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
815 gfc_resolve_kill (gfc_expr * f, ATTRIBUTE_UNUSED gfc_expr * p,
816 ATTRIBUTE_UNUSED gfc_expr * s)
818 f->ts.type = BT_INTEGER;
819 f->ts.kind = gfc_default_integer_kind;
821 f->value.function.name = gfc_get_string (PREFIX("kill_i%d"), f->ts.kind);
826 gfc_resolve_lbound (gfc_expr * f, gfc_expr * array,
829 static char lbound[] = "__lbound";
831 f->ts.type = BT_INTEGER;
832 f->ts.kind = gfc_default_integer_kind;
837 f->shape = gfc_get_shape (1);
838 mpz_init_set_ui (f->shape[0], array->rank);
841 f->value.function.name = lbound;
846 gfc_resolve_len (gfc_expr * f, gfc_expr * string)
848 f->ts.type = BT_INTEGER;
849 f->ts.kind = gfc_default_integer_kind;
850 f->value.function.name = gfc_get_string ("__len_%d", string->ts.kind);
855 gfc_resolve_len_trim (gfc_expr * f, gfc_expr * string)
857 f->ts.type = BT_INTEGER;
858 f->ts.kind = gfc_default_integer_kind;
859 f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
864 gfc_resolve_link (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
865 gfc_expr * p2 ATTRIBUTE_UNUSED)
867 f->ts.type = BT_INTEGER;
868 f->ts.kind = gfc_default_integer_kind;
869 f->value.function.name = gfc_get_string (PREFIX("link_i%d"), f->ts.kind);
874 gfc_resolve_loc (gfc_expr *f, gfc_expr *x)
876 f->ts.type= BT_INTEGER;
877 f->ts.kind = gfc_index_integer_kind;
878 f->value.function.name = gfc_get_string ("__loc_%d", x->ts.kind);
883 gfc_resolve_log (gfc_expr * f, gfc_expr * x)
886 f->value.function.name =
887 gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
892 gfc_resolve_log10 (gfc_expr * f, gfc_expr * x)
895 f->value.function.name =
896 gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
901 gfc_resolve_logical (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
903 f->ts.type = BT_LOGICAL;
904 f->ts.kind = (kind == NULL) ? gfc_default_logical_kind
905 : mpz_get_si (kind->value.integer);
908 f->value.function.name =
909 gfc_get_string ("__logical_%d_%c%d", f->ts.kind,
910 gfc_type_letter (a->ts.type), a->ts.kind);
915 gfc_resolve_matmul (gfc_expr * f, gfc_expr * a, gfc_expr * b)
919 if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
921 f->ts.type = BT_LOGICAL;
922 f->ts.kind = gfc_default_logical_kind;
926 temp.expr_type = EXPR_OP;
927 gfc_clear_ts (&temp.ts);
928 temp.value.op.operator = INTRINSIC_NONE;
929 temp.value.op.op1 = a;
930 temp.value.op.op2 = b;
931 gfc_type_convert_binary (&temp);
935 f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
937 f->value.function.name =
938 gfc_get_string (PREFIX("matmul_%c%d"), gfc_type_letter (f->ts.type),
944 gfc_resolve_minmax (const char * name, gfc_expr * f, gfc_actual_arglist * args)
946 gfc_actual_arglist *a;
948 f->ts.type = args->expr->ts.type;
949 f->ts.kind = args->expr->ts.kind;
950 /* Find the largest type kind. */
951 for (a = args->next; a; a = a->next)
953 if (a->expr->ts.kind > f->ts.kind)
954 f->ts.kind = a->expr->ts.kind;
957 /* Convert all parameters to the required kind. */
958 for (a = args; a; a = a->next)
960 if (a->expr->ts.kind != f->ts.kind)
961 gfc_convert_type (a->expr, &f->ts, 2);
964 f->value.function.name =
965 gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind);
970 gfc_resolve_max (gfc_expr * f, gfc_actual_arglist * args)
972 gfc_resolve_minmax ("__max_%c%d", f, args);
977 gfc_resolve_maxloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
982 f->ts.type = BT_INTEGER;
983 f->ts.kind = gfc_default_integer_kind;
989 f->rank = array->rank - 1;
990 gfc_resolve_dim_arg (dim);
993 name = mask ? "mmaxloc" : "maxloc";
994 f->value.function.name =
995 gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
996 gfc_type_letter (array->ts.type), array->ts.kind);
1001 gfc_resolve_maxval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1008 f->rank = array->rank - 1;
1009 gfc_resolve_dim_arg (dim);
1012 f->value.function.name =
1013 gfc_get_string (PREFIX("%s_%c%d"), mask ? "mmaxval" : "maxval",
1014 gfc_type_letter (array->ts.type), array->ts.kind);
1019 gfc_resolve_merge (gfc_expr * f, gfc_expr * tsource,
1020 gfc_expr * fsource ATTRIBUTE_UNUSED,
1021 gfc_expr * mask ATTRIBUTE_UNUSED)
1023 if (tsource->ts.type == BT_CHARACTER)
1024 check_charlen_present (tsource);
1026 f->ts = tsource->ts;
1027 f->value.function.name =
1028 gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
1034 gfc_resolve_min (gfc_expr * f, gfc_actual_arglist * args)
1036 gfc_resolve_minmax ("__min_%c%d", f, args);
1041 gfc_resolve_minloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1046 f->ts.type = BT_INTEGER;
1047 f->ts.kind = gfc_default_integer_kind;
1053 f->rank = array->rank - 1;
1054 gfc_resolve_dim_arg (dim);
1057 name = mask ? "mminloc" : "minloc";
1058 f->value.function.name =
1059 gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1060 gfc_type_letter (array->ts.type), array->ts.kind);
1065 gfc_resolve_minval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1072 f->rank = array->rank - 1;
1073 gfc_resolve_dim_arg (dim);
1076 f->value.function.name =
1077 gfc_get_string (PREFIX("%s_%c%d"), mask ? "mminval" : "minval",
1078 gfc_type_letter (array->ts.type), array->ts.kind);
1083 gfc_resolve_mod (gfc_expr * f, gfc_expr * a,
1084 gfc_expr * p ATTRIBUTE_UNUSED)
1087 f->value.function.name =
1088 gfc_get_string ("__mod_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
1093 gfc_resolve_modulo (gfc_expr * f, gfc_expr * a,
1094 gfc_expr * p ATTRIBUTE_UNUSED)
1097 f->value.function.name =
1098 gfc_get_string ("__modulo_%c%d", gfc_type_letter (a->ts.type),
1103 gfc_resolve_nearest (gfc_expr * f, gfc_expr * a, gfc_expr *p ATTRIBUTE_UNUSED)
1106 f->value.function.name =
1107 gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
1112 gfc_resolve_nint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
1114 f->ts.type = BT_INTEGER;
1115 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
1116 : mpz_get_si (kind->value.integer);
1118 f->value.function.name =
1119 gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
1124 gfc_resolve_not (gfc_expr * f, gfc_expr * i)
1127 f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
1132 gfc_resolve_pack (gfc_expr * f, gfc_expr * array, gfc_expr * mask,
1133 gfc_expr * vector ATTRIBUTE_UNUSED)
1138 if (mask->rank != 0)
1139 f->value.function.name = (array->ts.type == BT_CHARACTER
1140 ? PREFIX("pack_char")
1144 /* We convert mask to default logical only in the scalar case.
1145 In the array case we can simply read the array as if it were
1146 of type default logical. */
1147 if (mask->ts.kind != gfc_default_logical_kind)
1151 ts.type = BT_LOGICAL;
1152 ts.kind = gfc_default_logical_kind;
1153 gfc_convert_type (mask, &ts, 2);
1156 f->value.function.name = (array->ts.type == BT_CHARACTER
1157 ? PREFIX("pack_s_char")
1158 : PREFIX("pack_s"));
1164 gfc_resolve_product (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1171 f->rank = array->rank - 1;
1172 gfc_resolve_dim_arg (dim);
1175 f->value.function.name =
1176 gfc_get_string (PREFIX("%s_%c%d"), mask ? "mproduct" : "product",
1177 gfc_type_letter (array->ts.type), array->ts.kind);
1182 gfc_resolve_real (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
1184 f->ts.type = BT_REAL;
1187 f->ts.kind = mpz_get_si (kind->value.integer);
1189 f->ts.kind = (a->ts.type == BT_COMPLEX) ?
1190 a->ts.kind : gfc_default_real_kind;
1192 f->value.function.name =
1193 gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1194 gfc_type_letter (a->ts.type), a->ts.kind);
1199 gfc_resolve_realpart (gfc_expr * f, gfc_expr * a)
1201 f->ts.type = BT_REAL;
1202 f->ts.kind = a->ts.kind;
1203 f->value.function.name =
1204 gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1205 gfc_type_letter (a->ts.type), a->ts.kind);
1210 gfc_resolve_rename (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
1211 gfc_expr * p2 ATTRIBUTE_UNUSED)
1213 f->ts.type = BT_INTEGER;
1214 f->ts.kind = gfc_default_integer_kind;
1215 f->value.function.name = gfc_get_string (PREFIX("rename_i%d"), f->ts.kind);
1220 gfc_resolve_repeat (gfc_expr * f, gfc_expr * string,
1221 gfc_expr * ncopies ATTRIBUTE_UNUSED)
1223 f->ts.type = BT_CHARACTER;
1224 f->ts.kind = string->ts.kind;
1225 f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
1230 gfc_resolve_reshape (gfc_expr * f, gfc_expr * source, gfc_expr * shape,
1231 gfc_expr * pad ATTRIBUTE_UNUSED,
1232 gfc_expr * order ATTRIBUTE_UNUSED)
1240 gfc_array_size (shape, &rank);
1241 f->rank = mpz_get_si (rank);
1243 switch (source->ts.type)
1246 kind = source->ts.kind * 2;
1252 kind = source->ts.kind;
1266 if (source->ts.type == BT_COMPLEX)
1267 f->value.function.name =
1268 gfc_get_string (PREFIX("reshape_%c%d"),
1269 gfc_type_letter (BT_COMPLEX), source->ts.kind);
1271 f->value.function.name =
1272 gfc_get_string (PREFIX("reshape_%d"), source->ts.kind);
1277 f->value.function.name = (source->ts.type == BT_CHARACTER
1278 ? PREFIX("reshape_char")
1279 : PREFIX("reshape"));
1283 /* TODO: Make this work with a constant ORDER parameter. */
1284 if (shape->expr_type == EXPR_ARRAY
1285 && gfc_is_constant_expr (shape)
1289 f->shape = gfc_get_shape (f->rank);
1290 c = shape->value.constructor;
1291 for (i = 0; i < f->rank; i++)
1293 mpz_init_set (f->shape[i], c->expr->value.integer);
1298 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
1299 so many runtime variations. */
1300 if (shape->ts.kind != gfc_index_integer_kind)
1302 gfc_typespec ts = shape->ts;
1303 ts.kind = gfc_index_integer_kind;
1304 gfc_convert_type_warn (shape, &ts, 2, 0);
1306 if (order && order->ts.kind != gfc_index_integer_kind)
1307 gfc_convert_type_warn (order, &shape->ts, 2, 0);
1312 gfc_resolve_rrspacing (gfc_expr * f, gfc_expr * x)
1315 f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
1320 gfc_resolve_scale (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1324 /* The implementation calls scalbn which takes an int as the
1326 if (i->ts.kind != gfc_c_int_kind)
1330 ts.type = BT_INTEGER;
1331 ts.kind = gfc_default_integer_kind;
1333 gfc_convert_type_warn (i, &ts, 2, 0);
1336 f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
1341 gfc_resolve_scan (gfc_expr * f, gfc_expr * string,
1342 gfc_expr * set ATTRIBUTE_UNUSED,
1343 gfc_expr * back ATTRIBUTE_UNUSED)
1345 f->ts.type = BT_INTEGER;
1346 f->ts.kind = gfc_default_integer_kind;
1347 f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
1352 gfc_resolve_set_exponent (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1356 /* The library implementation uses GFC_INTEGER_4 unconditionally,
1357 convert type so we don't have to implement all possible
1359 if (i->ts.kind != 4)
1363 ts.type = BT_INTEGER;
1364 ts.kind = gfc_default_integer_kind;
1366 gfc_convert_type_warn (i, &ts, 2, 0);
1369 f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
1374 gfc_resolve_shape (gfc_expr * f, gfc_expr * array)
1376 f->ts.type = BT_INTEGER;
1377 f->ts.kind = gfc_default_integer_kind;
1379 f->value.function.name = gfc_get_string (PREFIX("shape_%d"), f->ts.kind);
1380 f->shape = gfc_get_shape (1);
1381 mpz_init_set_ui (f->shape[0], array->rank);
1386 gfc_resolve_sign (gfc_expr * f, gfc_expr * a, gfc_expr * b ATTRIBUTE_UNUSED)
1389 f->value.function.name =
1390 gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
1395 gfc_resolve_signal (gfc_expr * f, gfc_expr *number, gfc_expr *handler)
1397 f->ts.type = BT_INTEGER;
1398 f->ts.kind = gfc_c_int_kind;
1400 /* handler can be either BT_INTEGER or BT_PROCEDURE */
1401 if (handler->ts.type == BT_INTEGER)
1403 if (handler->ts.kind != gfc_c_int_kind)
1404 gfc_convert_type (handler, &f->ts, 2);
1405 f->value.function.name = gfc_get_string (PREFIX("signal_func_int"));
1408 f->value.function.name = gfc_get_string (PREFIX("signal_func"));
1410 if (number->ts.kind != gfc_c_int_kind)
1411 gfc_convert_type (number, &f->ts, 2);
1416 gfc_resolve_sin (gfc_expr * f, gfc_expr * x)
1419 f->value.function.name =
1420 gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1425 gfc_resolve_sinh (gfc_expr * f, gfc_expr * x)
1428 f->value.function.name =
1429 gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1434 gfc_resolve_spacing (gfc_expr * f, gfc_expr * x)
1437 f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
1442 gfc_resolve_spread (gfc_expr * f, gfc_expr * source,
1446 if (source->ts.type == BT_CHARACTER)
1447 check_charlen_present (source);
1450 f->rank = source->rank + 1;
1451 if (source->rank == 0)
1452 f->value.function.name = (source->ts.type == BT_CHARACTER
1453 ? PREFIX("spread_char_scalar")
1454 : PREFIX("spread_scalar"));
1456 f->value.function.name = (source->ts.type == BT_CHARACTER
1457 ? PREFIX("spread_char")
1458 : PREFIX("spread"));
1460 gfc_resolve_dim_arg (dim);
1461 gfc_resolve_index (ncopies, 1);
1466 gfc_resolve_sqrt (gfc_expr * f, gfc_expr * x)
1469 f->value.function.name =
1470 gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1474 /* Resolve the g77 compatibility function STAT AND FSTAT. */
1477 gfc_resolve_stat (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED,
1478 gfc_expr * a ATTRIBUTE_UNUSED)
1480 f->ts.type = BT_INTEGER;
1481 f->ts.kind = gfc_default_integer_kind;
1482 f->value.function.name = gfc_get_string (PREFIX("stat_i%d"), f->ts.kind);
1487 gfc_resolve_fstat (gfc_expr * f, gfc_expr * n, gfc_expr * a ATTRIBUTE_UNUSED)
1489 f->ts.type = BT_INTEGER;
1490 f->ts.kind = gfc_default_integer_kind;
1491 if (n->ts.kind != f->ts.kind)
1492 gfc_convert_type (n, &f->ts, 2);
1494 f->value.function.name = gfc_get_string (PREFIX("fstat_i%d"), f->ts.kind);
1499 gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1506 f->rank = array->rank - 1;
1507 gfc_resolve_dim_arg (dim);
1510 f->value.function.name =
1511 gfc_get_string (PREFIX("%s_%c%d"), mask ? "msum" : "sum",
1512 gfc_type_letter (array->ts.type), array->ts.kind);
1517 gfc_resolve_symlnk (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
1518 gfc_expr * p2 ATTRIBUTE_UNUSED)
1520 f->ts.type = BT_INTEGER;
1521 f->ts.kind = gfc_default_integer_kind;
1522 f->value.function.name = gfc_get_string (PREFIX("symlnk_i%d"), f->ts.kind);
1526 /* Resolve the g77 compatibility function SYSTEM. */
1529 gfc_resolve_system (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
1531 f->ts.type = BT_INTEGER;
1533 f->value.function.name = gfc_get_string (PREFIX("system"));
1538 gfc_resolve_tan (gfc_expr * f, gfc_expr * x)
1541 f->value.function.name =
1542 gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1547 gfc_resolve_tanh (gfc_expr * f, gfc_expr * x)
1550 f->value.function.name =
1551 gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1556 gfc_resolve_time (gfc_expr * f)
1558 f->ts.type = BT_INTEGER;
1560 f->value.function.name = gfc_get_string (PREFIX("time_func"));
1565 gfc_resolve_time8 (gfc_expr * f)
1567 f->ts.type = BT_INTEGER;
1569 f->value.function.name = gfc_get_string (PREFIX("time8_func"));
1574 gfc_resolve_transfer (gfc_expr * f, gfc_expr * source ATTRIBUTE_UNUSED,
1575 gfc_expr * mold, gfc_expr * size)
1577 /* TODO: Make this do something meaningful. */
1578 static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
1582 if (size == NULL && mold->rank == 0)
1585 f->value.function.name = transfer0;
1590 f->value.function.name = transfer1;
1596 gfc_resolve_transpose (gfc_expr * f, gfc_expr * matrix)
1604 f->shape = gfc_get_shape (2);
1605 mpz_init_set (f->shape[0], matrix->shape[1]);
1606 mpz_init_set (f->shape[1], matrix->shape[0]);
1609 kind = matrix->ts.kind;
1617 switch (matrix->ts.type)
1620 f->value.function.name =
1621 gfc_get_string (PREFIX("transpose_c%d"), kind);
1627 /* Use the integer routines for real and logical cases. This
1628 assumes they all have the same alignment requirements. */
1629 f->value.function.name =
1630 gfc_get_string (PREFIX("transpose_i%d"), kind);
1634 f->value.function.name = PREFIX("transpose");
1640 f->value.function.name = (matrix->ts.type == BT_CHARACTER
1641 ? PREFIX("transpose_char")
1642 : PREFIX("transpose"));
1649 gfc_resolve_trim (gfc_expr * f, gfc_expr * string)
1651 f->ts.type = BT_CHARACTER;
1652 f->ts.kind = string->ts.kind;
1653 f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
1658 gfc_resolve_ubound (gfc_expr * f, gfc_expr * array,
1661 static char ubound[] = "__ubound";
1663 f->ts.type = BT_INTEGER;
1664 f->ts.kind = gfc_default_integer_kind;
1669 f->shape = gfc_get_shape (1);
1670 mpz_init_set_ui (f->shape[0], array->rank);
1673 f->value.function.name = ubound;
1677 /* Resolve the g77 compatibility function UMASK. */
1680 gfc_resolve_umask (gfc_expr * f, gfc_expr * n)
1682 f->ts.type = BT_INTEGER;
1683 f->ts.kind = n->ts.kind;
1684 f->value.function.name = gfc_get_string (PREFIX("umask_i%d"), n->ts.kind);
1688 /* Resolve the g77 compatibility function UNLINK. */
1691 gfc_resolve_unlink (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
1693 f->ts.type = BT_INTEGER;
1695 f->value.function.name = gfc_get_string (PREFIX("unlink"));
1699 gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask,
1700 gfc_expr * field ATTRIBUTE_UNUSED)
1703 f->rank = mask->rank;
1705 f->value.function.name =
1706 gfc_get_string (PREFIX("unpack%d%s"), field->rank > 0 ? 1 : 0,
1707 vector->ts.type == BT_CHARACTER ? "_char" : "");
1712 gfc_resolve_verify (gfc_expr * f, gfc_expr * string,
1713 gfc_expr * set ATTRIBUTE_UNUSED,
1714 gfc_expr * back ATTRIBUTE_UNUSED)
1716 f->ts.type = BT_INTEGER;
1717 f->ts.kind = gfc_default_integer_kind;
1718 f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
1722 /* Intrinsic subroutine resolution. */
1725 gfc_resolve_alarm_sub (gfc_code * c)
1728 gfc_expr *seconds, *handler, *status;
1731 seconds = c->ext.actual->expr;
1732 handler = c->ext.actual->next->expr;
1733 status = c->ext.actual->next->next->expr;
1734 ts.type = BT_INTEGER;
1735 ts.kind = gfc_c_int_kind;
1737 /* handler can be either BT_INTEGER or BT_PROCEDURE */
1738 if (handler->ts.type == BT_INTEGER)
1740 if (handler->ts.kind != gfc_c_int_kind)
1741 gfc_convert_type (handler, &ts, 2);
1742 name = gfc_get_string (PREFIX("alarm_sub_int"));
1745 name = gfc_get_string (PREFIX("alarm_sub"));
1747 if (seconds->ts.kind != gfc_c_int_kind)
1748 gfc_convert_type (seconds, &ts, 2);
1749 if (status != NULL && status->ts.kind != gfc_c_int_kind)
1750 gfc_convert_type (status, &ts, 2);
1752 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1756 gfc_resolve_cpu_time (gfc_code * c ATTRIBUTE_UNUSED)
1760 name = gfc_get_string (PREFIX("cpu_time_%d"),
1761 c->ext.actual->expr->ts.kind);
1762 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1767 gfc_resolve_mvbits (gfc_code * c)
1772 kind = c->ext.actual->expr->ts.kind;
1773 name = gfc_get_string (PREFIX("mvbits_i%d"), kind);
1775 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1780 gfc_resolve_random_number (gfc_code * c ATTRIBUTE_UNUSED)
1785 kind = c->ext.actual->expr->ts.kind;
1786 if (c->ext.actual->expr->rank == 0)
1787 name = gfc_get_string (PREFIX("random_r%d"), kind);
1789 name = gfc_get_string (PREFIX("arandom_r%d"), kind);
1791 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1796 gfc_resolve_rename_sub (gfc_code * c)
1801 if (c->ext.actual->next->next->expr != NULL)
1802 kind = c->ext.actual->next->next->expr->ts.kind;
1804 kind = gfc_default_integer_kind;
1806 name = gfc_get_string (PREFIX("rename_i%d_sub"), kind);
1807 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1812 gfc_resolve_kill_sub (gfc_code * c)
1817 if (c->ext.actual->next->next->expr != NULL)
1818 kind = c->ext.actual->next->next->expr->ts.kind;
1820 kind = gfc_default_integer_kind;
1822 name = gfc_get_string (PREFIX("kill_i%d_sub"), kind);
1823 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1828 gfc_resolve_link_sub (gfc_code * c)
1833 if (c->ext.actual->next->next->expr != NULL)
1834 kind = c->ext.actual->next->next->expr->ts.kind;
1836 kind = gfc_default_integer_kind;
1838 name = gfc_get_string (PREFIX("link_i%d_sub"), kind);
1839 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1844 gfc_resolve_symlnk_sub (gfc_code * c)
1849 if (c->ext.actual->next->next->expr != NULL)
1850 kind = c->ext.actual->next->next->expr->ts.kind;
1852 kind = gfc_default_integer_kind;
1854 name = gfc_get_string (PREFIX("symlnk_i%d_sub"), kind);
1855 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1859 /* G77 compatibility subroutines etime() and dtime(). */
1862 gfc_resolve_etime_sub (gfc_code * c)
1866 name = gfc_get_string (PREFIX("etime_sub"));
1867 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1871 /* G77 compatibility subroutine second(). */
1874 gfc_resolve_second_sub (gfc_code * c)
1878 name = gfc_get_string (PREFIX("second_sub"));
1879 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1884 gfc_resolve_sleep_sub (gfc_code * c)
1889 if (c->ext.actual->expr != NULL)
1890 kind = c->ext.actual->expr->ts.kind;
1892 kind = gfc_default_integer_kind;
1894 name = gfc_get_string (PREFIX("sleep_i%d_sub"), kind);
1895 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1899 /* G77 compatibility function srand(). */
1902 gfc_resolve_srand (gfc_code * c)
1905 name = gfc_get_string (PREFIX("srand"));
1906 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1910 /* Resolve the getarg intrinsic subroutine. */
1913 gfc_resolve_getarg (gfc_code * c)
1918 kind = gfc_default_integer_kind;
1919 name = gfc_get_string (PREFIX("getarg_i%d"), kind);
1920 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1923 /* Resolve the getcwd intrinsic subroutine. */
1926 gfc_resolve_getcwd_sub (gfc_code * c)
1931 if (c->ext.actual->next->expr != NULL)
1932 kind = c->ext.actual->next->expr->ts.kind;
1934 kind = gfc_default_integer_kind;
1936 name = gfc_get_string (PREFIX("getcwd_i%d_sub"), kind);
1937 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1941 /* Resolve the get_command intrinsic subroutine. */
1944 gfc_resolve_get_command (gfc_code * c)
1949 kind = gfc_default_integer_kind;
1950 name = gfc_get_string (PREFIX("get_command_i%d"), kind);
1951 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1955 /* Resolve the get_command_argument intrinsic subroutine. */
1958 gfc_resolve_get_command_argument (gfc_code * c)
1963 kind = gfc_default_integer_kind;
1964 name = gfc_get_string (PREFIX("get_command_argument_i%d"), kind);
1965 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1968 /* Resolve the get_environment_variable intrinsic subroutine. */
1971 gfc_resolve_get_environment_variable (gfc_code * code)
1976 kind = gfc_default_integer_kind;
1977 name = gfc_get_string (PREFIX("get_environment_variable_i%d"), kind);
1978 code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1982 gfc_resolve_signal_sub (gfc_code * c)
1985 gfc_expr *number, *handler, *status;
1988 number = c->ext.actual->expr;
1989 handler = c->ext.actual->next->expr;
1990 status = c->ext.actual->next->next->expr;
1991 ts.type = BT_INTEGER;
1992 ts.kind = gfc_c_int_kind;
1994 /* handler can be either BT_INTEGER or BT_PROCEDURE */
1995 if (handler->ts.type == BT_INTEGER)
1997 if (handler->ts.kind != gfc_c_int_kind)
1998 gfc_convert_type (handler, &ts, 2);
1999 name = gfc_get_string (PREFIX("signal_sub_int"));
2002 name = gfc_get_string (PREFIX("signal_sub"));
2004 if (number->ts.kind != gfc_c_int_kind)
2005 gfc_convert_type (number, &ts, 2);
2006 if (status != NULL && status->ts.kind != gfc_c_int_kind)
2007 gfc_convert_type (status, &ts, 2);
2009 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2012 /* Resolve the SYSTEM intrinsic subroutine. */
2015 gfc_resolve_system_sub (gfc_code * c)
2019 name = gfc_get_string (PREFIX("system_sub"));
2020 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2023 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
2026 gfc_resolve_system_clock (gfc_code * c)
2031 if (c->ext.actual->expr != NULL)
2032 kind = c->ext.actual->expr->ts.kind;
2033 else if (c->ext.actual->next->expr != NULL)
2034 kind = c->ext.actual->next->expr->ts.kind;
2035 else if (c->ext.actual->next->next->expr != NULL)
2036 kind = c->ext.actual->next->next->expr->ts.kind;
2038 kind = gfc_default_integer_kind;
2040 name = gfc_get_string (PREFIX("system_clock_%d"), kind);
2041 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2044 /* Resolve the EXIT intrinsic subroutine. */
2047 gfc_resolve_exit (gfc_code * c)
2052 if (c->ext.actual->expr != NULL)
2053 kind = c->ext.actual->expr->ts.kind;
2055 kind = gfc_default_integer_kind;
2057 name = gfc_get_string (PREFIX("exit_i%d"), kind);
2058 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2061 /* Resolve the FLUSH intrinsic subroutine. */
2064 gfc_resolve_flush (gfc_code * c)
2070 ts.type = BT_INTEGER;
2071 ts.kind = gfc_default_integer_kind;
2072 n = c->ext.actual->expr;
2074 && n->ts.kind != ts.kind)
2075 gfc_convert_type (n, &ts, 2);
2077 name = gfc_get_string (PREFIX("flush_i%d"), ts.kind);
2078 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2083 gfc_resolve_gerror (gfc_code * c)
2085 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
2090 gfc_resolve_getlog (gfc_code * c)
2092 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
2097 gfc_resolve_hostnm_sub (gfc_code * c)
2102 if (c->ext.actual->next->expr != NULL)
2103 kind = c->ext.actual->next->expr->ts.kind;
2105 kind = gfc_default_integer_kind;
2107 name = gfc_get_string (PREFIX("hostnm_i%d_sub"), kind);
2108 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2113 gfc_resolve_perror (gfc_code * c)
2115 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
2118 /* Resolve the STAT and FSTAT intrinsic subroutines. */
2121 gfc_resolve_stat_sub (gfc_code * c)
2125 name = gfc_get_string (PREFIX("stat_i%d_sub"), gfc_default_integer_kind);
2126 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2131 gfc_resolve_fstat_sub (gfc_code * c)
2137 u = c->ext.actual->expr;
2138 ts = &c->ext.actual->next->expr->ts;
2139 if (u->ts.kind != ts->kind)
2140 gfc_convert_type (u, ts, 2);
2141 name = gfc_get_string (PREFIX("fstat_i%d_sub"), ts->kind);
2142 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2147 gfc_resolve_ttynam_sub (gfc_code * c)
2151 if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
2153 ts.type = BT_INTEGER;
2154 ts.kind = gfc_c_int_kind;
2157 gfc_convert_type (c->ext.actual->expr, &ts, 2);
2160 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("ttynam_sub"));
2164 /* Resolve the UMASK intrinsic subroutine. */
2167 gfc_resolve_umask_sub (gfc_code * c)
2172 if (c->ext.actual->next->expr != NULL)
2173 kind = c->ext.actual->next->expr->ts.kind;
2175 kind = gfc_default_integer_kind;
2177 name = gfc_get_string (PREFIX("umask_i%d_sub"), kind);
2178 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2181 /* Resolve the UNLINK intrinsic subroutine. */
2184 gfc_resolve_unlink_sub (gfc_code * c)
2189 if (c->ext.actual->next->expr != NULL)
2190 kind = c->ext.actual->next->expr->ts.kind;
2192 kind = gfc_default_integer_kind;
2194 name = gfc_get_string (PREFIX("unlink_i%d_sub"), kind);
2195 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);