Re: [gfortran/patch] Support NAMELIST I/O of derived type variables(compiler side)

[Victor Leikehman <lei at haifasphere dot co dot il>]

Paul Brook wrote:

> Maybe transfer_namelist, which is consistent with the existing transfer_expr.

Maybe transfer_namelist_element is even better. But feel free to change it.

> Don't take the address if c->pointer is set.
Okay.

> Pass an extra string length parameter to st_set_nml_val_char for the string 
> length.
Okay.  This reqired one more change to the library, so be sure to pick up
the latest library patch.

>> 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);
>
> Add gfc_evaluate_now(se->expr, &se->pre); here.

I still don't understand.  The documentation of gfc_evaluate_now says:

/* If the an expression is not constant, evaluate it now.  We assign the
   result of the expression to an artificially created variable VAR, and
   return a pointer to the VAR_DECL node for this variable.  */

Since se.expr is an ADDR_EXPR pointing to VAR_DECL node anyway, why do
we need one more?  And if we do, why only se and not se2 ?
Applied your fix anyway :-)

Thanks,
	Victor

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

	* trans-io.c (transfer_namelist_element): New. Recursively handle
	derived-type variables, in addition to the scalars.  For strings, pass
	their length. (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.


-- 
  Victor Leikehman
  IBM Research Labs in Haifa, Israel

Index: trans-io.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/trans-io.c,v
retrieving revision 1.9
diff -c -p -r1.9 trans-io.c
*** trans-io.c	10 Aug 2004 00:57:20 -0000	1.9
--- trans-io.c	15 Aug 2004 08:38:50 -0000
*************** gfc_build_io_library_fndecls (void)
*** 329,337 ****
                                       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,
                                       pvoid_type_node, pvoid_type_node,
!                                      gfc_int4_type_node,gfc_int4_type_node);
    iocall_set_nml_val_complex =
      gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_complex")),
                                       void_type_node, 4,
--- 329,338 ----
                                       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, 5,
                                       pvoid_type_node, pvoid_type_node,
!                                      gfc_int4_type_node, gfc_int4_type_node, 
!                                      gfc_int4_type_node); /* string length */
    iocall_set_nml_val_complex =
      gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_complex")),
                                       void_type_node, 4,
*************** get_new_var_expr(gfc_symbol * sym)
*** 842,847 ****
--- 843,936 ----
    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_2 (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
*************** build_dt (tree * function, gfc_code * co
*** 852,862 ****
  {
    stmtblock_t block, post_block;
    gfc_dt *dt;
!   tree tmp, args, arg2;
    gfc_expr *nmlname, *nmlvar;
!   gfc_namelist *nml, *nml_tail;
    gfc_se se,se2;
-   int ts_kind, ts_type, name_len;
  
    gfc_init_block (&block);
    gfc_init_block (&post_block);
--- 941,950 ----
  {
    stmtblock_t block, post_block;
    gfc_dt *dt;
!   tree tmp;
    gfc_expr *nmlname, *nmlvar;
!   gfc_namelist *nml;
    gfc_se se,se2;
  
    gfc_init_block (&block);
    gfc_init_block (&post_block);
*************** build_dt (tree * function, gfc_code * co
*** 925,975 ****
         if (last_dt == READ)
            set_flag (&block, ioparm_namelist_read_mode);
  
!        nml = dt->namelist->namelist;
!        nml_tail = dt->namelist->namelist_tail;
! 
!        while(nml != NULL)
!        {
!           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_2 (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);
--- 1013,1030 ----
         if (last_dt == READ)
            set_flag (&block, ioparm_namelist_read_mode);
  
!        for (nml = dt->namelist->namelist; nml; nml = nml->next)
!          {
!            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); 
  
!            transfer_namelist_element (&block, &nml->sym->ts, se.expr, se2.expr, se2.string_length);
!          }
      }
  
    tmp = gfc_build_function_call (*function, NULL_TREE);