1 /* Intrinsic function resolution.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
3 Free Software Foundation, Inc.
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 3, 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 COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
23 /* Assign name and types to intrinsic procedures. For functions, the
24 first argument to a resolution function is an expression pointer to
25 the original function node and the rest are pointers to the
26 arguments of the function call. For subroutines, a pointer to the
27 code node is passed. The result type and library subroutine name
28 are generally set according to the function arguments. */
32 #include "coretypes.h"
35 #include "intrinsic.h"
37 /* Given printf-like arguments, return a stable version of the result string.
39 We already have a working, optimized string hashing table in the form of
40 the identifier table. Reusing this table is likely not to be wasted,
41 since if the function name makes it to the gimple output of the frontend,
42 we'll have to create the identifier anyway. */
45 gfc_get_string (const char *format, ...)
51 va_start (ap, format);
52 vsnprintf (temp_name, sizeof (temp_name), format, ap);
54 temp_name[sizeof (temp_name) - 1] = 0;
56 ident = get_identifier (temp_name);
57 return IDENTIFIER_POINTER (ident);
60 /* MERGE and SPREAD need to have source charlen's present for passing
61 to the result expression. */
63 check_charlen_present (gfc_expr *source)
65 if (source->ts.u.cl == NULL)
66 source->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
68 if (source->expr_type == EXPR_CONSTANT)
70 source->ts.u.cl->length = gfc_int_expr (source->value.character.length);
73 else if (source->expr_type == EXPR_ARRAY)
74 source->ts.u.cl->length =
75 gfc_int_expr (source->value.constructor->expr->value.character.length);
78 /* Helper function for resolving the "mask" argument. */
81 resolve_mask_arg (gfc_expr *mask)
89 /* For the scalar case, coerce the mask to kind=4 unconditionally
90 (because this is the only kind we have a library function
93 if (mask->ts.kind != 4)
97 gfc_convert_type (mask, &ts, 2);
102 /* In the library, we access the mask with a GFC_LOGICAL_1
103 argument. No need to waste memory if we are about to create
104 a temporary array. */
105 if (mask->expr_type == EXPR_OP && mask->ts.kind != 1)
107 ts.type = BT_LOGICAL;
109 gfc_convert_type_warn (mask, &ts, 2, 0);
114 /********************** Resolution functions **********************/
118 gfc_resolve_abs (gfc_expr *f, gfc_expr *a)
121 if (f->ts.type == BT_COMPLEX)
122 f->ts.type = BT_REAL;
124 f->value.function.name
125 = gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
130 gfc_resolve_access (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
131 gfc_expr *mode ATTRIBUTE_UNUSED)
133 f->ts.type = BT_INTEGER;
134 f->ts.kind = gfc_c_int_kind;
135 f->value.function.name = PREFIX ("access_func");
140 gfc_resolve_adjustl (gfc_expr *f, gfc_expr *string)
142 f->ts.type = BT_CHARACTER;
143 f->ts.kind = string->ts.kind;
144 f->value.function.name = gfc_get_string ("__adjustl_s%d", f->ts.kind);
149 gfc_resolve_adjustr (gfc_expr *f, gfc_expr *string)
151 f->ts.type = BT_CHARACTER;
152 f->ts.kind = string->ts.kind;
153 f->value.function.name = gfc_get_string ("__adjustr_s%d", f->ts.kind);
158 gfc_resolve_char_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind,
161 f->ts.type = BT_CHARACTER;
162 f->ts.kind = (kind == NULL)
163 ? gfc_default_character_kind : mpz_get_si (kind->value.integer);
164 f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
165 f->ts.u.cl->length = gfc_int_expr (1);
167 f->value.function.name = gfc_get_string (name, f->ts.kind,
168 gfc_type_letter (x->ts.type),
174 gfc_resolve_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind)
176 gfc_resolve_char_achar (f, x, kind, "__achar_%d_%c%d");
181 gfc_resolve_acos (gfc_expr *f, gfc_expr *x)
184 f->value.function.name
185 = gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
190 gfc_resolve_acosh (gfc_expr *f, gfc_expr *x)
193 f->value.function.name
194 = gfc_get_string ("__acosh_%c%d", gfc_type_letter (x->ts.type),
200 gfc_resolve_aimag (gfc_expr *f, gfc_expr *x)
202 f->ts.type = BT_REAL;
203 f->ts.kind = x->ts.kind;
204 f->value.function.name
205 = gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type),
211 gfc_resolve_and (gfc_expr *f, gfc_expr *i, gfc_expr *j)
213 f->ts.type = i->ts.type;
214 f->ts.kind = gfc_kind_max (i, j);
216 if (i->ts.kind != j->ts.kind)
218 if (i->ts.kind == gfc_kind_max (i, j))
219 gfc_convert_type (j, &i->ts, 2);
221 gfc_convert_type (i, &j->ts, 2);
224 f->value.function.name
225 = gfc_get_string ("__and_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
230 gfc_resolve_aint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
235 f->ts.type = a->ts.type;
236 f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
238 if (a->ts.kind != f->ts.kind)
240 ts.type = f->ts.type;
241 ts.kind = f->ts.kind;
242 gfc_convert_type (a, &ts, 2);
244 /* The resolved name is only used for specific intrinsics where
245 the return kind is the same as the arg kind. */
246 f->value.function.name
247 = gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
252 gfc_resolve_dint (gfc_expr *f, gfc_expr *a)
254 gfc_resolve_aint (f, a, NULL);
259 gfc_resolve_all (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
265 gfc_resolve_dim_arg (dim);
266 f->rank = mask->rank - 1;
267 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
270 f->value.function.name
271 = gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask->ts.type),
277 gfc_resolve_anint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
282 f->ts.type = a->ts.type;
283 f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
285 if (a->ts.kind != f->ts.kind)
287 ts.type = f->ts.type;
288 ts.kind = f->ts.kind;
289 gfc_convert_type (a, &ts, 2);
292 /* The resolved name is only used for specific intrinsics where
293 the return kind is the same as the arg kind. */
294 f->value.function.name
295 = gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type),
301 gfc_resolve_dnint (gfc_expr *f, gfc_expr *a)
303 gfc_resolve_anint (f, a, NULL);
308 gfc_resolve_any (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
314 gfc_resolve_dim_arg (dim);
315 f->rank = mask->rank - 1;
316 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
319 f->value.function.name
320 = gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask->ts.type),
326 gfc_resolve_asin (gfc_expr *f, gfc_expr *x)
329 f->value.function.name
330 = gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
334 gfc_resolve_asinh (gfc_expr *f, gfc_expr *x)
337 f->value.function.name
338 = gfc_get_string ("__asinh_%c%d", gfc_type_letter (x->ts.type),
343 gfc_resolve_atan (gfc_expr *f, gfc_expr *x)
346 f->value.function.name
347 = gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
351 gfc_resolve_atanh (gfc_expr *f, gfc_expr *x)
354 f->value.function.name
355 = gfc_get_string ("__atanh_%c%d", gfc_type_letter (x->ts.type),
360 gfc_resolve_atan2 (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
363 f->value.function.name
364 = gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type),
369 /* Resolve the BESYN and BESJN intrinsics. */
372 gfc_resolve_besn (gfc_expr *f, gfc_expr *n, gfc_expr *x)
378 if (n->ts.kind != gfc_c_int_kind)
380 ts.type = BT_INTEGER;
381 ts.kind = gfc_c_int_kind;
382 gfc_convert_type (n, &ts, 2);
384 f->value.function.name = gfc_get_string ("<intrinsic>");
389 gfc_resolve_btest (gfc_expr *f, gfc_expr *i, gfc_expr *pos)
391 f->ts.type = BT_LOGICAL;
392 f->ts.kind = gfc_default_logical_kind;
393 f->value.function.name
394 = gfc_get_string ("__btest_%d_%d", i->ts.kind, pos->ts.kind);
399 gfc_resolve_ceiling (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
401 f->ts.type = BT_INTEGER;
402 f->ts.kind = (kind == NULL)
403 ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
404 f->value.function.name
405 = gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind,
406 gfc_type_letter (a->ts.type), a->ts.kind);
411 gfc_resolve_char (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
413 gfc_resolve_char_achar (f, a, kind, "__char_%d_%c%d");
418 gfc_resolve_chdir (gfc_expr *f, gfc_expr *d ATTRIBUTE_UNUSED)
420 f->ts.type = BT_INTEGER;
421 f->ts.kind = gfc_default_integer_kind;
422 f->value.function.name = gfc_get_string (PREFIX ("chdir_i%d"), f->ts.kind);
427 gfc_resolve_chdir_sub (gfc_code *c)
432 if (c->ext.actual->next->expr != NULL)
433 kind = c->ext.actual->next->expr->ts.kind;
435 kind = gfc_default_integer_kind;
437 name = gfc_get_string (PREFIX ("chdir_i%d_sub"), kind);
438 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
443 gfc_resolve_chmod (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
444 gfc_expr *mode ATTRIBUTE_UNUSED)
446 f->ts.type = BT_INTEGER;
447 f->ts.kind = gfc_c_int_kind;
448 f->value.function.name = PREFIX ("chmod_func");
453 gfc_resolve_chmod_sub (gfc_code *c)
458 if (c->ext.actual->next->next->expr != NULL)
459 kind = c->ext.actual->next->next->expr->ts.kind;
461 kind = gfc_default_integer_kind;
463 name = gfc_get_string (PREFIX ("chmod_i%d_sub"), kind);
464 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
469 gfc_resolve_cmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y, gfc_expr *kind)
471 f->ts.type = BT_COMPLEX;
472 f->ts.kind = (kind == NULL)
473 ? gfc_default_real_kind : mpz_get_si (kind->value.integer);
476 f->value.function.name
477 = gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind,
478 gfc_type_letter (x->ts.type), x->ts.kind);
480 f->value.function.name
481 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
482 gfc_type_letter (x->ts.type), x->ts.kind,
483 gfc_type_letter (y->ts.type), y->ts.kind);
488 gfc_resolve_dcmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y)
490 gfc_resolve_cmplx (f, x, y, gfc_int_expr (gfc_default_double_kind));
495 gfc_resolve_complex (gfc_expr *f, gfc_expr *x, gfc_expr *y)
499 if (x->ts.type == BT_INTEGER)
501 if (y->ts.type == BT_INTEGER)
502 kind = gfc_default_real_kind;
508 if (y->ts.type == BT_REAL)
509 kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
514 f->ts.type = BT_COMPLEX;
516 f->value.function.name
517 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
518 gfc_type_letter (x->ts.type), x->ts.kind,
519 gfc_type_letter (y->ts.type), y->ts.kind);
524 gfc_resolve_conjg (gfc_expr *f, gfc_expr *x)
527 f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind);
532 gfc_resolve_cos (gfc_expr *f, gfc_expr *x)
535 f->value.function.name
536 = gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
541 gfc_resolve_cosh (gfc_expr *f, gfc_expr *x)
544 f->value.function.name
545 = gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
550 gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
552 f->ts.type = BT_INTEGER;
554 f->ts.kind = mpz_get_si (kind->value.integer);
556 f->ts.kind = gfc_default_integer_kind;
560 f->rank = mask->rank - 1;
561 gfc_resolve_dim_arg (dim);
562 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
565 resolve_mask_arg (mask);
567 f->value.function.name
568 = gfc_get_string (PREFIX ("count_%d_%c"), f->ts.kind,
569 gfc_type_letter (mask->ts.type));
574 gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
579 if (array->ts.type == BT_CHARACTER && array->ref)
580 gfc_resolve_substring_charlen (array);
583 f->rank = array->rank;
584 f->shape = gfc_copy_shape (array->shape, array->rank);
591 /* If dim kind is greater than default integer we need to use the larger. */
592 m = gfc_default_integer_kind;
594 m = m < dim->ts.kind ? dim->ts.kind : m;
596 /* Convert shift to at least m, so we don't need
597 kind=1 and kind=2 versions of the library functions. */
598 if (shift->ts.kind < m)
602 ts.type = BT_INTEGER;
604 gfc_convert_type_warn (shift, &ts, 2, 0);
609 if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL
610 && dim->symtree->n.sym->attr.optional)
612 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
613 dim->representation.length = shift->ts.kind;
617 gfc_resolve_dim_arg (dim);
618 /* Convert dim to shift's kind to reduce variations. */
619 if (dim->ts.kind != shift->ts.kind)
620 gfc_convert_type_warn (dim, &shift->ts, 2, 0);
624 if (array->ts.type == BT_CHARACTER)
626 if (array->ts.kind == gfc_default_character_kind)
627 f->value.function.name
628 = gfc_get_string (PREFIX ("cshift%d_%d_char"), n, shift->ts.kind);
630 f->value.function.name
631 = gfc_get_string (PREFIX ("cshift%d_%d_char%d"), n, shift->ts.kind,
635 f->value.function.name
636 = gfc_get_string (PREFIX ("cshift%d_%d"), n, shift->ts.kind);
641 gfc_resolve_ctime (gfc_expr *f, gfc_expr *time)
646 f->ts.type = BT_CHARACTER;
647 f->ts.kind = gfc_default_character_kind;
649 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
650 if (time->ts.kind != 8)
652 ts.type = BT_INTEGER;
656 gfc_convert_type (time, &ts, 2);
659 f->value.function.name = gfc_get_string (PREFIX ("ctime"));
664 gfc_resolve_dble (gfc_expr *f, gfc_expr *a)
666 f->ts.type = BT_REAL;
667 f->ts.kind = gfc_default_double_kind;
668 f->value.function.name
669 = gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
674 gfc_resolve_dim (gfc_expr *f, gfc_expr *a, gfc_expr *p)
676 f->ts.type = a->ts.type;
678 f->ts.kind = gfc_kind_max (a,p);
680 f->ts.kind = a->ts.kind;
682 if (p != NULL && a->ts.kind != p->ts.kind)
684 if (a->ts.kind == gfc_kind_max (a,p))
685 gfc_convert_type (p, &a->ts, 2);
687 gfc_convert_type (a, &p->ts, 2);
690 f->value.function.name
691 = gfc_get_string ("__dim_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
696 gfc_resolve_dot_product (gfc_expr *f, gfc_expr *a, gfc_expr *b)
700 temp.expr_type = EXPR_OP;
701 gfc_clear_ts (&temp.ts);
702 temp.value.op.op = INTRINSIC_NONE;
703 temp.value.op.op1 = a;
704 temp.value.op.op2 = b;
705 gfc_type_convert_binary (&temp);
707 f->value.function.name
708 = gfc_get_string (PREFIX ("dot_product_%c%d"),
709 gfc_type_letter (f->ts.type), f->ts.kind);
714 gfc_resolve_dprod (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
715 gfc_expr *b ATTRIBUTE_UNUSED)
717 f->ts.kind = gfc_default_double_kind;
718 f->ts.type = BT_REAL;
719 f->value.function.name = gfc_get_string ("__dprod_r%d", f->ts.kind);
724 gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
725 gfc_expr *boundary, gfc_expr *dim)
729 if (array->ts.type == BT_CHARACTER && array->ref)
730 gfc_resolve_substring_charlen (array);
733 f->rank = array->rank;
734 f->shape = gfc_copy_shape (array->shape, array->rank);
739 if (boundary && boundary->rank > 0)
742 /* If dim kind is greater than default integer we need to use the larger. */
743 m = gfc_default_integer_kind;
745 m = m < dim->ts.kind ? dim->ts.kind : m;
747 /* Convert shift to at least m, so we don't need
748 kind=1 and kind=2 versions of the library functions. */
749 if (shift->ts.kind < m)
753 ts.type = BT_INTEGER;
755 gfc_convert_type_warn (shift, &ts, 2, 0);
760 if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL
761 && dim->symtree->n.sym->attr.optional)
763 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
764 dim->representation.length = shift->ts.kind;
768 gfc_resolve_dim_arg (dim);
769 /* Convert dim to shift's kind to reduce variations. */
770 if (dim->ts.kind != shift->ts.kind)
771 gfc_convert_type_warn (dim, &shift->ts, 2, 0);
775 if (array->ts.type == BT_CHARACTER)
777 if (array->ts.kind == gfc_default_character_kind)
778 f->value.function.name
779 = gfc_get_string (PREFIX ("eoshift%d_%d_char"), n, shift->ts.kind);
781 f->value.function.name
782 = gfc_get_string (PREFIX ("eoshift%d_%d_char%d"), n, shift->ts.kind,
786 f->value.function.name
787 = gfc_get_string (PREFIX ("eoshift%d_%d"), n, shift->ts.kind);
792 gfc_resolve_exp (gfc_expr *f, gfc_expr *x)
795 f->value.function.name
796 = gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
801 gfc_resolve_exponent (gfc_expr *f, gfc_expr *x)
803 f->ts.type = BT_INTEGER;
804 f->ts.kind = gfc_default_integer_kind;
805 f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind);
809 /* Resolve the EXTENDS_TYPE_OF intrinsic function. */
812 gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
817 /* Prevent double resolution. */
818 if (f->ts.type == BT_LOGICAL)
821 /* Replace the first argument with the corresponding vtab. */
822 if (a->ts.type == BT_CLASS)
823 gfc_add_component_ref (a, "$vptr");
824 else if (a->ts.type == BT_DERIVED)
826 vtab = gfc_find_derived_vtab (a->ts.u.derived);
827 /* Clear the old expr. */
828 gfc_free_ref_list (a->ref);
829 memset (a, '\0', sizeof (gfc_expr));
830 /* Construct a new one. */
831 a->expr_type = EXPR_VARIABLE;
832 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
837 /* Replace the second argument with the corresponding vtab. */
838 if (mo->ts.type == BT_CLASS)
839 gfc_add_component_ref (mo, "$vptr");
840 else if (mo->ts.type == BT_DERIVED)
842 vtab = gfc_find_derived_vtab (mo->ts.u.derived);
843 /* Clear the old expr. */
844 gfc_free_ref_list (mo->ref);
845 memset (mo, '\0', sizeof (gfc_expr));
846 /* Construct a new one. */
847 mo->expr_type = EXPR_VARIABLE;
848 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
853 f->ts.type = BT_LOGICAL;
855 /* Call library function. */
856 f->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
861 gfc_resolve_fdate (gfc_expr *f)
863 f->ts.type = BT_CHARACTER;
864 f->ts.kind = gfc_default_character_kind;
865 f->value.function.name = gfc_get_string (PREFIX ("fdate"));
870 gfc_resolve_floor (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
872 f->ts.type = BT_INTEGER;
873 f->ts.kind = (kind == NULL)
874 ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
875 f->value.function.name
876 = gfc_get_string ("__floor%d_%c%d", f->ts.kind,
877 gfc_type_letter (a->ts.type), a->ts.kind);
882 gfc_resolve_fnum (gfc_expr *f, gfc_expr *n)
884 f->ts.type = BT_INTEGER;
885 f->ts.kind = gfc_default_integer_kind;
886 if (n->ts.kind != f->ts.kind)
887 gfc_convert_type (n, &f->ts, 2);
888 f->value.function.name = gfc_get_string (PREFIX ("fnum_i%d"), f->ts.kind);
893 gfc_resolve_fraction (gfc_expr *f, gfc_expr *x)
896 f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind);
900 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
903 gfc_resolve_g77_math1 (gfc_expr *f, gfc_expr *x)
906 f->value.function.name = gfc_get_string ("<intrinsic>");
911 gfc_resolve_gamma (gfc_expr *f, gfc_expr *x)
914 f->value.function.name
915 = gfc_get_string ("__gamma_%d", x->ts.kind);
920 gfc_resolve_getcwd (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
922 f->ts.type = BT_INTEGER;
924 f->value.function.name = gfc_get_string (PREFIX ("getcwd"));
929 gfc_resolve_getgid (gfc_expr *f)
931 f->ts.type = BT_INTEGER;
933 f->value.function.name = gfc_get_string (PREFIX ("getgid"));
938 gfc_resolve_getpid (gfc_expr *f)
940 f->ts.type = BT_INTEGER;
942 f->value.function.name = gfc_get_string (PREFIX ("getpid"));
947 gfc_resolve_getuid (gfc_expr *f)
949 f->ts.type = BT_INTEGER;
951 f->value.function.name = gfc_get_string (PREFIX ("getuid"));
956 gfc_resolve_hostnm (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
958 f->ts.type = BT_INTEGER;
960 f->value.function.name = gfc_get_string (PREFIX ("hostnm"));
965 gfc_resolve_hypot (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
968 f->value.function.name = gfc_get_string ("__hypot_r%d", x->ts.kind);
973 gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j)
975 /* If the kind of i and j are different, then g77 cross-promoted the
976 kinds to the largest value. The Fortran 95 standard requires the
978 if (i->ts.kind != j->ts.kind)
980 if (i->ts.kind == gfc_kind_max (i, j))
981 gfc_convert_type (j, &i->ts, 2);
983 gfc_convert_type (i, &j->ts, 2);
987 f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind);
992 gfc_resolve_ibclr (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
995 f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind);
1000 gfc_resolve_ibits (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED,
1001 gfc_expr *len ATTRIBUTE_UNUSED)
1004 f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind);
1009 gfc_resolve_ibset (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
1012 f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind);
1017 gfc_resolve_iachar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
1019 f->ts.type = BT_INTEGER;
1021 f->ts.kind = mpz_get_si (kind->value.integer);
1023 f->ts.kind = gfc_default_integer_kind;
1024 f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
1029 gfc_resolve_ichar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
1031 f->ts.type = BT_INTEGER;
1033 f->ts.kind = mpz_get_si (kind->value.integer);
1035 f->ts.kind = gfc_default_integer_kind;
1036 f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
1041 gfc_resolve_idnint (gfc_expr *f, gfc_expr *a)
1043 gfc_resolve_nint (f, a, NULL);
1048 gfc_resolve_ierrno (gfc_expr *f)
1050 f->ts.type = BT_INTEGER;
1051 f->ts.kind = gfc_default_integer_kind;
1052 f->value.function.name = gfc_get_string (PREFIX ("ierrno_i%d"), f->ts.kind);
1057 gfc_resolve_ieor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1059 /* If the kind of i and j are different, then g77 cross-promoted the
1060 kinds to the largest value. The Fortran 95 standard requires the
1062 if (i->ts.kind != j->ts.kind)
1064 if (i->ts.kind == gfc_kind_max (i, j))
1065 gfc_convert_type (j, &i->ts, 2);
1067 gfc_convert_type (i, &j->ts, 2);
1071 f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind);
1076 gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1078 /* If the kind of i and j are different, then g77 cross-promoted the
1079 kinds to the largest value. The Fortran 95 standard requires the
1081 if (i->ts.kind != j->ts.kind)
1083 if (i->ts.kind == gfc_kind_max (i, j))
1084 gfc_convert_type (j, &i->ts, 2);
1086 gfc_convert_type (i, &j->ts, 2);
1090 f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind);
1095 gfc_resolve_index_func (gfc_expr *f, gfc_expr *str,
1096 gfc_expr *sub_str ATTRIBUTE_UNUSED, gfc_expr *back,
1102 f->ts.type = BT_INTEGER;
1104 f->ts.kind = mpz_get_si (kind->value.integer);
1106 f->ts.kind = gfc_default_integer_kind;
1108 if (back && back->ts.kind != gfc_default_integer_kind)
1110 ts.type = BT_LOGICAL;
1111 ts.kind = gfc_default_integer_kind;
1112 ts.u.derived = NULL;
1114 gfc_convert_type (back, &ts, 2);
1117 f->value.function.name
1118 = gfc_get_string ("__index_%d_i%d", str->ts.kind, f->ts.kind);
1123 gfc_resolve_int (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1125 f->ts.type = BT_INTEGER;
1126 f->ts.kind = (kind == NULL)
1127 ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
1128 f->value.function.name
1129 = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1130 gfc_type_letter (a->ts.type), a->ts.kind);
1135 gfc_resolve_int2 (gfc_expr *f, gfc_expr *a)
1137 f->ts.type = BT_INTEGER;
1139 f->value.function.name
1140 = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1141 gfc_type_letter (a->ts.type), a->ts.kind);
1146 gfc_resolve_int8 (gfc_expr *f, gfc_expr *a)
1148 f->ts.type = BT_INTEGER;
1150 f->value.function.name
1151 = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1152 gfc_type_letter (a->ts.type), a->ts.kind);
1157 gfc_resolve_long (gfc_expr *f, gfc_expr *a)
1159 f->ts.type = BT_INTEGER;
1161 f->value.function.name
1162 = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1163 gfc_type_letter (a->ts.type), a->ts.kind);
1168 gfc_resolve_isatty (gfc_expr *f, gfc_expr *u)
1173 f->ts.type = BT_LOGICAL;
1174 f->ts.kind = gfc_default_integer_kind;
1175 if (u->ts.kind != gfc_c_int_kind)
1177 ts.type = BT_INTEGER;
1178 ts.kind = gfc_c_int_kind;
1179 ts.u.derived = NULL;
1181 gfc_convert_type (u, &ts, 2);
1184 f->value.function.name = gfc_get_string (PREFIX ("isatty_l%d"), f->ts.kind);
1189 gfc_resolve_ishft (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1192 f->value.function.name
1193 = gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
1198 gfc_resolve_rshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1201 f->value.function.name
1202 = gfc_get_string ("__rshift_%d_%d", i->ts.kind, shift->ts.kind);
1207 gfc_resolve_lshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1210 f->value.function.name
1211 = gfc_get_string ("__lshift_%d_%d", i->ts.kind, shift->ts.kind);
1216 gfc_resolve_ishftc (gfc_expr *f, gfc_expr *i, gfc_expr *shift, gfc_expr *size)
1220 s_kind = (size == NULL) ? gfc_default_integer_kind : size->ts.kind;
1223 f->value.function.name
1224 = gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
1229 gfc_resolve_kill (gfc_expr *f, gfc_expr *p ATTRIBUTE_UNUSED,
1230 gfc_expr *s ATTRIBUTE_UNUSED)
1232 f->ts.type = BT_INTEGER;
1233 f->ts.kind = gfc_default_integer_kind;
1234 f->value.function.name = gfc_get_string (PREFIX ("kill_i%d"), f->ts.kind);
1239 gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
1241 static char lbound[] = "__lbound";
1243 f->ts.type = BT_INTEGER;
1245 f->ts.kind = mpz_get_si (kind->value.integer);
1247 f->ts.kind = gfc_default_integer_kind;
1252 f->shape = gfc_get_shape (1);
1253 mpz_init_set_ui (f->shape[0], array->rank);
1256 f->value.function.name = lbound;
1261 gfc_resolve_len (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
1263 f->ts.type = BT_INTEGER;
1265 f->ts.kind = mpz_get_si (kind->value.integer);
1267 f->ts.kind = gfc_default_integer_kind;
1268 f->value.function.name
1269 = gfc_get_string ("__len_%d_i%d", string->ts.kind,
1270 gfc_default_integer_kind);
1275 gfc_resolve_len_trim (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
1277 f->ts.type = BT_INTEGER;
1279 f->ts.kind = mpz_get_si (kind->value.integer);
1281 f->ts.kind = gfc_default_integer_kind;
1282 f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
1287 gfc_resolve_lgamma (gfc_expr *f, gfc_expr *x)
1290 f->value.function.name
1291 = gfc_get_string ("__lgamma_%d", x->ts.kind);
1296 gfc_resolve_link (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
1297 gfc_expr *p2 ATTRIBUTE_UNUSED)
1299 f->ts.type = BT_INTEGER;
1300 f->ts.kind = gfc_default_integer_kind;
1301 f->value.function.name = gfc_get_string (PREFIX ("link_i%d"), f->ts.kind);
1306 gfc_resolve_loc (gfc_expr *f, gfc_expr *x)
1308 f->ts.type= BT_INTEGER;
1309 f->ts.kind = gfc_index_integer_kind;
1310 f->value.function.name = gfc_get_string ("__loc_%d", x->ts.kind);
1315 gfc_resolve_log (gfc_expr *f, gfc_expr *x)
1318 f->value.function.name
1319 = gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1324 gfc_resolve_log10 (gfc_expr *f, gfc_expr *x)
1327 f->value.function.name
1328 = gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type),
1334 gfc_resolve_logical (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1336 f->ts.type = BT_LOGICAL;
1337 f->ts.kind = (kind == NULL)
1338 ? gfc_default_logical_kind : mpz_get_si (kind->value.integer);
1341 f->value.function.name
1342 = gfc_get_string ("__logical_%d_%c%d", f->ts.kind,
1343 gfc_type_letter (a->ts.type), a->ts.kind);
1348 gfc_resolve_malloc (gfc_expr *f, gfc_expr *size)
1350 if (size->ts.kind < gfc_index_integer_kind)
1355 ts.type = BT_INTEGER;
1356 ts.kind = gfc_index_integer_kind;
1357 gfc_convert_type_warn (size, &ts, 2, 0);
1360 f->ts.type = BT_INTEGER;
1361 f->ts.kind = gfc_index_integer_kind;
1362 f->value.function.name = gfc_get_string (PREFIX ("malloc"));
1367 gfc_resolve_matmul (gfc_expr *f, gfc_expr *a, gfc_expr *b)
1371 if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
1373 f->ts.type = BT_LOGICAL;
1374 f->ts.kind = gfc_default_logical_kind;
1378 temp.expr_type = EXPR_OP;
1379 gfc_clear_ts (&temp.ts);
1380 temp.value.op.op = INTRINSIC_NONE;
1381 temp.value.op.op1 = a;
1382 temp.value.op.op2 = b;
1383 gfc_type_convert_binary (&temp);
1387 f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
1389 if (a->rank == 2 && b->rank == 2)
1391 if (a->shape && b->shape)
1393 f->shape = gfc_get_shape (f->rank);
1394 mpz_init_set (f->shape[0], a->shape[0]);
1395 mpz_init_set (f->shape[1], b->shape[1]);
1398 else if (a->rank == 1)
1402 f->shape = gfc_get_shape (f->rank);
1403 mpz_init_set (f->shape[0], b->shape[1]);
1408 /* b->rank == 1 and a->rank == 2 here, all other cases have
1409 been caught in check.c. */
1412 f->shape = gfc_get_shape (f->rank);
1413 mpz_init_set (f->shape[0], a->shape[0]);
1417 f->value.function.name
1418 = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f->ts.type),
1424 gfc_resolve_minmax (const char *name, gfc_expr *f, gfc_actual_arglist *args)
1426 gfc_actual_arglist *a;
1428 f->ts.type = args->expr->ts.type;
1429 f->ts.kind = args->expr->ts.kind;
1430 /* Find the largest type kind. */
1431 for (a = args->next; a; a = a->next)
1433 if (a->expr->ts.kind > f->ts.kind)
1434 f->ts.kind = a->expr->ts.kind;
1437 /* Convert all parameters to the required kind. */
1438 for (a = args; a; a = a->next)
1440 if (a->expr->ts.kind != f->ts.kind)
1441 gfc_convert_type (a->expr, &f->ts, 2);
1444 f->value.function.name
1445 = gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind);
1450 gfc_resolve_max (gfc_expr *f, gfc_actual_arglist *args)
1452 gfc_resolve_minmax ("__max_%c%d", f, args);
1457 gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1463 f->ts.type = BT_INTEGER;
1464 f->ts.kind = gfc_default_integer_kind;
1469 f->shape = gfc_get_shape (1);
1470 mpz_init_set_si (f->shape[0], array->rank);
1474 f->rank = array->rank - 1;
1475 gfc_resolve_dim_arg (dim);
1476 if (array->shape && dim->expr_type == EXPR_CONSTANT)
1478 idim = (int) mpz_get_si (dim->value.integer);
1479 f->shape = gfc_get_shape (f->rank);
1480 for (i = 0, j = 0; i < f->rank; i++, j++)
1482 if (i == (idim - 1))
1484 mpz_init_set (f->shape[i], array->shape[j]);
1491 if (mask->rank == 0)
1496 resolve_mask_arg (mask);
1501 f->value.function.name
1502 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1503 gfc_type_letter (array->ts.type), array->ts.kind);
1508 gfc_resolve_maxval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1518 f->rank = array->rank - 1;
1519 gfc_resolve_dim_arg (dim);
1521 if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
1523 idim = (int) mpz_get_si (dim->value.integer);
1524 f->shape = gfc_get_shape (f->rank);
1525 for (i = 0, j = 0; i < f->rank; i++, j++)
1527 if (i == (idim - 1))
1529 mpz_init_set (f->shape[i], array->shape[j]);
1536 if (mask->rank == 0)
1541 resolve_mask_arg (mask);
1546 f->value.function.name
1547 = gfc_get_string (PREFIX ("%s_%c%d"), name,
1548 gfc_type_letter (array->ts.type), array->ts.kind);
1553 gfc_resolve_mclock (gfc_expr *f)
1555 f->ts.type = BT_INTEGER;
1557 f->value.function.name = PREFIX ("mclock");
1562 gfc_resolve_mclock8 (gfc_expr *f)
1564 f->ts.type = BT_INTEGER;
1566 f->value.function.name = PREFIX ("mclock8");
1571 gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource,
1572 gfc_expr *fsource ATTRIBUTE_UNUSED,
1573 gfc_expr *mask ATTRIBUTE_UNUSED)
1575 if (tsource->ts.type == BT_CHARACTER && tsource->ref)
1576 gfc_resolve_substring_charlen (tsource);
1578 if (fsource->ts.type == BT_CHARACTER && fsource->ref)
1579 gfc_resolve_substring_charlen (fsource);
1581 if (tsource->ts.type == BT_CHARACTER)
1582 check_charlen_present (tsource);
1584 f->ts = tsource->ts;
1585 f->value.function.name
1586 = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
1592 gfc_resolve_min (gfc_expr *f, gfc_actual_arglist *args)
1594 gfc_resolve_minmax ("__min_%c%d", f, args);
1599 gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1605 f->ts.type = BT_INTEGER;
1606 f->ts.kind = gfc_default_integer_kind;
1611 f->shape = gfc_get_shape (1);
1612 mpz_init_set_si (f->shape[0], array->rank);
1616 f->rank = array->rank - 1;
1617 gfc_resolve_dim_arg (dim);
1618 if (array->shape && dim->expr_type == EXPR_CONSTANT)
1620 idim = (int) mpz_get_si (dim->value.integer);
1621 f->shape = gfc_get_shape (f->rank);
1622 for (i = 0, j = 0; i < f->rank; i++, j++)
1624 if (i == (idim - 1))
1626 mpz_init_set (f->shape[i], array->shape[j]);
1633 if (mask->rank == 0)
1638 resolve_mask_arg (mask);
1643 f->value.function.name
1644 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1645 gfc_type_letter (array->ts.type), array->ts.kind);
1650 gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1660 f->rank = array->rank - 1;
1661 gfc_resolve_dim_arg (dim);
1663 if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
1665 idim = (int) mpz_get_si (dim->value.integer);
1666 f->shape = gfc_get_shape (f->rank);
1667 for (i = 0, j = 0; i < f->rank; i++, j++)
1669 if (i == (idim - 1))
1671 mpz_init_set (f->shape[i], array->shape[j]);
1678 if (mask->rank == 0)
1683 resolve_mask_arg (mask);
1688 f->value.function.name
1689 = gfc_get_string (PREFIX ("%s_%c%d"), name,
1690 gfc_type_letter (array->ts.type), array->ts.kind);
1695 gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p)
1697 f->ts.type = a->ts.type;
1699 f->ts.kind = gfc_kind_max (a,p);
1701 f->ts.kind = a->ts.kind;
1703 if (p != NULL && a->ts.kind != p->ts.kind)
1705 if (a->ts.kind == gfc_kind_max (a,p))
1706 gfc_convert_type (p, &a->ts, 2);
1708 gfc_convert_type (a, &p->ts, 2);
1711 f->value.function.name
1712 = gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
1717 gfc_resolve_modulo (gfc_expr *f, gfc_expr *a, gfc_expr *p)
1719 f->ts.type = a->ts.type;
1721 f->ts.kind = gfc_kind_max (a,p);
1723 f->ts.kind = a->ts.kind;
1725 if (p != NULL && a->ts.kind != p->ts.kind)
1727 if (a->ts.kind == gfc_kind_max (a,p))
1728 gfc_convert_type (p, &a->ts, 2);
1730 gfc_convert_type (a, &p->ts, 2);
1733 f->value.function.name
1734 = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type),
1739 gfc_resolve_nearest (gfc_expr *f, gfc_expr *a, gfc_expr *p)
1741 if (p->ts.kind != a->ts.kind)
1742 gfc_convert_type (p, &a->ts, 2);
1745 f->value.function.name
1746 = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
1751 gfc_resolve_nint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1753 f->ts.type = BT_INTEGER;
1754 f->ts.kind = (kind == NULL)
1755 ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
1756 f->value.function.name
1757 = gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
1762 gfc_resolve_not (gfc_expr *f, gfc_expr *i)
1765 f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
1770 gfc_resolve_or (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1772 f->ts.type = i->ts.type;
1773 f->ts.kind = gfc_kind_max (i, j);
1775 if (i->ts.kind != j->ts.kind)
1777 if (i->ts.kind == gfc_kind_max (i, j))
1778 gfc_convert_type (j, &i->ts, 2);
1780 gfc_convert_type (i, &j->ts, 2);
1783 f->value.function.name
1784 = gfc_get_string ("__or_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
1789 gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
1790 gfc_expr *vector ATTRIBUTE_UNUSED)
1792 if (array->ts.type == BT_CHARACTER && array->ref)
1793 gfc_resolve_substring_charlen (array);
1798 resolve_mask_arg (mask);
1800 if (mask->rank != 0)
1802 if (array->ts.type == BT_CHARACTER)
1803 f->value.function.name
1804 = array->ts.kind == 1 ? PREFIX ("pack_char")
1806 (PREFIX ("pack_char%d"),
1809 f->value.function.name = PREFIX ("pack");
1813 if (array->ts.type == BT_CHARACTER)
1814 f->value.function.name
1815 = array->ts.kind == 1 ? PREFIX ("pack_s_char")
1817 (PREFIX ("pack_s_char%d"),
1820 f->value.function.name = PREFIX ("pack_s");
1826 gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1835 f->rank = array->rank - 1;
1836 f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
1837 gfc_resolve_dim_arg (dim);
1842 if (mask->rank == 0)
1847 resolve_mask_arg (mask);
1852 f->value.function.name
1853 = gfc_get_string (PREFIX ("%s_%c%d"), name,
1854 gfc_type_letter (array->ts.type), array->ts.kind);
1859 gfc_resolve_real (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1861 f->ts.type = BT_REAL;
1864 f->ts.kind = mpz_get_si (kind->value.integer);
1866 f->ts.kind = (a->ts.type == BT_COMPLEX)
1867 ? a->ts.kind : gfc_default_real_kind;
1869 f->value.function.name
1870 = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1871 gfc_type_letter (a->ts.type), a->ts.kind);
1876 gfc_resolve_realpart (gfc_expr *f, gfc_expr *a)
1878 f->ts.type = BT_REAL;
1879 f->ts.kind = a->ts.kind;
1880 f->value.function.name
1881 = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1882 gfc_type_letter (a->ts.type), a->ts.kind);
1887 gfc_resolve_rename (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
1888 gfc_expr *p2 ATTRIBUTE_UNUSED)
1890 f->ts.type = BT_INTEGER;
1891 f->ts.kind = gfc_default_integer_kind;
1892 f->value.function.name = gfc_get_string (PREFIX ("rename_i%d"), f->ts.kind);
1897 gfc_resolve_repeat (gfc_expr *f, gfc_expr *string,
1898 gfc_expr *ncopies ATTRIBUTE_UNUSED)
1900 f->ts.type = BT_CHARACTER;
1901 f->ts.kind = string->ts.kind;
1902 f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
1907 gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
1908 gfc_expr *pad ATTRIBUTE_UNUSED,
1909 gfc_expr *order ATTRIBUTE_UNUSED)
1915 if (source->ts.type == BT_CHARACTER && source->ref)
1916 gfc_resolve_substring_charlen (source);
1920 gfc_array_size (shape, &rank);
1921 f->rank = mpz_get_si (rank);
1923 switch (source->ts.type)
1930 kind = source->ts.kind;
1944 if (source->ts.type == BT_COMPLEX || source->ts.type == BT_REAL)
1945 f->value.function.name
1946 = gfc_get_string (PREFIX ("reshape_%c%d"),
1947 gfc_type_letter (source->ts.type),
1949 else if (source->ts.type == BT_CHARACTER)
1950 f->value.function.name = gfc_get_string (PREFIX ("reshape_char%d"),
1953 f->value.function.name
1954 = gfc_get_string (PREFIX ("reshape_%d"), source->ts.kind);
1958 f->value.function.name = (source->ts.type == BT_CHARACTER
1959 ? PREFIX ("reshape_char") : PREFIX ("reshape"));
1963 /* TODO: Make this work with a constant ORDER parameter. */
1964 if (shape->expr_type == EXPR_ARRAY
1965 && gfc_is_constant_expr (shape)
1969 f->shape = gfc_get_shape (f->rank);
1970 c = shape->value.constructor;
1971 for (i = 0; i < f->rank; i++)
1973 mpz_init_set (f->shape[i], c->expr->value.integer);
1978 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
1979 so many runtime variations. */
1980 if (shape->ts.kind != gfc_index_integer_kind)
1982 gfc_typespec ts = shape->ts;
1983 ts.kind = gfc_index_integer_kind;
1984 gfc_convert_type_warn (shape, &ts, 2, 0);
1986 if (order && order->ts.kind != gfc_index_integer_kind)
1987 gfc_convert_type_warn (order, &shape->ts, 2, 0);
1992 gfc_resolve_rrspacing (gfc_expr *f, gfc_expr *x)
1995 f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
2000 gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i ATTRIBUTE_UNUSED)
2003 f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
2008 gfc_resolve_scan (gfc_expr *f, gfc_expr *string,
2009 gfc_expr *set ATTRIBUTE_UNUSED,
2010 gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
2012 f->ts.type = BT_INTEGER;
2014 f->ts.kind = mpz_get_si (kind->value.integer);
2016 f->ts.kind = gfc_default_integer_kind;
2017 f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
2022 gfc_resolve_secnds (gfc_expr *t1, gfc_expr *t0)
2025 t1->value.function.name = gfc_get_string (PREFIX ("secnds"));
2030 gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x,
2031 gfc_expr *i ATTRIBUTE_UNUSED)
2034 f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
2039 gfc_resolve_shape (gfc_expr *f, gfc_expr *array)
2041 f->ts.type = BT_INTEGER;
2042 f->ts.kind = gfc_default_integer_kind;
2044 f->shape = gfc_get_shape (1);
2045 mpz_init_set_ui (f->shape[0], array->rank);
2046 f->value.function.name = gfc_get_string (PREFIX ("shape_%d"), f->ts.kind);
2051 gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b ATTRIBUTE_UNUSED)
2054 f->value.function.name
2055 = gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
2060 gfc_resolve_signal (gfc_expr *f, gfc_expr *number, gfc_expr *handler)
2062 f->ts.type = BT_INTEGER;
2063 f->ts.kind = gfc_c_int_kind;
2065 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2066 if (handler->ts.type == BT_INTEGER)
2068 if (handler->ts.kind != gfc_c_int_kind)
2069 gfc_convert_type (handler, &f->ts, 2);
2070 f->value.function.name = gfc_get_string (PREFIX ("signal_func_int"));
2073 f->value.function.name = gfc_get_string (PREFIX ("signal_func"));
2075 if (number->ts.kind != gfc_c_int_kind)
2076 gfc_convert_type (number, &f->ts, 2);
2081 gfc_resolve_sin (gfc_expr *f, gfc_expr *x)
2084 f->value.function.name
2085 = gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2090 gfc_resolve_sinh (gfc_expr *f, gfc_expr *x)
2093 f->value.function.name
2094 = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2099 gfc_resolve_size (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2100 gfc_expr *dim ATTRIBUTE_UNUSED, gfc_expr *kind)
2102 f->ts.type = BT_INTEGER;
2104 f->ts.kind = mpz_get_si (kind->value.integer);
2106 f->ts.kind = gfc_default_integer_kind;
2111 gfc_resolve_spacing (gfc_expr *f, gfc_expr *x)
2114 f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
2119 gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim,
2122 if (source->ts.type == BT_CHARACTER && source->ref)
2123 gfc_resolve_substring_charlen (source);
2125 if (source->ts.type == BT_CHARACTER)
2126 check_charlen_present (source);
2129 f->rank = source->rank + 1;
2130 if (source->rank == 0)
2132 if (source->ts.type == BT_CHARACTER)
2133 f->value.function.name
2134 = source->ts.kind == 1 ? PREFIX ("spread_char_scalar")
2136 (PREFIX ("spread_char%d_scalar"),
2139 f->value.function.name = PREFIX ("spread_scalar");
2143 if (source->ts.type == BT_CHARACTER)
2144 f->value.function.name
2145 = source->ts.kind == 1 ? PREFIX ("spread_char")
2147 (PREFIX ("spread_char%d"),
2150 f->value.function.name = PREFIX ("spread");
2153 if (dim && gfc_is_constant_expr (dim)
2154 && ncopies && gfc_is_constant_expr (ncopies) && source->shape[0])
2157 idim = mpz_get_ui (dim->value.integer);
2158 f->shape = gfc_get_shape (f->rank);
2159 for (i = 0; i < (idim - 1); i++)
2160 mpz_init_set (f->shape[i], source->shape[i]);
2162 mpz_init_set (f->shape[idim - 1], ncopies->value.integer);
2164 for (i = idim; i < f->rank ; i++)
2165 mpz_init_set (f->shape[i], source->shape[i-1]);
2169 gfc_resolve_dim_arg (dim);
2170 gfc_resolve_index (ncopies, 1);
2175 gfc_resolve_sqrt (gfc_expr *f, gfc_expr *x)
2178 f->value.function.name
2179 = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2183 /* Resolve the g77 compatibility function STAT AND FSTAT. */
2186 gfc_resolve_stat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2187 gfc_expr *a ATTRIBUTE_UNUSED)
2189 f->ts.type = BT_INTEGER;
2190 f->ts.kind = gfc_default_integer_kind;
2191 f->value.function.name = gfc_get_string (PREFIX ("stat_i%d"), f->ts.kind);
2196 gfc_resolve_lstat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2197 gfc_expr *a ATTRIBUTE_UNUSED)
2199 f->ts.type = BT_INTEGER;
2200 f->ts.kind = gfc_default_integer_kind;
2201 f->value.function.name = gfc_get_string (PREFIX ("lstat_i%d"), f->ts.kind);
2206 gfc_resolve_fstat (gfc_expr *f, gfc_expr *n, gfc_expr *a ATTRIBUTE_UNUSED)
2208 f->ts.type = BT_INTEGER;
2209 f->ts.kind = gfc_default_integer_kind;
2210 if (n->ts.kind != f->ts.kind)
2211 gfc_convert_type (n, &f->ts, 2);
2213 f->value.function.name = gfc_get_string (PREFIX ("fstat_i%d"), f->ts.kind);
2218 gfc_resolve_fgetc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2223 f->ts.type = BT_INTEGER;
2224 f->ts.kind = gfc_c_int_kind;
2225 if (u->ts.kind != gfc_c_int_kind)
2227 ts.type = BT_INTEGER;
2228 ts.kind = gfc_c_int_kind;
2229 ts.u.derived = NULL;
2231 gfc_convert_type (u, &ts, 2);
2234 f->value.function.name = gfc_get_string (PREFIX ("fgetc"));
2239 gfc_resolve_fget (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2241 f->ts.type = BT_INTEGER;
2242 f->ts.kind = gfc_c_int_kind;
2243 f->value.function.name = gfc_get_string (PREFIX ("fget"));
2248 gfc_resolve_fputc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2253 f->ts.type = BT_INTEGER;
2254 f->ts.kind = gfc_c_int_kind;
2255 if (u->ts.kind != gfc_c_int_kind)
2257 ts.type = BT_INTEGER;
2258 ts.kind = gfc_c_int_kind;
2259 ts.u.derived = NULL;
2261 gfc_convert_type (u, &ts, 2);
2264 f->value.function.name = gfc_get_string (PREFIX ("fputc"));
2269 gfc_resolve_fput (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2271 f->ts.type = BT_INTEGER;
2272 f->ts.kind = gfc_c_int_kind;
2273 f->value.function.name = gfc_get_string (PREFIX ("fput"));
2278 gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
2283 f->ts.type = BT_INTEGER;
2284 f->ts.kind = gfc_index_integer_kind;
2285 if (u->ts.kind != gfc_c_int_kind)
2287 ts.type = BT_INTEGER;
2288 ts.kind = gfc_c_int_kind;
2289 ts.u.derived = NULL;
2291 gfc_convert_type (u, &ts, 2);
2294 f->value.function.name = gfc_get_string (PREFIX ("ftell"));
2299 gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
2307 if (mask->rank == 0)
2312 resolve_mask_arg (mask);
2319 f->rank = array->rank - 1;
2320 f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
2321 gfc_resolve_dim_arg (dim);
2324 f->value.function.name
2325 = gfc_get_string (PREFIX ("%s_%c%d"), name,
2326 gfc_type_letter (array->ts.type), array->ts.kind);
2331 gfc_resolve_symlnk (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
2332 gfc_expr *p2 ATTRIBUTE_UNUSED)
2334 f->ts.type = BT_INTEGER;
2335 f->ts.kind = gfc_default_integer_kind;
2336 f->value.function.name = gfc_get_string (PREFIX ("symlnk_i%d"), f->ts.kind);
2340 /* Resolve the g77 compatibility function SYSTEM. */
2343 gfc_resolve_system (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
2345 f->ts.type = BT_INTEGER;
2347 f->value.function.name = gfc_get_string (PREFIX ("system"));
2352 gfc_resolve_tan (gfc_expr *f, gfc_expr *x)
2355 f->value.function.name
2356 = gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2361 gfc_resolve_tanh (gfc_expr *f, gfc_expr *x)
2364 f->value.function.name
2365 = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2370 gfc_resolve_time (gfc_expr *f)
2372 f->ts.type = BT_INTEGER;
2374 f->value.function.name = gfc_get_string (PREFIX ("time_func"));
2379 gfc_resolve_time8 (gfc_expr *f)
2381 f->ts.type = BT_INTEGER;
2383 f->value.function.name = gfc_get_string (PREFIX ("time8_func"));
2388 gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
2389 gfc_expr *mold, gfc_expr *size)
2391 /* TODO: Make this do something meaningful. */
2392 static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
2394 if (mold->ts.type == BT_CHARACTER
2395 && !mold->ts.u.cl->length
2396 && gfc_is_constant_expr (mold))
2399 if (mold->expr_type == EXPR_CONSTANT)
2400 mold->ts.u.cl->length = gfc_int_expr (mold->value.character.length);
2403 len = mold->value.constructor->expr->value.character.length;
2404 mold->ts.u.cl->length = gfc_int_expr (len);
2410 if (size == NULL && mold->rank == 0)
2413 f->value.function.name = transfer0;
2418 f->value.function.name = transfer1;
2419 if (size && gfc_is_constant_expr (size))
2421 f->shape = gfc_get_shape (1);
2422 mpz_init_set (f->shape[0], size->value.integer);
2429 gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
2432 if (matrix->ts.type == BT_CHARACTER && matrix->ref)
2433 gfc_resolve_substring_charlen (matrix);
2439 f->shape = gfc_get_shape (2);
2440 mpz_init_set (f->shape[0], matrix->shape[1]);
2441 mpz_init_set (f->shape[1], matrix->shape[0]);
2444 switch (matrix->ts.kind)
2450 switch (matrix->ts.type)
2454 f->value.function.name
2455 = gfc_get_string (PREFIX ("transpose_%c%d"),
2456 gfc_type_letter (matrix->ts.type),
2462 /* Use the integer routines for real and logical cases. This
2463 assumes they all have the same alignment requirements. */
2464 f->value.function.name
2465 = gfc_get_string (PREFIX ("transpose_i%d"), matrix->ts.kind);
2469 if (matrix->ts.type == BT_CHARACTER && matrix->ts.kind == 4)
2470 f->value.function.name = PREFIX ("transpose_char4");
2472 f->value.function.name = PREFIX ("transpose");
2478 f->value.function.name = (matrix->ts.type == BT_CHARACTER
2479 ? PREFIX ("transpose_char")
2480 : PREFIX ("transpose"));
2487 gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
2489 f->ts.type = BT_CHARACTER;
2490 f->ts.kind = string->ts.kind;
2491 f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
2496 gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2498 static char ubound[] = "__ubound";
2500 f->ts.type = BT_INTEGER;
2502 f->ts.kind = mpz_get_si (kind->value.integer);
2504 f->ts.kind = gfc_default_integer_kind;
2509 f->shape = gfc_get_shape (1);
2510 mpz_init_set_ui (f->shape[0], array->rank);
2513 f->value.function.name = ubound;
2517 /* Resolve the g77 compatibility function UMASK. */
2520 gfc_resolve_umask (gfc_expr *f, gfc_expr *n)
2522 f->ts.type = BT_INTEGER;
2523 f->ts.kind = n->ts.kind;
2524 f->value.function.name = gfc_get_string (PREFIX ("umask_i%d"), n->ts.kind);
2528 /* Resolve the g77 compatibility function UNLINK. */
2531 gfc_resolve_unlink (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
2533 f->ts.type = BT_INTEGER;
2535 f->value.function.name = gfc_get_string (PREFIX ("unlink"));
2540 gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit)
2545 f->ts.type = BT_CHARACTER;
2546 f->ts.kind = gfc_default_character_kind;
2548 if (unit->ts.kind != gfc_c_int_kind)
2550 ts.type = BT_INTEGER;
2551 ts.kind = gfc_c_int_kind;
2552 ts.u.derived = NULL;
2554 gfc_convert_type (unit, &ts, 2);
2557 f->value.function.name = gfc_get_string (PREFIX ("ttynam"));
2562 gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
2563 gfc_expr *field ATTRIBUTE_UNUSED)
2565 if (vector->ts.type == BT_CHARACTER && vector->ref)
2566 gfc_resolve_substring_charlen (vector);
2569 f->rank = mask->rank;
2570 resolve_mask_arg (mask);
2572 if (vector->ts.type == BT_CHARACTER)
2574 if (vector->ts.kind == 1)
2575 f->value.function.name
2576 = gfc_get_string (PREFIX ("unpack%d_char"), field->rank > 0 ? 1 : 0);
2578 f->value.function.name
2579 = gfc_get_string (PREFIX ("unpack%d_char%d"),
2580 field->rank > 0 ? 1 : 0, vector->ts.kind);
2583 f->value.function.name
2584 = gfc_get_string (PREFIX ("unpack%d"), field->rank > 0 ? 1 : 0);
2589 gfc_resolve_verify (gfc_expr *f, gfc_expr *string,
2590 gfc_expr *set ATTRIBUTE_UNUSED,
2591 gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
2593 f->ts.type = BT_INTEGER;
2595 f->ts.kind = mpz_get_si (kind->value.integer);
2597 f->ts.kind = gfc_default_integer_kind;
2598 f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
2603 gfc_resolve_xor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
2605 f->ts.type = i->ts.type;
2606 f->ts.kind = gfc_kind_max (i, j);
2608 if (i->ts.kind != j->ts.kind)
2610 if (i->ts.kind == gfc_kind_max (i, j))
2611 gfc_convert_type (j, &i->ts, 2);
2613 gfc_convert_type (i, &j->ts, 2);
2616 f->value.function.name
2617 = gfc_get_string ("__xor_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
2621 /* Intrinsic subroutine resolution. */
2624 gfc_resolve_alarm_sub (gfc_code *c)
2627 gfc_expr *seconds, *handler;
2631 seconds = c->ext.actual->expr;
2632 handler = c->ext.actual->next->expr;
2633 ts.type = BT_INTEGER;
2634 ts.kind = gfc_c_int_kind;
2636 /* handler can be either BT_INTEGER or BT_PROCEDURE.
2637 In all cases, the status argument is of default integer kind
2638 (enforced in check.c) so that the function suffix is fixed. */
2639 if (handler->ts.type == BT_INTEGER)
2641 if (handler->ts.kind != gfc_c_int_kind)
2642 gfc_convert_type (handler, &ts, 2);
2643 name = gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
2644 gfc_default_integer_kind);
2647 name = gfc_get_string (PREFIX ("alarm_sub_i%d"),
2648 gfc_default_integer_kind);
2650 if (seconds->ts.kind != gfc_c_int_kind)
2651 gfc_convert_type (seconds, &ts, 2);
2653 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2657 gfc_resolve_cpu_time (gfc_code *c)
2660 name = gfc_get_string (PREFIX ("cpu_time_%d"), c->ext.actual->expr->ts.kind);
2661 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2665 /* Create a formal arglist based on an actual one and set the INTENTs given. */
2667 static gfc_formal_arglist*
2668 create_formal_for_intents (gfc_actual_arglist* actual, const sym_intent* ints)
2670 gfc_formal_arglist* head;
2671 gfc_formal_arglist* tail;
2677 head = tail = gfc_get_formal_arglist ();
2678 for (i = 0; actual; actual = actual->next, tail = tail->next, ++i)
2682 sym = gfc_new_symbol ("dummyarg", NULL);
2683 sym->ts = actual->expr->ts;
2685 sym->attr.intent = ints[i];
2689 tail->next = gfc_get_formal_arglist ();
2697 gfc_resolve_mvbits (gfc_code *c)
2699 static const sym_intent INTENTS[] = {INTENT_IN, INTENT_IN, INTENT_IN,
2700 INTENT_INOUT, INTENT_IN};
2706 /* FROMPOS, LEN and TOPOS are restricted to small values. As such,
2707 they will be converted so that they fit into a C int. */
2708 ts.type = BT_INTEGER;
2709 ts.kind = gfc_c_int_kind;
2710 if (c->ext.actual->next->expr->ts.kind != gfc_c_int_kind)
2711 gfc_convert_type (c->ext.actual->next->expr, &ts, 2);
2712 if (c->ext.actual->next->next->expr->ts.kind != gfc_c_int_kind)
2713 gfc_convert_type (c->ext.actual->next->next->expr, &ts, 2);
2714 if (c->ext.actual->next->next->next->next->expr->ts.kind != gfc_c_int_kind)
2715 gfc_convert_type (c->ext.actual->next->next->next->next->expr, &ts, 2);
2717 /* TO and FROM are guaranteed to have the same kind parameter. */
2718 name = gfc_get_string (PREFIX ("mvbits_i%d"),
2719 c->ext.actual->expr->ts.kind);
2720 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2721 /* Mark as elemental subroutine as this does not happen automatically. */
2722 c->resolved_sym->attr.elemental = 1;
2724 /* Create a dummy formal arglist so the INTENTs are known later for purpose
2725 of creating temporaries. */
2726 c->resolved_sym->formal = create_formal_for_intents (c->ext.actual, INTENTS);
2731 gfc_resolve_random_number (gfc_code *c)
2736 kind = c->ext.actual->expr->ts.kind;
2737 if (c->ext.actual->expr->rank == 0)
2738 name = gfc_get_string (PREFIX ("random_r%d"), kind);
2740 name = gfc_get_string (PREFIX ("arandom_r%d"), kind);
2742 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2747 gfc_resolve_random_seed (gfc_code *c)
2751 name = gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind);
2752 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2757 gfc_resolve_rename_sub (gfc_code *c)
2762 if (c->ext.actual->next->next->expr != NULL)
2763 kind = c->ext.actual->next->next->expr->ts.kind;
2765 kind = gfc_default_integer_kind;
2767 name = gfc_get_string (PREFIX ("rename_i%d_sub"), kind);
2768 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2773 gfc_resolve_kill_sub (gfc_code *c)
2778 if (c->ext.actual->next->next->expr != NULL)
2779 kind = c->ext.actual->next->next->expr->ts.kind;
2781 kind = gfc_default_integer_kind;
2783 name = gfc_get_string (PREFIX ("kill_i%d_sub"), kind);
2784 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2789 gfc_resolve_link_sub (gfc_code *c)
2794 if (c->ext.actual->next->next->expr != NULL)
2795 kind = c->ext.actual->next->next->expr->ts.kind;
2797 kind = gfc_default_integer_kind;
2799 name = gfc_get_string (PREFIX ("link_i%d_sub"), kind);
2800 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2805 gfc_resolve_symlnk_sub (gfc_code *c)
2810 if (c->ext.actual->next->next->expr != NULL)
2811 kind = c->ext.actual->next->next->expr->ts.kind;
2813 kind = gfc_default_integer_kind;
2815 name = gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind);
2816 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2820 /* G77 compatibility subroutines dtime() and etime(). */
2823 gfc_resolve_dtime_sub (gfc_code *c)
2826 name = gfc_get_string (PREFIX ("dtime_sub"));
2827 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2831 gfc_resolve_etime_sub (gfc_code *c)
2834 name = gfc_get_string (PREFIX ("etime_sub"));
2835 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2839 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
2842 gfc_resolve_itime (gfc_code *c)
2845 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
2846 gfc_default_integer_kind));
2850 gfc_resolve_idate (gfc_code *c)
2853 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
2854 gfc_default_integer_kind));
2858 gfc_resolve_ltime (gfc_code *c)
2861 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
2862 gfc_default_integer_kind));
2866 gfc_resolve_gmtime (gfc_code *c)
2869 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
2870 gfc_default_integer_kind));
2874 /* G77 compatibility subroutine second(). */
2877 gfc_resolve_second_sub (gfc_code *c)
2880 name = gfc_get_string (PREFIX ("second_sub"));
2881 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2886 gfc_resolve_sleep_sub (gfc_code *c)
2891 if (c->ext.actual->expr != NULL)
2892 kind = c->ext.actual->expr->ts.kind;
2894 kind = gfc_default_integer_kind;
2896 name = gfc_get_string (PREFIX ("sleep_i%d_sub"), kind);
2897 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2901 /* G77 compatibility function srand(). */
2904 gfc_resolve_srand (gfc_code *c)
2907 name = gfc_get_string (PREFIX ("srand"));
2908 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2912 /* Resolve the getarg intrinsic subroutine. */
2915 gfc_resolve_getarg (gfc_code *c)
2919 if (c->ext.actual->expr->ts.kind != gfc_default_integer_kind)
2924 ts.type = BT_INTEGER;
2925 ts.kind = gfc_default_integer_kind;
2927 gfc_convert_type (c->ext.actual->expr, &ts, 2);
2930 name = gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind);
2931 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2935 /* Resolve the getcwd intrinsic subroutine. */
2938 gfc_resolve_getcwd_sub (gfc_code *c)
2943 if (c->ext.actual->next->expr != NULL)
2944 kind = c->ext.actual->next->expr->ts.kind;
2946 kind = gfc_default_integer_kind;
2948 name = gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind);
2949 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2953 /* Resolve the get_command intrinsic subroutine. */
2956 gfc_resolve_get_command (gfc_code *c)
2960 kind = gfc_default_integer_kind;
2961 name = gfc_get_string (PREFIX ("get_command_i%d"), kind);
2962 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2966 /* Resolve the get_command_argument intrinsic subroutine. */
2969 gfc_resolve_get_command_argument (gfc_code *c)
2973 kind = gfc_default_integer_kind;
2974 name = gfc_get_string (PREFIX ("get_command_argument_i%d"), kind);
2975 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2979 /* Resolve the get_environment_variable intrinsic subroutine. */
2982 gfc_resolve_get_environment_variable (gfc_code *code)
2986 kind = gfc_default_integer_kind;
2987 name = gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind);
2988 code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2993 gfc_resolve_signal_sub (gfc_code *c)
2996 gfc_expr *number, *handler, *status;
3000 number = c->ext.actual->expr;
3001 handler = c->ext.actual->next->expr;
3002 status = c->ext.actual->next->next->expr;
3003 ts.type = BT_INTEGER;
3004 ts.kind = gfc_c_int_kind;
3006 /* handler can be either BT_INTEGER or BT_PROCEDURE */
3007 if (handler->ts.type == BT_INTEGER)
3009 if (handler->ts.kind != gfc_c_int_kind)
3010 gfc_convert_type (handler, &ts, 2);
3011 name = gfc_get_string (PREFIX ("signal_sub_int"));
3014 name = gfc_get_string (PREFIX ("signal_sub"));
3016 if (number->ts.kind != gfc_c_int_kind)
3017 gfc_convert_type (number, &ts, 2);
3018 if (status != NULL && status->ts.kind != gfc_c_int_kind)
3019 gfc_convert_type (status, &ts, 2);
3021 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3025 /* Resolve the SYSTEM intrinsic subroutine. */
3028 gfc_resolve_system_sub (gfc_code *c)
3031 name = gfc_get_string (PREFIX ("system_sub"));
3032 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3036 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
3039 gfc_resolve_system_clock (gfc_code *c)
3044 if (c->ext.actual->expr != NULL)
3045 kind = c->ext.actual->expr->ts.kind;
3046 else if (c->ext.actual->next->expr != NULL)
3047 kind = c->ext.actual->next->expr->ts.kind;
3048 else if (c->ext.actual->next->next->expr != NULL)
3049 kind = c->ext.actual->next->next->expr->ts.kind;
3051 kind = gfc_default_integer_kind;
3053 name = gfc_get_string (PREFIX ("system_clock_%d"), kind);
3054 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3058 /* Resolve the EXIT intrinsic subroutine. */
3061 gfc_resolve_exit (gfc_code *c)
3068 /* The STATUS argument has to be of default kind. If it is not,
3070 ts.type = BT_INTEGER;
3071 ts.kind = gfc_default_integer_kind;
3072 n = c->ext.actual->expr;
3073 if (n != NULL && n->ts.kind != ts.kind)
3074 gfc_convert_type (n, &ts, 2);
3076 name = gfc_get_string (PREFIX ("exit_i%d"), ts.kind);
3077 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3081 /* Resolve the FLUSH intrinsic subroutine. */
3084 gfc_resolve_flush (gfc_code *c)
3091 ts.type = BT_INTEGER;
3092 ts.kind = gfc_default_integer_kind;
3093 n = c->ext.actual->expr;
3094 if (n != NULL && n->ts.kind != ts.kind)
3095 gfc_convert_type (n, &ts, 2);
3097 name = gfc_get_string (PREFIX ("flush_i%d"), ts.kind);
3098 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3103 gfc_resolve_free (gfc_code *c)
3109 ts.type = BT_INTEGER;
3110 ts.kind = gfc_index_integer_kind;
3111 n = c->ext.actual->expr;
3112 if (n->ts.kind != ts.kind)
3113 gfc_convert_type (n, &ts, 2);
3115 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("free"));
3120 gfc_resolve_ctime_sub (gfc_code *c)
3125 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3126 if (c->ext.actual->expr->ts.kind != 8)
3128 ts.type = BT_INTEGER;
3130 ts.u.derived = NULL;
3132 gfc_convert_type (c->ext.actual->expr, &ts, 2);
3135 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3140 gfc_resolve_fdate_sub (gfc_code *c)
3142 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3147 gfc_resolve_gerror (gfc_code *c)
3149 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3154 gfc_resolve_getlog (gfc_code *c)
3156 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3161 gfc_resolve_hostnm_sub (gfc_code *c)
3166 if (c->ext.actual->next->expr != NULL)
3167 kind = c->ext.actual->next->expr->ts.kind;
3169 kind = gfc_default_integer_kind;
3171 name = gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind);
3172 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3177 gfc_resolve_perror (gfc_code *c)
3179 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3182 /* Resolve the STAT and FSTAT intrinsic subroutines. */
3185 gfc_resolve_stat_sub (gfc_code *c)
3188 name = gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind);
3189 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3194 gfc_resolve_lstat_sub (gfc_code *c)
3197 name = gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind);
3198 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3203 gfc_resolve_fstat_sub (gfc_code *c)
3209 u = c->ext.actual->expr;
3210 ts = &c->ext.actual->next->expr->ts;
3211 if (u->ts.kind != ts->kind)
3212 gfc_convert_type (u, ts, 2);
3213 name = gfc_get_string (PREFIX ("fstat_i%d_sub"), ts->kind);
3214 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3219 gfc_resolve_fgetc_sub (gfc_code *c)
3226 u = c->ext.actual->expr;
3227 st = c->ext.actual->next->next->expr;
3229 if (u->ts.kind != gfc_c_int_kind)
3231 ts.type = BT_INTEGER;
3232 ts.kind = gfc_c_int_kind;
3233 ts.u.derived = NULL;
3235 gfc_convert_type (u, &ts, 2);
3239 name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), st->ts.kind);
3241 name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind);
3243 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3248 gfc_resolve_fget_sub (gfc_code *c)
3253 st = c->ext.actual->next->expr;
3255 name = gfc_get_string (PREFIX ("fget_i%d_sub"), st->ts.kind);
3257 name = gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind);
3259 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3264 gfc_resolve_fputc_sub (gfc_code *c)
3271 u = c->ext.actual->expr;
3272 st = c->ext.actual->next->next->expr;
3274 if (u->ts.kind != gfc_c_int_kind)
3276 ts.type = BT_INTEGER;
3277 ts.kind = gfc_c_int_kind;
3278 ts.u.derived = NULL;
3280 gfc_convert_type (u, &ts, 2);
3284 name = gfc_get_string (PREFIX ("fputc_i%d_sub"), st->ts.kind);
3286 name = gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind);
3288 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3293 gfc_resolve_fput_sub (gfc_code *c)
3298 st = c->ext.actual->next->expr;
3300 name = gfc_get_string (PREFIX ("fput_i%d_sub"), st->ts.kind);
3302 name = gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind);
3304 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3309 gfc_resolve_fseek_sub (gfc_code *c)
3317 unit = c->ext.actual->expr;
3318 offset = c->ext.actual->next->expr;
3319 whence = c->ext.actual->next->next->expr;
3321 if (unit->ts.kind != gfc_c_int_kind)
3323 ts.type = BT_INTEGER;
3324 ts.kind = gfc_c_int_kind;
3325 ts.u.derived = NULL;
3327 gfc_convert_type (unit, &ts, 2);
3330 if (offset->ts.kind != gfc_intio_kind)
3332 ts.type = BT_INTEGER;
3333 ts.kind = gfc_intio_kind;
3334 ts.u.derived = NULL;
3336 gfc_convert_type (offset, &ts, 2);
3339 if (whence->ts.kind != gfc_c_int_kind)
3341 ts.type = BT_INTEGER;
3342 ts.kind = gfc_c_int_kind;
3343 ts.u.derived = NULL;
3345 gfc_convert_type (whence, &ts, 2);
3348 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
3352 gfc_resolve_ftell_sub (gfc_code *c)
3360 unit = c->ext.actual->expr;
3361 offset = c->ext.actual->next->expr;
3363 if (unit->ts.kind != gfc_c_int_kind)
3365 ts.type = BT_INTEGER;
3366 ts.kind = gfc_c_int_kind;
3367 ts.u.derived = NULL;
3369 gfc_convert_type (unit, &ts, 2);
3372 name = gfc_get_string (PREFIX ("ftell_i%d_sub"), offset->ts.kind);
3373 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3378 gfc_resolve_ttynam_sub (gfc_code *c)
3383 if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
3385 ts.type = BT_INTEGER;
3386 ts.kind = gfc_c_int_kind;
3387 ts.u.derived = NULL;
3389 gfc_convert_type (c->ext.actual->expr, &ts, 2);
3392 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
3396 /* Resolve the UMASK intrinsic subroutine. */
3399 gfc_resolve_umask_sub (gfc_code *c)
3404 if (c->ext.actual->next->expr != NULL)
3405 kind = c->ext.actual->next->expr->ts.kind;
3407 kind = gfc_default_integer_kind;
3409 name = gfc_get_string (PREFIX ("umask_i%d_sub"), kind);
3410 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3413 /* Resolve the UNLINK intrinsic subroutine. */
3416 gfc_resolve_unlink_sub (gfc_code *c)
3421 if (c->ext.actual->next->expr != NULL)
3422 kind = c->ext.actual->next->expr->ts.kind;
3424 kind = gfc_default_integer_kind;
3426 name = gfc_get_string (PREFIX ("unlink_i%d_sub"), kind);
3427 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);