primary.c

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

     assume we have a complex constant because we've seen the ','.  An
     ambiguous case here is the start of an iterator list of some
     sort. These sort of lists are matched prior to coming here.  */

  if (m == MATCH_ERROR)
    {
      gfc_free_error (&old_error);
      goto cleanup;
    }
  gfc_pop_error (&old_error);

  m = match_complex_part (&imag);
  if (m == MATCH_NO)
    goto syntax;
  if (m == MATCH_ERROR)
    goto cleanup;

  m = gfc_match_char (')');
  if (m == MATCH_NO)
    {
      /* Give the matcher for implied do-loops a chance to run.  This
	 yields a much saner error message for (/ (i, 4=i, 6) /).  */
      if (gfc_peek_char () == '=')
	{
	  m = MATCH_ERROR;
	  goto cleanup;
	}
      else
    goto syntax;
    }

  if (m == MATCH_ERROR)
    goto cleanup;

  /* Decide on the kind of this complex number.  */
  if (real->ts.type == BT_REAL)
    {
      if (imag->ts.type == BT_REAL)
	kind = gfc_kind_max (real, imag);
      else
	kind = real->ts.kind;
    }
  else
    {
      if (imag->ts.type == BT_REAL)
	kind = imag->ts.kind;
      else
	kind = gfc_default_real_kind;
    }
  target.type = BT_REAL;
  target.kind = kind;

  if (real->ts.type != BT_REAL || kind != real->ts.kind)
    gfc_convert_type (real, &target, 2);
  if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
    gfc_convert_type (imag, &target, 2);

  e = gfc_convert_complex (real, imag, kind);
  e->where = gfc_current_locus;

  gfc_free_expr (real);
  gfc_free_expr (imag);

  *result = e;
  return MATCH_YES;

syntax:
  gfc_error ("Syntax error in COMPLEX constant at %C");
  m = MATCH_ERROR;

cleanup:
  gfc_free_expr (e);
  gfc_free_expr (real);
  gfc_free_expr (imag);
  gfc_current_locus = old_loc;

  return m;
}


/* Match constants in any of several forms.  Returns nonzero for a
   match, zero for no match.  */

match
gfc_match_literal_constant (gfc_expr ** result, int signflag)
{
  match m;

  m = match_complex_constant (result);
  if (m != MATCH_NO)
    return m;

  m = match_string_constant (result);
  if (m != MATCH_NO)
    return m;

  m = match_boz_constant (result);
  if (m != MATCH_NO)
    return m;

  m = match_real_constant (result, signflag);
  if (m != MATCH_NO)
    return m;

  m = match_hollerith_constant (result);
  if (m != MATCH_NO)
    return m;

  m = match_integer_constant (result, signflag);
  if (m != MATCH_NO)
    return m;

  m = match_logical_constant (result);
  if (m != MATCH_NO)
    return m;

  return MATCH_NO;
}


/* Match a single actual argument value.  An actual argument is
   usually an expression, but can also be a procedure name.  If the
   argument is a single name, it is not always possible to tell
   whether the name is a dummy procedure or not.  We treat these cases
   by creating an argument that looks like a dummy procedure and
   fixing things later during resolution.  */

static match
match_actual_arg (gfc_expr ** result)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_symtree *symtree;
  locus where, w;
  gfc_expr *e;
  int c;

  where = gfc_current_locus;

  switch (gfc_match_name (name))
    {
    case MATCH_ERROR:
      return MATCH_ERROR;

    case MATCH_NO:
      break;

    case MATCH_YES:
      w = gfc_current_locus;
      gfc_gobble_whitespace ();
      c = gfc_next_char ();
      gfc_current_locus = w;

      if (c != ',' && c != ')')
	break;

      if (gfc_find_sym_tree (name, NULL, 1, &symtree))
	break;
      /* Handle error elsewhere.  */

      /* Eliminate a couple of common cases where we know we don't
         have a function argument.  */
      if (symtree == NULL)
        {
	  gfc_get_sym_tree (name, NULL, &symtree);
          gfc_set_sym_referenced (symtree->n.sym);
        }
      else
	{
          gfc_symbol *sym;

          sym = symtree->n.sym;
          gfc_set_sym_referenced (sym);
	  if (sym->attr.flavor != FL_PROCEDURE
	      && sym->attr.flavor != FL_UNKNOWN)
	    break;

	  /* If the symbol is a function with itself as the result and
	     is being defined, then we have a variable.  */
	  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))
		break;

	      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)
		      break;

		  if (el)
		    break;
		}
	    }
	}

      e = gfc_get_expr ();	/* Leave it unknown for now */
      e->symtree = symtree;
      e->expr_type = EXPR_VARIABLE;
      e->ts.type = BT_PROCEDURE;
      e->where = where;

      *result = e;
      return MATCH_YES;
    }

  gfc_current_locus = where;
  return gfc_match_expr (result);
}


