[gfortran/patch] Support NAMELIST I/O of derived type variables (compilerside)

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

This is the compiler side part of the fix that adds support of NAMELIST I/O of
derived type variables.  Library fix to appear in a separate message.

Some remarks:

1. I am not entirely satisfied with the name "build_namelist".  Improvements are
   welcome.

2. In a similar fix to transfer_expr, Paul added call to gfc_evaluate_now.
   I don't understand if it should be here as well.

3. String support was broken (passed only the first character).  I pass
   now the string length in the kind field.  Not sure if this is the right
   approach.

4. Array support is still broken.  Volunteers are welcome.


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

	* trans-io.c (build_namelist): 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.

-- 
  Victor Leikehman
  IBM Research Labs in Haifa, Israel

? trans-array.ps
? trans-io.c.new
? trans-io.ps
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	12 Aug 2004 07:07:32 -0000
*************** get_new_var_expr(gfc_symbol * sym)
*** 842,847 ****
--- 842,940 ----
    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
+ build_namelist (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");
+     
+           build_namelist (block, &c->ts, 
+                           gfc_build_addr_expr (NULL, 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);
+ 
+   if (ts->type != BT_CHARACTER)
+       arg2 = build_int_2 (ts->kind, 0);
+   else
+     {
+       expr = gfc_build_indirect_ref (addr_expr);
+       assert (TREE_CODE (TREE_TYPE (expr)) == ARRAY_TYPE);
+       arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (expr)));
+     }
+ 
+   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);
+ }
  
  /* 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);
--- 945,954 ----
  {
    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);
--- 1017,1033 ----
         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);
  
!            build_namelist (&block, &nml->sym->ts, se.expr, se2.expr, se2.string_length);
!          }
      }
  
    tmp = gfc_build_function_call (*function, NULL_TREE);