[prev in list] [next in list] [prev in thread] [next in thread] 

List:       gcc-fortran
Subject:    [RFC, patch] Extended types in namelists
From:       Jerry DeLisle <jvdelisle () charter ! net>
Date:       2014-03-23 22:57:59
Message-ID: 532F66F7.3000602 () charter ! net
[Download RAW message or body]

Hi all,

The attached patch will eventually resolve pr55117.  It provides a way to
identify extended type variable names in namelists that use a parent%child
format, but internally these are represented as parent%extended%child. (Forgive
me if I have my nomenclature inaccurate).

The patch has two parts, front-end and library.  The front-end patch was
provided by Tobias and substitutes a '+' symbol in the namelist variable name
strings so that we can tell if the variable being searched is an extended type.
The library part modifies the search for the variable names to first look for a
match to a non extended type and then if not found, looks for an extended type
match.

I have been running Tobias front-end patch for months without any failures so
that tells me we don't have too many code examples to exercise this, none in the
testsuite for sure.

The patch is preliminary in that I have tested with some test cases I have.  I
am not convinced that a recursive approach is not needed depending on how the
variable names get nested. With that said, I would appreciate some examples that
are not handled yet by the patch. (I hate it when I ask for it because usually I
will then get a bundle of examples, ha ha)

Testing and comments much appreciated.

Regards,

Jerry


["extended_type_nml.diff" (text/x-patch)]

Index: gcc/fortran/trans-io.c
===================================================================
--- gcc/fortran/trans-io.c	(revision 208755)
+++ 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 208755)
+++ libgfortran/io/list_read.c	(working copy)
@@ -2400,6 +2400,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)
 {
@@ -2411,6 +2443,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;

["deep.f90" (text/x-fortran)]

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"

  !write(*,*) tke%x, tke%string, answer
  !write(*,*) "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"
  !write(*,*) trouble
  !write(*,*) "======================================="

  !write(6,nml=test_NML)
  open(unit=10,file='good.inp')
  read(10,NML=test_NML)

  write(*,*) tke%x, tke%string, answer

end program test_type_extension

["good.inp" (text/plain)]

&TEST_NML
 TKE%X=  3.14    ,
 TKE%STRING="kf7rcc",
 ANSWER=          42,
 /

***** replace the above chunk with the following for no error*******
&TEST_NML
 TKE%TK_T%X=  3.14    ,
 TKE%STRING="kf7rcc54",
 ANSWER=          42,
 /
****************************
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(tke_t) :: tke
type(deep) :: trouble

integer :: answer
namelist /test_NML/ tke, answer, trouble

Note to self:

To fix this bug we need to modify the search algorythm in find_nml_node

Consider searching for matching first name and matching last name
Create a test case with multiple extended/nested types
Tobias patch is applied

var_name = tke%x  << We have this
t.var_name = tke
t.next.var_name = tke%tk_t
t.next.next.var_name = tke%tk_t%x    <<  The one we are looking for
t.next.next.next.var_name = tke%string

["tc55117-2.f90" (text/x-fortran)]

type i1
  integer :: val
end type i1

type, extends(i1) :: i2
end type i2
 
type o1
  type(i2) :: i2
end type o1

type,extends(o1) :: o2
end type o2
 
type(o2) :: var
namelist /nml/ var
 
var%i2%val = -42
write(*,nml=nml)
open (99, status='scratch')
write(99, '(A)') '&nml var%i2%val = 1 /'
rewind(99); read(99,nml=nml); close(99)
if (var%i2%val /= 1) call abort ()
 
!var%i2%i1%val = -43
!open (99, status='scratch')
!write(99, '(A)') '&nml var%i2%i1%val = 2 /'
!rewind(99); read(99,nml=nml); close(99)
!if (var%i2%val /= 2) call abort ()
 
!var%o1%i2%i1%val = -44
!open (99, status='scratch')
!write(99, '(A)') '&nml var%o1%i2%i1%val = 3 /'
!rewind(99); read(99,nml=nml); close(99)
!if (var%i2%val /= 3) call abort ()
 
!var%o1%i2%val = -45
!open (99, status='scratch')
!write(99, '(A)') '&nml var%o1%i2%val = 4 /'
!rewind(99); read(99,nml=nml); close(99)
!if (var%i2%val /= 4) call abort ()
end



[prev in list] [next in list] [prev in thread] [next in thread]