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

re PR fortran/17472 ([4.0 only] namelist does not handle arrays) 

-------------------------------------------------------------------

From-SVN: r98287
This commit is contained in:
Paul Thomas 2005-04-17 20:09:37 +00:00
parent 3f620b5f2b
commit 29dc5138c3
30 changed files with 2459 additions and 426 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
gcc/fortran/ChangeLog
View File

@ -1,3 +1,19 @@
2005-04-17 Paul Thomas <pault@gcc.gnu.org>
PR fortran/17472
PR fortran/18209
PR fortran/18396
PR fortran/19467
PR fortran/19657
* fortran/trans-io.c (gfc_build_io_library_fndecls): Create declaration for
st_set_nml_var and st_set_nml_var_dim. Remove declarations of old
namelist functions.
(build_dt): Simplified call to transfer_namelist_element.
(nml_get_addr_expr): Generates address expression for start of object data. New function.
(nml_full_name): Qualified name for derived type components. New function.
(transfer_namelist_element): Modified for calls to new functions and improved derived
type handling.
2005-04-17 Richard Guenther <rguenth@gcc.gnu.org>
* scanner.c (gfc_next_char_literal): Reset truncation flag

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

@ -125,11 +125,8 @@ static GTY(()) tree iocall_iolength_done;
static GTY(()) tree iocall_rewind;
static GTY(()) tree iocall_backspace;
static GTY(()) tree iocall_endfile;
static GTY(()) tree iocall_set_nml_val_int;
static GTY(()) tree iocall_set_nml_val_float;
static GTY(()) tree iocall_set_nml_val_char;
static GTY(()) tree iocall_set_nml_val_complex;
static GTY(()) tree iocall_set_nml_val_log;
static GTY(()) tree iocall_set_nml_val;
static GTY(()) tree iocall_set_nml_val_dim;
/* Variable for keeping track of what the last data transfer statement
was. Used for deciding which subroutine to call when the data
@ -314,34 +311,19 @@ gfc_build_io_library_fndecls (void)
gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
gfc_int4_type_node, 0);
iocall_set_nml_val_int =
gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_int")),
void_type_node, 4,
pvoid_type_node, pvoid_type_node,
gfc_int4_type_node,gfc_int4_type_node);
iocall_set_nml_val_float =
gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_float")),
void_type_node, 4,
pvoid_type_node, pvoid_type_node,
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")),
iocall_set_nml_val =
gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var")),
void_type_node, 5,
pvoid_type_node, pvoid_type_node,
gfc_int4_type_node, gfc_int4_type_node,
gfc_charlen_type_node);
iocall_set_nml_val_complex =
gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_complex")),
void_type_node, 4,
pvoid_type_node, pvoid_type_node,
gfc_int4_type_node,gfc_int4_type_node);
iocall_set_nml_val_log =
gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_log")),
void_type_node, 4,
pvoid_type_node, pvoid_type_node,
gfc_int4_type_node,gfc_int4_type_node);
gfc_int4_type_node, gfc_charlen_type_node,
gfc_int4_type_node);
iocall_set_nml_val_dim =
gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_dim")),
void_type_node, 4,
gfc_int4_type_node, gfc_int4_type_node,
gfc_int4_type_node, gfc_int4_type_node);
}
@ -815,11 +797,11 @@ gfc_trans_inquire (gfc_code * code)
return gfc_finish_block (&block);
}
static gfc_expr *
gfc_new_nml_name_expr (const char * name)
{
gfc_expr * nml_name;
nml_name = gfc_get_expr();
nml_name->ref = NULL;
nml_name->expr_type = EXPR_CONSTANT;
@ -832,114 +814,229 @@ gfc_new_nml_name_expr (const char * name)
return nml_name;
}
static gfc_expr *
get_new_var_expr(gfc_symbol * sym)
/* nml_full_name builds up the fully qualified name of a
derived type component. */
static char*
nml_full_name (const char* var_name, const char* cmp_name)
{
gfc_expr * nml_var;
int full_name_length;
char * full_name;
nml_var = gfc_get_expr();
nml_var->expr_type = EXPR_VARIABLE;
nml_var->ts = sym->ts;
if (sym->as)
nml_var->rank = sym->as->rank;
nml_var->symtree = (gfc_symtree *)gfc_getmem (sizeof (gfc_symtree));
nml_var->symtree->n.sym = sym;
nml_var->where = sym->declared_at;
sym->attr.referenced = 1;
return nml_var;
full_name_length = strlen (var_name) + strlen (cmp_name) + 1;
full_name = (char*)gfc_getmem (full_name_length + 1);
strcpy (full_name, var_name);
full_name = strcat (full_name, "%");
full_name = strcat (full_name, cmp_name);
return full_name;
}
/* For a scalar variable STRING whose address is ADDR_EXPR, generate a
/* nml_get_addr_expr builds an address expression from the
gfc_symbol or gfc_component backend_decl's. An offset is
provided so that the address of an element of an array of
derived types is returned. This is used in the runtime to
determine that span of the derived type. */
static tree
nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
tree base_addr)
{
tree decl = NULL_TREE;
tree tmp;
tree itmp;
int array_flagged;
int dummy_arg_flagged;
if (sym)
{
sym->attr.referenced = 1;
decl = gfc_get_symbol_decl (sym);
}
else
decl = c->backend_decl;
gcc_assert (decl && ((TREE_CODE (decl) == FIELD_DECL
|| TREE_CODE (decl) == VAR_DECL
|| TREE_CODE (decl) == PARM_DECL)
|| TREE_CODE (decl) == COMPONENT_REF));
tmp = decl;
/* Build indirect reference, if dummy argument. */
dummy_arg_flagged = POINTER_TYPE_P (TREE_TYPE(tmp));
itmp = (dummy_arg_flagged) ? gfc_build_indirect_ref (tmp) : tmp;
/* If an array, set flag and use indirect ref. if built. */
array_flagged = (TREE_CODE (TREE_TYPE (itmp)) == ARRAY_TYPE
&& !TYPE_STRING_FLAG (TREE_TYPE (itmp)));
if (array_flagged)
tmp = itmp;
/* Treat the component of a derived type, using base_addr for
the derived type. */
if (TREE_CODE (decl) == FIELD_DECL)
tmp = build3 (COMPONENT_REF, TREE_TYPE (tmp),
base_addr, tmp, NULL_TREE);
/* If we have a derived type component, a reference to the first
element of the array is built. This is done so that base_addr,
used in the build of the component reference, always points to
a RECORD_TYPE. */
if (array_flagged)
tmp = gfc_build_array_ref (tmp, gfc_index_zero_node);
/* Now build the address expression. */
tmp = gfc_build_addr_expr (NULL, tmp);
/* If scalar dummy, resolve indirect reference now. */
if (dummy_arg_flagged && !array_flagged)
tmp = gfc_build_indirect_ref (tmp);
gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp)));
return tmp;
}
/* For an object VAR_NAME whose base address is BASE_ADDR, 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:
generate calls to iocall_set_nml_val for each component. */
&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. */
#define NML_FIRST_ARG(a) args = gfc_chainon_list (NULL_TREE, a)
#define NML_ADD_ARG(a) args = gfc_chainon_list (args, a)
#define IARG(i) build_int_cst (gfc_array_index_type, i)
static void
transfer_namelist_element (stmtblock_t * block, gfc_typespec * ts, tree addr_expr,
tree string, tree string_length)
transfer_namelist_element (stmtblock_t * block, const char * var_name,
gfc_symbol * sym, gfc_component * c,
tree base_addr)
{
tree tmp, args, arg2;
tree expr;
gfc_typespec * ts = NULL;
gfc_array_spec * as = NULL;
tree addr_expr = NULL;
tree dt = NULL;
tree string;
tree tmp;
tree args;
tree dtype;
int n_dim;
int itype;
int rank = 0;
gcc_assert (POINTER_TYPE_P (TREE_TYPE (addr_expr)));
gcc_assert (sym || c);
/* Build the namelist object name. */
string = gfc_build_cstring_const (var_name);
string = gfc_build_addr_expr (pchar_type_node, string);
/* Build ts, as and data address using symbol or component. */
ts = (sym) ? &sym->ts : &c->ts;
as = (sym) ? sym->as : c->as;
addr_expr = nml_get_addr_expr (sym, c, base_addr);
if (as)
rank = as->rank;
if (rank)
{
dt = TREE_TYPE ((sym) ? sym->backend_decl : c->backend_decl);
dtype = gfc_get_dtype (dt);
}
else
{
itype = GFC_DTYPE_UNKNOWN;
switch (ts->type)
{
case BT_INTEGER:
itype = GFC_DTYPE_INTEGER;
break;
case BT_LOGICAL:
itype = GFC_DTYPE_LOGICAL;
break;
case BT_REAL:
itype = GFC_DTYPE_REAL;
break;
case BT_COMPLEX:
itype = GFC_DTYPE_COMPLEX;
break;
case BT_DERIVED:
itype = GFC_DTYPE_DERIVED;
break;
case BT_CHARACTER:
itype = GFC_DTYPE_CHARACTER;
break;
default:
gcc_unreachable ();
}
dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT);
}
/* Build up the arguments for the transfer call.
The call for the scalar part transfers:
(address, name, type, kind or string_length, dtype) */
NML_FIRST_ARG (addr_expr);
NML_ADD_ARG (string);
NML_ADD_ARG (IARG (ts->kind));
if (ts->type == BT_CHARACTER)
NML_ADD_ARG (ts->cl->backend_decl);
else
NML_ADD_ARG (convert (gfc_charlen_type_node, integer_zero_node));
NML_ADD_ARG (dtype);
tmp = gfc_build_function_call (iocall_set_nml_val, args);
gfc_add_expr_to_block (block, tmp);
/* If the object is an array, transfer rank times:
(null pointer, name, stride, lbound, ubound) */
for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
{
NML_FIRST_ARG (IARG (n_dim));
NML_ADD_ARG (GFC_TYPE_ARRAY_STRIDE (dt, n_dim));
NML_ADD_ARG (GFC_TYPE_ARRAY_LBOUND (dt, n_dim));
NML_ADD_ARG (GFC_TYPE_ARRAY_UBOUND (dt, n_dim));
tmp = gfc_build_function_call (iocall_set_nml_val_dim, args);
gfc_add_expr_to_block (block, tmp);
}
if (ts->type == BT_DERIVED)
{
gfc_component *c;
expr = gfc_build_indirect_ref (addr_expr);
gfc_component *cmp;
for (c = ts->derived->components; c; c = c->next)
{
tree field = c->backend_decl;
gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
tmp = build3 (COMPONENT_REF, TREE_TYPE (field),
expr, field, NULL_TREE);
/* Provide the RECORD_TYPE to build component references. */
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);
tree expr = gfc_build_indirect_ref (addr_expr);
/* 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;
for (cmp = ts->derived->components; cmp; cmp = cmp->next)
{
char *full_name = nml_full_name (var_name, cmp->name);
transfer_namelist_element (block,
full_name,
NULL, cmp, expr);
gfc_free (full_name);
}
}
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);
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);
gcc_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);
}
#undef IARG
#undef NML_ADD_ARG
#undef NML_FIRST_ARG
/* Create a data transfer statement. Not all of the fields are valid
for both reading and writing, but improper use has been filtered
out by now. */
@ -950,9 +1047,8 @@ build_dt (tree * function, gfc_code * code)
stmtblock_t block, post_block;
gfc_dt *dt;
tree tmp;
gfc_expr *nmlname, *nmlvar;
gfc_expr *nmlname;
gfc_namelist *nml;
gfc_se se,se2;
gfc_init_block (&block);
gfc_init_block (&post_block);
@ -1010,30 +1106,20 @@ build_dt (tree * function, gfc_code * code)
if (dt->namelist)
{
if (dt->format_expr || dt->format_label)
fatal_error("A format cannot be specified with a namelist");
if (dt->format_expr || dt->format_label)
gfc_internal_error ("build_dt: format with namelist");
nmlname = gfc_new_nml_name_expr(dt->namelist->name);
nmlname = gfc_new_nml_name_expr(dt->namelist->name);
set_string (&block, &post_block, ioparm_namelist_name,
ioparm_namelist_name_len, nmlname);
set_string (&block, &post_block, ioparm_namelist_name,
ioparm_namelist_name_len, nmlname);
if (last_dt == READ)
set_flag (&block, ioparm_namelist_read_mode);
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);
gfc_evaluate_now (se.expr, &se.pre);
transfer_namelist_element (&block, &nml->sym->ts, se.expr,
se2.expr, se2.string_length);
}
for (nml = dt->namelist->namelist; nml; nml = nml->next)
transfer_namelist_element (&block, nml->sym->name, nml->sym,
NULL, NULL);
}
tmp = gfc_build_function_call (*function, NULL_TREE);

24
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,27 @@
2005-04-17 Paul Thomas <pault@gcc.gnu.org>
PR libfortran/12884 gfortran.dg/pr12884.f: New test
PR libfortran/17285 gfortran.dg/pr17285.f90: New test
PR libfortran/17472, 18396, 18209 gfortran.dg/pr17472.f: New test
PR libfortran/18122, 18591 gfortran.dg/pr18122.f90: New test
PR libfortran/18210 gfortran.dg/pr18210.f90: New test
PR libfortran/18392 gfortran.dg/pr18392.f90: New test
PR libfortran/19467 gfortran.dg/pr19467.f90: New test
PR libfortran/19657 gfortran.dg/pr19657.f90: New test
* gfortran.dg/namelist_1.f90: Correct comment (PUBLIC and PRIVATE wrong way round).
* gfortran.dg/namelist_2.f90: Variables with INTENT(IN) cannot be in namelists. New test
* gfortran.dg/namelist_3.f90: Pointers cannot be in namelists. New test
* gfortran.dg/namelist_11.f: Tests reals and qualifiers in namelist. New test
* gfortran.dg/namelist_12.f: Tests integers and qualifiers in namelist. New test
* gfortran.dg/namelist_13.f90: Tests derived types in namelist. New test
* gfortran.dg/namelist_14.f90: Tests trans-io.c namelist support. New test
* gfortran.dg/namelist_15.f90: Tests arrays of derived types in namelist. New test
* gfortran.dg/namelist_16.f90: Tests complex in namelist. New test
* gfortran.dg/namelist_17.f90: Tests logical in namelist. New test
* gfortran.dg/namelist_18.f90: Tests charcter delimiters in namelist. New test
* gfortran.dg/namelist_19.f90: Tests namelist errors. New test
* gfortran.dg/namelist_20.f90: Tests negative bounds for explicit arrays. New test
2005-04-17 Richard Guenther <rguenth@gcc.gnu.org>
* gfortran.dg/wtruncate.f: New testcase.

3
gcc/testsuite/gfortran.dg/namelist_1.f90
View File

@ -1,8 +1,7 @@
! { dg-do compile }
! Check that public entities in private namelists are rejected
! Check that private entities in public namelists are rejected
module namelist_1
public
integer,private :: x
namelist /n/ x ! { dg-error "cannot be member of PUBLIC namelist" "" }
end module

55
gcc/testsuite/gfortran.dg/namelist_11.f Normal file
View File

