primary.c

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

      case REF_COMPONENT:
	gfc_get_component_attr (&attr, ref->u.c.component);
	if (ts != NULL)
	  *ts = ref->u.c.component->ts;

	pointer = ref->u.c.component->pointer;
	if (pointer)
	  target = 1;

	break;

      case REF_SUBSTRING:
	pointer = 0;
	break;
      }

  attr.dimension = dimension;
  attr.pointer = pointer;
  attr.target = target;

  return attr;
}


/* Return the attribute from a general expression.  */

symbol_attribute
gfc_expr_attr (gfc_expr * e)
{
  symbol_attribute attr;

  switch (e->expr_type)
    {
    case EXPR_VARIABLE:
      attr = gfc_variable_attr (e, NULL);
      break;

    case EXPR_FUNCTION:
      gfc_clear_attr (&attr);

      if (e->value.function.esym != NULL)
	attr = e->value.function.esym->result->attr;

      /* TODO: NULL() returns pointers.  May have to take care of this
         here.  */

      break;

    default:
      gfc_clear_attr (&attr);
      break;
    }

  return attr;
}


/* Match a structure constructor.  The initial symbol has already been
   seen.  */

match
gfc_match_structure_constructor (gfc_symbol * sym, gfc_expr ** result)
{
  gfc_constructor *head, *tail;
  gfc_component *comp;
  gfc_expr *e;
  locus where;
  match m;

  head = tail = NULL;

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

  where = gfc_current_locus;

  gfc_find_component (sym, NULL);

  for (comp = sym->components; comp; comp = comp->next)
    {
      if (head == NULL)
	tail = head = gfc_get_constructor ();
      else
	{
	  tail->next = gfc_get_constructor ();
	  tail = tail->next;
	}

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

      if (gfc_match_char (',') == MATCH_YES)
	{
	  if (comp->next == NULL)
	    {
	      gfc_error
		("Too many components in structure constructor at %C");
	      goto cleanup;
	    }

	  continue;
	}

      break;
    }

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

  if (comp->next != NULL)
    {
      gfc_error ("Too few components in structure constructor at %C");
      goto cleanup;
    }

  e = gfc_get_expr ();

  e->expr_type = EXPR_STRUCTURE;

  e->ts.type = BT_DERIVED;
  e->ts.derived = sym;
  e->where = where;

  e->value.constructor = head;

  *result = e;
  return MATCH_YES;

syntax:
  gfc_error ("Syntax error in structure constructor at %C");

cleanup:
  gfc_free_constructor (head);
  return MATCH_ERROR;
}


/* Matches a variable name followed by anything that might follow it--
   array reference, argument list of a function, etc.  */

