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 /********************** Resolution functions **********************/
66 gfc_resolve_abs (gfc_expr * f, gfc_expr * a)
69 if (f->ts.type == BT_COMPLEX)
72 f->value.function.name =
73 gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
78 gfc_resolve_acos (gfc_expr * f, gfc_expr * x)
81 f->value.function.name =
82 gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
87 gfc_resolve_acosh (gfc_expr * f, gfc_expr * x)
90 f->value.function.name =
91 gfc_get_string ("__acosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
96 gfc_resolve_aimag (gfc_expr * f, gfc_expr * x)
99 f->ts.kind = x->ts.kind;
100 f->value.function.name =
101 gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
106 gfc_resolve_aint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
108 f->ts.type = a->ts.type;
109 f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
111 /* The resolved name is only used for specific intrinsics where
112 the return kind is the same as the arg kind. */
113 f->value.function.name =
114 gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
119 gfc_resolve_dint (gfc_expr * f, gfc_expr * a)
121 gfc_resolve_aint (f, a, NULL);
126 gfc_resolve_all (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
132 gfc_resolve_index (dim, 1);
133 f->rank = mask->rank - 1;
134 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
137 f->value.function.name =
138 gfc_get_string (PREFIX("all_%c%d"), gfc_type_letter (mask->ts.type),
144 gfc_resolve_anint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
146 f->ts.type = a->ts.type;
147 f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
149 /* The resolved name is only used for specific intrinsics where
150 the return kind is the same as the arg kind. */
151 f->value.function.name =
152 gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
157 gfc_resolve_dnint (gfc_expr * f, gfc_expr * a)
159 gfc_resolve_anint (f, a, NULL);
164 gfc_resolve_any (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
170 gfc_resolve_index (dim, 1);
171 f->rank = mask->rank - 1;
172 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
175 f->value.function.name =
176 gfc_get_string (PREFIX("any_%c%d"), gfc_type_letter (mask->ts.type),
182 gfc_resolve_asin (gfc_expr * f, gfc_expr * x)
185 f->value.function.name =
186 gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
190 gfc_resolve_asinh (gfc_expr * f, gfc_expr * x)
193 f->value.function.name =
194 gfc_get_string ("__asinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
198 gfc_resolve_atan (gfc_expr * f, gfc_expr * x)
201 f->value.function.name =
202 gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
206 gfc_resolve_atanh (gfc_expr * f, gfc_expr * x)
209 f->value.function.name =
210 gfc_get_string ("__atanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
214 gfc_resolve_atan2 (gfc_expr * f, gfc_expr * x,
215 gfc_expr * y ATTRIBUTE_UNUSED)
218 f->value.function.name =
219 gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
223 /* Resolve the BESYN and BESJN intrinsics. */
226 gfc_resolve_besn (gfc_expr * f, gfc_expr * n, gfc_expr * x)
231 if (n->ts.kind != gfc_c_int_kind)
233 ts.type = BT_INTEGER;
234 ts.kind = gfc_c_int_kind;
235 gfc_convert_type (n, &ts, 2);
237 f->value.function.name = gfc_get_string ("<intrinsic>");
242 gfc_resolve_btest (gfc_expr * f, gfc_expr * i, gfc_expr * pos)
244 f->ts.type = BT_LOGICAL;
245 f->ts.kind = gfc_default_logical_kind;
247 f->value.function.name = gfc_get_string ("__btest_%d_%d", i->ts.kind,
253 gfc_resolve_ceiling (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
255 f->ts.type = BT_INTEGER;
256 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
257 : mpz_get_si (kind->value.integer);
259 f->value.function.name =
260 gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind,
261 gfc_type_letter (a->ts.type), a->ts.kind);
266 gfc_resolve_char (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
268 f->ts.type = BT_CHARACTER;
269 f->ts.kind = (kind == NULL) ? gfc_default_character_kind
270 : mpz_get_si (kind->value.integer);
272 f->value.function.name =
273 gfc_get_string ("__char_%d_%c%d", f->ts.kind,
274 gfc_type_letter (a->ts.type), a->ts.kind);
279 gfc_resolve_chdir (gfc_expr * f, gfc_expr * d ATTRIBUTE_UNUSED)
281 f->ts.type = BT_INTEGER;
282 f->ts.kind = gfc_default_integer_kind;
283 f->value.function.name = gfc_get_string (PREFIX("chdir_i%d"), f->ts.kind);
288 gfc_resolve_chdir_sub (gfc_code * c)
293 if (c->ext.actual->next->expr != NULL)
294 kind = c->ext.actual->next->expr->ts.kind;
296 kind = gfc_default_integer_kind;
298 name = gfc_get_string (PREFIX("chdir_i%d_sub"), kind);
299 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
304 gfc_resolve_cmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y, gfc_expr * kind)
306 f->ts.type = BT_COMPLEX;
307 f->ts.kind = (kind == NULL) ? gfc_default_real_kind
308 : mpz_get_si (kind->value.integer);
311 f->value.function.name =
312 gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind,
313 gfc_type_letter (x->ts.type), x->ts.kind);
315 f->value.function.name =
316 gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
317 gfc_type_letter (x->ts.type), x->ts.kind,
318 gfc_type_letter (y->ts.type), y->ts.kind);
322 gfc_resolve_dcmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y)
324 gfc_resolve_cmplx (f, x, y, gfc_int_expr (gfc_default_double_kind));
328 gfc_resolve_conjg (gfc_expr * f, gfc_expr * x)
331 f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind);
336 gfc_resolve_cos (gfc_expr * f, gfc_expr * x)
339 f->value.function.name =
340 gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
345 gfc_resolve_cosh (gfc_expr * f, gfc_expr * x)
348 f->value.function.name =
349 gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
354 gfc_resolve_count (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
356 f->ts.type = BT_INTEGER;
357 f->ts.kind = gfc_default_integer_kind;
361 f->rank = mask->rank - 1;
362 gfc_resolve_index (dim, 1);
363 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
366 f->value.function.name =
367 gfc_get_string (PREFIX("count_%d_%c%d"), f->ts.kind,
368 gfc_type_letter (mask->ts.type), mask->ts.kind);
373 gfc_resolve_cshift (gfc_expr * f, gfc_expr * array,
380 f->rank = array->rank;
381 f->shape = gfc_copy_shape (array->shape, array->rank);
390 gfc_resolve_index (dim, 1);
391 /* Convert dim to shift's kind, so we don't need so many variations. */
392 if (dim->ts.kind != shift->ts.kind)
393 gfc_convert_type_warn (dim, &shift->ts, 2, 0);
395 f->value.function.name =
396 gfc_get_string (PREFIX("cshift%d_%d"), n, shift->ts.kind);
401 gfc_resolve_dble (gfc_expr * f, gfc_expr * a)
403 f->ts.type = BT_REAL;
404 f->ts.kind = gfc_default_double_kind;
405 f->value.function.name =
406 gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
411 gfc_resolve_dim (gfc_expr * f, gfc_expr * x,
412 gfc_expr * y ATTRIBUTE_UNUSED)
415 f->value.function.name =
416 gfc_get_string ("__dim_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
421 gfc_resolve_dot_product (gfc_expr * f, gfc_expr * a, gfc_expr * b)
425 if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
427 f->ts.type = BT_LOGICAL;
428 f->ts.kind = gfc_default_logical_kind;
432 temp.expr_type = EXPR_OP;
433 gfc_clear_ts (&temp.ts);
434 temp.value.op.operator = INTRINSIC_NONE;
435 temp.value.op.op1 = a;
436 temp.value.op.op2 = b;
437 gfc_type_convert_binary (&temp);
441 f->value.function.name =
442 gfc_get_string (PREFIX("dot_product_%c%d"), gfc_type_letter (f->ts.type),
448 gfc_resolve_dprod (gfc_expr * f,
449 gfc_expr * a ATTRIBUTE_UNUSED,
450 gfc_expr * b ATTRIBUTE_UNUSED)
452 f->ts.kind = gfc_default_double_kind;
453 f->ts.type = BT_REAL;
455 f->value.function.name = gfc_get_string ("__dprod_r%d", f->ts.kind);
460 gfc_resolve_eoshift (gfc_expr * f, gfc_expr * array,
468 f->rank = array->rank;
469 f->shape = gfc_copy_shape (array->shape, array->rank);
474 if (boundary && boundary->rank > 0)
477 /* Convert dim to the same type as shift, so we don't need quite so many
479 if (dim != NULL && dim->ts.kind != shift->ts.kind)
480 gfc_convert_type_warn (dim, &shift->ts, 2, 0);
482 f->value.function.name =
483 gfc_get_string (PREFIX("eoshift%d_%d"), n, shift->ts.kind);
488 gfc_resolve_exp (gfc_expr * f, gfc_expr * x)
491 f->value.function.name =
492 gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
497 gfc_resolve_exponent (gfc_expr * f, gfc_expr * x)
499 f->ts.type = BT_INTEGER;
500 f->ts.kind = gfc_default_integer_kind;
502 f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind);
507 gfc_resolve_floor (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
509 f->ts.type = BT_INTEGER;
510 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
511 : mpz_get_si (kind->value.integer);
513 f->value.function.name =
514 gfc_get_string ("__floor%d_%c%d", f->ts.kind,
515 gfc_type_letter (a->ts.type), a->ts.kind);
520 gfc_resolve_fnum (gfc_expr * f, gfc_expr * n)
522 f->ts.type = BT_INTEGER;
523 f->ts.kind = gfc_default_integer_kind;
524 if (n->ts.kind != f->ts.kind)
525 gfc_convert_type (n, &f->ts, 2);
526 f->value.function.name = gfc_get_string (PREFIX("fnum_i%d"), f->ts.kind);
531 gfc_resolve_fraction (gfc_expr * f, gfc_expr * x)
534 f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind);
538 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
541 gfc_resolve_g77_math1 (gfc_expr * f, gfc_expr * x)
544 f->value.function.name = gfc_get_string ("<intrinsic>");
549 gfc_resolve_getcwd (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
551 f->ts.type = BT_INTEGER;
553 f->value.function.name = gfc_get_string (PREFIX("getcwd"));
558 gfc_resolve_getgid (gfc_expr * f)
560 f->ts.type = BT_INTEGER;
562 f->value.function.name = gfc_get_string (PREFIX("getgid"));
567 gfc_resolve_getpid (gfc_expr * f)
569 f->ts.type = BT_INTEGER;
571 f->value.function.name = gfc_get_string (PREFIX("getpid"));
576 gfc_resolve_getuid (gfc_expr * f)
578 f->ts.type = BT_INTEGER;
580 f->value.function.name = gfc_get_string (PREFIX("getuid"));
584 gfc_resolve_hostnm (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
586 f->ts.type = BT_INTEGER;
588 f->value.function.name = gfc_get_string (PREFIX ("hostnm"));
592 gfc_resolve_iand (gfc_expr * f, gfc_expr * i, gfc_expr * j)
594 /* If the kind of i and j are different, then g77 cross-promoted the
595 kinds to the largest value. The Fortran 95 standard requires the
597 if (i->ts.kind != j->ts.kind)
599 if (i->ts.kind == gfc_kind_max (i,j))
600 gfc_convert_type(j, &i->ts, 2);
602 gfc_convert_type(i, &j->ts, 2);
606 f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind);
611 gfc_resolve_ibclr (gfc_expr * f, gfc_expr * i, gfc_expr * pos ATTRIBUTE_UNUSED)
614 f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind);
619 gfc_resolve_ibits (gfc_expr * f, gfc_expr * i,
620 gfc_expr * pos ATTRIBUTE_UNUSED,
621 gfc_expr * len ATTRIBUTE_UNUSED)
624 f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind);
629 gfc_resolve_ibset (gfc_expr * f, gfc_expr * i,
630 gfc_expr * pos ATTRIBUTE_UNUSED)
633 f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind);
638 gfc_resolve_ichar (gfc_expr * f, gfc_expr * c)
640 f->ts.type = BT_INTEGER;
641 f->ts.kind = gfc_default_integer_kind;
643 f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
648 gfc_resolve_idnint (gfc_expr * f, gfc_expr * a)
650 gfc_resolve_nint (f, a, NULL);
655 gfc_resolve_ierrno (gfc_expr * f)
657 f->ts.type = BT_INTEGER;
658 f->ts.kind = gfc_default_integer_kind;
659 f->value.function.name = gfc_get_string (PREFIX("ierrno_i%d"), f->ts.kind);
664 gfc_resolve_ieor (gfc_expr * f, gfc_expr * i, gfc_expr * j)
666 /* If the kind of i and j are different, then g77 cross-promoted the
667 kinds to the largest value. The Fortran 95 standard requires the
669 if (i->ts.kind != j->ts.kind)
671 if (i->ts.kind == gfc_kind_max (i,j))
672 gfc_convert_type(j, &i->ts, 2);
674 gfc_convert_type(i, &j->ts, 2);
678 f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind);
683 gfc_resolve_ior (gfc_expr * f, gfc_expr * i, gfc_expr * j)
685 /* If the kind of i and j are different, then g77 cross-promoted the
686 kinds to the largest value. The Fortran 95 standard requires the
688 if (i->ts.kind != j->ts.kind)
690 if (i->ts.kind == gfc_kind_max (i,j))
691 gfc_convert_type(j, &i->ts, 2);
693 gfc_convert_type(i, &j->ts, 2);
697 f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind);
702 gfc_resolve_int (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
704 f->ts.type = BT_INTEGER;
705 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
706 : mpz_get_si (kind->value.integer);
708 f->value.function.name =
709 gfc_get_string ("__int_%d_%c%d", f->ts.kind, gfc_type_letter (a->ts.type),
715 gfc_resolve_isatty (gfc_expr * f, gfc_expr * u)
719 f->ts.type = BT_LOGICAL;
720 f->ts.kind = gfc_default_integer_kind;
721 if (u->ts.kind != gfc_c_int_kind)
723 ts.type = BT_INTEGER;
724 ts.kind = gfc_c_int_kind;
727 gfc_convert_type (u, &ts, 2);
730 f->value.function.name = gfc_get_string (PREFIX("isatty_l%d"), f->ts.kind);
735 gfc_resolve_ishft (gfc_expr * f, gfc_expr * i, gfc_expr * shift)
738 f->value.function.name =
739 gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
744 gfc_resolve_ishftc (gfc_expr * f, gfc_expr * i, gfc_expr * shift,
749 s_kind = (size == NULL) ? gfc_default_integer_kind : shift->ts.kind;
752 f->value.function.name =
753 gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
758 gfc_resolve_kill (gfc_expr * f, ATTRIBUTE_UNUSED gfc_expr * p,
759 ATTRIBUTE_UNUSED gfc_expr * s)
761 f->ts.type = BT_INTEGER;
762 f->ts.kind = gfc_default_integer_kind;
764 f->value.function.name = gfc_get_string (PREFIX("kill_i%d"), f->ts.kind);
769 gfc_resolve_lbound (gfc_expr * f, gfc_expr * array,
772 static char lbound[] = "__lbound";
774 f->ts.type = BT_INTEGER;
775 f->ts.kind = gfc_default_integer_kind;
780 f->shape = gfc_get_shape (1);
781 mpz_init_set_ui (f->shape[0], array->rank);
784 f->value.function.name = lbound;
789 gfc_resolve_len (gfc_expr * f, gfc_expr * string)
791 f->ts.type = BT_INTEGER;
792 f->ts.kind = gfc_default_integer_kind;
793 f->value.function.name = gfc_get_string ("__len_%d", string->ts.kind);
798 gfc_resolve_len_trim (gfc_expr * f, gfc_expr * string)
800 f->ts.type = BT_INTEGER;
801 f->ts.kind = gfc_default_integer_kind;
802 f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
807 gfc_resolve_link (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
808 gfc_expr * p2 ATTRIBUTE_UNUSED)
810 f->ts.type = BT_INTEGER;
811 f->ts.kind = gfc_default_integer_kind;
812 f->value.function.name = gfc_get_string (PREFIX("link_i%d"), f->ts.kind);
817 gfc_resolve_log (gfc_expr * f, gfc_expr * x)
820 f->value.function.name =
821 gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
826 gfc_resolve_log10 (gfc_expr * f, gfc_expr * x)
829 f->value.function.name =
830 gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
835 gfc_resolve_logical (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
837 f->ts.type = BT_LOGICAL;
838 f->ts.kind = (kind == NULL) ? gfc_default_logical_kind
839 : mpz_get_si (kind->value.integer);
842 f->value.function.name =
843 gfc_get_string ("__logical_%d_%c%d", f->ts.kind,
844 gfc_type_letter (a->ts.type), a->ts.kind);
849 gfc_resolve_matmul (gfc_expr * f, gfc_expr * a, gfc_expr * b)
853 if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
855 f->ts.type = BT_LOGICAL;
856 f->ts.kind = gfc_default_logical_kind;
860 temp.expr_type = EXPR_OP;
861 gfc_clear_ts (&temp.ts);
862 temp.value.op.operator = INTRINSIC_NONE;
863 temp.value.op.op1 = a;
864 temp.value.op.op2 = b;
865 gfc_type_convert_binary (&temp);
869 f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
871 f->value.function.name =
872 gfc_get_string (PREFIX("matmul_%c%d"), gfc_type_letter (f->ts.type),
878 gfc_resolve_minmax (const char * name, gfc_expr * f, gfc_actual_arglist * args)
880 gfc_actual_arglist *a;
882 f->ts.type = args->expr->ts.type;
883 f->ts.kind = args->expr->ts.kind;
884 /* Find the largest type kind. */
885 for (a = args->next; a; a = a->next)
887 if (a->expr->ts.kind > f->ts.kind)
888 f->ts.kind = a->expr->ts.kind;
891 /* Convert all parameters to the required kind. */
892 for (a = args; a; a = a->next)
894 if (a->expr->ts.kind != f->ts.kind)
895 gfc_convert_type (a->expr, &f->ts, 2);
898 f->value.function.name =
899 gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind);
904 gfc_resolve_max (gfc_expr * f, gfc_actual_arglist * args)
906 gfc_resolve_minmax ("__max_%c%d", f, args);
911 gfc_resolve_maxloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
916 f->ts.type = BT_INTEGER;
917 f->ts.kind = gfc_default_integer_kind;
923 f->rank = array->rank - 1;
924 gfc_resolve_index (dim, 1);
927 name = mask ? "mmaxloc" : "maxloc";
928 f->value.function.name =
929 gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
930 gfc_type_letter (array->ts.type), array->ts.kind);
935 gfc_resolve_maxval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
942 f->rank = array->rank - 1;
943 gfc_resolve_index (dim, 1);
946 f->value.function.name =
947 gfc_get_string (PREFIX("%s_%c%d"), mask ? "mmaxval" : "maxval",
948 gfc_type_letter (array->ts.type), array->ts.kind);
953 gfc_resolve_merge (gfc_expr * f, gfc_expr * tsource,
954 gfc_expr * fsource ATTRIBUTE_UNUSED,
955 gfc_expr * mask ATTRIBUTE_UNUSED)
958 f->value.function.name =
959 gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
965 gfc_resolve_min (gfc_expr * f, gfc_actual_arglist * args)
967 gfc_resolve_minmax ("__min_%c%d", f, args);
972 gfc_resolve_minloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
977 f->ts.type = BT_INTEGER;
978 f->ts.kind = gfc_default_integer_kind;
984 f->rank = array->rank - 1;
985 gfc_resolve_index (dim, 1);
988 name = mask ? "mminloc" : "minloc";
989 f->value.function.name =
990 gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
991 gfc_type_letter (array->ts.type), array->ts.kind);
996 gfc_resolve_minval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1003 f->rank = array->rank - 1;
1004 gfc_resolve_index (dim, 1);
1007 f->value.function.name =
1008 gfc_get_string (PREFIX("%s_%c%d"), mask ? "mminval" : "minval",
1009 gfc_type_letter (array->ts.type), array->ts.kind);
1014 gfc_resolve_mod (gfc_expr * f, gfc_expr * a,
1015 gfc_expr * p ATTRIBUTE_UNUSED)
1018 f->value.function.name =
1019 gfc_get_string ("__mod_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
1024 gfc_resolve_modulo (gfc_expr * f, gfc_expr * a,
1025 gfc_expr * p ATTRIBUTE_UNUSED)
1028 f->value.function.name =
1029 gfc_get_string ("__modulo_%c%d", gfc_type_letter (a->ts.type),
1034 gfc_resolve_nearest (gfc_expr * f, gfc_expr * a, gfc_expr *p ATTRIBUTE_UNUSED)
1037 f->value.function.name =
1038 gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
1043 gfc_resolve_nint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
1045 f->ts.type = BT_INTEGER;
1046 f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
1047 : mpz_get_si (kind->value.integer);
1049 f->value.function.name =
1050 gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
1055 gfc_resolve_not (gfc_expr * f, gfc_expr * i)
1058 f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
1063 gfc_resolve_pack (gfc_expr * f,
1064 gfc_expr * array ATTRIBUTE_UNUSED,
1066 gfc_expr * vector ATTRIBUTE_UNUSED)
1071 if (mask->rank != 0)
1072 f->value.function.name = PREFIX("pack");
1075 /* We convert mask to default logical only in the scalar case.
1076 In the array case we can simply read the array as if it were
1077 of type default logical. */
1078 if (mask->ts.kind != gfc_default_logical_kind)
1082 ts.type = BT_LOGICAL;
1083 ts.kind = gfc_default_logical_kind;
1084 gfc_convert_type (mask, &ts, 2);
1087 f->value.function.name = PREFIX("pack_s");
1093 gfc_resolve_product (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1100 f->rank = array->rank - 1;
1101 gfc_resolve_index (dim, 1);
1104 f->value.function.name =
1105 gfc_get_string (PREFIX("%s_%c%d"), mask ? "mproduct" : "product",
1106 gfc_type_letter (array->ts.type), array->ts.kind);
1111 gfc_resolve_real (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
1113 f->ts.type = BT_REAL;
1116 f->ts.kind = mpz_get_si (kind->value.integer);
1118 f->ts.kind = (a->ts.type == BT_COMPLEX) ?
1119 a->ts.kind : gfc_default_real_kind;
1121 f->value.function.name =
1122 gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1123 gfc_type_letter (a->ts.type), a->ts.kind);
1128 gfc_resolve_rename (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
1129 gfc_expr * p2 ATTRIBUTE_UNUSED)
1131 f->ts.type = BT_INTEGER;
1132 f->ts.kind = gfc_default_integer_kind;
1133 f->value.function.name = gfc_get_string (PREFIX("rename_i%d"), f->ts.kind);
1138 gfc_resolve_repeat (gfc_expr * f, gfc_expr * string,
1139 gfc_expr * ncopies ATTRIBUTE_UNUSED)
1141 f->ts.type = BT_CHARACTER;
1142 f->ts.kind = string->ts.kind;
1143 f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
1148 gfc_resolve_reshape (gfc_expr * f, gfc_expr * source, gfc_expr * shape,
1149 gfc_expr * pad ATTRIBUTE_UNUSED,
1150 gfc_expr * order ATTRIBUTE_UNUSED)
1158 gfc_array_size (shape, &rank);
1159 f->rank = mpz_get_si (rank);
1161 switch (source->ts.type)
1164 kind = source->ts.kind * 2;
1170 kind = source->ts.kind;
1183 if (source->ts.type == BT_COMPLEX)
1184 f->value.function.name =
1185 gfc_get_string (PREFIX("reshape_%c%d"),
1186 gfc_type_letter (BT_COMPLEX), source->ts.kind);
1188 f->value.function.name =
1189 gfc_get_string (PREFIX("reshape_%d"), source->ts.kind);
1194 f->value.function.name = PREFIX("reshape");
1198 /* TODO: Make this work with a constant ORDER parameter. */
1199 if (shape->expr_type == EXPR_ARRAY
1200 && gfc_is_constant_expr (shape)
1204 f->shape = gfc_get_shape (f->rank);
1205 c = shape->value.constructor;
1206 for (i = 0; i < f->rank; i++)
1208 mpz_init_set (f->shape[i], c->expr->value.integer);
1213 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
1214 so many runtime variations. */
1215 if (shape->ts.kind != gfc_index_integer_kind)
1217 gfc_typespec ts = shape->ts;
1218 ts.kind = gfc_index_integer_kind;
1219 gfc_convert_type_warn (shape, &ts, 2, 0);
1221 if (order && order->ts.kind != gfc_index_integer_kind)
1222 gfc_convert_type_warn (order, &shape->ts, 2, 0);
1227 gfc_resolve_rrspacing (gfc_expr * f, gfc_expr * x)
1230 f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
1235 gfc_resolve_scale (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1239 /* The implementation calls scalbn which takes an int as the
1241 if (i->ts.kind != gfc_c_int_kind)
1245 ts.type = BT_INTEGER;
1246 ts.kind = gfc_default_integer_kind;
1248 gfc_convert_type_warn (i, &ts, 2, 0);
1251 f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
1256 gfc_resolve_scan (gfc_expr * f, gfc_expr * string,
1257 gfc_expr * set ATTRIBUTE_UNUSED,
1258 gfc_expr * back ATTRIBUTE_UNUSED)
1260 f->ts.type = BT_INTEGER;
1261 f->ts.kind = gfc_default_integer_kind;
1262 f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
1267 gfc_resolve_set_exponent (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1271 /* The library implementation uses GFC_INTEGER_4 unconditionally,
1272 convert type so we don't have to implement all possible
1274 if (i->ts.kind != 4)
1278 ts.type = BT_INTEGER;
1279 ts.kind = gfc_default_integer_kind;
1281 gfc_convert_type_warn (i, &ts, 2, 0);
1284 f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
1289 gfc_resolve_shape (gfc_expr * f, gfc_expr * array)
1291 f->ts.type = BT_INTEGER;
1292 f->ts.kind = gfc_default_integer_kind;
1294 f->value.function.name = gfc_get_string (PREFIX("shape_%d"), f->ts.kind);
1295 f->shape = gfc_get_shape (1);
1296 mpz_init_set_ui (f->shape[0], array->rank);
1301 gfc_resolve_sign (gfc_expr * f, gfc_expr * a, gfc_expr * b ATTRIBUTE_UNUSED)
1304 f->value.function.name =
1305 gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
1310 gfc_resolve_sin (gfc_expr * f, gfc_expr * x)
1313 f->value.function.name =
1314 gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1319 gfc_resolve_sinh (gfc_expr * f, gfc_expr * x)
1322 f->value.function.name =
1323 gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1328 gfc_resolve_spacing (gfc_expr * f, gfc_expr * x)
1331 f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
1336 gfc_resolve_spread (gfc_expr * f, gfc_expr * source,
1341 f->rank = source->rank + 1;
1342 f->value.function.name = PREFIX("spread");
1344 gfc_resolve_index (dim, 1);
1345 gfc_resolve_index (ncopies, 1);
1350 gfc_resolve_sqrt (gfc_expr * f, gfc_expr * x)
1353 f->value.function.name =
1354 gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1358 /* Resolve the g77 compatibility function STAT AND FSTAT. */
1361 gfc_resolve_stat (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED,
1362 gfc_expr * a ATTRIBUTE_UNUSED)
1364 f->ts.type = BT_INTEGER;
1365 f->ts.kind = gfc_default_integer_kind;
1366 f->value.function.name = gfc_get_string (PREFIX("stat_i%d"), f->ts.kind);
1371 gfc_resolve_fstat (gfc_expr * f, gfc_expr * n, gfc_expr * a ATTRIBUTE_UNUSED)
1373 f->ts.type = BT_INTEGER;
1374 f->ts.kind = gfc_default_integer_kind;
1375 if (n->ts.kind != f->ts.kind)
1376 gfc_convert_type (n, &f->ts, 2);
1378 f->value.function.name = gfc_get_string (PREFIX("fstat_i%d"), f->ts.kind);
1383 gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1390 f->rank = array->rank - 1;
1391 gfc_resolve_index (dim, 1);
1394 f->value.function.name =
1395 gfc_get_string (PREFIX("%s_%c%d"), mask ? "msum" : "sum",
1396 gfc_type_letter (array->ts.type), array->ts.kind);
1401 gfc_resolve_symlnk (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
1402 gfc_expr * p2 ATTRIBUTE_UNUSED)
1404 f->ts.type = BT_INTEGER;
1405 f->ts.kind = gfc_default_integer_kind;
1406 f->value.function.name = gfc_get_string (PREFIX("symlnk_i%d"), f->ts.kind);
1410 /* Resolve the g77 compatibility function SYSTEM. */
1413 gfc_resolve_system (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
1415 f->ts.type = BT_INTEGER;
1417 f->value.function.name = gfc_get_string (PREFIX("system"));
1422 gfc_resolve_tan (gfc_expr * f, gfc_expr * x)
1425 f->value.function.name =
1426 gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1431 gfc_resolve_tanh (gfc_expr * f, gfc_expr * x)
1434 f->value.function.name =
1435 gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1440 gfc_resolve_time (gfc_expr * f)
1442 f->ts.type = BT_INTEGER;
1444 f->value.function.name = gfc_get_string (PREFIX("time_func"));
1449 gfc_resolve_time8 (gfc_expr * f)
1451 f->ts.type = BT_INTEGER;
1453 f->value.function.name = gfc_get_string (PREFIX("time8_func"));
1458 gfc_resolve_transfer (gfc_expr * f, gfc_expr * source ATTRIBUTE_UNUSED,
1459 gfc_expr * mold, gfc_expr * size)
1461 /* TODO: Make this do something meaningful. */
1462 static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
1466 if (size == NULL && mold->rank == 0)
1469 f->value.function.name = transfer0;
1474 f->value.function.name = transfer1;
1480 gfc_resolve_transpose (gfc_expr * f, gfc_expr * matrix)
1488 f->shape = gfc_get_shape (2);
1489 mpz_init_set (f->shape[0], matrix->shape[1]);
1490 mpz_init_set (f->shape[1], matrix->shape[0]);
1493 kind = matrix->ts.kind;
1499 switch (matrix->ts.type)
1502 f->value.function.name =
1503 gfc_get_string (PREFIX("transpose_c%d"), kind);
1509 /* Use the integer routines for real and logical cases. This
1510 assumes they all have the same alignment requirements. */
1511 f->value.function.name =
1512 gfc_get_string (PREFIX("transpose_i%d"), kind);
1516 f->value.function.name = PREFIX("transpose");
1522 f->value.function.name = PREFIX("transpose");
1528 gfc_resolve_trim (gfc_expr * f, gfc_expr * string)
1530 f->ts.type = BT_CHARACTER;
1531 f->ts.kind = string->ts.kind;
1532 f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
1537 gfc_resolve_ubound (gfc_expr * f, gfc_expr * array,
1540 static char ubound[] = "__ubound";
1542 f->ts.type = BT_INTEGER;
1543 f->ts.kind = gfc_default_integer_kind;
1548 f->shape = gfc_get_shape (1);
1549 mpz_init_set_ui (f->shape[0], array->rank);
1552 f->value.function.name = ubound;
1556 /* Resolve the g77 compatibility function UMASK. */
1559 gfc_resolve_umask (gfc_expr * f, gfc_expr * n)
1561 f->ts.type = BT_INTEGER;
1562 f->ts.kind = n->ts.kind;
1563 f->value.function.name = gfc_get_string (PREFIX("umask_i%d"), n->ts.kind);
1567 /* Resolve the g77 compatibility function UNLINK. */
1570 gfc_resolve_unlink (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
1572 f->ts.type = BT_INTEGER;
1574 f->value.function.name = gfc_get_string (PREFIX("unlink"));
1578 gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask,
1579 gfc_expr * field ATTRIBUTE_UNUSED)
1581 f->ts.type = vector->ts.type;
1582 f->ts.kind = vector->ts.kind;
1583 f->rank = mask->rank;
1585 f->value.function.name =
1586 gfc_get_string (PREFIX("unpack%d"), field->rank > 0 ? 1 : 0);
1591 gfc_resolve_verify (gfc_expr * f, gfc_expr * string,
1592 gfc_expr * set ATTRIBUTE_UNUSED,
1593 gfc_expr * back ATTRIBUTE_UNUSED)
1595 f->ts.type = BT_INTEGER;
1596 f->ts.kind = gfc_default_integer_kind;
1597 f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
1601 /* Intrinsic subroutine resolution. */
1604 gfc_resolve_cpu_time (gfc_code * c ATTRIBUTE_UNUSED)
1608 name = gfc_get_string (PREFIX("cpu_time_%d"),
1609 c->ext.actual->expr->ts.kind);
1610 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1615 gfc_resolve_mvbits (gfc_code * c)
1620 kind = c->ext.actual->expr->ts.kind;
1621 name = gfc_get_string (PREFIX("mvbits_i%d"), kind);
1623 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1628 gfc_resolve_random_number (gfc_code * c ATTRIBUTE_UNUSED)
1633 kind = c->ext.actual->expr->ts.kind;
1634 if (c->ext.actual->expr->rank == 0)
1635 name = gfc_get_string (PREFIX("random_r%d"), kind);
1637 name = gfc_get_string (PREFIX("arandom_r%d"), kind);
1639 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1644 gfc_resolve_rename_sub (gfc_code * c)
1649 if (c->ext.actual->next->next->expr != NULL)
1650 kind = c->ext.actual->next->next->expr->ts.kind;
1652 kind = gfc_default_integer_kind;
1654 name = gfc_get_string (PREFIX("rename_i%d_sub"), kind);
1655 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1660 gfc_resolve_kill_sub (gfc_code * c)
1665 if (c->ext.actual->next->next->expr != NULL)
1666 kind = c->ext.actual->next->next->expr->ts.kind;
1668 kind = gfc_default_integer_kind;
1670 name = gfc_get_string (PREFIX("kill_i%d_sub"), kind);
1671 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1676 gfc_resolve_link_sub (gfc_code * c)
1681 if (c->ext.actual->next->next->expr != NULL)
1682 kind = c->ext.actual->next->next->expr->ts.kind;
1684 kind = gfc_default_integer_kind;
1686 name = gfc_get_string (PREFIX("link_i%d_sub"), kind);
1687 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1692 gfc_resolve_symlnk_sub (gfc_code * c)
1697 if (c->ext.actual->next->next->expr != NULL)
1698 kind = c->ext.actual->next->next->expr->ts.kind;
1700 kind = gfc_default_integer_kind;
1702 name = gfc_get_string (PREFIX("symlnk_i%d_sub"), kind);
1703 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1707 /* G77 compatibility subroutines etime() and dtime(). */
1710 gfc_resolve_etime_sub (gfc_code * c)
1714 name = gfc_get_string (PREFIX("etime_sub"));
1715 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1719 /* G77 compatibility subroutine second(). */
1722 gfc_resolve_second_sub (gfc_code * c)
1726 name = gfc_get_string (PREFIX("second_sub"));
1727 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1732 gfc_resolve_sleep_sub (gfc_code * c)
1737 if (c->ext.actual->expr != NULL)
1738 kind = c->ext.actual->expr->ts.kind;
1740 kind = gfc_default_integer_kind;
1742 name = gfc_get_string (PREFIX("sleep_i%d_sub"), kind);
1743 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1747 /* G77 compatibility function srand(). */
1750 gfc_resolve_srand (gfc_code * c)
1753 name = gfc_get_string (PREFIX("srand"));
1754 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1758 /* Resolve the getarg intrinsic subroutine. */
1761 gfc_resolve_getarg (gfc_code * c)
1766 kind = gfc_default_integer_kind;
1767 name = gfc_get_string (PREFIX("getarg_i%d"), kind);
1768 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1771 /* Resolve the getcwd intrinsic subroutine. */
1774 gfc_resolve_getcwd_sub (gfc_code * c)
1779 if (c->ext.actual->next->expr != NULL)
1780 kind = c->ext.actual->next->expr->ts.kind;
1782 kind = gfc_default_integer_kind;
1784 name = gfc_get_string (PREFIX("getcwd_i%d_sub"), kind);
1785 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1789 /* Resolve the get_command intrinsic subroutine. */
1792 gfc_resolve_get_command (gfc_code * c)
1797 kind = gfc_default_integer_kind;
1798 name = gfc_get_string (PREFIX("get_command_i%d"), kind);
1799 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1803 /* Resolve the get_command_argument intrinsic subroutine. */
1806 gfc_resolve_get_command_argument (gfc_code * c)
1811 kind = gfc_default_integer_kind;
1812 name = gfc_get_string (PREFIX("get_command_argument_i%d"), kind);
1813 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1816 /* Resolve the get_environment_variable intrinsic subroutine. */
1819 gfc_resolve_get_environment_variable (gfc_code * code)
1824 kind = gfc_default_integer_kind;
1825 name = gfc_get_string (PREFIX("get_environment_variable_i%d"), kind);
1826 code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1829 /* Resolve the SYSTEM intrinsic subroutine. */
1832 gfc_resolve_system_sub (gfc_code * c)
1836 name = gfc_get_string (PREFIX("system_sub"));
1837 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1840 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
1843 gfc_resolve_system_clock (gfc_code * c)
1848 if (c->ext.actual->expr != NULL)
1849 kind = c->ext.actual->expr->ts.kind;
1850 else if (c->ext.actual->next->expr != NULL)
1851 kind = c->ext.actual->next->expr->ts.kind;
1852 else if (c->ext.actual->next->next->expr != NULL)
1853 kind = c->ext.actual->next->next->expr->ts.kind;
1855 kind = gfc_default_integer_kind;
1857 name = gfc_get_string (PREFIX("system_clock_%d"), kind);
1858 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1861 /* Resolve the EXIT intrinsic subroutine. */
1864 gfc_resolve_exit (gfc_code * c)
1869 if (c->ext.actual->expr != NULL)
1870 kind = c->ext.actual->expr->ts.kind;
1872 kind = gfc_default_integer_kind;
1874 name = gfc_get_string (PREFIX("exit_i%d"), kind);
1875 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1878 /* Resolve the FLUSH intrinsic subroutine. */
1881 gfc_resolve_flush (gfc_code * c)
1887 ts.type = BT_INTEGER;
1888 ts.kind = gfc_default_integer_kind;
1889 n = c->ext.actual->expr;
1891 && n->ts.kind != ts.kind)
1892 gfc_convert_type (n, &ts, 2);
1894 name = gfc_get_string (PREFIX("flush_i%d"), ts.kind);
1895 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1900 gfc_resolve_gerror (gfc_code * c)
1902 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
1907 gfc_resolve_getlog (gfc_code * c)
1909 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
1914 gfc_resolve_hostnm_sub (gfc_code * c)
1919 if (c->ext.actual->next->expr != NULL)
1920 kind = c->ext.actual->next->expr->ts.kind;
1922 kind = gfc_default_integer_kind;
1924 name = gfc_get_string (PREFIX("hostnm_i%d_sub"), kind);
1925 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1930 gfc_resolve_perror (gfc_code * c)
1932 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
1935 /* Resolve the STAT and FSTAT intrinsic subroutines. */
1938 gfc_resolve_stat_sub (gfc_code * c)
1942 name = gfc_get_string (PREFIX("stat_i%d_sub"), gfc_default_integer_kind);
1943 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1948 gfc_resolve_fstat_sub (gfc_code * c)
1954 u = c->ext.actual->expr;
1955 ts = &c->ext.actual->next->expr->ts;
1956 if (u->ts.kind != ts->kind)
1957 gfc_convert_type (u, ts, 2);
1958 name = gfc_get_string (PREFIX("fstat_i%d_sub"), ts->kind);
1959 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1964 gfc_resolve_ttynam_sub (gfc_code * c)
1968 if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
1970 ts.type = BT_INTEGER;
1971 ts.kind = gfc_c_int_kind;
1974 gfc_convert_type (c->ext.actual->expr, &ts, 2);
1977 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("ttynam_sub"));
1981 /* Resolve the UMASK intrinsic subroutine. */
1984 gfc_resolve_umask_sub (gfc_code * c)
1989 if (c->ext.actual->next->expr != NULL)
1990 kind = c->ext.actual->next->expr->ts.kind;
1992 kind = gfc_default_integer_kind;
1994 name = gfc_get_string (PREFIX("umask_i%d_sub"), kind);
1995 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1998 /* Resolve the UNLINK intrinsic subroutine. */
2001 gfc_resolve_unlink_sub (gfc_code * c)
2006 if (c->ext.actual->next->expr != NULL)
2007 kind = c->ext.actual->next->expr->ts.kind;
2009 kind = gfc_default_integer_kind;
2011 name = gfc_get_string (PREFIX("unlink_i%d_sub"), kind);
2012 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);