Commit 34d567d1 by Fritz Reese Committed by Fritz Reese

lang.opt, [...]: New flag -fdec-static.

2016-09-23  Fritz Reese  <fritzoreese@gmail.com>

	gcc/fortran/
	* lang.opt, invoke.texi, gfortran.texi: New flag -fdec-static.
	* options.c (set_dec_flags): Set -fdec-static with -fdec.
	* gfortran.h (symbol_attribute): New attribute automatic.
	* gfortran.h (gfc_add_automatic): New prototype.
	* match.h (gfc_match_automatic, gfc_match_static): New functions.
	* decl.c (gfc_match_automatic, gfc_match_static): Ditto.
	* symbol.c (gfc_add_automatic): Ditto.
	* decl.c (match_attr_spec): Match AUTOMATIC and STATIC decls.
	* parse.c (decode_specification_statement, decode_statement): Ditto.
	* resolve.c (apply_default_init_local, resolve_fl_variable_derived,
	resolve_symbol): Support for automatic attribute.
	* symbol.c (check_conflict, gfc_copy_attr, gfc_is_var_automatic):
	Ditto.
	* trans-decl.c (gfc_finish_var_decl): Ditto.

	gcc/testsuite/gfortran.dg/
	* dec_static_1.f90, dec_static_2.f90, dec_static_3.f90,
	dec_static_4.f90: New testcases.

