match.c

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

	  if (group_name->namelist == NULL)
	    group_name->namelist = group_name->namelist_tail = nl;
	  else
	    {
	      group_name->namelist_tail->next = nl;
	      group_name->namelist_tail = nl;
	    }

	  if (gfc_match_eos () == MATCH_YES)
	    goto done;

	  m = gfc_match_char (',');

	  if (gfc_match_char ('/') == MATCH_YES)
	    {
	      m2 = gfc_match (" %s /", &group_name);
	      if (m2 == MATCH_YES)
		break;
	      if (m2 == MATCH_ERROR)
		goto error;
	      goto syntax;
	    }

	  if (m != MATCH_YES)
	    goto syntax;
	}
    }

done:
  return MATCH_YES;

syntax:
  gfc_syntax_error (ST_NAMELIST);

error:
  return MATCH_ERROR;
}


/* Match a MODULE statement.  */

match
gfc_match_module (void)
{
  match m;

  m = gfc_match (" %s%t", &gfc_new_block);
  if (m != MATCH_YES)
    return m;

  if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
		      gfc_new_block->name, NULL) == FAILURE)
    return MATCH_ERROR;

  return MATCH_YES;
}


/* Free equivalence sets and lists.  Recursively is the easiest way to
   do this.  */

void
gfc_free_equiv (gfc_equiv * eq)
{

  if (eq == NULL)
    return;

  gfc_free_equiv (eq->eq);
  gfc_free_equiv (eq->next);

  gfc_free_expr (eq->expr);
  gfc_free (eq);
}


/* Match an EQUIVALENCE statement.  */

match
gfc_match_equivalence (void)
{
  gfc_equiv *eq, *set, *tail;
  gfc_ref *ref;
  gfc_symbol *sym;
  match m;
  gfc_common_head *common_head = NULL;
  bool common_flag;
  int cnt;

  tail = NULL;

  for (;;)
    {
      eq = gfc_get_equiv ();
      if (tail == NULL)
	tail = eq;

      eq->next = gfc_current_ns->equiv;
      gfc_current_ns->equiv = eq;

      if (gfc_match_char ('(') != MATCH_YES)
	goto syntax;

      set = eq;
      common_flag = FALSE;
      cnt = 0;

      for (;;)
	{
	  m = gfc_match_equiv_variable (&set->expr);
	  if (m == MATCH_ERROR)
	    goto cleanup;
	  if (m == MATCH_NO)
	    goto syntax;

	  /*  count the number of objects.  */
	  cnt++;

	  if (gfc_match_char ('%') == MATCH_YES)
	    {
	      gfc_error ("Derived type component %C is not a "
			 "permitted EQUIVALENCE member");
	      goto cleanup;
	    }

	  for (ref = set->expr->ref; ref; ref = ref->next)
	    if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
	      {
		gfc_error
		  ("Array reference in EQUIVALENCE at %C cannot be an "
		   "array section");
		goto cleanup;
	      }

	  sym = set->expr->symtree->n.sym;

	  if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL)
		== FAILURE)
	    goto cleanup;

	  if (sym->attr.in_common)
	    {
	      common_flag = TRUE;
	      common_head = sym->common_head;
	    }

	  if (gfc_match_char (')') == MATCH_YES)
	    break;

	  if (gfc_match_char (',') != MATCH_YES)
	    goto syntax;

	  set->eq = gfc_get_equiv ();
	  set = set->eq;
	}

      if (cnt < 2)
	{
	  gfc_error ("EQUIVALENCE at %C requires two or more objects");
	  goto cleanup;
	}

      /* If one of the members of an equivalence is in common, then
	 mark them all as being in common.  Before doing this, check
	 that members of the equivalence group are not in different
	 common blocks. */
      if (common_flag)
	for (set = eq; set; set = set->eq)
	  {
	    sym = set->expr->symtree->n.sym;
	    if (sym->common_head && sym->common_head != common_head)
	      {
		gfc_error ("Attempt to indirectly overlap COMMON "
			   "blocks %s and %s by EQUIVALENCE at %C",
			   sym->common_head->name,
			   common_head->name);
		goto cleanup;
	      }
	    sym->attr.in_common = 1;
	    sym->common_head = common_head;
	  }

      if (gfc_match_eos () == MATCH_YES)
	break;
      if (gfc_match_char (',') != MATCH_YES)
	goto syntax;
    }

  return MATCH_YES;

syntax:
  gfc_syntax_error (ST_EQUIVALENCE);

cleanup:
  eq = tail->next;
  tail->next = NULL;

  gfc_free_equiv (gfc_current_ns->equiv);
  gfc_current_ns->equiv = eq;

  return MATCH_ERROR;
}