/* Match a keyword argument.  */

static match
match_keyword_arg (gfc_actual_arglist * actual, gfc_actual_arglist * base)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_actual_arglist *a;
  locus name_locus;
  match m;

  name_locus = gfc_current_locus;
  m = gfc_match_name (name);

  if (m != MATCH_YES)
    goto cleanup;
  if (gfc_match_char ('=') != MATCH_YES)
    {
      m = MATCH_NO;
      goto cleanup;
    }

  m = match_actual_arg (&actual->expr);
  if (m != MATCH_YES)
    goto cleanup;

  /* Make sure this name has not appeared yet.  */

  if (name[0] != '\0')
    {
      for (a = base; a; a = a->next)
	if (a->name != NULL && strcmp (a->name, name) == 0)
	  {
	    gfc_error
	      ("Keyword '%s' at %C has already appeared in the current "
	       "argument list", name);
	    return MATCH_ERROR;
	  }
    }

  actual->name = gfc_get_string (name);
  return MATCH_YES;

cleanup:
  gfc_current_locus = name_locus;
  return m;
}


/* Matches an actual argument list of a function or subroutine, from
   the opening parenthesis to the closing parenthesis.  The argument
   list is assumed to allow keyword arguments because we don't know if
   the symbol associated with the procedure has an implicit interface
   or not.  We make sure keywords are unique. If SUB_FLAG is set,
   we're matching the argument list of a subroutine.  */

match
gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist ** argp)
{
  gfc_actual_arglist *head, *tail;
  int seen_keyword;
  gfc_st_label *label;
  locus old_loc;
  match m;

  *argp = tail = NULL;
  old_loc = gfc_current_locus;

  seen_keyword = 0;

  if (gfc_match_char ('(') == MATCH_NO)
    return (sub_flag) ? MATCH_YES : MATCH_NO;

  if (gfc_match_char (')') == MATCH_YES)
    return MATCH_YES;
  head = NULL;

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

      if (sub_flag && gfc_match_char ('*') == MATCH_YES)
	{
	  m = gfc_match_st_label (&label);
	  if (m == MATCH_NO)
	    gfc_error ("Expected alternate return label at %C");
	  if (m != MATCH_YES)
	    goto cleanup;

	  tail->label = label;
	  goto next;
	}

      /* After the first keyword argument is seen, the following
         arguments must also have keywords.  */
      if (seen_keyword)
	{
	  m = match_keyword_arg (tail, head);

	  if (m == MATCH_ERROR)
	    goto cleanup;
	  if (m == MATCH_NO)
	    {
	      gfc_error
		("Missing keyword name in actual argument list at %C");
	      goto cleanup;
	    }

	}
      else
	{
	  /* See if we have the first keyword argument.  */
	  m = match_keyword_arg (tail, head);
	  if (m == MATCH_YES)
	    seen_keyword = 1;
	  if (m == MATCH_ERROR)
	    goto cleanup;

	  if (m == MATCH_NO)
	    {
	      /* Try for a non-keyword argument.  */
	      m = match_actual_arg (&tail->expr);
	      if (m == MATCH_ERROR)
		goto cleanup;
	      if (m == MATCH_NO)
		goto syntax;
	    }
	}

    next:
      if (gfc_match_char (')') == MATCH_YES)
	break;
      if (gfc_match_char (',') != MATCH_YES)
	goto syntax;
    }

  *argp = head;
  return MATCH_YES;

syntax:
  gfc_error ("Syntax error in argument list at %C");

cleanup:
  gfc_free_actual_arglist (head);
  gfc_current_locus = old_loc;

  return MATCH_ERROR;
}


/* Used by match_varspec() to extend the reference list by one
   element.  */

static gfc_ref *
extend_ref (gfc_expr * primary, gfc_ref * tail)
{

  if (primary->ref == NULL)
    primary->ref = tail = gfc_get_ref ();
  else
    {
      if (tail == NULL)
	gfc_internal_error ("extend_ref(): Bad tail");
      tail->next = gfc_get_ref ();
      tail = tail->next;
    }

  return tail;
}


/* Match any additional specifications associated with the current
   variable like member references or substrings.  If equiv_flag is
   set we only match stuff that is allowed inside an EQUIVALENCE
   statement.  */

