1 /* Intrinsic function resolution.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
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->expr_type == EXPR_CONSTANT && source->ts.cl == NULL)
67 source->ts.cl = gfc_get_charlen ();
68 source->ts.cl->next = gfc_current_ns->cl_list;
69 gfc_current_ns->cl_list = source->ts.cl;
70 source->ts.cl->length = gfc_int_expr (source->value.character.length);
75 /* Helper function for resolving the "mask" argument. */
78 resolve_mask_arg (gfc_expr *mask)
85 /* For the scalar case, coerce the mask to kind=4 unconditionally
86 (because this is the only kind we have a library function
89 if (mask->ts.kind != 4)
93 gfc_convert_type (mask, &ts, 2);
98 /* In the library, we access the mask with a GFC_LOGICAL_1
99 argument. No need to waste memory if we are about to create
100 a temporary array. */
101 if (mask->expr_type == EXPR_OP)
103 ts.type = BT_LOGICAL;
105 gfc_convert_type (mask, &ts, 2);
110 /********************** Resolution functions **********************/
114 gfc_resolve_abs (gfc_expr *f, gfc_expr *a)
117 if (f->ts.type == BT_COMPLEX)
118 f->ts.type = BT_REAL;
120 f->value.function.name
121 = gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
126 gfc_resolve_access (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
127 gfc_expr *mode ATTRIBUTE_UNUSED)
129 f->ts.type = BT_INTEGER;
130 f->ts.kind = gfc_c_int_kind;
131 f->value.function.name = PREFIX ("access_func");
136 gfc_resolve_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind)
138 f->ts.type = BT_CHARACTER;
139 f->ts.kind = (kind == NULL)
140 ? gfc_default_character_kind : mpz_get_si (kind->value.integer);
141 f->ts.cl = gfc_get_charlen ();
142 f->ts.cl->next = gfc_current_ns->cl_list;
143 gfc_current_ns->cl_list = f->ts.cl;
144 f->ts.cl->length = gfc_int_expr (1);
146 f->value.function.name = gfc_get_string ("__achar_%d_%c%d", f->ts.kind,
147 gfc_type_letter (x->ts.type),
153 gfc_resolve_acos (gfc_expr *f, gfc_expr *x)
156 f->value.function.name
157 = gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
162 gfc_resolve_acosh (gfc_expr *f, gfc_expr *x)
165 f->value.function.name
166 = gfc_get_string ("__acosh_%c%d", gfc_type_letter (x->ts.type),
172 gfc_resolve_aimag (gfc_expr *f, gfc_expr *x)
174 f->ts.type = BT_REAL;
175 f->ts.kind = x->ts.kind;
176 f->value.function.name
177 = gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type),
183 gfc_resolve_and (gfc_expr *f, gfc_expr *i, gfc_expr *j)
185 f->ts.type = i->ts.type;
186 f->ts.kind = gfc_kind_max (i, j);
188 if (i->ts.kind != j->ts.kind)
190 if (i->ts.kind == gfc_kind_max (i, j))
191 gfc_convert_type (j, &i->ts, 2);
193 gfc_convert_type (i, &j->ts, 2);
196 f->value.function.name
197 = gfc_get_string ("__and_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
202 gfc_resolve_aint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
206 f->ts.type = a->ts.type;
207 f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
209 if (a->ts.kind != f->ts.kind)
211 ts.type = f->ts.type;
212 ts.kind = f->ts.kind;
213 gfc_convert_type (a, &ts, 2);
215 /* The resolved name is only used for specific intrinsics where
216 the return kind is the same as the arg kind. */
217 f->value.function.name
218 = gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
223 gfc_resolve_dint (gfc_expr *f, gfc_expr *a)
225 gfc_resolve_aint (f, a, NULL);
230 gfc_resolve_all (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
236 gfc_resolve_dim_arg (dim);
237 f->rank = mask->rank - 1;
238 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
241 f->value.function.name
242 = gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask->ts.type),
248 gfc_resolve_anint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
252 f->ts.type = a->ts.type;
253 f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
255 if (a->ts.kind != f->ts.kind)
257 ts.type = f->ts.type;
258 ts.kind = f->ts.kind;
259 gfc_convert_type (a, &ts, 2);
262 /* The resolved name is only used for specific intrinsics where
263 the return kind is the same as the arg kind. */
264 f->value.function.name
265 = gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type),
271 gfc_resolve_dnint (gfc_expr *f, gfc_expr *a)
273 gfc_resolve_anint (f, a, NULL);
278 gfc_resolve_any (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
284 gfc_resolve_dim_arg (dim);
285 f->rank = mask->rank - 1;
286 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
289 f->value.function.name
290 = gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask->ts.type),
296 gfc_resolve_asin (gfc_expr *f, gfc_expr *x)
299 f->value.function.name
300 = gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
304 gfc_resolve_asinh (gfc_expr *f, gfc_expr *x)
307 f->value.function.name
308 = gfc_get_string ("__asinh_%c%d", gfc_type_letter (x->ts.type),
313 gfc_resolve_atan (gfc_expr *f, gfc_expr *x)
316 f->value.function.name
317 = gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
321 gfc_resolve_atanh (gfc_expr *f, gfc_expr *x)
324 f->value.function.name
325 = gfc_get_string ("__atanh_%c%d", gfc_type_letter (x->ts.type),
330 gfc_resolve_atan2 (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
333 f->value.function.name
334 = gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type),
339 /* Resolve the BESYN and BESJN intrinsics. */
342 gfc_resolve_besn (gfc_expr *f, gfc_expr *n, gfc_expr *x)
347 if (n->ts.kind != gfc_c_int_kind)
349 ts.type = BT_INTEGER;
350 ts.kind = gfc_c_int_kind;
351 gfc_convert_type (n, &ts, 2);
353 f->value.function.name = gfc_get_string ("<intrinsic>");
358 gfc_resolve_btest (gfc_expr *f, gfc_expr *i, gfc_expr *pos)
360 f->ts.type = BT_LOGICAL;
361 f->ts.kind = gfc_default_logical_kind;
362 f->value.function.name
363 = gfc_get_string ("__btest_%d_%d", i->ts.kind, pos->ts.kind);
368 gfc_resolve_ceiling (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
370 f->ts.type = BT_INTEGER;
371 f->ts.kind = (kind == NULL)
372 ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
373 f->value.function.name
374 = gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind,
375 gfc_type_letter (a->ts.type), a->ts.kind);
380 gfc_resolve_char (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
382 f->ts.type = BT_CHARACTER;
383 f->ts.kind = (kind == NULL)
384 ? gfc_default_character_kind : mpz_get_si (kind->value.integer);
385 f->value.function.name
386 = gfc_get_string ("__char_%d_%c%d", f->ts.kind,
387 gfc_type_letter (a->ts.type), a->ts.kind);
392 gfc_resolve_chdir (gfc_expr *f, gfc_expr *d ATTRIBUTE_UNUSED)
394 f->ts.type = BT_INTEGER;
395 f->ts.kind = gfc_default_integer_kind;
396 f->value.function.name = gfc_get_string (PREFIX ("chdir_i%d"), f->ts.kind);
401 gfc_resolve_chdir_sub (gfc_code *c)
406 if (c->ext.actual->next->expr != NULL)
407 kind = c->ext.actual->next->expr->ts.kind;
409 kind = gfc_default_integer_kind;
411 name = gfc_get_string (PREFIX ("chdir_i%d_sub"), kind);
412 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
417 gfc_resolve_chmod (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
418 gfc_expr *mode ATTRIBUTE_UNUSED)
420 f->ts.type = BT_INTEGER;
421 f->ts.kind = gfc_c_int_kind;
422 f->value.function.name = PREFIX ("chmod_func");
427 gfc_resolve_chmod_sub (gfc_code *c)
432 if (c->ext.actual->next->next->expr != NULL)
433 kind = c->ext.actual->next->next->expr->ts.kind;
435 kind = gfc_default_integer_kind;
437 name = gfc_get_string (PREFIX ("chmod_i%d_sub"), kind);
438 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
443 gfc_resolve_cmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y, gfc_expr *kind)
445 f->ts.type = BT_COMPLEX;
446 f->ts.kind = (kind == NULL)
447 ? gfc_default_real_kind : mpz_get_si (kind->value.integer);
450 f->value.function.name
451 = gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind,
452 gfc_type_letter (x->ts.type), x->ts.kind);
454 f->value.function.name
455 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
456 gfc_type_letter (x->ts.type), x->ts.kind,
457 gfc_type_letter (y->ts.type), y->ts.kind);
462 gfc_resolve_dcmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y)
464 gfc_resolve_cmplx (f, x, y, gfc_int_expr (gfc_default_double_kind));
469 gfc_resolve_complex (gfc_expr *f, gfc_expr *x, gfc_expr *y)
473 if (x->ts.type == BT_INTEGER)
475 if (y->ts.type == BT_INTEGER)
476 kind = gfc_default_real_kind;
482 if (y->ts.type == BT_REAL)
483 kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
488 f->ts.type = BT_COMPLEX;
490 f->value.function.name
491 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
492 gfc_type_letter (x->ts.type), x->ts.kind,
493 gfc_type_letter (y->ts.type), y->ts.kind);
498 gfc_resolve_conjg (gfc_expr *f, gfc_expr *x)
501 f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind);
506 gfc_resolve_cos (gfc_expr *f, gfc_expr *x)
509 f->value.function.name
510 = gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
515 gfc_resolve_cosh (gfc_expr *f, gfc_expr *x)
518 f->value.function.name
519 = gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
524 gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
526 f->ts.type = BT_INTEGER;
528 f->ts.kind = mpz_get_si (kind->value.integer);
530 f->ts.kind = gfc_default_integer_kind;
534 f->rank = mask->rank - 1;
535 gfc_resolve_dim_arg (dim);
536 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
539 f->value.function.name
540 = gfc_get_string (PREFIX ("count_%d_%c%d"), f->ts.kind,
541 gfc_type_letter (mask->ts.type), mask->ts.kind);
546 gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
551 if (array->ts.type == BT_CHARACTER && array->ref)
552 gfc_resolve_substring_charlen (array);
555 f->rank = array->rank;
556 f->shape = gfc_copy_shape (array->shape, array->rank);
563 /* Convert shift to at least gfc_default_integer_kind, so we don't need
564 kind=1 and kind=2 versions of the library functions. */
565 if (shift->ts.kind < gfc_default_integer_kind)
568 ts.type = BT_INTEGER;
569 ts.kind = gfc_default_integer_kind;
570 gfc_convert_type_warn (shift, &ts, 2, 0);
575 gfc_resolve_dim_arg (dim);
576 /* Convert dim to shift's kind, so we don't need so many variations. */
577 if (dim->ts.kind != shift->ts.kind)
578 gfc_convert_type_warn (dim, &shift->ts, 2, 0);
580 f->value.function.name
581 = gfc_get_string (PREFIX ("cshift%d_%d%s"), n, shift->ts.kind,
582 array->ts.type == BT_CHARACTER ? "_char" : "");
587 gfc_resolve_ctime (gfc_expr *f, gfc_expr *time)
591 f->ts.type = BT_CHARACTER;
592 f->ts.kind = gfc_default_character_kind;
594 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
595 if (time->ts.kind != 8)
597 ts.type = BT_INTEGER;
601 gfc_convert_type (time, &ts, 2);
604 f->value.function.name = gfc_get_string (PREFIX ("ctime"));
609 gfc_resolve_dble (gfc_expr *f, gfc_expr *a)
611 f->ts.type = BT_REAL;
612 f->ts.kind = gfc_default_double_kind;
613 f->value.function.name
614 = gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
619 gfc_resolve_dim (gfc_expr *f, gfc_expr *a, gfc_expr *p)
621 f->ts.type = a->ts.type;
623 f->ts.kind = gfc_kind_max (a,p);
625 f->ts.kind = a->ts.kind;
627 if (p != NULL && a->ts.kind != p->ts.kind)
629 if (a->ts.kind == gfc_kind_max (a,p))
630 gfc_convert_type (p, &a->ts, 2);
632 gfc_convert_type (a, &p->ts, 2);
635 f->value.function.name
636 = gfc_get_string ("__dim_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
641 gfc_resolve_dot_product (gfc_expr *f, gfc_expr *a, gfc_expr *b)
645 temp.expr_type = EXPR_OP;
646 gfc_clear_ts (&temp.ts);
647 temp.value.op.operator = INTRINSIC_NONE;
648 temp.value.op.op1 = a;
649 temp.value.op.op2 = b;
650 gfc_type_convert_binary (&temp);
652 f->value.function.name
653 = gfc_get_string (PREFIX ("dot_product_%c%d"),
654 gfc_type_letter (f->ts.type), f->ts.kind);
659 gfc_resolve_dprod (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
660 gfc_expr *b ATTRIBUTE_UNUSED)
662 f->ts.kind = gfc_default_double_kind;
663 f->ts.type = BT_REAL;
664 f->value.function.name = gfc_get_string ("__dprod_r%d", f->ts.kind);
669 gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
670 gfc_expr *boundary, gfc_expr *dim)
674 if (array->ts.type == BT_CHARACTER && array->ref)
675 gfc_resolve_substring_charlen (array);
678 f->rank = array->rank;
679 f->shape = gfc_copy_shape (array->shape, array->rank);
684 if (boundary && boundary->rank > 0)
687 /* Convert shift to at least gfc_default_integer_kind, so we don't need
688 kind=1 and kind=2 versions of the library functions. */
689 if (shift->ts.kind < gfc_default_integer_kind)
692 ts.type = BT_INTEGER;
693 ts.kind = gfc_default_integer_kind;
694 gfc_convert_type_warn (shift, &ts, 2, 0);
699 gfc_resolve_dim_arg (dim);
700 /* Convert dim to shift's kind, so we don't need so many variations. */
701 if (dim->ts.kind != shift->ts.kind)
702 gfc_convert_type_warn (dim, &shift->ts, 2, 0);
705 f->value.function.name
706 = gfc_get_string (PREFIX ("eoshift%d_%d%s"), n, shift->ts.kind,
707 array->ts.type == BT_CHARACTER ? "_char" : "");
712 gfc_resolve_exp (gfc_expr *f, gfc_expr *x)
715 f->value.function.name
716 = gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
721 gfc_resolve_exponent (gfc_expr *f, gfc_expr *x)
723 f->ts.type = BT_INTEGER;
724 f->ts.kind = gfc_default_integer_kind;
725 f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind);
730 gfc_resolve_fdate (gfc_expr *f)
732 f->ts.type = BT_CHARACTER;
733 f->ts.kind = gfc_default_character_kind;
734 f->value.function.name = gfc_get_string (PREFIX ("fdate"));
739 gfc_resolve_floor (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
741 f->ts.type = BT_INTEGER;
742 f->ts.kind = (kind == NULL)
743 ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
744 f->value.function.name
745 = gfc_get_string ("__floor%d_%c%d", f->ts.kind,
746 gfc_type_letter (a->ts.type), a->ts.kind);
751 gfc_resolve_fnum (gfc_expr *f, gfc_expr *n)
753 f->ts.type = BT_INTEGER;
754 f->ts.kind = gfc_default_integer_kind;
755 if (n->ts.kind != f->ts.kind)
756 gfc_convert_type (n, &f->ts, 2);
757 f->value.function.name = gfc_get_string (PREFIX ("fnum_i%d"), f->ts.kind);
762 gfc_resolve_fraction (gfc_expr *f, gfc_expr *x)
765 f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind);
769 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
772 gfc_resolve_g77_math1 (gfc_expr *f, gfc_expr *x)
775 f->value.function.name = gfc_get_string ("<intrinsic>");
780 gfc_resolve_gamma (gfc_expr *f, gfc_expr *x)
783 f->value.function.name
784 = gfc_get_string ("__gamma_%d", x->ts.kind);
789 gfc_resolve_getcwd (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
791 f->ts.type = BT_INTEGER;
793 f->value.function.name = gfc_get_string (PREFIX ("getcwd"));
798 gfc_resolve_getgid (gfc_expr *f)
800 f->ts.type = BT_INTEGER;
802 f->value.function.name = gfc_get_string (PREFIX ("getgid"));
807 gfc_resolve_getpid (gfc_expr *f)
809 f->ts.type = BT_INTEGER;
811 f->value.function.name = gfc_get_string (PREFIX ("getpid"));
816 gfc_resolve_getuid (gfc_expr *f)
818 f->ts.type = BT_INTEGER;
820 f->value.function.name = gfc_get_string (PREFIX ("getuid"));
825 gfc_resolve_hostnm (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
827 f->ts.type = BT_INTEGER;
829 f->value.function.name = gfc_get_string (PREFIX ("hostnm"));
834 gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j)
836 /* If the kind of i and j are different, then g77 cross-promoted the
837 kinds to the largest value. The Fortran 95 standard requires the
839 if (i->ts.kind != j->ts.kind)
841 if (i->ts.kind == gfc_kind_max (i, j))
842 gfc_convert_type (j, &i->ts, 2);
844 gfc_convert_type (i, &j->ts, 2);
848 f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind);
853 gfc_resolve_ibclr (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
856 f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind);
861 gfc_resolve_ibits (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED,
862 gfc_expr *len ATTRIBUTE_UNUSED)
865 f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind);
870 gfc_resolve_ibset (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
873 f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind);
878 gfc_resolve_iachar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
880 f->ts.type = BT_INTEGER;
882 f->ts.kind = mpz_get_si (kind->value.integer);
884 f->ts.kind = gfc_default_integer_kind;
885 f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
890 gfc_resolve_ichar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
892 f->ts.type = BT_INTEGER;
894 f->ts.kind = mpz_get_si (kind->value.integer);
896 f->ts.kind = gfc_default_integer_kind;
897 f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
902 gfc_resolve_idnint (gfc_expr *f, gfc_expr *a)
904 gfc_resolve_nint (f, a, NULL);
909 gfc_resolve_ierrno (gfc_expr *f)
911 f->ts.type = BT_INTEGER;
912 f->ts.kind = gfc_default_integer_kind;
913 f->value.function.name = gfc_get_string (PREFIX ("ierrno_i%d"), f->ts.kind);
918 gfc_resolve_ieor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
920 /* If the kind of i and j are different, then g77 cross-promoted the
921 kinds to the largest value. The Fortran 95 standard requires the
923 if (i->ts.kind != j->ts.kind)
925 if (i->ts.kind == gfc_kind_max (i, j))
926 gfc_convert_type (j, &i->ts, 2);
928 gfc_convert_type (i, &j->ts, 2);
932 f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind);
937 gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j)
939 /* If the kind of i and j are different, then g77 cross-promoted the
940 kinds to the largest value. The Fortran 95 standard requires the
942 if (i->ts.kind != j->ts.kind)
944 if (i->ts.kind == gfc_kind_max (i, j))
945 gfc_convert_type (j, &i->ts, 2);
947 gfc_convert_type (i, &j->ts, 2);
951 f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind);
956 gfc_resolve_index_func (gfc_expr *f, gfc_expr *str,
957 gfc_expr *sub_str ATTRIBUTE_UNUSED, gfc_expr *back,
962 f->ts.type = BT_INTEGER;
964 f->ts.kind = mpz_get_si (kind->value.integer);
966 f->ts.kind = gfc_default_integer_kind;
968 if (back && back->ts.kind != gfc_default_integer_kind)
970 ts.type = BT_LOGICAL;
971 ts.kind = gfc_default_integer_kind;
974 gfc_convert_type (back, &ts, 2);
977 f->value.function.name
978 = gfc_get_string ("__index_%d_i%d", str->ts.kind, f->ts.kind);
983 gfc_resolve_int (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
985 f->ts.type = BT_INTEGER;
986 f->ts.kind = (kind == NULL)
987 ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
988 f->value.function.name
989 = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
990 gfc_type_letter (a->ts.type), a->ts.kind);
995 gfc_resolve_int2 (gfc_expr *f, gfc_expr *a)
997 f->ts.type = BT_INTEGER;
999 f->value.function.name
1000 = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1001 gfc_type_letter (a->ts.type), a->ts.kind);
1006 gfc_resolve_int8 (gfc_expr *f, gfc_expr *a)
1008 f->ts.type = BT_INTEGER;
1010 f->value.function.name
1011 = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1012 gfc_type_letter (a->ts.type), a->ts.kind);
1017 gfc_resolve_long (gfc_expr *f, gfc_expr *a)
1019 f->ts.type = BT_INTEGER;
1021 f->value.function.name
1022 = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1023 gfc_type_letter (a->ts.type), a->ts.kind);
1028 gfc_resolve_isatty (gfc_expr *f, gfc_expr *u)
1032 f->ts.type = BT_LOGICAL;
1033 f->ts.kind = gfc_default_integer_kind;
1034 if (u->ts.kind != gfc_c_int_kind)
1036 ts.type = BT_INTEGER;
1037 ts.kind = gfc_c_int_kind;
1040 gfc_convert_type (u, &ts, 2);
1043 f->value.function.name = gfc_get_string (PREFIX ("isatty_l%d"), f->ts.kind);
1048 gfc_resolve_ishft (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1051 f->value.function.name
1052 = gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
1057 gfc_resolve_rshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1060 f->value.function.name
1061 = gfc_get_string ("__rshift_%d_%d", i->ts.kind, shift->ts.kind);
1066 gfc_resolve_lshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1069 f->value.function.name
1070 = gfc_get_string ("__lshift_%d_%d", i->ts.kind, shift->ts.kind);
1075 gfc_resolve_ishftc (gfc_expr *f, gfc_expr *i, gfc_expr *shift, gfc_expr *size)
1079 s_kind = (size == NULL) ? gfc_default_integer_kind : size->ts.kind;
1082 f->value.function.name
1083 = gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
1088 gfc_resolve_kill (gfc_expr *f, gfc_expr *p ATTRIBUTE_UNUSED,
1089 gfc_expr *s ATTRIBUTE_UNUSED)
1091 f->ts.type = BT_INTEGER;
1092 f->ts.kind = gfc_default_integer_kind;
1093 f->value.function.name = gfc_get_string (PREFIX ("kill_i%d"), f->ts.kind);
1098 gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
1100 static char lbound[] = "__lbound";
1102 f->ts.type = BT_INTEGER;
1104 f->ts.kind = mpz_get_si (kind->value.integer);
1106 f->ts.kind = gfc_default_integer_kind;
1111 f->shape = gfc_get_shape (1);
1112 mpz_init_set_ui (f->shape[0], array->rank);
1115 f->value.function.name = lbound;
1120 gfc_resolve_len (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
1122 f->ts.type = BT_INTEGER;
1124 f->ts.kind = mpz_get_si (kind->value.integer);
1126 f->ts.kind = gfc_default_integer_kind;
1127 f->value.function.name
1128 = gfc_get_string ("__len_%d_i%d", string->ts.kind,
1129 gfc_default_integer_kind);
1134 gfc_resolve_len_trim (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
1136 f->ts.type = BT_INTEGER;
1138 f->ts.kind = mpz_get_si (kind->value.integer);
1140 f->ts.kind = gfc_default_integer_kind;
1141 f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
1146 gfc_resolve_lgamma (gfc_expr *f, gfc_expr *x)
1149 f->value.function.name
1150 = gfc_get_string ("__lgamma_%d", x->ts.kind);
1155 gfc_resolve_link (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
1156 gfc_expr *p2 ATTRIBUTE_UNUSED)
1158 f->ts.type = BT_INTEGER;
1159 f->ts.kind = gfc_default_integer_kind;
1160 f->value.function.name = gfc_get_string (PREFIX ("link_i%d"), f->ts.kind);
1165 gfc_resolve_loc (gfc_expr *f, gfc_expr *x)
1167 f->ts.type= BT_INTEGER;
1168 f->ts.kind = gfc_index_integer_kind;
1169 f->value.function.name = gfc_get_string ("__loc_%d", x->ts.kind);
1174 gfc_resolve_log (gfc_expr *f, gfc_expr *x)
1177 f->value.function.name
1178 = gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1183 gfc_resolve_log10 (gfc_expr *f, gfc_expr *x)
1186 f->value.function.name
1187 = gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type),
1193 gfc_resolve_logical (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1195 f->ts.type = BT_LOGICAL;
1196 f->ts.kind = (kind == NULL)
1197 ? gfc_default_logical_kind : mpz_get_si (kind->value.integer);
1200 f->value.function.name
1201 = gfc_get_string ("__logical_%d_%c%d", f->ts.kind,
1202 gfc_type_letter (a->ts.type), a->ts.kind);
1207 gfc_resolve_malloc (gfc_expr *f, gfc_expr *size)
1209 if (size->ts.kind < gfc_index_integer_kind)
1213 ts.type = BT_INTEGER;
1214 ts.kind = gfc_index_integer_kind;
1215 gfc_convert_type_warn (size, &ts, 2, 0);
1218 f->ts.type = BT_INTEGER;
1219 f->ts.kind = gfc_index_integer_kind;
1220 f->value.function.name = gfc_get_string (PREFIX ("malloc"));
1225 gfc_resolve_matmul (gfc_expr *f, gfc_expr *a, gfc_expr *b)
1229 if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
1231 f->ts.type = BT_LOGICAL;
1232 f->ts.kind = gfc_default_logical_kind;
1236 temp.expr_type = EXPR_OP;
1237 gfc_clear_ts (&temp.ts);
1238 temp.value.op.operator = INTRINSIC_NONE;
1239 temp.value.op.op1 = a;
1240 temp.value.op.op2 = b;
1241 gfc_type_convert_binary (&temp);
1245 f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
1247 f->value.function.name
1248 = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f->ts.type),
1254 gfc_resolve_minmax (const char *name, gfc_expr *f, gfc_actual_arglist *args)
1256 gfc_actual_arglist *a;
1258 f->ts.type = args->expr->ts.type;
1259 f->ts.kind = args->expr->ts.kind;
1260 /* Find the largest type kind. */
1261 for (a = args->next; a; a = a->next)
1263 if (a->expr->ts.kind > f->ts.kind)
1264 f->ts.kind = a->expr->ts.kind;
1267 /* Convert all parameters to the required kind. */
1268 for (a = args; a; a = a->next)
1270 if (a->expr->ts.kind != f->ts.kind)
1271 gfc_convert_type (a->expr, &f->ts, 2);
1274 f->value.function.name
1275 = gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind);
1280 gfc_resolve_max (gfc_expr *f, gfc_actual_arglist *args)
1282 gfc_resolve_minmax ("__max_%c%d", f, args);
1287 gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1293 f->ts.type = BT_INTEGER;
1294 f->ts.kind = gfc_default_integer_kind;
1299 f->shape = gfc_get_shape (1);
1300 mpz_init_set_si (f->shape[0], array->rank);
1304 f->rank = array->rank - 1;
1305 gfc_resolve_dim_arg (dim);
1306 if (array->shape && dim->expr_type == EXPR_CONSTANT)
1308 idim = (int) mpz_get_si (dim->value.integer);
1309 f->shape = gfc_get_shape (f->rank);
1310 for (i = 0, j = 0; i < f->rank; i++, j++)
1312 if (i == (idim - 1))
1314 mpz_init_set (f->shape[i], array->shape[j]);
1321 if (mask->rank == 0)
1326 resolve_mask_arg (mask);
1331 f->value.function.name
1332 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1333 gfc_type_letter (array->ts.type), array->ts.kind);
1338 gfc_resolve_maxval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1348 f->rank = array->rank - 1;
1349 gfc_resolve_dim_arg (dim);
1351 if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
1353 idim = (int) mpz_get_si (dim->value.integer);
1354 f->shape = gfc_get_shape (f->rank);
1355 for (i = 0, j = 0; i < f->rank; i++, j++)
1357 if (i == (idim - 1))
1359 mpz_init_set (f->shape[i], array->shape[j]);
1366 if (mask->rank == 0)
1371 resolve_mask_arg (mask);
1376 f->value.function.name
1377 = gfc_get_string (PREFIX ("%s_%c%d"), name,
1378 gfc_type_letter (array->ts.type), array->ts.kind);
1383 gfc_resolve_mclock (gfc_expr *f)
1385 f->ts.type = BT_INTEGER;
1387 f->value.function.name = PREFIX ("mclock");
1392 gfc_resolve_mclock8 (gfc_expr *f)
1394 f->ts.type = BT_INTEGER;
1396 f->value.function.name = PREFIX ("mclock8");
1401 gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource,
1402 gfc_expr *fsource ATTRIBUTE_UNUSED,
1403 gfc_expr *mask ATTRIBUTE_UNUSED)
1405 if (tsource->ts.type == BT_CHARACTER && tsource->ref)
1406 gfc_resolve_substring_charlen (tsource);
1408 if (fsource->ts.type == BT_CHARACTER && fsource->ref)
1409 gfc_resolve_substring_charlen (fsource);
1411 if (tsource->ts.type == BT_CHARACTER)
1412 check_charlen_present (tsource);
1414 f->ts = tsource->ts;
1415 f->value.function.name
1416 = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
1422 gfc_resolve_min (gfc_expr *f, gfc_actual_arglist *args)
1424 gfc_resolve_minmax ("__min_%c%d", f, args);
1429 gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1435 f->ts.type = BT_INTEGER;
1436 f->ts.kind = gfc_default_integer_kind;
1441 f->shape = gfc_get_shape (1);
1442 mpz_init_set_si (f->shape[0], array->rank);
1446 f->rank = array->rank - 1;
1447 gfc_resolve_dim_arg (dim);
1448 if (array->shape && dim->expr_type == EXPR_CONSTANT)
1450 idim = (int) mpz_get_si (dim->value.integer);
1451 f->shape = gfc_get_shape (f->rank);
1452 for (i = 0, j = 0; i < f->rank; i++, j++)
1454 if (i == (idim - 1))
1456 mpz_init_set (f->shape[i], array->shape[j]);
1463 if (mask->rank == 0)
1468 resolve_mask_arg (mask);
1473 f->value.function.name
1474 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1475 gfc_type_letter (array->ts.type), array->ts.kind);
1480 gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1490 f->rank = array->rank - 1;
1491 gfc_resolve_dim_arg (dim);
1493 if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
1495 idim = (int) mpz_get_si (dim->value.integer);
1496 f->shape = gfc_get_shape (f->rank);
1497 for (i = 0, j = 0; i < f->rank; i++, j++)
1499 if (i == (idim - 1))
1501 mpz_init_set (f->shape[i], array->shape[j]);
1508 if (mask->rank == 0)
1513 resolve_mask_arg (mask);
1518 f->value.function.name
1519 = gfc_get_string (PREFIX ("%s_%c%d"), name,
1520 gfc_type_letter (array->ts.type), array->ts.kind);
1525 gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p)
1527 f->ts.type = a->ts.type;
1529 f->ts.kind = gfc_kind_max (a,p);
1531 f->ts.kind = a->ts.kind;
1533 if (p != NULL && a->ts.kind != p->ts.kind)
1535 if (a->ts.kind == gfc_kind_max (a,p))
1536 gfc_convert_type (p, &a->ts, 2);
1538 gfc_convert_type (a, &p->ts, 2);
1541 f->value.function.name
1542 = gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
1547 gfc_resolve_modulo (gfc_expr *f, gfc_expr *a, gfc_expr *p)
1549 f->ts.type = a->ts.type;
1551 f->ts.kind = gfc_kind_max (a,p);
1553 f->ts.kind = a->ts.kind;
1555 if (p != NULL && a->ts.kind != p->ts.kind)
1557 if (a->ts.kind == gfc_kind_max (a,p))
1558 gfc_convert_type (p, &a->ts, 2);
1560 gfc_convert_type (a, &p->ts, 2);
1563 f->value.function.name
1564 = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type),
1569 gfc_resolve_nearest (gfc_expr *f, gfc_expr *a, gfc_expr *p ATTRIBUTE_UNUSED)
1572 f->value.function.name
1573 = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
1578 gfc_resolve_nint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1580 f->ts.type = BT_INTEGER;
1581 f->ts.kind = (kind == NULL)
1582 ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
1583 f->value.function.name
1584 = gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
1589 gfc_resolve_not (gfc_expr *f, gfc_expr *i)
1592 f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
1597 gfc_resolve_or (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1599 f->ts.type = i->ts.type;
1600 f->ts.kind = gfc_kind_max (i, j);
1602 if (i->ts.kind != j->ts.kind)
1604 if (i->ts.kind == gfc_kind_max (i, j))
1605 gfc_convert_type (j, &i->ts, 2);
1607 gfc_convert_type (i, &j->ts, 2);
1610 f->value.function.name
1611 = gfc_get_string ("__or_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
1616 gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
1617 gfc_expr *vector ATTRIBUTE_UNUSED)
1619 if (array->ts.type == BT_CHARACTER && array->ref)
1620 gfc_resolve_substring_charlen (array);
1625 resolve_mask_arg (mask);
1627 if (mask->rank != 0)
1628 f->value.function.name = (array->ts.type == BT_CHARACTER
1629 ? PREFIX ("pack_char") : PREFIX ("pack"));
1631 f->value.function.name = (array->ts.type == BT_CHARACTER
1632 ? PREFIX ("pack_s_char") : PREFIX ("pack_s"));
1637 gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1646 f->rank = array->rank - 1;
1647 gfc_resolve_dim_arg (dim);
1652 if (mask->rank == 0)
1657 resolve_mask_arg (mask);
1662 f->value.function.name
1663 = gfc_get_string (PREFIX ("%s_%c%d"), name,
1664 gfc_type_letter (array->ts.type), array->ts.kind);
1669 gfc_resolve_real (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1671 f->ts.type = BT_REAL;
1674 f->ts.kind = mpz_get_si (kind->value.integer);
1676 f->ts.kind = (a->ts.type == BT_COMPLEX)
1677 ? a->ts.kind : gfc_default_real_kind;
1679 f->value.function.name
1680 = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1681 gfc_type_letter (a->ts.type), a->ts.kind);
1686 gfc_resolve_realpart (gfc_expr *f, gfc_expr *a)
1688 f->ts.type = BT_REAL;
1689 f->ts.kind = a->ts.kind;
1690 f->value.function.name
1691 = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1692 gfc_type_letter (a->ts.type), a->ts.kind);
1697 gfc_resolve_rename (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
1698 gfc_expr *p2 ATTRIBUTE_UNUSED)
1700 f->ts.type = BT_INTEGER;
1701 f->ts.kind = gfc_default_integer_kind;
1702 f->value.function.name = gfc_get_string (PREFIX ("rename_i%d"), f->ts.kind);
1707 gfc_resolve_repeat (gfc_expr *f, gfc_expr *string,
1708 gfc_expr *ncopies ATTRIBUTE_UNUSED)
1710 f->ts.type = BT_CHARACTER;
1711 f->ts.kind = string->ts.kind;
1712 f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
1717 gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
1718 gfc_expr *pad ATTRIBUTE_UNUSED,
1719 gfc_expr *order ATTRIBUTE_UNUSED)
1725 if (source->ts.type == BT_CHARACTER && source->ref)
1726 gfc_resolve_substring_charlen (source);
1730 gfc_array_size (shape, &rank);
1731 f->rank = mpz_get_si (rank);
1733 switch (source->ts.type)
1739 kind = source->ts.kind;
1753 if (source->ts.type == BT_COMPLEX || source->ts.type == BT_REAL)
1754 f->value.function.name
1755 = gfc_get_string (PREFIX ("reshape_%c%d"),
1756 gfc_type_letter (source->ts.type),
1759 f->value.function.name
1760 = gfc_get_string (PREFIX ("reshape_%d"), source->ts.kind);
1765 f->value.function.name = (source->ts.type == BT_CHARACTER
1766 ? PREFIX ("reshape_char") : PREFIX ("reshape"));
1770 /* TODO: Make this work with a constant ORDER parameter. */
1771 if (shape->expr_type == EXPR_ARRAY
1772 && gfc_is_constant_expr (shape)
1776 f->shape = gfc_get_shape (f->rank);
1777 c = shape->value.constructor;
1778 for (i = 0; i < f->rank; i++)
1780 mpz_init_set (f->shape[i], c->expr->value.integer);
1785 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
1786 so many runtime variations. */
1787 if (shape->ts.kind != gfc_index_integer_kind)
1789 gfc_typespec ts = shape->ts;
1790 ts.kind = gfc_index_integer_kind;
1791 gfc_convert_type_warn (shape, &ts, 2, 0);
1793 if (order && order->ts.kind != gfc_index_integer_kind)
1794 gfc_convert_type_warn (order, &shape->ts, 2, 0);
1799 gfc_resolve_rrspacing (gfc_expr *f, gfc_expr *x)
1802 gfc_actual_arglist *prec;
1805 f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
1807 /* Create a hidden argument to the library routines for rrspacing. This
1808 hidden argument is the precision of x. */
1809 k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
1810 prec = gfc_get_actual_arglist ();
1812 prec->expr = gfc_int_expr (gfc_real_kinds[k].digits);
1813 /* The library routine expects INTEGER(4). */
1814 if (prec->expr->ts.kind != gfc_c_int_kind)
1817 ts.type = BT_INTEGER;
1818 ts.kind = gfc_c_int_kind;
1819 gfc_convert_type (prec->expr, &ts, 2);
1821 f->value.function.actual->next = prec;
1826 gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i)
1830 /* The implementation calls scalbn which takes an int as the
1832 if (i->ts.kind != gfc_c_int_kind)
1835 ts.type = BT_INTEGER;
1836 ts.kind = gfc_c_int_kind;
1837 gfc_convert_type_warn (i, &ts, 2, 0);
1840 f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
1845 gfc_resolve_scan (gfc_expr *f, gfc_expr *string,
1846 gfc_expr *set ATTRIBUTE_UNUSED,
1847 gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
1849 f->ts.type = BT_INTEGER;
1851 f->ts.kind = mpz_get_si (kind->value.integer);
1853 f->ts.kind = gfc_default_integer_kind;
1854 f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
1859 gfc_resolve_secnds (gfc_expr *t1, gfc_expr *t0)
1862 t1->value.function.name = gfc_get_string (PREFIX ("secnds"));
1867 gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x, gfc_expr *i)
1871 /* The library implementation uses GFC_INTEGER_4 unconditionally,
1872 convert type so we don't have to implement all possible
1874 if (i->ts.kind != gfc_c_int_kind)
1877 ts.type = BT_INTEGER;
1878 ts.kind = gfc_c_int_kind;
1879 gfc_convert_type_warn (i, &ts, 2, 0);
1882 f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
1887 gfc_resolve_shape (gfc_expr *f, gfc_expr *array)
1889 f->ts.type = BT_INTEGER;
1890 f->ts.kind = gfc_default_integer_kind;
1892 f->shape = gfc_get_shape (1);
1893 mpz_init_set_ui (f->shape[0], array->rank);
1894 f->value.function.name = gfc_get_string (PREFIX ("shape_%d"), f->ts.kind);
1899 gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b ATTRIBUTE_UNUSED)
1902 f->value.function.name
1903 = gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
1908 gfc_resolve_signal (gfc_expr *f, gfc_expr *number, gfc_expr *handler)
1910 f->ts.type = BT_INTEGER;
1911 f->ts.kind = gfc_c_int_kind;
1913 /* handler can be either BT_INTEGER or BT_PROCEDURE */
1914 if (handler->ts.type == BT_INTEGER)
1916 if (handler->ts.kind != gfc_c_int_kind)
1917 gfc_convert_type (handler, &f->ts, 2);
1918 f->value.function.name = gfc_get_string (PREFIX ("signal_func_int"));
1921 f->value.function.name = gfc_get_string (PREFIX ("signal_func"));
1923 if (number->ts.kind != gfc_c_int_kind)
1924 gfc_convert_type (number, &f->ts, 2);
1929 gfc_resolve_sin (gfc_expr *f, gfc_expr *x)
1932 f->value.function.name
1933 = gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1938 gfc_resolve_sinh (gfc_expr *f, gfc_expr *x)
1941 f->value.function.name
1942 = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1947 gfc_resolve_size (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
1948 gfc_expr *dim ATTRIBUTE_UNUSED, gfc_expr *kind)
1950 f->ts.type = BT_INTEGER;
1952 f->ts.kind = mpz_get_si (kind->value.integer);
1954 f->ts.kind = gfc_default_integer_kind;
1959 gfc_resolve_spacing (gfc_expr *f, gfc_expr *x)
1962 gfc_actual_arglist *prec, *tiny, *emin_1;
1965 f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
1967 /* Create hidden arguments to the library routine for spacing. These
1968 hidden arguments are tiny(x), min_exponent - 1, and the precision
1971 k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
1973 tiny = gfc_get_actual_arglist ();
1974 tiny->name = "tiny";
1975 tiny->expr = gfc_get_expr ();
1976 tiny->expr->expr_type = EXPR_CONSTANT;
1977 tiny->expr->where = gfc_current_locus;
1978 tiny->expr->ts.type = x->ts.type;
1979 tiny->expr->ts.kind = x->ts.kind;
1980 mpfr_init (tiny->expr->value.real);
1981 mpfr_set (tiny->expr->value.real, gfc_real_kinds[k].tiny, GFC_RND_MODE);
1983 emin_1 = gfc_get_actual_arglist ();
1984 emin_1->name = "emin";
1985 emin_1->expr = gfc_int_expr (gfc_real_kinds[k].min_exponent - 1);
1987 /* The library routine expects INTEGER(4). */
1988 if (emin_1->expr->ts.kind != gfc_c_int_kind)
1991 ts.type = BT_INTEGER;
1992 ts.kind = gfc_c_int_kind;
1993 gfc_convert_type (emin_1->expr, &ts, 2);
1995 emin_1->next = tiny;
1997 prec = gfc_get_actual_arglist ();
1998 prec->name = "prec";
1999 prec->expr = gfc_int_expr (gfc_real_kinds[k].digits);
2001 /* The library routine expects INTEGER(4). */
2002 if (prec->expr->ts.kind != gfc_c_int_kind)
2005 ts.type = BT_INTEGER;
2006 ts.kind = gfc_c_int_kind;
2007 gfc_convert_type (prec->expr, &ts, 2);
2009 prec->next = emin_1;
2011 f->value.function.actual->next = prec;
2016 gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim,
2019 if (source->ts.type == BT_CHARACTER && source->ref)
2020 gfc_resolve_substring_charlen (source);
2022 if (source->ts.type == BT_CHARACTER)
2023 check_charlen_present (source);
2026 f->rank = source->rank + 1;
2027 if (source->rank == 0)
2028 f->value.function.name = (source->ts.type == BT_CHARACTER
2029 ? PREFIX ("spread_char_scalar")
2030 : PREFIX ("spread_scalar"));
2032 f->value.function.name = (source->ts.type == BT_CHARACTER
2033 ? PREFIX ("spread_char")
2034 : PREFIX ("spread"));
2036 if (dim && gfc_is_constant_expr (dim)
2037 && ncopies && gfc_is_constant_expr (ncopies) && source->shape[0])
2040 idim = mpz_get_ui (dim->value.integer);
2041 f->shape = gfc_get_shape (f->rank);
2042 for (i = 0; i < (idim - 1); i++)
2043 mpz_init_set (f->shape[i], source->shape[i]);
2045 mpz_init_set (f->shape[idim - 1], ncopies->value.integer);
2047 for (i = idim; i < f->rank ; i++)
2048 mpz_init_set (f->shape[i], source->shape[i-1]);
2052 gfc_resolve_dim_arg (dim);
2053 gfc_resolve_index (ncopies, 1);
2058 gfc_resolve_sqrt (gfc_expr *f, gfc_expr *x)
2061 f->value.function.name
2062 = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2066 /* Resolve the g77 compatibility function STAT AND FSTAT. */
2069 gfc_resolve_stat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2070 gfc_expr *a ATTRIBUTE_UNUSED)
2072 f->ts.type = BT_INTEGER;
2073 f->ts.kind = gfc_default_integer_kind;
2074 f->value.function.name = gfc_get_string (PREFIX ("stat_i%d"), f->ts.kind);
2079 gfc_resolve_lstat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2080 gfc_expr *a ATTRIBUTE_UNUSED)
2082 f->ts.type = BT_INTEGER;
2083 f->ts.kind = gfc_default_integer_kind;
2084 f->value.function.name = gfc_get_string (PREFIX ("lstat_i%d"), f->ts.kind);
2089 gfc_resolve_fstat (gfc_expr *f, gfc_expr *n, gfc_expr *a ATTRIBUTE_UNUSED)
2091 f->ts.type = BT_INTEGER;
2092 f->ts.kind = gfc_default_integer_kind;
2093 if (n->ts.kind != f->ts.kind)
2094 gfc_convert_type (n, &f->ts, 2);
2096 f->value.function.name = gfc_get_string (PREFIX ("fstat_i%d"), f->ts.kind);
2101 gfc_resolve_fgetc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2105 f->ts.type = BT_INTEGER;
2106 f->ts.kind = gfc_c_int_kind;
2107 if (u->ts.kind != gfc_c_int_kind)
2109 ts.type = BT_INTEGER;
2110 ts.kind = gfc_c_int_kind;
2113 gfc_convert_type (u, &ts, 2);
2116 f->value.function.name = gfc_get_string (PREFIX ("fgetc"));
2121 gfc_resolve_fget (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2123 f->ts.type = BT_INTEGER;
2124 f->ts.kind = gfc_c_int_kind;
2125 f->value.function.name = gfc_get_string (PREFIX ("fget"));
2130 gfc_resolve_fputc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2134 f->ts.type = BT_INTEGER;
2135 f->ts.kind = gfc_c_int_kind;
2136 if (u->ts.kind != gfc_c_int_kind)
2138 ts.type = BT_INTEGER;
2139 ts.kind = gfc_c_int_kind;
2142 gfc_convert_type (u, &ts, 2);
2145 f->value.function.name = gfc_get_string (PREFIX ("fputc"));
2150 gfc_resolve_fput (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2152 f->ts.type = BT_INTEGER;
2153 f->ts.kind = gfc_c_int_kind;
2154 f->value.function.name = gfc_get_string (PREFIX ("fput"));
2159 gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
2163 f->ts.type = BT_INTEGER;
2164 f->ts.kind = gfc_index_integer_kind;
2165 if (u->ts.kind != gfc_c_int_kind)
2167 ts.type = BT_INTEGER;
2168 ts.kind = gfc_c_int_kind;
2171 gfc_convert_type (u, &ts, 2);
2174 f->value.function.name = gfc_get_string (PREFIX ("ftell"));
2179 gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
2187 if (mask->rank == 0)
2192 resolve_mask_arg (mask);
2199 f->rank = array->rank - 1;
2200 gfc_resolve_dim_arg (dim);
2203 f->value.function.name
2204 = gfc_get_string (PREFIX ("%s_%c%d"), name,
2205 gfc_type_letter (array->ts.type), array->ts.kind);
2210 gfc_resolve_symlnk (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
2211 gfc_expr *p2 ATTRIBUTE_UNUSED)
2213 f->ts.type = BT_INTEGER;
2214 f->ts.kind = gfc_default_integer_kind;
2215 f->value.function.name = gfc_get_string (PREFIX ("symlnk_i%d"), f->ts.kind);
2219 /* Resolve the g77 compatibility function SYSTEM. */
2222 gfc_resolve_system (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
2224 f->ts.type = BT_INTEGER;
2226 f->value.function.name = gfc_get_string (PREFIX ("system"));
2231 gfc_resolve_tan (gfc_expr *f, gfc_expr *x)
2234 f->value.function.name
2235 = gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2240 gfc_resolve_tanh (gfc_expr *f, gfc_expr *x)
2243 f->value.function.name
2244 = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2249 gfc_resolve_time (gfc_expr *f)
2251 f->ts.type = BT_INTEGER;
2253 f->value.function.name = gfc_get_string (PREFIX ("time_func"));
2258 gfc_resolve_time8 (gfc_expr *f)
2260 f->ts.type = BT_INTEGER;
2262 f->value.function.name = gfc_get_string (PREFIX ("time8_func"));
2267 gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
2268 gfc_expr *mold, gfc_expr *size)
2270 /* TODO: Make this do something meaningful. */
2271 static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
2275 if (size == NULL && mold->rank == 0)
2278 f->value.function.name = transfer0;
2283 f->value.function.name = transfer1;
2284 if (size && gfc_is_constant_expr (size))
2286 f->shape = gfc_get_shape (1);
2287 mpz_init_set (f->shape[0], size->value.integer);
2294 gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
2297 if (matrix->ts.type == BT_CHARACTER && matrix->ref)
2298 gfc_resolve_substring_charlen (matrix);
2304 f->shape = gfc_get_shape (2);
2305 mpz_init_set (f->shape[0], matrix->shape[1]);
2306 mpz_init_set (f->shape[1], matrix->shape[0]);
2309 switch (matrix->ts.kind)
2315 switch (matrix->ts.type)
2319 f->value.function.name
2320 = gfc_get_string (PREFIX ("transpose_%c%d"),
2321 gfc_type_letter (matrix->ts.type),
2327 /* Use the integer routines for real and logical cases. This
2328 assumes they all have the same alignment requirements. */
2329 f->value.function.name
2330 = gfc_get_string (PREFIX ("transpose_i%d"), matrix->ts.kind);
2334 f->value.function.name = PREFIX ("transpose");
2340 f->value.function.name = (matrix->ts.type == BT_CHARACTER
2341 ? PREFIX ("transpose_char")
2342 : PREFIX ("transpose"));
2349 gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
2351 f->ts.type = BT_CHARACTER;
2352 f->ts.kind = string->ts.kind;
2353 f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
2358 gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2360 static char ubound[] = "__ubound";
2362 f->ts.type = BT_INTEGER;
2364 f->ts.kind = mpz_get_si (kind->value.integer);
2366 f->ts.kind = gfc_default_integer_kind;
2371 f->shape = gfc_get_shape (1);
2372 mpz_init_set_ui (f->shape[0], array->rank);
2375 f->value.function.name = ubound;
2379 /* Resolve the g77 compatibility function UMASK. */
2382 gfc_resolve_umask (gfc_expr *f, gfc_expr *n)
2384 f->ts.type = BT_INTEGER;
2385 f->ts.kind = n->ts.kind;
2386 f->value.function.name = gfc_get_string (PREFIX ("umask_i%d"), n->ts.kind);
2390 /* Resolve the g77 compatibility function UNLINK. */
2393 gfc_resolve_unlink (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
2395 f->ts.type = BT_INTEGER;
2397 f->value.function.name = gfc_get_string (PREFIX ("unlink"));
2402 gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit)
2406 f->ts.type = BT_CHARACTER;
2407 f->ts.kind = gfc_default_character_kind;
2409 if (unit->ts.kind != gfc_c_int_kind)
2411 ts.type = BT_INTEGER;
2412 ts.kind = gfc_c_int_kind;
2415 gfc_convert_type (unit, &ts, 2);
2418 f->value.function.name = gfc_get_string (PREFIX ("ttynam"));
2423 gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
2424 gfc_expr *field ATTRIBUTE_UNUSED)
2426 if (vector->ts.type == BT_CHARACTER && vector->ref)
2427 gfc_resolve_substring_charlen (vector);
2430 f->rank = mask->rank;
2431 resolve_mask_arg (mask);
2433 f->value.function.name
2434 = gfc_get_string (PREFIX ("unpack%d%s"), field->rank > 0 ? 1 : 0,
2435 vector->ts.type == BT_CHARACTER ? "_char" : "");
2440 gfc_resolve_verify (gfc_expr *f, gfc_expr *string,
2441 gfc_expr *set ATTRIBUTE_UNUSED,
2442 gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
2444 f->ts.type = BT_INTEGER;
2446 f->ts.kind = mpz_get_si (kind->value.integer);
2448 f->ts.kind = gfc_default_integer_kind;
2449 f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
2454 gfc_resolve_xor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
2456 f->ts.type = i->ts.type;
2457 f->ts.kind = gfc_kind_max (i, j);
2459 if (i->ts.kind != j->ts.kind)
2461 if (i->ts.kind == gfc_kind_max (i, j))
2462 gfc_convert_type (j, &i->ts, 2);
2464 gfc_convert_type (i, &j->ts, 2);
2467 f->value.function.name
2468 = gfc_get_string ("__xor_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
2472 /* Intrinsic subroutine resolution. */
2475 gfc_resolve_alarm_sub (gfc_code *c)
2478 gfc_expr *seconds, *handler, *status;
2481 seconds = c->ext.actual->expr;
2482 handler = c->ext.actual->next->expr;
2483 status = c->ext.actual->next->next->expr;
2484 ts.type = BT_INTEGER;
2485 ts.kind = gfc_c_int_kind;
2487 /* handler can be either BT_INTEGER or BT_PROCEDURE.
2488 In all cases, the status argument is of default integer kind
2489 (enforced in check.c) so that the function suffix is fixed. */
2490 if (handler->ts.type == BT_INTEGER)
2492 if (handler->ts.kind != gfc_c_int_kind)
2493 gfc_convert_type (handler, &ts, 2);
2494 name = gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
2495 gfc_default_integer_kind);
2498 name = gfc_get_string (PREFIX ("alarm_sub_i%d"),
2499 gfc_default_integer_kind);
2501 if (seconds->ts.kind != gfc_c_int_kind)
2502 gfc_convert_type (seconds, &ts, 2);
2504 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2508 gfc_resolve_cpu_time (gfc_code *c)
2511 name = gfc_get_string (PREFIX ("cpu_time_%d"), c->ext.actual->expr->ts.kind);
2512 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2517 gfc_resolve_mvbits (gfc_code *c)
2522 /* FROMPOS, LEN and TOPOS are restricted to small values. As such,
2523 they will be converted so that they fit into a C int. */
2524 ts.type = BT_INTEGER;
2525 ts.kind = gfc_c_int_kind;
2526 if (c->ext.actual->next->expr->ts.kind != gfc_c_int_kind)
2527 gfc_convert_type (c->ext.actual->next->expr, &ts, 2);
2528 if (c->ext.actual->next->next->expr->ts.kind != gfc_c_int_kind)
2529 gfc_convert_type (c->ext.actual->next->next->expr, &ts, 2);
2530 if (c->ext.actual->next->next->next->next->expr->ts.kind != gfc_c_int_kind)
2531 gfc_convert_type (c->ext.actual->next->next->next->next->expr, &ts, 2);
2533 /* TO and FROM are guaranteed to have the same kind parameter. */
2534 name = gfc_get_string (PREFIX ("mvbits_i%d"),
2535 c->ext.actual->expr->ts.kind);
2536 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2541 gfc_resolve_random_number (gfc_code *c)
2546 kind = c->ext.actual->expr->ts.kind;
2547 if (c->ext.actual->expr->rank == 0)
2548 name = gfc_get_string (PREFIX ("random_r%d"), kind);
2550 name = gfc_get_string (PREFIX ("arandom_r%d"), kind);
2552 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2557 gfc_resolve_random_seed (gfc_code *c)
2561 name = gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind);
2562 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2567 gfc_resolve_rename_sub (gfc_code *c)
2572 if (c->ext.actual->next->next->expr != NULL)
2573 kind = c->ext.actual->next->next->expr->ts.kind;
2575 kind = gfc_default_integer_kind;
2577 name = gfc_get_string (PREFIX ("rename_i%d_sub"), kind);
2578 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2583 gfc_resolve_kill_sub (gfc_code *c)
2588 if (c->ext.actual->next->next->expr != NULL)
2589 kind = c->ext.actual->next->next->expr->ts.kind;
2591 kind = gfc_default_integer_kind;
2593 name = gfc_get_string (PREFIX ("kill_i%d_sub"), kind);
2594 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2599 gfc_resolve_link_sub (gfc_code *c)
2604 if (c->ext.actual->next->next->expr != NULL)
2605 kind = c->ext.actual->next->next->expr->ts.kind;
2607 kind = gfc_default_integer_kind;
2609 name = gfc_get_string (PREFIX ("link_i%d_sub"), kind);
2610 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2615 gfc_resolve_symlnk_sub (gfc_code *c)
2620 if (c->ext.actual->next->next->expr != NULL)
2621 kind = c->ext.actual->next->next->expr->ts.kind;
2623 kind = gfc_default_integer_kind;
2625 name = gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind);
2626 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2630 /* G77 compatibility subroutines etime() and dtime(). */
2633 gfc_resolve_etime_sub (gfc_code *c)
2636 name = gfc_get_string (PREFIX ("etime_sub"));
2637 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2641 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
2644 gfc_resolve_itime (gfc_code *c)
2647 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
2648 gfc_default_integer_kind));
2652 gfc_resolve_idate (gfc_code *c)
2655 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
2656 gfc_default_integer_kind));
2660 gfc_resolve_ltime (gfc_code *c)
2663 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
2664 gfc_default_integer_kind));
2668 gfc_resolve_gmtime (gfc_code *c)
2671 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
2672 gfc_default_integer_kind));
2676 /* G77 compatibility subroutine second(). */
2679 gfc_resolve_second_sub (gfc_code *c)
2682 name = gfc_get_string (PREFIX ("second_sub"));
2683 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2688 gfc_resolve_sleep_sub (gfc_code *c)
2693 if (c->ext.actual->expr != NULL)
2694 kind = c->ext.actual->expr->ts.kind;
2696 kind = gfc_default_integer_kind;
2698 name = gfc_get_string (PREFIX ("sleep_i%d_sub"), kind);
2699 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2703 /* G77 compatibility function srand(). */
2706 gfc_resolve_srand (gfc_code *c)
2709 name = gfc_get_string (PREFIX ("srand"));
2710 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2714 /* Resolve the getarg intrinsic subroutine. */
2717 gfc_resolve_getarg (gfc_code *c)
2721 if (c->ext.actual->expr->ts.kind != gfc_default_integer_kind)
2725 ts.type = BT_INTEGER;
2726 ts.kind = gfc_default_integer_kind;
2728 gfc_convert_type (c->ext.actual->expr, &ts, 2);
2731 name = gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind);
2732 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2736 /* Resolve the getcwd intrinsic subroutine. */
2739 gfc_resolve_getcwd_sub (gfc_code *c)
2744 if (c->ext.actual->next->expr != NULL)
2745 kind = c->ext.actual->next->expr->ts.kind;
2747 kind = gfc_default_integer_kind;
2749 name = gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind);
2750 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2754 /* Resolve the get_command intrinsic subroutine. */
2757 gfc_resolve_get_command (gfc_code *c)
2761 kind = gfc_default_integer_kind;
2762 name = gfc_get_string (PREFIX ("get_command_i%d"), kind);
2763 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2767 /* Resolve the get_command_argument intrinsic subroutine. */
2770 gfc_resolve_get_command_argument (gfc_code *c)
2774 kind = gfc_default_integer_kind;
2775 name = gfc_get_string (PREFIX ("get_command_argument_i%d"), kind);
2776 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2780 /* Resolve the get_environment_variable intrinsic subroutine. */
2783 gfc_resolve_get_environment_variable (gfc_code *code)
2787 kind = gfc_default_integer_kind;
2788 name = gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind);
2789 code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2794 gfc_resolve_signal_sub (gfc_code *c)
2797 gfc_expr *number, *handler, *status;
2800 number = c->ext.actual->expr;
2801 handler = c->ext.actual->next->expr;
2802 status = c->ext.actual->next->next->expr;
2803 ts.type = BT_INTEGER;
2804 ts.kind = gfc_c_int_kind;
2806 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2807 if (handler->ts.type == BT_INTEGER)
2809 if (handler->ts.kind != gfc_c_int_kind)
2810 gfc_convert_type (handler, &ts, 2);
2811 name = gfc_get_string (PREFIX ("signal_sub_int"));
2814 name = gfc_get_string (PREFIX ("signal_sub"));
2816 if (number->ts.kind != gfc_c_int_kind)
2817 gfc_convert_type (number, &ts, 2);
2818 if (status != NULL && status->ts.kind != gfc_c_int_kind)
2819 gfc_convert_type (status, &ts, 2);
2821 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2825 /* Resolve the SYSTEM intrinsic subroutine. */
2828 gfc_resolve_system_sub (gfc_code *c)
2831 name = gfc_get_string (PREFIX ("system_sub"));
2832 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2836 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
2839 gfc_resolve_system_clock (gfc_code *c)
2844 if (c->ext.actual->expr != NULL)
2845 kind = c->ext.actual->expr->ts.kind;
2846 else if (c->ext.actual->next->expr != NULL)
2847 kind = c->ext.actual->next->expr->ts.kind;
2848 else if (c->ext.actual->next->next->expr != NULL)
2849 kind = c->ext.actual->next->next->expr->ts.kind;
2851 kind = gfc_default_integer_kind;
2853 name = gfc_get_string (PREFIX ("system_clock_%d"), kind);
2854 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2858 /* Resolve the EXIT intrinsic subroutine. */
2861 gfc_resolve_exit (gfc_code *c)
2867 /* The STATUS argument has to be of default kind. If it is not,
2869 ts.type = BT_INTEGER;
2870 ts.kind = gfc_default_integer_kind;
2871 n = c->ext.actual->expr;
2872 if (n != NULL && n->ts.kind != ts.kind)
2873 gfc_convert_type (n, &ts, 2);
2875 name = gfc_get_string (PREFIX ("exit_i%d"), ts.kind);
2876 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2880 /* Resolve the FLUSH intrinsic subroutine. */
2883 gfc_resolve_flush (gfc_code *c)
2889 ts.type = BT_INTEGER;
2890 ts.kind = gfc_default_integer_kind;
2891 n = c->ext.actual->expr;
2892 if (n != NULL && n->ts.kind != ts.kind)
2893 gfc_convert_type (n, &ts, 2);
2895 name = gfc_get_string (PREFIX ("flush_i%d"), ts.kind);
2896 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2901 gfc_resolve_free (gfc_code *c)
2906 ts.type = BT_INTEGER;
2907 ts.kind = gfc_index_integer_kind;
2908 n = c->ext.actual->expr;
2909 if (n->ts.kind != ts.kind)
2910 gfc_convert_type (n, &ts, 2);
2912 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("free"));
2917 gfc_resolve_ctime_sub (gfc_code *c)
2921 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
2922 if (c->ext.actual->expr->ts.kind != 8)
2924 ts.type = BT_INTEGER;
2928 gfc_convert_type (c->ext.actual->expr, &ts, 2);
2931 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
2936 gfc_resolve_fdate_sub (gfc_code *c)
2938 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
2943 gfc_resolve_gerror (gfc_code *c)
2945 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
2950 gfc_resolve_getlog (gfc_code *c)
2952 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
2957 gfc_resolve_hostnm_sub (gfc_code *c)
2962 if (c->ext.actual->next->expr != NULL)
2963 kind = c->ext.actual->next->expr->ts.kind;
2965 kind = gfc_default_integer_kind;
2967 name = gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind);
2968 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2973 gfc_resolve_perror (gfc_code *c)
2975 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
2978 /* Resolve the STAT and FSTAT intrinsic subroutines. */
2981 gfc_resolve_stat_sub (gfc_code *c)
2984 name = gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind);
2985 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2990 gfc_resolve_lstat_sub (gfc_code *c)
2993 name = gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind);
2994 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2999 gfc_resolve_fstat_sub (gfc_code *c)
3005 u = c->ext.actual->expr;
3006 ts = &c->ext.actual->next->expr->ts;
3007 if (u->ts.kind != ts->kind)
3008 gfc_convert_type (u, ts, 2);
3009 name = gfc_get_string (PREFIX ("fstat_i%d_sub"), ts->kind);
3010 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3015 gfc_resolve_fgetc_sub (gfc_code *c)
3021 u = c->ext.actual->expr;
3022 st = c->ext.actual->next->next->expr;
3024 if (u->ts.kind != gfc_c_int_kind)
3026 ts.type = BT_INTEGER;
3027 ts.kind = gfc_c_int_kind;
3030 gfc_convert_type (u, &ts, 2);
3034 name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), st->ts.kind);
3036 name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind);
3038 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3043 gfc_resolve_fget_sub (gfc_code *c)
3048 st = c->ext.actual->next->expr;
3050 name = gfc_get_string (PREFIX ("fget_i%d_sub"), st->ts.kind);
3052 name = gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind);
3054 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3059 gfc_resolve_fputc_sub (gfc_code *c)
3065 u = c->ext.actual->expr;
3066 st = c->ext.actual->next->next->expr;
3068 if (u->ts.kind != gfc_c_int_kind)
3070 ts.type = BT_INTEGER;
3071 ts.kind = gfc_c_int_kind;
3074 gfc_convert_type (u, &ts, 2);
3078 name = gfc_get_string (PREFIX ("fputc_i%d_sub"), st->ts.kind);
3080 name = gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind);
3082 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3087 gfc_resolve_fput_sub (gfc_code *c)
3092 st = c->ext.actual->next->expr;
3094 name = gfc_get_string (PREFIX ("fput_i%d_sub"), st->ts.kind);
3096 name = gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind);
3098 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3103 gfc_resolve_fseek_sub (gfc_code *c)
3111 unit = c->ext.actual->expr;
3112 offset = c->ext.actual->next->expr;
3113 whence = c->ext.actual->next->next->expr;
3114 status = c->ext.actual->next->next->next->expr;
3116 if (unit->ts.kind != gfc_c_int_kind)
3118 ts.type = BT_INTEGER;
3119 ts.kind = gfc_c_int_kind;
3122 gfc_convert_type (unit, &ts, 2);
3125 if (offset->ts.kind != gfc_intio_kind)
3127 ts.type = BT_INTEGER;
3128 ts.kind = gfc_intio_kind;
3131 gfc_convert_type (offset, &ts, 2);
3134 if (whence->ts.kind != gfc_c_int_kind)
3136 ts.type = BT_INTEGER;
3137 ts.kind = gfc_c_int_kind;
3140 gfc_convert_type (whence, &ts, 2);
3143 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
3147 gfc_resolve_ftell_sub (gfc_code *c)
3154 unit = c->ext.actual->expr;
3155 offset = c->ext.actual->next->expr;
3157 if (unit->ts.kind != gfc_c_int_kind)
3159 ts.type = BT_INTEGER;
3160 ts.kind = gfc_c_int_kind;
3163 gfc_convert_type (unit, &ts, 2);
3166 name = gfc_get_string (PREFIX ("ftell_i%d_sub"), offset->ts.kind);
3167 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3172 gfc_resolve_ttynam_sub (gfc_code *c)
3176 if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
3178 ts.type = BT_INTEGER;
3179 ts.kind = gfc_c_int_kind;
3182 gfc_convert_type (c->ext.actual->expr, &ts, 2);
3185 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
3189 /* Resolve the UMASK intrinsic subroutine. */
3192 gfc_resolve_umask_sub (gfc_code *c)
3197 if (c->ext.actual->next->expr != NULL)
3198 kind = c->ext.actual->next->expr->ts.kind;
3200 kind = gfc_default_integer_kind;
3202 name = gfc_get_string (PREFIX ("umask_i%d_sub"), kind);
3203 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3206 /* Resolve the UNLINK intrinsic subroutine. */
3209 gfc_resolve_unlink_sub (gfc_code *c)
3214 if (c->ext.actual->next->expr != NULL)
3215 kind = c->ext.actual->next->expr->ts.kind;
3217 kind = gfc_default_integer_kind;
3219 name = gfc_get_string (PREFIX ("unlink_i%d_sub"), kind);
3220 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);