/* Check that a statement function is not recursive. This is done by looking
   for the statement function symbol(sym) by looking recursively through its
   expression(e).  If a reference to sym is found, true is returned.  */
static bool
recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
{
  gfc_actual_arglist *arg;
  gfc_ref *ref;
  int i;

  if (e == NULL)
    return false;

  switch (e->expr_type)
    {
    case EXPR_FUNCTION:
      for (arg = e->value.function.actual; arg; arg = arg->next)
	{
	  if (sym->name == arg->name
		|| recursive_stmt_fcn (arg->expr, sym))
	    return true;
	}

      if (e->symtree == NULL)
	return false;

      /* Check the name before testing for nested recursion!  */
      if (sym->name == e->symtree->n.sym->name)
	return true;

      /* Catch recursion via other statement functions.  */
      if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
	    && e->symtree->n.sym->value
	    && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
	return true;

      break;

    case EXPR_VARIABLE:
      if (e->symtree && sym->name == e->symtree->n.sym->name)
	return true;
      break;

    case EXPR_OP:
      if (recursive_stmt_fcn (e->value.op.op1, sym)
	    || recursive_stmt_fcn (e->value.op.op2, sym))
	return true;
      break;

    default:
      break;
    }

  /* Component references do not need to be checked.  */
  if (e->ref)
    {
      for (ref = e->ref; ref; ref = ref->next)
	{
	  switch (ref->type)
	    {
	    case REF_ARRAY:
	      for (i = 0; i < ref->u.ar.dimen; i++)
		{
		  if (recursive_stmt_fcn (ref->u.ar.start[i], sym)
			|| recursive_stmt_fcn (ref->u.ar.end[i], sym)
			|| recursive_stmt_fcn (ref->u.ar.stride[i], sym))
		    return true;
		}
	      break;

	    case REF_SUBSTRING:
	      if (recursive_stmt_fcn (ref->u.ss.start, sym)
		    || recursive_stmt_fcn (ref->u.ss.end, sym))
		return true;

	      break;

	    default:
	      break;
	    }
	}
    }
  return false;
}


/* Match a statement function declaration.  It is so easy to match
   non-statement function statements with a MATCH_ERROR as opposed to
   MATCH_NO that we suppress error message in most cases.  */

match
gfc_match_st_function (void)
{
  gfc_error_buf old_error;
  gfc_symbol *sym;
  gfc_expr *expr;
  match m;

  m = gfc_match_symbol (&sym, 0);
  if (m != MATCH_YES)
    return m;

  gfc_push_error (&old_error);

  if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
			 sym->name, NULL) == FAILURE)
    goto undo_error;

  if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
    goto undo_error;

  m = gfc_match (" = %e%t", &expr);
  if (m == MATCH_NO)
    goto undo_error;

  gfc_free_error (&old_error);
  if (m == MATCH_ERROR)
    return m;

  if (recursive_stmt_fcn (expr, sym))
    {
      gfc_error ("Statement function at %L is recursive",
		 &expr->where);
      return MATCH_ERROR;
    }

  sym->value = expr;

  return MATCH_YES;

undo_error:
  gfc_pop_error (&old_error);
  return MATCH_NO;
}


/***************** SELECT CASE subroutines ******************/

/* Free a single case structure.  */

static void
free_case (gfc_case * p)
{
  if (p->low == p->high)
    p->high = NULL;
  gfc_free_expr (p->low);
  gfc_free_expr (p->high);
  gfc_free (p);
}


/* Free a list of case structures.  */

void
gfc_free_case_list (gfc_case * p)
{
  gfc_case *q;

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


/* Match a single case selector.  */

static match
match_case_selector (gfc_case ** cp)
{
  gfc_case *c;
  match m;

  c = gfc_get_case ();
  c->where = gfc_current_locus;

  if (gfc_match_char (':') == MATCH_YES)
    {
      m = gfc_match_init_expr (&c->high);
      if (m == MATCH_NO)
	goto need_expr;
      if (m == MATCH_ERROR)
	goto cleanup;
    }

  else
    {
      m = gfc_match_init_expr (&c->low);
      if (m == MATCH_ERROR)
	goto cleanup;
      if (m == MATCH_NO)
	goto need_expr;

      /* If we're not looking at a ':' now, make a range out of a single
	 target.  Else get the upper bound for the case range.  */
      if (gfc_match_char (':') != MATCH_YES)
	c->high = c->low;
      else
	{
	  m = gfc_match_init_expr (&c->high);
	  if (m == MATCH_ERROR)
	    goto cleanup;
	  /* MATCH_NO is fine.  It's OK if nothing is there!  */
	}
    }

  *cp = c;
  return MATCH_YES;

need_expr:
  gfc_error ("Expected initialization expression in CASE at %C");

cleanup:
  free_case (c);
  return MATCH_ERROR;
}


/* Match the end of a case statement.  */

static match
match_case_eos (void)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  match m;

  if (gfc_match_eos () == MATCH_YES)
    return MATCH_YES;

  gfc_gobble_whitespace ();

  m = gfc_match_name (name);
  if (m != MATCH_YES)
    return m;

  if (strcmp (name, gfc_current_block ()->name) != 0)
    {
      gfc_error ("Expected case name of '%s' at %C",
		 gfc_current_block ()->name);
      return MATCH_ERROR;
    }

  return gfc_match_eos ();
}