@ -0,0 +1,55 @@
c { dg-do run }
c This program tests: namelist comment, a blank line before the nameilist name, the namelist name,
c a scalar qualifier, various combinations of space, comma and lf delimiters, f-formats, e-formats
c a blank line within the data read, nulls, a range qualifier, a new object name before end of data
c and an integer read. It also tests that namelist output can be re-read by namelist input.
c provided by Paul Thomas - pault@gcc.gnu.org
program namelist_1
REAL*4 x(10)
REAL*8 xx
integer ier
namelist /mynml/ x, xx
do i = 1 , 10
x(i) = -1
end do
x(6) = 6.0
x(10) = 10.0
xx = 0d0
open (10,status="scratch")
write (10, *) "!mynml"
write (10, *) ""
write (10, *) "&gf /"
write (10, *) "&mynml x(7) =+99.0e0 x=1.0, 2.0 ,"
write (10, *) " 2*3.0, ,, 7.0e0,+0.08e+02 !comment"
write (10, *) ""
write (10, *) " 9000e-3 x(4:5)=4 ,5 "
write (10, *) " x=,,3.0, xx=10d0 /"
rewind (10)
read (10, nml=mynml, IOSTAT=ier)
if (ier.ne.0) call abort
rewind (10)
do i = 1 , 10
if ( abs( x(i) - real(i) ) .gt. 1e-8 ) call abort
end do
if ( abs( xx - 10d0 ) .gt. 1e-8 ) call abort
write (10, nml=mynml, iostat=ier)
if (ier.ne.0) call abort
rewind (10)
read (10, NML=mynml, IOSTAT=ier)
if (ier.ne.0) call abort
close (10)
do i = 1 , 10
if ( abs( x(i) - real(i) ) .gt. 1e-8 ) call abort
end do
if ( abs( xx - 10d0 ) .gt. 1e-8 ) call abort
end program

56
gcc/testsuite/gfortran.dg/namelist_12.f Normal file
View File

@ -0,0 +1,56 @@
c{ dg-do run }
c This program repeats many of the same tests as test_nml_1 but for integer instead of real.
c It also tests repeat nulls, comma delimited character read, a triplet qualifier, a range with
c and assumed start, a quote delimited string, a qualifier with an assumed end and a fully
c explicit range. It also tests that integers and characters are successfully read back by
c namelist.
c Provided by Paul Thomas - pault@gcc.gnu.org
program namelist_12
integer*4 x(10)
integer*8 xx
integer ier
character*10 ch , check
namelist /mynml/ x, xx, ch
c set debug = 0 or 1 in the namelist! (line 33)
do i = 1 , 10
x(i) = -1
end do
x(6) = 6
x(10) = 10
xx = 0
ch ="zzzzzzzzzz"
check="abcdefghij"
open (10,status="scratch")
write (10, *) "!mynml"
write (10, *) " "
write (10, *) "&mynml x(7) =+99 x=1, 2 ,"
write (10, *) " 2*3, ,, 2* !comment"
write (10, *) " 9 ch=qqqdefghqq , x(8:7:-1) = 8 , 7"
write (10, *) " ch(:3) =""abc"","
write (10, *) " ch(9:)='ij' x(4:5)=4 ,5 xx = 42/"
rewind (10)
read (10, nml=mynml, IOSTAT=ier)
if (ier.ne.0) call abort
rewind (10)
write (10, nml=mynml, iostat=ier)
if (ier.ne.0) call abort
rewind (10)
read (10, NML=mynml, IOSTAT=ier)
if (ier.ne.0) call abort
close (10)
do i = 1 , 10
if ( abs( x(i) - i ) .ne. 0 ) call abort ()
if ( ch(i:i).ne.check(I:I) ) call abort
end do
if (xx.ne.42) call abort ()
end program

38
gcc/testsuite/gfortran.dg/namelist_13.f90 Normal file
View File

@ -0,0 +1,38 @@
!{ dg-do run }
! Tests simple derived types.
! Provided by Paul Thomas - pault@gcc.gnu.org
program namelist_13
type :: yourtype
integer, dimension(2) :: yi = (/8,9/)
real, dimension(2) :: yx = (/80.,90./)
character(len=2) :: ych = "xx"
end type yourtype
type :: mytype
integer, dimension(2) :: myi = (/800,900/)
real, dimension(2) :: myx = (/8000.,9000./)
character(len=2) :: mych = "zz"
type(yourtype) :: my_yourtype
end type mytype
type(mytype) :: z
integer :: ier
integer :: zeros(10)
namelist /mynml/ zeros, z
zeros = 0
zeros(5) = 1
open(10,status="scratch")
write (10, nml=mynml, iostat=ier)
if (ier.ne.0) call abort
rewind (10)
read (10, NML=mynml, IOSTAT=ier)
if (ier.ne.0) call abort
close (10)
end program namelist_13

94
gcc/testsuite/gfortran.dg/namelist_14.f90 Normal file
View File

@ -0,0 +1,94 @@
!{ dg-do run }
! Tests various combinations of intrinsic types, derived types, arrays,
! dummy arguments and common to check nml_get_addr_expr in trans-io.c.
! See comments below for selection.
! provided by Paul Thomas - pault@gcc.gnu.org
module global
type :: mt
integer :: ii(4)
end type mt
end module global
program namelist_14
use global
common /myc/ cdt
integer :: i(2) = (/101,201/)
type(mt) :: dt(2)
type(mt) :: cdt
real*8 :: pi = 3.14159_8
character*10 :: chs="singleton"
character*10 :: cha(2)=(/"first ","second "/)
dt = mt ((/99,999,9999,99999/))
cdt = mt ((/-99,-999,-9999,-99999/))
call foo (i,dt,pi,chs,cha)
contains
logical function dttest (dt1, dt2)
use global
type(mt) :: dt1
type(mt) :: dt2
dttest = any(dt1%ii == dt2%ii)
end function dttest
subroutine foo (i, dt, pi, chs, cha)
use global
common /myc/ cdt
real *8 :: pi !local real scalar
integer :: i(2) !dummy arg. array
integer :: j(2) = (/21, 21/) !equivalenced array
integer :: jj ! -||- scalar
integer :: ier
type(mt) :: dt(2) !dummy arg., derived array
type(mt) :: dtl(2) !in-scope derived type array
type(mt) :: dts !in-scope derived type
type(mt) :: cdt !derived type in common block
character*10 :: chs !dummy arg. character var.
character*10 :: cha(:) !dummy arg. character array
character*10 :: chl="abcdefg" !in-scope character var.
equivalence (j,jj)
namelist /z/ dt, dtl, dts, cdt, j, jj, i, pi, chs, chl, cha
dts = mt ((/1, 2, 3, 4/))
dtl = mt ((/41, 42, 43, 44/))
open (10, status = "scratch")
write (10, nml = z, iostat = ier)
if (ier /= 0 ) call abort()
rewind (10)
i = 0
j = 0
jj = 0
pi = 0
dt = mt ((/0, 0, 0, 0/))
dtl = mt ((/0, 0, 0, 0/))
dts = mt ((/0, 0, 0, 0/))
cdt = mt ((/0, 0, 0, 0/))
chs = ""
cha = ""
chl = ""
read (10, nml = z, iostat = ier)
if (ier /= 0 ) call abort()
close (10)
if (.not.(dttest (dt(1), mt ((/99,999,9999,99999/))) .and. &
dttest (dt(2), mt ((/99,999,9999,99999/))) .and. &
dttest (dtl(1), mt ((/41, 42, 43, 44/))) .and. &
dttest (dtl(2), mt ((/41, 42, 43, 44/))) .and. &
dttest (dts, mt ((/1, 2, 3, 4/))) .and. &
dttest (cdt, mt ((/-99,-999,-9999,-99999/))) .and. &
all (j ==(/21, 21/)) .and. &
all (i ==(/101, 201/)) .and. &
(pi == 3.14159_8) .and. &
(chs == "singleton") .and. &
(chl == "abcdefg") .and. &
(cha(1)(1:10) == "first ") .and. &
(cha(2)(1:10) == "second "))) call abort ()
end subroutine foo
end program namelist_14

