/* Intrinsic function resolution.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
Free Software Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb
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 2, or (at your option) any later
+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
for more details.
You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
-02110-1301, USA. */
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
/* Assign name and types to intrinsic procedures. For functions, the
#include "gfortran.h"
#include "intrinsic.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
tree ident;
va_start (ap, format);
- vsnprintf (temp_name, sizeof(temp_name), format, ap);
+ vsnprintf (temp_name, sizeof (temp_name), format, ap);
va_end (ap);
- temp_name[sizeof(temp_name)-1] = 0;
+ temp_name[sizeof (temp_name) - 1] = 0;
ident = get_identifier (temp_name);
return IDENTIFIER_POINTER (ident);
}
}
+/* Helper function for resolving the "mask" argument. */
+
+static void
+resolve_mask_arg (gfc_expr *mask)
+{
+ int newkind;
+
+ /* The mask can be kind 4 or 8 for the array case.
+ For the scalar case, coerce it to kind=4 unconditionally
+ (because this is the only kind we have a library function
+ for). */
+
+ newkind = 0;
+
+ if (mask->rank == 0)
+ {
+ if (mask->ts.kind != 4)
+ newkind = 4;
+ }
+ else
+ {
+ if (mask->ts.kind < 4)
+ newkind = gfc_default_logical_kind;
+ }
+
+ if (newkind)
+ {
+ gfc_typespec ts;
+
+ ts.type = BT_LOGICAL;
+ ts.kind = newkind;
+ gfc_convert_type (mask, &ts, 2);
+ }
+}
+
/********************** Resolution functions **********************/
void
-gfc_resolve_abs (gfc_expr * f, gfc_expr * a)
+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);
+ 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_acos (gfc_expr * f, gfc_expr * x)
+gfc_resolve_achar (gfc_expr *f, gfc_expr *x)
+{
+
+ f->ts.type = BT_CHARACTER;
+ f->ts.kind = gfc_default_character_kind;
+ f->ts.cl = gfc_get_charlen ();
+ f->ts.cl->next = gfc_current_ns->cl_list;
+ gfc_current_ns->cl_list = f->ts.cl;
+ f->ts.cl->length = gfc_int_expr (1);
+
+ f->value.function.name
+ = gfc_get_string ("__achar_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
+}
+
+
+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);
+ 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)
+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);
+ 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)
+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);
+ 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)
+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);
+ 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);
+ if (i->ts.kind == gfc_kind_max (i, j))
+ gfc_convert_type (j, &i->ts, 2);
else
- gfc_convert_type(i, &j->ts, 2);
+ 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);
+ 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_resolve_aint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
gfc_typespec ts;
}
/* 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);
+ 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_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)
+gfc_resolve_all (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
{
f->ts = mask->ts;
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);
+ 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_resolve_anint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
gfc_typespec ts;
/* 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);
+ 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_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)
+gfc_resolve_any (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
{
f->ts = mask->ts;
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);
+ 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)
+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);
+ 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)
+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);
+ 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)
+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);
+ 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)
+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);
+ 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)
+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);
+ 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_resolve_besn (gfc_expr *f, gfc_expr *n, gfc_expr *x)
{
gfc_typespec ts;
void
-gfc_resolve_btest (gfc_expr * f, gfc_expr * i, gfc_expr * pos)
+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);
+ 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)
+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);
+ 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 (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
f->ts.type = BT_CHARACTER;
- f->ts.kind = (kind == NULL) ? gfc_default_character_kind
- : mpz_get_si (kind->value.integer);
-
- f->value.function.name =
- gfc_get_string ("__char_%d_%c%d", f->ts.kind,
- gfc_type_letter (a->ts.type), a->ts.kind);
+ f->ts.kind = (kind == NULL)
+ ? gfc_default_character_kind : mpz_get_si (kind->value.integer);
+ f->value.function.name
+ = gfc_get_string ("__char_%d_%c%d", f->ts.kind,
+ gfc_type_letter (a->ts.type), a->ts.kind);
}
void
-gfc_resolve_chdir (gfc_expr * f, gfc_expr * d ATTRIBUTE_UNUSED)
+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);
+ f->value.function.name = gfc_get_string (PREFIX ("chdir_i%d"), f->ts.kind);
}
void
-gfc_resolve_chdir_sub (gfc_code * c)
+gfc_resolve_chdir_sub (gfc_code *c)
{
const char *name;
int kind;
else
kind = gfc_default_integer_kind;
- name = gfc_get_string (PREFIX("chdir_i%d_sub"), 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)
+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);
+ 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);
+ 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);
+ 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_dcmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y)
{
gfc_resolve_cmplx (f, x, y, gfc_int_expr (gfc_default_double_kind));
}
+
void
-gfc_resolve_complex (gfc_expr * f, gfc_expr * x, gfc_expr * y)
+gfc_resolve_complex (gfc_expr *f, gfc_expr *x, gfc_expr *y)
{
int 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);
+ 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)
+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)
+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);
+ 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)
+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);
+ 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_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
}
- f->value.function.name =
- gfc_get_string (PREFIX("count_%d_%c%d"), f->ts.kind,
- gfc_type_letter (mask->ts.type), mask->ts.kind);
+ f->value.function.name
+ = gfc_get_string (PREFIX ("count_%d_%c%d"), f->ts.kind,
+ gfc_type_letter (mask->ts.type), mask->ts.kind);
}
void
-gfc_resolve_cshift (gfc_expr * f, gfc_expr * array,
- gfc_expr * shift,
- gfc_expr * dim)
+gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
+ gfc_expr *dim)
{
int n;
if (dim->ts.kind != shift->ts.kind)
gfc_convert_type_warn (dim, &shift->ts, 2, 0);
}
- f->value.function.name =
- gfc_get_string (PREFIX("cshift%d_%d%s"), n, shift->ts.kind,
- array->ts.type == BT_CHARACTER ? "_char" : "");
+ f->value.function.name
+ = gfc_get_string (PREFIX ("cshift%d_%d%s"), n, shift->ts.kind,
+ array->ts.type == BT_CHARACTER ? "_char" : "");
}
void
-gfc_resolve_ctime (gfc_expr * f, gfc_expr * time)
+gfc_resolve_ctime (gfc_expr *f, gfc_expr *time)
{
gfc_typespec ts;
gfc_convert_type (time, &ts, 2);
}
- f->value.function.name = gfc_get_string (PREFIX("ctime"));
+ f->value.function.name = gfc_get_string (PREFIX ("ctime"));
}
void
-gfc_resolve_dble (gfc_expr * f, gfc_expr * a)
+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);
+ 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)
+gfc_resolve_dim (gfc_expr *f, gfc_expr *a, gfc_expr *p)
{
f->ts.type = a->ts.type;
if (p != NULL)
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);
+ gfc_convert_type (p, &a->ts, 2);
else
- gfc_convert_type(a, &p->ts, 2);
+ 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);
+ 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_resolve_dot_product (gfc_expr *f, gfc_expr *a, gfc_expr *b)
{
gfc_expr temp;
temp.value.op.op2 = b;
gfc_type_convert_binary (&temp);
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);
+ 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)
+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_eoshift (gfc_expr * f, gfc_expr * array,
- gfc_expr * shift,
- gfc_expr * boundary,
- gfc_expr * dim)
+gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
+ gfc_expr *boundary, gfc_expr *dim)
{
int n;
gfc_convert_type_warn (dim, &shift->ts, 2, 0);
}
- f->value.function.name =
- gfc_get_string (PREFIX("eoshift%d_%d%s"), n, shift->ts.kind,
- array->ts.type == BT_CHARACTER ? "_char" : "");
+ f->value.function.name
+ = gfc_get_string (PREFIX ("eoshift%d_%d%s"), n, shift->ts.kind,
+ array->ts.type == BT_CHARACTER ? "_char" : "");
}
void
-gfc_resolve_exp (gfc_expr * f, gfc_expr * x)
+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);
+ 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)
+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);
}
void
-gfc_resolve_fdate (gfc_expr * f)
+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"));
+ f->value.function.name = gfc_get_string (PREFIX ("fdate"));
}
void
-gfc_resolve_floor (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
+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);
+ 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)
+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);
+ f->value.function.name = gfc_get_string (PREFIX ("fnum_i%d"), f->ts.kind);
}
void
-gfc_resolve_fraction (gfc_expr * f, gfc_expr * x)
+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)
+gfc_resolve_g77_math1 (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
f->value.function.name = gfc_get_string ("<intrinsic>");
void
-gfc_resolve_getcwd (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
+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"));
+ f->value.function.name = gfc_get_string (PREFIX ("getcwd"));
}
void
-gfc_resolve_getgid (gfc_expr * f)
+gfc_resolve_getgid (gfc_expr *f)
{
f->ts.type = BT_INTEGER;
f->ts.kind = 4;
- f->value.function.name = gfc_get_string (PREFIX("getgid"));
+ f->value.function.name = gfc_get_string (PREFIX ("getgid"));
}
void
-gfc_resolve_getpid (gfc_expr * f)
+gfc_resolve_getpid (gfc_expr *f)
{
f->ts.type = BT_INTEGER;
f->ts.kind = 4;
- f->value.function.name = gfc_get_string (PREFIX("getpid"));
+ f->value.function.name = gfc_get_string (PREFIX ("getpid"));
}
void
-gfc_resolve_getuid (gfc_expr * f)
+gfc_resolve_getuid (gfc_expr *f)
{
f->ts.type = BT_INTEGER;
f->ts.kind = 4;
- f->value.function.name = gfc_get_string (PREFIX("getuid"));
+ f->value.function.name = gfc_get_string (PREFIX ("getuid"));
}
+
void
-gfc_resolve_hostnm (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
+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_iand (gfc_expr * f, gfc_expr * i, gfc_expr * j)
+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);
+ if (i->ts.kind == gfc_kind_max (i, j))
+ gfc_convert_type (j, &i->ts, 2);
else
- gfc_convert_type(i, &j->ts, 2);
+ gfc_convert_type (i, &j->ts, 2);
}
f->ts = i->ts;
void
-gfc_resolve_ibclr (gfc_expr * f, gfc_expr * i, gfc_expr * pos ATTRIBUTE_UNUSED)
+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)
+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)
+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_ichar (gfc_expr * f, gfc_expr * c)
+gfc_resolve_ichar (gfc_expr *f, gfc_expr *c)
{
f->ts.type = BT_INTEGER;
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_idnint (gfc_expr *f, gfc_expr *a)
{
gfc_resolve_nint (f, a, NULL);
}
void
-gfc_resolve_ierrno (gfc_expr * f)
+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);
+ 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)
+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);
+ if (i->ts.kind == gfc_kind_max (i, j))
+ gfc_convert_type (j, &i->ts, 2);
else
- gfc_convert_type(i, &j->ts, 2);
+ gfc_convert_type (i, &j->ts, 2);
}
f->ts = i->ts;
void
-gfc_resolve_ior (gfc_expr * f, gfc_expr * i, gfc_expr * j)
+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);
+ if (i->ts.kind == gfc_kind_max (i, j))
+ gfc_convert_type (j, &i->ts, 2);
else
- gfc_convert_type(i, &j->ts, 2);
+ gfc_convert_type (i, &j->ts, 2);
}
f->ts = i->ts;
void
-gfc_resolve_int (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
+gfc_resolve_index_func (gfc_expr *f, gfc_expr *str,
+ gfc_expr *sub_str ATTRIBUTE_UNUSED, gfc_expr *back)
+{
+ gfc_typespec ts;
+
+ f->ts.type = BT_INTEGER;
+ 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.derived = NULL;
+ ts.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->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);
+}
- 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_isatty (gfc_expr * f, gfc_expr * u)
+gfc_resolve_isatty (gfc_expr *f, gfc_expr *u)
{
gfc_typespec ts;
gfc_convert_type (u, &ts, 2);
}
- f->value.function.name = gfc_get_string (PREFIX("isatty_l%d"), f->ts.kind);
+ 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)
+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);
+ f->value.function.name
+ = gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
}
void
-gfc_resolve_ishftc (gfc_expr * f, gfc_expr * i, gfc_expr * shift,
- gfc_expr * size)
+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 : shift->ts.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);
+ 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, ATTRIBUTE_UNUSED gfc_expr * p,
- ATTRIBUTE_UNUSED gfc_expr * s)
+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);
+ 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_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
{
static char lbound[] = "__lbound";
void
-gfc_resolve_len (gfc_expr * f, gfc_expr * string)
+gfc_resolve_len (gfc_expr *f, gfc_expr *string)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
- f->value.function.name = gfc_get_string ("__len_%d", string->ts.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_resolve_len_trim (gfc_expr *f, gfc_expr *string)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
void
-gfc_resolve_link (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
- gfc_expr * p2 ATTRIBUTE_UNUSED)
+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);
+ f->value.function.name = gfc_get_string (PREFIX ("link_i%d"), f->ts.kind);
}
void
-gfc_resolve_log (gfc_expr * f, gfc_expr * x)
+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);
+ 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)
+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);
+ 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)
+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->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);
+ 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)
+gfc_resolve_malloc (gfc_expr *f, gfc_expr *size)
{
if (size->ts.kind < gfc_index_integer_kind)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_index_integer_kind;
- f->value.function.name = gfc_get_string (PREFIX("malloc"));
+ f->value.function.name = gfc_get_string (PREFIX ("malloc"));
}
void
-gfc_resolve_matmul (gfc_expr * f, gfc_expr * a, gfc_expr * b)
+gfc_resolve_matmul (gfc_expr *f, gfc_expr *a, gfc_expr *b)
{
gfc_expr temp;
f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
- f->value.function.name =
- gfc_get_string (PREFIX("matmul_%c%d"), gfc_type_letter (f->ts.type),
- f->ts.kind);
+ 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_resolve_minmax (const char *name, gfc_expr *f, gfc_actual_arglist *args)
{
gfc_actual_arglist *a;
for (a = args->next; a; a = a->next)
{
if (a->expr->ts.kind > f->ts.kind)
- f->ts.kind = a->expr->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);
+ 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);
+ 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_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)
+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->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)
else
name = "mmaxloc";
- /* The mask can be kind 4 or 8 for the array case. For the
- scalar case, coerce it to default kind unconditionally. */
- if ((mask->ts.kind < gfc_default_logical_kind)
- || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
- {
- gfc_typespec ts;
- ts.type = BT_LOGICAL;
- ts.kind = gfc_default_logical_kind;
- gfc_convert_type_warn (mask, &ts, 2, 0);
- }
+ 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);
+ 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)
+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;
{
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)
else
name = "mmaxval";
- /* The mask can be kind 4 or 8 for the array case. For the
- scalar case, coerce it to default kind unconditionally. */
- if ((mask->ts.kind < gfc_default_logical_kind)
- || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
- {
- gfc_typespec ts;
- ts.type = BT_LOGICAL;
- ts.kind = gfc_default_logical_kind;
- gfc_convert_type_warn (mask, &ts, 2, 0);
- }
+ 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);
+ 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_merge (gfc_expr * f, gfc_expr * tsource,
- gfc_expr * fsource ATTRIBUTE_UNUSED,
- gfc_expr * mask ATTRIBUTE_UNUSED)
+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)
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);
+ f->value.function.name
+ = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
+ tsource->ts.kind);
}
void
-gfc_resolve_min (gfc_expr * f, gfc_actual_arglist * args)
+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)
+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->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)
else
name = "mminloc";
- /* The mask can be kind 4 or 8 for the array case. For the
- scalar case, coerce it to default kind unconditionally. */
- if ((mask->ts.kind < gfc_default_logical_kind)
- || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
- {
- gfc_typespec ts;
- ts.type = BT_LOGICAL;
- ts.kind = gfc_default_logical_kind;
- gfc_convert_type_warn (mask, &ts, 2, 0);
- }
+ 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);
+ 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)
+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;
{
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)
else
name = "mminval";
- /* The mask can be kind 4 or 8 for the array case. For the
- scalar case, coerce it to default kind unconditionally. */
- if ((mask->ts.kind < gfc_default_logical_kind)
- || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
- {
- gfc_typespec ts;
- ts.type = BT_LOGICAL;
- ts.kind = gfc_default_logical_kind;
- gfc_convert_type_warn (mask, &ts, 2, 0);
- }
+ 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);
+ 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)
+gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p)
{
f->ts.type = a->ts.type;
if (p != NULL)
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);
+ gfc_convert_type (p, &a->ts, 2);
else
- gfc_convert_type(a, &p->ts, 2);
+ 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);
+ 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)
+gfc_resolve_modulo (gfc_expr *f, gfc_expr *a, gfc_expr *p)
{
f->ts.type = a->ts.type;
if (p != NULL)
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);
+ gfc_convert_type (p, &a->ts, 2);
else
- gfc_convert_type(a, &p->ts, 2);
+ 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);
+ 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 ATTRIBUTE_UNUSED)
+gfc_resolve_nearest (gfc_expr *f, gfc_expr *a, gfc_expr *p ATTRIBUTE_UNUSED)
{
f->ts = a->ts;
- f->value.function.name =
- gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
- a->ts.kind);
+ 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)
+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);
+ 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_not (gfc_expr * f, gfc_expr * i)
+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)
+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);
+ 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);
+ if (i->ts.kind == gfc_kind_max (i, j))
+ gfc_convert_type (j, &i->ts, 2);
else
- gfc_convert_type(i, &j->ts, 2);
+ 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);
+ 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)
+gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
+ gfc_expr *vector ATTRIBUTE_UNUSED)
{
f->ts = array->ts;
f->rank = 1;
+ resolve_mask_arg (mask);
+
if (mask->rank != 0)
f->value.function.name = (array->ts.type == BT_CHARACTER
- ? PREFIX("pack_char")
- : PREFIX("pack"));
+ ? PREFIX ("pack_char") : PREFIX ("pack"));
else
- {
- /* We convert mask to default logical only in the scalar case.
- In the array case we can simply read the array as if it were
- of type default logical. */
- if (mask->ts.kind != gfc_default_logical_kind)
- {
- gfc_typespec ts;
-
- ts.type = BT_LOGICAL;
- ts.kind = gfc_default_logical_kind;
- gfc_convert_type (mask, &ts, 2);
- }
-
- f->value.function.name = (array->ts.type == BT_CHARACTER
- ? PREFIX("pack_s_char")
- : PREFIX("pack_s"));
- }
+ f->value.function.name = (array->ts.type == BT_CHARACTER
+ ? PREFIX ("pack_s_char") : PREFIX ("pack_s"));
}
void
-gfc_resolve_product (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
- gfc_expr * mask)
+gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
+ gfc_expr *mask)
{
const char *name;
else
name = "mproduct";
- /* The mask can be kind 4 or 8 for the array case. For the
- scalar case, coerce it to default kind unconditionally. */
- if ((mask->ts.kind < gfc_default_logical_kind)
- || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
- {
- gfc_typespec ts;
- ts.type = BT_LOGICAL;
- ts.kind = gfc_default_logical_kind;
- gfc_convert_type_warn (mask, &ts, 2, 0);
- }
+ resolve_mask_arg (mask);
}
else
name = "product";
- f->value.function.name =
- gfc_get_string (PREFIX("%s_%c%d"), name,
- gfc_type_letter (array->ts.type), array->ts.kind);
+ f->value.function.name
+ = gfc_get_string (PREFIX ("%s_%c%d"), name,
+ gfc_type_letter (array->ts.type), array->ts.kind);
}
void
-gfc_resolve_real (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
+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->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);
+ 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)
+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);
+ 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)
+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);
+ 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 ATTRIBUTE_UNUSED)
+gfc_resolve_repeat (gfc_expr *f, gfc_expr *string,
+ gfc_expr *ncopies ATTRIBUTE_UNUSED)
{
f->ts.type = BT_CHARACTER;
f->ts.kind = string->ts.kind;
void
-gfc_resolve_reshape (gfc_expr * f, gfc_expr * source, gfc_expr * shape,
- gfc_expr * pad ATTRIBUTE_UNUSED,
- gfc_expr * order ATTRIBUTE_UNUSED)
+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;
case 8:
case 10:
case 16:
- if (source->ts.type == BT_COMPLEX)
- f->value.function.name =
- gfc_get_string (PREFIX("reshape_%c%d"),
- gfc_type_letter (BT_COMPLEX), source->ts.kind);
- else if (source->ts.type == BT_REAL && (kind == 10 || kind == 16))
- f->value.function.name =
- gfc_get_string (PREFIX("reshape_%c%d"),
- gfc_type_letter (BT_REAL), source->ts.kind);
+ 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
- f->value.function.name =
- gfc_get_string (PREFIX("reshape_%d"), source->ts.kind);
+ 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"));
+ ? PREFIX ("reshape_char") : PREFIX ("reshape"));
break;
}
void
-gfc_resolve_rrspacing (gfc_expr * f, gfc_expr * x)
+gfc_resolve_rrspacing (gfc_expr *f, gfc_expr *x)
{
+ int k;
+ gfc_actual_arglist *prec;
+
f->ts = x->ts;
f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
+
+ /* Create a hidden argument to the library routines for rrspacing. This
+ hidden argument is the precision of x. */
+ k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
+ prec = gfc_get_actual_arglist ();
+ prec->name = "p";
+ prec->expr = gfc_int_expr (gfc_real_kinds[k].digits);
+ /* The library routine expects INTEGER(4). */
+ if (prec->expr->ts.kind != gfc_c_int_kind)
+ {
+ gfc_typespec ts;
+ ts.type = BT_INTEGER;
+ ts.kind = gfc_c_int_kind;
+ gfc_convert_type (prec->expr, &ts, 2);
+ }
+ f->value.function.actual->next = prec;
}
void
-gfc_resolve_scale (gfc_expr * f, gfc_expr * x, gfc_expr * i)
+gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i)
{
f->ts = x->ts;
if (i->ts.kind != gfc_c_int_kind)
{
gfc_typespec ts;
-
ts.type = BT_INTEGER;
- ts.kind = gfc_default_integer_kind;
-
+ ts.kind = gfc_c_int_kind;
gfc_convert_type_warn (i, &ts, 2, 0);
}
void
-gfc_resolve_scan (gfc_expr * f, gfc_expr * string,
- gfc_expr * set ATTRIBUTE_UNUSED,
- gfc_expr * back ATTRIBUTE_UNUSED)
+gfc_resolve_scan (gfc_expr *f, gfc_expr *string,
+ gfc_expr *set ATTRIBUTE_UNUSED,
+ gfc_expr *back ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
void
-gfc_resolve_secnds (gfc_expr * t1, gfc_expr * t0)
+gfc_resolve_secnds (gfc_expr *t1, gfc_expr *t0)
{
t1->ts = t0->ts;
- t1->value.function.name =
- gfc_get_string (PREFIX("secnds"));
+ t1->value.function.name = gfc_get_string (PREFIX ("secnds"));
}
void
-gfc_resolve_set_exponent (gfc_expr * f, gfc_expr * x, gfc_expr * i)
+gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x, gfc_expr *i)
{
f->ts = x->ts;
/* The library implementation uses GFC_INTEGER_4 unconditionally,
convert type so we don't have to implement all possible
permutations. */
- if (i->ts.kind != 4)
+ if (i->ts.kind != gfc_c_int_kind)
{
gfc_typespec ts;
-
ts.type = BT_INTEGER;
- ts.kind = gfc_default_integer_kind;
-
+ ts.kind = gfc_c_int_kind;
gfc_convert_type_warn (i, &ts, 2, 0);
}
void
-gfc_resolve_shape (gfc_expr * f, gfc_expr * array)
+gfc_resolve_shape (gfc_expr *f, gfc_expr *array)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
f->rank = 1;
- f->value.function.name = gfc_get_string (PREFIX("shape_%d"), f->ts.kind);
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_sign (gfc_expr * f, gfc_expr * a, gfc_expr * b ATTRIBUTE_UNUSED)
+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);
+ 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)
+gfc_resolve_signal (gfc_expr *f, gfc_expr *number, gfc_expr *handler)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_c_int_kind;
{
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"));
+ f->value.function.name = gfc_get_string (PREFIX ("signal_func_int"));
}
else
- f->value.function.name = gfc_get_string (PREFIX("signal_func"));
+ 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)
+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);
+ 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)
+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);
+ f->value.function.name
+ = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}
void
-gfc_resolve_spacing (gfc_expr * f, gfc_expr * x)
+gfc_resolve_spacing (gfc_expr *f, gfc_expr *x)
{
+ int k;
+ gfc_actual_arglist *prec, *tiny, *emin_1;
+
f->ts = x->ts;
f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
+
+ /* Create hidden arguments to the library routine for spacing. These
+ hidden arguments are tiny(x), min_exponent - 1, and the precision
+ of x. */
+
+ k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
+
+ tiny = gfc_get_actual_arglist ();
+ tiny->name = "tiny";
+ tiny->expr = gfc_get_expr ();
+ tiny->expr->expr_type = EXPR_CONSTANT;
+ tiny->expr->where = gfc_current_locus;
+ tiny->expr->ts.type = x->ts.type;
+ tiny->expr->ts.kind = x->ts.kind;
+ mpfr_init (tiny->expr->value.real);
+ mpfr_set (tiny->expr->value.real, gfc_real_kinds[k].tiny, GFC_RND_MODE);
+
+ emin_1 = gfc_get_actual_arglist ();
+ emin_1->name = "emin";
+ emin_1->expr = gfc_int_expr (gfc_real_kinds[k].min_exponent - 1);
+
+ /* The library routine expects INTEGER(4). */
+ if (emin_1->expr->ts.kind != gfc_c_int_kind)
+ {
+ gfc_typespec ts;
+ ts.type = BT_INTEGER;
+ ts.kind = gfc_c_int_kind;
+ gfc_convert_type (emin_1->expr, &ts, 2);
+ }
+ emin_1->next = tiny;
+
+ prec = gfc_get_actual_arglist ();
+ prec->name = "prec";
+ prec->expr = gfc_int_expr (gfc_real_kinds[k].digits);
+
+ /* The library routine expects INTEGER(4). */
+ if (prec->expr->ts.kind != gfc_c_int_kind)
+ {
+ gfc_typespec ts;
+ ts.type = BT_INTEGER;
+ ts.kind = gfc_c_int_kind;
+ gfc_convert_type (prec->expr, &ts, 2);
+ }
+ prec->next = emin_1;
+
+ f->value.function.actual->next = prec;
}
void
-gfc_resolve_spread (gfc_expr * f, gfc_expr * source,
- gfc_expr * dim,
- gfc_expr * ncopies)
+gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim,
+ gfc_expr *ncopies)
{
if (source->ts.type == BT_CHARACTER)
check_charlen_present (source);
f->rank = source->rank + 1;
if (source->rank == 0)
f->value.function.name = (source->ts.type == BT_CHARACTER
- ? PREFIX("spread_char_scalar")
- : PREFIX("spread_scalar"));
+ ? PREFIX ("spread_char_scalar")
+ : PREFIX ("spread_scalar"));
else
f->value.function.name = (source->ts.type == BT_CHARACTER
- ? PREFIX("spread_char")
- : PREFIX("spread"));
+ ? PREFIX ("spread_char")
+ : 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)
+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);
+ 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)
+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("stat_i%d"), f->ts.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)
+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);
+ 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_resolve_fgetc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
{
gfc_typespec ts;
gfc_convert_type (u, &ts, 2);
}
- f->value.function.name = gfc_get_string (PREFIX("fgetc"));
+ f->value.function.name = gfc_get_string (PREFIX ("fgetc"));
}
void
-gfc_resolve_fget (gfc_expr * f, gfc_expr * c ATTRIBUTE_UNUSED)
+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"));
+ 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_resolve_fputc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
{
gfc_typespec ts;
gfc_convert_type (u, &ts, 2);
}
- f->value.function.name = gfc_get_string (PREFIX("fputc"));
+ f->value.function.name = gfc_get_string (PREFIX ("fputc"));
}
void
-gfc_resolve_fput (gfc_expr * f, gfc_expr * c ATTRIBUTE_UNUSED)
+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"));
+ f->value.function.name = gfc_get_string (PREFIX ("fput"));
}
void
-gfc_resolve_ftell (gfc_expr * f, gfc_expr * u)
+gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
{
gfc_typespec ts;
gfc_convert_type (u, &ts, 2);
}
- f->value.function.name = gfc_get_string (PREFIX("ftell"));
+ f->value.function.name = gfc_get_string (PREFIX ("ftell"));
}
void
-gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
- gfc_expr * mask)
+gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
{
const char *name;
else
name = "msum";
- /* The mask can be kind 4 or 8 for the array case. For the
- scalar case, coerce it to default kind unconditionally. */
- if ((mask->ts.kind < gfc_default_logical_kind)
- || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
- {
- gfc_typespec ts;
- ts.type = BT_LOGICAL;
- ts.kind = gfc_default_logical_kind;
- gfc_convert_type_warn (mask, &ts, 2, 0);
- }
+ resolve_mask_arg (mask);
}
else
name = "sum";
gfc_resolve_dim_arg (dim);
}
- f->value.function.name =
- gfc_get_string (PREFIX("%s_%c%d"), name,
+ f->value.function.name
+ = gfc_get_string (PREFIX ("%s_%c%d"), name,
gfc_type_letter (array->ts.type), array->ts.kind);
}
void
-gfc_resolve_symlnk (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
- gfc_expr * p2 ATTRIBUTE_UNUSED)
+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);
+ 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)
+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"));
+ f->value.function.name = gfc_get_string (PREFIX ("system"));
}
void
-gfc_resolve_tan (gfc_expr * f, gfc_expr * x)
+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);
+ 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)
+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);
+ f->value.function.name
+ = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}
void
-gfc_resolve_time (gfc_expr * f)
+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"));
+ f->value.function.name = gfc_get_string (PREFIX ("time_func"));
}
void
-gfc_resolve_time8 (gfc_expr * f)
+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"));
+ 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)
+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";
void
-gfc_resolve_transpose (gfc_expr * f, gfc_expr * matrix)
+gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
{
- int kind;
-
f->ts = matrix->ts;
f->rank = 2;
if (matrix->shape)
mpz_init_set (f->shape[1], matrix->shape[0]);
}
- kind = matrix->ts.kind;
-
- switch (kind)
+ switch (matrix->ts.kind)
{
case 4:
case 8:
case 10:
case 16:
switch (matrix->ts.type)
- {
- case BT_COMPLEX:
- f->value.function.name =
- gfc_get_string (PREFIX("transpose_c%d"), kind);
- break;
-
- case BT_REAL:
- /* There is no kind=10 integer type and on 32-bit targets
- there is usually no kind=16 integer type. We need to
- call the real version. */
- if (kind == 10 || kind == 16)
- {
- f->value.function.name =
- gfc_get_string (PREFIX("transpose_r%d"), kind);
- break;
- }
-
- /* Fall through */
-
- case BT_INTEGER:
- case BT_LOGICAL:
+ {
+ 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"), kind);
- break;
-
- default:
- f->value.function.name = PREFIX("transpose");
- break;
- }
+ f->value.function.name
+ = gfc_get_string (PREFIX ("transpose_i%d"), matrix->ts.kind);
+ break;
+
+ default:
+ f->value.function.name = PREFIX ("transpose");
+ break;
+ }
break;
default:
f->value.function.name = (matrix->ts.type == BT_CHARACTER
- ? PREFIX("transpose_char")
- : PREFIX("transpose"));
+ ? PREFIX ("transpose_char")
+ : PREFIX ("transpose"));
break;
}
}
void
-gfc_resolve_trim (gfc_expr * f, gfc_expr * string)
+gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
{
f->ts.type = BT_CHARACTER;
f->ts.kind = string->ts.kind;
void
-gfc_resolve_ubound (gfc_expr * f, gfc_expr * array,
- gfc_expr * dim)
+gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
{
static char ubound[] = "__ubound";
/* Resolve the g77 compatibility function UMASK. */
void
-gfc_resolve_umask (gfc_expr * f, gfc_expr * n)
+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);
+ 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)
+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"));
+ f->value.function.name = gfc_get_string (PREFIX ("unlink"));
}
void
-gfc_resolve_ttynam (gfc_expr * f, gfc_expr * unit)
+gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit)
{
gfc_typespec ts;
gfc_convert_type (unit, &ts, 2);
}
- f->value.function.name = gfc_get_string (PREFIX("ttynam"));
+ 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)
+gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
+ gfc_expr *field ATTRIBUTE_UNUSED)
{
f->ts = vector->ts;
f->rank = mask->rank;
+ resolve_mask_arg (mask);
- f->value.function.name =
- gfc_get_string (PREFIX("unpack%d%s"), field->rank > 0 ? 1 : 0,
- vector->ts.type == BT_CHARACTER ? "_char" : "");
+ f->value.function.name
+ = gfc_get_string (PREFIX ("unpack%d%s"), field->rank > 0 ? 1 : 0,
+ vector->ts.type == BT_CHARACTER ? "_char" : "");
}
void
-gfc_resolve_verify (gfc_expr * f, gfc_expr * string,
- gfc_expr * set ATTRIBUTE_UNUSED,
- gfc_expr * back ATTRIBUTE_UNUSED)
+gfc_resolve_verify (gfc_expr *f, gfc_expr *string,
+ gfc_expr *set ATTRIBUTE_UNUSED,
+ gfc_expr *back ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
void
-gfc_resolve_xor (gfc_expr * f, gfc_expr * i, gfc_expr * j)
+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);
+ 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);
+ if (i->ts.kind == gfc_kind_max (i, j))
+ gfc_convert_type (j, &i->ts, 2);
else
- gfc_convert_type(i, &j->ts, 2);
+ 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);
+ 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)
+gfc_resolve_alarm_sub (gfc_code *c)
{
const char *name;
gfc_expr *seconds, *handler, *status;
ts.type = BT_INTEGER;
ts.kind = gfc_c_int_kind;
- /* handler can be either BT_INTEGER or BT_PROCEDURE */
+ /* 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"));
+ name = gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
+ gfc_default_integer_kind);
}
else
- name = gfc_get_string (PREFIX("alarm_sub"));
+ 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);
- 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);
}
void
-gfc_resolve_cpu_time (gfc_code * c ATTRIBUTE_UNUSED)
+gfc_resolve_cpu_time (gfc_code *c)
{
const char *name;
-
- name = gfc_get_string (PREFIX("cpu_time_%d"),
- c->ext.actual->expr->ts.kind);
+ name = gfc_get_string (PREFIX ("cpu_time_%d"), c->ext.actual->expr->ts.kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
-gfc_resolve_mvbits (gfc_code * c)
+gfc_resolve_mvbits (gfc_code *c)
{
const char *name;
- int kind;
-
- kind = c->ext.actual->expr->ts.kind;
- name = gfc_get_string (PREFIX("mvbits_i%d"), kind);
+ gfc_typespec 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);
}
void
-gfc_resolve_random_number (gfc_code * c ATTRIBUTE_UNUSED)
+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);
+ name = gfc_get_string (PREFIX ("random_r%d"), kind);
else
- name = gfc_get_string (PREFIX("arandom_r%d"), kind);
+ name = gfc_get_string (PREFIX ("arandom_r%d"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
-gfc_resolve_rename_sub (gfc_code * c)
+gfc_resolve_rename_sub (gfc_code *c)
{
const char *name;
int kind;
else
kind = gfc_default_integer_kind;
- name = gfc_get_string (PREFIX("rename_i%d_sub"), 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)
+gfc_resolve_kill_sub (gfc_code *c)
{
const char *name;
int kind;
else
kind = gfc_default_integer_kind;
- name = gfc_get_string (PREFIX("kill_i%d_sub"), 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)
+gfc_resolve_link_sub (gfc_code *c)
{
const char *name;
int kind;
else
kind = gfc_default_integer_kind;
- name = gfc_get_string (PREFIX("link_i%d_sub"), 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)
+gfc_resolve_symlnk_sub (gfc_code *c)
{
const char *name;
int kind;
else
kind = gfc_default_integer_kind;
- name = gfc_get_string (PREFIX("symlnk_i%d_sub"), kind);
+ name = gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
/* G77 compatibility subroutines etime() and dtime(). */
void
-gfc_resolve_etime_sub (gfc_code * c)
+gfc_resolve_etime_sub (gfc_code *c)
{
const char *name;
-
- name = gfc_get_string (PREFIX("etime_sub"));
+ 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)
+gfc_resolve_second_sub (gfc_code *c)
{
const char *name;
-
- name = gfc_get_string (PREFIX("second_sub"));
+ name = gfc_get_string (PREFIX ("second_sub"));
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
-gfc_resolve_sleep_sub (gfc_code * c)
+gfc_resolve_sleep_sub (gfc_code *c)
{
const char *name;
int kind;
else
kind = gfc_default_integer_kind;
- name = gfc_get_string (PREFIX("sleep_i%d_sub"), 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)
+gfc_resolve_srand (gfc_code *c)
{
const char *name;
- name = gfc_get_string (PREFIX("srand"));
+ 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)
+gfc_resolve_getarg (gfc_code *c)
{
const char *name;
int kind;
-
kind = gfc_default_integer_kind;
- name = gfc_get_string (PREFIX("getarg_i%d"), kind);
+ name = gfc_get_string (PREFIX ("getarg_i%d"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
+
/* Resolve the getcwd intrinsic subroutine. */
void
-gfc_resolve_getcwd_sub (gfc_code * c)
+gfc_resolve_getcwd_sub (gfc_code *c)
{
const char *name;
int kind;
else
kind = gfc_default_integer_kind;
- name = gfc_get_string (PREFIX("getcwd_i%d_sub"), 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)
+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);
+ 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)
+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);
+ 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)
+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);
+ 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)
+gfc_resolve_signal_sub (gfc_code *c)
{
const char *name;
gfc_expr *number, *handler, *status;
{
if (handler->ts.kind != gfc_c_int_kind)
gfc_convert_type (handler, &ts, 2);
- name = gfc_get_string (PREFIX("signal_sub_int"));
+ name = gfc_get_string (PREFIX ("signal_sub_int"));
}
else
- name = gfc_get_string (PREFIX("signal_sub"));
+ name = gfc_get_string (PREFIX ("signal_sub"));
if (number->ts.kind != gfc_c_int_kind)
gfc_convert_type (number, &ts, 2);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
+
/* Resolve the SYSTEM intrinsic subroutine. */
void
-gfc_resolve_system_sub (gfc_code * c)
+gfc_resolve_system_sub (gfc_code *c)
{
const char *name;
-
- name = gfc_get_string (PREFIX("system_sub"));
+ 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)
+gfc_resolve_system_clock (gfc_code *c)
{
const char *name;
int kind;
else
kind = gfc_default_integer_kind;
- name = gfc_get_string (PREFIX("system_clock_%d"), kind);
+ name = gfc_get_string (PREFIX ("system_clock_%d"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
+
/* Resolve the EXIT intrinsic subroutine. */
void
-gfc_resolve_exit (gfc_code * c)
+gfc_resolve_exit (gfc_code *c)
{
const char *name;
- int kind;
+ gfc_typespec ts;
+ gfc_expr *n;
- if (c->ext.actual->expr != NULL)
- kind = c->ext.actual->expr->ts.kind;
- else
- kind = gfc_default_integer_kind;
+ /* 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"), kind);
+ 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)
+gfc_resolve_flush (gfc_code *c)
{
const char *name;
gfc_typespec ts;
ts.type = BT_INTEGER;
ts.kind = gfc_default_integer_kind;
n = c->ext.actual->expr;
- if (n != NULL
- && n->ts.kind != ts.kind)
+ if (n != NULL && n->ts.kind != ts.kind)
gfc_convert_type (n, &ts, 2);
- name = gfc_get_string (PREFIX("flush_i%d"), ts.kind);
+ 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_resolve_free (gfc_code *c)
{
gfc_typespec ts;
gfc_expr *n;
if (n->ts.kind != ts.kind)
gfc_convert_type (n, &ts, 2);
- c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("free"));
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("free"));
}
void
-gfc_resolve_ctime_sub (gfc_code * c)
+gfc_resolve_ctime_sub (gfc_code *c)
{
gfc_typespec ts;
gfc_convert_type (c->ext.actual->expr, &ts, 2);
}
- c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("ctime_sub"));
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
}
void
-gfc_resolve_fdate_sub (gfc_code * c)
+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)
+gfc_resolve_gerror (gfc_code *c)
{
c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
}
void
-gfc_resolve_getlog (gfc_code * c)
+gfc_resolve_getlog (gfc_code *c)
{
c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
}
void
-gfc_resolve_hostnm_sub (gfc_code * c)
+gfc_resolve_hostnm_sub (gfc_code *c)
{
const char *name;
int kind;
else
kind = gfc_default_integer_kind;
- name = gfc_get_string (PREFIX("hostnm_i%d_sub"), 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)
+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)
+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);
+}
+
- name = gfc_get_string (PREFIX("stat_i%d_sub"), gfc_default_integer_kind);
+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)
+gfc_resolve_fstat_sub (gfc_code *c)
{
const char *name;
gfc_expr *u;
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);
+ 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)
+gfc_resolve_fgetc_sub (gfc_code *c)
{
const char *name;
gfc_typespec ts;
}
if (st != NULL)
- name = gfc_get_string (PREFIX("fgetc_i%d_sub"), st->ts.kind);
+ 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);
+ 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)
+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);
+ 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);
+ 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)
+gfc_resolve_fputc_sub (gfc_code *c)
{
const char *name;
gfc_typespec ts;
}
if (st != NULL)
- name = gfc_get_string (PREFIX("fputc_i%d_sub"), st->ts.kind);
+ 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);
+ 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)
+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);
+ 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);
+ 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_expr *status;
+ gfc_typespec ts;
+
+ unit = c->ext.actual->expr;
+ offset = c->ext.actual->next->expr;
+ whence = c->ext.actual->next->next->expr;
+ status = c->ext.actual->next->next->next->expr;
+
+ if (unit->ts.kind != gfc_c_int_kind)
+ {
+ ts.type = BT_INTEGER;
+ ts.kind = gfc_c_int_kind;
+ ts.derived = NULL;
+ ts.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.derived = NULL;
+ ts.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.derived = NULL;
+ ts.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)
+gfc_resolve_ftell_sub (gfc_code *c)
{
const char *name;
gfc_expr *unit;
gfc_convert_type (unit, &ts, 2);
}
- name = gfc_get_string (PREFIX("ftell_i%d_sub"), offset->ts.kind);
+ 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_resolve_ttynam_sub (gfc_code *c)
{
gfc_typespec ts;
gfc_convert_type (c->ext.actual->expr, &ts, 2);
}
- c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("ttynam_sub"));
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
}
/* Resolve the UMASK intrinsic subroutine. */
void
-gfc_resolve_umask_sub (gfc_code * c)
+gfc_resolve_umask_sub (gfc_code *c)
{
const char *name;
int kind;
else
kind = gfc_default_integer_kind;
- name = gfc_get_string (PREFIX("umask_i%d_sub"), 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)
+gfc_resolve_unlink_sub (gfc_code *c)
{
const char *name;
int kind;
else
kind = gfc_default_integer_kind;
- name = gfc_get_string (PREFIX("unlink_i%d_sub"), kind);
+ name = gfc_get_string (PREFIX ("unlink_i%d_sub"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
OSDN Git Service
