public inbox for gcc-bugs@sourceware.org
help / color / mirror / Atom feed
From: "sgk at troutmask dot apl.washington.edu" <gcc-bugzilla@gcc.gnu.org>
To: gcc-bugs@gcc.gnu.org
Subject: [Bug fortran/101632] NON_RECURSIVE procedure prefix is unsupported.  F2018 defaults to recursive procedures.
Date: Wed, 28 Jul 2021 05:08:08 +0000	[thread overview]
Message-ID: <bug-101632-4-gOIaA9LuDv@http.gcc.gnu.org/bugzilla/> (raw)
In-Reply-To: <bug-101632-4@http.gcc.gnu.org/bugzilla/>

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 (&current_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 (&current_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))

  parent reply	other threads:[~2021-07-28  5:08 UTC|newest]

Thread overview: 9+ messages / expand[flat|nested]  mbox.gz  Atom feed  top
2021-07-26 19:11 [Bug fortran/101632] New: " kargl at gcc dot gnu.org
2021-07-26 19:14 ` [Bug fortran/101632] " kargl at gcc dot gnu.org
2021-07-26 19:15 ` kargl at gcc dot gnu.org
2021-07-28  5:08 ` sgk at troutmask dot apl.washington.edu [this message]
2021-08-03 14:37 ` jb at gcc dot gnu.org
2021-08-03 15:14 ` sgk at troutmask dot apl.washington.edu
2021-11-06 21:09 ` anlauf at gcc dot gnu.org
2021-12-06 20:47 ` anlauf at gcc dot gnu.org
2022-04-19 15:53 ` everythingfunctional at protonmail dot com

Reply instructions:

You may reply publicly to this message via plain-text email
using any one of the following methods:

* Save the following mbox file, import it into your mail client,
  and reply-to-all from there: mbox

  Avoid top-posting and favor interleaved quoting:
  https://en.wikipedia.org/wiki/Posting_style#Interleaved_style

* Reply using the --to, --cc, and --in-reply-to
  switches of git-send-email(1):

  git send-email \
    --in-reply-to=bug-101632-4-gOIaA9LuDv@http.gcc.gnu.org/bugzilla/ \
    --to=gcc-bugzilla@gcc.gnu.org \
    --cc=gcc-bugs@gcc.gnu.org \
    /path/to/YOUR_REPLY

  https://kernel.org/pub/software/scm/git/docs/git-send-email.html

* If your mail client supports setting the In-Reply-To header
  via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).