match.c

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

loop:
  c = *p++;
  switch (c)
    {
    case ' ':
      gfc_gobble_whitespace ();
      goto loop;
    case '\0':
      m = MATCH_YES;
      break;

    case '%':
      c = *p++;
      switch (c)
	{
	case 'e':
	  vp = va_arg (argp, void **);
	  n = gfc_match_expr ((gfc_expr **) vp);
	  if (n != MATCH_YES)
	    {
	      m = n;
	      goto not_yes;
	    }

	  matches++;
	  goto loop;

	case 'v':
	  vp = va_arg (argp, void **);
	  n = gfc_match_variable ((gfc_expr **) vp, 0);
	  if (n != MATCH_YES)
	    {
	      m = n;
	      goto not_yes;
	    }

	  matches++;
	  goto loop;

	case 's':
	  vp = va_arg (argp, void **);
	  n = gfc_match_symbol ((gfc_symbol **) vp, 0);
	  if (n != MATCH_YES)
	    {
	      m = n;
	      goto not_yes;
	    }

	  matches++;
	  goto loop;

	case 'n':
	  np = va_arg (argp, char *);
	  n = gfc_match_name (np);
	  if (n != MATCH_YES)
	    {
	      m = n;
	      goto not_yes;
	    }

	  matches++;
	  goto loop;

	case 'l':
	  label = va_arg (argp, gfc_st_label **);
	  n = gfc_match_st_label (label);
	  if (n != MATCH_YES)
	    {
	      m = n;
	      goto not_yes;
	    }

	  matches++;
	  goto loop;

	case 'o':
	  ip = va_arg (argp, int *);
	  n = gfc_match_intrinsic_op ((gfc_intrinsic_op *) ip);
	  if (n != MATCH_YES)
	    {
	      m = n;
	      goto not_yes;
	    }

	  matches++;
	  goto loop;

	case 't':
	  if (gfc_match_eos () != MATCH_YES)
	    {
	      m = MATCH_NO;
	      goto not_yes;
	    }
	  goto loop;

	case ' ':
	  if (gfc_match_space () == MATCH_YES)
	    goto loop;
	  m = MATCH_NO;
	  goto not_yes;

	case '%':
	  break;	/* Fall through to character matcher */

	default:
	  gfc_internal_error ("gfc_match(): Bad match code %c", c);
	}

    default:
      if (c == gfc_next_char ())
	goto loop;
      break;
    }

not_yes:
  va_end (argp);

  if (m != MATCH_YES)
    {
      /* Clean up after a failed match.  */
      gfc_current_locus = old_loc;
      va_start (argp, target);

      p = target;
      for (; matches > 0; matches--)
	{
	  while (*p++ != '%');

	  switch (*p++)
	    {
	    case '%':
	      matches++;
	      break;		/* Skip */

	    /* Matches that don't have to be undone */
	    case 'o':
	    case 'l':
	    case 'n':
	    case 's':
	      (void)va_arg (argp, void **);
	      break;

	    case 'e':
	    case 'v':
	      vp = va_arg (argp, void **);
	      gfc_free_expr (*vp);
	      *vp = NULL;
	      break;
	    }
	}

      va_end (argp);
    }

  return m;
}


/*********************** Statement level matching **********************/

/* Matches the start of a program unit, which is the program keyword
   followed by an obligatory symbol.  */

match
gfc_match_program (void)
{
  gfc_symbol *sym;
  match m;

  m = gfc_match ("% %s%t", &sym);

  if (m == MATCH_NO)
    {
      gfc_error ("Invalid form of PROGRAM statement at %C");
      m = MATCH_ERROR;
    }

  if (m == MATCH_ERROR)
    return m;

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

  gfc_new_block = sym;

  return MATCH_YES;
}


/* Match a simple assignment statement.  */

match
gfc_match_assignment (void)
{
  gfc_expr *lvalue, *rvalue;
  locus old_loc;
  match m;

  old_loc = gfc_current_locus;

  lvalue = rvalue = NULL;
  m = gfc_match (" %v =", &lvalue);
  if (m != MATCH_YES)
    goto cleanup;

  if (lvalue->symtree->n.sym->attr.flavor == FL_PARAMETER)
    {
      gfc_error ("Cannot assign to a PARAMETER variable at %C");
      m = MATCH_ERROR;
      goto cleanup;
    }

  m = gfc_match (" %e%t", &rvalue);
  if (m != MATCH_YES)
    goto cleanup;

  gfc_set_sym_referenced (lvalue->symtree->n.sym);

  new_st.op = EXEC_ASSIGN;
  new_st.expr = lvalue;
  new_st.expr2 = rvalue;

  gfc_check_do_variable (lvalue->symtree);

  return MATCH_YES;

cleanup:
  gfc_current_locus = old_loc;
  gfc_free_expr (lvalue);
  gfc_free_expr (rvalue);
  return m;
}


/* Match a pointer assignment statement.  */

