From 3bc268e64b4167a3566c8b53decda0b06668f6fe Mon Sep 17 00:00:00 2001 From: Victor Leikehman Date: Wed, 18 Aug 2004 01:20:06 +0000 Subject: [PATCH] re PR fortran/13278 (derived type namelist I/O support missing, causes ICE) 2004-08-18 Victor Leikehman 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 | 10 +++ gcc/fortran/trans-io.c | 154 ++++++++++++++++++++++++++------------ libgfortran/ChangeLog | 9 +++ libgfortran/io/io.h | 3 +- libgfortran/io/transfer.c | 33 +++++--- libgfortran/io/write.c | 9 ++- 6 files changed, 155 insertions(+), 63 deletions(-) diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index e8af2270fd8..c6e5cbe191b 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,13 @@ +2004-08-18 Victor Leikehman + + 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 Tobias Schlueter diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index 8df23edabca..63d56186c4c 100644 --- a/gcc/fortran/trans-io.c +++ b/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; - nml_tail = dt->namelist->namelist_tail; + 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); - 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_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; - } + transfer_namelist_element (&block, &nml->sym->ts, se.expr, + se2.expr, se2.string_length); + } } tmp = gfc_build_function_call (*function, NULL_TREE); diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index d5e97a2bdd6..ff4e9456aac 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,12 @@ +2004-08-18 Victor Leikehman + + 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 PR gfortran/16935 diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h index 8ad25993ce4..87a70f836cd 100644 --- a/libgfortran/io/io.h +++ b/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 ); diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index ff4bc26f317..d4bec91ea31 100644 --- a/libgfortran/io/transfer.c +++ b/libgfortran/io/transfer.c @@ -24,6 +24,7 @@ Boston, MA 02111-1307, USA. */ #include "config.h" #include +#include #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); - strncpy (nml->var_name,var_name,var_name_len); - nml->var_name[var_name_len] = 0; + if (var_name) + { + 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); } diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c index 1af8537d751..67c769ae920 100644 --- a/libgfortran/io/write.c +++ b/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)); - write_character("=",1); + if (t2->var_name) + { + 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);