match.c

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

  /* The abortive DO WHILE may have done something to the symbol
     table, so we start over: */
  gfc_undo_symbols ();
  gfc_current_locus = old_loc;

  gfc_match_label ();		/* This won't error */
  gfc_match (" do ");		/* This will work */

  gfc_match_st_label (&label);	/* Can't error out */
  gfc_match_char (',');		/* Optional comma */

  m = gfc_match_iterator (&iter, 0);
  if (m == MATCH_NO)
    return MATCH_NO;
  if (m == MATCH_ERROR)
    goto cleanup;

  gfc_check_do_variable (iter.var->symtree);

  if (gfc_match_eos () != MATCH_YES)
    {
      gfc_syntax_error (ST_DO);
      goto cleanup;
    }

  new_st.op = EXEC_DO;

done:
  if (label != NULL
      && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
    goto cleanup;

  new_st.label = label;

  if (new_st.op == EXEC_DO_WHILE)
    new_st.expr = iter.end;
  else
    {
      new_st.ext.iterator = ip = gfc_get_iterator ();
      *ip = iter;
    }

  return MATCH_YES;

cleanup:
  gfc_free_iterator (&iter, 0);

  return MATCH_ERROR;
}


/* Match an EXIT or CYCLE statement.  */

static match
match_exit_cycle (gfc_statement st, gfc_exec_op op)
{
  gfc_state_data *p;
  gfc_symbol *sym;
  match m;

  if (gfc_match_eos () == MATCH_YES)
    sym = NULL;
  else
    {
      m = gfc_match ("% %s%t", &sym);
      if (m == MATCH_ERROR)
	return MATCH_ERROR;
      if (m == MATCH_NO)
	{
	  gfc_syntax_error (st);
	  return MATCH_ERROR;
	}

      if (sym->attr.flavor != FL_LABEL)
	{
	  gfc_error ("Name '%s' in %s statement at %C is not a loop name",
		     sym->name, gfc_ascii_statement (st));
	  return MATCH_ERROR;
	}
    }

  /* Find the loop mentioned specified by the label (or lack of a
     label).  */
  for (p = gfc_state_stack; p; p = p->previous)
    if (p->state == COMP_DO && (sym == NULL || sym == p->sym))
      break;

  if (p == NULL)
    {
      if (sym == NULL)
	gfc_error ("%s statement at %C is not within a loop",
		   gfc_ascii_statement (st));
      else
	gfc_error ("%s statement at %C is not within loop '%s'",
		   gfc_ascii_statement (st), sym->name);

      return MATCH_ERROR;
    }

  /* Save the first statement in the loop - needed by the backend.  */
  new_st.ext.whichloop = p->head;

  new_st.op = op;
/*  new_st.sym = sym;*/

  return MATCH_YES;
}


/* Match the EXIT statement.  */

match
gfc_match_exit (void)
{

  return match_exit_cycle (ST_EXIT, EXEC_EXIT);
}


/* Match the CYCLE statement.  */

match
gfc_match_cycle (void)
{

  return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
}


/* Match a number or character constant after a STOP or PAUSE statement.  */

