This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[gfortran/patch] Support NAMELIST I/O of derived type variables (compilerside)
- From: Victor Leikehman <lei at haifasphere dot co dot il>
- To: gcc-patches at gcc dot gnu dot org, fortran at gcc dot gnu dot org
- Date: Thu, 12 Aug 2004 10:25:35 +0300
- Subject: [gfortran/patch] Support NAMELIST I/O of derived type variables (compilerside)
- Organization: IBM Research Lab in Haifa, Israel
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);