This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
namelist
- From: Paul Thomas <paulthomas2 at wanadoo dot fr>
- To: fortran at gcc dot gnu dot org
- Date: Thu, 07 Apr 2005 18:19:13 +0200
- Subject: namelist
Thank you to all of you that have helped out with comments or
corrections - it is well appreciated; in particular Steve Kargl, Tobi
Schlueter, Paul Brook and Steven Bosscher.
Bootstrapped and regtested on 4.0 and Mainline. OK to commit?
Paul T
Changelog entries
2005-04-07 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.
* io/io.h (namelist_info): Modify for arrays.
* io/list_read.c (namelist_read): Modified to call new functions.
* io/list_read.c (match_namelist_name): Simplified.
* io/list_read.c (nml_query): Handles stdin queries ? and =?. New
function.
* io/list_read.c (nml_get_obj_data): Parses object name. New function.
* io/list_read.c (touch_nml_nodes): Marks objects for read. New
function.
* io/list_read.c (untouch_nml_nodes): Resets objects. New function.
* io/list_read.c (parse_qualifier): Parses and checks qualifiers.
New function
* io/list_read.c (nml_read_object): Reads and stores object data.
New function.
* io/list_read.c (eat_separator): No new_record on '/' in namelist.
* io/list_read.c (finish_separator): No new_record on '/' in namelist.
* io/list_read.c (read_logical): Error return for namelist.
* io/list_read.c (read_integer): Error return for namelist.
* io/list_read.c (read_complex): Error return for namelist.
* io/list_read.c (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.
* io/transfer.c (st_set_nml_var_dim): Dimension descriptors. New
function.
* io/write.c (namelist_write): Modified to call new functions.
* io/write.c (nml_write_obj): Writes output for object. New function.
* io/write.c (write_integer): Suppress leading blanks for repeat counts.
* io/write.c (write_int): Suppress leading blanks for repeat counts.
* io/write.c (write_float): Suppress leading blanks for repeat counts.
* io/write.c (output_float): Suppress leading blanks for repeat counts.
2005-04-07 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 : Build library function for st_set_nml_var.
* fortran/trans-io.c : Build library function for st_set_nml_var_dim.
* fortran/trans-io.c (build_dt): Simplified call to
transfer_namelist_element.
* fortran/trans-io.c (nml_get_addr_expr): New function.
* fortran/trans-io.c (nml_full_name): Qualified name for derived
type components. New function.
2005-04-07 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.f: Tests reals and qualifiers in namelist.
New test
* gfortran.dg/namelist_2.f: Tests integers and qualifiers in
namelist. New test
* gfortran.dg/namelist_3.f90: Tests derived types in namelist. New test
* gfortran.dg/namelist_4.f90: Tests trans-io.c namelist support. New
test
* gfortran.dg/namelist_5.f90: Tests arrays of derived types in
namelist. New test
* gfortran.dg/namelist_6.f90: Tests complex in namelist. New test
* gfortran.dg/namelist_7.f90: Tests logical in namelist. New test
* gfortran.dg/namelist_8.f90: Tests charcter delimiters in namelist.
New test
* gfortran.dg/namelist_9.f90: Tests namelist errors. New test
? fortran.diff
? fortran.patch
Index: trans-io.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/trans-io.c,v
retrieving revision 1.34
diff -p -c -3 -r1.34 trans-io.c
*** trans-io.c 15 Mar 2005 02:52:37 -0000 1.34
--- trans-io.c 7 Apr 2005 14:14:15 -0000
*************** static GTY(()) tree iocall_iolength_done
*** 125,135 ****
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;
/* Variable for keeping track of what the last data transfer statement
was. Used for deciding which subroutine to call when the data
--- 125,132 ----
static GTY(()) tree iocall_rewind;
static GTY(()) tree iocall_backspace;
static GTY(()) tree iocall_endfile;
! 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
*************** gfc_build_io_library_fndecls (void)
*** 314,347 ****
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")),
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);
}
--- 311,329 ----
gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
gfc_int4_type_node, 0);
! 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_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);
}
*************** gfc_trans_inquire (gfc_code * code)
*** 815,821 ****
return gfc_finish_block (&block);
}
-
static gfc_expr *
gfc_new_nml_name_expr (const char * name)
{
--- 797,802 ----
*************** gfc_new_nml_name_expr (const char * name
*** 832,945 ****
return nml_name;
}
! static gfc_expr *
! get_new_var_expr(gfc_symbol * sym)
{
! gfc_expr * nml_var;
! 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;
}
! /* For a scalar variable STRING whose address is ADDR_EXPR, generate a
call to iocall_set_nml_val. For derived type variable, recursively
! generate calls to iocall_set_nml_val for each leaf field. The leafs
! have no names -- their STRING field is null, and are interpreted by
! the run-time library as having only the value, as in the example:
!
! &foo bzz=1,2,3,4,5/
!
! Note that the first output field appears after the name of the
! variable, not of the field name. This causes a little complication
! documented below. */
static void
! transfer_namelist_element (stmtblock_t * block, gfc_typespec * ts, tree addr_expr,
! tree string, tree string_length)
{
! tree tmp, args, arg2;
! tree expr;
! gcc_assert (POINTER_TYPE_P (TREE_TYPE (addr_expr)));
! if (ts->type == BT_DERIVED)
! {
! gfc_component *c;
! expr = gfc_build_indirect_ref (addr_expr);
! for (c = ts->derived->components; c; c = c->next)
! {
! tree field = c->backend_decl;
! gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
! tmp = build3 (COMPONENT_REF, TREE_TYPE (field),
! expr, field, NULL_TREE);
! if (c->dimension)
! gfc_todo_error ("NAMELIST IO of array in derived type");
! if (!c->pointer)
! tmp = gfc_build_addr_expr (NULL, tmp);
! transfer_namelist_element (block, &c->ts, tmp, string, string_length);
!
! /* The first output field bears the name of the topmost
! derived type variable. All other fields are anonymous
! and appear with nulls in their string and string_length
! fields. After the first use, we set string and
! string_length to null. */
! string = null_pointer_node;
! string_length = integer_zero_node;
! }
! return;
! }
! args = gfc_chainon_list (NULL_TREE, addr_expr);
! args = gfc_chainon_list (args, string);
! args = gfc_chainon_list (args, string_length);
! arg2 = build_int_cst (gfc_array_index_type, ts->kind);
! 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);
}
/* 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. */
--- 813,1038 ----
return nml_name;
}
! /* 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)
{
! int full_name_length;
! char * full_name;
! full_name_length = strlen (var_name) + strlen (cmp_name) + 1;
! if (full_name_length > GFC_MAX_SYMBOL_LEN)
! gfc_error ("NAMELIST IO: concatenation of %s and %s "
! "exceeds %d characters", var_name,
! cmp_name, GFC_MAX_SYMBOL_LEN);
! 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;
! }
!
! /* 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, itmp;
! int fl_array, fl_dummy;
! 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. */
+
+ fl_dummy = POINTER_TYPE_P (TREE_TYPE(tmp));
+ itmp = (fl_dummy) ? gfc_build_indirect_ref (tmp) : tmp;
+
+ /* If an array, set flag and use indirect ref. if built. After
+ building the component reference, 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. */
+
+ fl_array = (TREE_CODE (TREE_TYPE (itmp)) == ARRAY_TYPE &&
+ !TYPE_STRING_FLAG (TREE_TYPE (itmp)));
! if (fl_array)
! tmp = itmp;
!
! if (TREE_CODE (decl) == FIELD_DECL)
! tmp = build3 (COMPONENT_REF, TREE_TYPE (tmp),
! base_addr, tmp, NULL_TREE);
!
! if (fl_array)
! tmp = gfc_build_array_ref (tmp, gfc_index_zero_node);
!
! /* Now build the address expression, no matter what we have. */
!
! tmp = gfc_build_addr_expr (NULL, tmp);
!
! /* If scalar dummy, resolve indirect reference now. */
!
! if (fl_dummy && !fl_array)
! 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 component. */
static void
! transfer_namelist_element (stmtblock_t * block, const char * var_name,
! gfc_symbol * sym, gfc_component * c,
! tree base_addr)
{
! gfc_typespec * ts = NULL;
! gfc_array_spec * as = NULL;
! tree addr_expr = NULL;
! tree dt = NULL;
! tree string, tmp, args, dtype;
! int n_dim, itype, rank = 0;
! 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:
+ gfc_error("Bad type in namelist transfer");
+ }
+ dtype = build_int_cst (gfc_array_index_type,
+ itype << GFC_DTYPE_TYPE_SHIFT);
+ }
+ #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)
+
+ /* 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));
+ switch(ts->type)
+ {
+ case BT_CHARACTER:
+ NML_ADD_ARG (convert (gfc_array_index_type,
+ ts->cl->backend_decl));
+ break;
+ case BT_INTEGER:
+ case BT_REAL:
case BT_COMPLEX:
! case BT_LOGICAL:
! case BT_DERIVED:
! NML_ADD_ARG (integer_zero_node);
break;
! default:
! gfc_error("Bad type in namelist transfer");
}
+ 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 *cmp;
+
+ /* Provide the RECORD_TYPE itself 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
for both reading and writing, but improper use has been filtered
out by now. */
*************** build_dt (tree * function, gfc_code * co
*** 950,958 ****
stmtblock_t block, post_block;
gfc_dt *dt;
tree tmp;
! gfc_expr *nmlname, *nmlvar;
gfc_namelist *nml;
- gfc_se se,se2;
gfc_init_block (&block);
gfc_init_block (&post_block);
--- 1043,1050 ----
stmtblock_t block, post_block;
gfc_dt *dt;
tree tmp;
! gfc_expr *nmlname;
gfc_namelist *nml;
gfc_init_block (&block);
gfc_init_block (&post_block);
*************** build_dt (tree * function, gfc_code * co
*** 1022,1039 ****
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);
! }
}
tmp = gfc_build_function_call (*function, NULL_TREE);
--- 1114,1121 ----
set_flag (&block, ioparm_namelist_read_mode);
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);
? io.patch
? libgfortran.diff
Index: io.h
===================================================================
RCS file: /cvsroot/gcc/gcc/libgfortran/io/io.h,v
retrieving revision 1.17
diff -p -c -3 -r1.17 io.h
*** io.h 16 Mar 2005 19:33:07 -0000 1.17
--- io.h 7 Apr 2005 14:10:30 -0000
*************** stream;
*** 74,105 ****
#define sseek(s, pos) ((s)->seek)(s, pos)
#define struncate(s) ((s)->truncate)(s)
! /* Namelist represent object */
! /*
! Namelist Records
! &groupname object=value [,object=value].../
! or
! &groupname object=value [,object=value]...&groupname
!
! 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.
!
! All these requirements need a new data structure to record all info
! about the namelist.
! */
typedef struct namelist_type
{
char * var_name;
void * mem_pos;
! int value_acquired;
int len;
int string_length;
! bt type;
struct namelist_type * next;
}
namelist_info;
--- 74,102 ----
#define sseek(s, pos) ((s)->seek)(s, pos)
#define struncate(s) ((s)->truncate)(s)
! /* Namelist object representation*/
!
! typedef struct nml_loop_spec
! {
! int idx;
! int start;
! int end;
! int step;
! }
! nml_loop_spec;
typedef struct namelist_type
{
+ bt type;
char * var_name;
void * mem_pos;
! int touched;
int len;
+ int size;
int string_length;
! int var_rank;
! descriptor_dimension * dim;
! nml_loop_spec * ls;
struct namelist_type * next;
}
namelist_info;
Index: list_read.c
===================================================================
RCS file: /cvsroot/gcc/gcc/libgfortran/io/list_read.c,v
retrieving revision 1.15
diff -p -c -3 -r1.15 list_read.c
*** list_read.c 25 Mar 2005 13:35:29 -0000 1.15
--- list_read.c 7 Apr 2005 14:10:31 -0000
***************
*** 1,5 ****
! /* Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of the GNU Fortran 95 runtime library (libgfortran).
--- 1,6 ----
! /* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
Contributed by Andy Vaught
+ Namelist input contributed by Paul Thomas
This file is part of the GNU Fortran 95 runtime library (libgfortran).
*************** Boston, MA 02111-1307, USA. */
*** 50,61 ****
ourselves. Data is buffered in scratch[] until it becomes too
large, after which we start allocating memory on the heap. */
! static int repeat_count, saved_length, saved_used, input_complete, at_eol;
! static int comma_flag, namelist_mode;
!
static char last_char, *saved_string;
static bt saved_type;
/* Storage area for values except for strings. Must be large enough
--- 51,69 ----
ourselves. Data is buffered in scratch[] until it becomes too
large, after which we start allocating memory on the heap. */
! static int repeat_count, saved_length, saved_used;
! static int input_complete, at_eol, comma_flag;
static char last_char, *saved_string;
static bt saved_type;
+ /* These two namelist specific flags are used in the list directed library
+ to (i) flag that calls are being made from namelist read (eg. to ignore
+ comments or to treat '/' as a terminator) and (ii) both to flag read
+ errors and return, so that an attempt can be made to read a new object
+ name. */
+
+ static int namelist_mode, nml_read_error;
+
/* Storage area for values except for strings. Must be large enough
*************** eat_separator (void)
*** 226,237 ****
--- 234,249 ----
case '/':
input_complete = 1;
+ if (!namelist_mode)
+ {
next_record (0);
at_eol = 1;
+ }
break;
case '\n':
case '\r':
+ at_eol = 1;
break;
case '!':
*************** finish_separator (void)
*** 282,288 ****
case '/':
input_complete = 1;
! next_record (0);
break;
case '\n':
--- 294,300 ----
case '/':
input_complete = 1;
! if (!namelist_mode) next_record (0);
break;
case '\n':
*************** finish_separator (void)
*** 305,310 ****
--- 317,336 ----
}
}
+ /* 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)
+ return 0;
+ nml_read_error = 1;
+ unget_char(c);
+ return 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
*************** read_logical (int length)
*** 525,530 ****
--- 551,560 ----
return;
bad_logical:
+
+ if (nml_bad_return (c))
+ return;
+
st_sprintf (message, "Bad logical value while reading item %d",
g.item_count);
*************** read_integer (int length)
*** 641,646 ****
--- 671,680 ----
}
bad_integer:
+
+ if (nml_bad_return (c))
+ return;
+
free_saved ();
st_sprintf (message, "Bad integer for item %d in list input", g.item_count);
*************** read_complex (int length)
*** 976,981 ****
--- 1010,1019 ----
return;
bad_complex:
+
+ if (nml_bad_return (c))
+ return;
+
st_sprintf (message, "Bad complex value in item %d of list input",
g.item_count);
*************** read_real (int length)
*** 1186,1191 ****
--- 1224,1233 ----
return;
bad_real:
+
+ if (nml_bad_return (c))
+ return;
+
st_sprintf (message, "Bad real number in item %d of list input",
g.item_count);
*************** finish_list_read (void)
*** 1380,1385 ****
--- 1422,1622 ----
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 int clow;
+
+ /* Upper index for substring qualifier. */
+
+ static int chigh;
+
+ /* Inputs a rank-dimensional qualifier, which can contain
+ singlets, doublets, triplets or ':' with the standard meanings. ad is
+ the descriptor dimension, as in the declaration, whereas id is the
+ input descriptor. The input descriptor is checked for consistency with
+ the bounds in the variable declaration. */
+
+ 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;
+ case '+':
+ break;
+ default:
+ unget_char (c);
+ break;
+ }
+
+ /*process characters up to the next ':' , ',' or ')' */
+
+ for (;;)
+ {
+ c = next_char ();
+ switch (c)
+ {
+ case ',': 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 > ad[dim].ubound) ||
+ (ls[dim].start < ad[dim].lbound) ||
+ (ls[dim].end > ad[dim].ubound) ||
+ (ls[dim].end < 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 *
find_nml_node (char * var_name)
{
*************** find_nml_node (char * var_name)
*** 1388,1394 ****
{
if (strcmp (var_name,t->var_name) == 0)
{
! t->value_acquired = 1;
return t;
}
t = t->next;
--- 1625,1631 ----
{
if (strcmp (var_name,t->var_name) == 0)
{
! t->touched = 1;
return t;
}
t = t->next;
*************** find_nml_node (char * var_name)
*** 1396,1563 ****
return NULL;
}
static void
! match_namelist_name (char *name, int len)
{
! int name_len;
! char c;
! char * namelist_name = name;
! name_len = 0;
! /* Match the name of the namelist. */
! if (tolower (next_char ()) != tolower (namelist_name[name_len++]))
{
! wrong_name:
! generate_error (ERROR_READ_VALUE, "Wrong namelist name found");
return;
}
! while (name_len < len)
{
c = next_char ();
! if (tolower (c) != tolower (namelist_name[name_len++]))
! goto wrong_name;
}
}
! /********************************************************************
! Namelist reads
! ********************************************************************/
!
! /* 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;
! int name_matched, next_name ;
namelist_info * nl;
! int len, m;
! void * p;
! namelist_mode = 1;
! if (setjmp (g.eof_jump))
{
! generate_error (ERROR_END, NULL);
! return;
! }
! restart:
! c = next_char ();
! switch (c)
{
- case ' ':
- goto restart;
- case '!':
- do
- c = next_char ();
- while (c != '\n');
! goto restart;
! case '&':
! break;
! default:
! generate_error (ERROR_READ_VALUE, "Invalid character in namelist");
! return;
}
! /* Match the name of the namelist. */
! match_namelist_name(ioparm.namelist_name, ioparm.namelist_name_len);
! /* Ready to read namelist elements. */
! while (!input_complete)
! {
! c = next_char ();
! switch (c)
{
! case '/':
! input_complete = 1;
! next_record (0);
break;
! case '&':
! match_namelist_name("end",3);
! return;
! case '\\':
! return;
! case ' ':
! case '\n':
! case '\r':
! case '\t':
break;
! case ',':
! next_name = 1;
break;
! case '=':
! name_matched = 1;
! nl = find_nml_node (saved_string);
! if (nl == NULL)
! internal_error ("Can not match a namelist variable");
! free_saved();
! len = nl->len;
! p = nl->mem_pos;
! /* skip any blanks or tabs after the = */
! eat_spaces ();
switch (nl->type)
{
! case BT_INTEGER:
read_integer (len);
break;
! case BT_LOGICAL:
read_logical (len);
break;
! case BT_CHARACTER:
read_character (len);
break;
! case BT_REAL:
read_real (len);
break;
! case BT_COMPLEX:
read_complex (len);
break;
default:
! internal_error ("Bad type for namelist read");
}
switch (saved_type)
{
case BT_COMPLEX:
- len = 2 * len;
- /* Fall through... */
-
- case BT_INTEGER:
case BT_REAL:
case BT_LOGICAL:
! memcpy (p, value, len);
break;
-
case BT_CHARACTER:
! m = (len < saved_used) ? len : saved_used;
! memcpy (p, saved_string, m);
!
! if (m < len)
! memset (((char *) p) + m, ' ', len - m);
break;
!
! case BT_NULL:
break;
}
break;
default :
push_char(tolower(c));
break;
}
}
}
--- 1633,2275 ----
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
! nml_touch_nodes (namelist_info * nl)
{
! int len = strlen (nl->var_name) + 1;
! int dim;
! 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;
! }
! /* Resets touched for the entire list of nml_nodes, ready for a
! new object. */
! static void
! nml_untouch_nodes (void)
{
! namelist_info * t;
! for (t = ionml; t; t = t->next)
! t->touched = 0;
return;
}
! /* Attempts to input name to namelist name. Returns nml_read_error = 1
! on no match. */
!
! static void
! nml_match_name (char *name, int len)
! {
! int i;
! char c;
! nml_read_error = 0;
! for (i = 0; i < len; i++)
{
c = next_char ();
! if (tolower (c) != tolower (name[i]))
! {
! 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
! nml_query (char c)
{
! gfc_unit * temp_unit;
namelist_info * nl;
! int len;
! char * p;
! if (current_unit->unit_number != options.stdin_unit)
! return;
! /* Store the current unit and transfer to stdout. */
!
! temp_unit = current_unit;
! current_unit = find_unit (options.stdout_unit);
!
! if (current_unit)
{
! g.mode =WRITING;
! next_record (0);
! /* Write the namelist in its entirety. */
!
! if (c == '=')
! namelist_write ();
!
! /* Or write the list of names. */
!
! else
{
! /* "&namelist_name\n" */
! len = ioparm.namelist_name_len;
! 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)
! {
! /* " var_name\n" */
!
! len = strlen (nl->var_name);
! p = write_block (len + 2);
! memcpy (p, " ", 1);
! memcpy ((char*)(p + 1), nl->var_name, len);
! memcpy ((char*)(p + len + 1), "\n", 1);
}
! /* "&end\n" */
! p = write_block (5);
! memcpy (p, "&end\n", 5);
! }
!
! /* 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 dlen, len, m, dim, obj_name_len;
! int nml_carry;
! 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 GFC_DTYPE_INTEGER:
! case GFC_DTYPE_LOGICAL:
! case GFC_DTYPE_REAL:
! dlen = len;
break;
! case GFC_DTYPE_COMPLEX:
! dlen = 2* len;
break;
! case GFC_DTYPE_CHARACTER:
! dlen = chigh? (chigh - clow + 1): nl->string_length;
break;
+ default:
+ dlen = 0;
+ }
+
+ do
+ {
! /* Update the pointer to the data, using the current index vector */
! 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;
! saved_type = GFC_DTYPE_UNKNOWN; /* falls thru' for nulls */
! free_saved ();
switch (nl->type)
{
! case GFC_DTYPE_INTEGER:
read_integer (len);
break;
! case GFC_DTYPE_LOGICAL:
read_logical (len);
break;
! case GFC_DTYPE_CHARACTER:
read_character (len);
break;
! case GFC_DTYPE_REAL:
read_real (len);
break;
! case GFC_DTYPE_COMPLEX:
read_complex (len);
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:
! 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)
{
case BT_COMPLEX:
case BT_REAL:
+ case BT_INTEGER:
case BT_LOGICAL:
! memcpy (pdata, value, dlen);
break;
case BT_CHARACTER:
! m = (dlen < saved_used) ? dlen : saved_used;
! pdata = (void*)( pdata + clow - 1 );
! memcpy (pdata, saved_string, m);
! if (m < dlen)
! memset ((void*)( pdata + m ), ' ', dlen - m);
break;
! default:
break;
}
+ /* Break out of loop if scalar. */
+
+ if (!nl->var_rank)
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 len;
+ 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 :
+ 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));
+ 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;
+ 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;
}
Index: lock.c
===================================================================
RCS file: /cvsroot/gcc/gcc/libgfortran/io/lock.c,v
retrieving revision 1.5
diff -p -c -3 -r1.5 lock.c
*** lock.c 12 Jan 2005 21:27:31 -0000 1.5
--- lock.c 7 Apr 2005 14:10:31 -0000
***************
*** 1,5 ****
/* Thread/recursion locking
! Copyright 2002 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).
--- 1,5 ----
/* Thread/recursion locking
! 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).
*************** library_end (void)
*** 74,89 ****
filename = NULL;
line = 0;
t = ioparm.library_return;
if (ionml != NULL)
{
t1 = ionml;
while (t1 != NULL)
! {
! t2 = t1;
! t1 = t1->next;
! free_mem (t2);
! }
}
ionml = NULL;
--- 74,96 ----
filename = NULL;
line = 0;
+
t = ioparm.library_return;
if (ionml != NULL)
{
t1 = ionml;
while (t1 != NULL)
! {
! 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;
Index: transfer.c
===================================================================
RCS file: /cvsroot/gcc/gcc/libgfortran/io/transfer.c,v
retrieving revision 1.34
diff -p -c -3 -r1.34 transfer.c
*** transfer.c 31 Mar 2005 15:30:06 -0000 1.34
--- transfer.c 7 Apr 2005 14:10:31 -0000
***************
*** 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).
*************** st_write_done (void)
*** 1587,1617 ****
library_end ();
}
!
! static void
! st_set_nml_var (void * var_addr, char * var_name, int var_name_len,
! int kind, bt type, int string_length)
{
! namelist_info *t1 = NULL, *t2 = NULL;
! namelist_info *nml = (namelist_info *) get_mem (sizeof (namelist_info));
nml->mem_pos = var_addr;
! if (var_name)
! {
! assert (var_name_len > 0);
! nml->var_name = (char*) get_mem (var_name_len+1);
! strncpy (nml->var_name, var_name, var_name_len);
! nml->var_name[var_name_len] = 0;
}
else
{
! assert (var_name_len == 0);
! nml->var_name = NULL;
}
- nml->len = kind;
- nml->type = type;
- nml->string_length = string_length;
-
nml->next = NULL;
if (ionml == NULL)
--- 1588,1624 ----
library_end ();
}
! void
! st_set_nml_var (void * var_addr, char * var_name,
! index_type ia1, index_type ia2, index_type ia3)
{
! namelist_info *t1 = NULL, *t2 = NULL, * nml;
!
! nml = (namelist_info *) get_mem (sizeof (namelist_info));
nml->mem_pos = var_addr;
!
! nml->var_name = (char*) get_mem (strlen (var_name) + 1);
! strcpy (nml->var_name, var_name);
!
! nml->len = ia1;
! nml->string_length = ia2;
! nml->var_rank = ia3 & GFC_DTYPE_RANK_MASK;
! nml->size = ia3 >> GFC_DTYPE_SIZE_SHIFT;
! nml->type =(ia3 & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT;
!
! if (nml->var_rank > 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
{
! nml->dim = NULL;
! nml->ls = NULL;
}
nml->next = NULL;
if (ionml == NULL)
*************** st_set_nml_var (void * var_addr, char *
*** 1626,1680 ****
}
t2->next = nml;
}
}
- 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);
-
void
! st_set_nml_var_int (void * var_addr, char * var_name, int var_name_len,
! int kind)
{
! st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_INTEGER, 0);
! }
! void
! st_set_nml_var_float (void * var_addr, char * var_name, int var_name_len,
! int kind)
! {
! st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_REAL, 0);
}
! 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);
! }
- 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);
- }
--- 1633,1664 ----
}
t2->next = nml;
}
+ return;
}
void
! st_set_nml_var_dim (index_type n_dim, index_type ia1,
! index_type ia2, index_type ia3)
{
! namelist_info *t1 = NULL, * nml;
! t1 = ionml;
! while ( t1 != NULL )
! {
! nml = t1;
! t1 = t1->next;
! }
! nml->dim[n_dim].stride = ia1;
! nml->dim[n_dim].lbound = ia2;
! nml->dim[n_dim].ubound = ia3;
}
! extern void st_set_nml_var (void * ,char * ,
! index_type ,index_type ,index_type);
! export_proto(st_set_nml_var);
!
! extern void st_set_nml_var_dim (index_type, index_type,
! index_type ,index_type);
! export_proto(st_set_nml_var_dim);
Index: write.c
===================================================================
RCS file: /cvsroot/gcc/gcc/libgfortran/io/write.c,v
retrieving revision 1.31
diff -p -c -3 -r1.31 write.c
*** write.c 5 Apr 2005 14:20:10 -0000 1.31
--- write.c 7 Apr 2005 14:10:31 -0000
***************
*** 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).
*************** Boston, MA 02111-1307, USA. */
*** 29,34 ****
--- 30,36 ----
#include "config.h"
#include <string.h>
+ #include <ctype.h>
#include <float.h>
#include <stdio.h>
#include <stdlib.h>
*************** typedef enum
*** 44,49 ****
--- 46,53 ----
sign_t;
+ static int no_leading_blank = 0 ;
+
void
write_a (fnode * f, const char *source, int len)
{
*************** output_float (fnode *f, double value, in
*** 576,582 ****
leadzero = 0;
/* Padd to full field width. */
! if (nblanks > 0)
{
memset (out, ' ', nblanks);
out += nblanks;
--- 580,588 ----
leadzero = 0;
/* Padd to full field width. */
!
!
! if ( ( nblanks > 0 ) && !no_leading_blank )
{
memset (out, ' ', nblanks);
out += nblanks;
*************** output_float (fnode *f, double value, in
*** 650,655 ****
--- 656,668 ----
#endif
memcpy (out, buffer, edigits);
}
+
+ if ( no_leading_blank )
+ {
+ out += edigits;
+ memset( out , ' ' , nblanks );
+ no_leading_blank = 0;
+ }
}
*************** write_int (fnode *f, const char *source,
*** 802,814 ****
goto done;
}
memset (p, ' ', nblank);
p += nblank;
-
memset (p, '0', nzero);
p += nzero;
-
memcpy (p, q, digits);
done:
return;
--- 815,838 ----
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;
*************** write_integer (const char *source, int l
*** 1102,1110 ****
if(width < digits )
width = digits ;
p = write_block (width) ;
!
memset(p ,' ', width - digits) ;
memcpy (p + width - digits, q, digits);
}
--- 1126,1141 ----
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);
+ }
}
*************** list_formatted_write (bt type, void *p,
*** 1269,1328 ****
char_flag = (type == BT_CHARACTER);
}
! void
! namelist_write (void)
! {
! namelist_info * t1, *t2;
! int len,num;
! void * p;
!
! num = 0;
! write_character("&",1);
! write_character (ioparm.namelist_name, ioparm.namelist_name_len);
! write_character("\n",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);
}
}
}
! write_character("/",1);
}
--- 1300,1592 ----
char_flag = (type == BT_CHARACTER);
}
! /* 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 len, obj_size, num, nelem, dim_i, clen;
! int nml_carry, elem_ctr, obj_name_len;
! void * p ;
! char cup;
! char * obj_name;
! char * ext_name;
! char rep_buff[NML_DIGITS];
! int rep_ctr;
! 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, 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;
!
! nelem = 1;
!
! /* Set the index vector and count the number of elements. */
!
! 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);
! }
! rep_ctr = 1;
!
! /* Main loop to output the data held in the object. */
!
! 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 > 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;
+ int 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);
+ }
+
+ if (ionml != NULL)
+ {
+ t1 = ionml;
+ while (t1 != NULL)
+ {
+ t2 = t1;
+ t1 = nml_write_obj (t2, dummy_offset, dummy, dummy_name);
}
}
! write_character (" /\n", 4);
! current_unit->flags.delim = tmp_delim;
}
+ #undef NML_DIGITS
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
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_2
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
!{ dg-do run }
! Tests simple derived types.
! Provided by Paul Thomas - pault@gcc.gnu.org
program namelist_3
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_3
!{ 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_4
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_4
!{ 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_5
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_5
!{ dg-do run }
! Tests namelist on complex variables
! provided by Paul Thomas - pault@gcc.gnu.org
program namelist_6
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_6
!{ dg-do run }
! Tests namelist on logical variables
! provided by Paul Thomas - pault@gcc.gnu.org
program namelist_7
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_7
!{ dg-do run }
! Tests character delimiters for namelist write
! provided by Paul Thomas - pault@gcc.gnu.org
program namelist_8
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_8
!{ dg-do run }
! Test namelist error trapping.
! provided by Paul Thomas - pault@gcc.gnu.org
program namelist_9
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_9
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
! { 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
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
! { dg-do run }
! pr 18122
! test namelist read
! 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
! { 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
! { 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
! { 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
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