static match
gfc_match_stopcode (gfc_statement st)
{
  int stop_code;
  gfc_expr *e;
  match m;
  int cnt;

  stop_code = -1;
  e = NULL;

  if (gfc_match_eos () != MATCH_YES)
    {
      m = gfc_match_small_literal_int (&stop_code, &cnt);
      if (m == MATCH_ERROR)
        goto cleanup;

      if (m == MATCH_YES && cnt > 5)
        {
          gfc_error ("Too many digits in STOP code at %C");
          goto cleanup;
        }

      if (m == MATCH_NO)
        {
          /* Try a character constant.  */
          m = gfc_match_expr (&e);
          if (m == MATCH_ERROR)
            goto cleanup;
          if (m == MATCH_NO)
            goto syntax;
          if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
            goto syntax;
        }

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

  if (gfc_pure (NULL))
    {
      gfc_error ("%s statement not allowed in PURE procedure at %C",
	         gfc_ascii_statement (st));
      goto cleanup;
    }

  new_st.op = st == ST_STOP ? EXEC_STOP : EXEC_PAUSE;
  new_st.expr = e;
  new_st.ext.stop_code = stop_code;

  return MATCH_YES;

syntax:
  gfc_syntax_error (st);

cleanup:

  gfc_free_expr (e);
  return MATCH_ERROR;
}

/* Match the (deprecated) PAUSE statement.  */

match
gfc_match_pause (void)
{
  match m;

  m = gfc_match_stopcode (ST_PAUSE);
  if (m == MATCH_YES)
    {
      if (gfc_notify_std (GFC_STD_F95_DEL,
	    "Obsolete: PAUSE statement at %C")
	  == FAILURE)
	m = MATCH_ERROR;
    }
  return m;
}


/* Match the STOP statement.  */

match
gfc_match_stop (void)
{
  return gfc_match_stopcode (ST_STOP);
}


/* Match a CONTINUE statement.  */

match
gfc_match_continue (void)
{

  if (gfc_match_eos () != MATCH_YES)
    {
      gfc_syntax_error (ST_CONTINUE);
      return MATCH_ERROR;
    }

  new_st.op = EXEC_CONTINUE;
  return MATCH_YES;
}


/* Match the (deprecated) ASSIGN statement.  */

match
gfc_match_assign (void)
{
  gfc_expr *expr;
  gfc_st_label *label;

  if (gfc_match (" %l", &label) == MATCH_YES)
    {
      if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
        return MATCH_ERROR;
      if (gfc_match (" to %v%t", &expr) == MATCH_YES)
        {
	  if (gfc_notify_std (GFC_STD_F95_DEL,
		"Obsolete: ASSIGN statement at %C")
	      == FAILURE)
	    return MATCH_ERROR;

          expr->symtree->n.sym->attr.assign = 1;

          new_st.op = EXEC_LABEL_ASSIGN;
          new_st.label = label;
          new_st.expr = expr;
          return MATCH_YES;
        }
    }
  return MATCH_NO;
}


/* Match the GO TO statement.  As a computed GOTO statement is
   matched, it is transformed into an equivalent SELECT block.  No
   tree is necessary, and the resulting jumps-to-jumps are
   specifically optimized away by the back end.  */

match
gfc_match_goto (void)
{
  gfc_code *head, *tail;
  gfc_expr *expr;
  gfc_case *cp;
  gfc_st_label *label;
  int i;
  match m;

  if (gfc_match (" %l%t", &label) == MATCH_YES)
    {
      if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
	return MATCH_ERROR;

      new_st.op = EXEC_GOTO;
      new_st.label = label;
      return MATCH_YES;
    }

  /* The assigned GO TO statement.  */ 

  if (gfc_match_variable (&expr, 0) == MATCH_YES)
    {
      if (gfc_notify_std (GFC_STD_F95_DEL,
			  "Obsolete: Assigned GOTO statement at %C")
	  == FAILURE)
	return MATCH_ERROR;

      new_st.op = EXEC_GOTO;
      new_st.expr = expr;

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

      /* Match label list.  */
      gfc_match_char (',');
      if (gfc_match_char ('(') != MATCH_YES)
	{
	  gfc_syntax_error (ST_GOTO);
	  return MATCH_ERROR;
	}
      head = tail = NULL;

      do
	{
	  m = gfc_match_st_label (&label);
	  if (m != MATCH_YES)
	    goto syntax;

	  if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
	    goto cleanup;

	  if (head == NULL)
	    head = tail = gfc_get_code ();
	  else
	    {
	      tail->block = gfc_get_code ();
	      tail = tail->block;
	    }

	  tail->label = label;
	  tail->op = EXEC_GOTO;
	}
      while (gfc_match_char (',') == MATCH_YES);

      if (gfc_match (")%t") != MATCH_YES)
	goto syntax;

      if (head == NULL)
	{
	   gfc_error (
	       "Statement label list in GOTO at %C cannot be empty");
	   goto syntax;
	}
      new_st.block = head;

      return MATCH_YES;
    }

  /* Last chance is a computed GO TO statement.  */
  if (gfc_match_char ('(') != MATCH_YES)
    {
      gfc_syntax_error (ST_GOTO);
      return MATCH_ERROR;
    }

  head = tail = NULL;
  i = 1;

  do
    {
      m = gfc_match_st_label (&label);
      if (m != MATCH_YES)
	goto syntax;

      if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
	goto cleanup;

      if (head == NULL)
	head = tail = gfc_get_code ();
      else
	{
	  tail->block = gfc_get_code ();
	  tail = tail->block;
	}

      cp = gfc_get_case ();
      cp->low = cp->high = gfc_int_expr (i++);

      tail->op = EXEC_SELECT;
      tail->ext.case_list = cp;

      tail->next = gfc_get_code ();
      tail->next->op = EXEC_GOTO;
      tail->next->label = label;
    }
  while (gfc_match_char (',') == MATCH_YES);

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

  if (head == NULL)
    {
      gfc_error ("Statement label list in GOTO at %C cannot be empty");
      goto syntax;
    }

  /* Get the rest of the statement.  */
  gfc_match_char (',');

  if (gfc_match (" %e%t", &expr) != MATCH_YES)
    goto syntax;

  /* At this point, a computed GOTO has been fully matched and an
     equivalent SELECT statement constructed.  */

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

  /* Hack: For a "real" SELECT, the expression is in expr. We put
     it in expr2 so we can distinguish then and produce the correct
     diagnostics.  */
  new_st.expr2 = expr;
  new_st.block = head;
  return MATCH_YES;

syntax:
  gfc_syntax_error (ST_GOTO);
cleanup:
  gfc_free_statements (head);
  return MATCH_ERROR;
}


/* Frees a list of gfc_alloc structures.  */

void
gfc_free_alloc_list (gfc_alloc * p)
{
  gfc_alloc *q;

  for (; p; p = q)
    {
      q = p->next;
      gfc_free_expr (p->expr);
      gfc_free (p);
    }
}


/* Match an ALLOCATE statement.  */

match
gfc_match_allocate (void)
{
  gfc_alloc *head, *tail;
  gfc_expr *stat;
  match m;

  head = tail = NULL;
  stat = NULL;

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

  for (;;)
    {
      if (head == NULL)
	head = tail = gfc_get_alloc ();
      else
	{
	  tail->next = gfc_get_alloc ();
	  tail = tail->next;
	}

      m = gfc_match_variable (&tail->expr, 0);
      if (m == MATCH_NO)
	goto syntax;
      if (m == MATCH_ERROR)
	goto cleanup;

      if (gfc_check_do_variable (tail->expr->symtree))
	goto cleanup;

      if (gfc_pure (NULL)
          && gfc_impure_variable (tail->expr->symtree->n.sym))
	{
	  gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
		     "PURE procedure");
	  goto cleanup;
	}

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

      m = gfc_match (" stat = %v", &stat);
      if (m == MATCH_ERROR)
	goto cleanup;
      if (m == MATCH_YES)
	break;
    }

  if (stat != NULL)
    {
      if (stat->symtree->n.sym->attr.intent == INTENT_IN)
	{
	  gfc_error
	    ("STAT variable '%s' of ALLOCATE statement at %C cannot be "
	     "INTENT(IN)", stat->symtree->n.sym->name);
	  goto cleanup;
	}

      if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
	{
	  gfc_error
	    ("Illegal STAT variable in ALLOCATE statement at %C for a PURE "
	     "procedure");
	  goto cleanup;
	}

      if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
	{
	  gfc_error("STAT expression at %C must be a variable");
	  goto cleanup;
	}

      gfc_check_do_variable(stat->symtree);
    }

  if (gfc_match (" )%t") != MATCH_YES)
    goto syntax;

  new_st.op = EXEC_ALLOCATE;
  new_st.expr = stat;
  new_st.ext.alloc_list = head;

  return MATCH_YES;

syntax:
  gfc_syntax_error (ST_ALLOCATE);

cleanup:
  gfc_free_expr (stat);
  gfc_free_alloc_list (head);
  return MATCH_ERROR;
}


