iresolve.c

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

		    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_xor (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 ("__xor_%c%d",
					   gfc_type_letter (i->ts.type),
					   f->ts.kind);
}


/* Intrinsic subroutine resolution.  */

void
gfc_resolve_alarm_sub (gfc_code * c)
{
  const char *name;
  gfc_expr *seconds, *handler, *status;
  gfc_typespec ts;

  seconds = c->ext.actual->expr;
  handler = c->ext.actual->next->expr;
  status = c->ext.actual->next->next->expr;
  ts.type = BT_INTEGER;
  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, &ts, 2);
      name = gfc_get_string (PREFIX("alarm_sub_int"));
    }
  else
    name = gfc_get_string (PREFIX("alarm_sub"));

  if (seconds->ts.kind != gfc_c_int_kind)
    gfc_convert_type (seconds, &ts, 2);
  if (status != NULL && status->ts.kind != gfc_c_int_kind)
    gfc_convert_type (status, &ts, 2);

  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}

void
gfc_resolve_cpu_time (gfc_code * c ATTRIBUTE_UNUSED)
{
  const char *name;

  name = gfc_get_string (PREFIX("cpu_time_%d"),
			 c->ext.actual->expr->ts.kind);
  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}


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

  kind = c->ext.actual->expr->ts.kind;
  name = gfc_get_string (PREFIX("mvbits_i%d"), kind);

  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}


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

  kind = c->ext.actual->expr->ts.kind;
  if (c->ext.actual->expr->rank == 0)
    name = gfc_get_string (PREFIX("random_r%d"), kind);
  else
    name = gfc_get_string (PREFIX("arandom_r%d"), kind);
  
  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}


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
gfc_resolve_etime_sub (gfc_code * c)
{
  const char *name;

  name = gfc_get_string (PREFIX("etime_sub"));
  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}


/* G77 compatibility subroutine second().  */

void
gfc_resolve_second_sub (gfc_code * c)
{
  const char *name;

  name = gfc_get_string (PREFIX("second_sub"));
  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}


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
gfc_resolve_srand (gfc_code * c)
{
  const char *name;
  name = gfc_get_string (PREFIX("srand"));
  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}


/* Resolve the getarg intrinsic subroutine.  */

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

  kind = gfc_default_integer_kind;
  name = gfc_get_string (PREFIX("getarg_i%d"), kind);
  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}

/* Resolve the getcwd intrinsic subroutine.  */

void
gfc_resolve_getcwd_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("getcwd_i%d_sub"), kind);
  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}


/* Resolve the get_command intrinsic subroutine.  */

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

  kind = gfc_default_integer_kind;
  name = gfc_get_string (PREFIX("get_command_i%d"), kind);
  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}


/* Resolve the get_command_argument intrinsic subroutine.  */

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

  kind = gfc_default_integer_kind;
  name = gfc_get_string (PREFIX("get_command_argument_i%d"), kind);
  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}

/* Resolve the get_environment_variable intrinsic subroutine.  */

void
gfc_resolve_get_environment_variable (gfc_code * code)
{
  const char *name;
  int kind;

  kind = gfc_default_integer_kind;
  name = gfc_get_string (PREFIX("get_environment_variable_i%d"), kind);
  code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}

void
gfc_resolve_signal_sub (gfc_code * c)
{
  const char *name;
  gfc_expr *number, *handler, *status;
  gfc_typespec ts;

  number = c->ext.actual->expr;
  handler = c->ext.actual->next->expr;
  status = c->ext.actual->next->next->expr;
  ts.type = BT_INTEGER;
  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, &ts, 2);
      name = gfc_get_string (PREFIX("signal_sub_int"));
    }
  else
    name = gfc_get_string (PREFIX("signal_sub"));

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

  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}

/* Resolve the SYSTEM intrinsic subroutine.  */

void
gfc_resolve_system_sub (gfc_code * c)
{
  const char *name;

  name = gfc_get_string (PREFIX("system_sub"));
  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}

/* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */

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

  if (c->ext.actual->expr != NULL)
    kind = c->ext.actual->expr->ts.kind;
  else if (c->ext.actual->next->expr != NULL)
      kind = c->ext.actual->next->expr->ts.kind;
  else 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("system_clock_%d"), kind);
  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}

/* Resolve the EXIT intrinsic subroutine.  */

void
gfc_resolve_exit (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("exit_i%d"), kind);
  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}

/* Resolve the FLUSH intrinsic subroutine.  */

