iresolve.c

gcc-fortran,linux使用fortran的编译软件。很好用的。

/* Intrinsic function resolution.
   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
   Inc.
   Contributed by Andy Vaught & Katherine Holcomb

This file is part of GCC.

GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
Software Foundation; either version 2, or (at your option) any later
version.

GCC is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
for more details.

You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING.  If not, write to the Free
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.  */


/* Assign name and types to intrinsic procedures.  For functions, the
   first argument to a resolution function is an expression pointer to
   the original function node and the rest are pointers to the
   arguments of the function call.  For subroutines, a pointer to the
   code node is passed.  The result type and library subroutine name
   are generally set according to the function arguments.  */

#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tree.h"
#include "gfortran.h"
#include "intrinsic.h"


/* Given printf-like arguments, return a stable version of the result string. 

   We already have a working, optimized string hashing table in the form of
   the identifier table.  Reusing this table is likely not to be wasted, 
   since if the function name makes it to the gimple output of the frontend,
   we'll have to create the identifier anyway.  */

const char *
gfc_get_string (const char *format, ...)
{
  char temp_name[128];
  va_list ap;
  tree ident;

  va_start (ap, format);
  vsnprintf (temp_name, sizeof(temp_name), format, ap);
  va_end (ap);
  temp_name[sizeof(temp_name)-1] = 0;

  ident = get_identifier (temp_name);
  return IDENTIFIER_POINTER (ident);
}

/* MERGE and SPREAD need to have source charlen's present for passing
   to the result expression.  */
static void
check_charlen_present (gfc_expr *source)
{
  if (source->expr_type == EXPR_CONSTANT && source->ts.cl == NULL)
    {
      source->ts.cl = gfc_get_charlen ();
      source->ts.cl->next = gfc_current_ns->cl_list;
      gfc_current_ns->cl_list = source->ts.cl;
      source->ts.cl->length = gfc_int_expr (source->value.character.length);
      source->rank = 0;
    }
}

/********************** Resolution functions **********************/


void
gfc_resolve_abs (gfc_expr * f, gfc_expr * a)
{
  f->ts = a->ts;
  if (f->ts.type == BT_COMPLEX)
    f->ts.type = BT_REAL;

  f->value.function.name =
    gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
}


void
gfc_resolve_acos (gfc_expr * f, gfc_expr * x)
{
  f->ts = x->ts;
  f->value.function.name =
    gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}


