OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/13278 (derived type namelist I/O support missing, causes ICE)

Browse Source 
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:
Victor Leikehman 2004-08-18 01:20:06 +00:00 committed by Paul Brook
parent b14454ba1a
commit 3bc268e64b
6 changed files with 155 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
gcc/fortran/ChangeLog
View File

@ -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>
Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de>

154
gcc/fortran/trans-io.c
View File

@ -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);

9
libgfortran/ChangeLog
View File

@ -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>
PR gfortran/16935

3
libgfortran/io/io.h
View File

@ -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 );

33
libgfortran/io/transfer.c
View File

@ -24,6 +24,7 @@ Boston, MA 02111-1307, USA. */
#include "config.h"
#include <string.h>
#include <assert.h>
#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);
}

9
libgfortran/io/write.c
View File

@ -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);