expr.c

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

/* Routines for manipulation of expression nodes.
   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software 
   Foundation, Inc.
   Contributed by Andy Vaught

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.  */

#include "config.h"
#include "system.h"
#include "gfortran.h"
#include "arith.h"
#include "match.h"

/* Get a new expr node.  */

gfc_expr *
gfc_get_expr (void)
{
  gfc_expr *e;

  e = gfc_getmem (sizeof (gfc_expr));

  gfc_clear_ts (&e->ts);
  e->shape = NULL;
  e->ref = NULL;
  e->symtree = NULL;

  return e;
}


/* Free an argument list and everything below it.  */

void
gfc_free_actual_arglist (gfc_actual_arglist * a1)
{
  gfc_actual_arglist *a2;

  while (a1)
    {
      a2 = a1->next;
      gfc_free_expr (a1->expr);
      gfc_free (a1);
      a1 = a2;
    }
}


/* Copy an arglist structure and all of the arguments.  */

gfc_actual_arglist *
gfc_copy_actual_arglist (gfc_actual_arglist * p)
{
  gfc_actual_arglist *head, *tail, *new;

  head = tail = NULL;

  for (; p; p = p->next)
    {
      new = gfc_get_actual_arglist ();
      *new = *p;

      new->expr = gfc_copy_expr (p->expr);
      new->next = NULL;

      if (head == NULL)
	head = new;
      else
	tail->next = new;

      tail = new;
    }

  return head;
}


/* Free a list of reference structures.  */

void
gfc_free_ref_list (gfc_ref * p)
{
  gfc_ref *q;
  int i;

  for (; p; p = q)
    {
      q = p->next;

      switch (p->type)
	{
	case REF_ARRAY:
	  for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
	    {
	      gfc_free_expr (p->u.ar.start[i]);
	      gfc_free_expr (p->u.ar.end[i]);
	      gfc_free_expr (p->u.ar.stride[i]);
	    }

	  break;

	case REF_SUBSTRING:
	  gfc_free_expr (p->u.ss.start);
	  gfc_free_expr (p->u.ss.end);
	  break;

	case REF_COMPONENT:
	  break;
	}

      gfc_free (p);
    }
}


/* Workhorse function for gfc_free_expr() that frees everything
   beneath an expression node, but not the node itself.  This is
   useful when we want to simplify a node and replace it with
   something else or the expression node belongs to another structure.  */

static void
free_expr0 (gfc_expr * e)
{
  int n;

  switch (e->expr_type)
    {
    case EXPR_CONSTANT:
      if (e->from_H)
	{
	  gfc_free (e->value.character.string);
	  break;
	}

      switch (e->ts.type)
	{
	case BT_INTEGER:
	  mpz_clear (e->value.integer);
	  break;

	case BT_REAL:
	  mpfr_clear (e->value.real);
	  break;

	case BT_CHARACTER:
	case BT_HOLLERITH:
	  gfc_free (e->value.character.string);
	  break;

	case BT_COMPLEX:
	  mpfr_clear (e->value.complex.r);
	  mpfr_clear (e->value.complex.i);
	  break;

	default:
	  break;
	}

      break;

    case EXPR_OP:
      if (e->value.op.op1 != NULL)
	gfc_free_expr (e->value.op.op1);
      if (e->value.op.op2 != NULL)
	gfc_free_expr (e->value.op.op2);
      break;

    case EXPR_FUNCTION:
      gfc_free_actual_arglist (e->value.function.actual);
      break;

    case EXPR_VARIABLE:
      break;

    case EXPR_ARRAY:
    case EXPR_STRUCTURE:
      gfc_free_constructor (e->value.constructor);
      break;

    case EXPR_SUBSTRING:
      gfc_free (e->value.character.string);
      break;

    case EXPR_NULL:
      break;

    default:
      gfc_internal_error ("free_expr0(): Bad expr type");
    }

  /* Free a shape array.  */
  if (e->shape != NULL)
    {
      for (n = 0; n < e->rank; n++)
	mpz_clear (e->shape[n]);

      gfc_free (e->shape);
    }

  gfc_free_ref_list (e->ref);

  memset (e, '\0', sizeof (gfc_expr));
}


