iresolve.c

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

gfc_resolve_product (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
		     gfc_expr * mask)
{
  f->ts = array->ts;

  if (dim != NULL)
    {
      f->rank = array->rank - 1;
      gfc_resolve_dim_arg (dim);
    }

  f->value.function.name =
    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)
    f->ts.kind = mpz_get_si (kind->value.integer);
  else
    f->ts.kind = (a->ts.type == BT_COMPLEX) ?
      a->ts.kind : gfc_default_real_kind;

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


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


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


void
gfc_resolve_repeat (gfc_expr * f, gfc_expr * string,
		    gfc_expr * ncopies 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);
}


void
gfc_resolve_reshape (gfc_expr * f, gfc_expr * source, gfc_expr * shape,
		     gfc_expr * pad ATTRIBUTE_UNUSED,
		     gfc_expr * order ATTRIBUTE_UNUSED)
{
  mpz_t rank;
  int kind;
  int i;

  f->ts = source->ts;

  gfc_array_size (shape, &rank);
  f->rank = mpz_get_si (rank);
  mpz_clear (rank);
  switch (source->ts.type)
    {
    case BT_COMPLEX:
      kind = source->ts.kind * 2;
      break;

    case BT_REAL:
    case BT_INTEGER:
    case BT_LOGICAL:
      kind = source->ts.kind;
      break;

    default:
      kind = 0;
      break;
    }

  switch (kind)
    {
    case 4:
    case 8:
    case 10:
    case 16:
      if (source->ts.type == BT_COMPLEX)
	f->value.function.name =
	  gfc_get_string (PREFIX("reshape_%c%d"),
			  gfc_type_letter (BT_COMPLEX), source->ts.kind);
      else
	f->value.function.name =
	  gfc_get_string (PREFIX("reshape_%d"), source->ts.kind);

      break;

    default:
      f->value.function.name = (source->ts.type == BT_CHARACTER
				? PREFIX("reshape_char")
				: PREFIX("reshape"));
      break;
    }

  /* TODO: Make this work with a constant ORDER parameter.  */
  if (shape->expr_type == EXPR_ARRAY
      && gfc_is_constant_expr (shape)
      && order == NULL)
    {
      gfc_constructor *c;
      f->shape = gfc_get_shape (f->rank);
      c = shape->value.constructor;
      for (i = 0; i < f->rank; i++)
	{
	  mpz_init_set (f->shape[i], c->expr->value.integer);
	  c = c->next;
	}
    }

  /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
     so many runtime variations.  */
  if (shape->ts.kind != gfc_index_integer_kind)
    {
      gfc_typespec ts = shape->ts;
      ts.kind = gfc_index_integer_kind;
      gfc_convert_type_warn (shape, &ts, 2, 0);
    }
  if (order && order->ts.kind != gfc_index_integer_kind)
    gfc_convert_type_warn (order, &shape->ts, 2, 0);
}


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