/* Match a SELECT statement.  */

match
gfc_match_select (void)
{
  gfc_expr *expr;
  match m;

  m = gfc_match_label ();
  if (m == MATCH_ERROR)
    return m;

  m = gfc_match (" select case ( %e )%t", &expr);
  if (m != MATCH_YES)
    return m;

  new_st.op = EXEC_SELECT;
  new_st.expr = expr;

  return MATCH_YES;
}


/* Match a CASE statement.  */

match
gfc_match_case (void)
{
  gfc_case *c, *head, *tail;
  match m;

  head = tail = NULL;

  if (gfc_current_state () != COMP_SELECT)
    {
      gfc_error ("Unexpected CASE statement at %C");
      return MATCH_ERROR;
    }

  if (gfc_match ("% default") == MATCH_YES)
    {
      m = match_case_eos ();
      if (m == MATCH_NO)
	goto syntax;
      if (m == MATCH_ERROR)
	goto cleanup;

      new_st.op = EXEC_SELECT;
      c = gfc_get_case ();
      c->where = gfc_current_locus;
      new_st.ext.case_list = c;
      return MATCH_YES;
    }

  if (gfc_match_char ('(') != MATCH_YES)
    goto syntax;

  for (;;)
    {
      if (match_case_selector (&c) == MATCH_ERROR)
	goto cleanup;

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

      tail = c;

      if (gfc_match_char (')') == MATCH_YES)
	break;
      if (gfc_match_char (',') != MATCH_YES)
	goto syntax;
    }

  m = match_case_eos ();
  if (m == MATCH_NO)
    goto syntax;
  if (m == MATCH_ERROR)
    goto cleanup;

  new_st.op = EXEC_SELECT;
  new_st.ext.case_list = head;

  return MATCH_YES;

syntax:
  gfc_error ("Syntax error in CASE-specification at %C");

cleanup:
  gfc_free_case_list (head);  /* new_st is cleaned up in parse.c.  */
  return MATCH_ERROR;
}

/********************* WHERE subroutines ********************/

/* Match the rest of a simple WHERE statement that follows an IF statement.  
 */

static match
match_simple_where (void)
{
  gfc_expr *expr;
  gfc_code *c;
  match m;

  m = gfc_match (" ( %e )", &expr);
  if (m != MATCH_YES)
    return m;

  m = gfc_match_assignment ();
  if (m == MATCH_NO)
    goto syntax;
  if (m == MATCH_ERROR)
    goto cleanup;

  if (gfc_match_eos () != MATCH_YES)
    goto syntax;

  c = gfc_get_code ();

  c->op = EXEC_WHERE;
  c->expr = expr;
  c->next = gfc_get_code ();

  *c->next = new_st;
  gfc_clear_new_st ();

  new_st.op = EXEC_WHERE;
  new_st.block = c;

  return MATCH_YES;

syntax:
  gfc_syntax_error (ST_WHERE);

cleanup:
  gfc_free_expr (expr);
  return MATCH_ERROR;
}

/* Match a WHERE statement.  */

match
gfc_match_where (gfc_statement * st)
{
  gfc_expr *expr;
  match m0, m;
  gfc_code *c;

  m0 = gfc_match_label ();
  if (m0 == MATCH_ERROR)
    return m0;

  m = gfc_match (" where ( %e )", &expr);
  if (m != MATCH_YES)
    return m;

  if (gfc_match_eos () == MATCH_YES)
    {
      *st = ST_WHERE_BLOCK;

      new_st.op = EXEC_WHERE;
      new_st.expr = expr;
      return MATCH_YES;
    }

  m = gfc_match_assignment ();
  if (m == MATCH_NO)
    gfc_syntax_error (ST_WHERE);

  if (m != MATCH_YES)
    {
      gfc_free_expr (expr);
      return MATCH_ERROR;
    }

  /* We've got a simple WHERE statement.  */
  *st = ST_WHERE;
  c = gfc_get_code ();

  c->op = EXEC_WHERE;
  c->expr = expr;
  c->next = gfc_get_code ();

  *c->next = new_st;
  gfc_clear_new_st ();

  new_st.op = EXEC_WHERE;
  new_st.block