match
gfc_match_pointer_assignment (void)
{
  gfc_expr *lvalue, *rvalue;
  locus old_loc;
  match m;

  old_loc = gfc_current_locus;

  lvalue = rvalue = NULL;

  m = gfc_match (" %v =>", &lvalue);
  if (m != MATCH_YES)
    {
      m = MATCH_NO;
      goto cleanup;
    }

  m = gfc_match (" %e%t", &rvalue);
  if (m != MATCH_YES)
    goto cleanup;

  new_st.op = EXEC_POINTER_ASSIGN;
  new_st.expr = lvalue;
  new_st.expr2 = rvalue;

  return MATCH_YES;

cleanup:
  gfc_current_locus = old_loc;
  gfc_free_expr (lvalue);
  gfc_free_expr (rvalue);
  return m;
}


/* We try to match an easy arithmetic IF statement. This only happens
   when just after having encountered a simple IF statement. This code
   is really duplicate with parts of the gfc_match_if code, but this is
   *much* easier.  */
static match
match_arithmetic_if (void)
{
  gfc_st_label *l1, *l2, *l3;
  gfc_expr *expr;
  match m;

  m = gfc_match (" ( %e ) %l , %l , %l%t", &expr, &l1, &l2, &l3);
  if (m != MATCH_YES)
    return m;

  if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
      || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
      || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
    {
      gfc_free_expr (expr);
      return MATCH_ERROR;
    }

  if (gfc_notify_std (GFC_STD_F95_DEL,
		      "Obsolete: arithmetic IF statement at %C") == FAILURE)
    return MATCH_ERROR;

  new_st.op = EXEC_ARITHMETIC_IF;
  new_st.expr = expr;
  new_st.label = l1;
  new_st.label2 = l2;
  new_st.label3 = l3;

  return MATCH_YES;
}


/* The IF statement is a bit of a pain.  First of all, there are three
   forms of it, the simple IF, the IF that starts a block and the
   arithmetic IF.

   There is a problem with the simple IF and that is the fact that we
   only have a single level of undo information on symbols.  What this
   means is for a simple IF, we must re-match the whole IF statement
   multiple times in order to guarantee that the symbol table ends up
   in the proper state.  */

static match match_simple_forall (void);
static match match_simple_where (void);

match
gfc_match_if (gfc_statement * if_type)
{
  gfc_expr *expr;
  gfc_st_label *l1, *l2, *l3;
  locus old_loc;
  gfc_code *p;
  match m, n;

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

  old_loc = gfc_current_locus;

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

  if (gfc_match_char (')') != MATCH_YES)
    {
      gfc_error ("Syntax error in IF-expression at %C");
      gfc_free_expr (expr);
      return MATCH_ERROR;
    }

  m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3);

  if (m == MATCH_YES)
    {
      if (n == MATCH_YES)
	{
	  gfc_error
	    ("Block label not appropriate for arithmetic IF statement "
	     "at %C");

	  gfc_free_expr (expr);
	  return MATCH_ERROR;
	}

      if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
	  || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
	  || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
	{

	  gfc_free_expr (expr);
	  return MATCH_ERROR;
	}
      
      if (gfc_notify_std (GFC_STD_F95_DEL,
  		          "Obsolete: arithmetic IF statement at %C")
	  == FAILURE)
        return MATCH_ERROR;

      new_st.op = EXEC_ARITHMETIC_IF;
      new_st.expr = expr;
      new_st.label = l1;
      new_st.label2 = l2;
      new_st.label3 = l3;

      *if_type = ST_ARITHMETIC_IF;
      return MATCH_YES;
    }

  if (gfc_match (" then%t") == MATCH_YES)
    {
      new_st.op = EXEC_IF;
      new_st.expr = expr;

      *if_type = ST_IF_BLOCK;
      return MATCH_YES;
    }

  if (n == MATCH_YES)
    {
      gfc_error ("Block label is not appropriate IF statement at %C");

      gfc_free_expr (expr);
      return MATCH_ERROR;
    }

  /* At this point the only thing left is a simple IF statement.  At
     this point, n has to be MATCH_NO, so we don't have to worry about
     re-matching a block label.  From what we've got so far, try
     matching an assignment.  */

  *if_type = ST_SIMPLE_IF;

  m = gfc_match_assignment ();
  if (m == MATCH_YES)
    goto got_match;

  gfc_free_expr (expr);
  gfc_undo_symbols ();
  gfc_current_locus = old_loc;

  gfc_match (" if ( %e ) ", &expr);	/* Guaranteed to match */

  m = gfc_match_pointer_assignment ();
  if (m == MATCH_YES)
    goto got_match;

  gfc_free_expr (expr);
  gfc_undo_symbols ();
  gfc_current_locus = old_loc;

  gfc_match (" if ( %e ) ", &expr);	/* Guaranteed to match */

  /* Look at the next keyword to see which matcher to call.  Matching
     the keyword doesn't affect the symbol table, so we don't have to
     restore between tries.  */