void
gfc_resolve_scale (gfc_expr * f, gfc_expr * x, gfc_expr * i)
{
  f->ts = x->ts;

  /* The implementation calls scalbn which takes an int as the
     second argument.  */
  if (i->ts.kind != gfc_c_int_kind)
    {
      gfc_typespec ts;

      ts.type = BT_INTEGER;
      ts.kind = gfc_default_integer_kind;

      gfc_convert_type_warn (i, &ts, 2, 0);
    }

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


void
gfc_resolve_scan (gfc_expr * f, gfc_expr * string,
		  gfc_expr * set ATTRIBUTE_UNUSED,
		  gfc_expr * back ATTRIBUTE_UNUSED)
{
  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_secnds (gfc_expr * t1, gfc_expr * t0)
{
  t1->ts = t0->ts;
  t1->value.function.name =
    gfc_get_string (PREFIX("secnds"));
}


void
gfc_resolve_set_exponent (gfc_expr * f, gfc_expr * x, gfc_expr * i)
{
  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)
    {
      gfc_typespec ts;

      ts.type = BT_INTEGER;
      ts.kind = gfc_default_integer_kind;

      gfc_convert_type_warn (i, &ts, 2, 0);
    }

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


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 (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_signal (gfc_expr * f, gfc_expr *number, gfc_expr *handler)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_c_int_kind;

  /* handler can be either BT_INTEGER or BT_PROCEDURE  */
  if (handler->ts.type == BT_INTEGER)
    {
      if (handler->ts.kind != gfc_c_int_kind)
	gfc_convert_type (handler, &f->ts, 2);
      f->value.function.name = gfc_get_string (PREFIX("signal_func_int"));
    }
  else
    f->value.function.name = gfc_get_string (PREFIX("signal_func"));

  if (number->ts.kind != gfc_c_int_kind)
    gfc_convert_type (number, &f->ts, 2);
}


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


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


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


void
gfc_resolve_spread (gfc_expr * f, gfc_expr * source,
		    gfc_expr * dim,
		    gfc_expr * ncopies)
{
  if (source->ts.type == BT_CHARACTER)
    check_charlen_present (source);

  f->ts = source->ts;
  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"));
  else
    f->value.function.name = (source->ts.type == BT_CHARACTER
			      ? PREFIX("spread_char")
			      : PREFIX("spread"));

  gfc_resolve_dim_arg (dim);
  gfc_resolve_index (ncopies, 1);
}


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


/* Resolve the g77 compatibility function STAT AND FSTAT.  */

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


void
gfc_resolve_fstat (gfc_expr * f, gfc_expr * n, gfc_expr * a ATTRIBUTE_UNUSED)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_default_integer_kind;
  if (n->ts.kind != f->ts.kind)
    gfc_convert_type (n, &f->ts, 2);

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


void
gfc_resolve_fgetc (gfc_expr * f, gfc_expr * u, gfc_expr * c ATTRIBUTE_UNUSED)
{
  gfc_typespec ts;

  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_c_int_kind;
  if (u->ts.kind != gfc_c_int_kind)
    {
      ts.type = BT_INTEGER;
      ts.kind = gfc_c_int_kind;
      ts.derived = NULL;
      ts.cl = NULL;
      gfc_convert_type (u, &ts, 2);
    }

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


void
gfc_resolve_fget (gfc_expr * f, gfc_expr * c ATTRIBUTE_UNUSED)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_c_int_kind;
  f->value.function.name = gfc_get_string (PREFIX("fget"));
}


void
gfc_resolve_fputc (gfc_expr * f, gfc_expr * u, gfc_expr * c ATTRIBUTE_UNUSED)
{
  gfc_typespec ts;

  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_c_int_kind;
  if (u->ts.kind != gfc_c_int_kind)
    {
      ts.type = BT_INTEGER;
      ts.kind = gfc_c_int_kind;
      ts.derived = NULL;
      ts.cl = NULL;
      gfc_convert_type (u, &ts, 2);
    }

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


void
gfc_resolve_fput (gfc_expr * f, gfc_expr * c ATTRIBUTE_UNUSED)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_c_int_kind;
  f->value.function.name = gfc_get_string (PREFIX("fput"));
}


void
gfc_resolve_ftell (gfc_expr * f, gfc_expr * u)
{
  gfc_typespec ts;

  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_index_integer_kind;
  if (u->ts.kind != gfc_c_int_kind)
    {
      ts.type = BT_INTEGER;
      ts.kind = gfc_c_int_kind;
      ts.derived = NULL;
      ts.cl = NULL;
      gfc_convert_type (u, &ts, 2);
    }

  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)
{
  f->ts = array->ts;

  if (dim != NULL)
    {
      f->rank = array->rank - 1;
      gfc_resolve_dim_arg (dim);
    }

  f->value.function.name =
    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
gfc_resolve_system (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = 4;
  f->value.function.name = gfc_get_string (PREFIX("system"));
}


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


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


void
gfc_resolve_time (gfc_expr * f)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = 4;
  f->value.function.name = gfc_get_string (PREFIX("time_func"));
}


void
gfc_resolve_time8 (gfc_expr * f)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = 8;
  f->value.function.name = gfc_get_string (PREFIX("time8_func"));
}


void
gfc_resolve_transfer (gfc_expr * f, gfc_expr * source ATTRIBUTE_UNUSED,
		      gfc_expr * mold, gfc_expr * size)
{
  /* TODO: Make this do something meaningful.  */
  static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";

  f->ts = mold->ts;

  if (size == NULL && mold->rank == 0)
    {
      f->rank = 0;
      f->value.function.name = transfer0;
    }
  else
    {
      f->rank = 1;
      f->value.function.name = transfer1;
    }
}


void
gfc_resolve_transpose (gfc_expr * f, gfc_expr * matrix)
{
  int kind;

  f->ts = matrix->ts;
  f->rank = 2;
  if (matrix->shape)
    {
      f->shape = gfc_get_shape (2);
      mpz_init_set (f->shape[0], matrix->shape[1]);
      mpz_init_set (f->shape[1], matrix->shape[0]);
    }

  kind = matrix->ts.kind;

  switch (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_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 = (matrix->ts.type == BT_CHARACTER
				? PREFIX("transpose_char")
				: PREFIX("transpose"));
      break;
    }
}


void
gfc_resolve_trim (gfc_expr * f, gfc_expr * string)
{
  f->ts.type = BT_CHARACTER;
  f->ts.kind = string->ts.kind;
  f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
}


void
gfc_resolve_ubound (gfc_expr * f, gfc_expr * array,
		    gfc_expr * dim)
{
  static char ubound[] = "__ubound";

  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_default_integer_kind;

  if (dim == NULL)
    {
      f->rank = 1;
      f->shape = gfc_get_shape (1);
      mpz_init_set_ui (f->shape[0], array->rank);
    }

  f->value.function.name = ubound;
}


/* Resolve the g77 compatibility function UMASK.  */

void
gfc_resolve_umask (gfc_expr * f, gfc_expr * n)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = n->ts.kind;
  f->value.function.name = gfc_get_string (PREFIX("umask_i%d"), n->ts.kind);
}


/* Resolve the g77 compatibility function UNLINK.  */

void
gfc_resolve_unlink (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = 4;
  f->value.function.name = gfc_get_string (PREFIX("unlink"));
}


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

  if (unit->ts.kind != gfc_c_int_kind)
    {
      ts.type = BT_INTEGER;
      ts.kind = gfc_c_int_kind;
      ts.derived = NULL;
      ts.cl = NULL;
      gfc_convert_type (unit, &ts, 2);
    }

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


void
gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask,
		    gfc_expr * field ATTRIBUTE_UNUSED)
{
  f->ts = vector->ts;
  f->rank = mask->rank;

  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,