decl.c

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

      gfc_find_symbol (current_ts.derived->name,
			 current_ts.derived->ns->parent, 1, &sym);

      /* Any symbol that we find had better be a type definition
         which has its components defined.  */
      if (sym != NULL && sym->attr.flavor == FL_DERIVED
	    && current_ts.derived->components != NULL)
	goto ok;

      /* Now we have an error, which we signal, and then fix up
	 because the knock-on is plain and simple confusing.  */
      gfc_error_now ("Derived type at %C has not been previously defined "
		 "and so cannot appear in a derived type definition.");
      current_attr.pointer = 1;
      goto ok;
    }

ok:
  /* If we have an old-style character declaration, and no new-style
     attribute specifications, then there a comma is optional between
     the type specification and the variable list.  */
  if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
    gfc_match_char (',');

  /* Give the types/attributes to symbols that follow. Give the element
     a number so that repeat character length expressions can be copied.  */
  elem = 1;
  for (;;)
    {
      m = variable_decl (elem++);
      if (m == MATCH_ERROR)
	goto cleanup;
      if (m == MATCH_NO)
	break;

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

  gfc_error ("Syntax error in data declaration at %C");
  m = MATCH_ERROR;

cleanup:
  gfc_free_array_spec (current_as);
  current_as = NULL;
  return m;
}


/* Match a prefix associated with a function or subroutine
   declaration.  If the typespec pointer is nonnull, then a typespec
   can be matched.  Note that if nothing matches, MATCH_YES is
   returned (the null string was matched).  */

static match
match_prefix (gfc_typespec * ts)
{
  int seen_type;

  gfc_clear_attr (&current_attr);
  seen_type = 0;

loop:
  if (!seen_type && ts != NULL
      && match_type_spec (ts, 0) == MATCH_YES
      && gfc_match_space () == MATCH_YES)
    {

      seen_type = 1;
      goto loop;
    }

  if (gfc_match ("elemental% ") == MATCH_YES)
    {
      if (gfc_add_elemental (&current_attr, NULL) == FAILURE)
	return MATCH_ERROR;

      goto loop;
    }

  if (gfc_match ("pure% ") == MATCH_YES)
    {
      if (gfc_add_pure (&current_attr, NULL) == FAILURE)
	return MATCH_ERROR;

      goto loop;
    }

  if (gfc_match ("recursive% ") == MATCH_YES)
    {
      if (gfc_add_recursive (&current_attr, NULL) == FAILURE)
	return MATCH_ERROR;

      goto loop;
    }

  /* At this point, the next item is not a prefix.  */
  return MATCH_YES;
}


/* Copy attributes matched by match_prefix() to attributes on a symbol.  */

static try
copy_prefix (symbol_attribute * dest, locus * where)
{

  if (current_attr.pure && gfc_add_pure (dest, where) == FAILURE)
    return FAILURE;

  if (current_attr.elemental && gfc_add_elemental (dest, where) == FAILURE)
    return FAILURE;

  if (current_attr.recursive && gfc_add_recursive (dest, where) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


/* Match a formal argument list.  */

match
gfc_match_formal_arglist (gfc_symbol * progname, int st_flag, int null_flag)
{
  gfc_formal_arglist *head, *tail, *p, *q;
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_symbol *sym;
  match m;

  head = tail = NULL;

  if (gfc_match_char ('(') != MATCH_YES)
    {
      if (null_flag)
	goto ok;
      return MATCH_NO;
    }

  if (gfc_match_char (')') == MATCH_YES)
    goto ok;

  for (;;)
    {
      if (gfc_match_char ('*') == MATCH_YES)
	sym = NULL;
      else
	{
	  m = gfc_match_name (name);
	  if (m != MATCH_YES)
	    goto cleanup;

	  if (gfc_get_symbol (name, NULL, &sym))
	    goto cleanup;
	}

      p = gfc_get_formal_arglist ();

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

      tail->sym = sym;

      /* We don't add the VARIABLE flavor because the name could be a
         dummy procedure.  We don't apply these attributes to formal
         arguments of statement functions.  */
      if (sym != NULL && !st_flag
	  && (gfc_add_dummy (&sym->attr, sym->name, NULL) == FAILURE
	      || gfc_missing_attr (&sym->attr, NULL) == FAILURE))
	{
	  m = MATCH_ERROR;
	  goto cleanup;
	}

      /* The name of a program unit can be in a different namespace,
         so check for it explicitly.  After the statement is accepted,
         the name is checked for especially in gfc_get_symbol().  */
      if (gfc_new_block != NULL && sym != NULL
	  && strcmp (sym->name, gfc_new_block->name) == 0)
	{
	  gfc_error ("Name '%s' at %C is the name of the procedure",
		     sym->name);
	  m = MATCH_ERROR;
	  goto cleanup;
	}

      if (gfc_match_char (')') == MATCH_YES)
	goto ok;

      m = gfc_match_char (',');
      if (m != MATCH_YES)
	{
	  gfc_error ("Unexpected junk in formal argument list at %C");
	  goto cleanup;
	}
    }

ok:
  /* Check for duplicate symbols in the formal argument list.  */
  if (head != NULL)
    {
      for (p = head; p->next; p = p->next)
	{
	  if (p->sym == NULL)
	    continue;

	  for (q = p->next; q; q = q->next)
	    if (p->sym == q->sym)
	      {
		gfc_error
		  ("Duplicate symbol '%s' in formal argument list at %C",
		   p->sym->name);

		m = MATCH_ERROR;
		goto cleanup;
	      }
	}
    }

  if (gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL) ==
      FAILURE)
    {
      m = MATCH_ERROR;
      goto cleanup;
    }

  return MATCH_YES;

cleanup:
  gfc_free_formal_arglist (head);
  return m;
}


/* Match a RESULT specification following a function declaration or
   ENTRY statement.  Also matches the end-of-statement.  */

static match
match_result (gfc_symbol * function, gfc_symbol ** result)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_symbol *r;
  match m;

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

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

  if (gfc_match (" )%t") != MATCH_YES)
    {
      gfc_error ("Unexpected junk following RESULT variable at %C");
      return MATCH_ERROR;
    }

  if (strcmp (function->name, name) == 0)
    {
      gfc_error
	("RESULT variable at %C must be different than function name");
      return MATCH_ERROR;
    }

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

  if (gfc_add_flavor (&r->attr, FL_VARIABLE, r->name, NULL) == FAILURE
      || gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
    return MATCH_ERROR;

  *result = r;

  return MATCH_YES;
}


/* Match a function declaration.  */

match
gfc_match_function_decl (void)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_symbol *sym, *result;
  locus old_loc;
  match m;

  if (gfc_current_state () != COMP_NONE
      && gfc_current_state () != COMP_INTERFACE
      && gfc_current_state () != COMP_CONTAINS)
    return MATCH_NO;

  gfc_clear_ts (&current_ts);

  old_loc = gfc_current_locus;

  m = match_prefix (&current_ts);
  if (m != MATCH_YES)
    {
      gfc_current_locus = old_loc;
      return m;
    }

  if (gfc_match ("function% %n", name) != MATCH_YES)
    {
      gfc_current_locus = old_loc;
      return MATCH_NO;
    }

  if (get_proc_name (name, &sym))
    return MATCH_ERROR;
  gfc_new_block = sym;

  m = gfc_match_formal_arglist (sym, 0, 0);
  if (m == MATCH_NO)
    gfc_error ("Expected formal argument list in function definition at %C");
  else if (m == MATCH_ERROR)
    goto cleanup;

  result = NULL;

  if (gfc_match_eos () != MATCH_YES)
    {
      /* See if a result variable is present.  */
      m = match_result (sym, &result);
      if (m == MATCH_NO)
	gfc_error ("Unexpected junk after function declaration at %C");

      if (m != MATCH_YES)
	{
	  m = MATCH_ERROR;
	  goto cleanup;
	}
    }

  /* Make changes to the symbol.  */
  m = MATCH_ERROR;

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

  if (gfc_missing_attr (&sym->attr, NULL) == FAILURE
      || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
    goto cleanup;

  if (current_ts.type != BT_UNKNOWN && sym->ts.type != BT_UNKNOWN)
    {
      gfc_error ("Function '%s' at %C already has a type of %s", name,
		 gfc_basic_typename (sym->ts.type));
      goto cleanup;
    }

  if (result == NULL)
    {
      sym->ts = current_ts;
      sym->result = sym;
    }
  else
    {
      result->ts = current_ts;
      sym->result = result;
    }

  return MATCH_YES;

cleanup:
  gfc_current_locus = old_loc;
  return m;
}

/* This is mostly a copy of parse.c(add_global_procedure) but modified to pass the
   name of the entry, rather than the gfc_current_block name, and to return false
   upon finding an existing global entry.  */

static bool
add_global_entry (const char * name, int sub)
{
  gfc_gsymbol *s;

  s = gfc_get_gsymbol(name);

  if (s->defined
	|| (s->type != GSYM_UNKNOWN && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
    global_used(s, NULL);
  else
    {
      s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
      s->where = gfc_current_locus;
      s->defined = 1;
      return true;
    }
  return false;
}

/* Match an ENTRY statement.  */

match
gfc_match_entry (void)
{
  gfc_symbol *proc;
  gfc_symbol *result;
  gfc_symbol *entry;
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_compile_state state;
  match m;
  gfc_entry_list *el;
  locus old_loc;

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

  state = gfc_current_state ();
  if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
    {
      switch (state)
	{
	  case COMP_PROGRAM:
	    gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
	    break;
	  case COMP_MODULE:
	    gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
	    break;
	  case COMP_BLOCK_DATA:
	    gfc_error
	      ("ENTRY statement at %C cannot appear within a BLOCK DATA");
	    break;
	  case COMP_INTERFACE:
	    gfc_error
	      ("ENTRY statement at %C cannot appear within an INTERFACE");
	    break;
	  case COMP_DERIVED:
	    gfc_error
	      ("ENTRY statement at %C cannot appear "
	       "within a DERIVED TYPE block");
	    break;
	  case COMP_IF:
	    gfc_error
	      ("ENTRY statement at %C cannot appear within an IF-THEN block");
	    break;
	  case COMP_DO:
	    gfc_error
	      ("ENTRY statement at %C cannot appear within a DO block");
	    break;
	  case COMP_SELECT:
	    gfc_error
	      ("ENTRY statement at %C cannot appear within a SELECT block");
	    break;
	  case COMP_FORALL:
	    gfc_error
	      ("ENTRY statement at %C cannot appear within a FORALL block");
	    break;
	  case COMP_WHERE:
	    gfc_error
	      ("ENTRY statement at %C cannot appear within a WHERE block");
	    break;
	  case COMP_CONTAINS:
	    gfc_error
	      ("ENTRY statement at %C cannot appear "
	       "within a contained subprogram");
	    break;
	  default:
	    gfc_internal_error ("gfc_match_entry(): Bad state");
	}
      return MATCH_ERROR;
    }

  if (gfc_current_ns->parent != NULL
      && gfc_current_ns->parent->proc_name
      && gfc_current_ns->parent->proc_name->attr.flavor != FL_MODULE)
    {
      gfc_error("ENTRY statement at %C cannot appear in a "
		"contained procedure");
      return MATCH_ERROR;
    }

  if (get_proc_name (name, &entry))
    return MATCH_ERROR;

  proc = gfc_current_block ();

  if (state == COMP_SUBROUTINE)
    {
      /* An entry in a subroutine.  */
      if (!add_global_entry (name, 1))
	return MATCH_ERROR;

      m = gfc_match_formal_arglist (entry, 0, 1);
      if (m != MATCH_YES)
	return MATCH_ERROR;

      if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
	  || gfc_add_subroutine (&entry->attr, entry->name, NULL) == FAILURE)
	return MATCH_ERROR;
    }
  else
    {
      /* An entry in a function.
         We need to take special care because writing
            ENTRY f()
         as
            ENTRY f
         is allowed, whereas
            ENTRY f() RESULT (r)
         can't be written as
            ENTRY f RESULT (r).  */
      if (!add_global_entry (name, 0))
	return MATCH_ERROR;

      old_loc = gfc_current_locus;
      if (gfc_match_eos () == MATCH_YES)
	{
	  gfc_current_locus = old_loc;
	  /* Match the empty argument list, and add the interface to
	     the symbol.  */
	  m = gfc_match_formal_arglist (entry, 0, 1);
	}
      else
	m = gfc_match_formal_arglist (entry, 0, 0);

      if (m != MATCH_YES)
	return MATCH_ERROR;

      result = NULL;

      if (gfc_match_eos () == MATCH_YES)
	{
	  if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
	      || gfc_add_function (&entry->attr, entry->name, NULL) == FAILURE)
	    return MATCH_ERROR;

	  entry->result = entry;
	}
      else
	{
	  m = match_result (proc, &result);
	  if (m == MATCH_NO)
	    gfc_syntax_error (ST_ENTRY);
	  if (m != MATCH_YES)
	    return MATCH_ERROR;

	  if (gfc_add_result (&result->attr, result->name, NULL) == FAILURE
	      || gfc_add_entry (&entry->attr, result->name, NULL) == FAILURE
	      || gfc_add_function (&entry->attr, result->name,
				   NULL) == FAILURE)
	    return MATCH_ERROR;

	  entry->result = result;
	}

      if (proc->attr.recursive && result == NULL)
	{
	  gfc_error ("RESULT attribute requi