#define match(string, subr, statement) \
  if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }

  gfc_clear_error ();

  match ("allocate", gfc_match_allocate, ST_ALLOCATE)
    match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
    match ("backspace", gfc_match_backspace, ST_BACKSPACE)
    match ("call", gfc_match_call, ST_CALL)
    match ("close", gfc_match_close, ST_CLOSE)
    match ("continue", gfc_match_continue, ST_CONTINUE)
    match ("cycle", gfc_match_cycle, ST_CYCLE)
    match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
    match ("end file", gfc_match_endfile, ST_END_FILE)
    match ("exit", gfc_match_exit, ST_EXIT)
    match ("flush", gfc_match_flush, ST_FLUSH)
    match ("forall", match_simple_forall, ST_FORALL)
    match ("go to", gfc_match_goto, ST_GOTO)
    match ("if", match_arithmetic_if, ST_ARITHMETIC_IF)
    match ("inquire", gfc_match_inquire, ST_INQUIRE)
    match ("nullify", gfc_match_nullify, ST_NULLIFY)
    match ("open", gfc_match_open, ST_OPEN)
    match ("pause", gfc_match_pause, ST_NONE)
    match ("print", gfc_match_print, ST_WRITE)
    match ("read", gfc_match_read, ST_READ)
    match ("return", gfc_match_return, ST_RETURN)
    match ("rewind", gfc_match_rewind, ST_REWIND)
    match ("stop", gfc_match_stop, ST_STOP)
    match ("where", match_simple_where, ST_WHERE)
    match ("write", gfc_match_write, ST_WRITE)

  /* All else has failed, so give up.  See if any of the matchers has
     stored an error message of some sort.  */
    if (gfc_error_check () == 0)
    gfc_error ("Unclassifiable statement in IF-clause at %C");

  gfc_free_expr (expr);
  return MATCH_ERROR;

got_match:
  if (m == MATCH_NO)
    gfc_error ("Syntax error in IF-clause at %C");
  if (m != MATCH_YES)
    {
      gfc_free_expr (expr);
      return MATCH_ERROR;
    }

  /* At this point, we've matched the single IF and the action clause
     is in new_st.  Rearrange things so that the IF statement appears
     in new_st.  */

  p = gfc_get_code ();
  p->next = gfc_get_code ();
  *p->next = new_st;
  p->next->loc = gfc_current_locus;

  p->expr = expr;
  p->op = EXEC_IF;

  gfc_clear_new_st ();

  new_st.op = EXEC_IF;
  new_st.block = p;

  return MATCH_YES;
}

#undef match


/* Match an ELSE statement.  */

match
gfc_match_else (void)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];

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

  if (gfc_match_name (name) != MATCH_YES
      || gfc_current_block () == NULL
      || gfc_match_eos () != MATCH_YES)
    {
      gfc_error ("Unexpected junk after ELSE statement at %C");
      return MATCH_ERROR;
    }

  if (strcmp (name, gfc_current_block ()->name) != 0)
    {
      gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
		 name, gfc_current_block ()->name);
      return MATCH_ERROR;
    }

  return MATCH_YES;
}


/* Match an ELSE IF statement.  */

match
gfc_match_elseif (void)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_expr *expr;
  match m;

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

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

  if (gfc_match_name (name) != MATCH_YES
      || gfc_current_block () == NULL
      || gfc_match_eos () != MATCH_YES)
    {
      gfc_error ("Unexpected junk after ELSE IF statement at %C");
      goto cleanup;
    }

  if (strcmp (name, gfc_current_block ()->name) != 0)
    {
      gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
		 name, gfc_current_block ()->name);
      goto cleanup;
    }

done:
  new_st.op = EXEC_IF;
  new_st.expr = expr;
  return MATCH_YES;

cleanup:
  gfc_free_expr (expr);
  return MATCH_ERROR;
}


/* Free a gfc_iterator structure.  */

void
gfc_free_iterator (gfc_iterator * iter, int flag)
{

  if (iter == NULL)
    return;

  gfc_free_expr (iter->var);
  gfc_free_expr (iter->start);
  gfc_free_expr (iter->end);
  gfc_free_expr (iter->step);

  if (flag)
    gfc_free (iter);
}


/* Match a DO statement.  */

match
gfc_match_do (void)
{
  gfc_iterator iter, *ip;
  locus old_loc;
  gfc_st_label *label;
  match m;

  old_loc = gfc_current_locus;

  label = NULL;
  iter.var = iter.start = iter.end = iter.step = NULL;

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

  if (gfc_match (" do") != MATCH_YES)
    return MATCH_NO;

  m = gfc_match_st_label (&label);
  if (m == MATCH_ERROR)
    goto cleanup;

/* Match an infinite DO, make it like a DO WHILE(.TRUE.) */

  if (gfc_match_eos () == MATCH_YES)
    {
      iter.end = gfc_logical_expr (1, NULL);
      new_st.op = EXEC_DO_WHILE;
      goto done;
    }

  /* match an optional comma, if no comma is found a space is obligatory.  */
  if (gfc_match_char(',') != MATCH_YES
      && gfc_match ("% ") != MATCH_YES)
    return MATCH_NO;

  /* See if we have a DO WHILE.  */
  if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
    {
      new_st.op = EXEC_DO_WHILE;
      goto done;
    }