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
This commit is contained in:
parent
b14454ba1a
commit
3bc268e64b
|
@ -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>
|
2004-08-17 Paul Brook <paul@codesourcery.com>
|
||||||
Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de>
|
Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de>
|
||||||
|
|
||||||
|
|
|
@ -329,9 +329,10 @@ gfc_build_io_library_fndecls (void)
|
||||||
gfc_int4_type_node,gfc_int4_type_node);
|
gfc_int4_type_node,gfc_int4_type_node);
|
||||||
iocall_set_nml_val_char =
|
iocall_set_nml_val_char =
|
||||||
gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_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,
|
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 =
|
iocall_set_nml_val_complex =
|
||||||
gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_complex")),
|
gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_complex")),
|
||||||
void_type_node, 4,
|
void_type_node, 4,
|
||||||
|
@ -842,6 +843,94 @@ get_new_var_expr(gfc_symbol * sym)
|
||||||
return nml_var;
|
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
|
/* Create a data transfer statement. Not all of the fields are valid
|
||||||
for both reading and writing, but improper use has been filtered
|
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;
|
stmtblock_t block, post_block;
|
||||||
gfc_dt *dt;
|
gfc_dt *dt;
|
||||||
tree tmp, args, arg2;
|
tree tmp;
|
||||||
gfc_expr *nmlname, *nmlvar;
|
gfc_expr *nmlname, *nmlvar;
|
||||||
gfc_namelist *nml, *nml_tail;
|
gfc_namelist *nml;
|
||||||
gfc_se se,se2;
|
gfc_se se,se2;
|
||||||
int ts_kind, ts_type, name_len;
|
|
||||||
|
|
||||||
gfc_init_block (&block);
|
gfc_init_block (&block);
|
||||||
gfc_init_block (&post_block);
|
gfc_init_block (&post_block);
|
||||||
|
@ -925,51 +1013,19 @@ build_dt (tree * function, gfc_code * code)
|
||||||
if (last_dt == READ)
|
if (last_dt == READ)
|
||||||
set_flag (&block, ioparm_namelist_read_mode);
|
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);
|
tmp = gfc_build_function_call (*function, NULL_TREE);
|
||||||
|
|
|
@ -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>
|
2004-08-13 Bud Davis <bdavis9659@comcast.net>
|
||||||
|
|
||||||
PR gfortran/16935
|
PR gfortran/16935
|
||||||
|
|
|
@ -90,6 +90,7 @@ typedef struct namelist_type
|
||||||
void * mem_pos;
|
void * mem_pos;
|
||||||
int value_acquired;
|
int value_acquired;
|
||||||
int len;
|
int len;
|
||||||
|
int string_length;
|
||||||
bt type;
|
bt type;
|
||||||
struct namelist_type * next;
|
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 );
|
void st_set_nml_var_float (void * , char * , int , int );
|
||||||
|
|
||||||
#define st_set_nml_var_char prefix(st_set_nml_var_char)
|
#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)
|
#define st_set_nml_var_complex prefix(st_set_nml_var_complex)
|
||||||
void st_set_nml_var_complex (void * , char * , int , int );
|
void st_set_nml_var_complex (void * , char * , int , int );
|
||||||
|
|
|
@ -24,6 +24,7 @@ Boston, MA 02111-1307, USA. */
|
||||||
|
|
||||||
#include "config.h"
|
#include "config.h"
|
||||||
#include <string.h>
|
#include <string.h>
|
||||||
|
#include <assert.h>
|
||||||
#include "libgfortran.h"
|
#include "libgfortran.h"
|
||||||
#include "io.h"
|
#include "io.h"
|
||||||
|
|
||||||
|
@ -1507,17 +1508,28 @@ st_write_done (void)
|
||||||
|
|
||||||
static void
|
static void
|
||||||
st_set_nml_var (void * var_addr, char * var_name, int var_name_len,
|
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 *t1 = NULL, *t2 = NULL;
|
||||||
namelist_info *nml = (namelist_info *) get_mem (sizeof(
|
namelist_info *nml = (namelist_info *) get_mem (sizeof(
|
||||||
namelist_info ));
|
namelist_info ));
|
||||||
nml->mem_pos = var_addr;
|
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->len = kind;
|
||||||
nml->type = type;
|
nml->type = type;
|
||||||
|
nml->string_length = string_length;
|
||||||
|
|
||||||
nml->next = NULL;
|
nml->next = NULL;
|
||||||
|
|
||||||
|
@ -1539,34 +1551,35 @@ void
|
||||||
st_set_nml_var_int (void * var_addr, char * var_name, int var_name_len,
|
st_set_nml_var_int (void * var_addr, char * var_name, int var_name_len,
|
||||||
int kind)
|
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
|
void
|
||||||
st_set_nml_var_float (void * var_addr, char * var_name, int var_name_len,
|
st_set_nml_var_float (void * var_addr, char * var_name, int var_name_len,
|
||||||
int kind)
|
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
|
void
|
||||||
st_set_nml_var_char (void * var_addr, char * var_name, int var_name_len,
|
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
|
void
|
||||||
st_set_nml_var_complex (void * var_addr, char * var_name, int var_name_len,
|
st_set_nml_var_complex (void * var_addr, char * var_name, int var_name_len,
|
||||||
int kind)
|
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
|
void
|
||||||
st_set_nml_var_log (void * var_addr, char * var_name, int var_name_len,
|
st_set_nml_var_log (void * var_addr, char * var_name, int var_name_len,
|
||||||
int kind)
|
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);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
|
@ -1122,8 +1122,11 @@ namelist_write (void)
|
||||||
num ++;
|
num ++;
|
||||||
t2 = t1;
|
t2 = t1;
|
||||||
t1 = t1->next;
|
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;
|
len = t2->len;
|
||||||
p = t2->mem_pos;
|
p = t2->mem_pos;
|
||||||
switch (t2->type)
|
switch (t2->type)
|
||||||
|
@ -1135,7 +1138,7 @@ namelist_write (void)
|
||||||
write_logical (p, len);
|
write_logical (p, len);
|
||||||
break;
|
break;
|
||||||
case BT_CHARACTER:
|
case BT_CHARACTER:
|
||||||
write_character (p, len);
|
write_character (p, t2->string_length);
|
||||||
break;
|
break;
|
||||||
case BT_REAL:
|
case BT_REAL:
|
||||||
write_real (p, len);
|
write_real (p, len);
|
||||||
|
|
Loading…
Reference in New Issue