Skip to content

R
riscv-gcc-1
Commit 29dc5138 by Paul Thomas
Options

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

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

From-SVN: r98287
parent 3f620b5f
Showing with 2376 additions and 343 deletions
gcc/fortran/ChangeLog
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> 2005-04-17 Richard Guenther <rguenth@gcc.gnu.org>
* scanner.c (gfc_next_char_literal): Reset truncation flag * scanner.c (gfc_next_char_literal): Reset truncation flag
......
gcc/fortran/trans-io.c
...@@ -125,11 +125,8 @@ static GTY(()) tree iocall_iolength_done; ...@@ -125,11 +125,8 @@ static GTY(()) tree iocall_iolength_done;
static GTY(()) tree iocall_rewind; static GTY(()) tree iocall_rewind;
static GTY(()) tree iocall_backspace; static GTY(()) tree iocall_backspace;
static GTY(()) tree iocall_endfile; static GTY(()) tree iocall_endfile;
static GTY(()) tree iocall_set_nml_val_int; static GTY(()) tree iocall_set_nml_val;
static GTY(()) tree iocall_set_nml_val_float; static GTY(()) tree iocall_set_nml_val_dim;
static GTY(()) tree iocall_set_nml_val_char;
static GTY(()) tree iocall_set_nml_val_complex;
static GTY(()) tree iocall_set_nml_val_log;
/* Variable for keeping track of what the last data transfer statement /* Variable for keeping track of what the last data transfer statement
was. Used for deciding which subroutine to call when the data was. Used for deciding which subroutine to call when the data
...@@ -314,34 +311,19 @@ gfc_build_io_library_fndecls (void) ...@@ -314,34 +311,19 @@ gfc_build_io_library_fndecls (void)
gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")), gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
gfc_int4_type_node, 0); 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 = iocall_set_nml_val =
gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_float")), gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var")),
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")),
void_type_node, 5, 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_charlen_type_node,
gfc_charlen_type_node); gfc_int4_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);
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) ...@@ -815,11 +797,11 @@ gfc_trans_inquire (gfc_code * code)
return gfc_finish_block (&block); return gfc_finish_block (&block);
} }
static gfc_expr * static gfc_expr *
gfc_new_nml_name_expr (const char * name) gfc_new_nml_name_expr (const char * name)
{ {
gfc_expr * nml_name; gfc_expr * nml_name;
nml_name = gfc_get_expr(); nml_name = gfc_get_expr();
nml_name->ref = NULL; nml_name->ref = NULL;
nml_name->expr_type = EXPR_CONSTANT; nml_name->expr_type = EXPR_CONSTANT;
...@@ -832,114 +814,229 @@ gfc_new_nml_name_expr (const char * name) ...@@ -832,114 +814,229 @@ gfc_new_nml_name_expr (const char * name)
return nml_name; return nml_name;
} }
static gfc_expr * /* nml_full_name builds up the fully qualified name of a
get_new_var_expr(gfc_symbol * sym) 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; full_name_length = strlen (var_name) + strlen (cmp_name) + 1;
nml_var->ts = sym->ts; full_name = (char*)gfc_getmem (full_name_length + 1);
if (sym->as) strcpy (full_name, var_name);
nml_var->rank = sym->as->rank; full_name = strcat (full_name, "%");
nml_var->symtree = (gfc_symtree *)gfc_getmem (sizeof (gfc_symtree)); full_name = strcat (full_name, cmp_name);
nml_var->symtree->n.sym = sym; return full_name;
nml_var->where = sym->declared_at; }
/* 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; sym->attr.referenced = 1;
decl = gfc_get_symbol_decl (sym);
}
else
decl = c->backend_decl;
return nml_var; 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 a scalar variable STRING whose address is ADDR_EXPR, generate a /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
call to iocall_set_nml_val. For derived type variable, recursively call to iocall_set_nml_val. For derived type variable, recursively
generate calls to iocall_set_nml_val for each leaf field. The leafs generate calls to iocall_set_nml_val for each component. */
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 #define NML_FIRST_ARG(a) args = gfc_chainon_list (NULL_TREE, a)
variable, not of the field name. This causes a little complication #define NML_ADD_ARG(a) args = gfc_chainon_list (args, a)
documented below. */ #define IARG(i) build_int_cst (gfc_array_index_type, i)
static void static void
transfer_namelist_element (stmtblock_t * block, gfc_typespec * ts, tree addr_expr, transfer_namelist_element (stmtblock_t * block, const char * var_name,
tree string, tree string_length) gfc_symbol * sym, gfc_component * c,
tree base_addr)
{ {
tree tmp, args, arg2; gfc_typespec * ts = NULL;
tree expr; 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);
if (ts->type == BT_DERIVED) /* Build the namelist object name. */
{
gfc_component *c;
expr = gfc_build_indirect_ref (addr_expr);
for (c = ts->derived->components; c; c = c->next) string = gfc_build_cstring_const (var_name);
{ string = gfc_build_addr_expr (pchar_type_node, string);
tree field = c->backend_decl;
gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
tmp = build3 (COMPONENT_REF, TREE_TYPE (field),
expr, field, NULL_TREE);
if (c->dimension) /* Build ts, as and data address using symbol or component. */
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; ts = (sym) ? &sym->ts : &c->ts;
} as = (sym) ? sym->as : c->as;
args = gfc_chainon_list (NULL_TREE, addr_expr); addr_expr = nml_get_addr_expr (sym, c, base_addr);
args = gfc_chainon_list (args, string);
args = gfc_chainon_list (args, string_length); if (as)
arg2 = build_int_cst (gfc_array_index_type, ts->kind); rank = as->rank;
args = gfc_chainon_list (args,arg2);
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) switch (ts->type)
{ {
case BT_INTEGER: case BT_INTEGER:
tmp = gfc_build_function_call (iocall_set_nml_val_int, args); itype = GFC_DTYPE_INTEGER;
break; break;
case BT_LOGICAL:
case BT_CHARACTER: itype = GFC_DTYPE_LOGICAL;
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; break;
case BT_REAL: case BT_REAL:
tmp = gfc_build_function_call (iocall_set_nml_val_float, args); itype = GFC_DTYPE_REAL;
break; break;
case BT_LOGICAL:
tmp = gfc_build_function_call (iocall_set_nml_val_log, args);
break;
case BT_COMPLEX: case BT_COMPLEX:
tmp = gfc_build_function_call (iocall_set_nml_val_complex, args); itype = GFC_DTYPE_COMPLEX;
break;
case BT_DERIVED:
itype = GFC_DTYPE_DERIVED;
break;
case BT_CHARACTER:
itype = GFC_DTYPE_CHARACTER;
break; break;
default:
gcc_unreachable ();
}
default : dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT);
internal_error ("Bad namelist IO basetype (%d)", ts->type);
} }
/* 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); 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 *cmp;
/* Provide the RECORD_TYPE to build component references. */
tree expr = gfc_build_indirect_ref (addr_expr);
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);
}
}
} }
#undef IARG
#undef NML_ADD_ARG
#undef NML_FIRST_ARG
/* 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
out by now. */ out by now. */
...@@ -950,9 +1047,8 @@ build_dt (tree * function, gfc_code * code) ...@@ -950,9 +1047,8 @@ 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; tree tmp;
gfc_expr *nmlname, *nmlvar; gfc_expr *nmlname;
gfc_namelist *nml; gfc_namelist *nml;
gfc_se se,se2;
gfc_init_block (&block); gfc_init_block (&block);
gfc_init_block (&post_block); gfc_init_block (&post_block);
...@@ -1011,7 +1107,7 @@ build_dt (tree * function, gfc_code * code) ...@@ -1011,7 +1107,7 @@ build_dt (tree * function, gfc_code * code)
if (dt->namelist) if (dt->namelist)
{ {
if (dt->format_expr || dt->format_label) if (dt->format_expr || dt->format_label)
fatal_error("A format cannot be specified with a namelist"); 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);
...@@ -1022,18 +1118,8 @@ build_dt (tree * function, gfc_code * code) ...@@ -1022,18 +1118,8 @@ build_dt (tree * function, gfc_code * code)
set_flag (&block, ioparm_namelist_read_mode); set_flag (&block, ioparm_namelist_read_mode);
for (nml = dt->namelist->namelist; nml; nml = nml->next) for (nml = dt->namelist->namelist; nml; nml = nml->next)
{ transfer_namelist_element (&block, nml->sym->name, nml->sym,
gfc_init_se (&se, NULL); NULL, 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);
}
} }
tmp = gfc_build_function_call (*function, NULL_TREE); tmp = gfc_build_function_call (*function, NULL_TREE);
......
gcc/testsuite/ChangeLog
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> 2005-04-17 Richard Guenther <rguenth@gcc.gnu.org>
* gfortran.dg/wtruncate.f: New testcase. * gfortran.dg/wtruncate.f: New testcase.
......
gcc/testsuite/gfortran.dg/namelist_1.f90
! { dg-do compile } ! { dg-do compile }
! Check that public entities in private namelists are rejected ! Check that private entities in public namelists are rejected
module namelist_1 module namelist_1
public public
integer,private :: x integer,private :: x
namelist /n/ x ! { dg-error "cannot be member of PUBLIC namelist" "" } namelist /n/ x ! { dg-error "cannot be member of PUBLIC namelist" "" }
end module end module
gcc/testsuite/gfortran.dg/namelist_11.f 0 → 100644
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
gcc/testsuite/gfortran.dg/namelist_12.f 0 → 100644
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
gcc/testsuite/gfortran.dg/namelist_13.f90 0 → 100644
!{ 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
gcc/testsuite/gfortran.dg/namelist_14.f90 0 → 100644
!{ 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
gcc/testsuite/gfortran.dg/namelist_15.f90 0 → 100644
!{ 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
gcc/testsuite/gfortran.dg/namelist_16.f90 0 → 100644
!{ 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
gcc/testsuite/gfortran.dg/namelist_17.f90 0 → 100644
!{ 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
gcc/testsuite/gfortran.dg/namelist_18.f90 0 → 100644
!{ 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
gcc/testsuite/gfortran.dg/namelist_19.f90 0 → 100644
!{ 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
gcc/testsuite/gfortran.dg/namelist_2.f90 0 → 100644
! { 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
gcc/testsuite/gfortran.dg/namelist_20.f90 0 → 100644
!{ 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
gcc/testsuite/gfortran.dg/namelist_3.f90 0 → 100644
! { 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
gcc/testsuite/gfortran.dg/pr12884.f 0 → 100644
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
gcc/testsuite/gfortran.dg/pr17285.f90 0 → 100644
! { 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
gcc/testsuite/gfortran.dg/pr17472.f 0 → 100644
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
gcc/testsuite/gfortran.dg/pr18122.f90 0 → 100644
! { 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
gcc/testsuite/gfortran.dg/pr18210.f90 0 → 100644
! { 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
gcc/testsuite/gfortran.dg/pr18392.f90 0 → 100644
! { 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
gcc/testsuite/gfortran.dg/pr19467.f90 0 → 100644
! { 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
gcc/testsuite/gfortran.dg/pr19657.f 0 → 100644
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
libgfortran/ChangeLog
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> 2005-04-15 Thomas Koenig <Thomas.Koenig@online.de>
PR libfortran/18495 PR libfortran/18495
......
libgfortran/io/io.h
...@@ -74,32 +74,75 @@ stream; ...@@ -74,32 +74,75 @@ stream;
#define sseek(s, pos) ((s)->seek)(s, pos) #define sseek(s, pos) ((s)->seek)(s, pos)
#define struncate(s) ((s)->truncate)(s) #define struncate(s) ((s)->truncate)(s)
/* Namelist represent object */ /* Representation of a namelist object in libgfortran
/*
Namelist Records Namelist Records
&groupname object=value [,object=value].../ &GROUPNAME OBJECT=value[s] [,OBJECT=value[s]].../
or or
&groupname object=value [,object=value]...&groupname &GROUPNAME OBJECT=value[s] [,OBJECT=value[s]]...&END
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.
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
{
Even more complex, during the execution of a program containing a /* Index counter for this dimension. */
namelist READ statement, you can specify a question mark character(?) ssize_t idx;
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.
All these requirements need a new data structure to record all info /* Start for the index counter. */
about the namelist. 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 typedef struct namelist_type
{ {
/* Object type, stored as GFC_DTYPE_xxxx. */
bt type;
/* Object name. */
char * var_name; char * var_name;
/* Address for the start of the object's data. */
void * mem_pos; void * mem_pos;
int value_acquired;
/* Flag to show that a read is to be attempted for this node. */
int touched;
/* Length of intrinsic type in bytes. */
int len; int len;
int string_length;
bt type; /* 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; struct namelist_type * next;
} }
namelist_info; namelist_info;
......
libgfortran/io/list_read.c
/* Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc. /* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
Contributed by Andy Vaught Contributed by Andy Vaught
Namelist input contributed by Paul Thomas
This file is part of the GNU Fortran 95 runtime library (libgfortran). This file is part of the GNU Fortran 95 runtime library (libgfortran).
...@@ -50,13 +51,22 @@ Boston, MA 02111-1307, USA. */ ...@@ -50,13 +51,22 @@ Boston, MA 02111-1307, USA. */
ourselves. Data is buffered in scratch[] until it becomes too ourselves. Data is buffered in scratch[] until it becomes too
large, after which we start allocating memory on the heap. */ large, after which we start allocating memory on the heap. */
static int repeat_count, saved_length, saved_used, input_complete, at_eol; static int repeat_count, saved_length, saved_used;
static int comma_flag, namelist_mode; static int input_complete, at_eol, comma_flag;
static char last_char, *saved_string; static char last_char, *saved_string;
static bt saved_type; static bt saved_type;
/* A namelist specific flag used in the list directed library
to flag that calls are being made from namelist read (eg. to ignore
comments or to treat '/' as a terminator) */
static int namelist_mode;
/* A namelist specific flag used in the list directed library to flag
read errors and return, so that an attempt can be made to read a
new object name. */
static int nml_read_error;
/* Storage area for values except for strings. Must be large enough /* Storage area for values except for strings. Must be large enough
to hold a complex value (two reals) of the largest kind. */ to hold a complex value (two reals) of the largest kind. */
...@@ -226,12 +236,16 @@ eat_separator (void) ...@@ -226,12 +236,16 @@ eat_separator (void)
case '/': case '/':
input_complete = 1; input_complete = 1;
if (!namelist_mode)
{
next_record (0); next_record (0);
at_eol = 1; at_eol = 1;
}
break; break;
case '\n': case '\n':
case '\r': case '\r':
at_eol = 1;
break; break;
case '!': case '!':
...@@ -282,7 +296,7 @@ finish_separator (void) ...@@ -282,7 +296,7 @@ finish_separator (void)
case '/': case '/':
input_complete = 1; input_complete = 1;
next_record (0); if (!namelist_mode) next_record (0);
break; break;
case '\n': case '\n':
...@@ -305,6 +319,21 @@ finish_separator (void) ...@@ -305,6 +319,21 @@ finish_separator (void)
} }
} }
/* This function is needed to catch bad conversions so that namelist can
attempt to see if saved_string contains a new object name rather than
a bad value. */
static int
nml_bad_return (char c)
{
if (namelist_mode)
{
nml_read_error = 1;
unget_char(c);
return 1;
}
return 0;
}
/* Convert an unsigned string to an integer. The length value is -1 /* Convert an unsigned string to an integer. The length value is -1
if we are working on a repeat count. Returns nonzero if we have a if we are working on a repeat count. Returns nonzero if we have a
...@@ -525,6 +554,10 @@ read_logical (int length) ...@@ -525,6 +554,10 @@ read_logical (int length)
return; return;
bad_logical: bad_logical:
if (nml_bad_return (c))
return;
st_sprintf (message, "Bad logical value while reading item %d", st_sprintf (message, "Bad logical value while reading item %d",
g.item_count); g.item_count);
...@@ -641,6 +674,10 @@ read_integer (int length) ...@@ -641,6 +674,10 @@ read_integer (int length)
} }
bad_integer: bad_integer:
if (nml_bad_return (c))
return;
free_saved (); free_saved ();
st_sprintf (message, "Bad integer for item %d in list input", g.item_count); st_sprintf (message, "Bad integer for item %d in list input", g.item_count);
...@@ -976,6 +1013,10 @@ read_complex (int length) ...@@ -976,6 +1013,10 @@ read_complex (int length)
return; return;
bad_complex: bad_complex:
if (nml_bad_return (c))
return;
st_sprintf (message, "Bad complex value in item %d of list input", st_sprintf (message, "Bad complex value in item %d of list input",
g.item_count); g.item_count);
...@@ -1186,6 +1227,10 @@ read_real (int length) ...@@ -1186,6 +1227,10 @@ read_real (int length)
return; return;
bad_real: bad_real:
if (nml_bad_return (c))
return;
st_sprintf (message, "Bad real number in item %d of list input", st_sprintf (message, "Bad real number in item %d of list input",
g.item_count); g.item_count);
...@@ -1380,6 +1425,209 @@ finish_list_read (void) ...@@ -1380,6 +1425,209 @@ finish_list_read (void)
while (c != '\n'); while (c != '\n');
} }
/* NAMELIST INPUT
void namelist_read (void)
calls:
static void nml_match_name (char *name, int len)
static int nml_query (void)
static int nml_get_obj_data (void)
calls:
static void nml_untouch_nodes (void)
static namelist_info * find_nml_node (char * var_name)
static int nml_parse_qualifier(descriptor_dimension * ad,
nml_loop_spec * ls, int rank)
static void nml_touch_nodes (namelist_info * nl)
static int nml_read_obj (namelist_info * nl, index_type offset)
calls:
-itself- */
/* Carries error messages from the qualifier parser. */
static char parse_err_msg[30];
/* Carries error messages for error returns. */
static char nml_err_msg[100];
/* Pointer to the previously read object, in case attempt is made to read
new object name. Should this fail, error message can give previous
name. */
static namelist_info * prev_nl;
/* Lower index for substring qualifier. */
static index_type clow;
/* Upper index for substring qualifier. */
static index_type chigh;
/* Inputs a rank-dimensional qualifier, which can contain
singlets, doublets, triplets or ':' with the standard meanings. */
static try
nml_parse_qualifier(descriptor_dimension * ad,
nml_loop_spec * ls, int rank)
{
int dim;
int indx;
int neg;
int null_flag;
char c;
/* The next character in the stream should be the '('. */
c = next_char ();
/* Process the qualifier, by dimension and triplet. */
for (dim=0; dim < rank; dim++ )
{
for (indx=0; indx<3; indx++)
{
free_saved ();
eat_spaces ();
neg = 0;
/*process a potential sign. */
c = next_char ();
switch (c)
{
case '-':
neg = 1;
break;
case '+':
break;
default:
unget_char (c);
break;
}
/*process characters up to the next ':' , ',' or ')' */
for (;;)
{
c = next_char ();
switch (c)
{
case ':':
break;
case ',': case ')':
if ( (c==',' && dim == rank -1)
|| (c==')' && dim < rank -1))
{
st_sprintf (parse_err_msg,
"Bad number of index fields");
goto err_ret;
}
break;
CASE_DIGITS:
push_char (c);
continue;
case ' ': case '\t':
eat_spaces ();
c = next_char ();
break;
default:
st_sprintf (parse_err_msg, "Bad character in index");
goto err_ret;
}
if (( c==',' || c==')') && indx==0 && saved_string == 0 )
{
st_sprintf (parse_err_msg, "Null index field");
goto err_ret;
}
if ( ( c==':' && indx==1 && saved_string == 0)
|| (indx==2 && saved_string == 0))
{
st_sprintf(parse_err_msg, "Bad index triplet");
goto err_ret;
}
/* If '( : ? )' or '( ? : )' break and flag read failure. */
null_flag = 0;
if ( (c==':' && indx==0 && saved_string == 0)
|| (indx==1 && saved_string == 0))
{
null_flag = 1;
break;
}
/* Now read the index. */
if (convert_integer (sizeof(int),neg))
{
st_sprintf (parse_err_msg, "Bad integer in index");
goto err_ret;
}
break;
}
/*feed the index values to the triplet arrays. */
if (!null_flag)
{
if (indx == 0)
ls[dim].start = *(int *)value;
if (indx == 1)
ls[dim].end = *(int *)value;
if (indx == 2)
ls[dim].step = *(int *)value;
}
/*singlet or doublet indices */
if (c==',' || c==')')
{
if (indx == 0)
{
ls[dim].start = *(int *)value;
ls[dim].end = *(int *)value;
}
break;
}
}
/*Check the values of the triplet indices. */
if ( (ls[dim].start > (ssize_t)ad[dim].ubound)
|| (ls[dim].start < (ssize_t)ad[dim].lbound)
|| (ls[dim].end > (ssize_t)ad[dim].ubound)
|| (ls[dim].end < (ssize_t)ad[dim].lbound))
{
st_sprintf (parse_err_msg, "Index %d out of range", dim + 1);
goto err_ret;
}
if (((ls[dim].end - ls[dim].start ) * ls[dim].step < 0)
|| (ls[dim].step == 0))
{
st_sprintf (parse_err_msg, "Bad range in index %d", dim + 1);
goto err_ret;
}
/* Initialise the loop index counter. */
ls[dim].idx = ls[dim].start;
}
eat_spaces ();
return SUCCESS;
err_ret:
return FAILURE;
}
static namelist_info * static namelist_info *
find_nml_node (char * var_name) find_nml_node (char * var_name)
{ {
...@@ -1388,7 +1636,7 @@ find_nml_node (char * var_name) ...@@ -1388,7 +1636,7 @@ find_nml_node (char * var_name)
{ {
if (strcmp (var_name,t->var_name) == 0) if (strcmp (var_name,t->var_name) == 0)
{ {
t->value_acquired = 1; t->touched = 1;
return t; return t;
} }
t = t->next; t = t->next;
...@@ -1396,168 +1644,691 @@ find_nml_node (char * var_name) ...@@ -1396,168 +1644,691 @@ find_nml_node (char * var_name)
return NULL; return NULL;
} }
/* Visits all the components of a derived type that have
not explicitly been identified in the namelist input.
touched is set and the loop specification initialised
to default values */
static void static void
match_namelist_name (char *name, int len) nml_touch_nodes (namelist_info * nl)
{ {
int name_len; index_type len = strlen (nl->var_name) + 1;
char c; int dim;
char * namelist_name = name; char * ext_name = (char*)get_mem (len + 1);
strcpy (ext_name, nl->var_name);
strcat (ext_name, "%");
for (nl = nl->next; nl; nl = nl->next)
{
if (strncmp (nl->var_name, ext_name, len) == 0)
{
nl->touched = 1;
for (dim=0; dim < nl->var_rank; dim++)
{
nl->ls[dim].step = 1;
nl->ls[dim].end = nl->dim[dim].ubound;
nl->ls[dim].start = nl->dim[dim].lbound;
nl->ls[dim].idx = nl->ls[dim].start;
}
}
else
break;
}
return;
}
name_len = 0; /* Resets touched for the entire list of nml_nodes, ready for a
/* Match the name of the namelist. */ new object. */
if (tolower (next_char ()) != tolower (namelist_name[name_len++])) static void
{ nml_untouch_nodes (void)
wrong_name: {
generate_error (ERROR_READ_VALUE, "Wrong namelist name found"); namelist_info * t;
for (t = ionml; t; t = t->next)
t->touched = 0;
return; return;
} }
/* Attempts to input name to namelist name. Returns nml_read_error = 1
on no match. */
while (name_len < len) static void
nml_match_name (char *name, index_type len)
{
index_type i;
char c;
nml_read_error = 0;
for (i = 0; i < len; i++)
{ {
c = next_char (); c = next_char ();
if (tolower (c) != tolower (namelist_name[name_len++])) if (tolower (c) != tolower (name[i]))
goto wrong_name; {
nml_read_error = 1;
break;
}
} }
} }
/* If the namelist read is from stdin, output the current state of the
namelist to stdout. This is used to implement the non-standard query
features, ? and =?. If c == '=' the full namelist is printed. Otherwise
the names alone are printed. */
/******************************************************************** static void
Namelist reads nml_query (char c)
********************************************************************/
/* Process a namelist read. This subroutine initializes things,
positions to the first element and
FIXME: was this comment ever complete? */
void
namelist_read (void)
{ {
char c; gfc_unit * temp_unit;
int name_matched, next_name ;
namelist_info * nl; namelist_info * nl;
int len, m; index_type len;
void * p; char * p;
namelist_mode = 1; if (current_unit->unit_number != options.stdin_unit)
return;
if (setjmp (g.eof_jump)) /* Store the current unit and transfer to stdout. */
temp_unit = current_unit;
current_unit = find_unit (options.stdout_unit);
if (current_unit)
{ {
generate_error (ERROR_END, NULL); g.mode =WRITING;
return; next_record (0);
}
restart: /* Write the namelist in its entirety. */
c = next_char ();
switch (c) if (c == '=')
namelist_write ();
/* Or write the list of names. */
else
{ {
case ' ':
goto restart;
case '!':
do
c = next_char ();
while (c != '\n');
goto restart; /* "&namelist_name\n" */
case '&': len = ioparm.namelist_name_len;
break; p = write_block (len + 2);
if (!p)
goto query_return;
memcpy (p, "&", 1);
memcpy ((char*)(p + 1), ioparm.namelist_name, len);
memcpy ((char*)(p + len + 1), "\n", 1);
for (nl =ionml; nl; nl = nl->next)
{
default: /* " var_name\n" */
generate_error (ERROR_READ_VALUE, "Invalid character in namelist");
return; len = strlen (nl->var_name);
p = write_block (len + 2);
if (!p)
goto query_return;
memcpy (p, " ", 1);
memcpy ((char*)(p + 1), nl->var_name, len);
memcpy ((char*)(p + len + 1), "\n", 1);
} }
/* Match the name of the namelist. */ /* "&end\n" */
match_namelist_name(ioparm.namelist_name, ioparm.namelist_name_len);
/* Ready to read namelist elements. */ p = write_block (5);
while (!input_complete) if (!p)
{ goto query_return;
c = next_char (); memcpy (p, "&end\n", 5);
switch (c) }
/* Flush the stream to force immediate output. */
flush (current_unit->s);
}
query_return:
/* Restore the current unit. */
current_unit = temp_unit;
g.mode = READING;
return;
}
/* Reads and stores the input for the namelist object nl. For an array,
the function loops over the ranges defined by the loop specification.
This default to all the data or to the specification from a qualifier.
nml_read_obj recursively calls itself to read derived types. It visits
all its own components but only reads data for those that were touched
when the name was parsed. If a read error is encountered, an attempt is
made to return to read a new object name because the standard allows too
little data to be available. On the other hand, too much data is an
error. */
static try
nml_read_obj (namelist_info * nl, index_type offset)
{
namelist_info * cmp;
char * obj_name;
int nml_carry;
int len;
int dim;
index_type dlen;
index_type m;
index_type obj_name_len;
void * pdata ;
/* This object not touched in name parsing. */
if (!nl->touched)
return SUCCESS;
repeat_count = 0;
eat_spaces();
len = nl->len;
switch (nl->type)
{ {
case '/':
input_complete = 1; case GFC_DTYPE_INTEGER:
next_record (0); case GFC_DTYPE_LOGICAL:
case GFC_DTYPE_REAL:
dlen = len;
break; break;
case '&':
match_namelist_name("end",3); case GFC_DTYPE_COMPLEX:
return; dlen = 2* len;
case '\\':
return;
case ' ':
case '\n':
case '\r':
case '\t':
break; break;
case ',':
next_name = 1; case GFC_DTYPE_CHARACTER:
dlen = chigh ? (chigh - clow + 1) : nl->string_length;
break; break;
case '=': default:
name_matched = 1; dlen = 0;
nl = find_nml_node (saved_string); }
if (nl == NULL)
internal_error ("Can not match a namelist variable");
free_saved();
len = nl->len; do
p = nl->mem_pos; {
/* skip any blanks or tabs after the = */ /* Update the pointer to the data, using the current index vector */
eat_spaces ();
pdata = (void*)(nl->mem_pos + offset);
for (dim = 0; dim < nl->var_rank; dim++)
pdata = (void*)(pdata + (nl->ls[dim].idx - nl->dim[dim].lbound) *
nl->dim[dim].stride * nl->size);
/* Reset the error flag and try to read next value, if
repeat_count=0 */
nml_read_error = 0;
nml_carry = 0;
if (--repeat_count <= 0)
{
if (input_complete)
return SUCCESS;
if (at_eol)
finish_separator ();
if (input_complete)
return SUCCESS;
/* GFC_TYPE_UNKNOWN through for nulls and is detected
after the switch block. */
saved_type = GFC_DTYPE_UNKNOWN;
free_saved ();
switch (nl->type) switch (nl->type)
{ {
case BT_INTEGER: case GFC_DTYPE_INTEGER:
read_integer (len); read_integer (len);
break; break;
case BT_LOGICAL:
case GFC_DTYPE_LOGICAL:
read_logical (len); read_logical (len);
break; break;
case BT_CHARACTER:
case GFC_DTYPE_CHARACTER:
read_character (len); read_character (len);
break; break;
case BT_REAL:
case GFC_DTYPE_REAL:
read_real (len); read_real (len);
break; break;
case BT_COMPLEX:
case GFC_DTYPE_COMPLEX:
read_complex (len); read_complex (len);
break; break;
case GFC_DTYPE_DERIVED:
obj_name_len = strlen (nl->var_name) + 1;
obj_name = get_mem (obj_name_len+1);
strcpy (obj_name, nl->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 by testing if the potential
component name contains '%'. */
for (cmp = nl->next;
cmp &&
!strncmp (cmp->var_name, obj_name, obj_name_len) &&
!strchr (cmp->var_name + obj_name_len, '%');
cmp = cmp->next)
{
if (nml_read_obj (cmp, (index_type)(pdata - nl->mem_pos)) == FAILURE)
return FAILURE;
if (input_complete)
return SUCCESS;
}
free_mem (obj_name);
goto incr_idx;
default: default:
internal_error ("Bad type for namelist read"); st_sprintf (nml_err_msg, "Bad type for namelist object %s",
nl->var_name );
internal_error (nml_err_msg);
goto nml_err_ret;
} }
}
/* The standard permits array data to stop short of the number of
elements specified in the loop specification. In this case, we
should be here with nml_read_error != 0. Control returns to
nml_get_obj_data and an attempt is made to read object name. */
prev_nl = nl;
if (nml_read_error)
return SUCCESS;
if (saved_type == GFC_DTYPE_UNKNOWN)
goto incr_idx;
/* Note the switch from GFC_DTYPE_type to BT_type at this point.
This comes about because the read functions return BT_types. */
switch (saved_type) switch (saved_type)
{ {
case BT_COMPLEX:
len = 2 * len;
/* Fall through... */
case BT_INTEGER: case BT_COMPLEX:
case BT_REAL: case BT_REAL:
case BT_INTEGER:
case BT_LOGICAL: case BT_LOGICAL:
memcpy (p, value, len); memcpy (pdata, value, dlen);
break; break;
case BT_CHARACTER: case BT_CHARACTER:
m = (len < saved_used) ? len : saved_used; m = (dlen < saved_used) ? dlen : saved_used;
memcpy (p, saved_string, m); pdata = (void*)( pdata + clow - 1 );
memcpy (pdata, saved_string, m);
if (m < len) if (m < dlen)
memset (((char *) p) + m, ' ', len - m); memset ((void*)( pdata + m ), ' ', dlen - m);
break; break;
case BT_NULL: default:
break; break;
} }
/* Break out of loop if scalar. */
if (!nl->var_rank)
break; break;
/* Now increment the index vector. */
incr_idx:
nml_carry = 1;
for (dim = 0; dim < nl->var_rank; dim++)
{
nl->ls[dim].idx += nml_carry * nl->ls[dim].step;
nml_carry = 0;
if (((nl->ls[dim].step > 0) && (nl->ls[dim].idx > nl->ls[dim].end))
||
((nl->ls[dim].step < 0) && (nl->ls[dim].idx < nl->ls[dim].end)))
{
nl->ls[dim].idx = nl->ls[dim].start;
nml_carry = 1;
}
}
} while (!nml_carry);
if (repeat_count > 1)
{
st_sprintf (nml_err_msg, "Repeat count too large for namelist object %s" ,
nl->var_name );
goto nml_err_ret;
}
return SUCCESS;
nml_err_ret:
return FAILURE;
}
/* Parses the object name, including array and substring qualifiers. It
iterates over derived type components, touching those components and
setting their loop specifications, if there is a qualifier. If the
object is itself a derived type, its components and subcomponents are
touched. nml_read_obj is called at the end and this reads the data in
the manner specified by the object name. */
static try
nml_get_obj_data (void)
{
char c;
char * ext_name;
namelist_info * nl;
namelist_info * first_nl;
namelist_info * root_nl;
int dim;
int component_flag;
/* Look for end of input or object name. If '?' or '=?' are encountered
in stdin, print the node names or the namelist to stdout. */
eat_separator ();
if (input_complete)
return SUCCESS;
if ( at_eol )
finish_separator ();
if (input_complete)
return SUCCESS;
c = next_char ();
switch (c)
{
case '=':
c = next_char ();
if (c != '?')
{
st_sprintf (nml_err_msg, "namelist read: missplaced = sign");
goto nml_err_ret;
}
nml_query ('=');
return SUCCESS;
case '?':
nml_query ('?');
return SUCCESS;
case '$':
case '&':
nml_match_name ("end", 3);
if (nml_read_error)
{
st_sprintf (nml_err_msg, "namelist not terminated with / or &end");
goto nml_err_ret;
}
case '/':
input_complete = 1;
return SUCCESS;
default : default :
break;
}
/* Untouch all nodes of the namelist and reset the flag that is set for
derived type components. */
nml_untouch_nodes();
component_flag = 0;
/* Get the object name - should '!' and '\n' be permitted separators? */
get_name:
free_saved ();
do
{
push_char(tolower(c)); push_char(tolower(c));
c = next_char ();
} while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' ));
unget_char (c);
/* Check that the name is in the namelist and get pointer to object.
Three error conditions exist: (i) An attempt is being made to
identify a non-existent object, following a failed data read or
(ii) The object name does not exist or (iii) Too many data items
are present for an object. (iii) gives the same error message
as (i) */
push_char ('\0');
if (component_flag)
{
ext_name = (char*)get_mem (strlen (root_nl->var_name) +
saved_string ? strlen (saved_string) : 0 + 1);
strcpy (ext_name, root_nl->var_name);
strcat (ext_name, saved_string);
nl = find_nml_node (ext_name);
}
else
nl = find_nml_node (saved_string);
if (nl == NULL)
{
if (nml_read_error && prev_nl)
st_sprintf (nml_err_msg, "Bad data for namelist object %s",
prev_nl->var_name);
else
st_sprintf (nml_err_msg, "Cannot match namelist object name %s",
saved_string);
goto nml_err_ret;
}
/* Get the length, data length, base pointer and rank of the variable.
Set the default loop specification first. */
for (dim=0; dim < nl->var_rank; dim++)
{
nl->ls[dim].step = 1;
nl->ls[dim].end = nl->dim[dim].ubound;
nl->ls[dim].start = nl->dim[dim].lbound;
nl->ls[dim].idx = nl->ls[dim].start;
}
/* Check to see if there is a qualifier: if so, parse it.*/
if (c == '(' && nl->var_rank)
{
if (nml_parse_qualifier (nl->dim, nl->ls, nl->var_rank) == FAILURE)
{
st_sprintf (nml_err_msg, "%s for namelist variable %s",
parse_err_msg, nl->var_name);
goto nml_err_ret;
}
c = next_char ();
unget_char (c);
}
/* Now parse a derived type component. The root namelist_info address
is backed up, as is the previous component level. The component flag
is set and the iteration is made by jumping back to get_name. */
if (c == '%')
{
if (nl->type != GFC_DTYPE_DERIVED)
{
st_sprintf (nml_err_msg, "Attempt to get derived component for %s",
nl->var_name);
goto nml_err_ret;
}
if (!component_flag)
first_nl = nl;
root_nl = nl;
component_flag = 1;
c = next_char ();
goto get_name;
}
/* Parse a character qualifier, if present. chigh = 0 is a default
that signals that the string length = string_length. */
clow = 1;
chigh = 0;
if (c == '(' && nl->type == GFC_DTYPE_CHARACTER)
{
descriptor_dimension chd[1] = {1, clow, nl->string_length};
nml_loop_spec ind[1] = {1, clow, nl->string_length, 1};
if (nml_parse_qualifier (chd, ind, 1) == FAILURE)
{
st_sprintf (nml_err_msg, "%s for namelist variable %s",
parse_err_msg, nl->var_name);
goto nml_err_ret;
}
clow = ind[0].start;
chigh = ind[0].end;
if (ind[0].step != 1)
{
st_sprintf (nml_err_msg,
"Bad step in substring for namelist object %s",
nl->var_name);
goto nml_err_ret;
}
c = next_char ();
unget_char (c);
}
/* If a derived type touch its components and restore the root
namelist_info if we have parsed a qualified derived type
component. */
if (nl->type == GFC_DTYPE_DERIVED)
nml_touch_nodes (nl);
if (component_flag)
nl = first_nl;
/*make sure no extraneous qualifiers are there.*/
if (c == '(')
{
st_sprintf (nml_err_msg, "Qualifier for a scalar or non-character"
" namelist object %s", nl->var_name);
goto nml_err_ret;
}
/* According to the standard, an equal sign MUST follow an object name. The
following is possibly lax - it allows comments, blank lines and so on to
intervene. eat_spaces (); c = next_char (); would be compliant*/
free_saved ();
eat_separator ();
if (input_complete)
return SUCCESS;
if (at_eol)
finish_separator ();
if (input_complete)
return SUCCESS;
c = next_char ();
if (c != '=')
{
st_sprintf (nml_err_msg, "Equal sign must follow namelist object name %s",
nl->var_name);
goto nml_err_ret;
}
if (nml_read_obj (nl, 0) == FAILURE)
goto nml_err_ret;
return SUCCESS;
nml_err_ret:
return FAILURE;
}
/* Entry point for namelist input. Goes through input until namelist name
is matched. Then cycles through nml_get_obj_data until the input is
completed or there is an error. */
void
namelist_read (void)
{
char c;
namelist_mode = 1;
input_complete = 0;
if (setjmp (g.eof_jump))
{
generate_error (ERROR_END, NULL);
return;
}
/* Look for &namelist_name . Skip all characters, testing for $nmlname.
Exit on success or EOF. If '?' or '=?' encountered in stdin, print
node names or namelist on stdout. */
find_nml_name:
switch (c = next_char ())
{
case '$':
case '&':
break; break;
case '=':
c = next_char ();
if (c == '?')
nml_query ('=');
else
unget_char (c);
goto find_nml_name;
case '?':
nml_query ('?');
default:
goto find_nml_name;
} }
/* Match the name of the namelist. */
nml_match_name (ioparm.namelist_name, ioparm.namelist_name_len);
if (nml_read_error)
goto find_nml_name;
/* Ready to read namelist objects. If there is an error in input
from stdin, output the error message and continue. */
while (!input_complete)
{
if (nml_get_obj_data () == FAILURE)
{
if (current_unit->unit_number != options.stdin_unit)
goto nml_err_ret;
st_printf ("%s\n", nml_err_msg);
flush (find_unit (options.stderr_unit)->s);
}
} }
return;
/* All namelist error calls return from here */
nml_err_ret:
generate_error (ERROR_READ_VALUE , nml_err_msg);
return;
} }
libgfortran/io/lock.c
/* Thread/recursion locking /* 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 Contributed by Paul Brook <paul@nowt.org> and Andy Vaught
This file is part of the GNU Fortran 95 runtime library (libgfortran). This file is part of the GNU Fortran 95 runtime library (libgfortran).
...@@ -73,8 +73,10 @@ library_end (void) ...@@ -73,8 +73,10 @@ library_end (void)
g.in_library = 0; g.in_library = 0;
filename = NULL; filename = NULL;
line = 0; line = 0;
t = ioparm.library_return; t = ioparm.library_return;
/* Delete the namelist, if it exists. */
if (ionml != NULL) if (ionml != NULL)
{ {
t1 = ionml; t1 = ionml;
...@@ -82,11 +84,17 @@ library_end (void) ...@@ -82,11 +84,17 @@ library_end (void)
{ {
t2 = t1; t2 = t1;
t1 = t1->next; t1 = t1->next;
free_mem (t2->var_name);
if (t2->var_rank)
{
free_mem (t2->dim);
free_mem (t2->ls);
}
free_mem (t2); free_mem (t2);
} }
} }
ionml = NULL; ionml = NULL;
memset (&ioparm, '\0', sizeof (ioparm)); memset (&ioparm, '\0', sizeof (ioparm));
ioparm.library_return = t; ioparm.library_return = t;
} }
libgfortran/io/transfer.c
/* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc. /* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
Contributed by Andy Vaught Contributed by Andy Vaught
Namelist transfer functions contributed by Paul Thomas
This file is part of the GNU Fortran 95 runtime library (libgfortran). This file is part of the GNU Fortran 95 runtime library (libgfortran).
...@@ -1623,94 +1624,78 @@ st_write_done (void) ...@@ -1623,94 +1624,78 @@ st_write_done (void)
library_end (); library_end ();
} }
/* Receives the scalar information for namelist objects and stores it
in a linked list of namelist_info types. */
static void 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, GFC_INTEGER_4 len,
int kind, bt type, int string_length) gfc_charlen_type string_length, GFC_INTEGER_4 dtype)
{ {
namelist_info *t1 = NULL, *t2 = NULL; namelist_info *t1 = NULL;
namelist_info *nml = (namelist_info *) get_mem (sizeof (namelist_info)); namelist_info *nml;
nml = (namelist_info*) get_mem (sizeof (namelist_info));
nml->mem_pos = var_addr; 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->dim = (descriptor_dimension*)
nml->var_name = (char*) get_mem (var_name_len+1); get_mem (nml->var_rank * sizeof (descriptor_dimension));
strncpy (nml->var_name, var_name, var_name_len); nml->ls = (nml_loop_spec*)
nml->var_name[var_name_len] = 0; get_mem (nml->var_rank * sizeof (nml_loop_spec));
} }
else else
{ {
assert (var_name_len == 0); nml->dim = NULL;
nml->var_name = NULL; nml->ls = NULL;
} }
nml->len = kind;
nml->type = type;
nml->string_length = string_length;
nml->next = NULL; nml->next = NULL;
if (ionml == NULL) if (ionml == NULL)
ionml = nml; ionml = nml;
else else
{ {
t1 = ionml; for (t1 = ionml; t1->next; t1 = t1->next);
while (t1 != NULL) t1->next = nml;
{
t2 = t1;
t1 = t1->next;
}
t2->next = nml;
} }
return;
} }
extern void st_set_nml_var_int (void *, char *, int, int); /* Store the dimensional information for the namelist object. */
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);
void void
st_set_nml_var_int (void * var_addr, char * var_name, int var_name_len, st_set_nml_var_dim (GFC_INTEGER_4 n_dim, GFC_INTEGER_4 stride,
int kind) 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;
void n = (int)n_dim;
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);
}
void for (nml = ionml; nml->next; nml = nml->next);
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);
}
void nml->dim[n].stride = (ssize_t)stride;
st_set_nml_var_complex (void * var_addr, char * var_name, int var_name_len, nml->dim[n].lbound = (ssize_t)lbound;
int kind) nml->dim[n].ubound = (ssize_t)ubound;
{
st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_COMPLEX, 0);
} }
void extern void st_set_nml_var (void * ,char * ,
st_set_nml_var_log (void * var_addr, char * var_name, int var_name_len, GFC_INTEGER_4 ,gfc_charlen_type ,GFC_INTEGER_4);
int kind) export_proto(st_set_nml_var);
{
st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_LOGICAL, 0); 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);
libgfortran/io/write.c
/* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc. /* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
Contributed by Andy Vaught Contributed by Andy Vaught
Namelist output contibuted by Paul Thomas
This file is part of the GNU Fortran 95 runtime library (libgfortran). This file is part of the GNU Fortran 95 runtime library (libgfortran).
...@@ -29,6 +30,7 @@ Boston, MA 02111-1307, USA. */ ...@@ -29,6 +30,7 @@ Boston, MA 02111-1307, USA. */
#include "config.h" #include "config.h"
#include <string.h> #include <string.h>
#include <ctype.h>
#include <float.h> #include <float.h>
#include <stdio.h> #include <stdio.h>
#include <stdlib.h> #include <stdlib.h>
...@@ -44,6 +46,8 @@ typedef enum ...@@ -44,6 +46,8 @@ typedef enum
sign_t; sign_t;
static int no_leading_blank = 0 ;
void void
write_a (fnode * f, const char *source, int len) write_a (fnode * f, const char *source, int len)
{ {
...@@ -576,7 +580,9 @@ output_float (fnode *f, double value, int len) ...@@ -576,7 +580,9 @@ output_float (fnode *f, double value, int len)
leadzero = 0; leadzero = 0;
/* Padd to full field width. */ /* Padd to full field width. */
if (nblanks > 0)
if ( ( nblanks > 0 ) && !no_leading_blank )
{ {
memset (out, ' ', nblanks); memset (out, ' ', nblanks);
out += nblanks; out += nblanks;
...@@ -650,6 +656,13 @@ output_float (fnode *f, double value, int len) ...@@ -650,6 +656,13 @@ output_float (fnode *f, double value, int len)
#endif #endif
memcpy (out, buffer, edigits); 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)) ...@@ -802,13 +815,24 @@ write_int (fnode *f, const char *source, int len, char *(*conv) (uint64_t))
goto done; goto done;
} }
if (!no_leading_blank)
{
memset (p, ' ', nblank); memset (p, ' ', nblank);
p += nblank; p += nblank;
memset (p, '0', nzero); memset (p, '0', nzero);
p += nzero; p += nzero;
memcpy (p, q, digits); 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: done:
return; return;
...@@ -1102,9 +1126,16 @@ write_integer (const char *source, int length) ...@@ -1102,9 +1126,16 @@ write_integer (const char *source, int length)
if(width < digits ) if(width < digits )
width = digits ; width = digits ;
p = write_block (width) ; p = write_block (width) ;
if (no_leading_blank)
{
memcpy (p, q, digits);
memset(p + digits ,' ', width - digits) ;
}
else
{
memset(p ,' ', width - digits) ; memset(p ,' ', width - digits) ;
memcpy (p + width - digits, q, digits); memcpy (p + width - digits, q, digits);
}
} }
...@@ -1269,60 +1300,320 @@ list_formatted_write (bt type, void *p, int len) ...@@ -1269,60 +1300,320 @@ list_formatted_write (bt type, void *p, int len)
char_flag = (type == BT_CHARACTER); char_flag = (type == BT_CHARACTER);
} }
void /* NAMELIST OUTPUT
namelist_write (void)
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)
{ {
namelist_info * t1, *t2; int rep_ctr;
int len,num; int num;
void * p; 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;
num = 0; /* Write namelist variable names in upper case. If a derived type,
write_character("&",1); nothing is output. If a component, base and base_name are set. */
write_character (ioparm.namelist_name, ioparm.namelist_name_len);
write_character("\n",1);
if (ionml != NULL) if (obj->type != GFC_DTYPE_DERIVED)
{ {
t1 = ionml; write_character ("\n ", 2);
while (t1 != NULL) len = 0;
if (base)
{ {
num ++; len =strlen (base->var_name);
t2 = t1; for (dim_i = 0; dim_i < strlen (base_name); dim_i++)
t1 = t1->next;
if (t2->var_name)
{ {
write_character(t2->var_name, strlen(t2->var_name)); cup = toupper (base_name[dim_i]);
write_character("=",1); write_character (&cup, 1);
} }
len = t2->len; }
p = t2->mem_pos; for (dim_i =len; dim_i < strlen (obj->var_name); dim_i++)
switch (t2->type)
{ {
case BT_INTEGER: 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); write_integer (p, len);
break; break;
case BT_LOGICAL:
case GFC_DTYPE_LOGICAL:
write_logical (p, len); write_logical (p, len);
break; break;
case BT_CHARACTER:
write_character (p, t2->string_length); 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; break;
case BT_REAL:
case GFC_DTYPE_REAL:
write_real (p, len); write_real (p, len);
break; break;
case BT_COMPLEX:
case GFC_DTYPE_COMPLEX:
no_leading_blank = 0;
num++;
write_complex (p, len); write_complex (p, len);
break; 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: default:
internal_error ("Bad type for namelist write"); internal_error ("Bad type for namelist write");
} }
write_character(",",1);
/* 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) if (num > 5)
{ {
num = 0; num = 0;
write_character("\n",1); 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, *dummy = NULL;
index_type i;
index_type dummy_offset = 0;
char c;
char * dummy_name = NULL;
unit_delim tmp_delim;
/* 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);
} }
write_character("/",1);
if (ionml != NULL)
{
t1 = ionml;
while (t1 != NULL)
{
t2 = t1;
t1 = nml_write_obj (t2, dummy_offset, dummy, dummy_name);
}
}
write_character (" /\n", 4);
/* Recover the original delimiter. */
current_unit->flags.delim = tmp_delim;
} }
#undef NML_DIGITS
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment