Hi folks,
This patch combines Tobias front-end patch with my libgfortran patch to resolve
this PR.
To denote extended derived types (classes) we use a '+' rather than '%' in
certain parts of the namelist name internally to identify that an extended type
is being dealt with. The runtime is modified to look for this '+' and when it
is seen, scan ahead for the varname match.
For inherited types, a match could be found in two different ways.
parent%cousin%child
parent%child
This would be internally represented as:
parent+cousin%child
So the '+' sign is used to signal that we have to do a special matching check
for both possible cases depending on how the user chose to represent it, usually
as the shorter version of the name.
Admittedly, I do not have very many examples of code that use this feature yet.
Regression tested on x86-64. Test case attached with patch.
OK for trunk?
Regards,
Jerry
2014-05-24 Tobias Burnus <[email protected]>
PR fortran/55117
* trans-io.c (nml_full_name, transfer_namelist_element): Insert
a '+' rather then '%' to differentiate namelist variable names
that are based on extended derived types.
2014-05-24 Jerry DeLisle <[email protected]>
PR libgfortran/55117
* io/list_read.c (extended_look_ahead): New helper function to
scan the namelist name and look for matches with the new '+'
extended type parent indicator. (str_comp_extended): New
helper function to compare the namelist name with the varname
namelist. (find_nml_name): Use the new helper functions to match
the extended type varnames.
Index: gcc/fortran/trans-io.c
===================================================================
--- gcc/fortran/trans-io.c (revision 210573)
+++ gcc/fortran/trans-io.c (working copy)
@@ -1452,10 +1452,10 @@ gfc_trans_wait (gfc_code * code)
/* nml_full_name builds up the fully qualified name of a
- derived type component. */
+ derived type component. '+' is used to denote a type extension. */
static char*
-nml_full_name (const char* var_name, const char* cmp_name)
+nml_full_name (const char* var_name, const char* cmp_name, bool parent)
{
int full_name_length;
char * full_name;
@@ -1463,7 +1463,7 @@ static char*
full_name_length = strlen (var_name) + strlen (cmp_name) + 1;
full_name = XCNEWVEC (char, full_name_length + 1);
strcpy (full_name, var_name);
- full_name = strcat (full_name, "%");
+ full_name = strcat (full_name, parent ? "+" : "%");
full_name = strcat (full_name, cmp_name);
return full_name;
}
@@ -1634,7 +1634,8 @@ transfer_namelist_element (stmtblock_t * block, co
for (cmp = ts->u.derived->components; cmp; cmp = cmp->next)
{
- char *full_name = nml_full_name (var_name, cmp->name);
+ char *full_name = nml_full_name (var_name, cmp->name,
+ ts->u.derived->attr.extension);
transfer_namelist_element (block,
full_name,
NULL, cmp, expr);
Index: libgfortran/io/list_read.c
===================================================================
--- libgfortran/io/list_read.c (revision 210898)
+++ libgfortran/io/list_read.c (working copy)
@@ -2557,6 +2557,38 @@ err_ret:
return false;
}
+
+static bool
+extended_look_ahead (char *p, char *q)
+{
+ char *r, *s;
+
+ /* Scan ahead to find a '%' in the p string. */
+ for(r = p, s = q; *r && *s; s++)
+ if ((*s == '%' || *s == '+') && strcmp (r + 1, s + 1) == 0)
+ return true;
+ return false;
+}
+
+
+static bool
+strcmp_extended_type (char *p, char *q)
+{
+ char *r, *s;
+
+ for (r = p, s = q; *r && *s; r++, s++)
+ {
+ if (*r != *s)
+ {
+ if (*r == '%' && *s == '+' && extended_look_ahead (r, s))
+ return true;
+ break;
+ }
+ }
+ return false;
+}
+
+
static namelist_info *
find_nml_node (st_parameter_dt *dtp, char * var_name)
{
@@ -2568,6 +2600,11 @@ find_nml_node (st_parameter_dt *dtp, char * var_na
t->touched = 1;
return t;
}
+ if (strcmp_extended_type (var_name, t->var_name))
+ {
+ t->touched = 1;
+ return t;
+ }
t = t->next;
}
return NULL;
! { dg-do run }
! PR55117 Programs fails namelist read (contains derived types objects)
program test_type_extension
type tk_t
real :: x
end type tk_t
type, extends(tk_t) :: tke_t
character(8) :: string
end type tke_t
type, extends(tke_t) :: deep
integer :: int1
real :: y
character(10) :: the_name
end type deep
type other
integer :: one_oh
integer :: two_oh
end type other
type plain_type
integer :: var1
type(other) :: var2
real :: var3
end type plain_type
type some_other
complex :: varx
type(tke_t) :: tke
type (plain_type) :: varpy
real :: vary
end type some_other
type(deep) :: trouble
type(some_other) :: somethinelse
type(tke_t) :: tke
integer :: answer
namelist /test_NML/ trouble, somethinelse, tke, answer
tke%x = 0.0
tke%string = "xxxxxxxx"
answer = 5
trouble%x = 5.34
trouble%y = 4.25
trouble%string = "yyyy"
trouble%the_name = "mischief"
open(unit=10,file='good.inp')
read(10,NML=test_NML)
if (tke%x - 3.14000010 > .00001) call abort
if (tke%string /= "kf7rcc") call abort
if (answer /= 42) call abort ! hitchkikers guide to the galaxy
end program test_type_extension
