You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA. */
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA. */
#include "config.h"
{
int i;
+ if (gfc_current_ns->seen_implicit_none)
+ {
+ gfc_error ("Duplicate IMPLICIT NONE statement at %C");
+ return;
+ }
+
+ gfc_current_ns->seen_implicit_none = 1;
+
for (i = 0; i < GFC_LETTERS; i++)
{
gfc_clear_ts (&gfc_current_ns->default_type[i]);
{
int i;
+ if (gfc_current_ns->seen_implicit_none)
+ {
+ gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
+ return FAILURE;
+ }
+
for (i = 0; i < GFC_LETTERS; i++)
{
if (new_flag[i])
}
-/* Given a symbol, return a pointer to the typespec for it's default
- type. */
+/* Given a symbol, return a pointer to the typespec for its default type. */
gfc_typespec *
gfc_get_default_type (gfc_symbol * sym, gfc_namespace * ns)
if (ts->type == BT_UNKNOWN)
{
- if (error_flag)
- gfc_error ("Symbol '%s' at %L has no IMPLICIT type", sym->name,
- &sym->declared_at);
+ if (error_flag && !sym->attr.untyped)
+ {
+ gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
+ sym->name, &sym->declared_at);
+ sym->attr.untyped = 1; /* Ensure we only give an error once. */
+ }
return FAILURE;
}
{
case PROC_ST_FUNCTION:
conf2 (in_common);
+ conf2 (dummy);
break;
case PROC_MODULE:
conf2 (target);
conf2 (dummy);
conf2 (in_common);
+ conf2 (save);
break;
default:
/* Used to prevent changing the attributes of a symbol after it has been
- used. This check is only done from dummy variable as only these can be
+ used. This check is only done for dummy variables as only these can be
used in specification expressions. Applying this to all symbols causes
- error when we reach the body of a contained function. */
+ an error when we reach the body of a contained function. */
static int
check_done (symbol_attribute * attr, locus * where)
if (check_used (attr, name, where))
return FAILURE;
- /* Duplicate dummy arguments are allow due to ENTRY statements. */
+ /* Duplicate dummy arguments are allowed due to ENTRY statements. */
attr->dummy = 1;
return check_conflict (attr, name, where);
}
}
-/* Flavors are special because some flavors are not what fortran
+/* Flavors are special because some flavors are not what Fortran
considers attributes and can be reaffirmed multiple times. */
try
if (attr->proc != PROC_UNKNOWN)
{
- gfc_error ("%s procedure at %L is already %s %s procedure",
+ gfc_error ("%s procedure at %L is already declared as %s procedure",
gfc_code2string (procedures, t), where,
- gfc_article (gfc_code2string (procedures, attr->proc)),
gfc_code2string (procedures, attr->proc));
return FAILURE;
goto fail;
/* The subroutines that set these bits also cause flavors to be set,
- and that has already happened in the original, so don't let to
+ and that has already happened in the original, so don't let it
happen again. */
if (src->external)
dest->external = 1;
tail = p;
}
- /* Allocate new component */
+ /* Allocate a new component. */
p = gfc_get_component ();
if (tail == NULL)
else
tail->next = p;
- strcpy (p->name, name);
+ p->name = gfc_get_string (name);
p->loc = gfc_current_locus;
*component = p;
have to have a derived type in a parent unit. We find the node in
the other namespace and point the symtree node in this namespace to
that node. Further reference to this name point to the correct
- node. If we can't find the node in a parent namespace, then have
+ node. If we can't find the node in a parent namespace, then we have
an error.
This subroutine takes a pointer to a symbol node and returns a
the internal subprograms must be read before we can start
generating code for the host.
- Given the tricky nature of the fortran grammar, we must be able to
+ Given the tricky nature of the Fortran grammar, we must be able to
undo changes made to a symbol table if the current interpretation
of a statement is found to be incorrect. Whenever a symbol is
looked up, we make a copy of it and link to it. All of these
this case, that symbol has been used as a host associated variable
at some previous time. */
-/* Allocate a new namespace structure. */
+/* Allocate a new namespace structure. Copies the implicit types from
+ PARENT if PARENT_TYPES is set. */
gfc_namespace *
-gfc_get_namespace (gfc_namespace * parent)
+gfc_get_namespace (gfc_namespace * parent, int parent_types)
{
gfc_namespace *ns;
gfc_typespec *ts;
ns->set_flag[i - 'a'] = 0;
ts = &ns->default_type[i - 'a'];
- if (ns->parent != NULL)
+ if (parent_types && ns->parent != NULL)
{
/* Copy parent settings */
*ts = ns->parent->default_type[i - 'a'];
gfc_symtree *st;
st = gfc_getmem (sizeof (gfc_symtree));
- strcpy (st->name, name);
+ st->name = gfc_get_string (name);
gfc_insert_bbt (root, st, compare_symtree);
return st;
st0 = gfc_find_symtree (*root, name);
- strcpy (st.name, name);
+ st.name = gfc_get_string (name);
gfc_delete_bbt (root, &st, compare_symtree);
gfc_free (st0);
st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
uop = st->n.uop = gfc_getmem (sizeof (gfc_user_op));
- strcpy (uop->name, name);
+ uop->name = gfc_get_string (name);
uop->access = ACCESS_UNKNOWN;
uop->ns = gfc_current_ns;
if (strlen (name) > GFC_MAX_SYMBOL_LEN)
gfc_internal_error ("new_symbol(): Symbol name too long");
- strcpy (p->name, name);
+ p->name = gfc_get_string (name);
return p;
}
ambiguous_symbol (const char *name, gfc_symtree * st)
{
- if (st->n.sym->module[0])
+ if (st->n.sym->module)
gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
"from module '%s'", name, st->n.sym->name, st->n.sym->module);
else
gfc_symbol_init_2 (void)
{
- gfc_current_ns = gfc_get_namespace (NULL);
+ gfc_current_ns = gfc_get_namespace (NULL, 0);
}
}
+/* Return TRUE if the symbol is an automatic variable. */
+static bool
+gfc_is_var_automatic (gfc_symbol * sym)
+{
+ /* Pointer and allocatable variables are never automatic. */
+ if (sym->attr.pointer || sym->attr.allocatable)
+ return false;
+ /* Check for arrays with non-constant size. */
+ if (sym->attr.dimension && sym->as
+ && !gfc_is_compile_time_shape (sym->as))
+ return true;
+ /* Check for non-constant length character variables. */
+ if (sym->ts.type == BT_CHARACTER
+ && sym->ts.cl
+ && !gfc_is_constant_expr (sym->ts.cl->length))
+ return true;
+ return false;
+}
+
/* Given a symbol, mark it as SAVEd if it is allowed. */
static void
|| sym->attr.dummy
|| sym->attr.flavor != FL_VARIABLE)
return;
-
+ /* Automatic objects are not saved. */
+ if (gfc_is_var_automatic (sym))
+ return;
gfc_add_save (&sym->attr, sym->name, &sym->declared_at);
}
/* Search a tree for the global symbol. */
gfc_gsymbol *
-gfc_find_gsymbol (gfc_gsymbol *symbol, char *name)
+gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
{
gfc_gsymbol *s;
/* Get a global symbol, creating it if it doesn't exist. */
gfc_gsymbol *
-gfc_get_gsymbol (char *name)
+gfc_get_gsymbol (const char *name)
{
gfc_gsymbol *s;
s = gfc_getmem (sizeof (gfc_gsymbol));
s->type = GSYM_UNKNOWN;
- strcpy (s->name, name);
+ s->name = gfc_get_string (name);
gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
OSDN Git Service