match
gfc_match_rvalue (gfc_expr ** result)
{
  gfc_actual_arglist *actual_arglist;
  char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
  gfc_state_data *st;
  gfc_symbol *sym;
  gfc_symtree *symtree;
  locus where, old_loc;
  gfc_expr *e;
  match m, m2;
  int i;

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

  if (gfc_find_state (COMP_INTERFACE) == SUCCESS)
    i = gfc_get_sym_tree (name, NULL, &symtree);
  else
    i = gfc_get_ha_sym_tree (name, &symtree);

  if (i)
    return MATCH_ERROR;

  sym = symtree->n.sym;
  e = NULL;
  where = gfc_current_locus;

  gfc_set_sym_referenced (sym);

  if (sym->attr.function && sym->result == sym)
    {
      if (gfc_current_ns->proc_name == sym
	  || (gfc_current_ns->parent != NULL
	      && gfc_current_ns->parent->proc_name == sym))
	goto variable;

      if (sym->attr.entry
	  && (sym->ns == gfc_current_ns
	      || sym->ns == gfc_current_ns->parent))
	{
	  gfc_entry_list *el = NULL;
	  
	  for (el = sym->ns->entries; el; el = el->next)
	    if (sym == el->sym)
	      goto variable;
	}
    }

  if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
    goto function0;

  if (sym->attr.generic)
    goto generic_function;

  switch (sym->attr.flavor)
    {
    case FL_VARIABLE:
    variable:
      if (sym->ts.type == BT_UNKNOWN && gfc_peek_char () == '%'
	  && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
	gfc_set_default_type (sym, 0, sym->ns);

      e = gfc_get_expr ();

      e->expr_type = EXPR_VARIABLE;
      e->symtree = symtree;

      m = match_varspec (e, 0);
      break;

    case FL_PARAMETER:
      /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
	 end up here.  Unfortunately, sym->value->expr_type is set to 
	 EXPR_CONSTANT, and so the if () branch would be followed without
	 the !sym->as check.  */
      if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
	e = gfc_copy_expr (sym->value);
      else
	{
	  e = gfc_get_expr ();
	  e->expr_type = EXPR_VARIABLE;
	}

      e->symtree = symtree;
      m = match_varspec (e, 0);
      break;

    case FL_DERIVED:
      sym = gfc_use_derived (sym);
      if (sym == NULL)
	m = MATCH_ERROR;
      else
        m = gfc_match_structure_constructor (sym, &e);
      break;

    /* If we're here, then the name is known to be the name of a
       procedure, yet it is not sure to be the name of a function.  */
    case FL_PROCEDURE:
      if (sym->attr.subroutine)
	{
	  gfc_error ("Unexpected use of subroutine name '%s' at %C",
		     sym->name);
	  m = MATCH_ERROR;
	  break;
	}

      /* At this point, the name has to be a non-statement function.
         If the name is the same as the current function being
         compiled, then we have a variable reference (to the function
         result) if the name is non-recursive.  */

      st = gfc_enclosing_unit (NULL);

      if (st != NULL && st->state == COMP_FUNCTION
	  && st->sym == sym
	  && !sym->attr.recursive)
	{
	  e = gfc_get_expr ();
	  e->symtree = symtree;
	  e->expr_type = EXPR_VARIABLE;

	  m = match_varspec (e, 0);
	  break;
	}

    /* Match a function reference.  */
    function0:
      m = gfc_match_actual_arglist (0, &actual_arglist);
      if (m == MATCH_NO)
	{
	  if (sym->attr.proc == PROC_ST_FUNCTION)
	    gfc_error ("Statement function '%s' requires argument list at %C",
		       sym->name);
	  else
	    gfc_error ("Function '%s' requires an argument list at %C",
		       sym->name);

	  m = MATCH_ERROR;
	  break;
	}

      if (m != MATCH_YES)
	{
	  m = MATCH_ERROR;
	  break;
	}

      gfc_get_ha_sym_tree (name, &symtree);	/* Can't fail */
      sym = symtree->n.sym;

      e = gfc_get_expr ();
      e->symtree = symtree;
      e->expr_type = EXPR_FUNCTION;
      e->value.function.actual = actual_arglist;
      e->where = gfc_current_locus;

      if (sym->as != NULL)
	e->rank = sym->as->rank;

      if (!sym->attr.function
	  && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
	{
	  m = MATCH_ERROR;
	  break;
	}

      if (sym->result == NULL)
	sym->result = sym;

      m = MATCH_YES;
      break;

    case FL_UNKNOWN:

      /* Special case for derived type variables that get their types
         via an IMPLICIT statement.  This can't wait for the
         resolution phase.  */

      if (gfc_peek_char () == '%'
	  && sym->ts.type == BT_UNKNOWN
	  && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
	gfc_set_default_type (sym, 0, sym->ns);

      /* If the symbol has a dimension attribute, the expression is a
         variable.  */

      if (sym->attr.dimension)
	{
	  if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
			      sym->name, NULL) == FAILURE)
	    {
	      m = MATCH_ERROR;
	      break;
	    }

	  e = gfc_get_expr ();
	  e->symtree = symtree;
	  e->expr_type = EXPR_VARIABLE;
	  m = match_varspec (e, 0);
	  break;
	}

      /* Name is not an array, so we peek to see if a '(' implies a
         function call or a substring reference.  Otherwise the
         variable is just a scalar.  */

      gfc_gobble_whitespace ();
      if (gfc_peek_char () != '(')
	{
	  /* Assume a scalar variable */
	  e = gfc_get_expr ();
	  e->symtree = symtree;
	  e->expr_type = EXPR_VARIABLE;

	  if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
			      sym->name, NULL) == FAILURE)
	    {
	      m = MATCH_ERROR;
	      break;
	    }

	  e->ts = sym->ts;
	  m = match_varspec (e, 0);
	  break;
	}

      /* See if this is a function reference with a keyword argument
	 as first argument. We do this because otherwise a spurious
	 symbol would end up in the symbol table.  */

      old_loc = gfc_current_locus;
      m2 = gfc_match (" ( %n =", argname);
      gfc_current_locus = old_loc;

      e = gfc_get_expr ();
      e->symtree = symtree;

      if (m2 != MATCH_YES)
	{
	  /* See if this could possibly be a substring reference of a name
	     that we're not sure is a variable yet.  */

	  if ((sym->ts.type == BT_UNKNOWN || sym->ts.type == BT_CHARACTER)
	      && match_substring (sym->ts.cl, 0, &e->ref) == MATCH_YES)
	    {

	      e->expr_type = EXPR_VARIABLE;

	      if (sym->attr.flavor != FL_VARIABLE
		  && gfc_add_flavor (&sym->attr, FL_VARIABLE,
				     sym->name, NULL) == FAILURE)
		{
		  m = MATCH_ERROR;
		  break;
		}

	      if (sym->ts.type == BT_UNKNOWN
		  && gfc_set_default_type (sym, 1, NULL) == FAILURE)
		{
		  m = MATCH_ERROR;
		  break;
		}

	      e->ts = sym->ts;
	      if (e->ref)
		e->ts.cl = NULL;
	      m = MATCH_YES;
	      break;
	    }
	}

      /* Give up, assume we have a function.  */

      gfc_get_sym_tree (name, NULL, &symtree);	/* Can't fail */
      sym = symtree->n.sym;
      e->expr_type = EXPR_FUNCTION;

      if (!sym->attr.function
	  && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
	{
	  m = MATCH_ERROR;
	  break;
	}

      sym->result = sym;

      m = gfc_match_actual_arglist (0, &e->value.function.actual);
      if (m == MATCH_NO)
	gfc_error ("Missing argument list in function '%s' at %C", sym->name);

      if (m != MATCH_YES)
	{
	  m = MATCH_ERROR;
	  break;
	}

      /* If our new function returns a character, array or structure
         type, it might have subsequent references.  */

      m = match_varspec (e, 0);
      if (m == MATCH_NO)
	m = MATCH_YES;

      break;

    generic_function:
      gfc_get_sym_tree (name, NULL, &symtree);	/* Can't fail */

      e = gfc_get_expr ();
      e->symtree = symtree;
      e->expr_type = EXPR_FUNCTION;

      m = gfc_match_actual_arglist (0, &e->value.function.actual);
      break;

    default:
      gfc_error ("Symbol at %C is not appropriate for an expression");
      return MATCH_ERROR;
    }

  if (m == MATCH_YES)
    {
      e->where = where;
      *result = e;
    }
  else
    gfc_free_expr (e);

  return m;
}