void
gfc_resolve_acosh (gfc_expr * f, gfc_expr * x)
{
  f->ts = x->ts;
  f->value.function.name =
    gfc_get_string ("__acosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}


void
gfc_resolve_aimag (gfc_expr * f, gfc_expr * x)
{
  f->ts.type = BT_REAL;
  f->ts.kind = x->ts.kind;
  f->value.function.name =
    gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}


void
gfc_resolve_and (gfc_expr * f, gfc_expr * i, gfc_expr * j)
{
  f->ts.type = i->ts.type;
  f->ts.kind = gfc_kind_max (i,j);

  if (i->ts.kind != j->ts.kind)
    {
      if (i->ts.kind == gfc_kind_max (i,j))
	gfc_convert_type(j, &i->ts, 2);
      else
	gfc_convert_type(i, &j->ts, 2);
    }

  f->value.function.name = gfc_get_string ("__and_%c%d",
					   gfc_type_letter (i->ts.type),
					   f->ts.kind);
}


void
gfc_resolve_aint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
{
  gfc_typespec ts;
  
  f->ts.type = a->ts.type;
  f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);

  if (a->ts.kind != f->ts.kind)
    {
      ts.type = f->ts.type;
      ts.kind = f->ts.kind;
      gfc_convert_type (a, &ts, 2);
    }
  /* The resolved name is only used for specific intrinsics where
     the return kind is the same as the arg kind.  */
  f->value.function.name =
    gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
}


void
gfc_resolve_dint (gfc_expr * f, gfc_expr * a)
{
  gfc_resolve_aint (f, a, NULL);
}


void
gfc_resolve_all (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
{
  f->ts = mask->ts;

  if (dim != NULL)
    {
      gfc_resolve_dim_arg (dim);
      f->rank = mask->rank - 1;
      f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
    }

  f->value.function.name =
    gfc_get_string (PREFIX("all_%c%d"), gfc_type_letter (mask->ts.type),
		    mask->ts.kind);
}


void
gfc_resolve_anint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
{
  gfc_typespec ts;
  
  f->ts.type = a->ts.type;
  f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);

  if (a->ts.kind != f->ts.kind)
    {
      ts.type = f->ts.type;
      ts.kind = f->ts.kind;
      gfc_convert_type (a, &ts, 2);
    }

  /* The resolved name is only used for specific intrinsics where
     the return kind is the same as the arg kind.  */
  f->value.function.name =
    gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
}


void
gfc_resolve_dnint (gfc_expr * f, gfc_expr * a)
{
  gfc_resolve_anint (f, a, NULL);
}


void
gfc_resolve_any (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
{
  f->ts = mask->ts;

  if (dim != NULL)
    {
      gfc_resolve_dim_arg (dim);
      f->rank = mask->rank - 1;
      f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
    }

  f->value.function.name =
    gfc_get_string (PREFIX("any_%c%d"), gfc_type_letter (mask->ts.type),
		    mask->ts.kind);
}


void
gfc_resolve_asin (gfc_expr * f, gfc_expr * x)
{
  f->ts = x->ts;
  f->value.function.name =
    gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}

void
gfc_resolve_asinh (gfc_expr * f, gfc_expr * x)
{
  f->ts = x->ts;
  f->value.function.name =
    gfc_get_string ("__asinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}

void
gfc_resolve_atan (gfc_expr * f, gfc_expr * x)
{
  f->ts = x->ts;
  f->value.function.name =
    gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}

void
gfc_resolve_atanh (gfc_expr * f, gfc_expr * x)
{
  f->ts = x->ts;
  f->value.function.name =
    gfc_get_string ("__atanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}

void
gfc_resolve_atan2 (gfc_expr * f, gfc_expr * x,
		   gfc_expr * y ATTRIBUTE_UNUSED)
{
  f->ts = x->ts;
  f->value.function.name =
    gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}


/* Resolve the BESYN and BESJN intrinsics.  */

void
gfc_resolve_besn (gfc_expr * f, gfc_expr * n, gfc_expr * x)
{
  gfc_typespec ts;
  
  f->ts = x->ts;
  if (n->ts.kind != gfc_c_int_kind)
    {
      ts.type = BT_INTEGER;
      ts.kind = gfc_c_int_kind;
      gfc_convert_type (n, &ts, 2);
    }
  f->value.function.name = gfc_get_string ("<intrinsic>");
}


void
gfc_resolve_btest (gfc_expr * f, gfc_expr * i, gfc_expr * pos)
{
  f->ts.type = BT_LOGICAL;
  f->ts.kind = gfc_default_logical_kind;

  f->value.function.name = gfc_get_string ("__btest_%d_%d", i->ts.kind,
					   pos->ts.kind);
}


void
gfc_resolve_ceiling (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
    : mpz_get_si (kind->value.integer);

  f->value.function.name =
    gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind,
		    gfc_type_letter (a->ts.type), a->ts.kind);
}


void
gfc_resolve_char (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
{
  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);
}


void
gfc_resolve_chdir (gfc_expr * f, gfc_expr * d ATTRIBUTE_UNUSED)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_default_integer_kind;
  f->value.function.name = gfc_get_string (PREFIX("chdir_i%d"), f->ts.kind);
}


void
gfc_resolve_chdir_sub (gfc_code * c)
{
  const char *name;
  int kind;

  if (c->ext.actual->next->expr != NULL)
    kind = c->ext.actual->next->expr->ts.kind;
  else
    kind = gfc_default_integer_kind;

  name = gfc_get_string (PREFIX("chdir_i%d_sub"), kind);
  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}


void
gfc_resolve_cmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y, gfc_expr * kind)
{
  f->ts.type = BT_COMPLEX;
  f->ts.kind = (kind == NULL) ? gfc_default_real_kind
    : mpz_get_si (kind->value.integer);

  if (y == NULL)
    f->value.function.name =
      gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind,
		      gfc_type_letter (x->ts.type), x->ts.kind);
  else
    f->value.function.name =
      gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
		      gfc_type_letter (x->ts.type), x->ts.kind,
		      gfc_type_letter (y->ts.type), y->ts.kind);
}

void
gfc_resolve_dcmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y)
{
  gfc_resolve_cmplx (f, x, y, gfc_int_expr (gfc_default_double_kind));
}

void
gfc_resolve_complex (gfc_expr * f, gfc_expr * x, gfc_expr * y)
{
  int kind;

  if (x->ts.type == BT_INTEGER)
    {
      if (y->ts.type == BT_INTEGER)
	kind = gfc_default_real_kind;
      else
	kind = y->ts.kind;
    }
  else
    {
      if (y->ts.type == BT_REAL)
	kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
      else
	kind = x->ts.kind;
    }

  f->ts.type = BT_COMPLEX;
  f->ts.kind = kind;

  f->value.function.name =
    gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
		    gfc_type_letter (x->ts.type), x->ts.kind,
		    gfc_type_letter (y->ts.type), y->ts.kind);
}


void
gfc_resolve_conjg (gfc_expr * f, gfc_expr * x)
{
  f->ts = x->ts;
  f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind);
}


void
gfc_resolve_cos (gfc_expr * f, gfc_expr * x)
{
  f->ts = x->ts;
  f->value.function.name =
    gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}


void
gfc_resolve_cosh (gfc_expr * f, gfc_expr * x)
{
  f->ts = x->ts;
  f->value.function.name =
    gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}


