match.c

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

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

      if (gfc_pure (NULL)
          && gfc_impure_variable (tail->expr->symtree->n.sym))
	{
	  gfc_error
	    ("Illegal deallocate-expression in DEALLOCATE 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 DEALLOCATE 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 DEALLOCATE 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_DEALLOCATE;
  new_st.expr = stat;
  new_st.ext.alloc_list = head;

  return MATCH_YES;

syntax:
  gfc_syntax_error (ST_DEALLOCATE);

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


/* Match a RETURN statement.  */

match
gfc_match_return (void)
{
  gfc_expr *e;
  match m;
  gfc_compile_state s;
  int c;

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

  if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
    {
      gfc_error ("Alternate RETURN statement at %C is only allowed within "
		 "a SUBROUTINE");
      goto cleanup;
    }

  if (gfc_current_form == FORM_FREE)
    {
      /* The following are valid, so we can't require a blank after the
        RETURN keyword:
          return+1
          return(1)  */
      c = gfc_peek_char ();
      if (ISALPHA (c) || ISDIGIT (c))
       return MATCH_NO;
    }

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

  gfc_syntax_error (ST_RETURN);

cleanup:
  gfc_free_expr (e);
  return MATCH_ERROR;

done:
  gfc_enclosing_unit (&s);
  if (s == COMP_PROGRAM
      && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
                        "main program at %C") == FAILURE)
      return MATCH_ERROR;

  new_st.op = EXEC_RETURN;
  new_st.expr = e;

  return MATCH_YES;
}


/* Match a CALL statement.  The tricky part here are possible
   alternate return specifiers.  We handle these by having all
   "subroutines" actually return an integer via a register that gives
   the return number.  If the call specifies alternate returns, we
   generate code for a SELECT statement whose case clauses contain
   GOTOs to the various labels.  */

match
gfc_match_call (void)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_actual_arglist *a, *arglist;
  gfc_case *new_case;
  gfc_symbol *sym;
  gfc_symtree *st;
  gfc_code *c;
  match m;
  int i;

  arglist = NULL;

  m = gfc_match ("% %n", name);
  if (m == MATCH_NO)
    goto syntax;
  if (m != MATCH_YES)
    return m;

  if (gfc_get_ha_sym_tree (name, &st))
    return MATCH_ERROR;

  sym = st->n.sym;
  gfc_set_sym_referenced (sym);

  if (!sym->attr.generic
      && !sym->attr.subroutine
      && gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
    return MATCH_ERROR;

  if (gfc_match_eos () != MATCH_YES)
    {
      m = gfc_match_actual_arglist (1, &arglist);
      if (m == MATCH_NO)
	goto syntax;
      if (m == MATCH_ERROR)
	goto cleanup;

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

  /* If any alternate return labels were found, construct a SELECT
     statement that will jump to the right place.  */

  i = 0;
  for (a = arglist; a; a = a->next)
    if (a->expr == NULL)
	i = 1;

  if (i)
    {
      gfc_symtree *select_st;
      gfc_symbol *select_sym;
      char name[GFC_MAX_SYMBOL_LEN + 1];

      new_st.next = c = gfc_get_code ();
      c->op = EXEC_SELECT;
      sprintf (name, "_result_%s",sym->name);
      gfc_get_ha_sym_tree (name, &select_st);  /* Can't fail */

      select_sym = select_st->n.sym;
      select_sym->ts.type = BT_INTEGER;
      select_sym->ts.kind = gfc_default_integer_kind;
      gfc_set_sym_referenced (select_sym);
      c->expr = gfc_get_expr ();
      c->expr->expr_type = EXPR_VARIABLE;
      c->expr->symtree = select_st;
      c->expr->ts = select_sym->ts;
      c->expr->where = gfc_current_locus;

      i = 0;
      for (a = arglist; a; a = a->next)
	{
	  if (a->expr != NULL)
	    continue;

	  if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
	    continue;

	  i++;

	  c->block = gfc_get_code ();
	  c = c->block;
	  c->op = EXEC_SELECT;

	  new_case = gfc_get_case ();
	  new_case->high = new_case->low = gfc_int_expr (i);
	  c->ext.case_list = new_case;

	  c->next = gfc_get_code ();
	  c->next->op = EXEC_GOTO;
	  c->next->label = a->label;
	}
    }

  new_st.op = EXEC_CALL;
  new_st.symtree = st;
  new_st.ext.actual = arglist;

  return MATCH_YES;

syntax:
  gfc_syntax_error (ST_CALL);

cleanup:
  gfc_free_actual_arglist (arglist);
  return MATCH_ERROR;
}


/* Given a name, return a pointer to the common head structure,
   creating it if it does not exist. If FROM_MODULE is nonzero, we
   mangle the name so that it doesn't interfere with commons defined 
   in the using namespace.
   TODO: Add to global symbol tree.  */

gfc_common_head *
gfc_get_common (const char *name, int from_module)
{
  gfc_symtree *st;
  static int serial = 0;
  char mangled_name[GFC_MAX_SYMBOL_LEN+1];

  if (from_module)
    {
      /* A use associated common block is only needed to correctly layout
	 the variables it contains.  */
      snprintf(mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
      st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
    }
  else
    {
      st = gfc_find_symtree (gfc_current_ns->common_root, name);

      if (st == NULL)
	st = gfc_new_symtree (&gfc_current_ns->common_root, name);
    }

  if (st->n.common == NULL)
    {
      st->n.common = gfc_get_common_head ();
      st->n.common->where = gfc_current_locus;
      strcpy (st->n.common->name, name);
    }

  return st->n.common;
}


/* Match a common block name.  */

static match
match_common_name (char *name)
{
  match m;

  if (gfc_match_char ('/') == MATCH_NO)
    {
      name[0] = '\0';
      return MATCH_YES;
    }

  if (gfc_match_char ('/') == MATCH_YES)
    {
      name[0] = '\0';
      return MATCH_YES;
    }

  m = gfc_match_name (name);

  if (m == MATCH_ERROR)
    return MATCH_ERROR;
  if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
    return MATCH_YES;

  gfc_error ("Syntax error in common block name at %C");
  return MATCH_ERROR;
}


/* Match a COMMON statement.  */

match
gfc_match_common (void)
{
  gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
  char name[GFC_MAX_SYMBOL_LEN+1];
  gfc_common_head *t;
  gfc_array_spec *as;
  gfc_equiv * e1, * e2;
  match m;
  gfc_gsymbol *gsym;

  old_blank_common = gfc_current_ns->blank_common.head;
  if (old_blank_common)
    {
      while (old_blank_common->common_next)
	old_blank_common = old_blank_common->common_next;
    }

  as = NULL;

  for (;;)
    {
      m = match_common_name (name);
      if (m == MATCH_ERROR)
	goto cleanup;

      gsym = gfc_get_gsymbol (name);
      if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
	{
	  gfc_error ("Symbol '%s' at %C is already an external symbol that is not COMMON",
		     sym->name);
	  goto cleanup;
	}

      if (gsym->type == GSYM_UNKNOWN)
	{
	  gsym->type = GSYM_COMMON;
	  gsym->where = gfc_current_locus;
	  gsym->defined = 1;
	}

      gsym->used = 1;

      if (name[0] == '\0')
	{
	  t = &gfc_current_ns->blank_common;
	  if (t->head == NULL)
	    t->where = gfc_current_locus;
	  head = &t->head;
	}
      else
	{
	  t = gfc_get_common (name, 0);
	  head = &t->head;
	}

      if (*head == NULL)
	tail = NULL;
      else
	{
	  tail = *head;
	  while (tail->common_next)
	    tail = tail->common_next;
	}

      /* Grab the list of symbols.  */
      for (;;)
	{
	  m = gfc_match_symbol (&sym, 0);
	  if (m == MATCH_ERROR)
	    goto cleanup;
	  if (m == MATCH_NO)
	    goto syntax;

	  if (sym->attr.in_common)
	    {
	      gfc_error ("Symbol '%s' at %C is already in a COMMON block",
			 sym->name);
	      goto cleanup;
	    }

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

	  if (sym->value != NULL
	      && (name[0] == '\0' || !sym->attr.data))
	    {
	      if (name[0] == '\0')
		gfc_error ("Previously initialized symbol '%s' in "
			   "blank COMMON block at %C", sym->name);
	      else
		gfc_error ("Previously initialized symbol '%s' in "
			   "COMMON block '%s' at %C", sym->name, name);
	      goto cleanup;
	    }

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

	  /* Derived type names must have the SEQUENCE attribute.  */
	  if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.sequence)
	    {
	      gfc_error
		("Derived type variable in COMMON at %C does not have the "
		 "SEQUENCE attribute");
	      goto cleanup;
	    }

	  if (tail != NULL)
	    tail->common_next = sym;
	  else
	    *head = sym;

	  tail = sym;

	  /* Deal with an optional array specification after the
             symbol name.  */
	  m = gfc_match_array_spec (&as);
	  if (m == MATCH_ERROR)
	    goto cleanup;

	  if (m == MATCH_YES)
	    {
	      if (as->type != AS_EXPLICIT)
		{
		  gfc_error
		    ("Array specification for symbol '%s' in COMMON at %C "
		     "must be explicit", sym->name);
		  goto cleanup;
		}

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

	      if (sym->attr.pointer)
		{
		  gfc_error
		    ("Symbol '%s' in COMMON at %C cannot be a POINTER array",
		     sym->name);
		  goto cleanup;
		}

	      sym->as = as;
	      as = NULL;

	    }

	  sym->common_head = t;

	  /* Check to see if the symbol is already in an equivalence group.
	     If it is, set the other members as being in common.  */
	  if (sym->attr.in_equivalence)
	    {
	      for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
	        {
	          for (e2 = e1; e2; e2 = e2->eq)
	            if (e2->expr->symtree->n.sym == sym)
		      goto equiv_found;

		  continue;

	  equiv_found:

		  for (e2 = e1; e2; e2 = e2->eq)
		    {
		      other = e2->expr->symtree->n.sym;
		      if (other->common_head
		            && other->common_head != sym->common_head)
			{
			  gfc_error ("Symbol '%s', in COMMON block '%s' at "
				     "%C is being indirectly equivalenced to "
				     "another COMMON block '%s'",
				     sym->name,
				     sym->common_head->name,
				     other->common_head->name);
			    goto cleanup;
			}
		      other->attr.in_common = 1;
		      other->common_head = t;
		    }
		}
	    }


	  gfc_gobble_whitespace ();
	  if (gfc_match_eos () == MATCH_YES)
	    goto done;
	  if (gfc_peek_char () == '/')
	    break;
	  if (gfc_match_char (',') != MATCH_YES)
	    goto syntax;
	  gfc_gobble_whitespace ();
	  if (gfc_peek_char () == '/')
	    break;
	}
    }

done:
  return MATCH_YES;

syntax:
  gfc_syntax_error (ST_COMMON);

cleanup:
  if (old_blank_common)
    old_blank_common->common_next = NULL;
  else
    gfc_current_ns->blank_common.head = NULL;
  gfc_free_array_spec (as);
  return MATCH_ERROR;
}


/* Match a BLOCK DATA program unit.  */

match
gfc_match_block_data (void)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_symbol *sym;
  match m;

  if (gfc_match_eos () == MATCH_YES)
    {
      gfc_new_block = NULL;
      return MATCH_YES;
    }

  m = gfc_match ("% %n%t", name);
  if (m != MATCH_YES)
    return MATCH_ERROR;

  if (gfc_get_symbol (name, NULL, &sym))
    return MATCH_ERROR;

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

  gfc_new_block = sym;

  return MATCH_YES;
}


/* Free a namelist structure.  */

void
gfc_free_namelist (gfc_namelist * name)
{
  gfc_namelist *n;

  for (; name; name = n)
    {
      n = name->next;
      gfc_free (name);
    }
}


/* Match a NAMELIST statement.  */

match
gfc_match_namelist (void)
{
  gfc_symbol *group_name, *sym;
  gfc_namelist *nl;
  match m, m2;

  m = gfc_match (" / %s /", &group_name);
  if (m == MATCH_NO)
    goto syntax;
  if (m == MATCH_ERROR)
    goto error;

  for (;;)
    {
      if (group_name->ts.type != BT_UNKNOWN)
	{
	  gfc_error
	    ("Namelist group name '%s' at %C already has a basic type "
	     "of %s", group_name->name, gfc_typename (&group_name->ts));
	  return MATCH_ERROR;
	}

      if (group_name->attr.flavor == FL_NAMELIST
	    && group_name->attr.use_assoc
	    && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
			       "at %C already is USE associated and can"
			       "not be respecified.", group_name->name)
		 == FAILURE)
	return MATCH_ERROR;

      if (group_name->attr.flavor != FL_NAMELIST
	  && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
			     group_name->name, NULL) == FAILURE)
	return MATCH_ERROR;

      for (;;)
	{
	  m = gfc_match_symbol (&sym, 1);
	  if (m == MATCH_NO)
	    goto syntax;
	  if (m == MATCH_ERROR)
	    goto error;

	  if (sym->attr.in_namelist == 0
	      && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
	    goto error;

	  /* Use gfc_error_check here, rather than goto error, so that this
	     these are the only errors for the next two lines.  */
	  if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
	    {
	      gfc_error ("Assumed size array '%s' in namelist '%s'at "
		         "%C is not allowed.", sym->name, group_name->name);
	      gfc_error_check ();
	    }

	  if (sym->as && sym->as->type == AS_ASSUMED_SHAPE
		&& gfc_notify_std (GFC_STD_GNU, "Assumed shape array '%s' in "
				   "namelist '%s' at %C is an extension.",
				   sym->name, group_name->name) == FAILURE)
	    gfc_error_check ();

	  nl = gfc_get_namelist ();
	  nl->sym = sym;