/* Intrinsic function resolution.
- Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation,
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
Inc.
Contributed by Andy Vaught & Katherine Holcomb
are generally set according to the function arguments. */
#include "config.h"
-#include <string.h>
-#include <stdarg.h>
-
+#include "system.h"
+#include "coretypes.h"
+#include "tree.h"
#include "gfortran.h"
#include "intrinsic.h"
-/* String pool subroutines. This are used to provide static locations
- for the string constants that represent library function names. */
-
-typedef struct string_node
-{
- struct string_node *next;
- char string[1];
-}
-string_node;
-
-#define HASH_SIZE 13
-
-static string_node *string_head[HASH_SIZE];
-
-
-/* Return a hash code based on the name. */
-
-static int
-hash (const char *name)
-{
- int h;
+/* Given printf-like arguments, return a stable version of the result string.
- h = 1;
- while (*name)
- h = 5311966 * h + *name++;
+ 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. */
- if (h < 0)
- h = -h;
- return h % HASH_SIZE;
-}
-
-
-/* Given printf-like arguments, return a static address of the
- resulting string. If the name is not in the table, it is added. */
-
-char *
+const char *
gfc_get_string (const char *format, ...)
{
- char temp_name[50];
- string_node *p;
+ char temp_name[128];
va_list ap;
- int h;
+ tree ident;
va_start (ap, format);
- vsprintf (temp_name, format, ap);
+ vsnprintf (temp_name, sizeof(temp_name), format, ap);
va_end (ap);
+ temp_name[sizeof(temp_name)-1] = 0;
- h = hash (temp_name);
-
- /* Search */
- for (p = string_head[h]; p; p = p->next)
- if (strcmp (p->string, temp_name) == 0)
- return p->string;
-
- /* Add */
- p = gfc_getmem (sizeof (string_node) + strlen (temp_name));
-
- strcpy (p->string, temp_name);
-
- p->next = string_head[h];
- string_head[h] = p;
-
- return p->string;
+ ident = get_identifier (temp_name);
+ return IDENTIFIER_POINTER (ident);
}
-
-
-static void
-free_strings (void)
-{
- string_node *p, *q;
- int h;
-
- for (h = 0; h < HASH_SIZE; h++)
- {
- for (p = string_head[h]; p; p = q)
- {
- q = p->next;
- gfc_free (p);
- }
- }
-}
-
-
/********************** 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;
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_aimag (gfc_expr * f, gfc_expr * x)
{
-
f->ts.type = BT_REAL;
f->ts.kind = x->ts.kind;
f->value.function.name =
void
gfc_resolve_aint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
{
-
f->ts.type = a->ts.type;
f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
void
gfc_resolve_all (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
{
-
f->ts = mask->ts;
if (dim != NULL)
}
f->value.function.name =
- gfc_get_string ("__all_%c%d", gfc_type_letter (mask->ts.type),
+ 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)
{
-
f->ts.type = a->ts.type;
f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
void
gfc_resolve_any (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
{
-
f->ts = mask->ts;
if (dim != NULL)
}
f->value.function.name =
- gfc_get_string ("__any_%c%d", gfc_type_letter (mask->ts.type),
+ 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_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);
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);
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;
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);
void
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);
void
-gfc_resolve_cmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y, gfc_expr * kind)
+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_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);
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)
{
-
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
}
f->value.function.name =
- gfc_get_string ("__count_%d_%c%d", f->ts.kind,
+ gfc_get_string (PREFIX("count_%d_%c%d"), f->ts.kind,
gfc_type_letter (mask->ts.type), mask->ts.kind);
}
gfc_convert_type_warn (dim, &shift->ts, 2, 0);
}
f->value.function.name =
- gfc_get_string ("__cshift%d_%d", n, shift->ts.kind);
+ gfc_get_string (PREFIX("cshift%d_%d"), n, shift->ts.kind);
}
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_resolve_dim (gfc_expr * f, gfc_expr * x,
gfc_expr * y ATTRIBUTE_UNUSED)
{
-
f->ts = x->ts;
f->value.function.name =
gfc_get_string ("__dim_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
{
temp.expr_type = EXPR_OP;
gfc_clear_ts (&temp.ts);
- temp.operator = INTRINSIC_NONE;
- temp.op1 = a;
- temp.op2 = b;
+ temp.value.op.operator = INTRINSIC_NONE;
+ temp.value.op.op1 = a;
+ temp.value.op.op2 = b;
gfc_type_convert_binary (&temp);
f->ts = temp.ts;
}
f->value.function.name =
- gfc_get_string ("__dot_product_%c%d", gfc_type_letter (f->ts.type),
+ gfc_get_string (PREFIX("dot_product_%c%d"), gfc_type_letter (f->ts.type),
f->ts.kind);
}
gfc_convert_type_warn (dim, &shift->ts, 2, 0);
f->value.function.name =
- gfc_get_string ("__eoshift%d_%d", n, shift->ts.kind);
+ 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;
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);
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)
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);
}
}
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_iand (gfc_expr * f, gfc_expr * i, gfc_expr * j)
{
/* If the kind of i and j are different, then g77 cross-promoted the
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);
}
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);
}
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)
{
-
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
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
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);
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_kill (gfc_expr * f, ATTRIBUTE_UNUSED gfc_expr * p,
+ ATTRIBUTE_UNUSED gfc_expr * s)
+{
+ 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)
{
void
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);
void
gfc_resolve_len_trim (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_trim%d", string->ts.kind);
void
-gfc_resolve_log (gfc_expr * f, gfc_expr * x)
+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_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);
{
temp.expr_type = EXPR_OP;
gfc_clear_ts (&temp.ts);
- temp.operator = INTRINSIC_NONE;
- temp.op1 = a;
- temp.op2 = b;
+ temp.value.op.operator = INTRINSIC_NONE;
+ temp.value.op.op1 = a;
+ temp.value.op.op2 = b;
gfc_type_convert_binary (&temp);
f->ts = temp.ts;
}
f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
f->value.function.name =
- gfc_get_string ("__matmul_%c%d", gfc_type_letter (f->ts.type),
+ gfc_get_string (PREFIX("matmul_%c%d"), gfc_type_letter (f->ts.type),
f->ts.kind);
}
name = mask ? "mmaxloc" : "maxloc";
f->value.function.name =
- gfc_get_string ("__%s%d_%d_%c%d", name, dim != NULL, f->ts.kind,
+ gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
gfc_type_letter (array->ts.type), array->ts.kind);
}
gfc_resolve_maxval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
gfc_expr * mask)
{
-
f->ts = array->ts;
if (dim != NULL)
}
f->value.function.name =
- gfc_get_string ("__%s_%c%d", mask ? "mmaxval" : "maxval",
+ gfc_get_string (PREFIX("%s_%c%d"), mask ? "mmaxval" : "maxval",
gfc_type_letter (array->ts.type), array->ts.kind);
}
gfc_expr * fsource ATTRIBUTE_UNUSED,
gfc_expr * mask ATTRIBUTE_UNUSED)
{
-
f->ts = tsource->ts;
f->value.function.name =
gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
name = mask ? "mminloc" : "minloc";
f->value.function.name =
- gfc_get_string ("__%s%d_%d_%c%d", name, dim != NULL, f->ts.kind,
+ gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
gfc_type_letter (array->ts.type), array->ts.kind);
}
gfc_resolve_minval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
gfc_expr * mask)
{
-
f->ts = array->ts;
if (dim != NULL)
}
f->value.function.name =
- gfc_get_string ("__%s_%c%d", mask ? "mminval" : "minval",
+ gfc_get_string (PREFIX("%s_%c%d"), mask ? "mminval" : "minval",
gfc_type_letter (array->ts.type), array->ts.kind);
}
gfc_resolve_mod (gfc_expr * f, gfc_expr * a,
gfc_expr * p ATTRIBUTE_UNUSED)
{
-
f->ts = a->ts;
f->value.function.name =
gfc_get_string ("__mod_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
gfc_resolve_modulo (gfc_expr * f, gfc_expr * a,
gfc_expr * p ATTRIBUTE_UNUSED)
{
-
f->ts = a->ts;
f->value.function.name =
gfc_get_string ("__modulo_%c%d", gfc_type_letter (a->ts.type),
}
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),
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);
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);
}
gfc_expr * mask,
gfc_expr * vector ATTRIBUTE_UNUSED)
{
- static char pack[] = "__pack",
- pack_s[] = "__pack_s";
-
f->ts = array->ts;
f->rank = 1;
if (mask->rank != 0)
- f->value.function.name = pack;
+ f->value.function.name = PREFIX("pack");
else
{
/* We convert mask to default logical only in the scalar case.
gfc_convert_type (mask, &ts, 2);
}
- f->value.function.name = pack_s;
+ f->value.function.name = PREFIX("pack_s");
}
}
gfc_resolve_product (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
gfc_expr * mask)
{
-
f->ts = array->ts;
if (dim != NULL)
}
f->value.function.name =
- gfc_get_string ("__%s_%c%d", mask ? "mproduct" : "product",
+ gfc_get_string (PREFIX("%s_%c%d"), mask ? "mproduct" : "product",
gfc_type_letter (array->ts.type), array->ts.kind);
}
void
gfc_resolve_real (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
{
-
f->ts.type = BT_REAL;
if (kind != NULL)
void
-gfc_resolve_repeat (gfc_expr * f, gfc_expr * string,
- gfc_expr * ncopies 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);
+}
+
+void
+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;
f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
gfc_expr * pad ATTRIBUTE_UNUSED,
gfc_expr * order ATTRIBUTE_UNUSED)
{
- static char reshape0[] = "__reshape";
mpz_t rank;
int kind;
int i;
case 8:
/* case 16: */
f->value.function.name =
- gfc_get_string ("__reshape_%d", source->ts.kind);
+ gfc_get_string (PREFIX("reshape_%d"), source->ts.kind);
break;
default:
- f->value.function.name = reshape0;
+ f->value.function.name = PREFIX("reshape");
break;
}
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)
{
-
f->ts = x->ts;
/* The implementation calls scalbn which takes an int as the
gfc_expr * set ATTRIBUTE_UNUSED,
gfc_expr * back ATTRIBUTE_UNUSED)
{
-
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
void
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 implment all possible
+ convert type so we don't have to implement all possible
permutations. */
if (i->ts.kind != 4)
{
void
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 ("__shape_%d", f->ts.kind);
+ 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);
}
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_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_spacing (gfc_expr * f, gfc_expr * x)
{
-
f->ts = x->ts;
f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
}
gfc_expr * dim,
gfc_expr * ncopies)
{
- static char spread[] = "__spread";
-
f->ts = source->ts;
f->rank = source->rank + 1;
- f->value.function.name = spread;
+ f->value.function.name = PREFIX("spread");
gfc_resolve_index (dim, 1);
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);
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_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_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
gfc_expr * mask)
{
-
f->ts = array->ts;
if (dim != NULL)
}
f->value.function.name =
- gfc_get_string ("__%s_%c%d", mask ? "msum" : "sum",
+ gfc_get_string (PREFIX("%s_%c%d"), mask ? "msum" : "sum",
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)
+{
+ 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
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_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)
{
void
gfc_resolve_transpose (gfc_expr * f, gfc_expr * matrix)
{
- static char transpose0[] = "__transpose";
int kind;
f->ts = matrix->ts;
mpz_init_set (f->shape[1], matrix->shape[0]);
}
- switch (matrix->ts.type)
- {
- case BT_COMPLEX:
- kind = matrix->ts.kind * 2;
- break;
-
- case BT_REAL:
- case BT_INTEGER:
- case BT_LOGICAL:
- kind = matrix->ts.kind;
- break;
-
- default:
- kind = 0;
- break;
-
- }
+ kind = matrix->ts.kind;
switch (kind)
{
case 4:
case 8:
- /* case 16: */
- f->value.function.name =
- gfc_get_string ("__transpose_%d", kind);
+ switch (matrix->ts.type)
+ {
+ case BT_COMPLEX:
+ f->value.function.name =
+ gfc_get_string (PREFIX("transpose_c%d"), kind);
+ break;
+
+ case BT_INTEGER:
+ case BT_REAL:
+ 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;
+ }
break;
default:
- f->value.function.name = transpose0;
+ f->value.function.name = PREFIX("transpose");
}
}
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_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);
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"));
gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask,
gfc_expr * field ATTRIBUTE_UNUSED)
{
-
f->ts.type = vector->ts.type;
f->ts.kind = vector->ts.kind;
f->rank = mask->rank;
f->value.function.name =
- gfc_get_string ("__unpack%d", field->rank > 0 ? 1 : 0);
+ gfc_get_string (PREFIX("unpack%d"), field->rank > 0 ? 1 : 0);
}
gfc_expr * set ATTRIBUTE_UNUSED,
gfc_expr * back ATTRIBUTE_UNUSED)
{
-
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
}
+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 etime() and dtime(). */
void
}
+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
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
+
+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
name = gfc_get_string (PREFIX("unlink_i%d_sub"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
-
-
-void
-gfc_iresolve_init_1 (void)
-{
- int i;
-
- for (i = 0; i < HASH_SIZE; i++)
- string_head[i] = NULL;
-}
-
-
-void
-gfc_iresolve_done_1 (void)
-{
-
- free_strings ();
-}
OSDN Git Service
