decl.c

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

  i = gfc_get_symbol (name, NULL, result);
  if (i==0) 
    goto end;
  
  if (gfc_current_state () != COMP_SUBROUTINE
      && gfc_current_state () != COMP_FUNCTION)
    goto end;

  s = gfc_state_stack->previous;
  if (s == NULL)
    goto end;

  if (s->state != COMP_INTERFACE)
    goto end;
  if (s->sym == NULL)
    goto end;                  /* Nameless interface */

  if (strcmp (name, s->sym->name) == 0)
    {
      *result = s->sym;
      return 0;
    }

end:
  return i;
}


/* Special subroutine for getting a symbol node associated with a
   procedure name, used in SUBROUTINE and FUNCTION statements.  The
   symbol is created in the parent using with symtree node in the
   child unit pointing to the symbol.  If the current namespace has no
   parent, then the symbol is just created in the current unit.  */

static int
get_proc_name (const char *name, gfc_symbol ** result)
{
  gfc_symtree *st;
  gfc_symbol *sym;
  int rc;

  if (gfc_current_ns->parent == NULL)
    rc = gfc_get_symbol (name, NULL, result);
  else
    rc = gfc_get_symbol (name, gfc_current_ns->parent, result);

  sym = *result;

  if (sym && !sym->new && gfc_current_state () != COMP_INTERFACE)
    {
      /* Trap another encompassed procedure with the same name.  All
	 these conditions are necessary to avoid picking up an entry
	 whose name clashes with that of the encompassing procedure;
	 this is handled using gsymbols to register unique,globally
	 accessible names.  */
      if (sym->attr.flavor != 0
	    && sym->attr.proc != 0
	    && sym->formal)
	gfc_error_now ("Procedure '%s' at %C is already defined at %L",
		       name, &sym->declared_at);

      /* Trap declarations of attributes in encompassing scope.  The
	 signature for this is that ts.kind is set.  Legitimate
	 references only set ts.type.  */
      if (sym->ts.kind != 0
	    && sym->attr.proc == 0
	    && gfc_current_ns->parent != NULL
	    && sym->attr.access == 0)
	gfc_error_now ("Procedure '%s' at %C has an explicit interface"
		       " and must not have attributes declared at %L",
		       name, &sym->declared_at);
    }

  if (gfc_current_ns->parent == NULL || *result == NULL)
    return rc;

  st = gfc_new_symtree (&gfc_current_ns->sym_root, name);

  st->n.sym = sym;
  sym->refs++;

  /* See if the procedure should be a module procedure */

  if (sym->ns->proc_name != NULL
      && sym->ns->proc_name->attr.flavor == FL_MODULE
      && sym->attr.proc != PROC_MODULE
      && gfc_add_procedure (&sym->attr, PROC_MODULE,
			    sym->name, NULL) == FAILURE)
    rc = 2;

  return rc;
}


/* Function called by variable_decl() that adds a name to the symbol
   table.  */

static try
build_sym (const char *name, gfc_charlen * cl,
	   gfc_array_spec ** as, locus * var_locus)
{
  symbol_attribute attr;
  gfc_symbol *sym;

  /* if (find_special (name, &sym)) */
  if (gfc_get_symbol (name, NULL, &sym))
    return FAILURE;

  /* Start updating the symbol table.  Add basic type attribute
     if present.  */
  if (current_ts.type != BT_UNKNOWN
      &&(sym->attr.implicit_type == 0
	 || !gfc_compare_types (&sym->ts, &current_ts))
      && gfc_add_type (sym, &current_ts, var_locus) == FAILURE)
    return FAILURE;

  if (sym->ts.type == BT_CHARACTER)
    sym->ts.cl = cl;

  /* Add dimension attribute if present.  */
  if (gfc_set_array_spec (sym, *as, var_locus) == FAILURE)
    return FAILURE;
  *as = NULL;

  /* Add attribute to symbol.  The copy is so that we can reset the
     dimension attribute.  */
  attr = current_attr;
  attr.dimension = 0;

  if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE)
    return FAILURE;

  return SUCCESS;
}

