re PR fortran/13278 (derived type namelist I/O support missing, causes ICE)

2004-08-18  Victor Leikehman  <lei@il.ibm.com>

	PR fortran/13278
	* trans-io.c (transfer_namelist_element): New. Recursively handle
	derived-type variables.  Pass string lengths.
	(build_dt): Code moved to build_namelist, with some
	changes and additions.
	(gfc_build_io_library_fndecls): Declare the fifth
	argument in st_set_nml_var_char -- string_length.
libgfortran/
	* io/transfer.c (st_set_nml_var)
	* io/write.c (namelist_write): Allow var_name and var_name_len to be
	null. For strings, use string_length field instead of len.
	* io/io.h (struct namelist_type): New field string_length.
	(st_set_nml_var_char): New argument string_length.

From-SVN: r86166

gcc/fortran/ChangeLog

@@ -1,3 +1,13 @@
+2004-08-18  Victor Leikehman  <lei@il.ibm.com>
+
+	PR fortran/13278
+	* trans-io.c (transfer_namelist_element): New. Recursively handle
+	derived-type variables.  Pass string lengths.
+	(build_dt): Code moved to build_namelist, with some
+	changes and additions.
+	(gfc_build_io_library_fndecls): Declare the fifth
+	argument in st_set_nml_var_char -- string_length.
+
 2004-08-17  Paul Brook  <paul@codesourcery.com>
 	Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
 

gcc/fortran/trans-io.c

@@ -329,9 +329,10 @@ gfc_build_io_library_fndecls (void)
                                      gfc_int4_type_node,gfc_int4_type_node);
   iocall_set_nml_val_char =
     gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_char")),
-                                     void_type_node, 4,
+                                     void_type_node, 5,
                                      pvoid_type_node, pvoid_type_node,
-                                     gfc_int4_type_node,gfc_int4_type_node);
+                                     gfc_int4_type_node, gfc_int4_type_node, 
+                                     gfc_strlen_type_node);
   iocall_set_nml_val_complex =
     gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_complex")),
                                      void_type_node, 4,
@@ -842,6 +843,94 @@ get_new_var_expr(gfc_symbol * sym)
   return nml_var;
 }
 
