decl.c

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

		  if (m == MATCH_ERROR)
		    goto cleanup;
		}
	    }     
	  goto cleanup;
	}
      else
	{
	  gfc_free_array_spec (cp_as);
	}
    }
  
    
  /* OK, we've successfully matched the declaration.  Now put the
     symbol in the current namespace, because it might be used in the
     optional initialization expression for this symbol, e.g. this is
     perfectly legal:

     integer, parameter :: i = huge(i)

     This is only true for parameters or variables of a basic type.
     For components of derived types, it is not true, so we don't
     create a symbol for those yet.  If we fail to create the symbol,
     bail out.  */
  if (gfc_current_state () != COMP_DERIVED
      && build_sym (name, cl, &as, &var_locus) == FAILURE)
    {
      m = MATCH_ERROR;
      goto cleanup;
    }

  /* In functions that have a RESULT variable defined, the function
     name always refers to function calls.  Therefore, the name is
     not allowed to appear in specification statements.  */
  if (gfc_current_state () == COMP_FUNCTION
      && gfc_current_block () != NULL
      && gfc_current_block ()->result != NULL
      && gfc_current_block ()->result != gfc_current_block ()
      && strcmp (gfc_current_block ()->name, name) == 0)
    {
      gfc_error ("Function name '%s' not allowed at %C", name);
      m = MATCH_ERROR;
      goto cleanup;
    }

  /* We allow old-style initializations of the form
       integer i /2/, j(4) /3*3, 1/
     (if no colon has been seen). These are different from data
     statements in that initializers are only allowed to apply to the
     variable immediately preceding, i.e.
       integer i, j /1, 2/
     is not allowed. Therefore we have to do some work manually, that
     could otherwise be left to the matchers for DATA statements.  */

  if (!colon_seen && gfc_match (" /") == MATCH_YES)
    {
      if (gfc_notify_std (GFC_STD_GNU, "Extension: Old-style "
			  "initialization at %C") == FAILURE)
	return MATCH_ERROR;
     
      return match_old_style_init (name);
    }

  /* The double colon must be present in order to have initializers.
     Otherwise the statement is ambiguous with an assignment statement.  */
  if (colon_seen)
    {
      if (gfc_match (" =>") == MATCH_YES)
	{

	  if (!current_attr.pointer)
	    {
	      gfc_error ("Initialization at %C isn't for a pointer variable");
	      m = MATCH_ERROR;
	      goto cleanup;
	    }

	  m = gfc_match_null (&initializer);
	  if (m == MATCH_NO)
	    {
	      gfc_error ("Pointer initialization requires a NULL() at %C");
	      m = MATCH_ERROR;
	    }

	  if (gfc_pure (NULL))
	    {
	      gfc_error
		("Initialization of pointer at %C is not allowed in a "
		 "PURE procedure");
	      m = MATCH_ERROR;
	    }

	  if (m != MATCH_YES)
	    goto cleanup;

	}
      else if (gfc_match_char ('=') == MATCH_YES)
	{
	  if (current_attr.pointer)
	    {
	      gfc_error
		("Pointer initialization at %C requires '=>', not '='");
	      m = MATCH_ERROR;
	      goto cleanup;
	    }

	  m = gfc_match_init_expr (&initializer);
	  if (m == MATCH_NO)
	    {
	      gfc_error ("Expected an initialization expression at %C");
	      m = MATCH_ERROR;
	    }

	  if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL))
	    {
	      gfc_error
		("Initialization of variable at %C is not allowed in a "
		 "PURE procedure");
	      m = MATCH_ERROR;
	    }

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

  /* Check if we are parsing an enumeration and if the current enumerator
     variable has an initializer or not. If it does not have an
     initializer, the initialization value of the previous enumerator 
     (stored in last_initializer) is incremented by 1 and is used to
     initialize the current enumerator.  */
  if (gfc_current_state () == COMP_ENUM)
    {
      if (initializer == NULL)
        initializer = gfc_enum_initializer (last_initializer, old_locus);
 
      if (initializer == NULL || initializer->ts.type != BT_INTEGER)
        {
          gfc_error("ENUMERATOR %L not initialized with integer expression",
		    &var_locus);
          m = MATCH_ERROR; 
          gfc_free_enum_history ();
          goto cleanup;
        }

      /* Store this current initializer, for the next enumerator
	 variable to be parsed.  */
      last_initializer = initializer;
    }

  /* Add the initializer.  Note that it is fine if initializer is
     NULL here, because we sometimes also need to check if a
     declaration *must* have an initialization expression.  */
  if (gfc_current_state () != COMP_DERIVED)
    t = add_init_expr_to_sym (name, &initializer, &var_locus);
  else
    {
      if (current_ts.type == BT_DERIVED && !current_attr.pointer
	  && !initializer)
	initializer = gfc_default_initializer (&current_ts);
      t = build_struct (name, cl, &initializer, &as);
    }

  m = (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;

cleanup:
  /* Free stuff up and return.  */
  gfc_free_expr (initializer);
  gfc_free_array_spec (as);

  return m;
}


