[Patch, fortran] PR108663 - Accepts invalid bug with pdtXXX
Paul Richard Thomas <[email protected]>
| Newsgroups | gmane.comp.gcc.patches,gmane.comp.gcc.fortran |
|---|---|
| Message-ID | <CAGkQGiLjDrL6Gvwvbk4K5Z1Rq3jz8Xto0u8EcECdG7ifj=Phtw@mail.gmail.com> |
Hello All, This bug allowed direct references by name to PDT instances. It took me a long time to have the necessary light bulb moment: The names of PDT instances never have to go through the scanner and so are not subject to the ministrations of gfc_wide_tolower. Therefore, rendering all the letters of the PDT prefix in upper case prevents pdt_types from being directly referenced in code. I took the opportunity to define PDT_TEMPLATE and PDT_TEMPLATE_LEN in gfortran.h. The chunk in resolve.cc is a funny one. I had previously encountered the test for assumed LEN parameters in typebound procedure dummies (pdt_37.f03) failing due to apparently unrelated changes in the frontend. It seems that it is the order of appearance of pdt_templates and pdt_types that mattered. The problem is fixed by testing for both, as is necessary for this patch to pass regression testing. Regtests OK with FC43/x86_64. OK for mainline? I will be offline for a few weeks from Monday evening and so I will push the patch then if it hasn't been reviewed. In the words of Hitchhikers Guide to the Galaxy, it is "mostly harmless". Paul
Change.Logs
(application/octet-stream, 721 B) - not displayed
submit.diff
(text/x-patch, 7 KB)
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index 2908007d75c..cb6bd6f8cc0 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -3960,10 +3960,9 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
/* Pointers to the parameter specification being used. */
gfc_actual_arglist *actual_param;
gfc_actual_arglist *tail = NULL;
- /* Used to build up the name of the PDT instance. The prefix uses 4
+ /* Used to build up the name of the PDT instance. The prefix uses 3
characters and each KIND parameter 2 more. Allow 8 of the latter. */
- char name[GFC_MAX_SYMBOL_LEN + 21];
-
+ char name[GFC_MAX_SYMBOL_LEN + PDT_PREFIX_LEN + 16];
bool name_seen = (param_list == NULL);
bool assumed_seen = false;
bool deferred_seen = false;
@@ -3980,7 +3979,7 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
type_param_name_list = pdt->formal;
actual_param = param_list;
- sprintf (name, "Pdt%s", pdt->name);
+ sprintf (name, "%s%s", PDT_PREFIX, pdt->name);
/* Prevent a PDT component of the same type as the template from being
converted into an instance. Doing this results in the component being
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 109bf6a5c29..c9242a3adcc 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -4310,6 +4310,8 @@ bool gfc_may_be_finalized (gfc_typespec);
(expr && expr->expr_type == EXPR_VARIABLE \
&& expr->symtree->n.sym->assoc \
&& expr->symtree->n.sym->assoc->inferred_type)
+#define PDT_PREFIX "PDT"
+#define PDT_PREFIX_LEN 3
#define IS_PDT(sym) \
(sym != NULL && sym->ts.type == BT_DERIVED \
&& sym->ts.u.derived \
diff --git a/gcc/fortran/module.cc b/gcc/fortran/module.cc
index 47b1c943132..04ddf6b4476 100644
--- a/gcc/fortran/module.cc
+++ b/gcc/fortran/module.cc
@@ -5843,13 +5843,14 @@ read_module (void)
/* Include pdt_types if their associated pdt_template is in a
USE, ONLY list. */
if (p == NULL && name[0] == 'P'
- && startswith (name, "Pdt")
+ && startswith (name, PDT_PREFIX)
&& module_list)
{
gfc_use_list *ml = module_list;
for (; ml; ml = ml->next)
if (ml->rename
- && !strncmp (&name[3], ml->rename->use_name,
+ && !strncmp (&name[PDT_PREFIX_LEN],
+ ml->rename->use_name,
strlen (ml->rename->use_name)))
p = name;
}
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index e5b36234d7e..7d19c946b6d 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -16684,9 +16684,10 @@ resolve_typebound_procedure (gfc_symtree* stree)
goto error;
}
- if (resolve_bindings_derived->attr.pdt_template
- && gfc_pdt_is_instance_of (resolve_bindings_derived,
- CLASS_DATA (me_arg)->ts.u.derived)
+ if (((resolve_bindings_derived->attr.pdt_template
+ && gfc_pdt_is_instance_of (resolve_bindings_derived,
+ CLASS_DATA (me_arg)->ts.u.derived))
+ || resolve_bindings_derived->attr.pdt_type)
&& (me_arg->param_list != NULL)
&& (gfc_spec_list_type (me_arg->param_list,
CLASS_DATA(me_arg)->ts.u.derived)
diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc
index d521bf1012b..5a68f44ca63 100644
--- a/gcc/fortran/symbol.cc
+++ b/gcc/fortran/symbol.cc
@@ -5467,14 +5467,14 @@ gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2)
gfc_symbol *t2 -> pdt instance to be verified.
In decl.cc, gfc_get_pdt_instance, a pdt instance is given a 3 character
- prefix "Pdt", followed by an underscore list of the kind parameters,
+ prefix PDT_PREFIX, followed by an underscore list of the kind parameters,
up to a maximum of 8 kind parameters. To verify if a PDT Type corresponds
to the template, this functions extracts t2's derive_type name,
and compares it to the derive_type name of t1 for compatibility.
For example:
- t2->name = Pdtf_2_2; extract out the 'f' and compare with t1->name. */
+ t2->name = PDT_PREFIXf_2_2; extract the 'f' and compare with t1->name. */
bool
gfc_pdt_is_instance_of (gfc_symbol *t1, gfc_symbol *t2)
@@ -5483,7 +5483,8 @@ gfc_pdt_is_instance_of (gfc_symbol *t1, gfc_symbol *t2)
return false;
/* Limit comparison to length of t1->name to ignore new kind params. */
- if ( !(strncmp (&(t2->name[3]), t1->name, strlen (t1->name)) == 0) )
+ if ( !(strncmp (&(t2->name[PDT_PREFIX_LEN]), t1->name,
+ strlen (t1->name)) == 0) )
return false;
return true;
diff --git a/gcc/testsuite/gfortran.dg/pdt_15.f03 b/gcc/testsuite/gfortran.dg/pdt_15.f03
index 17d4d37d3fa..f7ee691cfce 100644
--- a/gcc/testsuite/gfortran.dg/pdt_15.f03
+++ b/gcc/testsuite/gfortran.dg/pdt_15.f03
@@ -101,6 +101,6 @@ contains
if (int (pop_8 (root)) .ne. 0) STOP 4
end subroutine
end program ch2701
-! { dg-final { scan-tree-dump-times "Pdtlink_8._deallocate " 5 "original" } }
+! { dg-final { scan-tree-dump-times "PDTlink_8._deallocate " 5 "original" } }
! { dg-final { scan-tree-dump-times ".n.data = 0B" 9 "original" } }
! { dg-final { scan-tree-dump-times "__builtin_free" 15 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/pdt_71.f03 b/gcc/testsuite/gfortran.dg/pdt_71.f03
index ec9cde06731..06deed6ae15 100644
--- a/gcc/testsuite/gfortran.dg/pdt_71.f03
+++ b/gcc/testsuite/gfortran.dg/pdt_71.f03
@@ -40,5 +40,5 @@ contains
print *, kind (z%x%n), z%x%n
end subroutine
end
-! { dg-final { scan-tree-dump-times "Pdtt2_4.1.x.n = 8" 1 "original" } }
-! { dg-final { scan-tree-dump-times "z = Pdtt2_4.1" 1 "original" } }
+! { dg-final { scan-tree-dump-times "PDTt2_4.1.x.n = 8" 1 "original" } }
+! { dg-final { scan-tree-dump-times "z = PDTt2_4.1" 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/pdt_79.f03 b/gcc/testsuite/gfortran.dg/pdt_79.f03
index 16b40fe6576..68c1810918b 100644
--- a/gcc/testsuite/gfortran.dg/pdt_79.f03
+++ b/gcc/testsuite/gfortran.dg/pdt_79.f03
@@ -57,5 +57,5 @@ contains
end subroutine ! { dg-warning ".mapped_tensor. is used uninitialized" }
end
-! { dg-final { scan-tree-dump-times "Pdttensor_t_4.2.j = 42" 1 "original" } }
-! { dg-final { scan-tree-dump-times "struct Pdttensor_t_4 mt" 1 "original" } }
+! { dg-final { scan-tree-dump-times "PDTtensor_t_4.2.j = 42" 1 "original" } }
+! { dg-final { scan-tree-dump-times "struct PDTtensor_t_4 mt" 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/pdt_84.f03 b/gcc/testsuite/gfortran.dg/pdt_84.f03
new file mode 100644
index 00000000000..a473cb8137d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_84.f03
@@ -0,0 +1,28 @@
+! { dg-do compile }
+!
+! Test the fix for PR108663
+!
+! Contributed by
+!
+module m
+ type t(n)
+ integer, len :: n
+ integer :: a(n)
+ end type
+contains
+ subroutine s(x, arr)
+ type(t(2)) :: x
+ integer :: arr(2)
+ if (any (x%a /= arr)) stop 1
+ end
+end
+program p
+ use m, only: t, pdtt, s ! { dg-error "not found in module" }
+
+ type(t(2)) :: y = t(2)([1,2])
+ type (pdtt) :: z ! { dg-error "being used before it is defined" }
+
+ call s(y, [1,2])
+ y = t(2)([3,4])
+ call s(y, [3,4])
+end