iresolve.c

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

  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)
{
  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);
}


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);
}


/* Resolve single-argument g77 math intrinsics, eg BESY0, ERF.  */

void
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)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = 4;
  f->value.function.name = gfc_get_string (PREFIX("getcwd"));
}


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


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


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

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
     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);
      else
	gfc_convert_type(i, &j->ts, 2);
    }

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


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);
}


void
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)
{
  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;

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


void
gfc_resolve_idnint (gfc_expr * f, gfc_expr * a)
{
  gfc_resolve_nint (f, a, NULL);
}


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
     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);
      else
	gfc_convert_type(i, &j->ts, 2);
    }

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


void
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);
      else
	gfc_convert_type(i, &j->ts, 2);
    }

  f->ts = i->ts;
  f->value.function.name = gfc_get_string ("__ior_%d", i->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->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_typespec ts;
  
  f->ts.type = BT_LOGICAL;
  f->ts.kind = gfc_default_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("isatty_l%d"), f->ts.kind);
}


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_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;

  f->ts = i->ts;
  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)
{
  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)
{
  static char lbound[] = "__lbound";

  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 = lbound;
}


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_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_loc (gfc_expr *f, gfc_expr *x)
{
  f->ts.type= BT_INTEGER;
  f->ts.kind = gfc_index_integer_kind;
  f->value.function.name = gfc_get_string ("__loc_%d", x->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);
  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);
}


void
gfc_resolve_malloc (gfc_expr * f, gfc_expr * size)
{
  if (size->ts.kind < gfc_index_integer_kind)
    {
      gfc_typespec ts;

      ts.type = BT_INTEGER;
      ts.kind = gfc_index_integer_kind;
      gfc_convert_type_warn (size, &ts, 2, 0);
    }

  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_index_integer_kind;
  f->value.function.name = gfc_get_string (PREFIX("malloc"));
}


void
gfc_resolve_matmul (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->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);
}


static void
gfc_resolve_minmax (const char * name, gfc_expr * f, gfc_actual_arglist * args)
{
  gfc_actual_arglist *a;

  f->ts.type = args->expr->ts.type;
  f->ts.kind = args->expr->ts.kind;
  /* Find the largest type kind.  */
  for (a = args->next; a; a = a->next)
    {
      if (a->expr->ts.kind > f->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);
    }

  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_minmax ("__max_%c%d", f, args);
}


void
gfc_resolve_maxloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
		    gfc_expr * mask)
{
  const char *name;

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

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

  name = mask ? "mmaxloc" : "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);
}


void
gfc_resolve_maxval (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 ? "mmaxval" : "maxval",
		    gfc_type_letter (array->ts.type), array->ts.kind);
}


void
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);
}


void
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)
{
  const char *name;

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

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

  name = mask ? "mminloc" : "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);
}


void
gfc_resolve_minval (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 ? "mminval" : "minval",
		    gfc_type_letter (array->ts.type), array->ts.kind);
}


void
gfc_resolve_mod (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 ("__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)
{
  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 ("__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)
{
  f->ts = a->ts;
  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)
{
  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);
}


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);
}


void
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);

  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 ("__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)
{
  f->ts = array->ts;
  f->rank = 1;

  if (mask->rank != 0)
    f->value.function.name = (array->ts.type == BT_CHARACTER
			      ? 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"));
    }
}


void