void
gfc_resolve_flush (gfc_code * c)
{
  const char *name;
  gfc_typespec ts;
  gfc_expr *n;

  ts.type = BT_INTEGER;
  ts.kind = gfc_default_integer_kind;
  n = c->ext.actual->expr;
  if (n != NULL
      && n->ts.kind != ts.kind)
    gfc_convert_type (n, &ts, 2);

  name = gfc_get_string (PREFIX("flush_i%d"), ts.kind);
  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}


void
gfc_resolve_free (gfc_code * c)
{
  gfc_typespec ts;
  gfc_expr *n;

  ts.type = BT_INTEGER;
  ts.kind = gfc_index_integer_kind;
  n = c->ext.actual->expr;
  if (n->ts.kind != ts.kind)
    gfc_convert_type (n, &ts, 2);

  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("free"));
}


void
gfc_resolve_ctime_sub (gfc_code * c)
{
  gfc_typespec ts;
  
  /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
  if (c->ext.actual->expr->ts.kind != 8)
    {
      ts.type = BT_INTEGER;
      ts.kind = 8;
      ts.derived = NULL;
      ts.cl = NULL;
      gfc_convert_type (c->ext.actual->expr, &ts, 2);
    }

  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("ctime_sub"));
}


void
gfc_resolve_fdate_sub (gfc_code * c)
{
  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
}


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
gfc_resolve_stat_sub (gfc_code * c)
{
  const char *name;

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


void
gfc_resolve_fstat_sub (gfc_code * c)
{
  const char *name;
  gfc_expr *u;
  gfc_typespec *ts;

  u = c->ext.actual->expr;
  ts = &c->ext.actual->next->expr->ts;
  if (u->ts.kind != ts->kind)
    gfc_convert_type (u, ts, 2);
  name = gfc_get_string (PREFIX("fstat_i%d_sub"), ts->kind);
  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}


void
gfc_resolve_fgetc_sub (gfc_code * c)
{
  const char *name;
  gfc_typespec ts;
  gfc_expr *u, *st;

  u = c->ext.actual->expr;
  st = c->ext.actual->next->next->expr;

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

  if (st != NULL)
    name = gfc_get_string (PREFIX("fgetc_i%d_sub"), st->ts.kind);
  else
    name = gfc_get_string (PREFIX("fgetc_i%d_sub"), gfc_default_integer_kind);

  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}


void
gfc_resolve_fget_sub (gfc_code * c)
{
  const char *name;
  gfc_expr *st;

  st = c->ext.actual->next->expr;
  if (st != NULL)
    name = gfc_get_string (PREFIX("fget_i%d_sub"), st->ts.kind);
  else
    name = gfc_get_string (PREFIX("fget_i%d_sub"), gfc_default_integer_kind);

  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}


void
gfc_resolve_fputc_sub (gfc_code * c)
{
  const char *name;
  gfc_typespec ts;
  gfc_expr *u, *st;

  u = c->ext.actual->expr;
  st = c->ext.actual->next->next->expr;

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

  if (st != NULL)
    name = gfc_get_string (PREFIX("fputc_i%d_sub"), st->ts.kind);
  else
    name = gfc_get_string (PREFIX("fputc_i%d_sub"), gfc_default_integer_kind);

  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}


void
gfc_resolve_fput_sub (gfc_code * c)
{
  const char *name;
  gfc_expr *st;

  st = c->ext.actual->next->expr;
  if (st != NULL)
    name = gfc_get_string (PREFIX("fput_i%d_sub"), st->ts.kind);
  else
    name = gfc_get_string (PREFIX("fput_i%d_sub"), gfc_default_integer_kind);

  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}


void
gfc_resolve_ftell_sub (gfc_code * c)
{
  const char *name;
  gfc_expr *unit;
  gfc_expr *offset;
  gfc_typespec ts;

  unit = c->ext.actual->expr;
  offset = c->ext.actual->next->expr;

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

  name = gfc_get_string (PREFIX("ftell_i%d_sub"), offset->ts.kind);
  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}


void
gfc_resolve_ttynam_sub (gfc_code * c)
{
  gfc_typespec ts;
  
  if (c->ext.actual->expr->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 (c->ext.actual->expr, &ts, 2);
    }

  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("ttynam_sub"));
}


/* Resolve the UMASK intrinsic subroutine.  */

void
gfc_resolve_umask_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("umask_i%d_sub"), kind);
  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}

/* Resolve the UNLINK intrinsic subroutine.  */

void
gfc_resolve_unlink_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("unlink_i%d_sub"), kind);
  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}