{
static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
*target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
- *intrinsic = "INTRINSIC", *allocatable = "ALLOCATABLE",
- *elemental = "ELEMENTAL", *private = "PRIVATE", *recursive = "RECURSIVE",
+ *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
+ *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
+ *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
+ *private = "PRIVATE", *recursive = "RECURSIVE",
*in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
*public = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
*function = "FUNCTION", *subroutine = "SUBROUTINE",
*dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
*use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
- *cray_pointee = "CRAY POINTEE", *data = "DATA";
+ *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
+ *volatile_ = "VOLATILE";
static const char *threadprivate = "THREADPRIVATE";
const char *a1, *a2;
}
}
+ conf (dummy, entry);
+ conf (dummy, intrinsic);
conf (dummy, save);
conf (dummy, threadprivate);
conf (pointer, target);
conf (data, allocatable);
conf (data, use_assoc);
+ conf (value, pointer)
+ conf (value, allocatable)
+ conf (value, subroutine)
+ conf (value, function)
+ conf (value, volatile_)
+ conf (value, dimension)
+ conf (value, external)
+
+ if (attr->value && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
+ {
+ a1 = value;
+ a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
+ goto conflict;
+ }
+
+ conf (volatile_, intrinsic)
+ conf (volatile_, external)
+
+ if (attr->volatile_ && attr->intent == INTENT_IN)
+ {
+ a1 = volatile_;
+ a2 = intent_in;
+ goto conflict;
+ }
+
a1 = gfc_code2string (flavors, attr->flavor);
if (attr->in_namelist
case FL_BLOCK_DATA:
case FL_MODULE:
case FL_LABEL:
+ conf2 (dimension);
conf2 (dummy);
conf2 (save);
+ conf2 (volatile_);
conf2 (pointer);
conf2 (target);
conf2 (external);
case FL_PROCEDURE:
conf2 (intent);
+ conf2(save);
if (attr->subroutine)
{
- conf2(save);
conf2(pointer);
conf2(target);
conf2(allocatable);
conf2(result);
conf2(in_namelist);
+ conf2(dimension);
conf2(function);
conf2(threadprivate);
}
conf2 (dummy);
conf2 (in_common);
conf2 (save);
+ conf2 (value);
+ conf2 (volatile_);
conf2 (threadprivate);
break;
}
-/* Used to prevent changing the attributes of a symbol after it has been
- used. This check is only done for dummy variables as only these can be
- used in specification expressions. Applying this to all symbols causes
- an error when we reach the body of a contained function. */
-
-static int
-check_done (symbol_attribute * attr, locus * where)
-{
-
- if (!(attr->dummy && attr->referenced))
- return 0;
-
- if (where == NULL)
- where = &gfc_current_locus;
-
- gfc_error ("Cannot change attributes of symbol at %L"
- " after it has been used", where);
-
- return 1;
-}
-
-
/* Generate an error because of a duplicate attribute. */
static void
/* Called from decl.c (attr_decl1) to check attributes, when declared separately. */
try
-gfc_add_attribute (symbol_attribute * attr, locus * where,
- unsigned int attr_intent)
+gfc_add_attribute (symbol_attribute * attr, locus * where)
{
-
- if (check_used (attr, NULL, where)
- || (attr_intent == 0 && check_done (attr, where)))
+ if (check_used (attr, NULL, where))
return FAILURE;
return check_conflict (attr, NULL, where);
gfc_add_allocatable (symbol_attribute * attr, locus * where)
{
- if (check_used (attr, NULL, where) || check_done (attr, where))
+ if (check_used (attr, NULL, where))
return FAILURE;
if (attr->allocatable)
gfc_add_dimension (symbol_attribute * attr, const char *name, locus * where)
{
- if (check_used (attr, name, where) || check_done (attr, where))
+ if (check_used (attr, name, where))
return FAILURE;
if (attr->dimension)
gfc_add_external (symbol_attribute * attr, locus * where)
{
- if (check_used (attr, NULL, where) || check_done (attr, where))
+ if (check_used (attr, NULL, where))
return FAILURE;
if (attr->external)
gfc_add_intrinsic (symbol_attribute * attr, locus * where)
{
- if (check_used (attr, NULL, where) || check_done (attr, where))
+ if (check_used (attr, NULL, where))
return FAILURE;
if (attr->intrinsic)
gfc_add_optional (symbol_attribute * attr, locus * where)
{
- if (check_used (attr, NULL, where) || check_done (attr, where))
+ if (check_used (attr, NULL, where))
return FAILURE;
if (attr->optional)
gfc_add_pointer (symbol_attribute * attr, locus * where)
{
- if (check_used (attr, NULL, where) || check_done (attr, where))
+ if (check_used (attr, NULL, where))
return FAILURE;
attr->pointer = 1;
gfc_add_cray_pointer (symbol_attribute * attr, locus * where)
{
- if (check_used (attr, NULL, where) || check_done (attr, where))
+ if (check_used (attr, NULL, where))
return FAILURE;
attr->cray_pointer = 1;
gfc_add_cray_pointee (symbol_attribute * attr, locus * where)
{
- if (check_used (attr, NULL, where) || check_done (attr, where))
+ if (check_used (attr, NULL, where))
return FAILURE;
if (attr->cray_pointee)
{
gfc_error ("Cray Pointee at %L appears in multiple pointer()"
- " statements.", where);
+ " statements", where);
return FAILURE;
}
gfc_add_result (symbol_attribute * attr, const char *name, locus * where)
{
- if (check_used (attr, name, where) || check_done (attr, where))
+ if (check_used (attr, name, where))
return FAILURE;
attr->result = 1;
return check_conflict (attr, name, where);
}
+try
+gfc_add_value (symbol_attribute * attr, const char *name, locus * where)
+{
+
+ if (check_used (attr, name, where))
+ return FAILURE;
+
+ if (attr->value)
+ {
+ if (gfc_notify_std (GFC_STD_LEGACY,
+ "Duplicate VALUE attribute specified at %L",
+ where)
+ == FAILURE)
+ return FAILURE;
+ }
+
+ attr->value = 1;
+ return check_conflict (attr, name, where);
+}
+
+try
+gfc_add_volatile (symbol_attribute * attr, const char *name, locus * where)
+{
+
+ if (check_used (attr, name, where))
+ return FAILURE;
+
+ if (attr->volatile_)
+ {
+ if (gfc_notify_std (GFC_STD_LEGACY,
+ "Duplicate VOLATILE attribute specified at %L",
+ where)
+ == FAILURE)
+ return FAILURE;
+ }
+
+ attr->volatile_ = 1;
+ return check_conflict (attr, name, where);
+}
+
try
gfc_add_threadprivate (symbol_attribute * attr, const char *name, locus * where)
gfc_add_target (symbol_attribute * attr, locus * where)
{
- if (check_used (attr, NULL, where) || check_done (attr, where))
+ if (check_used (attr, NULL, where))
return FAILURE;
if (attr->target)
gfc_add_in_common (symbol_attribute * attr, const char *name, locus * where)
{
- if (check_used (attr, name, where) || check_done (attr, where))
+ if (check_used (attr, name, where))
return FAILURE;
/* Duplicate attribute already checked for. */
gfc_add_elemental (symbol_attribute * attr, locus * where)
{
- if (check_used (attr, NULL, where) || check_done (attr, where))
+ if (check_used (attr, NULL, where))
return FAILURE;
attr->elemental = 1;
gfc_add_pure (symbol_attribute * attr, locus * where)
{
- if (check_used (attr, NULL, where) || check_done (attr, where))
+ if (check_used (attr, NULL, where))
return FAILURE;
attr->pure = 1;
gfc_add_recursive (symbol_attribute * attr, locus * where)
{
- if (check_used (attr, NULL, where) || check_done (attr, where))
+ if (check_used (attr, NULL, where))
return FAILURE;
attr->recursive = 1;
const char *name, locus * where)
{
- if (check_used (attr, name, where) || check_done (attr, where))
+ if (check_used (attr, name, where))
return FAILURE;
if (attr->flavor != FL_PROCEDURE
{
sym_flavor flavor;
-/* TODO: This is legal if it is reaffirming an implicit type.
- if (check_done (&sym->attr, where))
- return FAILURE;*/
-
if (where == NULL)
where = &gfc_current_locus;
goto fail;
if (src->save && gfc_add_save (dest, NULL, where) == FAILURE)
goto fail;
+ if (src->value && gfc_add_value (dest, NULL, where) == FAILURE)
+ goto fail;
+ if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE)
+ goto fail;
if (src->threadprivate && gfc_add_threadprivate (dest, NULL, where) == FAILURE)
goto fail;
if (src->target && gfc_add_target (dest, where) == FAILURE)
c->dimension = attr->dimension;
c->pointer = attr->pointer;
+ c->allocatable = attr->allocatable;
}
gfc_clear_attr (attr);
attr->dimension = c->dimension;
attr->pointer = c->pointer;
+ attr->allocatable = c->allocatable;
}