58
gcc/testsuite/gfortran.dg/namelist_15.f90 Normal file
View File

@ -0,0 +1,58 @@
!{ dg-do run }
! Tests arrays of derived types containing derived type arrays whose
! components are character arrays - exercises object name parser in
! list_read.c. Checks that namelist output can be reread.
! provided by Paul Thomas - pault@gcc.gnu.org
module global
type :: mt
character(len=2) :: ch(2) = (/"aa","bb"/)
end type mt
type :: bt
integer :: i(2) = (/1,2/)
type(mt) :: m(2)
end type bt
end module global
program namelist_15
use global
type(bt) :: x(2)
namelist /mynml/ x
open (10, status = "scratch")
write (10, '(A)') "&MYNML"
write (10, '(A)') " x = 3, 4, 'dd', 'ee', 'ff', 'gg',"
write (10, '(A)') " 4, 5, 'hh', 'ii', 'jj', 'kk',"
write (10, '(A)') " x%i = , ,-3, -4"
write (10, '(A)') " x(2)%m(1)%ch(2) =q,"
write (10, '(A)') " x(2)%m(2)%ch(1)(1) =w,"
write (10, '(A)') " x%m%ch(:)(2) =z z z z z z z z,"
write (10, '(A)') "&end"
rewind (10)
read (10, nml = mynml, iostat = ier)
if (ier .ne. 0) call abort ()
close (10)
open (10, status = "scratch")
write (10, nml = mynml)
rewind (10)
read (10, nml = mynml, iostat = ier)
if (ier .ne. 0) call abort ()
close(10)
if (.not. ((x(1)%i(1) == 3) .and. &
(x(1)%i(2) == 4) .and. &
(x(1)%m(1)%ch(1) == "dz") .and. &
(x(1)%m(1)%ch(2) == "ez") .and. &
(x(1)%m(2)%ch(1) == "fz") .and. &
(x(1)%m(2)%ch(2) == "gz") .and. &
(x(2)%i(1) == -3) .and. &
(x(2)%i(2) == -4) .and. &
(x(2)%m(1)%ch(1) == "hz") .and. &
(x(2)%m(1)%ch(2) == "qz") .and. &
(x(2)%m(2)%ch(1) == "wz") .and. &
(x(2)%m(2)%ch(2) == "kz"))) call abort ()
end program namelist_15

29
gcc/testsuite/gfortran.dg/namelist_16.f90 Normal file
View File

@ -0,0 +1,29 @@
!{ dg-do run }
! Tests namelist on complex variables
! provided by Paul Thomas - pault@gcc.gnu.org
program namelist_16
complex(kind=8), dimension(2) :: z
namelist /mynml/ z
z = (/(1.0,2.0), (3.0,4.0)/)
open (10, status = "scratch")
write (10, '(A)') "&mynml z(1)=(5.,6.) z(2)=(7.,8.) /"
rewind (10)
read (10, mynml, iostat = ier)
if (ier .ne. 0) call abort ()
close (10)
open (10, status = "scratch")
write (10, mynml, iostat = ier)
if (ier .ne. 0) call abort ()
rewind (10)
z = (/(1.0,2.0), (3.0,4.0)/)
read (10, mynml, iostat = ier)
if (ier .ne. 0) call abort ()
close (10)
if ((z(1) .ne. (5.0,6.0)) .or. (z(2) .ne. (7.0,8.0))) call abort ()
end program namelist_16

30
gcc/testsuite/gfortran.dg/namelist_17.f90 Normal file
View File

@ -0,0 +1,30 @@
!{ dg-do run }
! Tests namelist on logical variables
! provided by Paul Thomas - pault@gcc.gnu.org
program namelist_17
logical, dimension(2) :: l
namelist /mynml/ l
l = (/.true., .false./)
open (10, status = "scratch")
write (10, '(A)') "&mynml l = F T /"
rewind (10)
read (10, mynml, iostat = ier)
if (ier .ne. 0) call abort ()
close (10)
open (10, status = "scratch")
write (10, mynml, iostat = ier)
if (ier .ne. 0) call abort ()
rewind (10)
l = (/.true., .false./)
read (10, mynml, iostat = ier)
if (ier .ne. 0) call abort ()
close (10)
if (l(1) .or. (.not.l(2))) call abort ()
end program namelist_17

37
gcc/testsuite/gfortran.dg/namelist_18.f90 Normal file
View File