/* Match a NULLIFY statement. A NULLIFY statement is transformed into
   a set of pointer assignments to intrinsic NULL().  */

match
gfc_match_nullify (void)
{
  gfc_code *tail;
  gfc_expr *e, *p;
  match m;

  tail = NULL;

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

  for (;;)
    {
      m = gfc_match_variable (&p, 0);
      if (m == MATCH_ERROR)
	goto cleanup;
      if (m == MATCH_NO)
	goto syntax;

      if (gfc_check_do_variable(p->symtree))
	goto cleanup;

      if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
	{
	  gfc_error
	    ("Illegal variable in NULLIFY at %C for a PURE procedure");
	  goto cleanup;
	}

      /* build ' => NULL() ' */
      e = gfc_get_expr ();
      e->where = gfc_current_locus;
      e->expr_type = EXPR_NULL;
      e->ts.type = BT_UNKNOWN;

      /* Chain to list */
      if (tail == NULL)
	tail = &new_st;
      else
	{
	  tail->next = gfc_get_code ();
	  tail = tail->next;
	}

      tail->op = EXEC_POINTER_ASSIGN;
      tail->expr = p;
      tail->expr2 = e;

      if (gfc_match (" )%t") == MATCH_YES)
	break;
      if (gfc_match_char (',') != MATCH_YES)
	goto syntax;
    }

  return MATCH_YES;

syntax:
  gfc_syntax_error (ST_NULLIFY);

cleanup:
  gfc_free_statements (new_st.next);
  return MATCH_ERROR;
}


/* Match a DEALLOCATE statement.  */

match
gfc_match_deallocate (void)
{
  gfc_alloc *head, *tail;
  gfc_expr *stat;
  match m;

  head = tail = NULL;
  stat = NULL;

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

  for (;;)
    {
      if (head == NULL)
	head = tail = gfc_get_alloc ();
      else
	{
	  tail->next = gfc_get_alloc ();
	  tail = tail->next;
	}

      m = gfc_match_variable (&tail->expr, 0);
      if (m == MATCH_ERROR)
	goto cleanup;
      if (m == MATCH_NO)
	goto syntax;