void
gfc_resolve_count (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_default_integer_kind;

  if (dim != NULL)
    {
      f->rank = mask->rank - 1;
      gfc_resolve_dim_arg (dim);
      f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
    }

  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)
{
  int n;

  f->ts = array->ts;
  f->rank = array->rank;
  f->shape = gfc_copy_shape (array->shape, array->rank);

  if (shift->rank > 0)
    n = 1;
  else
    n = 0;

  /* Convert shift to at least gfc_default_integer_kind, so we don't need
     kind=1 and kind=2 versions of the library functions.  */
  if (shift->ts.kind < gfc_default_integer_kind)
    {
      gfc_typespec ts;
      ts.type = BT_INTEGER;
      ts.kind = gfc_default_integer_kind;
      gfc_convert_type_warn (shift, &ts, 2, 0);
    }

  if (dim != NULL)
    {
      gfc_resolve_dim_arg (dim);
      /* Convert dim to shift's kind, so we don't need so many variations.  */
      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" : "");
}


void
gfc_resolve_ctime (gfc_expr * f, gfc_expr * time)
{
  gfc_typespec ts;
  
  f->ts.type = BT_CHARACTER;
  f->ts.kind = gfc_default_character_kind;

  /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
  if (time->ts.kind != 8)
    {
      ts.type = BT_INTEGER;
      ts.kind = 8;
      ts.derived = NULL;
      ts.cl = NULL;
      gfc_convert_type (time, &ts, 2);
    }

  f->value.function.name = gfc_get_string (PREFIX("ctime"));
}


void
gfc_resolve_dble (gfc_expr * f, gfc_expr * a)
{
  f->ts.type = BT_REAL;
  f->ts.kind = gfc_default_double_kind;
  f->value.function.name =
    gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
}


void
gfc_resolve_dim (gfc_expr * f, gfc_expr * a, gfc_expr * p)
{
  f->ts.type = a->ts.type;
  if (p != NULL)
    f->ts.kind = gfc_kind_max (a,p);
  else
    f->ts.kind = a->ts.kind;

  if (p != NULL && a->ts.kind != p->ts.kind)
    {
      if (a->ts.kind == gfc_kind_max (a,p))
	gfc_convert_type(p, &a->ts, 2);
      else
	gfc_convert_type(a, &p->ts, 2);
    }

  f->value.function.name =
    gfc_get_string ("__dim_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
}


void
gfc_resolve_dot_product (gfc_expr * f, gfc_expr * a, gfc_expr * b)
{
  gfc_expr temp;

  if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
    {
      f->ts.type = BT_LOGICAL;
      f->ts.kind = gfc_default_logical_kind;
    }
  else
    {
      temp.expr_type = EXPR_OP;
      gfc_clear_ts (&temp.ts);
      temp.value.op.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 (PREFIX("dot_product_%c%d"), gfc_type_letter (f->ts.type),
		    f->ts.kind);
}


void
gfc_resolve_dprod (gfc_expr * f,
		   gfc_expr * a ATTRIBUTE_UNUSED,
		   gfc_expr * b ATTRIBUTE_UNUSED)
{
  f->ts.kind = gfc_default_double_kind;
  f->ts.type = BT_REAL;

  f->value.function.name = gfc_get_string ("__dprod_r%d", f->ts.kind);
}


void
gfc_resolve_eoshift (gfc_expr * f, gfc_expr * array,
		     gfc_expr * shift,
		     gfc_expr * boundary,
		     gfc_expr * dim)
{
  int n;

  f->ts = array->ts;
  f->rank = array->rank;
  f->shape = gfc_copy_shape (array->shape, array->rank);

  n = 0;
  if (shift->rank > 0)
    n = n | 1;
  if (boundary && boundary->rank > 0)
    n = n | 2;

  /* Convert shift to at least gfc_default_integer_kind, so we don't need
     kind=1 and kind=2 versions of the library functions.  */
  if (shift->ts.kind < gfc_default_integer_kind)
    {
      gfc_typespec ts;
      ts.type = BT_INTEGER;
      ts.kind = gfc_default_integer_kind;
      gfc_convert_type_warn (shift, &ts, 2, 0);
    }

  if (dim != NULL)
    {
      gfc_resolve_dim_arg (dim);
      /* Convert dim to shift's kind, so we don't need so many variations.  */
      if (dim->ts.kind != shift->ts.kind)
	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" : "");
}


void
gfc_resolve_exp (gfc_expr * f, gfc_expr * x)
{
  f->ts = x->ts;
  f->value.function.name =
    gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}


void
gfc_resolve_exponent (gfc_expr * f, gfc_expr * x)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_default_integer_kind;

  f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind);
}


void
gfc_resolve_fdate (gfc_expr * f)
{
  f->ts.type = BT_CHARACTER;
  f->ts.kind = gfc_default_character_kind;
  f->value.function.name = gfc_get_string (PREFIX("fdate"));
}


void
gfc_resolve_floor (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
{
  f->ts.type = BT_INTEGER;