https://gcc.gnu.org/bugzilla/show_bug.cgi?id=101632
--- Comment #3 from Steve Kargl <sgk at troutmask dot apl.washington.edu> --- On Mon, Jul 26, 2021 at 07:15:53PM +0000, kargl at gcc dot gnu.org wrote: > https://gcc.gnu.org/bugzilla/show_bug.cgi?id=101632 > > --- Comment #2 from kargl at gcc dot gnu.org --- > Created attachment 51207 > --> https://gcc.gnu.org/bugzilla/attachment.cgi?id=51207&action=edit > Diff that implements F2018 NON_RECURSIVE and makes things recursive by > default. > Better patch. diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 413c7a75e0c..35ab2655a3b 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -6353,6 +6353,17 @@ gfc_match_prefix (gfc_typespec *ts) found_prefix = true; } + if (gfc_match ("non_recursive% ") == MATCH_YES) + { + if (!gfc_notify_std (GFC_STD_F2018, "NON_RECURSIVE procedure at %C")) + goto error; + + if (!gfc_add_non_recursive (¤t_attr, NULL)) + goto error; + + found_prefix = true; + } + /* IMPURE is a somewhat special case, as it needs not set an actual attribute but rather only prevents ELEMENTAL routines from being automatically PURE. */ @@ -6381,6 +6392,15 @@ gfc_match_prefix (gfc_typespec *ts) goto error; } + /* If neither NON_RECURSIVE nor RECURSIVE has been seen and the F2018 + standard is in play, then mark the the procedure as recursive. */ + if ((gfc_option.allow_std & GFC_STD_F2018) + && !current_attr.non_recursive && !current_attr.recursive) + { + if (!gfc_add_recursive (¤t_attr, NULL)) + goto error; + } + /* At this point, the next item is not a prefix. */ gcc_assert (gfc_matching_prefix); @@ -6447,6 +6467,9 @@ copy_prefix (symbol_attribute *dest, locus *where) if (current_attr.recursive && !gfc_add_recursive (dest, where)) return false; + if (current_attr.non_recursive && !gfc_add_non_recursive (dest, where)) + return false; + return true; } diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index f4a50d74f14..72ed9c6ee3d 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -842,7 +842,7 @@ typedef struct unsigned is_iso_c:1; /* Symbol is from iso_c_binding. */ /* Function/subroutine attributes */ - unsigned sequence:1, elemental:1, pure:1, recursive:1; + unsigned sequence:1, elemental:1, pure:1, recursive:1, non_recursive:1; unsigned unmaskable:1, masked:1, contained:1, mod_proc:1, abstract:1; /* Set if this is a module function or subroutine. Note that it is an @@ -3223,6 +3223,7 @@ bool gfc_add_sequence (symbol_attribute *, const char *, locus *); bool gfc_add_elemental (symbol_attribute *, locus *); bool gfc_add_pure (symbol_attribute *, locus *); bool gfc_add_recursive (symbol_attribute *, locus *); +bool gfc_add_non_recursive (symbol_attribute *, locus *); bool gfc_add_function (symbol_attribute *, const char *, locus *); bool gfc_add_subroutine (symbol_attribute *, const char *, locus *); bool gfc_add_volatile (symbol_attribute *, const char *, locus *); diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 6d61bf4982b..f456a02847c 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -410,24 +410,24 @@ gfc_check_function_type (gfc_namespace *ns) bool gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) { - static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER", - *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT", - *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC", - *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)", - *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL", - *privat = "PRIVATE", *recursive = "RECURSIVE", - *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST", - *publik = "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", *value = "VALUE", - *volatile_ = "VOLATILE", *is_protected = "PROTECTED", - *is_bind_c = "BIND(C)", *procedure = "PROCEDURE", - *proc_pointer = "PROCEDURE POINTER", *abstract = "ABSTRACT", - *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION", - *contiguous = "CONTIGUOUS", *generic = "GENERIC", *automatic = "AUTOMATIC", - *pdt_len = "LEN", *pdt_kind = "KIND"; + static const char *abstract = "ABSTRACT", *allocatable = "ALLOCATABLE", + *asynchronous = "ASYNCHRONOUS", *automatic = "AUTOMATIC", + *codimension = "CODIMENSION", *contiguous = "CONTIGUOUS", + *cray_pointee = "CRAYPOINTEE", *cray_pointer = "CRAYPOINTER", + *data = "DATA", *dimension = "DIMENSION", *dummy = "DUMMY", + *elemental = "ELEMENTAL", *entry = "ENTRY", *external = "EXTERNAL", + *function = "FUNCTION", *generic = "GENERIC", *in_common = "COMMON", + *in_equivalence = "EQUIVALENCE", *in_namelist = "NAMELIST", + *intent = "INTENT", *intent_in = "INTENT(IN)", + *intent_inout = "INTENT(INOUT)", *intent_out = "INTENT(OUT)", + *intrinsic = "INTRINSIC", *is_bind_c = "BIND(C)", + *is_protected = "PROTECTED", *non_recursive = "NON_RECURSIVE", + *optional = "OPTIONAL", *pdt_kind = "KIND", *pdt_len="LEN", + *pointer="POINTER", *privat="PRIVATE", *proc_pointer="PROCEDUREPOINTER", + *procedure="PROCEDURE", *publik="PUBLIC", *recursive="RECURSIVE", + *result="RESULT", *save="SAVE", *subroutine="SUBROUTINE", + *target="TARGET", *use_assoc="USEASSOCIATED", *value="VALUE", + *volatile_="VOLATILE"; static const char *threadprivate = "THREADPRIVATE"; static const char *omp_declare_target = "OMP DECLARE TARGET"; static const char *omp_declare_target_link = "OMP DECLARE TARGET LINK"; @@ -570,6 +570,7 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf_std (allocatable, function, GFC_STD_F2003); conf_std (allocatable, result, GFC_STD_F2003); conf_std (elemental, recursive, GFC_STD_F2018); + conf (non_recursive, recursive); conf (in_common, dummy); conf (in_common, allocatable); @@ -1650,6 +1651,24 @@ gfc_add_recursive (symbol_attribute *attr, locus *where) } +bool +gfc_add_non_recursive (symbol_attribute *attr, locus *where) +{ + + if (check_used (attr, NULL, where)) + return false; + + if (attr->non_recursive) + { + duplicate_attr ("NON_RECURSIVE", where); + return false; + } + + attr->non_recursive = 1; + return gfc_check_conflict (attr, NULL, where); +} + + bool gfc_add_entry (symbol_attribute *attr, const char *name, locus *where) { @@ -2148,6 +2167,8 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where) goto fail; if (src->recursive && !gfc_add_recursive (dest, where)) goto fail; + if (src->non_recursive && !gfc_add_non_recursive (dest, where)) + goto fail; if (src->flavor != FL_UNKNOWN && !gfc_add_flavor (dest, src->flavor, NULL, where))