/* Free an expression node and everything beneath it.  */

void
gfc_free_expr (gfc_expr * e)
{

  if (e == NULL)
    return;

  free_expr0 (e);
  gfc_free (e);
}


/* Graft the *src expression onto the *dest subexpression.  */

void
gfc_replace_expr (gfc_expr * dest, gfc_expr * src)
{

  free_expr0 (dest);
  *dest = *src;

  gfc_free (src);
}


/* Try to extract an integer constant from the passed expression node.
   Returns an error message or NULL if the result is set.  It is
   tempting to generate an error and return SUCCESS or FAILURE, but
   failure is OK for some callers.  */

const char *
gfc_extract_int (gfc_expr * expr, int *result)
{

  if (expr->expr_type != EXPR_CONSTANT)
    return _("Constant expression required at %C");

  if (expr->ts.type != BT_INTEGER)
    return _("Integer expression required at %C");

  if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0)
      || (mpz_cmp_si (expr->value.integer, INT_MIN) < 0))
    {
      return _("Integer value too large in expression at %C");
    }

  *result = (int) mpz_get_si (expr->value.integer);

  return NULL;
}


/* Recursively copy a list of reference structures.  */

static gfc_ref *
copy_ref (gfc_ref * src)
{
  gfc_array_ref *ar;
  gfc_ref *dest;

  if (src == NULL)
    return NULL;

  dest = gfc_get_ref ();
  dest->type = src->type;

  switch (src->type)
    {
    case REF_ARRAY:
      ar = gfc_copy_array_ref (&src->u.ar);
      dest->u.ar = *ar;
      gfc_free (ar);
      break;

    case REF_COMPONENT:
      dest->u.c = src->u.c;
      break;

    case REF_SUBSTRING:
      dest->u.ss = src->u.ss;
      dest->u.ss.start = gfc_copy_expr (src->u.ss.start);
      dest->u.ss.end = gfc_copy_expr (src->u.ss.end);
      break;
    }

  dest->next = copy_ref (src->next);

  return dest;
}


/* Detect whether an expression has any vector index array
   references.  */

int
gfc_has_vector_index (gfc_expr *e)
{
  gfc_ref * ref;
  int i;
  for (ref = e->ref; ref; ref = ref->next)
    if (ref->type == REF_ARRAY)
      for (i = 0; i < ref->u.ar.dimen; i++)
	if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
	  return 1;
  return 0;
}


/* Copy a shape array.  */

mpz_t *
gfc_copy_shape (mpz_t * shape, int rank)
{
  mpz_t *new_shape;
  int n;

  if (shape == NULL)
    return NULL;

  new_shape = gfc_get_shape (rank);

  for (n = 0; n < rank; n++)
    mpz_init_set (new_shape[n], shape[n]);

  return new_shape;
}


/* Copy a shape array excluding dimension N, where N is an integer
   constant expression.  Dimensions are numbered in fortran style --
   starting with ONE.

   So, if the original shape array contains R elements
      { s1 ... sN-1  sN  sN+1 ... sR-1 sR}
   the result contains R-1 elements:
      { s1 ... sN-1  sN+1    ...  sR-1}

   If anything goes wrong -- N is not a constant, its value is out
   of range -- or anything else, just returns NULL.
*/

mpz_t *
gfc_copy_shape_excluding (mpz_t * shape, int rank, gfc_expr * dim)
{
  mpz_t *new_shape, *s;
  int i, n;

  if (shape == NULL 
      || rank <= 1
      || dim == NULL
      || dim->expr_type != EXPR_CONSTANT 
      || dim->ts.type != BT_INTEGER)
    return NULL;

  n = mpz_get_si (dim->value.integer);
  n--; /* Convert to zero based index */
  if (n < 0 || n >= rank)
    return NULL;

  s = new_shape = gfc_get_shape (rank-1);

  for (i = 0; i < rank; i++)
    {
      if (i == n)
        continue;
      mpz_init_set (*s, shape[i]);
      s++;
    }

  return new_shape;
}

/* Given an expression pointer, return a copy of the expression.  This
   subroutine is recursive.  */

gfc_expr *
gfc_copy_expr (gfc_expr * p)
{
  gfc_expr *q;
  char *s;

  if (p == NULL)
    return NULL;

  q = gfc_get_expr ();
  *q = *p;

  switch (q->expr_type)
    {
    case EXPR_SUBSTRING:
      s = gfc_getmem (p->value.character.length + 1);
      q->value.character.string = s;

      memcpy (s, p->value.character.string, p->value.character.length + 1);
      break;

    case EXPR_CONSTANT:
      if (p->from_H)
	{
	  s = gfc_getmem (p->value.character.length + 1);
	  q->value.character.string = s;

	  memcpy (s, p->value.character.string,
		  p->value.character.length + 1);
	  break;
	}
      switch (q->ts.type)
	{
	case BT_INTEGER:
	  mpz_init_set (q->value.integer, p->value.integer);
	  break;

	case BT_REAL:
          gfc_set_model_kind (q->ts.kind);
          mpfr_init (q->value.real);
	  mpfr_set (q->value.real, p->value.real, GFC_RND_MODE);
	  break;

	case BT_COMPLEX:
          gfc_set_model_kind (q->ts.kind);
          mpfr_init (q->value.complex.r);
          mpfr_init (q->value.complex.i);
	  mpfr_set (q->value.complex.r, p->value.complex.r, GFC_RND_MODE);
	  mpfr_set (q->value.complex.i, p->value.complex.i, GFC_RND_MODE);
	  break;

	case BT_CHARACTER:
	case BT_HOLLERITH:
	  s = gfc_getmem (p->value.character.length + 1);
	  q->value.character.string = s;

	  memcpy (s, p->value.character.string,
		  p->value.character.length + 1);
	  break;

	case BT_LOGICAL:
	case BT_DERIVED:
	  break;		/* Already done */

	case BT_PROCEDURE:
	case BT_UNKNOWN:
	  gfc_internal_error ("gfc_copy_expr(): Bad expr node");
	  /* Not reached */
	}

      break;

    case EXPR_OP:
      switch (q->value.op.operator)
	{
	case INTRINSIC_NOT:
	case INTRINSIC_UPLUS:
	case INTRINSIC_UMINUS:
	  q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
	  break;

	default:		/* Binary operators */
	  q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
	  q->value.op.op2 = gfc_copy_expr (p->value.op.op2);
	  break;
	}

      break;

    case EXPR_FUNCTION:
      q->value.function.actual =
	gfc_copy_actual_arglist (p->value.function.actual);
      break;

    case EXPR_STRUCTURE:
    case EXPR_ARRAY:
      q->value.constructor = gfc_copy_constructor (p->value.constructor);
      break;

    case EXPR_VARIABLE:
    case EXPR_NULL:
      break;
    }

  q->shape = gfc_copy_shape (p->shape, p->rank);

  q->ref = copy_ref (p->ref);

  return q;
}


/* Return the maximum kind of two expressions.  In general, higher
   kind numbers mean more precision for numeric types.  */

int
gfc_kind_max (gfc_expr * e1, gfc_expr * e2)
{

  return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind;
}


/* Returns nonzero if the type is numeric, zero otherwise.  */

static int
numeric_type (bt type)
{

  return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER;
}


/* Returns nonzero if the typespec is a numeric type, zero otherwise.  */

int
gfc_numeric_ts (gfc_typespec * ts)
{

  return numeric_type (ts->type);
}


/* Returns an expression node that is an integer constant.  */

gfc_expr *
gfc_int_expr (int i)
{
  gfc_expr *p;

  p = gfc_get_expr ();

  p->expr_type = EXPR_CONSTANT;
  p->ts.type = BT_INTEGER;
  p->ts.kind = gfc_default_integer_kind;

  p->where = gfc_current_locus;
  mpz_init_set_si (p->value.integer, i);

  return p;
}