+/* For a scalar variable STRING whose address is ADDR_EXPR, generate a
+   call to iocall_set_nml_val.  For derived type variable, recursively
+   generate calls to iocall_set_nml_val for each leaf field. The leafs
+   have no names -- their STRING field is null, and are interpreted by
+   the run-time library as having only the value, as in the example:
+
+   &foo bzz=1,2,3,4,5/
+
+   Note that the first output field appears after the name of the
+   variable, not of the field name.  This causes a little complication
+   documented below. */
+
+static void
+transfer_namelist_element (stmtblock_t * block, gfc_typespec * ts, tree addr_expr, 
+                           tree string, tree string_length)
+{
+  tree tmp, args, arg2;
+  tree expr;
+
+  assert (POINTER_TYPE_P (TREE_TYPE (addr_expr)));
+
+  if (ts->type == BT_DERIVED)
+    {
+      gfc_component *c;
+      expr = gfc_build_indirect_ref (addr_expr);
+
+      for (c = ts->derived->components; c; c = c->next)
+        {
+          tree field = c->backend_decl;
+          assert (field && TREE_CODE (field) == FIELD_DECL);
+          tmp = build (COMPONENT_REF, TREE_TYPE (field), expr, field, NULL_TREE);
+
+          if (c->dimension)
+            gfc_todo_error ("NAMELIST IO of array in derived type");
+          if (!c->pointer)
+            tmp = gfc_build_addr_expr (NULL, tmp);
+          transfer_namelist_element (block, &c->ts, tmp, string, string_length);
+
+          /* The first output field bears the name of the topmost
+             derived type variable.  All other fields are anonymous
+             and appear with nulls in their string and string_length
+             fields.  After the first use, we set string and
+             string_length to null. */
+          string = null_pointer_node;
+          string_length = integer_zero_node;
+        }
+
+      return;
+    }
+
+  args = gfc_chainon_list (NULL_TREE, addr_expr);
+  args = gfc_chainon_list (args, string);
+  args = gfc_chainon_list (args, string_length);
+  arg2 = build_int_cst (gfc_array_index_type, ts->kind, 0);
+  args = gfc_chainon_list (args,arg2);
+
+  switch (ts->type)
+    {
+    case BT_INTEGER:
+      tmp = gfc_build_function_call (iocall_set_nml_val_int, args);
+      break;
+
+    case BT_CHARACTER:
+      expr = gfc_build_indirect_ref (addr_expr);
+      assert (TREE_CODE (TREE_TYPE (expr)) == ARRAY_TYPE);
+      args = gfc_chainon_list (args,
+                               TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (expr))));
+      tmp = gfc_build_function_call (iocall_set_nml_val_char, args);
+      break;
+
+    case BT_REAL:
+      tmp = gfc_build_function_call (iocall_set_nml_val_float, args);
+      break;
+
+    case BT_LOGICAL:
+      tmp = gfc_build_function_call (iocall_set_nml_val_log, args);
+      break;
+
+    case BT_COMPLEX:
+      tmp = gfc_build_function_call (iocall_set_nml_val_complex, args);
+      break;
+
+    default :
+      internal_error ("Bad namelist IO basetype (%d)", ts->type);
+    }
+
+  gfc_add_expr_to_block (block, tmp);
+}
 
 /* Create a data transfer statement.  Not all of the fields are valid
    for both reading and writing, but improper use has been filtered
@@ -852,11 +941,10 @@ build_dt (tree * function, gfc_code * code)
 {
   stmtblock_t block, post_block;
   gfc_dt *dt;
-  tree tmp, args, arg2;
+  tree tmp;
   gfc_expr *nmlname, *nmlvar;
-  gfc_namelist *nml, *nml_tail;
+  gfc_namelist *nml;
   gfc_se se,se2;
-  int ts_kind, ts_type, name_len;
 
   gfc_init_block (&block);
   gfc_init_block (&post_block);
@@ -925,51 +1013,19 @@ build_dt (tree * function, gfc_code * code)
        if (last_dt == READ)
           set_flag (&block, ioparm_namelist_read_mode);
 
-       nml = dt->namelist->namelist;
+	for (nml = dt->namelist->namelist; nml; nml = nml->next)
-       nml_tail = dt->namelist->namelist_tail;
+	  {
+	    gfc_init_se (&se, NULL);
+	    gfc_init_se (&se2, NULL);
+	    nmlvar = get_new_var_expr (nml->sym);
+	    nmlname = gfc_new_nml_name_expr (nml->sym->name);
+	    gfc_conv_expr_reference (&se2, nmlname);
+	    gfc_conv_expr_reference (&se, nmlvar);
+	    gfc_evaluate_now (se.expr, &se.pre); 
 
-       while(nml != NULL)
+	    transfer_namelist_element (&block, &nml->sym->ts, se.expr,
-       {
+				       se2.expr, se2.string_length);
-          gfc_init_se (&se, NULL);
+	  }
-          gfc_init_se (&se2, NULL);
-          nmlvar = get_new_var_expr(nml->sym);
-          nmlname = gfc_new_nml_name_expr(nml->sym->name);
-          name_len = strlen(nml->sym->name);
-          ts_kind = nml->sym->ts.kind;
-          ts_type = nml->sym->ts.type;
-
-          gfc_conv_expr_reference (&se2, nmlname);
-          gfc_conv_expr_reference (&se, nmlvar);
-          args = gfc_chainon_list (NULL_TREE, se.expr);
-          args = gfc_chainon_list (args, se2.expr);
-          args = gfc_chainon_list (args, se2.string_length);
-          arg2 = build_int_cst (NULL_TREE, ts_kind, 0);
-          args = gfc_chainon_list (args,arg2);
-          switch (ts_type)
-            {
-            case BT_INTEGER:
-              tmp = gfc_build_function_call (iocall_set_nml_val_int, args);
-              break;
-            case BT_CHARACTER:
-              tmp = gfc_build_function_call (iocall_set_nml_val_char, args);
-              break;
-            case BT_REAL:
-              tmp = gfc_build_function_call (iocall_set_nml_val_float, args);
-              break;
-            case BT_LOGICAL:
-              tmp = gfc_build_function_call (iocall_set_nml_val_log, args);
-              break;
-            case BT_COMPLEX:
-              tmp = gfc_build_function_call (iocall_set_nml_val_complex, args);
-              break;
-            default :
-              internal_error ("Bad namelist IO basetype (%d)", ts_type);
-            }
-
-          gfc_add_expr_to_block (&block, tmp);
-
-          nml = nml->next;
-       }
     }
 
   tmp = gfc_build_function_call (*function, NULL_TREE);

libgfortran/ChangeLog

@@ -1,3 +1,12 @@
+2004-08-18  Victor Leikehman  <lei@il.ibm.com>
+
+	PR fortran/13278
+	* io/transfer.c (st_set_nml_var)
+	* io/write.c (namelist_write): Allow var_name and var_name_len to be
+	null. For strings, use string_length field instead of len.
+	* io/io.h (struct namelist_type): New field string_length.
+	(st_set_nml_var_char): New argument string_length.
+
 2004-08-13  Bud Davis  <bdavis9659@comcast.net>
 
 	PR gfortran/16935

libgfortran/io/io.h

@@ -90,6 +90,7 @@ typedef struct namelist_type
   void * mem_pos;
   int  value_acquired;
   int len;
+  int string_length;
   bt type;
   struct namelist_type * next;
 }
@@ -545,7 +546,7 @@ void st_set_nml_var_int (void * , char * , int , int );
 void st_set_nml_var_float (void * , char * , int , int );
 
 #define st_set_nml_var_char prefix(st_set_nml_var_char)
-void st_set_nml_var_char (void * , char * , int , int );
+void st_set_nml_var_char (void * , char * , int , int, gfc_strlen_type);
 
 #define st_set_nml_var_complex prefix(st_set_nml_var_complex)
 void st_set_nml_var_complex (void * , char * , int , int );

libgfortran/io/transfer.c

@@ -24,6 +24,7 @@ Boston, MA 02111-1307, USA.  */
 
 #include "config.h"
 #include <string.h>