/* Set character constant to the given length. The constant will be padded or
   truncated.  */

void
gfc_set_constant_character_len (int len, gfc_expr * expr)
{
  char * s;
  int slen;

  gcc_assert (expr->expr_type == EXPR_CONSTANT);
  gcc_assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1);

  slen = expr->value.character.length;
  if (len != slen)
    {
      s = gfc_getmem (len);
      memcpy (s, expr->value.character.string, MIN (len, slen));
      if (len > slen)
	memset (&s[slen], ' ', len - slen);
      gfc_free (expr->value.character.string);
      expr->value.character.string = s;
      expr->value.character.length = len;
    }
}


/* Function to create and update the enumerator history 
   using the information passed as arguments.
   Pointer "max_enum" is also updated, to point to 
   enum history node containing largest initializer.  

   SYM points to the symbol node of enumerator.
   INIT points to its enumerator value.   */

static void 
create_enum_history(gfc_symbol *sym, gfc_expr *init)
{
  enumerator_history *new_enum_history;
  gcc_assert (sym != NULL && init != NULL);

  new_enum_history = gfc_getmem (sizeof (enumerator_history));

  new_enum_history->sym = sym;
  new_enum_history->initializer = init;
  new_enum_history->next = NULL;

  if (enum_history == NULL)
    {
      enum_history = new_enum_history;
      max_enum = enum_history;
    }
  else
    {
      new_enum_history->next = enum_history;
      enum_history = new_enum_history;

      if (mpz_cmp (max_enum->initializer->value.integer, 
		   new_enum_history->initializer->value.integer) < 0)
        max_enum = new_enum_history;
    }
}


/* Function to free enum kind history.  */ 

void 
gfc_free_enum_history(void)
{
  enumerator_history *current = enum_history;  
  enumerator_history *next;  

  while (current != NULL)
    {
      next = current->next;
      gfc_free (current);
      current = next;
    }
  max_enum = NULL;
  enum_history = NULL;
}


/* Function called by variable_decl() that adds an initialization
   expression to a symbol.  */

static try
add_init_expr_to_sym (const char *name, gfc_expr ** initp,
		      locus * var_locus)
{
  symbol_attribute attr;
  gfc_symbol *sym;
  gfc_expr *init;

  init = *initp;
  if (find_special (name, &sym))
    return FAILURE;

  attr = sym->attr;

  /* If this symbol is confirming an implicit parameter type,
     then an initialization expression is not allowed.  */
  if (attr.flavor == FL_PARAMETER
      && sym->value != NULL
      && *initp != NULL)
    {
      gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
		 sym->name);
      return FAILURE;
    }

  if (attr.in_common
      && !attr.data
      && *initp != NULL)
    {
      gfc_error ("Initializer not allowed for COMMON variable '%s' at %C",
		 sym->name);
      return FAILURE;
    }

  if (init == NULL)
    {
      /* An initializer is required for PARAMETER declarations.  */
      if (attr.flavor == FL_PARAMETER)
	{
	  gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
	  return FAILURE;
	}
    }
  else
    {
      /* If a variable appears in a DATA block, it cannot have an
	 initializer.  */
      if (sym->attr.data)
	{
	  gfc_error
	    ("Variable '%s' at %C with an initializer already appears "
	     "in a DATA statement", sym->name);
	  return FAILURE;
	}

      /* Check if the assignment can happen. This has to be put off
	 until later for a derived type variable.  */
      if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
	  && gfc_check_assign_symbol (sym, init) == FAILURE)
	return FAILURE;

      if (sym->ts.type == BT_CHARACTER && sym->ts.cl)
	{
	  /* Update symbol character length according initializer.  */
	  if (sym->ts.cl->length == NULL)
	    {
	      /* If there are multiple CHARACTER variables declared on
		 the same line, we don't want them to share the same
	        length.  */
	      sym->ts.cl = gfc_get_charlen ();
	      sym->ts.cl->next = gfc_current_ns->cl_list;
	      gfc_current_ns->cl_list = sym->ts.cl;

	      if (init->expr_type == EXPR_CONSTANT)
		sym->ts.cl->length =
			gfc_int_expr (init->value.character.length);
	      else if (init->expr_type == EXPR_ARRAY)
		sym->ts.cl->length = gfc_copy_expr (init->ts.cl->length);
	    }
	  /* Update initializer character length according symbol.  */
	  else if (sym->ts.cl->length->expr_type == EXPR_CONSTANT)
	    {
	      int len = mpz_get_si (sym->ts.cl->length->value.integer);
	      gfc_constructor * p;

	      if (init->expr_type == EXPR_CONSTANT)
		gfc_set_constant_character_len (len, init);
	      else if (init->expr_type == EXPR_ARRAY)
		{
		  gfc_free_expr (init->ts.cl->length);
		  init->ts.cl->length = gfc_copy_expr (sym->ts.cl->length);
		  for (p = init->value.constructor; p; p = p->next)
		    gfc_set_constant_character_len (len, p->expr);
		}
	    }
	}

      /* Add initializer.  Make sure we keep the ranks sane.  */
      if (sym->attr.dimension && init->rank == 0)
	init->rank = sym->as->rank;

      sym->value = init;
      *initp = NULL;
    }

  /* Maintain enumerator history.  */
  if (gfc_current_state () == COMP_ENUM)
    create_enum_history (sym, init);

  return SUCCESS;
}


/* Function called by variable_decl() that adds a name to a structure
   being built.  */

static try
build_struct (const char *name, gfc_charlen * cl, gfc_expr ** init,
	      gfc_array_spec ** as)
{
  gfc_component *c;

  /* If the current symbol is of the same derived type that we're
     constructing, it must have the pointer attribute.  */
  if (current_ts.type == BT_DERIVED
      && current_ts.derived == gfc_current_block ()
      && current_attr.pointer == 0)
    {
      gfc_error ("Component at %C must have the POINTER attribute");
      return FAILURE;
    }

  if (gfc_current_block ()->attr.pointer
      && (*as)->rank != 0)
    {
      if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
	{
	  gfc_error ("Array component of structure at %C must have explicit "
		     "or deferred shape");
	  return FAILURE;
	}
    }

  if (gfc_add_component (gfc_current_block (), name, &c) == FAILURE)
    return FAILURE;

  c->ts = current_ts;
  c->ts.cl = cl;
  gfc_set_component_attr (c, &current_attr);

  c->initializer = *init;
  *init = NULL;

  c->as = *as;
  if (c->as != NULL)
    c->dimension = 1;
  *as = NULL;

  /* Check array components.  */
  if (!c->dimension)
    return SUCCESS;

  if (c->pointer)
    {
      if (c->as->type != AS_DEFERRED)
	{
	  gfc_error ("Pointer array component of structure at %C "
		     "must have a deferred shape");
	  return FAILURE;
	}
    }
  else
    {
      if (c->as->type != AS_EXPLICIT)
	{
	  gfc_error
	    ("Array component of structure at %C must have an explicit "
	     "shape");
	  return FAILURE;
	}
    }

  return SUCCESS;
}


/* Match a 'NULL()', and possibly take care of some side effects.  */

match
gfc_match_null (gfc_expr ** result)
{
  gfc_symbol *sym;
  gfc_expr *e;
  match m;

  m = gfc_match (" null ( )");
  if (m != MATCH_YES)
    return m;

  /* The NULL symbol now has to be/become an intrinsic function.  */
  if (gfc_get_symbol ("null", NULL, &sym))
    {
      gfc_error ("NULL() initialization at %C is ambiguous");
      return MATCH_ERROR;
    }

  gfc_intrinsic_symbol (sym);

  if (sym->attr.proc != PROC_INTRINSIC
      && (gfc_add_procedure (&sym->attr, PROC_INTRINSIC,
			     sym->name, NULL) == FAILURE
	  || gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE))
    return MATCH_ERROR;

  e = gfc_get_expr ();
  e->where = gfc_current_locus;
  e->expr_type = EXPR_NULL;
  e->ts.type = BT_UNKNOWN;

  *result = e;

  return MATCH_YES;
}