@ -0,0 +1,37 @@
!{ dg-do run }
! Tests character delimiters for namelist write
! provided by Paul Thomas - pault@gcc.gnu.org
program namelist_18
character*3 :: ch = "foo"
character*80 :: buffer
namelist /mynml/ ch
open (10, status = "scratch")
write (10, mynml)
rewind (10)
read (10, '(a)', iostat = ier) buffer
read (10, '(a)', iostat = ier) buffer
if (ier .ne. 0) call abort ()
close (10)
If ((buffer(5:5) /= "f") .or. (buffer(9:9) /= " ")) call abort ()
open (10, status = "scratch", delim ="quote")
write (10, mynml)
rewind (10)
read (10, '(a)', iostat = ier) buffer
read (10, '(a)', iostat = ier) buffer
if (ier .ne. 0) call abort ()
close (10)
If ((buffer(5:5) /= """") .or. (buffer(9:9) /= """")) call abort ()
open (10, status = "scratch", delim ="apostrophe")
write (10, mynml)
rewind (10)
read (10, '(a)', iostat = ier) buffer
read (10, '(a)', iostat = ier) buffer
if (ier .ne. 0) call abort ()
close (10)
If ((buffer(5:5) /= "'") .or. (buffer(9:9) /= "'")) call abort ()
end program namelist_18

135
gcc/testsuite/gfortran.dg/namelist_19.f90 Normal file
View File

@ -0,0 +1,135 @@
!{ dg-do run }
! Test namelist error trapping.
! provided by Paul Thomas - pault@gcc.gnu.org
program namelist_19
character*80 wrong, right
! "=" before any object name
wrong = "&z = i = 1,2 /"
right = "&z i = 1,2 /"
call test_err(wrong, right)
! &* instead of &end for termination
wrong = "&z i = 1,2 &xxx"
right = "&z i = 1,2 &end"
call test_err(wrong, right)
! bad data
wrong = "&z i = 1,q /"
right = "&z i = 1,2 /"
call test_err(wrong, right)
! object name not matched
wrong = "&z j = 1,2 /"
right = "&z i = 1,2 /"
call test_err(wrong, right)
! derived type component for intrinsic type
wrong = "&z i%j = 1,2 /"
right = "&z i = 1,2 /"
call test_err(wrong, right)
! step other than 1 for substring qualifier
wrong = "&z ch(1:2:2) = 'a'/"
right = "&z ch(1:2) = 'ab' /"
call test_err(wrong, right)
! qualifier for scalar
wrong = "&z k(2) = 1 /"
right = "&z k = 1 /"
call test_err(wrong, right)
! no '=' after object name
wrong = "&z i 1,2 /"
right = "&z i = 1,2 /"
call test_err(wrong, right)
! repeat count too large
wrong = "&z i = 3*2 /"
right = "&z i = 2*2 /"
call test_err(wrong, right)
! too much data
wrong = "&z i = 1 2 3 /"
right = "&z i = 1 2 /"
call test_err(wrong, right)
! no '=' after object name
wrong = "&z i 1,2 /"
right = "&z i = 1,2 /"
call test_err(wrong, right)
! bad number of index fields
wrong = "&z i(1,2) = 1 /"
right = "&z i(1) = 1 /"
call test_err(wrong, right)
! bad character in index field
wrong = "&z i(x) = 1 /"
right = "&z i(1) = 1 /"
call test_err(wrong, right)
! null index field
wrong = "&z i( ) = 1 /"
right = "&z i(1) = 1 /"
call test_err(wrong, right)
! null index field
wrong = "&z i(1::) = 1 2/"
right = "&z i(1:2:1) = 1 2 /"
call test_err(wrong, right)
! null index field
wrong = "&z i(1:2:) = 1 2/"
right = "&z i(1:2:1) = 1 2 /"
call test_err(wrong, right)
! index out of range
wrong = "&z i(10) = 1 /"
right = "&z i(1) = 1 /"
call test_err(wrong, right)
! index out of range
wrong = "&z i(0:1) = 1 /"
right = "&z i(1:1) = 1 /"
call test_err(wrong, right)
! bad range
wrong = "&z i(1:2:-1) = 1 2 /"
right = "&z i(1:2: 1) = 1 2 /"
call test_err(wrong, right)
! bad range
wrong = "&z i(2:1: 1) = 1 2 /"
right = "&z i(2:1:-1) = 1 2 /"
call test_err(wrong, right)
contains
subroutine test_err(wrong, right)
character*80 wrong, right
integer :: i(2) = (/0, 0/)
integer :: k =0
character*2 :: ch = " "
namelist /z/ i, k, ch
! Check that wrong namelist input gives an error
open (10, status = "scratch")
write (10, '(A)') wrong
rewind (10)
read (10, z, iostat = ier)
close(10)
if (ier == 0) call abort ()
! Check that right namelist input gives no error
open (10, status = "scratch")
write (10, '(A)') right
rewind (10)
read (10, z, iostat = ier)
close(10)
if (ier /= 0) call abort ()
end subroutine test_err
end program namelist_19

7
gcc/testsuite/gfortran.dg/namelist_2.f90 Normal file
View File

@ -0,0 +1,7 @@
! { dg-do compile }
! Check that variable with intent(in) cannot be a member of a namelist
subroutine namelist_2(x)
integer,intent(in) :: x
namelist /n/ x
read(*,n) ! { dg-error "is INTENT" "" }
end subroutine namelist_2

35
gcc/testsuite/gfortran.dg/namelist_20.f90 Normal file
View File

@ -0,0 +1,35 @@
!{ dg-do run }
! Tests namelist io for an explicit shape array with negative bounds
! provided by Paul Thomas - pault@gcc.gnu.org
program namelist_20
integer, dimension (-4:-2) :: x
integer :: i, ier
namelist /a/ x
open (10, status = "scratch")
write (10, '(A)') "&a x(-5)=0 /" !-ve index below lbound
write (10, '(A)') "&a x(-1)=0 /" !-ve index above ubound
write (10, '(A)') "&a x(1:2)=0 /" !+ve indices
write (10, '(A)') "&a x(-4:-2)= -4,-3,-2 /" !correct
write (10, '(A)') " "
rewind (10)
ier=0
read(10, a, iostat=ier)
if (ier == 0) call abort ()
ier=0
read(10, a, iostat=ier)
if (ier == 0) call abort ()
ier=0
read(10, a, iostat=ier)
if (ier == 0) call abort ()
ier=0
read(10, a, iostat=ier)
if (ier /= 0) call abort ()
do i = -4,-2
if (x(i) /= i) call abort ()
end do
end program namelist_20

7
gcc/testsuite/gfortran.dg/namelist_3.f90 Normal file
View File

@ -0,0 +1,7 @@
! { dg-do compile }
! Check that a pointer cannot be a member of a namelist
program namelist_3
integer,pointer :: x
allocate (x)
namelist /n/ x ! { dg-error "NAMELIST attribute conflicts with POINTER attribute" "" }
end program namelist_3

25
gcc/testsuite/gfortran.dg/pr12884.f Normal file
View File

@ -0,0 +1,25 @@
c { dg-do run }
c pr 12884
c test namelist with input file containg / before namelist. Also checks
c non-standard use of $ instead of &
c Based on example provided by jean-pierre.flament@univ-lille1.fr
program pr12884
integer ispher,nosym,runflg,noprop
namelist /cntrl/ ispher,nosym,runflg,noprop
ispher = 0
nosym = 0
runflg = 0
noprop = 0
open (10, status = "scratch")
write (10, '(A)') " $FILE"
write (10, '(A)') " pseu dir/file"
write (10, '(A)') " $END"
write (10, '(A)') " $cntrl ispher=1,nosym=2,"
write (10, '(A)') " runflg=3,noprop=4,$END"
write (10, '(A)')"/"
rewind (10)
read (10, cntrl)
if ((ispher.ne.1).or.(nosym.ne.2).or.(runflg.ne.3).or.
& (noprop.ne.4)) call abort ()
end

25
gcc/testsuite/gfortran.dg/pr17285.f90 Normal file
View File

@ -0,0 +1,25 @@
! { dg-do run }
! pr 17285
! Test that namelist can read its own output.
! At the same time, check arrays and different terminations
! Based on example provided by paulthomas2@wanadoo.fr
program pr17285
implicit none
integer, dimension(10) :: number = 42
integer :: ctr, ierr
namelist /mynml/ number
open (10, status = "scratch")
write (10,'(A)') &
"&mynml number(:)=42,42,42,42,42,42,42,42,42,42,/ "
write (10,mynml)
write (10,'(A)') "&mynml number(1:10)=10*42 &end"
rewind (10)
do ctr = 1,3
number = 0
read (10, nml = mynml, iostat = ierr)
if ((ierr /= 0) .or. (any (number /= 42))) &
call abort ()
end do
close(10)
end program pr17285

12
gcc/testsuite/gfortran.dg/pr17472.f Normal file
View File

@ -0,0 +1,12 @@
c { dg-do run }
c pr 17472
c test namelist handles arrays
c Based on example provided by thomas.koenig@online.de
integer a(10), ctr
data a / 1,2,3,4,5,6,7,8,9,10 /
namelist /ints/ a
do ctr = 1,10
if (a(ctr).ne.ctr) call abort ()
end do
end

45
gcc/testsuite/gfortran.dg/pr18122.f90 Normal file
View File

@ -0,0 +1,45 @@
! { dg-do run }
! test namelist with scalars and arrays.
! Based on example provided by thomas.koenig@online.de
program sechs_w
implicit none
integer, parameter :: dr=selected_real_kind(15)
integer, parameter :: nkmax=6
real (kind=dr) :: rb(nkmax)
integer :: z
real (kind=dr) :: dg
real (kind=dr) :: a
real (kind=dr) :: da
real (kind=dr) :: delta
real (kind=dr) :: s,t
integer :: nk
real (kind=dr) alpha0
real (kind=dr) :: phi, phi0, rad, rex, zk, z0, drdphi, dzdphi
namelist /schnecke/ z, dg, a, t, delta, s, nk, rb, alpha0
open (10,status="scratch")
write (10, *) "&SCHNECKE"
write (10, *) " z=1,"
write (10, *) " dg=58.4,"
write (10, *) " a=48.,"
write (10, *) " delta=0.4,"
write (10, *) " s=0.4,"
write (10, *) " nk=6,"
write (10, *) " rb=60, 0, 40,"
write (10, *) " alpha0=20.,"
write (10, *) "/"
rewind (10)
read (10,schnecke)
close (10)
if ((z /= 1) .or. (dg /= 58.4_dr) .or. (a /= 48.0_dr) .or. &
(delta /= 0.4_dr).or. (s /= 0.4_dr) .or. (nk /= 6) .or. &
(rb(1) /= 60._dr).or. (rb(2) /= 0.0_dr).or. (rb(3) /=40.0_dr).or. &
(alpha0 /= 20.0_dr)) call abort ()
end program sechs_w

21
gcc/testsuite/gfortran.dg/pr18210.f90 Normal file
View File

@ -0,0 +1,21 @@
! { dg-do run }
! Names in upper case and object names starting column 2
! Based on example provided by thomas.koenig@online.de
program pr18210
real :: a
character*80 :: buffer
namelist /foo/ a
a = 1.4
open (10, status = "scratch")
write (10,foo)
rewind (10)
read (10, '(a)') buffer
if (buffer(2:4) /= "FOO") call abort ()
read (10, '(a)') buffer
if (buffer(1:2) /= " A") call abort ()
close (10)
end program pr18210

22
gcc/testsuite/gfortran.dg/pr18392.f90 Normal file
View File

@ -0,0 +1,22 @@
! { dg-do run }
! pr 18392
! test namelist with derived types
! Based on example provided by thomas.koenig@online.de
program pr18392
implicit none
type foo
integer a
real b
end type foo
type(foo) :: a
namelist /nl/ a
open (10, status="scratch")
write (10,*) " &NL"
write (10,*) " A%A = 10,"
write (10,*) "/"
rewind (10)
read (10,nl)
close (10)
IF (a%a /= 10.0) call abort ()
end program pr18392

18
gcc/testsuite/gfortran.dg/pr19467.f90 Normal file
View File

@ -0,0 +1,18 @@
! { dg-do run }
! pr 19467
! test namelist with character arrays
! Based on example provided by paulthomas2@wanadoo.fr
program pr19467
implicit none
integer :: ier
character(len=2) :: ch(2)
character(len=2) :: dh(2)=(/"aa","bb"/)
namelist /a/ ch
open (10, status = "scratch")
write (10, *) "&A ch = 'aa' , 'bb' /"
rewind (10)
READ (10,nml=a, iostat = ier)
close (10)
if ((ier /= 0) .or. (any (ch /= dh))) call abort ()
end program pr19467

21
gcc/testsuite/gfortran.dg/pr19657.f Normal file
View File

@ -0,0 +1,21 @@
c { dg-do run }
c pr 19657
c test namelist not skipped if ending with logical.
c Based on example provided by fuyuki@ccsr.u-tokyo.ac.jp
program pr19657
implicit none
logical l
integer i, ctr
namelist /nm/ i, l
open (10, status = "scratch")
write (10,*) "&nm i=1,l=t &end"
write (10,*) "&nm i=2 &end"
write (10,*) "&nm i=3 &end"
rewind (10)
do ctr = 1,3
read (10,nm,end=190)
if (i.ne.ctr) call abort ()
enddo
190 continue
end

40
libgfortran/ChangeLog
View File

@ -1,3 +1,43 @@
2005-04-17 Paul Thomas <pault@gcc.gnu.org>
* io/list_read.c (eat_separator): at_eol = 1 replaced(zapped at some time?).
2005-04-17 Paul Thomas <pault@gcc.gnu.org>
PR libgfortran/12884
PR libgfortran/17285
PR libgfortran/18122
PR libgfortran/18210
PR libgfortran/18392
PR libgfortran/18591
PR libgfortran/18879
* io/io.h (nml_ls): Declare.
(namelist_info): Modify for arrays.
* io/list_read.c (namelist_read): Reduced to call to new functions.
(match_namelist_name): Simplified.
(nml_query): Handles stdin queries ? and =?. New function.
(nml_get_obj_data): Parses object name. New function.
(touch_nml_nodes): Marks objects for read. New function.
(untouch_nml_nodes): Resets objects. New function.
(parse_qualifier): Parses and checks qualifiers. New function
(nml_read_object): Reads and stores object data. New function.
(eat_separator): No new_record on '/' in namelist.
(finish_separator): No new_record on '/' in namelist.
(read_logical): Error return for namelist.
(read_integer): Error return for namelist.
(read_complex): Error return for namelist.
(read_real): Error return for namelist.
* io/lock.c (library_end): Free extended namelist_info types.
* io/transfer.c (st_set_nml_var): Modified for arrays.
(st_set_nml_var_dim): Dimension descriptors. New function.
* io/write.c (namelist_write): Reduced to call to new functions.
(nml_write_obj): Writes output for object. New function.
(write_integer): Suppress leading blanks for repeat counts.
(write_int): Suppress leading blanks for repeat counts.
(write_float): Suppress leading blanks for repeat counts.
(output_float): Suppress leading blanks for repeat counts.
2005-04-15 Thomas Koenig <Thomas.Koenig@online.de>
PR libfortran/18495

79
libgfortran/io/io.h
View File

@ -74,32 +74,75 @@ stream;
#define sseek(s, pos) ((s)->seek)(s, pos)
#define struncate(s) ((s)->truncate)(s)
/* Namelist represent object */
/*
/* Representation of a namelist object in libgfortran
Namelist Records
&groupname object=value [,object=value].../
&GROUPNAME OBJECT=value[s] [,OBJECT=value[s]].../
or
&groupname object=value [,object=value]...&groupname
&GROUPNAME OBJECT=value[s] [,OBJECT=value[s]]...&END
Even more complex, during the execution of a program containing a
namelist READ statement, you can specify a question mark character(?)
or a question mark character preceded by an equal sign(=?) to get
the information of the namelist group. By '?', the name of variables
in the namelist will be displayed, by '=?', the name and value of
variables will be displayed.
The object can be a fully qualified, compound name for an instrinsic
type, derived types or derived type components. So, a substring
a(:)%b(4)%ch(2:4)(1:7) has to be treated correctly in namelist
read. Hence full information about the structure of the object has
to be available to list_read.c and write.
All these requirements need a new data structure to record all info
about the namelist.
*/
These requirements are met by the following data structures.
nml_loop_spec contains the variables for the loops over index ranges
that are encountered. Since the variables can be negative, ssize_t
is used. */
typedef struct nml_loop_spec
{
/* Index counter for this dimension. */
ssize_t idx;
/* Start for the index counter. */
ssize_t start;
/* End for the index counter. */
ssize_t end;
/* Step for the index counter. */
ssize_t step;
}
nml_loop_spec;
/* namelist_info type contains all the scalar information about the
object and arrays of descriptor_dimension and nml_loop_spec types for
arrays. */
typedef struct namelist_type
{
char * var_name;
void * mem_pos;
int value_acquired;
int len;
int string_length;
/* Object type, stored as GFC_DTYPE_xxxx. */
bt type;
/* Object name. */
char * var_name;
/* Address for the start of the object's data. */
void * mem_pos;
/* Flag to show that a read is to be attempted for this node. */
int touched;
/* Length of intrinsic type in bytes. */
int len;
/* Rank of the object. */
int var_rank;
/* Overall size of the object in bytes. */
index_type size;
/* Length of character string. */
index_type string_length;
descriptor_dimension * dim;
nml_loop_spec * ls;
struct namelist_type * next;
}
namelist_info;

1055
libgfortran/io/list_read.c
View File

File diff suppressed because it is too large Load Diff

24
libgfortran/io/lock.c
View File

@ -1,5 +1,5 @@
/* Thread/recursion locking
Copyright 2002 Free Software Foundation, Inc.
Copyright 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org> and Andy Vaught
This file is part of the GNU Fortran 95 runtime library (libgfortran).
@ -73,20 +73,28 @@ library_end (void)
g.in_library = 0;
filename = NULL;
line = 0;
t = ioparm.library_return;
/* Delete the namelist, if it exists. */
if (ionml != NULL)
{
t1 = ionml;
while (t1 != NULL)
{
t2 = t1;
t1 = t1->next;
free_mem (t2);
}
{
t2 = t1;
t1 = t1->next;
free_mem (t2->var_name);
if (t2->var_rank)
{
free_mem (t2->dim);
free_mem (t2->ls);
}
free_mem (t2);
}
}
ionml = NULL;
memset (&ioparm, '\0', sizeof (ioparm));
ioparm.library_return = t;
}

119
libgfortran/io/transfer.c
View File

@ -1,5 +1,6 @@
/* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
Contributed by Andy Vaught
Namelist transfer functions contributed by Paul Thomas
This file is part of the GNU Fortran 95 runtime library (libgfortran).
@ -1623,94 +1624,78 @@ st_write_done (void)
library_end ();
}
/* Receives the scalar information for namelist objects and stores it
in a linked list of namelist_info types. */
static void
st_set_nml_var (void * var_addr, char * var_name, int var_name_len,
int kind, bt type, int string_length)
void
st_set_nml_var (void * var_addr, char * var_name, GFC_INTEGER_4 len,
gfc_charlen_type string_length, GFC_INTEGER_4 dtype)
{
namelist_info *t1 = NULL, *t2 = NULL;
namelist_info *nml = (namelist_info *) get_mem (sizeof (namelist_info));
namelist_info *t1 = NULL;
namelist_info *nml;
nml = (namelist_info*) get_mem (sizeof (namelist_info));
nml->mem_pos = var_addr;
if (var_name)
nml->var_name = (char*) get_mem (strlen (var_name) + 1);
strcpy (nml->var_name, var_name);
nml->len = (int) len;
nml->string_length = (index_type) string_length;
nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK);
nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT);
nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT);
if (nml->var_rank > 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;
nml->dim = (descriptor_dimension*)
get_mem (nml->var_rank * sizeof (descriptor_dimension));
nml->ls = (nml_loop_spec*)
get_mem (nml->var_rank * sizeof (nml_loop_spec));
}
else
{
assert (var_name_len == 0);
nml->var_name = NULL;
nml->dim = NULL;
nml->ls = NULL;
}
nml->len = kind;
nml->type = type;
nml->string_length = string_length;
nml->next = NULL;
if (ionml == NULL)
ionml = nml;
ionml = nml;
else
{
t1 = ionml;
while (t1 != NULL)
{
t2 = t1;
t1 = t1->next;
}
t2->next = nml;
for (t1 = ionml; t1->next; t1 = t1->next);
t1->next = nml;
}
return;
}
extern void st_set_nml_var_int (void *, char *, int, int);
export_proto(st_set_nml_var_int);
extern void st_set_nml_var_float (void *, char *, int, int);
export_proto(st_set_nml_var_float);
extern void st_set_nml_var_char (void *, char *, int, int, gfc_charlen_type);
export_proto(st_set_nml_var_char);
extern void st_set_nml_var_complex (void *, char *, int, int);
export_proto(st_set_nml_var_complex);
extern void st_set_nml_var_log (void *, char *, int, int);
export_proto(st_set_nml_var_log);
/* Store the dimensional information for the namelist object. */
void
st_set_nml_var_int (void * var_addr, char * var_name, int var_name_len,
int kind)
st_set_nml_var_dim (GFC_INTEGER_4 n_dim, GFC_INTEGER_4 stride,
GFC_INTEGER_4 lbound, GFC_INTEGER_4 ubound)
{
st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_INTEGER, 0);
namelist_info * nml;
int n;
n = (int)n_dim;
for (nml = ionml; nml->next; nml = nml->next);
nml->dim[n].stride = (ssize_t)stride;
nml->dim[n].lbound = (ssize_t)lbound;
nml->dim[n].ubound = (ssize_t)ubound;
}
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, 0);
}
extern void st_set_nml_var (void * ,char * ,
GFC_INTEGER_4 ,gfc_charlen_type ,GFC_INTEGER_4);
export_proto(st_set_nml_var);
void
st_set_nml_var_char (void * var_addr, char * var_name, int var_name_len,
int kind, gfc_charlen_type string_length)
{
st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_CHARACTER,
string_length);
}
extern void st_set_nml_var_dim (GFC_INTEGER_4, GFC_INTEGER_4,
GFC_INTEGER_4 ,GFC_INTEGER_4);
export_proto(st_set_nml_var_dim);
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, 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, 0);
}