From-SVN: r240458
parent 6465652c
2016-09-23 Fritz Reese <fritzoreese@gmail.com>
* lang.opt, invoke.texi, gfortran.texi: New flag -fdec-static.
* options.c (set_dec_flags): Set -fdec-static with -fdec.
* gfortran.h (symbol_attribute): New attribute automatic.
* gfortran.h (gfc_add_automatic): New prototype.
* match.h (gfc_match_automatic, gfc_match_static): New functions.
* decl.c (gfc_match_automatic, gfc_match_static): Ditto.
* symbol.c (gfc_add_automatic): Ditto.
* decl.c (match_attr_spec): Match AUTOMATIC and STATIC decls.
* parse.c (decode_specification_statement, decode_statement): Ditto.
* resolve.c (apply_default_init_local, resolve_fl_variable_derived,
resolve_symbol): Support for automatic attribute.
* symbol.c (check_conflict, gfc_copy_attr, gfc_is_var_automatic):
Ditto.
* trans-decl.c (gfc_finish_var_decl): Ditto.
2016-09-23 Jerry DeLisle <jvdelisle@gcc.gnu.org> 2016-09-23 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/48298 PR fortran/48298
......
...@@ -3811,6 +3811,7 @@ match_attr_spec (void) ...@@ -3811,6 +3811,7 @@ match_attr_spec (void)
DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL, DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL, DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE, DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
DECL_STATIC, DECL_AUTOMATIC,
DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE, DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS, DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS,
DECL_NONE, GFC_DECL_END /* Sentinel */ DECL_NONE, GFC_DECL_END /* Sentinel */
...@@ -3874,6 +3875,14 @@ match_attr_spec (void) ...@@ -3874,6 +3875,14 @@ match_attr_spec (void)
d = DECL_ASYNCHRONOUS; d = DECL_ASYNCHRONOUS;
} }
break; break;
case 'u':
if (match_string_p ("tomatic"))
{
/* Matched "automatic". */
d = DECL_AUTOMATIC;
}
break;
} }
break; break;
...@@ -4003,8 +4012,25 @@ match_attr_spec (void) ...@@ -4003,8 +4012,25 @@ match_attr_spec (void)
break; break;
case 's': case 's':
if (match_string_p ("save")) gfc_next_ascii_char ();
d = DECL_SAVE; switch (gfc_next_ascii_char ())
{
case 'a':
if (match_string_p ("ve"))
{
/* Matched "save". */
d = DECL_SAVE;
}
break;
case 't':
if (match_string_p ("atic"))
{
/* Matched "static". */
d = DECL_STATIC;
}
break;
}
break; break;
case 't': case 't':
...@@ -4141,6 +4167,12 @@ match_attr_spec (void) ...@@ -4141,6 +4167,12 @@ match_attr_spec (void)
case DECL_SAVE: case DECL_SAVE:
attr = "SAVE"; attr = "SAVE";
break; break;
case DECL_STATIC:
attr = "STATIC";
break;
case DECL_AUTOMATIC:
attr = "AUTOMATIC";
break;
case DECL_TARGET: case DECL_TARGET:
attr = "TARGET"; attr = "TARGET";
break; break;
...@@ -4169,6 +4201,18 @@ match_attr_spec (void) ...@@ -4169,6 +4201,18 @@ match_attr_spec (void)
if (seen[d] == 0) if (seen[d] == 0)
continue; continue;
if ((d == DECL_STATIC || d == DECL_AUTOMATIC)
&& !flag_dec_static)
{
gfc_error ("%s at %L is a DEC extension, enable with -fdec-static",
d == DECL_STATIC ? "STATIC" : "AUTOMATIC", &seen_at[d]);
m = MATCH_ERROR;
goto cleanup;
}
/* Allow SAVE with STATIC, but don't complain. */
if (d == DECL_STATIC && seen[DECL_SAVE])
continue;
if (gfc_current_state () == COMP_DERIVED if (gfc_current_state () == COMP_DERIVED
&& d != DECL_DIMENSION && d != DECL_CODIMENSION && d != DECL_DIMENSION && d != DECL_CODIMENSION
&& d != DECL_POINTER && d != DECL_PRIVATE && d != DECL_POINTER && d != DECL_PRIVATE
...@@ -4307,10 +4351,15 @@ match_attr_spec (void) ...@@ -4307,10 +4351,15 @@ match_attr_spec (void)
&seen_at[d]); &seen_at[d]);
break; break;
case DECL_STATIC:
case DECL_SAVE: case DECL_SAVE:
t = gfc_add_save (&current_attr, SAVE_EXPLICIT, NULL, &seen_at[d]); t = gfc_add_save (&current_attr, SAVE_EXPLICIT, NULL, &seen_at[d]);
break; break;
case DECL_AUTOMATIC:
t = gfc_add_automatic (&current_attr, NULL, &seen_at[d]);
break;
case DECL_TARGET: case DECL_TARGET:
t = gfc_add_target (&current_attr, &seen_at[d]); t = gfc_add_target (&current_attr, &seen_at[d]);
break; break;
...@@ -7785,6 +7834,114 @@ gfc_match_parameter (void) ...@@ -7785,6 +7834,114 @@ gfc_match_parameter (void)
} }
match
gfc_match_automatic (void)
{
gfc_symbol *sym;
match m;
bool seen_symbol = false;
if (!flag_dec_static)
{
gfc_error ("AUTOMATIC at %C is a DEC extension, enable with "
"-fdec-static");
return MATCH_ERROR;
}
gfc_match (" ::");
for (;;)
{
m = gfc_match_symbol (&sym, 0);
switch (m)
{
case MATCH_NO:
break;
case MATCH_ERROR:
return MATCH_ERROR;
case MATCH_YES:
if (!gfc_add_automatic (&sym->attr, sym->name, &gfc_current_locus))
return MATCH_ERROR;
seen_symbol = true;
break;
}
if (gfc_match_eos () == MATCH_YES)
break;
if (gfc_match_char (',') != MATCH_YES)
goto syntax;
}
if (!seen_symbol)
{
gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
return MATCH_ERROR;
}
return MATCH_YES;
syntax:
gfc_error ("Syntax error in AUTOMATIC statement at %C");
return MATCH_ERROR;
}
match
gfc_match_static (void)
{
gfc_symbol *sym;
match m;
bool seen_symbol = false;
if (!flag_dec_static)
{
gfc_error ("STATIC at %C is a DEC extension, enable with -fdec-static");
return MATCH_ERROR;
}
gfc_match (" ::");
for (;;)
{
m = gfc_match_symbol (&sym, 0);
switch (m)
{
case MATCH_NO:
break;
case MATCH_ERROR:
return MATCH_ERROR;
case MATCH_YES:
if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
&gfc_current_locus))
return MATCH_ERROR;
seen_symbol = true;
break;
}
if (gfc_match_eos () == MATCH_YES)
break;
if (gfc_match_char (',') != MATCH_YES)
goto syntax;
}
if (!seen_symbol)
{
gfc_error ("Expected entity-list in STATIC statement at %C");
return MATCH_ERROR;
}
return MATCH_YES;
syntax:
gfc_error ("Syntax error in STATIC statement at %C");
return MATCH_ERROR;
}
/* Save statements have a special syntax. */ /* Save statements have a special syntax. */
match match
......
...@@ -736,7 +736,7 @@ typedef struct ...@@ -736,7 +736,7 @@ typedef struct
optional:1, pointer:1, target:1, value:1, volatile_:1, temporary:1, optional:1, pointer:1, target:1, value:1, volatile_:1, temporary:1,
dummy:1, result:1, assign:1, threadprivate:1, not_always_present:1, dummy:1, result:1, assign:1, threadprivate:1, not_always_present:1,
implied_index:1, subref_array_pointer:1, proc_pointer:1, asynchronous:1, implied_index:1, subref_array_pointer:1, proc_pointer:1, asynchronous:1,
contiguous:1, fe_temp: 1; contiguous:1, fe_temp: 1, automatic: 1;
/* For CLASS containers, the pointer attribute is sometimes set internally /* For CLASS containers, the pointer attribute is sometimes set internally
even though it was not directly specified. In this case, keep the even though it was not directly specified. In this case, keep the
...@@ -2816,6 +2816,7 @@ bool gfc_add_cray_pointee (symbol_attribute *, locus *); ...@@ -2816,6 +2816,7 @@ bool gfc_add_cray_pointee (symbol_attribute *, locus *);
match gfc_mod_pointee_as (gfc_array_spec *); match gfc_mod_pointee_as (gfc_array_spec *);
bool gfc_add_protected (symbol_attribute *, const char *, locus *); bool gfc_add_protected (symbol_attribute *, const char *, locus *);
bool gfc_add_result (symbol_attribute *, const char *, locus *); bool gfc_add_result (symbol_attribute *, const char *, locus *);
bool gfc_add_automatic (symbol_attribute *, const char *, locus *);
bool gfc_add_save (symbol_attribute *, save_state, const char *, locus *); bool gfc_add_save (symbol_attribute *, save_state, const char *, locus *);
bool gfc_add_threadprivate (symbol_attribute *, const char *, locus *); bool gfc_add_threadprivate (symbol_attribute *, const char *, locus *);
bool gfc_add_omp_declare_target (symbol_attribute *, const char *, locus *); bool gfc_add_omp_declare_target (symbol_attribute *, const char *, locus *);
......
...@@ -1462,6 +1462,7 @@ without warning. ...@@ -1462,6 +1462,7 @@ without warning.
* STRUCTURE and RECORD:: * STRUCTURE and RECORD::
* UNION and MAP:: * UNION and MAP::
* Type variants for integer intrinsics:: * Type variants for integer intrinsics::
* AUTOMATIC and STATIC attributes::
@end menu @end menu
@node Old-style kind specifications @node Old-style kind specifications
...@@ -2421,6 +2422,56 @@ here: ...@@ -2421,6 +2422,56 @@ here:
@tab @code{--} @tab @code{FLOATI} @tab @code{FLOATJ} @tab @code{FLOATK} @tab @code{--} @tab @code{FLOATI} @tab @code{FLOATJ} @tab @code{FLOATK}
@end multitable @end multitable
@node AUTOMATIC and STATIC attributes
@subsection @code{AUTOMATIC} and @code{STATIC} attributes
@cindex variable attributes
@cindex @code{AUTOMATIC}
@cindex @code{STATIC}
With @option{-fdec-static} GNU Fortran supports the DEC extended attributes
@code{STATIC} and @code{AUTOMATIC} to provide explicit specification of entity
storage. These follow the syntax of the Fortran standard @code{SAVE} attribute.
@code{STATIC} is exactly equivalent to @code{SAVE}, and specifies that
an entity should be allocated in static memory. As an example, @code{STATIC}
local variables will retain their values across multiple calls to a function.
Entities marked @code{AUTOMATIC} will be stack automatic whenever possible.
@code{AUTOMATIC} is the default for local variables smaller than
@option{-fmax-stack-var-size}, unless @option{-fno-automatic} is given. This
attribute overrides @option{-fno-automatic}, @option{-fmax-stack-var-size}, and
blanket @code{SAVE} statements.
Examples:
@example
subroutine f
integer, automatic :: i ! automatic variable
integer x, y ! static variables
save
...
endsubroutine
@end example
@example
subroutine f
integer a, b, c, x, y, z
static :: x
save y
automatic z, c
! a, b, c, and z are automatic
! x and y are static
endsubroutine
@end example
@example
! Compiled with -fno-automatic
subroutine f
integer a, b, c, d
automatic :: a
! a is automatic; b, c, and d are static
endsubroutine
@end example
@node Extensions not implemented in GNU Fortran @node Extensions not implemented in GNU Fortran
@section Extensions not implemented in GNU Fortran @section Extensions not implemented in GNU Fortran
...@@ -2444,7 +2495,6 @@ code that uses them running with the GNU Fortran compiler. ...@@ -2444,7 +2495,6 @@ code that uses them running with the GNU Fortran compiler.
* ENCODE and DECODE statements:: * ENCODE and DECODE statements::
* Variable FORMAT expressions:: * Variable FORMAT expressions::
@c * Q edit descriptor:: @c * Q edit descriptor::
@c * AUTOMATIC statement::
@c * TYPE and ACCEPT I/O Statements:: @c * TYPE and ACCEPT I/O Statements::
@c * .XOR. operator:: @c * .XOR. operator::
@c * CARRIAGECONTROL, DEFAULTFILE, DISPOSE and RECORDTYPE I/O specifiers:: @c * CARRIAGECONTROL, DEFAULTFILE, DISPOSE and RECORDTYPE I/O specifiers::
......
...@@ -116,7 +116,7 @@ by type. Explanations are in the following sections. ...@@ -116,7 +116,7 @@ by type. Explanations are in the following sections.
@xref{Fortran Dialect Options,,Options controlling Fortran dialect}. @xref{Fortran Dialect Options,,Options controlling Fortran dialect}.
@gccoptlist{-fall-intrinsics -fbackslash -fcray-pointer -fd-lines-as-code @gol @gccoptlist{-fall-intrinsics -fbackslash -fcray-pointer -fd-lines-as-code @gol
-fd-lines-as-comments @gol -fd-lines-as-comments @gol
-fdec -fdec-structure -fdec-intrinsic-ints @gol -fdec -fdec-structure -fdec-intrinsic-ints -fdec-static @gol
-fdefault-double-8 -fdefault-integer-8 @gol -fdefault-double-8 -fdefault-integer-8 @gol
-fdefault-real-8 -fdollar-ok -ffixed-line-length-@var{n} @gol -fdefault-real-8 -fdollar-ok -ffixed-line-length-@var{n} @gol
-ffixed-line-length-none -ffree-form -ffree-line-length-@var{n} @gol -ffixed-line-length-none -ffree-form -ffree-line-length-@var{n} @gol
...@@ -241,7 +241,7 @@ full documentation. ...@@ -241,7 +241,7 @@ full documentation.
Other flags enabled by this switch are: Other flags enabled by this switch are:
@option{-fdollar-ok} @option{-fcray-pointer} @option{-fdec-structure} @option{-fdollar-ok} @option{-fcray-pointer} @option{-fdec-structure}
@option{-fdec-intrinsic-ints} @option{-fdec-intrinsic-ints} @option{-fdec-static}
@item -fdec-structure @item -fdec-structure
@opindex @code{fdec-structure} @opindex @code{fdec-structure}
...@@ -255,6 +255,11 @@ instead where possible. ...@@ -255,6 +255,11 @@ instead where possible.
Enable B/I/J/K kind variants of existing integer functions (e.g. BIAND, IIAND, Enable B/I/J/K kind variants of existing integer functions (e.g. BIAND, IIAND,
JIAND, etc...). For a complete list of intrinsics see the full documentation. JIAND, etc...). For a complete list of intrinsics see the full documentation.
@item -fdec-static
@opindex @code{fdec-static}
Enable DEC-style STATIC and AUTOMATIC attributes to explicitly specify
the storage of variables and other objects.
@item -fdollar-ok @item -fdollar-ok
@opindex @code{fdollar-ok} @opindex @code{fdollar-ok}
@cindex @code{$} @cindex @code{$}
......
...@@ -432,6 +432,10 @@ fdec-structure ...@@ -432,6 +432,10 @@ fdec-structure
Fortran Fortran
Enable support for DEC STRUCTURE/RECORD. Enable support for DEC STRUCTURE/RECORD.
fdec-static
Fortran Var(flag_dec_static)
Enable DEC-style STATIC and AUTOMATIC attributes.
fdefault-double-8 fdefault-double-8
Fortran Var(flag_default_double) Fortran Var(flag_default_double)
Set the default double precision kind to an 8 byte wide type. Set the default double precision kind to an 8 byte wide type.
......
...@@ -223,6 +223,7 @@ void gfc_set_constant_character_len (int, gfc_expr *, int); ...@@ -223,6 +223,7 @@ void gfc_set_constant_character_len (int, gfc_expr *, int);
/* Matchers for attribute declarations. */ /* Matchers for attribute declarations. */
match gfc_match_allocatable (void); match gfc_match_allocatable (void);
match gfc_match_asynchronous (void); match gfc_match_asynchronous (void);
match gfc_match_automatic (void);
match gfc_match_codimension (void); match gfc_match_codimension (void);
match gfc_match_contiguous (void); match gfc_match_contiguous (void);
match gfc_match_dimension (void); match gfc_match_dimension (void);
...@@ -238,6 +239,7 @@ match gfc_match_protected (void); ...@@ -238,6 +239,7 @@ match gfc_match_protected (void);
match gfc_match_private (gfc_statement *); match gfc_match_private (gfc_statement *);
match gfc_match_public (gfc_statement *); match gfc_match_public (gfc_statement *);
match gfc_match_save (void); match gfc_match_save (void);
match gfc_match_static (void);
match gfc_match_modproc (void); match gfc_match_modproc (void);
match gfc_match_target (void); match gfc_match_target (void);
match gfc_match_value (void); match gfc_match_value (void);
......
...@@ -54,6 +54,7 @@ set_dec_flags (int value) ...@@ -54,6 +54,7 @@ set_dec_flags (int value)
{ {
gfc_option.flag_dec_structure = value; gfc_option.flag_dec_structure = value;
flag_dec_intrinsic_ints = value; flag_dec_intrinsic_ints = value;
flag_dec_static = value;
} }
......
...@@ -191,6 +191,7 @@ decode_specification_statement (void) ...@@ -191,6 +191,7 @@ decode_specification_statement (void)
ST_INTERFACE); ST_INTERFACE);
match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL); match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL); match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL);
match ("automatic", gfc_match_automatic, ST_ATTR_DECL);
break; break;
case 'b': case 'b':
...@@ -256,6 +257,7 @@ decode_specification_statement (void) ...@@ -256,6 +257,7 @@ decode_specification_statement (void)
case 's': case 's':
match ("save", gfc_match_save, ST_ATTR_DECL); match ("save", gfc_match_save, ST_ATTR_DECL);
match ("static", gfc_match_static, ST_ATTR_DECL);
match ("structure", gfc_match_structure_decl, ST_STRUCTURE_DECL); match ("structure", gfc_match_structure_decl, ST_STRUCTURE_DECL);
break; break;
...@@ -436,6 +438,7 @@ decode_statement (void) ...@@ -436,6 +438,7 @@ decode_statement (void)
match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL); match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT); match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT);
match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL); match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL);
match ("automatic", gfc_match_automatic, ST_ATTR_DECL);
break; break;
case 'b': case 'b':
...@@ -548,6 +551,7 @@ decode_statement (void) ...@@ -548,6 +551,7 @@ decode_statement (void)
match ("sequence", gfc_match_eos, ST_SEQUENCE); match ("sequence", gfc_match_eos, ST_SEQUENCE);
match ("stop", gfc_match_stop, ST_STOP); match ("stop", gfc_match_stop, ST_STOP);
match ("save", gfc_match_save, ST_ATTR_DECL); match ("save", gfc_match_save, ST_ATTR_DECL);
match ("static", gfc_match_static, ST_ATTR_DECL);
match ("submodule", gfc_match_submodule, ST_SUBMODULE); match ("submodule", gfc_match_submodule, ST_SUBMODULE);
match ("sync all", gfc_match_sync_all, ST_SYNC_ALL); match ("sync all", gfc_match_sync_all, ST_SYNC_ALL);
match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES); match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES);
......
...@@ -11348,10 +11348,11 @@ apply_default_init_local (gfc_symbol *sym) ...@@ -11348,10 +11348,11 @@ apply_default_init_local (gfc_symbol *sym)
entry, so we just add a static initializer. Note that automatic variables entry, so we just add a static initializer. Note that automatic variables
are stack allocated even with -fno-automatic; we have also to exclude are stack allocated even with -fno-automatic; we have also to exclude
result variable, which are also nonstatic. */ result variable, which are also nonstatic. */
if (sym->attr.save || sym->ns->save_all if (!sym->attr.automatic
|| (flag_max_stack_var_size == 0 && !sym->attr.result && (sym->attr.save || sym->ns->save_all
&& (sym->ns->proc_name && !sym->ns->proc_name->attr.recursive) || (flag_max_stack_var_size == 0 && !sym->attr.result
&& (!sym->attr.dimension || !is_non_constant_shape_array (sym)))) && (sym->ns->proc_name && !sym->ns->proc_name->attr.recursive)
&& (!sym->attr.dimension || !is_non_constant_shape_array (sym)))))
{ {
/* Don't clobber an existing initializer! */ /* Don't clobber an existing initializer! */
gcc_assert (sym->value == NULL); gcc_assert (sym->value == NULL);
...@@ -11496,7 +11497,7 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) ...@@ -11496,7 +11497,7 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
a hidden default for allocatable components. */ a hidden default for allocatable components. */
if (!(sym->value || no_init_flag) && sym->ns->proc_name if (!(sym->value || no_init_flag) && sym->ns->proc_name
&& sym->ns->proc_name->attr.flavor == FL_MODULE && sym->ns->proc_name->attr.flavor == FL_MODULE
&& !sym->ns->save_all && !sym->attr.save && !(sym->ns->save_all && !sym->attr.automatic) && !sym->attr.save
&& !sym->attr.pointer && !sym->attr.allocatable && !sym->attr.pointer && !sym->attr.allocatable
&& gfc_has_default_initializer (sym->ts.u.derived) && gfc_has_default_initializer (sym->ts.u.derived)
&& !gfc_notify_std (GFC_STD_F2008, "Implied SAVE for module variable " && !gfc_notify_std (GFC_STD_F2008, "Implied SAVE for module variable "
...@@ -14319,7 +14320,7 @@ resolve_symbol (gfc_symbol *sym) ...@@ -14319,7 +14320,7 @@ resolve_symbol (gfc_symbol *sym)
if (class_attr.codimension if (class_attr.codimension
&& !(class_attr.allocatable || sym->attr.dummy || sym->attr.save && !(class_attr.allocatable || sym->attr.dummy || sym->attr.save
|| sym->attr.select_type_temporary || sym->attr.select_type_temporary
|| sym->ns->save_all || (sym->ns->save_all && !sym->attr.automatic)
|| sym->ns->proc_name->attr.flavor == FL_MODULE || sym->ns->proc_name->attr.flavor == FL_MODULE
|| sym->ns->proc_name->attr.is_main_program || sym->ns->proc_name->attr.is_main_program
|| sym->attr.function || sym->attr.result || sym->attr.use_assoc)) || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
...@@ -14471,7 +14472,8 @@ resolve_symbol (gfc_symbol *sym) ...@@ -14471,7 +14472,8 @@ resolve_symbol (gfc_symbol *sym)
} }
/* Check threadprivate restrictions. */ /* Check threadprivate restrictions. */
if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all if (sym->attr.threadprivate && !sym->attr.save
&& !(sym->ns->save_all && !sym->attr.automatic)
&& (!sym->attr.in_common && (!sym->attr.in_common
&& sym->module == NULL && sym->module == NULL
&& (sym->ns->proc_name == NULL && (sym->ns->proc_name == NULL
...@@ -14482,7 +14484,7 @@ resolve_symbol (gfc_symbol *sym) ...@@ -14482,7 +14484,7 @@ resolve_symbol (gfc_symbol *sym)
if (sym->attr.omp_declare_target if (sym->attr.omp_declare_target
&& sym->attr.flavor == FL_VARIABLE && sym->attr.flavor == FL_VARIABLE
&& !sym->attr.save && !sym->attr.save
&& !sym->ns->save_all && !(sym->ns->save_all && !sym->attr.automatic)
&& (!sym->attr.in_common && (!sym->attr.in_common
&& sym->module == NULL && sym->module == NULL
&& (sym->ns->proc_name == NULL && (sym->ns->proc_name == NULL
......
...@@ -382,7 +382,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) ...@@ -382,7 +382,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
*is_bind_c = "BIND(C)", *procedure = "PROCEDURE", *is_bind_c = "BIND(C)", *procedure = "PROCEDURE",
*proc_pointer = "PROCEDURE POINTER", *abstract = "ABSTRACT", *proc_pointer = "PROCEDURE POINTER", *abstract = "ABSTRACT",
*asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION", *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION",
*contiguous = "CONTIGUOUS", *generic = "GENERIC"; *contiguous = "CONTIGUOUS", *generic = "GENERIC", *automatic = "AUTOMATIC";
static const char *threadprivate = "THREADPRIVATE"; static const char *threadprivate = "THREADPRIVATE";
static const char *omp_declare_target = "OMP DECLARE TARGET"; static const char *omp_declare_target = "OMP DECLARE TARGET";
static const char *oacc_declare_copyin = "OACC DECLARE COPYIN"; static const char *oacc_declare_copyin = "OACC DECLARE COPYIN";
...@@ -447,6 +447,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) ...@@ -447,6 +447,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
conf (dummy, save); conf (dummy, save);
conf (in_common, save); conf (in_common, save);
conf (result, save); conf (result, save);
conf (automatic, save);
switch (attr->flavor) switch (attr->flavor)
{ {
...@@ -488,6 +489,12 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) ...@@ -488,6 +489,12 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
conf (pointer, codimension); conf (pointer, codimension);
conf (allocatable, elemental); conf (allocatable, elemental);
conf (in_common, automatic);
conf (in_equivalence, automatic);
conf (result, automatic);
conf (use_assoc, automatic);
conf (dummy, automatic);
conf (target, external); conf (target, external);
conf (target, intrinsic); conf (target, intrinsic);
...@@ -942,6 +949,21 @@ gfc_add_allocatable (symbol_attribute *attr, locus *where) ...@@ -942,6 +949,21 @@ gfc_add_allocatable (symbol_attribute *attr, locus *where)
bool bool
gfc_add_automatic (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, name, where))
return false;
if (attr->automatic && !gfc_notify_std (GFC_STD_LEGACY,
"Duplicate AUTOMATIC attribute specified at %L", where))
return false;
attr->automatic = 1;
return check_conflict (attr, name, where);
}
bool
gfc_add_codimension (symbol_attribute *attr, const char *name, locus *where) gfc_add_codimension (symbol_attribute *attr, const char *name, locus *where)
{ {
...@@ -1889,6 +1911,8 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where) ...@@ -1889,6 +1911,8 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
if (src->allocatable && !gfc_add_allocatable (dest, where)) if (src->allocatable && !gfc_add_allocatable (dest, where))
goto fail; goto fail;
if (src->automatic && !gfc_add_automatic (dest, NULL, where))
goto fail;
if (src->dimension && !gfc_add_dimension (dest, NULL, where)) if (src->dimension && !gfc_add_dimension (dest, NULL, where))
goto fail; goto fail;
if (src->codimension && !gfc_add_codimension (dest, NULL, where)) if (src->codimension && !gfc_add_codimension (dest, NULL, where))
...@@ -4000,6 +4024,10 @@ gfc_is_var_automatic (gfc_symbol *sym) ...@@ -4000,6 +4024,10 @@ gfc_is_var_automatic (gfc_symbol *sym)
&& sym->ts.u.cl && sym->ts.u.cl
&& !gfc_is_constant_expr (sym->ts.u.cl->length)) && !gfc_is_constant_expr (sym->ts.u.cl->length))
return true; return true;
/* Variables with explicit AUTOMATIC attribute. */
if (sym->attr.automatic)
return true;
return false; return false;
} }
......
...@@ -660,7 +660,7 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym) ...@@ -660,7 +660,7 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
} }
/* Keep variables larger than max-stack-var-size off stack. */ /* Keep variables larger than max-stack-var-size off stack. */
if (!sym->ns->proc_name->attr.recursive if (!sym->ns->proc_name->attr.recursive && !sym->attr.automatic
&& INTEGER_CST_P (DECL_SIZE_UNIT (decl)) && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
&& !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)) && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
/* Put variable length auto array pointers always into stack. */ /* Put variable length auto array pointers always into stack. */
......
2016-09-23 Fritz Reese <fritzoreese@gmail.com>
* gfortran.dg/dec_static_1.f90: New.
* gfortran.dg/dec_static_2.f90: New.
* gfortran.dg/dec_static_3.f90: New.
* gfortran.dg/dec_static_4.f90: New.
2016-09-23 Jerry DeLisle <jvdelisle@gcc.gnu.org> 2016-09-23 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/48298 PR fortran/48298
......
! { dg-do run }
! { dg-options "-fdec-static -finit-local-zero" }
!
! Test AUTOMATIC and STATIC attributes.
!
subroutine assert(s, i1, i2)
implicit none
integer, intent(in) :: i1, i2
character(*), intent(in) :: s
if (i1 .ne. i2) then
print *, s, ": expected ", i2, " but was ", i1
call abort
endif
endsubroutine assert
function f (x, y)
implicit none
integer f
integer, intent(in) :: x, y
integer :: a ! only a can actually be saved
integer, automatic :: c ! should actually be automatic
save
! a should be incremented by x every time and saved
a = a + x
f = a
! c should be zeroed every time, therefore equal y
c = c + y
call assert ("f%c", c, y)
return
endfunction
implicit none
integer :: f
! Should return static value of a; accumulates x
call assert ("f()", f(1,3), 1)
call assert ("f()", f(1,4), 2)
call assert ("f()", f(1,2), 3)
end
! { dg-do run }
! { dg-options "-fdec-static -fno-automatic -finit-local-zero" }
!
! Test STATIC and AUTOMATIC with -fno-automatic and recursive subroutines.
!
subroutine assert(s, i1, i2)
implicit none
integer, intent(in) :: i1, i2
character(*), intent(in) :: s
if (i1 .ne. i2) then
print *, s, ": expected ", i2, " but was ", i1
call abort
endif
endsubroutine
function f (x)
implicit none
integer f
integer, intent(in) :: x
integer, static :: a ! should be SAVEd
a = a + x ! should increment by x every time
f = a
return
endfunction
recursive subroutine g (x)
implicit none
integer, intent(in) :: x
integer, automatic :: a ! should be automatic (in recursive)
a = a + x ! should be set to x every time
call assert ("g%a", a, x)
endsubroutine
subroutine h (x)
implicit none
integer, intent(in) :: x
integer, automatic :: a ! should be automatic (outside recursive)
a = a + x ! should be set to x every time
call assert ("h%a", a, x)
endsubroutine
implicit none
integer :: f
! Should return static value of c; accumulates x
call assert ("f()", f(3), 3)
call assert ("f()", f(4), 7)
call assert ("f()", f(2), 9)
call g(3)
call g(4)
call g(2)
call h(3)
call h(4)
call h(2)
end
! { dg-do compile }
! { dg-options "" }
!
! Check errors for use of STATIC/AUTOMATIC without -fdec-static.
!
subroutine s()
implicit none
integer, automatic :: a ! { dg-error "is a DEC extension" }
integer, static :: b ! { dg-error "is a DEC extension" }
integer, save :: c
integer :: auto1, auto2, static1, static2, save1, save2
automatic auto1 ! { dg-error "is a DEC extension" }
automatic :: auto2 ! { dg-error "is a DEC extension" }
static static1 ! { dg-error "is a DEC extension" }
static :: static2 ! { dg-error "is a DEC extension" }
save save1
save :: save2
end subroutine
! { dg-do compile }
! { dg-options "-fdec-static" }
!
! Check for conflicts between STATIC/AUTOMATIC and other attributes.
!
function s(a, b, x, y) result(z)
implicit none
integer, automatic, intent(IN) :: a ! { dg-error "DUMMY attribute conflicts" }
integer, static, intent(IN) :: b ! { dg-error "DUMMY attribute conflicts" }
integer, intent(OUT) :: x, y
automatic :: x ! { dg-error "DUMMY attribute conflicts" }
static :: y ! { dg-error "DUMMY attribute conflicts" }
automatic ! { dg-error "Expected entity-list in AUTOMATIC statement" }
automatic :: ! { dg-error "Expected entity-list in AUTOMATIC statement" }
static ! { dg-error "Expected entity-list in STATIC statement" }
static :: ! { dg-error "Expected entity-list in STATIC statement" }
integer, automatic :: auto1, auto2
integer, static :: static1, static2
integer :: auto3, static3
automatic :: auto3
static :: static3
common /c1/ auto1, auto2 ! { dg-error "COMMON attribute conflicts" }
common /c2/ static1, static2 ! { dg-error "COMMON attribute conflicts" }
common /c3/ auto3, static3 ! { dg-error "COMMON attribute conflicts" }
integer, static :: z ! { dg-error "RESULT attribute conflicts" }
integer, automatic :: z ! { dg-error "RESULT attribute conflicts" }
static :: z ! { dg-error "RESULT attribute conflicts" }
automatic :: z ! { dg-error "RESULT attribute conflicts" }
integer, static, automatic :: o ! { dg-error "AUTOMATIC attribute conflicts" }
integer :: a, b, z ! fall-back decls so we don't get "no implicit type"
end
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment