From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/fortran/iresolve.c | 3631 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 3631 insertions(+) create mode 100644 gcc/fortran/iresolve.c (limited to 'gcc/fortran/iresolve.c') diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c new file mode 100644 index 000000000..d8309d27f --- /dev/null +++ b/gcc/fortran/iresolve.c @@ -0,0 +1,3631 @@ +/* Intrinsic function resolution. + Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, + 2009, 2010 + Free Software Foundation, Inc. + Contributed by Andy Vaught & Katherine Holcomb + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + + +/* Assign name and types to intrinsic procedures. For functions, the + first argument to a resolution function is an expression pointer to + the original function node and the rest are pointers to the + arguments of the function call. For subroutines, a pointer to the + code node is passed. The result type and library subroutine name + are generally set according to the function arguments. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tree.h" +#include "gfortran.h" +#include "intrinsic.h" +#include "constructor.h" +#include "arith.h" + +/* Given printf-like arguments, return a stable version of the result string. + + We already have a working, optimized string hashing table in the form of + the identifier table. Reusing this table is likely not to be wasted, + since if the function name makes it to the gimple output of the frontend, + we'll have to create the identifier anyway. */ + +const char * +gfc_get_string (const char *format, ...) +{ + char temp_name[128]; + va_list ap; + tree ident; + + va_start (ap, format); + vsnprintf (temp_name, sizeof (temp_name), format, ap); + va_end (ap); + temp_name[sizeof (temp_name) - 1] = 0; + + ident = get_identifier (temp_name); + return IDENTIFIER_POINTER (ident); +} + +/* MERGE and SPREAD need to have source charlen's present for passing + to the result expression. */ +static void +check_charlen_present (gfc_expr *source) +{ + if (source->ts.u.cl == NULL) + source->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); + + if (source->expr_type == EXPR_CONSTANT) + { + source->ts.u.cl->length + = gfc_get_int_expr (gfc_default_integer_kind, NULL, + source->value.character.length); + source->rank = 0; + } + else if (source->expr_type == EXPR_ARRAY) + { + gfc_constructor *c = gfc_constructor_first (source->value.constructor); + source->ts.u.cl->length + = gfc_get_int_expr (gfc_default_integer_kind, NULL, + c->expr->value.character.length); + } +} + +/* Helper function for resolving the "mask" argument. */ + +static void +resolve_mask_arg (gfc_expr *mask) +{ + + gfc_typespec ts; + gfc_clear_ts (&ts); + + if (mask->rank == 0) + { + /* For the scalar case, coerce the mask to kind=4 unconditionally + (because this is the only kind we have a library function + for). */ + + if (mask->ts.kind != 4) + { + ts.type = BT_LOGICAL; + ts.kind = 4; + gfc_convert_type (mask, &ts, 2); + } + } + else + { + /* In the library, we access the mask with a GFC_LOGICAL_1 + argument. No need to waste memory if we are about to create + a temporary array. */ + if (mask->expr_type == EXPR_OP && mask->ts.kind != 1) + { + ts.type = BT_LOGICAL; + ts.kind = 1; + gfc_convert_type_warn (mask, &ts, 2, 0); + } + } +} + + +static void +resolve_bound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind, + const char *name, bool coarray) +{ + f->ts.type = BT_INTEGER; + if (kind) + f->ts.kind = mpz_get_si (kind->value.integer); + else + f->ts.kind = gfc_default_integer_kind; + + if (dim == NULL) + { + f->rank = 1; + f->shape = gfc_get_shape (1); + mpz_init_set_ui (f->shape[0], coarray ? gfc_get_corank (array) + : array->rank); + } + + f->value.function.name = xstrdup (name); +} + + +static void +resolve_transformational (const char *name, gfc_expr *f, gfc_expr *array, + gfc_expr *dim, gfc_expr *mask) +{ + const char *prefix; + + f->ts = array->ts; + + if (mask) + { + if (mask->rank == 0) + prefix = "s"; + else + prefix = "m"; + + resolve_mask_arg (mask); + } + else + prefix = ""; + + if (dim != NULL) + { + f->rank = array->rank - 1; + f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim); + gfc_resolve_dim_arg (dim); + } + + f->value.function.name + = gfc_get_string (PREFIX ("%s%s_%c%d"), prefix, name, + gfc_type_letter (array->ts.type), array->ts.kind); +} + + +/********************** Resolution functions **********************/ + + +void +gfc_resolve_abs (gfc_expr *f, gfc_expr *a) +{ + f->ts = a->ts; + if (f->ts.type == BT_COMPLEX) + f->ts.type = BT_REAL; + + f->value.function.name + = gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type), a->ts.kind); +} + + +void +gfc_resolve_access (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED, + gfc_expr *mode ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_c_int_kind; + f->value.function.name = PREFIX ("access_func"); +} + + +void +gfc_resolve_adjustl (gfc_expr *f, gfc_expr *string) +{ + f->ts.type = BT_CHARACTER; + f->ts.kind = string->ts.kind; + f->value.function.name = gfc_get_string ("__adjustl_s%d", f->ts.kind); +} + + +void +gfc_resolve_adjustr (gfc_expr *f, gfc_expr *string) +{ + f->ts.type = BT_CHARACTER; + f->ts.kind = string->ts.kind; + f->value.function.name = gfc_get_string ("__adjustr_s%d", f->ts.kind); +} + + +static void +gfc_resolve_char_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind, + const char *name) +{ + f->ts.type = BT_CHARACTER; + f->ts.kind = (kind == NULL) + ? gfc_default_character_kind : mpz_get_si (kind->value.integer); + f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); + f->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); + + f->value.function.name = gfc_get_string (name, f->ts.kind, + gfc_type_letter (x->ts.type), + x->ts.kind); +} + + +void +gfc_resolve_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind) +{ + gfc_resolve_char_achar (f, x, kind, "__achar_%d_%c%d"); +} + + +void +gfc_resolve_acos (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); +} + + +void +gfc_resolve_acosh (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__acosh_%c%d", gfc_type_letter (x->ts.type), + x->ts.kind); +} + + +void +gfc_resolve_aimag (gfc_expr *f, gfc_expr *x) +{ + f->ts.type = BT_REAL; + f->ts.kind = x->ts.kind; + f->value.function.name + = gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type), + x->ts.kind); +} + + +void +gfc_resolve_and (gfc_expr *f, gfc_expr *i, gfc_expr *j) +{ + f->ts.type = i->ts.type; + f->ts.kind = gfc_kind_max (i, j); + + if (i->ts.kind != j->ts.kind) + { + if (i->ts.kind == gfc_kind_max (i, j)) + gfc_convert_type (j, &i->ts, 2); + else + gfc_convert_type (i, &j->ts, 2); + } + + f->value.function.name + = gfc_get_string ("__and_%c%d", gfc_type_letter (i->ts.type), f->ts.kind); +} + + +void +gfc_resolve_aint (gfc_expr *f, gfc_expr *a, gfc_expr *kind) +{ + gfc_typespec ts; + gfc_clear_ts (&ts); + + f->ts.type = a->ts.type; + f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer); + + if (a->ts.kind != f->ts.kind) + { + ts.type = f->ts.type; + ts.kind = f->ts.kind; + gfc_convert_type (a, &ts, 2); + } + /* The resolved name is only used for specific intrinsics where + the return kind is the same as the arg kind. */ + f->value.function.name + = gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind); +} + + +void +gfc_resolve_dint (gfc_expr *f, gfc_expr *a) +{ + gfc_resolve_aint (f, a, NULL); +} + + +void +gfc_resolve_all (gfc_expr *f, gfc_expr *mask, gfc_expr *dim) +{ + f->ts = mask->ts; + + if (dim != NULL) + { + gfc_resolve_dim_arg (dim); + f->rank = mask->rank - 1; + f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim); + } + + f->value.function.name + = gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask->ts.type), + mask->ts.kind); +} + + +void +gfc_resolve_anint (gfc_expr *f, gfc_expr *a, gfc_expr *kind) +{ + gfc_typespec ts; + gfc_clear_ts (&ts); + + f->ts.type = a->ts.type; + f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer); + + if (a->ts.kind != f->ts.kind) + { + ts.type = f->ts.type; + ts.kind = f->ts.kind; + gfc_convert_type (a, &ts, 2); + } + + /* The resolved name is only used for specific intrinsics where + the return kind is the same as the arg kind. */ + f->value.function.name + = gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type), + a->ts.kind); +} + + +void +gfc_resolve_dnint (gfc_expr *f, gfc_expr *a) +{ + gfc_resolve_anint (f, a, NULL); +} + + +void +gfc_resolve_any (gfc_expr *f, gfc_expr *mask, gfc_expr *dim) +{ + f->ts = mask->ts; + + if (dim != NULL) + { + gfc_resolve_dim_arg (dim); + f->rank = mask->rank - 1; + f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim); + } + + f->value.function.name + = gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask->ts.type), + mask->ts.kind); +} + + +void +gfc_resolve_asin (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); +} + +void +gfc_resolve_asinh (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__asinh_%c%d", gfc_type_letter (x->ts.type), + x->ts.kind); +} + +void +gfc_resolve_atan (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); +} + +void +gfc_resolve_atanh (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__atanh_%c%d", gfc_type_letter (x->ts.type), + x->ts.kind); +} + +void +gfc_resolve_atan2 (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type), + x->ts.kind); +} + + +/* Resolve the BESYN and BESJN intrinsics. */ + +void +gfc_resolve_besn (gfc_expr *f, gfc_expr *n, gfc_expr *x) +{ + gfc_typespec ts; + gfc_clear_ts (&ts); + + f->ts = x->ts; + if (n->ts.kind != gfc_c_int_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + gfc_convert_type (n, &ts, 2); + } + f->value.function.name = gfc_get_string (""); +} + + +void +gfc_resolve_bessel_n2 (gfc_expr *f, gfc_expr *n1, gfc_expr *n2, gfc_expr *x) +{ + gfc_typespec ts; + gfc_clear_ts (&ts); + + f->ts = x->ts; + f->rank = 1; + if (n1->expr_type == EXPR_CONSTANT && n2->expr_type == EXPR_CONSTANT) + { + f->shape = gfc_get_shape (1); + mpz_init (f->shape[0]); + mpz_sub (f->shape[0], n2->value.integer, n1->value.integer); + mpz_add_ui (f->shape[0], f->shape[0], 1); + } + + if (n1->ts.kind != gfc_c_int_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + gfc_convert_type (n1, &ts, 2); + } + + if (n2->ts.kind != gfc_c_int_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + gfc_convert_type (n2, &ts, 2); + } + + if (f->value.function.isym->id == GFC_ISYM_JN2) + f->value.function.name = gfc_get_string (PREFIX ("bessel_jn_r%d"), + f->ts.kind); + else + f->value.function.name = gfc_get_string (PREFIX ("bessel_yn_r%d"), + f->ts.kind); +} + + +void +gfc_resolve_btest (gfc_expr *f, gfc_expr *i, gfc_expr *pos) +{ + f->ts.type = BT_LOGICAL; + f->ts.kind = gfc_default_logical_kind; + f->value.function.name + = gfc_get_string ("__btest_%d_%d", i->ts.kind, pos->ts.kind); +} + + +void +gfc_resolve_ceiling (gfc_expr *f, gfc_expr *a, gfc_expr *kind) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = (kind == NULL) + ? gfc_default_integer_kind : mpz_get_si (kind->value.integer); + f->value.function.name + = gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind, + gfc_type_letter (a->ts.type), a->ts.kind); +} + + +void +gfc_resolve_char (gfc_expr *f, gfc_expr *a, gfc_expr *kind) +{ + gfc_resolve_char_achar (f, a, kind, "__char_%d_%c%d"); +} + + +void +gfc_resolve_chdir (gfc_expr *f, gfc_expr *d ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = gfc_get_string (PREFIX ("chdir_i%d"), f->ts.kind); +} + + +void +gfc_resolve_chdir_sub (gfc_code *c) +{ + const char *name; + int kind; + + if (c->ext.actual->next->expr != NULL) + kind = c->ext.actual->next->expr->ts.kind; + else + kind = gfc_default_integer_kind; + + name = gfc_get_string (PREFIX ("chdir_i%d_sub"), kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_chmod (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED, + gfc_expr *mode ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_c_int_kind; + f->value.function.name = PREFIX ("chmod_func"); +} + + +void +gfc_resolve_chmod_sub (gfc_code *c) +{ + const char *name; + int kind; + + if (c->ext.actual->next->next->expr != NULL) + kind = c->ext.actual->next->next->expr->ts.kind; + else + kind = gfc_default_integer_kind; + + name = gfc_get_string (PREFIX ("chmod_i%d_sub"), kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_cmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y, gfc_expr *kind) +{ + f->ts.type = BT_COMPLEX; + f->ts.kind = (kind == NULL) + ? gfc_default_real_kind : mpz_get_si (kind->value.integer); + + if (y == NULL) + f->value.function.name + = gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind, + gfc_type_letter (x->ts.type), x->ts.kind); + else + f->value.function.name + = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind, + gfc_type_letter (x->ts.type), x->ts.kind, + gfc_type_letter (y->ts.type), y->ts.kind); +} + + +void +gfc_resolve_dcmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y) +{ + gfc_resolve_cmplx (f, x, y, gfc_get_int_expr (gfc_default_integer_kind, NULL, + gfc_default_double_kind)); +} + + +void +gfc_resolve_complex (gfc_expr *f, gfc_expr *x, gfc_expr *y) +{ + int kind; + + if (x->ts.type == BT_INTEGER) + { + if (y->ts.type == BT_INTEGER) + kind = gfc_default_real_kind; + else + kind = y->ts.kind; + } + else + { + if (y->ts.type == BT_REAL) + kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind; + else + kind = x->ts.kind; + } + + f->ts.type = BT_COMPLEX; + f->ts.kind = kind; + f->value.function.name + = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind, + gfc_type_letter (x->ts.type), x->ts.kind, + gfc_type_letter (y->ts.type), y->ts.kind); +} + + +void +gfc_resolve_conjg (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind); +} + + +void +gfc_resolve_cos (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); +} + + +void +gfc_resolve_cosh (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); +} + + +void +gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim, gfc_expr *kind) +{ + f->ts.type = BT_INTEGER; + if (kind) + f->ts.kind = mpz_get_si (kind->value.integer); + else + f->ts.kind = gfc_default_integer_kind; + + if (dim != NULL) + { + f->rank = mask->rank - 1; + gfc_resolve_dim_arg (dim); + f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim); + } + + resolve_mask_arg (mask); + + f->value.function.name + = gfc_get_string (PREFIX ("count_%d_%c"), f->ts.kind, + gfc_type_letter (mask->ts.type)); +} + + +void +gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift, + gfc_expr *dim) +{ + int n, m; + + if (array->ts.type == BT_CHARACTER && array->ref) + gfc_resolve_substring_charlen (array); + + f->ts = array->ts; + f->rank = array->rank; + f->shape = gfc_copy_shape (array->shape, array->rank); + + if (shift->rank > 0) + n = 1; + else + n = 0; + + /* If dim kind is greater than default integer we need to use the larger. */ + m = gfc_default_integer_kind; + if (dim != NULL) + m = m < dim->ts.kind ? dim->ts.kind : m; + + /* Convert shift to at least m, so we don't need + kind=1 and kind=2 versions of the library functions. */ + if (shift->ts.kind < m) + { + gfc_typespec ts; + gfc_clear_ts (&ts); + ts.type = BT_INTEGER; + ts.kind = m; + gfc_convert_type_warn (shift, &ts, 2, 0); + } + + if (dim != NULL) + { + if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL + && dim->symtree->n.sym->attr.optional) + { + /* Mark this for later setting the type in gfc_conv_missing_dummy. */ + dim->representation.length = shift->ts.kind; + } + else + { + gfc_resolve_dim_arg (dim); + /* Convert dim to shift's kind to reduce variations. */ + if (dim->ts.kind != shift->ts.kind) + gfc_convert_type_warn (dim, &shift->ts, 2, 0); + } + } + + if (array->ts.type == BT_CHARACTER) + { + if (array->ts.kind == gfc_default_character_kind) + f->value.function.name + = gfc_get_string (PREFIX ("cshift%d_%d_char"), n, shift->ts.kind); + else + f->value.function.name + = gfc_get_string (PREFIX ("cshift%d_%d_char%d"), n, shift->ts.kind, + array->ts.kind); + } + else + f->value.function.name + = gfc_get_string (PREFIX ("cshift%d_%d"), n, shift->ts.kind); +} + + +void +gfc_resolve_ctime (gfc_expr *f, gfc_expr *time) +{ + gfc_typespec ts; + gfc_clear_ts (&ts); + + f->ts.type = BT_CHARACTER; + f->ts.kind = gfc_default_character_kind; + + /* ctime TIME argument is a INTEGER(KIND=8), says the doc */ + if (time->ts.kind != 8) + { + ts.type = BT_INTEGER; + ts.kind = 8; + ts.u.derived = NULL; + ts.u.cl = NULL; + gfc_convert_type (time, &ts, 2); + } + + f->value.function.name = gfc_get_string (PREFIX ("ctime")); +} + + +void +gfc_resolve_dble (gfc_expr *f, gfc_expr *a) +{ + f->ts.type = BT_REAL; + f->ts.kind = gfc_default_double_kind; + f->value.function.name + = gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type), a->ts.kind); +} + + +void +gfc_resolve_dim (gfc_expr *f, gfc_expr *a, gfc_expr *p) +{ + f->ts.type = a->ts.type; + if (p != NULL) + f->ts.kind = gfc_kind_max (a,p); + else + f->ts.kind = a->ts.kind; + + if (p != NULL && a->ts.kind != p->ts.kind) + { + if (a->ts.kind == gfc_kind_max (a,p)) + gfc_convert_type (p, &a->ts, 2); + else + gfc_convert_type (a, &p->ts, 2); + } + + f->value.function.name + = gfc_get_string ("__dim_%c%d", gfc_type_letter (f->ts.type), f->ts.kind); +} + + +void +gfc_resolve_dot_product (gfc_expr *f, gfc_expr *a, gfc_expr *b) +{ + gfc_expr temp; + + temp.expr_type = EXPR_OP; + gfc_clear_ts (&temp.ts); + temp.value.op.op = INTRINSIC_NONE; + temp.value.op.op1 = a; + temp.value.op.op2 = b; + gfc_type_convert_binary (&temp, 1); + f->ts = temp.ts; + f->value.function.name + = gfc_get_string (PREFIX ("dot_product_%c%d"), + gfc_type_letter (f->ts.type), f->ts.kind); +} + + +void +gfc_resolve_dprod (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED, + gfc_expr *b ATTRIBUTE_UNUSED) +{ + f->ts.kind = gfc_default_double_kind; + f->ts.type = BT_REAL; + f->value.function.name = gfc_get_string ("__dprod_r%d", f->ts.kind); +} + + +void +gfc_resolve_dshift (gfc_expr *f, gfc_expr *i, gfc_expr *j ATTRIBUTE_UNUSED, + gfc_expr *shift ATTRIBUTE_UNUSED) +{ + f->ts = i->ts; + if (f->value.function.isym->id == GFC_ISYM_DSHIFTL) + f->value.function.name = gfc_get_string ("dshiftl_i%d", f->ts.kind); + else if (f->value.function.isym->id == GFC_ISYM_DSHIFTR) + f->value.function.name = gfc_get_string ("dshiftr_i%d", f->ts.kind); + else + gcc_unreachable (); +} + + +void +gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift, + gfc_expr *boundary, gfc_expr *dim) +{ + int n, m; + + if (array->ts.type == BT_CHARACTER && array->ref) + gfc_resolve_substring_charlen (array); + + f->ts = array->ts; + f->rank = array->rank; + f->shape = gfc_copy_shape (array->shape, array->rank); + + n = 0; + if (shift->rank > 0) + n = n | 1; + if (boundary && boundary->rank > 0) + n = n | 2; + + /* If dim kind is greater than default integer we need to use the larger. */ + m = gfc_default_integer_kind; + if (dim != NULL) + m = m < dim->ts.kind ? dim->ts.kind : m; + + /* Convert shift to at least m, so we don't need + kind=1 and kind=2 versions of the library functions. */ + if (shift->ts.kind < m) + { + gfc_typespec ts; + gfc_clear_ts (&ts); + ts.type = BT_INTEGER; + ts.kind = m; + gfc_convert_type_warn (shift, &ts, 2, 0); + } + + if (dim != NULL) + { + if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL + && dim->symtree->n.sym->attr.optional) + { + /* Mark this for later setting the type in gfc_conv_missing_dummy. */ + dim->representation.length = shift->ts.kind; + } + else + { + gfc_resolve_dim_arg (dim); + /* Convert dim to shift's kind to reduce variations. */ + if (dim->ts.kind != shift->ts.kind) + gfc_convert_type_warn (dim, &shift->ts, 2, 0); + } + } + + if (array->ts.type == BT_CHARACTER) + { + if (array->ts.kind == gfc_default_character_kind) + f->value.function.name + = gfc_get_string (PREFIX ("eoshift%d_%d_char"), n, shift->ts.kind); + else + f->value.function.name + = gfc_get_string (PREFIX ("eoshift%d_%d_char%d"), n, shift->ts.kind, + array->ts.kind); + } + else + f->value.function.name + = gfc_get_string (PREFIX ("eoshift%d_%d"), n, shift->ts.kind); +} + + +void +gfc_resolve_exp (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); +} + + +void +gfc_resolve_exponent (gfc_expr *f, gfc_expr *x) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind); +} + + +/* Resolve the EXTENDS_TYPE_OF intrinsic function. */ + +void +gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo) +{ + gfc_symbol *vtab; + gfc_symtree *st; + + /* Prevent double resolution. */ + if (f->ts.type == BT_LOGICAL) + return; + + /* Replace the first argument with the corresponding vtab. */ + if (a->ts.type == BT_CLASS) + gfc_add_vptr_component (a); + else if (a->ts.type == BT_DERIVED) + { + vtab = gfc_find_derived_vtab (a->ts.u.derived); + /* Clear the old expr. */ + gfc_free_ref_list (a->ref); + memset (a, '\0', sizeof (gfc_expr)); + /* Construct a new one. */ + a->expr_type = EXPR_VARIABLE; + st = gfc_find_symtree (vtab->ns->sym_root, vtab->name); + a->symtree = st; + a->ts = vtab->ts; + } + + /* Replace the second argument with the corresponding vtab. */ + if (mo->ts.type == BT_CLASS) + gfc_add_vptr_component (mo); + else if (mo->ts.type == BT_DERIVED) + { + vtab = gfc_find_derived_vtab (mo->ts.u.derived); + /* Clear the old expr. */ + gfc_free_ref_list (mo->ref); + memset (mo, '\0', sizeof (gfc_expr)); + /* Construct a new one. */ + mo->expr_type = EXPR_VARIABLE; + st = gfc_find_symtree (vtab->ns->sym_root, vtab->name); + mo->symtree = st; + mo->ts = vtab->ts; + } + + f->ts.type = BT_LOGICAL; + f->ts.kind = 4; + + f->value.function.isym->formal->ts = a->ts; + f->value.function.isym->formal->next->ts = mo->ts; + + /* Call library function. */ + f->value.function.name = gfc_get_string (PREFIX ("is_extension_of")); +} + + +void +gfc_resolve_fdate (gfc_expr *f) +{ + f->ts.type = BT_CHARACTER; + f->ts.kind = gfc_default_character_kind; + f->value.function.name = gfc_get_string (PREFIX ("fdate")); +} + + +void +gfc_resolve_floor (gfc_expr *f, gfc_expr *a, gfc_expr *kind) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = (kind == NULL) + ? gfc_default_integer_kind : mpz_get_si (kind->value.integer); + f->value.function.name + = gfc_get_string ("__floor%d_%c%d", f->ts.kind, + gfc_type_letter (a->ts.type), a->ts.kind); +} + + +void +gfc_resolve_fnum (gfc_expr *f, gfc_expr *n) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + if (n->ts.kind != f->ts.kind) + gfc_convert_type (n, &f->ts, 2); + f->value.function.name = gfc_get_string (PREFIX ("fnum_i%d"), f->ts.kind); +} + + +void +gfc_resolve_fraction (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind); +} + + +/* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */ + +void +gfc_resolve_g77_math1 (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name = gfc_get_string (""); +} + + +void +gfc_resolve_gamma (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__tgamma_%d", x->ts.kind); +} + + +void +gfc_resolve_getcwd (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = 4; + f->value.function.name = gfc_get_string (PREFIX ("getcwd")); +} + + +void +gfc_resolve_getgid (gfc_expr *f) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = 4; + f->value.function.name = gfc_get_string (PREFIX ("getgid")); +} + + +void +gfc_resolve_getpid (gfc_expr *f) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = 4; + f->value.function.name = gfc_get_string (PREFIX ("getpid")); +} + + +void +gfc_resolve_getuid (gfc_expr *f) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = 4; + f->value.function.name = gfc_get_string (PREFIX ("getuid")); +} + + +void +gfc_resolve_hostnm (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = 4; + f->value.function.name = gfc_get_string (PREFIX ("hostnm")); +} + + +void +gfc_resolve_hypot (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED) +{ + f->ts = x->ts; + f->value.function.name = gfc_get_string ("__hypot_r%d", x->ts.kind); +} + + +void +gfc_resolve_iall (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask) +{ + resolve_transformational ("iall", f, array, dim, mask); +} + + +void +gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j) +{ + /* If the kind of i and j are different, then g77 cross-promoted the + kinds to the largest value. The Fortran 95 standard requires the + kinds to match. */ + if (i->ts.kind != j->ts.kind) + { + if (i->ts.kind == gfc_kind_max (i, j)) + gfc_convert_type (j, &i->ts, 2); + else + gfc_convert_type (i, &j->ts, 2); + } + + f->ts = i->ts; + f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind); +} + + +void +gfc_resolve_iany (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask) +{ + resolve_transformational ("iany", f, array, dim, mask); +} + + +void +gfc_resolve_ibclr (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED) +{ + f->ts = i->ts; + f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind); +} + + +void +gfc_resolve_ibits (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED, + gfc_expr *len ATTRIBUTE_UNUSED) +{ + f->ts = i->ts; + f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind); +} + + +void +gfc_resolve_ibset (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED) +{ + f->ts = i->ts; + f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind); +} + + +void +gfc_resolve_iachar (gfc_expr *f, gfc_expr *c, gfc_expr *kind) +{ + f->ts.type = BT_INTEGER; + if (kind) + f->ts.kind = mpz_get_si (kind->value.integer); + else + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind); +} + + +void +gfc_resolve_ichar (gfc_expr *f, gfc_expr *c, gfc_expr *kind) +{ + f->ts.type = BT_INTEGER; + if (kind) + f->ts.kind = mpz_get_si (kind->value.integer); + else + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind); +} + + +void +gfc_resolve_idnint (gfc_expr *f, gfc_expr *a) +{ + gfc_resolve_nint (f, a, NULL); +} + + +void +gfc_resolve_ierrno (gfc_expr *f) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = gfc_get_string (PREFIX ("ierrno_i%d"), f->ts.kind); +} + + +void +gfc_resolve_ieor (gfc_expr *f, gfc_expr *i, gfc_expr *j) +{ + /* If the kind of i and j are different, then g77 cross-promoted the + kinds to the largest value. The Fortran 95 standard requires the + kinds to match. */ + if (i->ts.kind != j->ts.kind) + { + if (i->ts.kind == gfc_kind_max (i, j)) + gfc_convert_type (j, &i->ts, 2); + else + gfc_convert_type (i, &j->ts, 2); + } + + f->ts = i->ts; + f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind); +} + + +void +gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j) +{ + /* If the kind of i and j are different, then g77 cross-promoted the + kinds to the largest value. The Fortran 95 standard requires the + kinds to match. */ + if (i->ts.kind != j->ts.kind) + { + if (i->ts.kind == gfc_kind_max (i, j)) + gfc_convert_type (j, &i->ts, 2); + else + gfc_convert_type (i, &j->ts, 2); + } + + f->ts = i->ts; + f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind); +} + + +void +gfc_resolve_index_func (gfc_expr *f, gfc_expr *str, + gfc_expr *sub_str ATTRIBUTE_UNUSED, gfc_expr *back, + gfc_expr *kind) +{ + gfc_typespec ts; + gfc_clear_ts (&ts); + + f->ts.type = BT_INTEGER; + if (kind) + f->ts.kind = mpz_get_si (kind->value.integer); + else + f->ts.kind = gfc_default_integer_kind; + + if (back && back->ts.kind != gfc_default_integer_kind) + { + ts.type = BT_LOGICAL; + ts.kind = gfc_default_integer_kind; + ts.u.derived = NULL; + ts.u.cl = NULL; + gfc_convert_type (back, &ts, 2); + } + + f->value.function.name + = gfc_get_string ("__index_%d_i%d", str->ts.kind, f->ts.kind); +} + + +void +gfc_resolve_int (gfc_expr *f, gfc_expr *a, gfc_expr *kind) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = (kind == NULL) + ? gfc_default_integer_kind : mpz_get_si (kind->value.integer); + f->value.function.name + = gfc_get_string ("__int_%d_%c%d", f->ts.kind, + gfc_type_letter (a->ts.type), a->ts.kind); +} + + +void +gfc_resolve_int2 (gfc_expr *f, gfc_expr *a) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = 2; + f->value.function.name + = gfc_get_string ("__int_%d_%c%d", f->ts.kind, + gfc_type_letter (a->ts.type), a->ts.kind); +} + + +void +gfc_resolve_int8 (gfc_expr *f, gfc_expr *a) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = 8; + f->value.function.name + = gfc_get_string ("__int_%d_%c%d", f->ts.kind, + gfc_type_letter (a->ts.type), a->ts.kind); +} + + +void +gfc_resolve_long (gfc_expr *f, gfc_expr *a) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = 4; + f->value.function.name + = gfc_get_string ("__int_%d_%c%d", f->ts.kind, + gfc_type_letter (a->ts.type), a->ts.kind); +} + + +void +gfc_resolve_iparity (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask) +{ + resolve_transformational ("iparity", f, array, dim, mask); +} + + +void +gfc_resolve_isatty (gfc_expr *f, gfc_expr *u) +{ + gfc_typespec ts; + gfc_clear_ts (&ts); + + f->ts.type = BT_LOGICAL; + f->ts.kind = gfc_default_integer_kind; + if (u->ts.kind != gfc_c_int_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + ts.u.derived = NULL; + ts.u.cl = NULL; + gfc_convert_type (u, &ts, 2); + } + + f->value.function.name = gfc_get_string (PREFIX ("isatty_l%d"), f->ts.kind); +} + + +void +gfc_resolve_ishft (gfc_expr *f, gfc_expr *i, gfc_expr *shift) +{ + f->ts = i->ts; + f->value.function.name + = gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind); +} + + +void +gfc_resolve_rshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift) +{ + f->ts = i->ts; + f->value.function.name + = gfc_get_string ("__rshift_%d_%d", i->ts.kind, shift->ts.kind); +} + + +void +gfc_resolve_lshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift) +{ + f->ts = i->ts; + f->value.function.name + = gfc_get_string ("__lshift_%d_%d", i->ts.kind, shift->ts.kind); +} + + +void +gfc_resolve_ishftc (gfc_expr *f, gfc_expr *i, gfc_expr *shift, gfc_expr *size) +{ + int s_kind; + + s_kind = (size == NULL) ? gfc_default_integer_kind : size->ts.kind; + + f->ts = i->ts; + f->value.function.name + = gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind); +} + + +void +gfc_resolve_kill (gfc_expr *f, gfc_expr *p ATTRIBUTE_UNUSED, + gfc_expr *s ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = gfc_get_string (PREFIX ("kill_i%d"), f->ts.kind); +} + + +void +gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind) +{ + resolve_bound (f, array, dim, kind, "__lbound", false); +} + + +void +gfc_resolve_lcobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind) +{ + resolve_bound (f, array, dim, kind, "__lcobound", true); +} + + +void +gfc_resolve_len (gfc_expr *f, gfc_expr *string, gfc_expr *kind) +{ + f->ts.type = BT_INTEGER; + if (kind) + f->ts.kind = mpz_get_si (kind->value.integer); + else + f->ts.kind = gfc_default_integer_kind; + f->value.function.name + = gfc_get_string ("__len_%d_i%d", string->ts.kind, + gfc_default_integer_kind); +} + + +void +gfc_resolve_len_trim (gfc_expr *f, gfc_expr *string, gfc_expr *kind) +{ + f->ts.type = BT_INTEGER; + if (kind) + f->ts.kind = mpz_get_si (kind->value.integer); + else + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind); +} + + +void +gfc_resolve_lgamma (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__lgamma_%d", x->ts.kind); +} + + +void +gfc_resolve_link (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED, + gfc_expr *p2 ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = gfc_get_string (PREFIX ("link_i%d"), f->ts.kind); +} + + +void +gfc_resolve_loc (gfc_expr *f, gfc_expr *x) +{ + f->ts.type= BT_INTEGER; + f->ts.kind = gfc_index_integer_kind; + f->value.function.name = gfc_get_string ("__loc_%d", x->ts.kind); +} + + +void +gfc_resolve_log (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); +} + + +void +gfc_resolve_log10 (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type), + x->ts.kind); +} + + +void +gfc_resolve_logical (gfc_expr *f, gfc_expr *a, gfc_expr *kind) +{ + f->ts.type = BT_LOGICAL; + f->ts.kind = (kind == NULL) + ? gfc_default_logical_kind : mpz_get_si (kind->value.integer); + f->rank = a->rank; + + f->value.function.name + = gfc_get_string ("__logical_%d_%c%d", f->ts.kind, + gfc_type_letter (a->ts.type), a->ts.kind); +} + + +void +gfc_resolve_malloc (gfc_expr *f, gfc_expr *size) +{ + if (size->ts.kind < gfc_index_integer_kind) + { + gfc_typespec ts; + gfc_clear_ts (&ts); + + ts.type = BT_INTEGER; + ts.kind = gfc_index_integer_kind; + gfc_convert_type_warn (size, &ts, 2, 0); + } + + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_index_integer_kind; + f->value.function.name = gfc_get_string (PREFIX ("malloc")); +} + + +void +gfc_resolve_matmul (gfc_expr *f, gfc_expr *a, gfc_expr *b) +{ + gfc_expr temp; + + if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL) + { + f->ts.type = BT_LOGICAL; + f->ts.kind = gfc_default_logical_kind; + } + else + { + temp.expr_type = EXPR_OP; + gfc_clear_ts (&temp.ts); + temp.value.op.op = INTRINSIC_NONE; + temp.value.op.op1 = a; + temp.value.op.op2 = b; + gfc_type_convert_binary (&temp, 1); + f->ts = temp.ts; + } + + f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1; + + if (a->rank == 2 && b->rank == 2) + { + if (a->shape && b->shape) + { + f->shape = gfc_get_shape (f->rank); + mpz_init_set (f->shape[0], a->shape[0]); + mpz_init_set (f->shape[1], b->shape[1]); + } + } + else if (a->rank == 1) + { + if (b->shape) + { + f->shape = gfc_get_shape (f->rank); + mpz_init_set (f->shape[0], b->shape[1]); + } + } + else + { + /* b->rank == 1 and a->rank == 2 here, all other cases have + been caught in check.c. */ + if (a->shape) + { + f->shape = gfc_get_shape (f->rank); + mpz_init_set (f->shape[0], a->shape[0]); + } + } + + f->value.function.name + = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f->ts.type), + f->ts.kind); +} + + +static void +gfc_resolve_minmax (const char *name, gfc_expr *f, gfc_actual_arglist *args) +{ + gfc_actual_arglist *a; + + f->ts.type = args->expr->ts.type; + f->ts.kind = args->expr->ts.kind; + /* Find the largest type kind. */ + for (a = args->next; a; a = a->next) + { + if (a->expr->ts.kind > f->ts.kind) + f->ts.kind = a->expr->ts.kind; + } + + /* Convert all parameters to the required kind. */ + for (a = args; a; a = a->next) + { + if (a->expr->ts.kind != f->ts.kind) + gfc_convert_type (a->expr, &f->ts, 2); + } + + f->value.function.name + = gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind); +} + + +void +gfc_resolve_max (gfc_expr *f, gfc_actual_arglist *args) +{ + gfc_resolve_minmax ("__max_%c%d", f, args); +} + + +void +gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim, + gfc_expr *mask) +{ + const char *name; + int i, j, idim; + + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + + if (dim == NULL) + { + f->rank = 1; + f->shape = gfc_get_shape (1); + mpz_init_set_si (f->shape[0], array->rank); + } + else + { + f->rank = array->rank - 1; + gfc_resolve_dim_arg (dim); + if (array->shape && dim->expr_type == EXPR_CONSTANT) + { + idim = (int) mpz_get_si (dim->value.integer); + f->shape = gfc_get_shape (f->rank); + for (i = 0, j = 0; i < f->rank; i++, j++) + { + if (i == (idim - 1)) + j++; + mpz_init_set (f->shape[i], array->shape[j]); + } + } + } + + if (mask) + { + if (mask->rank == 0) + name = "smaxloc"; + else + name = "mmaxloc"; + + resolve_mask_arg (mask); + } + else + name = "maxloc"; + + f->value.function.name + = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind, + gfc_type_letter (array->ts.type), array->ts.kind); +} + + +void +gfc_resolve_maxval (gfc_expr *f, gfc_expr *array, gfc_expr *dim, + gfc_expr *mask) +{ + const char *name; + int i, j, idim; + + f->ts = array->ts; + + if (dim != NULL) + { + f->rank = array->rank - 1; + gfc_resolve_dim_arg (dim); + + if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT) + { + idim = (int) mpz_get_si (dim->value.integer); + f->shape = gfc_get_shape (f->rank); + for (i = 0, j = 0; i < f->rank; i++, j++) + { + if (i == (idim - 1)) + j++; + mpz_init_set (f->shape[i], array->shape[j]); + } + } + } + + if (mask) + { + if (mask->rank == 0) + name = "smaxval"; + else + name = "mmaxval"; + + resolve_mask_arg (mask); + } + else + name = "maxval"; + + f->value.function.name + = gfc_get_string (PREFIX ("%s_%c%d"), name, + gfc_type_letter (array->ts.type), array->ts.kind); +} + + +void +gfc_resolve_mclock (gfc_expr *f) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = 4; + f->value.function.name = PREFIX ("mclock"); +} + + +void +gfc_resolve_mclock8 (gfc_expr *f) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = 8; + f->value.function.name = PREFIX ("mclock8"); +} + + +void +gfc_resolve_mask (gfc_expr *f, gfc_expr *i ATTRIBUTE_UNUSED, + gfc_expr *kind) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = kind ? mpz_get_si (kind->value.integer) + : gfc_default_integer_kind; + + if (f->value.function.isym->id == GFC_ISYM_MASKL) + f->value.function.name = gfc_get_string ("__maskl_i%d", f->ts.kind); + else + f->value.function.name = gfc_get_string ("__maskr_i%d", f->ts.kind); +} + + +void +gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource, + gfc_expr *fsource ATTRIBUTE_UNUSED, + gfc_expr *mask ATTRIBUTE_UNUSED) +{ + if (tsource->ts.type == BT_CHARACTER && tsource->ref) + gfc_resolve_substring_charlen (tsource); + + if (fsource->ts.type == BT_CHARACTER && fsource->ref) + gfc_resolve_substring_charlen (fsource); + + if (tsource->ts.type == BT_CHARACTER) + check_charlen_present (tsource); + + f->ts = tsource->ts; + f->value.function.name + = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type), + tsource->ts.kind); +} + + +void +gfc_resolve_merge_bits (gfc_expr *f, gfc_expr *i, + gfc_expr *j ATTRIBUTE_UNUSED, + gfc_expr *mask ATTRIBUTE_UNUSED) +{ + f->ts = i->ts; + f->value.function.name = gfc_get_string ("__merge_bits_i%d", i->ts.kind); +} + + +void +gfc_resolve_min (gfc_expr *f, gfc_actual_arglist *args) +{ + gfc_resolve_minmax ("__min_%c%d", f, args); +} + + +void +gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim, + gfc_expr *mask) +{ + const char *name; + int i, j, idim; + + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + + if (dim == NULL) + { + f->rank = 1; + f->shape = gfc_get_shape (1); + mpz_init_set_si (f->shape[0], array->rank); + } + else + { + f->rank = array->rank - 1; + gfc_resolve_dim_arg (dim); + if (array->shape && dim->expr_type == EXPR_CONSTANT) + { + idim = (int) mpz_get_si (dim->value.integer); + f->shape = gfc_get_shape (f->rank); + for (i = 0, j = 0; i < f->rank; i++, j++) + { + if (i == (idim - 1)) + j++; + mpz_init_set (f->shape[i], array->shape[j]); + } + } + } + + if (mask) + { + if (mask->rank == 0) + name = "sminloc"; + else + name = "mminloc"; + + resolve_mask_arg (mask); + } + else + name = "minloc"; + + f->value.function.name + = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind, + gfc_type_letter (array->ts.type), array->ts.kind); +} + + +void +gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim, + gfc_expr *mask) +{ + const char *name; + int i, j, idim; + + f->ts = array->ts; + + if (dim != NULL) + { + f->rank = array->rank - 1; + gfc_resolve_dim_arg (dim); + + if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT) + { + idim = (int) mpz_get_si (dim->value.integer); + f->shape = gfc_get_shape (f->rank); + for (i = 0, j = 0; i < f->rank; i++, j++) + { + if (i == (idim - 1)) + j++; + mpz_init_set (f->shape[i], array->shape[j]); + } + } + } + + if (mask) + { + if (mask->rank == 0) + name = "sminval"; + else + name = "mminval"; + + resolve_mask_arg (mask); + } + else + name = "minval"; + + f->value.function.name + = gfc_get_string (PREFIX ("%s_%c%d"), name, + gfc_type_letter (array->ts.type), array->ts.kind); +} + + +void +gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p) +{ + f->ts.type = a->ts.type; + if (p != NULL) + f->ts.kind = gfc_kind_max (a,p); + else + f->ts.kind = a->ts.kind; + + if (p != NULL && a->ts.kind != p->ts.kind) + { + if (a->ts.kind == gfc_kind_max (a,p)) + gfc_convert_type (p, &a->ts, 2); + else + gfc_convert_type (a, &p->ts, 2); + } + + f->value.function.name + = gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type), f->ts.kind); +} + + +void +gfc_resolve_modulo (gfc_expr *f, gfc_expr *a, gfc_expr *p) +{ + f->ts.type = a->ts.type; + if (p != NULL) + f->ts.kind = gfc_kind_max (a,p); + else + f->ts.kind = a->ts.kind; + + if (p != NULL && a->ts.kind != p->ts.kind) + { + if (a->ts.kind == gfc_kind_max (a,p)) + gfc_convert_type (p, &a->ts, 2); + else + gfc_convert_type (a, &p->ts, 2); + } + + f->value.function.name + = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type), + f->ts.kind); +} + +void +gfc_resolve_nearest (gfc_expr *f, gfc_expr *a, gfc_expr *p) +{ + if (p->ts.kind != a->ts.kind) + gfc_convert_type (p, &a->ts, 2); + + f->ts = a->ts; + f->value.function.name + = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type), + a->ts.kind); +} + +void +gfc_resolve_nint (gfc_expr *f, gfc_expr *a, gfc_expr *kind) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = (kind == NULL) + ? gfc_default_integer_kind : mpz_get_si (kind->value.integer); + f->value.function.name + = gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind); +} + + +void +gfc_resolve_norm2 (gfc_expr *f, gfc_expr *array, gfc_expr *dim) +{ + resolve_transformational ("norm2", f, array, dim, NULL); +} + + +void +gfc_resolve_not (gfc_expr *f, gfc_expr *i) +{ + f->ts = i->ts; + f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind); +} + + +void +gfc_resolve_or (gfc_expr *f, gfc_expr *i, gfc_expr *j) +{ + f->ts.type = i->ts.type; + f->ts.kind = gfc_kind_max (i, j); + + if (i->ts.kind != j->ts.kind) + { + if (i->ts.kind == gfc_kind_max (i, j)) + gfc_convert_type (j, &i->ts, 2); + else + gfc_convert_type (i, &j->ts, 2); + } + + f->value.function.name + = gfc_get_string ("__or_%c%d", gfc_type_letter (i->ts.type), f->ts.kind); +} + + +void +gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask, + gfc_expr *vector ATTRIBUTE_UNUSED) +{ + if (array->ts.type == BT_CHARACTER && array->ref) + gfc_resolve_substring_charlen (array); + + f->ts = array->ts; + f->rank = 1; + + resolve_mask_arg (mask); + + if (mask->rank != 0) + { + if (array->ts.type == BT_CHARACTER) + f->value.function.name + = array->ts.kind == 1 ? PREFIX ("pack_char") + : gfc_get_string + (PREFIX ("pack_char%d"), + array->ts.kind); + else + f->value.function.name = PREFIX ("pack"); + } + else + { + if (array->ts.type == BT_CHARACTER) + f->value.function.name + = array->ts.kind == 1 ? PREFIX ("pack_s_char") + : gfc_get_string + (PREFIX ("pack_s_char%d"), + array->ts.kind); + else + f->value.function.name = PREFIX ("pack_s"); + } +} + + +void +gfc_resolve_parity (gfc_expr *f, gfc_expr *array, gfc_expr *dim) +{ + resolve_transformational ("parity", f, array, dim, NULL); +} + + +void +gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim, + gfc_expr *mask) +{ + resolve_transformational ("product", f, array, dim, mask); +} + + +void +gfc_resolve_real (gfc_expr *f, gfc_expr *a, gfc_expr *kind) +{ + f->ts.type = BT_REAL; + + if (kind != NULL) + f->ts.kind = mpz_get_si (kind->value.integer); + else + f->ts.kind = (a->ts.type == BT_COMPLEX) + ? a->ts.kind : gfc_default_real_kind; + + f->value.function.name + = gfc_get_string ("__real_%d_%c%d", f->ts.kind, + gfc_type_letter (a->ts.type), a->ts.kind); +} + + +void +gfc_resolve_realpart (gfc_expr *f, gfc_expr *a) +{ + f->ts.type = BT_REAL; + f->ts.kind = a->ts.kind; + f->value.function.name + = gfc_get_string ("__real_%d_%c%d", f->ts.kind, + gfc_type_letter (a->ts.type), a->ts.kind); +} + + +void +gfc_resolve_rename (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED, + gfc_expr *p2 ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = gfc_get_string (PREFIX ("rename_i%d"), f->ts.kind); +} + + +void +gfc_resolve_repeat (gfc_expr *f, gfc_expr *string, + gfc_expr *ncopies) +{ + int len; + gfc_expr *tmp; + f->ts.type = BT_CHARACTER; + f->ts.kind = string->ts.kind; + f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind); + + /* If possible, generate a character length. */ + if (f->ts.u.cl == NULL) + f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); + + tmp = NULL; + if (string->expr_type == EXPR_CONSTANT) + { + len = string->value.character.length; + tmp = gfc_get_int_expr (gfc_default_integer_kind, NULL , len); + } + else if (string->ts.u.cl && string->ts.u.cl->length) + { + tmp = gfc_copy_expr (string->ts.u.cl->length); + } + + if (tmp) + f->ts.u.cl->length = gfc_multiply (tmp, gfc_copy_expr (ncopies)); +} + + +void +gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape, + gfc_expr *pad ATTRIBUTE_UNUSED, + gfc_expr *order ATTRIBUTE_UNUSED) +{ + mpz_t rank; + int kind; + int i; + + if (source->ts.type == BT_CHARACTER && source->ref) + gfc_resolve_substring_charlen (source); + + f->ts = source->ts; + + gfc_array_size (shape, &rank); + f->rank = mpz_get_si (rank); + mpz_clear (rank); + switch (source->ts.type) + { + case BT_COMPLEX: + case BT_REAL: + case BT_INTEGER: + case BT_LOGICAL: + case BT_CHARACTER: + kind = source->ts.kind; + break; + + default: + kind = 0; + break; + } + + switch (kind) + { + case 4: + case 8: + case 10: + case 16: + if (source->ts.type == BT_COMPLEX || source->ts.type == BT_REAL) + f->value.function.name + = gfc_get_string (PREFIX ("reshape_%c%d"), + gfc_type_letter (source->ts.type), + source->ts.kind); + else if (source->ts.type == BT_CHARACTER) + f->value.function.name = gfc_get_string (PREFIX ("reshape_char%d"), + kind); + else + f->value.function.name + = gfc_get_string (PREFIX ("reshape_%d"), source->ts.kind); + break; + + default: + f->value.function.name = (source->ts.type == BT_CHARACTER + ? PREFIX ("reshape_char") : PREFIX ("reshape")); + break; + } + + /* TODO: Make this work with a constant ORDER parameter. */ + if (shape->expr_type == EXPR_ARRAY + && gfc_is_constant_expr (shape) + && order == NULL) + { + gfc_constructor *c; + f->shape = gfc_get_shape (f->rank); + c = gfc_constructor_first (shape->value.constructor); + for (i = 0; i < f->rank; i++) + { + mpz_init_set (f->shape[i], c->expr->value.integer); + c = gfc_constructor_next (c); + } + } + + /* Force-convert both SHAPE and ORDER to index_kind so that we don't need + so many runtime variations. */ + if (shape->ts.kind != gfc_index_integer_kind) + { + gfc_typespec ts = shape->ts; + ts.kind = gfc_index_integer_kind; + gfc_convert_type_warn (shape, &ts, 2, 0); + } + if (order && order->ts.kind != gfc_index_integer_kind) + gfc_convert_type_warn (order, &shape->ts, 2, 0); +} + + +void +gfc_resolve_rrspacing (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind); +} + + +void +gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i ATTRIBUTE_UNUSED) +{ + f->ts = x->ts; + f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind); +} + + +void +gfc_resolve_scan (gfc_expr *f, gfc_expr *string, + gfc_expr *set ATTRIBUTE_UNUSED, + gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind) +{ + f->ts.type = BT_INTEGER; + if (kind) + f->ts.kind = mpz_get_si (kind->value.integer); + else + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind); +} + + +void +gfc_resolve_secnds (gfc_expr *t1, gfc_expr *t0) +{ + t1->ts = t0->ts; + t1->value.function.name = gfc_get_string (PREFIX ("secnds")); +} + + +void +gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x, + gfc_expr *i ATTRIBUTE_UNUSED) +{ + f->ts = x->ts; + f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind); +} + + +void +gfc_resolve_shape (gfc_expr *f, gfc_expr *array, gfc_expr *kind) +{ + f->ts.type = BT_INTEGER; + + if (kind) + f->ts.kind = mpz_get_si (kind->value.integer); + else + f->ts.kind = gfc_default_integer_kind; + + f->rank = 1; + f->shape = gfc_get_shape (1); + mpz_init_set_ui (f->shape[0], array->rank); + f->value.function.name = gfc_get_string (PREFIX ("shape_%d"), f->ts.kind); +} + + +void +gfc_resolve_shift (gfc_expr *f, gfc_expr *i, gfc_expr *shift ATTRIBUTE_UNUSED) +{ + f->ts = i->ts; + if (f->value.function.isym->id == GFC_ISYM_SHIFTA) + f->value.function.name = gfc_get_string ("shifta_i%d", f->ts.kind); + else if (f->value.function.isym->id == GFC_ISYM_SHIFTL) + f->value.function.name = gfc_get_string ("shiftl_i%d", f->ts.kind); + else if (f->value.function.isym->id == GFC_ISYM_SHIFTR) + f->value.function.name = gfc_get_string ("shiftr_i%d", f->ts.kind); + else + gcc_unreachable (); +} + + +void +gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b ATTRIBUTE_UNUSED) +{ + f->ts = a->ts; + f->value.function.name + = gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind); +} + + +void +gfc_resolve_signal (gfc_expr *f, gfc_expr *number, gfc_expr *handler) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_c_int_kind; + + /* handler can be either BT_INTEGER or BT_PROCEDURE */ + if (handler->ts.type == BT_INTEGER) + { + if (handler->ts.kind != gfc_c_int_kind) + gfc_convert_type (handler, &f->ts, 2); + f->value.function.name = gfc_get_string (PREFIX ("signal_func_int")); + } + else + f->value.function.name = gfc_get_string (PREFIX ("signal_func")); + + if (number->ts.kind != gfc_c_int_kind) + gfc_convert_type (number, &f->ts, 2); +} + + +void +gfc_resolve_sin (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); +} + + +void +gfc_resolve_sinh (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); +} + + +void +gfc_resolve_size (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED, + gfc_expr *dim ATTRIBUTE_UNUSED, gfc_expr *kind) +{ + f->ts.type = BT_INTEGER; + if (kind) + f->ts.kind = mpz_get_si (kind->value.integer); + else + f->ts.kind = gfc_default_integer_kind; +} + + +void +gfc_resolve_spacing (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind); +} + + +void +gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim, + gfc_expr *ncopies) +{ + if (source->ts.type == BT_CHARACTER && source->ref) + gfc_resolve_substring_charlen (source); + + if (source->ts.type == BT_CHARACTER) + check_charlen_present (source); + + f->ts = source->ts; + f->rank = source->rank + 1; + if (source->rank == 0) + { + if (source->ts.type == BT_CHARACTER) + f->value.function.name + = source->ts.kind == 1 ? PREFIX ("spread_char_scalar") + : gfc_get_string + (PREFIX ("spread_char%d_scalar"), + source->ts.kind); + else + f->value.function.name = PREFIX ("spread_scalar"); + } + else + { + if (source->ts.type == BT_CHARACTER) + f->value.function.name + = source->ts.kind == 1 ? PREFIX ("spread_char") + : gfc_get_string + (PREFIX ("spread_char%d"), + source->ts.kind); + else + f->value.function.name = PREFIX ("spread"); + } + + if (dim && gfc_is_constant_expr (dim) + && ncopies && gfc_is_constant_expr (ncopies) && source->shape[0]) + { + int i, idim; + idim = mpz_get_ui (dim->value.integer); + f->shape = gfc_get_shape (f->rank); + for (i = 0; i < (idim - 1); i++) + mpz_init_set (f->shape[i], source->shape[i]); + + mpz_init_set (f->shape[idim - 1], ncopies->value.integer); + + for (i = idim; i < f->rank ; i++) + mpz_init_set (f->shape[i], source->shape[i-1]); + } + + + gfc_resolve_dim_arg (dim); + gfc_resolve_index (ncopies, 1); +} + + +void +gfc_resolve_sqrt (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); +} + + +/* Resolve the g77 compatibility function STAT AND FSTAT. */ + +void +gfc_resolve_stat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED, + gfc_expr *a ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = gfc_get_string (PREFIX ("stat_i%d"), f->ts.kind); +} + + +void +gfc_resolve_lstat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED, + gfc_expr *a ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = gfc_get_string (PREFIX ("lstat_i%d"), f->ts.kind); +} + + +void +gfc_resolve_fstat (gfc_expr *f, gfc_expr *n, gfc_expr *a ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + if (n->ts.kind != f->ts.kind) + gfc_convert_type (n, &f->ts, 2); + + f->value.function.name = gfc_get_string (PREFIX ("fstat_i%d"), f->ts.kind); +} + + +void +gfc_resolve_fgetc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED) +{ + gfc_typespec ts; + gfc_clear_ts (&ts); + + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_c_int_kind; + if (u->ts.kind != gfc_c_int_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + ts.u.derived = NULL; + ts.u.cl = NULL; + gfc_convert_type (u, &ts, 2); + } + + f->value.function.name = gfc_get_string (PREFIX ("fgetc")); +} + + +void +gfc_resolve_fget (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_c_int_kind; + f->value.function.name = gfc_get_string (PREFIX ("fget")); +} + + +void +gfc_resolve_fputc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED) +{ + gfc_typespec ts; + gfc_clear_ts (&ts); + + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_c_int_kind; + if (u->ts.kind != gfc_c_int_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + ts.u.derived = NULL; + ts.u.cl = NULL; + gfc_convert_type (u, &ts, 2); + } + + f->value.function.name = gfc_get_string (PREFIX ("fputc")); +} + + +void +gfc_resolve_fput (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_c_int_kind; + f->value.function.name = gfc_get_string (PREFIX ("fput")); +} + + +void +gfc_resolve_ftell (gfc_expr *f, gfc_expr *u) +{ + gfc_typespec ts; + gfc_clear_ts (&ts); + + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_index_integer_kind; + if (u->ts.kind != gfc_c_int_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + ts.u.derived = NULL; + ts.u.cl = NULL; + gfc_convert_type (u, &ts, 2); + } + + f->value.function.name = gfc_get_string (PREFIX ("ftell")); +} + + +void +gfc_resolve_storage_size (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED, + gfc_expr *kind) +{ + f->ts.type = BT_INTEGER; + if (kind) + f->ts.kind = mpz_get_si (kind->value.integer); + else + f->ts.kind = gfc_default_integer_kind; +} + + +void +gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask) +{ + resolve_transformational ("sum", f, array, dim, mask); +} + + +void +gfc_resolve_symlnk (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED, + gfc_expr *p2 ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = gfc_get_string (PREFIX ("symlnk_i%d"), f->ts.kind); +} + + +/* Resolve the g77 compatibility function SYSTEM. */ + +void +gfc_resolve_system (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = 4; + f->value.function.name = gfc_get_string (PREFIX ("system")); +} + + +void +gfc_resolve_tan (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); +} + + +void +gfc_resolve_tanh (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); +} + + +void +gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED, + gfc_expr *sub ATTRIBUTE_UNUSED) +{ + static char this_image[] = "__image_index"; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = this_image; +} + + +void +gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim) +{ + resolve_bound (f, array, dim, NULL, "__this_image", true); +} + + +void +gfc_resolve_time (gfc_expr *f) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = 4; + f->value.function.name = gfc_get_string (PREFIX ("time_func")); +} + + +void +gfc_resolve_time8 (gfc_expr *f) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = 8; + f->value.function.name = gfc_get_string (PREFIX ("time8_func")); +} + + +void +gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED, + gfc_expr *mold, gfc_expr *size) +{ + /* TODO: Make this do something meaningful. */ + static char transfer0[] = "__transfer0", transfer1[] = "__transfer1"; + + if (mold->ts.type == BT_CHARACTER + && !mold->ts.u.cl->length + && gfc_is_constant_expr (mold)) + { + int len; + if (mold->expr_type == EXPR_CONSTANT) + { + len = mold->value.character.length; + mold->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, + NULL, len); + } + else + { + gfc_constructor *c = gfc_constructor_first (mold->value.constructor); + len = c->expr->value.character.length; + mold->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, + NULL, len); + } + } + + f->ts = mold->ts; + + if (size == NULL && mold->rank == 0) + { + f->rank = 0; + f->value.function.name = transfer0; + } + else + { + f->rank = 1; + f->value.function.name = transfer1; + if (size && gfc_is_constant_expr (size)) + { + f->shape = gfc_get_shape (1); + mpz_init_set (f->shape[0], size->value.integer); + } + } +} + + +void +gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix) +{ + + if (matrix->ts.type == BT_CHARACTER && matrix->ref) + gfc_resolve_substring_charlen (matrix); + + f->ts = matrix->ts; + f->rank = 2; + if (matrix->shape) + { + f->shape = gfc_get_shape (2); + mpz_init_set (f->shape[0], matrix->shape[1]); + mpz_init_set (f->shape[1], matrix->shape[0]); + } + + switch (matrix->ts.kind) + { + case 4: + case 8: + case 10: + case 16: + switch (matrix->ts.type) + { + case BT_REAL: + case BT_COMPLEX: + f->value.function.name + = gfc_get_string (PREFIX ("transpose_%c%d"), + gfc_type_letter (matrix->ts.type), + matrix->ts.kind); + break; + + case BT_INTEGER: + case BT_LOGICAL: + /* Use the integer routines for real and logical cases. This + assumes they all have the same alignment requirements. */ + f->value.function.name + = gfc_get_string (PREFIX ("transpose_i%d"), matrix->ts.kind); + break; + + default: + if (matrix->ts.type == BT_CHARACTER && matrix->ts.kind == 4) + f->value.function.name = PREFIX ("transpose_char4"); + else + f->value.function.name = PREFIX ("transpose"); + break; + } + break; + + default: + f->value.function.name = (matrix->ts.type == BT_CHARACTER + ? PREFIX ("transpose_char") + : PREFIX ("transpose")); + break; + } +} + + +void +gfc_resolve_trim (gfc_expr *f, gfc_expr *string) +{ + f->ts.type = BT_CHARACTER; + f->ts.kind = string->ts.kind; + f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind); +} + + +void +gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind) +{ + resolve_bound (f, array, dim, kind, "__ubound", false); +} + + +void +gfc_resolve_ucobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind) +{ + resolve_bound (f, array, dim, kind, "__ucobound", true); +} + + +/* Resolve the g77 compatibility function UMASK. */ + +void +gfc_resolve_umask (gfc_expr *f, gfc_expr *n) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = n->ts.kind; + f->value.function.name = gfc_get_string (PREFIX ("umask_i%d"), n->ts.kind); +} + + +/* Resolve the g77 compatibility function UNLINK. */ + +void +gfc_resolve_unlink (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = 4; + f->value.function.name = gfc_get_string (PREFIX ("unlink")); +} + + +void +gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit) +{ + gfc_typespec ts; + gfc_clear_ts (&ts); + + f->ts.type = BT_CHARACTER; + f->ts.kind = gfc_default_character_kind; + + if (unit->ts.kind != gfc_c_int_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + ts.u.derived = NULL; + ts.u.cl = NULL; + gfc_convert_type (unit, &ts, 2); + } + + f->value.function.name = gfc_get_string (PREFIX ("ttynam")); +} + + +void +gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask, + gfc_expr *field ATTRIBUTE_UNUSED) +{ + if (vector->ts.type == BT_CHARACTER && vector->ref) + gfc_resolve_substring_charlen (vector); + + f->ts = vector->ts; + f->rank = mask->rank; + resolve_mask_arg (mask); + + if (vector->ts.type == BT_CHARACTER) + { + if (vector->ts.kind == 1) + f->value.function.name + = gfc_get_string (PREFIX ("unpack%d_char"), field->rank > 0 ? 1 : 0); + else + f->value.function.name + = gfc_get_string (PREFIX ("unpack%d_char%d"), + field->rank > 0 ? 1 : 0, vector->ts.kind); + } + else + f->value.function.name + = gfc_get_string (PREFIX ("unpack%d"), field->rank > 0 ? 1 : 0); +} + + +void +gfc_resolve_verify (gfc_expr *f, gfc_expr *string, + gfc_expr *set ATTRIBUTE_UNUSED, + gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind) +{ + f->ts.type = BT_INTEGER; + if (kind) + f->ts.kind = mpz_get_si (kind->value.integer); + else + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind); +} + + +void +gfc_resolve_xor (gfc_expr *f, gfc_expr *i, gfc_expr *j) +{ + f->ts.type = i->ts.type; + f->ts.kind = gfc_kind_max (i, j); + + if (i->ts.kind != j->ts.kind) + { + if (i->ts.kind == gfc_kind_max (i, j)) + gfc_convert_type (j, &i->ts, 2); + else + gfc_convert_type (i, &j->ts, 2); + } + + f->value.function.name + = gfc_get_string ("__xor_%c%d", gfc_type_letter (i->ts.type), f->ts.kind); +} + + +/* Intrinsic subroutine resolution. */ + +void +gfc_resolve_alarm_sub (gfc_code *c) +{ + const char *name; + gfc_expr *seconds, *handler; + gfc_typespec ts; + gfc_clear_ts (&ts); + + seconds = c->ext.actual->expr; + handler = c->ext.actual->next->expr; + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + + /* handler can be either BT_INTEGER or BT_PROCEDURE. + In all cases, the status argument is of default integer kind + (enforced in check.c) so that the function suffix is fixed. */ + if (handler->ts.type == BT_INTEGER) + { + if (handler->ts.kind != gfc_c_int_kind) + gfc_convert_type (handler, &ts, 2); + name = gfc_get_string (PREFIX ("alarm_sub_int_i%d"), + gfc_default_integer_kind); + } + else + name = gfc_get_string (PREFIX ("alarm_sub_i%d"), + gfc_default_integer_kind); + + if (seconds->ts.kind != gfc_c_int_kind) + gfc_convert_type (seconds, &ts, 2); + + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + +void +gfc_resolve_cpu_time (gfc_code *c) +{ + const char *name; + name = gfc_get_string (PREFIX ("cpu_time_%d"), c->ext.actual->expr->ts.kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +/* Create a formal arglist based on an actual one and set the INTENTs given. */ + +static gfc_formal_arglist* +create_formal_for_intents (gfc_actual_arglist* actual, const sym_intent* ints) +{ + gfc_formal_arglist* head; + gfc_formal_arglist* tail; + int i; + + if (!actual) + return NULL; + + head = tail = gfc_get_formal_arglist (); + for (i = 0; actual; actual = actual->next, tail = tail->next, ++i) + { + gfc_symbol* sym; + + sym = gfc_new_symbol ("dummyarg", NULL); + sym->ts = actual->expr->ts; + + sym->attr.intent = ints[i]; + tail->sym = sym; + + if (actual->next) + tail->next = gfc_get_formal_arglist (); + } + + return head; +} + + +void +gfc_resolve_mvbits (gfc_code *c) +{ + static const sym_intent INTENTS[] = {INTENT_IN, INTENT_IN, INTENT_IN, + INTENT_INOUT, INTENT_IN}; + + const char *name; + gfc_typespec ts; + gfc_clear_ts (&ts); + + /* FROMPOS, LEN and TOPOS are restricted to small values. As such, + they will be converted so that they fit into a C int. */ + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + if (c->ext.actual->next->expr->ts.kind != gfc_c_int_kind) + gfc_convert_type (c->ext.actual->next->expr, &ts, 2); + if (c->ext.actual->next->next->expr->ts.kind != gfc_c_int_kind) + gfc_convert_type (c->ext.actual->next->next->expr, &ts, 2); + if (c->ext.actual->next->next->next->next->expr->ts.kind != gfc_c_int_kind) + gfc_convert_type (c->ext.actual->next->next->next->next->expr, &ts, 2); + + /* TO and FROM are guaranteed to have the same kind parameter. */ + name = gfc_get_string (PREFIX ("mvbits_i%d"), + c->ext.actual->expr->ts.kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); + /* Mark as elemental subroutine as this does not happen automatically. */ + c->resolved_sym->attr.elemental = 1; + + /* Create a dummy formal arglist so the INTENTs are known later for purpose + of creating temporaries. */ + c->resolved_sym->formal = create_formal_for_intents (c->ext.actual, INTENTS); +} + + +void +gfc_resolve_random_number (gfc_code *c) +{ + const char *name; + int kind; + + kind = c->ext.actual->expr->ts.kind; + if (c->ext.actual->expr->rank == 0) + name = gfc_get_string (PREFIX ("random_r%d"), kind); + else + name = gfc_get_string (PREFIX ("arandom_r%d"), kind); + + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_random_seed (gfc_code *c) +{ + const char *name; + + name = gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_rename_sub (gfc_code *c) +{ + const char *name; + int kind; + + if (c->ext.actual->next->next->expr != NULL) + kind = c->ext.actual->next->next->expr->ts.kind; + else + kind = gfc_default_integer_kind; + + name = gfc_get_string (PREFIX ("rename_i%d_sub"), kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_kill_sub (gfc_code *c) +{ + const char *name; + int kind; + + if (c->ext.actual->next->next->expr != NULL) + kind = c->ext.actual->next->next->expr->ts.kind; + else + kind = gfc_default_integer_kind; + + name = gfc_get_string (PREFIX ("kill_i%d_sub"), kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_link_sub (gfc_code *c) +{ + const char *name; + int kind; + + if (c->ext.actual->next->next->expr != NULL) + kind = c->ext.actual->next->next->expr->ts.kind; + else + kind = gfc_default_integer_kind; + + name = gfc_get_string (PREFIX ("link_i%d_sub"), kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_symlnk_sub (gfc_code *c) +{ + const char *name; + int kind; + + if (c->ext.actual->next->next->expr != NULL) + kind = c->ext.actual->next->next->expr->ts.kind; + else + kind = gfc_default_integer_kind; + + name = gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +/* G77 compatibility subroutines dtime() and etime(). */ + +void +gfc_resolve_dtime_sub (gfc_code *c) +{ + const char *name; + name = gfc_get_string (PREFIX ("dtime_sub")); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + +void +gfc_resolve_etime_sub (gfc_code *c) +{ + const char *name; + name = gfc_get_string (PREFIX ("etime_sub")); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +/* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */ + +void +gfc_resolve_itime (gfc_code *c) +{ + c->resolved_sym + = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"), + gfc_default_integer_kind)); +} + +void +gfc_resolve_idate (gfc_code *c) +{ + c->resolved_sym + = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"), + gfc_default_integer_kind)); +} + +void +gfc_resolve_ltime (gfc_code *c) +{ + c->resolved_sym + = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"), + gfc_default_integer_kind)); +} + +void +gfc_resolve_gmtime (gfc_code *c) +{ + c->resolved_sym + = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"), + gfc_default_integer_kind)); +} + + +/* G77 compatibility subroutine second(). */ + +void +gfc_resolve_second_sub (gfc_code *c) +{ + const char *name; + name = gfc_get_string (PREFIX ("second_sub")); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_sleep_sub (gfc_code *c) +{ + const char *name; + int kind; + + if (c->ext.actual->expr != NULL) + kind = c->ext.actual->expr->ts.kind; + else + kind = gfc_default_integer_kind; + + name = gfc_get_string (PREFIX ("sleep_i%d_sub"), kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +/* G77 compatibility function srand(). */ + +void +gfc_resolve_srand (gfc_code *c) +{ + const char *name; + name = gfc_get_string (PREFIX ("srand")); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +/* Resolve the getarg intrinsic subroutine. */ + +void +gfc_resolve_getarg (gfc_code *c) +{ + const char *name; + + if (c->ext.actual->expr->ts.kind != gfc_default_integer_kind) + { + gfc_typespec ts; + gfc_clear_ts (&ts); + + ts.type = BT_INTEGER; + ts.kind = gfc_default_integer_kind; + + gfc_convert_type (c->ext.actual->expr, &ts, 2); + } + + name = gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +/* Resolve the getcwd intrinsic subroutine. */ + +void +gfc_resolve_getcwd_sub (gfc_code *c) +{ + const char *name; + int kind; + + if (c->ext.actual->next->expr != NULL) + kind = c->ext.actual->next->expr->ts.kind; + else + kind = gfc_default_integer_kind; + + name = gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +/* Resolve the get_command intrinsic subroutine. */ + +void +gfc_resolve_get_command (gfc_code *c) +{ + const char *name; + int kind; + kind = gfc_default_integer_kind; + name = gfc_get_string (PREFIX ("get_command_i%d"), kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +/* Resolve the get_command_argument intrinsic subroutine. */ + +void +gfc_resolve_get_command_argument (gfc_code *c) +{ + const char *name; + int kind; + kind = gfc_default_integer_kind; + name = gfc_get_string (PREFIX ("get_command_argument_i%d"), kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +/* Resolve the get_environment_variable intrinsic subroutine. */ + +void +gfc_resolve_get_environment_variable (gfc_code *code) +{ + const char *name; + int kind; + kind = gfc_default_integer_kind; + name = gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind); + code->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_signal_sub (gfc_code *c) +{ + const char *name; + gfc_expr *number, *handler, *status; + gfc_typespec ts; + gfc_clear_ts (&ts); + + number = c->ext.actual->expr; + handler = c->ext.actual->next->expr; + status = c->ext.actual->next->next->expr; + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + + /* handler can be either BT_INTEGER or BT_PROCEDURE */ + if (handler->ts.type == BT_INTEGER) + { + if (handler->ts.kind != gfc_c_int_kind) + gfc_convert_type (handler, &ts, 2); + name = gfc_get_string (PREFIX ("signal_sub_int")); + } + else + name = gfc_get_string (PREFIX ("signal_sub")); + + if (number->ts.kind != gfc_c_int_kind) + gfc_convert_type (number, &ts, 2); + if (status != NULL && status->ts.kind != gfc_c_int_kind) + gfc_convert_type (status, &ts, 2); + + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +/* Resolve the SYSTEM intrinsic subroutine. */ + +void +gfc_resolve_system_sub (gfc_code *c) +{ + const char *name; + name = gfc_get_string (PREFIX ("system_sub")); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +/* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */ + +void +gfc_resolve_system_clock (gfc_code *c) +{ + const char *name; + int kind; + + if (c->ext.actual->expr != NULL) + kind = c->ext.actual->expr->ts.kind; + else if (c->ext.actual->next->expr != NULL) + kind = c->ext.actual->next->expr->ts.kind; + else if (c->ext.actual->next->next->expr != NULL) + kind = c->ext.actual->next->next->expr->ts.kind; + else + kind = gfc_default_integer_kind; + + name = gfc_get_string (PREFIX ("system_clock_%d"), kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +/* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine. */ +void +gfc_resolve_execute_command_line (gfc_code *c) +{ + const char *name; + name = gfc_get_string (PREFIX ("execute_command_line_i%d"), + gfc_default_integer_kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +/* Resolve the EXIT intrinsic subroutine. */ + +void +gfc_resolve_exit (gfc_code *c) +{ + const char *name; + gfc_typespec ts; + gfc_expr *n; + gfc_clear_ts (&ts); + + /* The STATUS argument has to be of default kind. If it is not, + we convert it. */ + ts.type = BT_INTEGER; + ts.kind = gfc_default_integer_kind; + n = c->ext.actual->expr; + if (n != NULL && n->ts.kind != ts.kind) + gfc_convert_type (n, &ts, 2); + + name = gfc_get_string (PREFIX ("exit_i%d"), ts.kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +/* Resolve the FLUSH intrinsic subroutine. */ + +void +gfc_resolve_flush (gfc_code *c) +{ + const char *name; + gfc_typespec ts; + gfc_expr *n; + gfc_clear_ts (&ts); + + ts.type = BT_INTEGER; + ts.kind = gfc_default_integer_kind; + n = c->ext.actual->expr; + if (n != NULL && n->ts.kind != ts.kind) + gfc_convert_type (n, &ts, 2); + + name = gfc_get_string (PREFIX ("flush_i%d"), ts.kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_free (gfc_code *c) +{ + gfc_typespec ts; + gfc_expr *n; + gfc_clear_ts (&ts); + + ts.type = BT_INTEGER; + ts.kind = gfc_index_integer_kind; + n = c->ext.actual->expr; + if (n->ts.kind != ts.kind) + gfc_convert_type (n, &ts, 2); + + c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("free")); +} + + +void +gfc_resolve_ctime_sub (gfc_code *c) +{ + gfc_typespec ts; + gfc_clear_ts (&ts); + + /* ctime TIME argument is a INTEGER(KIND=8), says the doc */ + if (c->ext.actual->expr->ts.kind != 8) + { + ts.type = BT_INTEGER; + ts.kind = 8; + ts.u.derived = NULL; + ts.u.cl = NULL; + gfc_convert_type (c->ext.actual->expr, &ts, 2); + } + + c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub")); +} + + +void +gfc_resolve_fdate_sub (gfc_code *c) +{ + c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub")); +} + + +void +gfc_resolve_gerror (gfc_code *c) +{ + c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror")); +} + + +void +gfc_resolve_getlog (gfc_code *c) +{ + c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog")); +} + + +void +gfc_resolve_hostnm_sub (gfc_code *c) +{ + const char *name; + int kind; + + if (c->ext.actual->next->expr != NULL) + kind = c->ext.actual->next->expr->ts.kind; + else + kind = gfc_default_integer_kind; + + name = gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_perror (gfc_code *c) +{ + c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub")); +} + +/* Resolve the STAT and FSTAT intrinsic subroutines. */ + +void +gfc_resolve_stat_sub (gfc_code *c) +{ + const char *name; + name = gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_lstat_sub (gfc_code *c) +{ + const char *name; + name = gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_fstat_sub (gfc_code *c) +{ + const char *name; + gfc_expr *u; + gfc_typespec *ts; + + u = c->ext.actual->expr; + ts = &c->ext.actual->next->expr->ts; + if (u->ts.kind != ts->kind) + gfc_convert_type (u, ts, 2); + name = gfc_get_string (PREFIX ("fstat_i%d_sub"), ts->kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_fgetc_sub (gfc_code *c) +{ + const char *name; + gfc_typespec ts; + gfc_expr *u, *st; + gfc_clear_ts (&ts); + + u = c->ext.actual->expr; + st = c->ext.actual->next->next->expr; + + if (u->ts.kind != gfc_c_int_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + ts.u.derived = NULL; + ts.u.cl = NULL; + gfc_convert_type (u, &ts, 2); + } + + if (st != NULL) + name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), st->ts.kind); + else + name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind); + + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_fget_sub (gfc_code *c) +{ + const char *name; + gfc_expr *st; + + st = c->ext.actual->next->expr; + if (st != NULL) + name = gfc_get_string (PREFIX ("fget_i%d_sub"), st->ts.kind); + else + name = gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind); + + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_fputc_sub (gfc_code *c) +{ + const char *name; + gfc_typespec ts; + gfc_expr *u, *st; + gfc_clear_ts (&ts); + + u = c->ext.actual->expr; + st = c->ext.actual->next->next->expr; + + if (u->ts.kind != gfc_c_int_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + ts.u.derived = NULL; + ts.u.cl = NULL; + gfc_convert_type (u, &ts, 2); + } + + if (st != NULL) + name = gfc_get_string (PREFIX ("fputc_i%d_sub"), st->ts.kind); + else + name = gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind); + + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_fput_sub (gfc_code *c) +{ + const char *name; + gfc_expr *st; + + st = c->ext.actual->next->expr; + if (st != NULL) + name = gfc_get_string (PREFIX ("fput_i%d_sub"), st->ts.kind); + else + name = gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind); + + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_fseek_sub (gfc_code *c) +{ + gfc_expr *unit; + gfc_expr *offset; + gfc_expr *whence; + gfc_typespec ts; + gfc_clear_ts (&ts); + + unit = c->ext.actual->expr; + offset = c->ext.actual->next->expr; + whence = c->ext.actual->next->next->expr; + + if (unit->ts.kind != gfc_c_int_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + ts.u.derived = NULL; + ts.u.cl = NULL; + gfc_convert_type (unit, &ts, 2); + } + + if (offset->ts.kind != gfc_intio_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_intio_kind; + ts.u.derived = NULL; + ts.u.cl = NULL; + gfc_convert_type (offset, &ts, 2); + } + + if (whence->ts.kind != gfc_c_int_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + ts.u.derived = NULL; + ts.u.cl = NULL; + gfc_convert_type (whence, &ts, 2); + } + + c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub")); +} + +void +gfc_resolve_ftell_sub (gfc_code *c) +{ + const char *name; + gfc_expr *unit; + gfc_expr *offset; + gfc_typespec ts; + gfc_clear_ts (&ts); + + unit = c->ext.actual->expr; + offset = c->ext.actual->next->expr; + + if (unit->ts.kind != gfc_c_int_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + ts.u.derived = NULL; + ts.u.cl = NULL; + gfc_convert_type (unit, &ts, 2); + } + + name = gfc_get_string (PREFIX ("ftell_i%d_sub"), offset->ts.kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_ttynam_sub (gfc_code *c) +{ + gfc_typespec ts; + gfc_clear_ts (&ts); + + if (c->ext.actual->expr->ts.kind != gfc_c_int_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + ts.u.derived = NULL; + ts.u.cl = NULL; + gfc_convert_type (c->ext.actual->expr, &ts, 2); + } + + c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub")); +} + + +/* Resolve the UMASK intrinsic subroutine. */ + +void +gfc_resolve_umask_sub (gfc_code *c) +{ + const char *name; + int kind; + + if (c->ext.actual->next->expr != NULL) + kind = c->ext.actual->next->expr->ts.kind; + else + kind = gfc_default_integer_kind; + + name = gfc_get_string (PREFIX ("umask_i%d_sub"), kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + +/* Resolve the UNLINK intrinsic subroutine. */ + +void +gfc_resolve_unlink_sub (gfc_code *c) +{ + const char *name; + int kind; + + if (c->ext.actual->next->expr != NULL) + kind = c->ext.actual->next->expr->ts.kind; + else + kind = gfc_default_integer_kind; + + name = gfc_get_string (PREFIX ("unlink_i%d_sub"), kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} -- cgit v1.2.3