387
libgfortran/io/write.c
View File

@ -1,5 +1,6 @@
/* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
Contributed by Andy Vaught
Namelist output contibuted by Paul Thomas
This file is part of the GNU Fortran 95 runtime library (libgfortran).
@ -29,6 +30,7 @@ Boston, MA 02111-1307, USA. */
#include "config.h"
#include <string.h>
#include <ctype.h>
#include <float.h>
#include <stdio.h>
#include <stdlib.h>
@ -44,6 +46,8 @@ typedef enum
sign_t;
static int no_leading_blank = 0 ;
void
write_a (fnode * f, const char *source, int len)
{
@ -576,7 +580,9 @@ output_float (fnode *f, double value, int len)
leadzero = 0;
/* Padd to full field width. */
if (nblanks > 0)
if ( ( nblanks > 0 ) && !no_leading_blank )
{
memset (out, ' ', nblanks);
out += nblanks;
@ -650,6 +656,13 @@ output_float (fnode *f, double value, int len)
#endif
memcpy (out, buffer, edigits);
}
if ( no_leading_blank )
{
out += edigits;
memset( out , ' ' , nblanks );
no_leading_blank = 0;
}
}
@ -802,13 +815,24 @@ write_int (fnode *f, const char *source, int len, char *(*conv) (uint64_t))
goto done;
}
if (!no_leading_blank)
{
memset (p, ' ', nblank);
p += nblank;
memset (p, '0', nzero);
p += nzero;
memcpy (p, q, digits);
}
else
{
memset (p, '0', nzero);
p += nzero;
memcpy (p, q, digits);
p += digits;
memset (p, ' ', nblank);
no_leading_blank = 0;
}
done:
return;
@ -1102,9 +1126,16 @@ write_integer (const char *source, int length)
if(width < digits )
width = digits ;
p = write_block (width) ;
if (no_leading_blank)
{
memcpy (p, q, digits);
memset(p + digits ,' ', width - digits) ;
}
else
{
memset(p ,' ', width - digits) ;
memcpy (p + width - digits, q, digits);
}
}
@ -1269,60 +1300,320 @@ list_formatted_write (bt type, void *p, int len)
char_flag = (type == BT_CHARACTER);
}
/* NAMELIST OUTPUT
nml_write_obj writes a namelist object to the output stream. It is called
recursively for derived type components:
obj = is the namelist_info for the current object.
offset = the offset relative to the address held by the object for
derived type arrays.
base = is the namelist_info of the derived type, when obj is a
component.
base_name = the full name for a derived type, including qualifiers
if any.
The returned value is a pointer to the object beyond the last one
accessed, including nested derived types. Notice that the namelist is
a linear linked list of objects, including derived types and their
components. A tree, of sorts, is implied by the compound names of
the derived type components and this is how this function recurses through
the list. */
/* A generous estimate of the number of characters needed to print
repeat counts and indices, including commas, asterices and brackets. */
#define NML_DIGITS 20
/* Stores the delimiter to be used for character objects. */
static char * nml_delim;
static namelist_info *
nml_write_obj (namelist_info * obj, index_type offset,
namelist_info * base, char * base_name)
{
int rep_ctr;
int num;
int nml_carry;
index_type len;
index_type obj_size;
index_type nelem;
index_type dim_i;
index_type clen;
index_type elem_ctr;
index_type obj_name_len;
void * p ;
char cup;
char * obj_name;
char * ext_name;
char rep_buff[NML_DIGITS];
namelist_info * cmp;
namelist_info * retval = obj->next;
/* Write namelist variable names in upper case. If a derived type,
nothing is output. If a component, base and base_name are set. */
if (obj->type != GFC_DTYPE_DERIVED)
{
write_character ("\n ", 2);
len = 0;
if (base)
{
len =strlen (base->var_name);
for (dim_i = 0; dim_i < strlen (base_name); dim_i++)
{
cup = toupper (base_name[dim_i]);
write_character (&cup, 1);
}
}
for (dim_i =len; dim_i < strlen (obj->var_name); dim_i++)
{
cup = toupper (obj->var_name[dim_i]);
write_character (&cup, 1);
}
write_character ("=", 1);
}
/* Counts the number of data output on a line, including names. */
num = 1;
len = obj->len;
obj_size = len;
if (obj->type == GFC_DTYPE_COMPLEX)
obj_size = 2*len;
if (obj->type == GFC_DTYPE_CHARACTER)
obj_size = obj->string_length;
if (obj->var_rank)
obj_size = obj->size;
/* Set the index vector and count the number of elements. */
nelem = 1;
for (dim_i=0; dim_i < obj->var_rank; dim_i++)
{
obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
nelem = nelem * (obj->dim[dim_i].ubound + 1 - obj->dim[dim_i].lbound);
}
/* Main loop to output the data held in the object. */
rep_ctr = 1;
for (elem_ctr = 0; elem_ctr < nelem; elem_ctr++)
{
/* Build the pointer to the data value. The offset is passed by
recursive calls to this function for arrays of derived types.
Is NULL otherwise. */
p = (void *)(obj->mem_pos + elem_ctr * obj_size);
p += offset;
/* Check for repeat counts of intrinsic types. */
if ((elem_ctr < (nelem - 1)) &&
(obj->type != GFC_DTYPE_DERIVED) &&
!memcmp (p, (void*)(p + obj_size ), obj_size ))
{
rep_ctr++;
}
/* Execute a repeated output. Note the flag no_leading_blank that
is used in the functions used to output the intrinsic types. */
else
{
if (rep_ctr > 1)
{
st_sprintf(rep_buff, " %d*", rep_ctr);
write_character (rep_buff, strlen (rep_buff));
no_leading_blank = 1;
}
num++;
/* Output the data, if an intrinsic type, or recurse into this
routine to treat derived types. */
switch (obj->type)
{
case GFC_DTYPE_INTEGER:
write_integer (p, len);
break;
case GFC_DTYPE_LOGICAL:
write_logical (p, len);
break;
case GFC_DTYPE_CHARACTER:
if (nml_delim)
write_character (nml_delim, 1);
write_character (p, obj->string_length);
if (nml_delim)
write_character (nml_delim, 1);
break;
case GFC_DTYPE_REAL:
write_real (p, len);
break;
case GFC_DTYPE_COMPLEX:
no_leading_blank = 0;
num++;
write_complex (p, len);
break;
case GFC_DTYPE_DERIVED:
/* To treat a derived type, we need to build two strings:
ext_name = the name, including qualifiers that prepends
component names in the output - passed to
nml_write_obj.
obj_name = the derived type name with no qualifiers but %
appended. This is used to identify the
components. */
/* First ext_name => get length of all possible components */
ext_name = (char*)get_mem ( (base_name ? strlen (base_name) : 0)
+ (base ? strlen (base->var_name) : 0)
+ strlen (obj->var_name)
+ obj->var_rank * NML_DIGITS);
strcpy(ext_name, base_name ? base_name : "");
clen = base ? strlen (base->var_name) : 0;
strcat (ext_name, obj->var_name + clen);
/* Append the qualifier. */
for (dim_i = 0; dim_i < obj->var_rank; dim_i++)
{
strcat (ext_name, dim_i ? "" : "(");
clen = strlen (ext_name);
st_sprintf (ext_name + clen, "%d", obj->ls[dim_i].idx);
strcat (ext_name, (dim_i == obj->var_rank - 1) ? ")" : ",");
}
/* Now obj_name. */
obj_name_len = strlen (obj->var_name) + 1;
obj_name = get_mem (obj_name_len+1);
strcpy (obj_name, obj->var_name);
strcat (obj_name, "%");
/* Now loop over the components. Update the component pointer
with the return value from nml_write_obj => this loop jumps
past nested derived types. */
for (cmp = obj->next;
cmp && !strncmp (cmp->var_name, obj_name, obj_name_len);
cmp = retval)
{
retval = nml_write_obj (cmp, (index_type)(p - obj->mem_pos),
obj, ext_name);
}
free_mem (obj_name);
free_mem (ext_name);
goto obj_loop;
default:
internal_error ("Bad type for namelist write");
}
/* Reset the leading blank suppression, write a comma and, if 5
values have been output, write a newline and advance to column
2. Reset the repeat counter. */
no_leading_blank = 0;
write_character (",", 1);
if (num > 5)
{
num = 0;
write_character ("\n ", 2);
}
rep_ctr = 1;
}
/* Cycle through and increment the index vector. */
obj_loop:
nml_carry = 1;
for (dim_i = 0; nml_carry && (dim_i < obj->var_rank); dim_i++)
{
obj->ls[dim_i].idx += nml_carry ;
nml_carry = 0;
if (obj->ls[dim_i].idx > (ssize_t)obj->dim[dim_i].ubound)
{
obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
nml_carry = 1;
}
}
}
/* Return a pointer beyond the furthest object accessed. */
return retval;
}
/* This is the entry function for namelist writes. It outputs the name
of the namelist and iterates through the namelist by calls to
nml_write_obj. The call below has dummys in the arguments used in
the treatment of derived types. */
void
namelist_write (void)
{
namelist_info * t1, *t2;
int len,num;
void * p;
namelist_info * t1, *t2, *dummy = NULL;
index_type i;
index_type dummy_offset = 0;
char c;
char * dummy_name = NULL;
unit_delim tmp_delim;
num = 0;
write_character("&",1);
write_character (ioparm.namelist_name, ioparm.namelist_name_len);
write_character("\n",1);
/* Set the delimiter for namelist output. */
tmp_delim = current_unit->flags.delim;
current_unit->flags.delim = DELIM_NONE;
switch (tmp_delim)
{
case (DELIM_QUOTE):
nml_delim = "\"";
break;
case (DELIM_APOSTROPHE):
nml_delim = "'";
break;
default:
nml_delim = NULL;
}
write_character ("&",1);
/* Write namelist name in upper case - f95 std. */
for (i = 0 ;i < ioparm.namelist_name_len ;i++ )
{
c = toupper (ioparm.namelist_name[i]);
write_character (&c ,1);
}
if (ionml != NULL)
{
t1 = ionml;
while (t1 != NULL)
{
num ++;
t2 = t1;
t1 = t1->next;
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)
{
case BT_INTEGER:
write_integer (p, len);
break;
case BT_LOGICAL:
write_logical (p, len);
break;
case BT_CHARACTER:
write_character (p, t2->string_length);
break;
case BT_REAL:
write_real (p, len);
break;
case BT_COMPLEX:
write_complex (p, len);
break;
default:
internal_error ("Bad type for namelist write");
}
write_character(",",1);
if (num > 5)
{
num = 0;
write_character("\n",1);
}
t2 = t1;
t1 = nml_write_obj (t2, dummy_offset, dummy, dummy_name);
}
}
write_character("/",1);
write_character (" /\n", 4);
/* Recover the original delimiter. */
current_unit->flags.delim = tmp_delim;
}
#undef NML_DIGITS