/* Match a variable name with an optional initializer.  When this
   subroutine is called, a variable is expected to be parsed next.
   Depending on what is happening at the moment, updates either the
   symbol table or the current interface.  */

static match
variable_decl (int elem)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_expr *initializer, *char_len;
  gfc_array_spec *as;
  gfc_array_spec *cp_as; /* Extra copy for Cray Pointees.  */
  gfc_charlen *cl;
  locus var_locus;
  match m;
  try t;
  gfc_symbol *sym;
  locus old_locus;

  initializer = NULL;
  as = NULL;
  cp_as = NULL;
  old_locus = gfc_current_locus;

  /* When we get here, we've just matched a list of attributes and
     maybe a type and a double colon.  The next thing we expect to see
     is the name of the symbol.  */
  m = gfc_match_name (name);
  if (m != MATCH_YES)
    goto cleanup;

  var_locus = gfc_current_locus;

  /* Now we could see the optional array spec. or character length.  */
  m = gfc_match_array_spec (&as);
  if (gfc_option.flag_cray_pointer && m == MATCH_YES)
    cp_as = gfc_copy_array_spec (as);
  else if (m == MATCH_ERROR)
    goto cleanup;

  if (m == MATCH_NO)
    as = gfc_copy_array_spec (current_as);
  else if (gfc_current_state () == COMP_ENUM)
    {
      gfc_error ("Enumerator cannot be array at %C");
      gfc_free_enum_history ();
      m = MATCH_ERROR;
      goto cleanup;
    }


  char_len = NULL;
  cl = NULL;

  if (current_ts.type == BT_CHARACTER)
    {
      switch (match_char_length (&char_len))
	{
	case MATCH_YES:
	  cl = gfc_get_charlen ();
	  cl->next = gfc_current_ns->cl_list;
	  gfc_current_ns->cl_list = cl;

	  cl->length = char_len;
	  break;

	/* Non-constant lengths need to be copied after the first
	   element.  */
	case MATCH_NO:
	  if (elem > 1 && current_ts.cl->length
		&& current_ts.cl->length->expr_type != EXPR_CONSTANT)
	    {
	      cl = gfc_get_charlen ();
	      cl->next = gfc_current_ns->cl_list;
	      gfc_current_ns->cl_list = cl;
	      cl->length = gfc_copy_expr (current_ts.cl->length);
	    }
	  else
	    cl = current_ts.cl;

	  break;

	case MATCH_ERROR:
	  goto cleanup;
	}
    }

  /*  If this symbol has already shown up in a Cray Pointer declaration,
      then we want to set the type & bail out. */
  if (gfc_option.flag_cray_pointer)
    {
      gfc_find_symbol (name, gfc_current_ns, 1, &sym);
      if (sym != NULL && sym->attr.cray_pointee)
	{
	  sym->ts.type = current_ts.type;
	  sym->ts.kind = current_ts.kind;
	  sym->ts.cl = cl;
	  sym->ts.derived = current_ts.derived;
	  m = MATCH_YES;
	
	  /* Check to see if we have an array specification.  */
	  if (cp_as != NULL)
	    {
	      if (sym->as != NULL)
		{
		  gfc_error ("Duplicate array spec for Cray pointee at %C.");
		  gfc_free_array_spec (cp_as);
		  m = MATCH_ERROR;
		  goto cleanup;
		}
	      else
		{
		  if (gfc_set_array_spec (sym, cp_as, &var_locus) == FAILURE)
		    gfc_internal_error ("Couldn't set pointee array spec.");
	      
		  /* Fix the array spec.  */
		  m = gfc_mod_pointee_as (sym->as);