+#include <assert.h>
 #include "libgfortran.h"
 #include "io.h"
 
@@ -1507,17 +1508,28 @@ st_write_done (void)
 
 static void
 st_set_nml_var (void * var_addr, char * var_name, int var_name_len,
-                int kind, bt type)
+                int kind, bt type, int string_length)
 {
   namelist_info *t1 = NULL, *t2 = NULL;
   namelist_info *nml = (namelist_info *) get_mem (sizeof(
                                                     namelist_info ));
   nml->mem_pos = var_addr;
-  nml->var_name = (char*) get_mem (var_name_len+1);
+  if (var_name)
-  strncpy (nml->var_name,var_name,var_name_len);
+    {
-  nml->var_name[var_name_len] = 0;
+      assert (var_name_len > 0);
+      nml->var_name = (char*) get_mem (var_name_len+1);
+      strncpy (nml->var_name, var_name, var_name_len);
+      nml->var_name[var_name_len] = 0;
+    }
+  else
+    {
+      assert (var_name_len == 0);
+      nml->var_name = NULL;
+    }
+
   nml->len = kind;
   nml->type = type;
+  nml->string_length = string_length;
 
   nml->next = NULL;
 
@@ -1539,34 +1551,35 @@ void
 st_set_nml_var_int (void * var_addr, char * var_name, int var_name_len,
                 int kind)
 {
-   st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_INTEGER);
+   st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_INTEGER, 0);
 }
 
 void
 st_set_nml_var_float (void * var_addr, char * var_name, int var_name_len,
                 int kind)
 {
-   st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_REAL);
+   st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_REAL, 0);
 }
 
 void
 st_set_nml_var_char (void * var_addr, char * var_name, int var_name_len,
-                int kind)
+                int kind, gfc_strlen_type string_length)
 {
-   st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_CHARACTER);
+   st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_CHARACTER,
+                   string_length);
 }
 
 void
 st_set_nml_var_complex (void * var_addr, char * var_name, int var_name_len,
                 int kind)
 {
-   st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_COMPLEX);
+   st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_COMPLEX, 0);
 }
 
 void
 st_set_nml_var_log (void * var_addr, char * var_name, int var_name_len,
                 int kind)
 {
-   st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_LOGICAL);
+   st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_LOGICAL, 0);
 }
 

libgfortran/io/write.c

@@ -1122,8 +1122,11 @@ namelist_write (void)
           num ++;
           t2 = t1;
           t1 = t1->next;
-          write_character(t2->var_name, strlen(t2->var_name));
+          if (t2->var_name)
-          write_character("=",1);
+            {
+              write_character(t2->var_name, strlen(t2->var_name));
+              write_character("=",1);
+            }
           len = t2->len;
           p = t2->mem_pos;
           switch (t2->type)
@@ -1135,7 +1138,7 @@ namelist_write (void)
               write_logical (p, len);
               break;
             case BT_CHARACTER:
-              write_character (p, len);
+              write_character (p, t2->string_length);
               break;
             case BT_REAL:
               write_real (p, len);