/* Match an extended-f77 kind specification.  */

match
gfc_match_old_kind_spec (gfc_typespec * ts)
{
  match m;
  int original_kind, cnt;

  if (gfc_match_char ('*') != MATCH_YES)
    return MATCH_NO;

  /* cnt is unused, here.  */
  m = gfc_match_small_literal_int (&ts->kind, &cnt);
  if (m != MATCH_YES)
    return MATCH_ERROR;

  original_kind = ts->kind;

  /* Massage the kind numbers for complex types.  */
  if (ts->type == BT_COMPLEX)
    {
      if (ts->kind % 2)
        {
          gfc_error ("Old-style type declaration %s*%d not supported at %C",
                     gfc_basic_typename (ts->type), original_kind);
          return MATCH_ERROR;
        }
      ts->kind /= 2;
    }

  if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
    {
      gfc_error ("Old-style type declaration %s*%d not supported at %C",
                 gfc_basic_typename (ts->type), original_kind);
      return MATCH_ERROR;
    }

  if (gfc_notify_std (GFC_STD_GNU, "Nonstandard type declaration %s*%d at %C",
		      gfc_basic_typename (ts->type), original_kind) == FAILURE)
    return MATCH_ERROR;

  return MATCH_YES;
}


/* Match a kind specification.  Since kinds are generally optional, we
   usually return MATCH_NO if something goes wrong.  If a "kind="
   string is found, then we know we have an error.  */

match
gfc_match_kind_spec (gfc_typespec * ts)
{
  locus where;
  gfc_expr *e;
  match m, n;
  const char *msg;

  m = MATCH_NO;
  e = NULL;

  where = gfc_current_locus;

  if (gfc_match_char ('(') == MATCH_NO)
    return MATCH_NO;

  /* Also gobbles optional text.  */
  if (gfc_match (" kind = ") == MATCH_YES)
    m = MATCH_ERROR;

  n = gfc_match_init_expr (&e);
  if (n == MATCH_NO)
    gfc_error ("Expected initialization expression at %C");
  if (n != MATCH_YES)
    return MATCH_ERROR;

  if (e->rank != 0)
    {
      gfc_error ("Expected scalar initialization expression at %C");
      m = MATCH_ERROR;
      goto no_match;
    }

  msg = gfc_extract_int (e, &ts->kind);
  if (msg != NULL)
    {
      gfc_error (msg);
      m = MATCH_ERROR;
      goto no_match;
    }

  gfc_free_expr (e);
  e = NULL;

  if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
    {
      gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
		 gfc_basic_typename (ts->type));

      m = MATCH_ERROR;
      goto no_match;
    }

  if (gfc_match_char (')') != MATCH_YES)
    {
      gfc_error ("Missing right paren at %C");
      goto no_match;
    }

  return MATCH_YES;

no_match:
  gfc_free_expr (e);
  gfc_current_locus = where;
  return m;
}


/* Match the various kind/length specifications in a CHARACTER
   declaration.  We don't return MATCH_NO.  */

static match
match_char_spec (gfc_typespec * ts)
{
  int i, kind, seen_length;
  gfc_charlen *cl;
  gfc_expr *len;
  match m;

  kind = gfc_default_character_kind;
  len = NULL;
  seen_length = 0;

  /* Try the old-style specification first.  */
  old_char_selector = 0;

  m = match_char_length (&len);
  if (m != MATCH_NO)
    {
      if (m == MATCH_YES)
	old_char_selector = 1;
      seen_length = 1;
      goto done;
    }

  m = gfc_match_char ('(');
  if (m != MATCH_YES)
    {
      m = MATCH_YES;	/* character without length is a single char */
      goto done;
    }

  /* Try the weird case:  ( KIND = <int> [ , LEN = <len-param> ] )   */
  if (gfc_match (" kind =") == MATCH_YES)
    {
      m = gfc_match_small_int (&kind);
      if (m == MATCH_ERROR)
	goto done;
      if (m == MATCH_NO)
	goto syntax;

      if (gfc_match (" , len =") == MATCH_NO)
	goto rparen;

      m = char_len_param_value (&len);
      if (m == MATCH_NO)
	goto syntax;
      if (m == MATCH_ERROR)
	goto done;
      seen_length = 1;

      goto rparen;
    }

  /* Try to match ( LEN = <len-param> ) or ( LEN = <len-param>, KIND = <int> )  */
  if (gfc_match (" len =") == MATCH_YES)
    {
      m = char_len_param_value (&len);
      if (m == MATCH_NO)
	goto syntax;
      if (m == MATCH_ERROR)
	goto done;
      seen_length = 1;

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

      if (gfc_match (" , kind =") != MATCH_YES)
	goto syntax;

      gfc_match_small_int (&kind);

      if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
	{
	  gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
	  return MATCH_YES;
	}

      goto rparen;
    }

  /* Try to match   ( <len-param> ) or ( <len-param> , [ KIND = ] <int> )  */
  m = char_len_param_value (&len);
  if (m == MATCH_NO)
    goto syntax;
  if (m == MATCH_ERROR)
    goto done;
  seen_length = 1;

  m = gfc_match_char (')');
  if (m == MATCH_YES)
    goto done;

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

  gfc_match (" kind =");	/* Gobble optional text */

  m = gfc_match_small_int (&kind);
  if (m == MATCH_ERROR)
    goto done;
  if (m == MATCH_NO)
    goto syntax;

rparen:
  /* Require a right-paren at this point.  */
  m = gfc_match_char (')');
  if (m == MATCH_YES)
    goto done;

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

done:
  if (m == MATCH_YES && gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
    {
      gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
      m = MATCH_ERROR;
    }

  if (m != MATCH_YES)
    {
      gfc_free_expr (len);
      return m;
    }

  /* Do some final massaging of the length values.  */
  cl = gfc_get_charlen ();
  cl->next = gfc_current_ns->cl_list;
  gfc_current_ns->cl_list = cl;

  if (seen_length == 0)
    cl->length = gfc_int_expr (1);
  else
    {
      if (len == NULL || gfc_extract_int (len, &i) != NULL || i >= 0)
	cl->length = len;
      else
	{
	  gfc_free_expr (len);
	  cl->length = gfc_int_expr (0);
	}
    }

  ts->cl = cl;
  ts->kind = kind;

  return MATCH_YES;
}


/* Matches a type specification.  If successful, sets the ts structure
   to the matched specification.  This is necessary for FUNCTION and
   IMPLICIT statements.

   If implicit_flag is nonzero, then we don't check for the optional 
   kind specification.  Not doing so is needed for matching an IMPLICIT
   statement correctly.  */

static match
match_type_spec (gfc_typespec * ts, int implicit_flag)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_symbol *sym;
  match m;
  int c;

  gfc_clear_ts (ts);

  if (gfc_match (" byte") == MATCH_YES)
    {
      if (gfc_notify_std(GFC_STD_GNU, "Extension: BYTE type at %C") 
	  == FAILURE)
	return MATCH_ERROR;

      if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
	{
	  gfc_error ("BYTE type used at %C "
		     "is not available on the target machine");
	  return MATCH_ERROR;
	}
      
      ts->type = BT_INTEGER;
      ts->kind = 1;
      return MATCH_YES;
    }

  if (gfc_match (" integer") == MATCH_YES)
    {
      ts->type = BT_INTEGER;
      ts->kind = gfc_default_integer_kind;
      goto get_kind;
    }

  if (gfc_match (" character") == MATCH_YES)
    {
      ts->type = BT_CHARACTER;
      if (implicit_flag == 0)
	return match_char_spec (ts);
      else
	return MATCH_YES;
    }

  if (gfc_match (" real") == MATCH_YES)
    {
      ts->type = BT_REAL;
      ts->kind = gfc_default_real_kind;
      goto get_kind;
    }

  if (gfc_match (" double precision") == MATCH_YES)
    {
      ts->type = BT_REAL;
      ts->kind = gfc_default_double_kind;
      return MATCH_YES;
    }

  if (gfc_match (" complex") == MATCH_YES)
    {
      ts->type = BT_COMPLEX;
      ts->kind = gfc_default_complex_kind;
      goto get_kind;
    }

  if (gfc_match (" double complex") == MATCH_YES)
    {
      if (gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C does not "
			  "conform to the Fortran 95 standard") == FAILURE)
	return MATCH_ERROR;

      ts->type = BT_COMPLEX;
      ts->kind = gfc_default_double_kind;
      return MATCH_YES;
    }

  if (gfc_match (" logical") == MATCH_YES)
    {
      ts->type = BT_LOGICAL;
      ts->kind = gfc_default_logical_kind;
      goto get_kind;
    }

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

  /* Search for the name but allow the components to be defined later.  */
  if (gfc_get_ha_symbol (name, &sym))
    {
      gfc_error ("Type name '%s' at %C is ambiguous", name);
      return MATCH_ERROR;
    }

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

  ts->type = BT_DERIVED;
  ts->kind = 0;
  ts->derived = sym;

  return MATCH_YES;

get_kind:
  /* For all types except double, derived and character, look for an
     optional kind specifier.  MATCH_NO is actually OK at this point.  */
  if (implicit_flag == 1)
    return MATCH_YES;