/* Match a variable, ie something that can be assigned to.  This
   starts as a symbol, can be a structure component or an array
   reference.  It can be a function if the function doesn't have a
   separate RESULT variable.  If the symbol has not been previously
   seen, we assume it is a variable.

   This function is called by two interface functions:
   gfc_match_variable, which has host_flag = 1, and
   gfc_match_equiv_variable, with host_flag = 0, to restrict the
   match of the symbol to the local scope.  */

static match
match_variable (gfc_expr ** result, int equiv_flag, int host_flag)
{
  gfc_symbol *sym;
  gfc_symtree *st;
  gfc_expr *expr;
  locus where;
  match m;

  m = gfc_match_sym_tree (&st, host_flag);
  if (m != MATCH_YES)
    return m;
  where = gfc_current_locus;

  sym = st->n.sym;
  gfc_set_sym_referenced (sym);
  switch (sym->attr.flavor)
    {
    case FL_VARIABLE:
      break;

    case FL_UNKNOWN:
      if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
			  sym->name, NULL) == FAILURE)
	return MATCH_ERROR;
      break;

    case FL_PROCEDURE:
      /* Check for a nonrecursive function result */
      if (sym->attr.function && (sym->result == sym || sym->attr.entry))
	{
	  /* If a function result is a derived type, then the derived
	     type may still have to be resolved.  */

	  if (sym->ts.type == BT_DERIVED
	      && gfc_use_derived (sym->ts.derived) == NULL)
	    return MATCH_ERROR;
	  break;
	}

      /* Fall through to error */

    default:
      gfc_error ("Expected VARIABLE at %C");
      return MATCH_ERROR;
    }

  /* Special case for derived type variables that get their types
     via an IMPLICIT statement.  This can't wait for the
     resolution phase.  */

    {
      gfc_namespace * implicit_ns;

      if (gfc_current_ns->proc_name == sym)
	implicit_ns = gfc_current_ns;
      else
	implicit_ns = sym->ns;
	
      if (gfc_peek_char () == '%'
	  && sym->ts.type == BT_UNKNOWN
	  && gfc_get_default_type (sym, implicit_ns)->type == BT_DERIVED)
	gfc_set_default_type (sym, 0, implicit_ns);
    }

  expr = gfc_get_expr ();

  expr->expr_type = EXPR_VARIABLE;
  expr->symtree = st;
  expr->ts = sym->ts;
  expr->where = where;

  /* Now see if we have to do more.  */
  m = match_varspec (expr, equiv_flag);
  if (m != MATCH_YES)
    {
      gfc_free_expr (expr);
      return m;
    }

  *result = expr;
  return MATCH_YES;
}

match
gfc_match_variable (gfc_expr ** result, int equiv_flag)
{
  return match_variable (result, equiv_flag, 1);
}

match
gfc_match_equiv_variable (gfc_expr ** result)
{
  return match_variable (result, 1, 0);
}