static match
match_varspec (gfc_expr * primary, int equiv_flag)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_ref *substring, *tail;
  gfc_component *component;
  gfc_symbol *sym = primary->symtree->n.sym;
  match m;

  tail = NULL;

  if ((equiv_flag && gfc_peek_char () == '(')
      || sym->attr.dimension)
    {
      /* In EQUIVALENCE, we don't know yet whether we are seeing
	 an array, character variable or array of character
	 variables.  We'll leave the decision till resolve
	 time.  */
      tail = extend_ref (primary, tail);
      tail->type = REF_ARRAY;

      m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
			       equiv_flag);
      if (m != MATCH_YES)
	return m;

      if (equiv_flag && gfc_peek_char () == '(')
	{
	  tail = extend_ref (primary, tail);
	  tail->type = REF_ARRAY;

	  m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag);
	  if (m != MATCH_YES)
	    return m;
	}
    }

  primary->ts = sym->ts;

  if (equiv_flag)
    return MATCH_YES;

  if (sym->ts.type != BT_DERIVED || gfc_match_char ('%') != MATCH_YES)
    goto check_substring;

  sym = sym->ts.derived;

  for (;;)
    {
      m = gfc_match_name (name);
      if (m == MATCH_NO)
	gfc_error ("Expected structure component name at %C");
      if (m != MATCH_YES)
	return MATCH_ERROR;

      component = gfc_find_component (sym, name);
      if (component == NULL)
	return MATCH_ERROR;

      tail = extend_ref (primary, tail);
      tail->type = REF_COMPONENT;

      tail->u.c.component = component;
      tail->u.c.sym = sym;

      primary->ts = component->ts;

      if (component->as != NULL)
	{
	  tail = extend_ref (primary, tail);
	  tail->type = REF_ARRAY;

	  m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag);
	  if (m != MATCH_YES)
	    return m;
	}

      if (component->ts.type != BT_DERIVED
	  || gfc_match_char ('%') != MATCH_YES)
	break;

      sym = component->ts.derived;
    }

check_substring:
  if (primary->ts.type == BT_UNKNOWN)
    {
      if (gfc_get_default_type (sym, sym->ns)->type == BT_CHARACTER)
       {
         gfc_set_default_type (sym, 0, sym->ns);
         primary->ts = sym->ts;
       }
    }

  if (primary->ts.type == BT_CHARACTER)
    {
      switch (match_substring (primary->ts.cl, equiv_flag, &substring))
	{
	case MATCH_YES:
	  if (tail == NULL)
	    primary->ref = substring;
	  else
	    tail->next = substring;

	  if (primary->expr_type == EXPR_CONSTANT)
	    primary->expr_type = EXPR_SUBSTRING;

	  if (substring)
	    primary->ts.cl = NULL;

	  break;

	case MATCH_NO:
	  break;

	case MATCH_ERROR:
	  return MATCH_ERROR;
	}
    }

  return MATCH_YES;
}


/* Given an expression that is a variable, figure out what the
   ultimate variable's type and attribute is, traversing the reference
   structures if necessary.

   This subroutine is trickier than it looks.  We start at the base
   symbol and store the attribute.  Component references load a
   completely new attribute.

   A couple of rules come into play.  Subobjects of targets are always
   targets themselves.  If we see a component that goes through a
   pointer, then the expression must also be a target, since the
   pointer is associated with something (if it isn't core will soon be
   dumped).  If we see a full part or section of an array, the
   expression is also an array.

   We can have at most one full array reference.  */

symbol_attribute
gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
{
  int dimension, pointer, target;
  symbol_attribute attr;
  gfc_ref *ref;

  if (expr->expr_type != EXPR_VARIABLE)
    gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");

  ref = expr->ref;
  attr = expr->symtree->n.sym->attr;

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

  target = attr.target;
  if (pointer)
    target = 1;

  if (ts != NULL && expr->ts.type == BT_UNKNOWN)
    *ts = expr->symtree->n.sym->ts;

  for (; ref; ref = ref->next)
    switch (ref->type)
      {
      case REF_ARRAY:

	switch (ref->u.ar.type)
	  {
	  case AR_FULL:
	    dimension = 1;
	    break;

	  case AR_SECTION:
	    pointer = 0;
	    dimension = 1;
	    break;

	  case AR_ELEMENT:
	    pointer = 0;
	    break;

	  case AR_UNKNOWN:
	    gfc_internal_error ("gfc_variable_attr(): Bad array reference");
	  }

	break;