Belated patch to gfortran 4.0
Jakub Jelinek
jakub@redhat.com
Sun Jun 5 19:21:00 GMT 2005
On Sun, Jun 05, 2005 at 09:06:31PM +0200, Toon Moene wrote:
> Paul Thomas wrote:
>
> >As you will see, I just committed to 4.0 , belatedly, the character
> >related patches already committed to 4.1.
>
> How about your namelist cleanup patch ? AFAICS, it isn't included in
> 4.0 yet.
>
> If you do not have the time to pursue this, I'll take a stab at it the
> next weekend.
I'm using the following backport on 4.0 branch for more than a month now.
Tested on 7 linux arches, there is just one extra failure on ppc64 and
s390x (and none on the remaining 5 ones):
+FAIL: gfortran.dg/namelist_14.f90 -O0 (test for excess errors)
+WARNING: gfortran.dg/namelist_14.f90 -O0 compilation failed to produce executable
but that one looks like a middle-end bug and is present on HEAD as well.
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.
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-18 Paul Thomas <pault@gcc.gnu.org>
Jerry DeLisle <jvdelisle@verizon.net>
* io/write.c (nml_write_obj): Provide 1 more byte for ext_name.
* io/list_read.c (nml_get_obj_data): Put extra brackets in get_mem
call for ext_name. These fix the bug reported by Jerry DeLisle to
the fortran list and are based on his suggested fix.
2005-04-18 Paul Thomas <pault@gcc.gnu.org>
* io/list_read.c (nml_touch_nodes, nml_read_obj,
nml_get_obj_data): Fix memory leaks in code for derived types.
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.
--- gcc/fortran/trans-io.c 15 Mar 2005 02:52:37 -0000 1.34
+++ gcc/fortran/trans-io.c 17 Apr 2005 20:09:33 -0000 1.35
@@ -125,11 +125,8 @@ static GTY(()) tree iocall_iolength_done
static GTY(()) tree iocall_rewind;
static GTY(()) tree iocall_backspace;
static GTY(()) tree iocall_endfile;
-static GTY(()) tree iocall_set_nml_val_int;
-static GTY(()) tree iocall_set_nml_val_float;
-static GTY(()) tree iocall_set_nml_val_char;
-static GTY(()) tree iocall_set_nml_val_complex;
-static GTY(()) tree iocall_set_nml_val_log;
+static GTY(()) tree iocall_set_nml_val;
+static GTY(()) tree iocall_set_nml_val_dim;
/* Variable for keeping track of what the last data transfer statement
was. Used for deciding which subroutine to call when the data
@@ -314,34 +311,19 @@ gfc_build_io_library_fndecls (void)
gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
gfc_int4_type_node, 0);
- iocall_set_nml_val_int =
- gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_int")),
- void_type_node, 4,
- pvoid_type_node, pvoid_type_node,
- gfc_int4_type_node,gfc_int4_type_node);
- iocall_set_nml_val_float =
- gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_float")),
- void_type_node, 4,
- pvoid_type_node, pvoid_type_node,
- gfc_int4_type_node,gfc_int4_type_node);
- iocall_set_nml_val_char =
- gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_char")),
+ iocall_set_nml_val =
+ gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var")),
void_type_node, 5,
pvoid_type_node, pvoid_type_node,
- gfc_int4_type_node, gfc_int4_type_node,
- gfc_charlen_type_node);
- iocall_set_nml_val_complex =
- gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_complex")),
- void_type_node, 4,
- pvoid_type_node, pvoid_type_node,
- gfc_int4_type_node,gfc_int4_type_node);
- iocall_set_nml_val_log =
- gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_log")),
- void_type_node, 4,
- pvoid_type_node, pvoid_type_node,
- gfc_int4_type_node,gfc_int4_type_node);
+ gfc_int4_type_node, gfc_charlen_type_node,
+ gfc_int4_type_node);
+ iocall_set_nml_val_dim =
+ gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_dim")),
+ void_type_node, 4,
+ gfc_int4_type_node, gfc_int4_type_node,
+ gfc_int4_type_node, gfc_int4_type_node);
}
@@ -815,11 +797,11 @@ gfc_trans_inquire (gfc_code * code)
return gfc_finish_block (&block);
}
-
static gfc_expr *
gfc_new_nml_name_expr (const char * name)
{
gfc_expr * nml_name;
+
nml_name = gfc_get_expr();
nml_name->ref = NULL;
nml_name->expr_type = EXPR_CONSTANT;
@@ -832,114 +814,229 @@ gfc_new_nml_name_expr (const char * name
return nml_name;
}
-static gfc_expr *
-get_new_var_expr(gfc_symbol * sym)
+/* nml_full_name builds up the fully qualified name of a
+ derived type component. */
+
+static char*
+nml_full_name (const char* var_name, const char* cmp_name)
+{
+ int full_name_length;
+ char * full_name;
+
+ full_name_length = strlen (var_name) + strlen (cmp_name) + 1;
+ full_name = (char*)gfc_getmem (full_name_length + 1);
+ strcpy (full_name, var_name);
+ full_name = strcat (full_name, "%");
+ full_name = strcat (full_name, cmp_name);
+ return full_name;
+}
+
+/* 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)
{
- gfc_expr * nml_var;
+ tree decl = NULL_TREE;
+ tree tmp;
+ tree itmp;
+ int array_flagged;
+ int dummy_arg_flagged;
+
+ if (sym)
+ {
+ sym->attr.referenced = 1;
+ decl = gfc_get_symbol_decl (sym);
+ }
+ else
+ decl = c->backend_decl;
+
+ gcc_assert (decl && ((TREE_CODE (decl) == FIELD_DECL
+ || TREE_CODE (decl) == VAR_DECL
+ || TREE_CODE (decl) == PARM_DECL)
+ || TREE_CODE (decl) == COMPONENT_REF));
+
+ tmp = decl;
- 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;
+ /* Build indirect reference, if dummy argument. */
- return nml_var;
+ 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
- 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. */
+ generate calls to iocall_set_nml_val for each component. */
+
+#define NML_FIRST_ARG(a) args = gfc_chainon_list (NULL_TREE, a)
+#define NML_ADD_ARG(a) args = gfc_chainon_list (args, a)
+#define IARG(i) build_int_cst (gfc_array_index_type, i)
static void
-transfer_namelist_element (stmtblock_t * block, gfc_typespec * ts, tree addr_expr,
- tree string, tree string_length)
-{
- tree tmp, args, arg2;
- tree expr;
+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;
+ 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)
- {
- gfc_component *c;
- expr = gfc_build_indirect_ref (addr_expr);
+ /* Build the namelist object name. */
- 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);
+ string = gfc_build_cstring_const (var_name);
+ string = gfc_build_addr_expr (pchar_type_node, string);
- 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;
- }
+ /* Build ts, as and data address using symbol or component. */
- return;
- }
+ ts = (sym) ? &sym->ts : &c->ts;
+ as = (sym) ? sym->as : c->as;
- 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);
+ addr_expr = nml_get_addr_expr (sym, c, base_addr);
- switch (ts->type)
+ if (as)
+ rank = as->rank;
+
+ if (rank)
{
- case BT_INTEGER:
- tmp = gfc_build_function_call (iocall_set_nml_val_int, args);
- break;
+ dt = TREE_TYPE ((sym) ? sym->backend_decl : c->backend_decl);
+ dtype = gfc_get_dtype (dt);
+ }
+ else
+ {
+ itype = GFC_DTYPE_UNKNOWN;
- 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;
+ switch (ts->type)
- case BT_REAL:
- tmp = gfc_build_function_call (iocall_set_nml_val_float, args);
- break;
+ {
+ case BT_INTEGER:
+ itype = GFC_DTYPE_INTEGER;
+ break;
+ case BT_LOGICAL:
+ itype = GFC_DTYPE_LOGICAL;
+ break;
+ case BT_REAL:
+ itype = GFC_DTYPE_REAL;
+ break;
+ case BT_COMPLEX:
+ itype = GFC_DTYPE_COMPLEX;
+ break;
+ case BT_DERIVED:
+ itype = GFC_DTYPE_DERIVED;
+ break;
+ case BT_CHARACTER:
+ itype = GFC_DTYPE_CHARACTER;
+ break;
+ default:
+ gcc_unreachable ();
+ }
- case BT_LOGICAL:
- tmp = gfc_build_function_call (iocall_set_nml_val_log, args);
- break;
+ dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT);
+ }
- case BT_COMPLEX:
- tmp = gfc_build_function_call (iocall_set_nml_val_complex, args);
- break;
+ /* 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));
- default :
- internal_error ("Bad namelist IO basetype (%d)", ts->type);
- }
+ if (ts->type == BT_CHARACTER)
+ NML_ADD_ARG (ts->cl->backend_decl);
+ else
+ NML_ADD_ARG (convert (gfc_charlen_type_node, integer_zero_node));
+ NML_ADD_ARG (dtype);
+ tmp = gfc_build_function_call (iocall_set_nml_val, args);
gfc_add_expr_to_block (block, tmp);
+
+ /* If the object is an array, transfer rank times:
+ (null pointer, name, stride, lbound, ubound) */
+
+ for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
+ {
+ NML_FIRST_ARG (IARG (n_dim));
+ NML_ADD_ARG (GFC_TYPE_ARRAY_STRIDE (dt, n_dim));
+ NML_ADD_ARG (GFC_TYPE_ARRAY_LBOUND (dt, n_dim));
+ NML_ADD_ARG (GFC_TYPE_ARRAY_UBOUND (dt, n_dim));
+ tmp = gfc_build_function_call (iocall_set_nml_val_dim, args);
+ gfc_add_expr_to_block (block, tmp);
+ }
+
+ if (ts->type == BT_DERIVED)
+ {
+ gfc_component *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
for both reading and writing, but improper use has been filtered
out by now. */
@@ -950,9 +1047,8 @@ build_dt (tree * function, gfc_code * co
stmtblock_t block, post_block;
gfc_dt *dt;
tree tmp;
- gfc_expr *nmlname, *nmlvar;
+ gfc_expr *nmlname;
gfc_namelist *nml;
- gfc_se se,se2;
gfc_init_block (&block);
gfc_init_block (&post_block);
@@ -1010,30 +1106,20 @@ build_dt (tree * function, gfc_code * co
if (dt->namelist)
{
- if (dt->format_expr || dt->format_label)
- fatal_error("A format cannot be specified with a namelist");
+ if (dt->format_expr || dt->format_label)
+ gfc_internal_error ("build_dt: format with namelist");
+
+ nmlname = gfc_new_nml_name_expr(dt->namelist->name);
- nmlname = gfc_new_nml_name_expr(dt->namelist->name);
+ set_string (&block, &post_block, ioparm_namelist_name,
+ ioparm_namelist_name_len, nmlname);
- set_string (&block, &post_block, ioparm_namelist_name,
- ioparm_namelist_name_len, nmlname);
+ if (last_dt == READ)
+ set_flag (&block, ioparm_namelist_read_mode);
- if (last_dt == READ)
- set_flag (&block, ioparm_namelist_read_mode);
-
- for (nml = dt->namelist->namelist; nml; nml = nml->next)
- {
- gfc_init_se (&se, NULL);
- gfc_init_se (&se2, NULL);
- nmlvar = get_new_var_expr (nml->sym);
- nmlname = gfc_new_nml_name_expr (nml->sym->name);
- gfc_conv_expr_reference (&se2, nmlname);
- gfc_conv_expr_reference (&se, nmlvar);
- gfc_evaluate_now (se.expr, &se.pre);
-
- transfer_namelist_element (&block, &nml->sym->ts, se.expr,
- se2.expr, se2.string_length);
- }
+ for (nml = dt->namelist->namelist; nml; nml = nml->next)
+ transfer_namelist_element (&block, nml->sym->name, nml->sym,
+ NULL, NULL);
}
tmp = gfc_build_function_call (*function, NULL_TREE);
--- libgfortran/io/io.h 16 Mar 2005 19:33:07 -0000 1.17
+++ libgfortran/io/io.h 17 Apr 2005 20:09:37 -0000 1.18
@@ -74,32 +74,75 @@ stream;
#define sseek(s, pos) ((s)->seek)(s, pos)
#define struncate(s) ((s)->truncate)(s)
-/* Namelist represent object */
-/*
+/* Representation of a namelist object in libgfortran
+
Namelist Records
- &groupname object=value [,object=value].../
+ &GROUPNAME OBJECT=value[s] [,OBJECT=value[s]].../
or
- &groupname object=value [,object=value]...&groupname
+ &GROUPNAME OBJECT=value[s] [,OBJECT=value[s]]...&END
+
+ 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
+{
+
+ /* Index counter for this dimension. */
+ ssize_t idx;
+
+ /* Start for the index counter. */
+ ssize_t start;
+
+ /* End for the index counter. */
+ ssize_t end;
+
+ /* Step for the index counter. */
+ ssize_t step;
+}
+nml_loop_spec;
- 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.
-*/
+/* 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
{
+
+ /* Object type, stored as GFC_DTYPE_xxxx. */
+ bt type;
+
+ /* Object name. */
char * var_name;
+
+ /* Address for the start of the object's data. */
void * mem_pos;
- 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 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;
}
namelist_info;
--- libgfortran/io/list_read.c 25 Mar 2005 13:35:29 -0000 1.15
+++ libgfortran/io/list_read.c 23 Apr 2005 12:38:08 -0000 1.18
@@ -1,5 +1,6 @@
-/* Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
+/* 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).
@@ -50,13 +51,22 @@ Boston, MA 02111-1307, USA. */
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 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;
+/* 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
to hold a complex value (two reals) of the largest kind. */
@@ -226,12 +236,16 @@ eat_separator (void)
case '/':
input_complete = 1;
- next_record (0);
- at_eol = 1;
+ if (!namelist_mode)
+ {
+ next_record (0);
+ at_eol = 1;
+ }
break;
case '\n':
case '\r':
+ at_eol = 1;
break;
case '!':
@@ -282,7 +296,7 @@ finish_separator (void)
case '/':
input_complete = 1;
- next_record (0);
+ if (!namelist_mode) next_record (0);
break;
case '\n':
@@ -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
if we are working on a repeat count. Returns nonzero if we have a
@@ -525,6 +554,10 @@ read_logical (int length)
return;
bad_logical:
+
+ if (nml_bad_return (c))
+ return;
+
st_sprintf (message, "Bad logical value while reading item %d",
g.item_count);
@@ -641,6 +674,10 @@ read_integer (int length)
}
bad_integer:
+
+ if (nml_bad_return (c))
+ return;
+
free_saved ();
st_sprintf (message, "Bad integer for item %d in list input", g.item_count);
@@ -976,6 +1013,10 @@ read_complex (int length)
return;
bad_complex:
+
+ if (nml_bad_return (c))
+ return;
+
st_sprintf (message, "Bad complex value in item %d of list input",
g.item_count);
@@ -1186,6 +1227,10 @@ read_real (int length)
return;
bad_real:
+
+ if (nml_bad_return (c))
+ return;
+
st_sprintf (message, "Bad real number in item %d of list input",
g.item_count);
@@ -1380,184 +1425,919 @@ finish_list_read (void)
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 *
find_nml_node (char * var_name)
{
- namelist_info * t = ionml;
- while (t != NULL)
- {
- if (strcmp (var_name,t->var_name) == 0)
- {
- t->value_acquired = 1;
- return t;
- }
- t = t->next;
- }
+ namelist_info * t = ionml;
+ while (t != NULL)
+ {
+ if (strcmp (var_name,t->var_name) == 0)
+ {
+ t->touched = 1;
+ return t;
+ }
+ t = t->next;
+ }
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
-match_namelist_name (char *name, int len)
+nml_touch_nodes (namelist_info * nl)
{
- 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++]))
+ index_type 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)
{
- wrong_name:
- generate_error (ERROR_READ_VALUE, "Wrong namelist name found");
- return;
+ 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;
}
+ free_mem (ext_name);
+ return;
+}
- while (name_len < len)
+/* 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, index_type len)
+{
+ index_type i;
+ char c;
+ nml_read_error = 0;
+ for (i = 0; i < len; i++)
{
c = next_char ();
- if (tolower (c) != tolower (namelist_name[name_len++]))
- goto wrong_name;
+ 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. */
-/********************************************************************
- 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)
+static void
+nml_query (char c)
{
- char c;
- int name_matched, next_name ;
+ gfc_unit * temp_unit;
namelist_info * nl;
- int len, m;
- void * p;
+ index_type len;
+ 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);
- return;
+ 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);
+ if (!p)
+ goto query_return;
+ memcpy (p, " ", 1);
+ memcpy ((char*)(p + 1), nl->var_name, len);
+ memcpy ((char*)(p + len + 1), "\n", 1);
+ }
+
+ /* "&end\n" */
+
+ p = write_block (5);
+ if (!p)
+ goto query_return;
+ memcpy (p, "&end\n", 5);
+ }
+
+ /* Flush the stream to force immediate output. */
+
+ flush (current_unit->s);
}
- restart:
- c = next_char ();
- switch (c)
- {
- case ' ':
- goto restart;
- case '!':
- do
- c = next_char ();
- while (c != '\n');
+query_return:
- goto restart;
+ /* Restore the current unit. */
- case '&':
+ 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 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:
- generate_error (ERROR_READ_VALUE, "Invalid character in namelist");
- return;
+ dlen = 0;
}
- /* Match the name of the namelist. */
- match_namelist_name(ioparm.namelist_name, ioparm.namelist_name_len);
-
- /* Ready to read namelist elements. */
- while (!input_complete)
+ do
{
- 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();
+ /* 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;
- len = nl->len;
- p = nl->mem_pos;
+ /* GFC_TYPE_UNKNOWN through for nulls and is detected
+ after the switch block. */
- /* skip any blanks or tabs after the = */
- eat_spaces ();
+ saved_type = GFC_DTYPE_UNKNOWN;
+ free_saved ();
switch (nl->type)
- {
- case BT_INTEGER:
+ {
+ case GFC_DTYPE_INTEGER:
read_integer (len);
break;
- case BT_LOGICAL:
+
+ case GFC_DTYPE_LOGICAL:
read_logical (len);
break;
- case BT_CHARACTER:
+
+ case GFC_DTYPE_CHARACTER:
read_character (len);
break;
- case BT_REAL:
+
+ case GFC_DTYPE_REAL:
read_real (len);
break;
- case BT_COMPLEX:
+
+ case GFC_DTYPE_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);
+ 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)
+ {
+ free_mem (obj_name);
+ return FAILURE;
+ }
+
+ if (input_complete)
+ {
+ free_mem (obj_name);
+ 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;
+ }
+ }
- if (m < len)
- memset (((char *) p) + m, ' ', len - m);
- break;
+ /* 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_NULL:
- 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;
- 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 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);
+ free_mem (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 == '%')
+ {
- default :
- push_char(tolower(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;
}
--- libgfortran/io/lock.c 12 Jan 2005 21:27:31 -0000 1.5
+++ libgfortran/io/lock.c 17 Apr 2005 20:09:37 -0000 1.6
@@ -1,5 +1,5 @@
/* Thread/recursion locking
- Copyright 2002 Free Software Foundation, Inc.
+ Copyright 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org> and Andy Vaught
This file is part of the GNU Fortran 95 runtime library (libgfortran).
@@ -73,20 +73,28 @@ library_end (void)
g.in_library = 0;
filename = NULL;
line = 0;
-
t = ioparm.library_return;
+
+ /* Delete the namelist, if it exists. */
+
if (ionml != NULL)
{
t1 = ionml;
while (t1 != NULL)
- {
- t2 = t1;
- t1 = t1->next;
- free_mem (t2);
- }
+ {
+ t2 = t1;
+ t1 = t1->next;
+ free_mem (t2->var_name);
+ if (t2->var_rank)
+ {
+ free_mem (t2->dim);
+ free_mem (t2->ls);
+ }
+ free_mem (t2);
+ }
}
-
ionml = NULL;
+
memset (&ioparm, '\0', sizeof (ioparm));
ioparm.library_return = t;
}
--- libgfortran/io/transfer.c 10 Apr 2005 08:35:22 -0000 1.36
+++ libgfortran/io/transfer.c 17 Apr 2005 20:09:37 -0000 1.37
@@ -1,5 +1,6 @@
/* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
Contributed by Andy Vaught
+ Namelist transfer functions contributed by Paul Thomas
This file is part of the GNU Fortran 95 runtime library (libgfortran).
@@ -1623,94 +1624,78 @@ st_write_done (void)
library_end ();
}
+/* Receives the scalar information for namelist objects and stores it
+ in a linked list of namelist_info types. */
-static void
-st_set_nml_var (void * var_addr, char * var_name, int var_name_len,
- int kind, bt type, int string_length)
+void
+st_set_nml_var (void * var_addr, char * var_name, GFC_INTEGER_4 len,
+ gfc_charlen_type string_length, GFC_INTEGER_4 dtype)
{
- namelist_info *t1 = NULL, *t2 = NULL;
- namelist_info *nml = (namelist_info *) get_mem (sizeof (namelist_info));
+ namelist_info *t1 = NULL;
+ namelist_info *nml;
+
+ nml = (namelist_info*) get_mem (sizeof (namelist_info));
+
nml->mem_pos = var_addr;
- if (var_name)
- {
- assert (var_name_len > 0);
- nml->var_name = (char*) get_mem (var_name_len+1);
- strncpy (nml->var_name, var_name, var_name_len);
- nml->var_name[var_name_len] = 0;
+
+ nml->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)
+ {
+ nml->dim = (descriptor_dimension*)
+ get_mem (nml->var_rank * sizeof (descriptor_dimension));
+ nml->ls = (nml_loop_spec*)
+ get_mem (nml->var_rank * sizeof (nml_loop_spec));
}
else
{
- assert (var_name_len == 0);
- nml->var_name = NULL;
+ nml->dim = NULL;
+ nml->ls = NULL;
}
- nml->len = kind;
- nml->type = type;
- nml->string_length = string_length;
-
nml->next = NULL;
if (ionml == NULL)
- ionml = nml;
+ ionml = nml;
else
{
- t1 = ionml;
- while (t1 != NULL)
- {
- t2 = t1;
- t1 = t1->next;
- }
- t2->next = nml;
+ for (t1 = ionml; t1->next; t1 = t1->next);
+ t1->next = nml;
}
+ return;
}
-extern void st_set_nml_var_int (void *, char *, int, int);
-export_proto(st_set_nml_var_int);
-
-extern void st_set_nml_var_float (void *, char *, int, int);
-export_proto(st_set_nml_var_float);
-
-extern void st_set_nml_var_char (void *, char *, int, int, gfc_charlen_type);
-export_proto(st_set_nml_var_char);
-
-extern void st_set_nml_var_complex (void *, char *, int, int);
-export_proto(st_set_nml_var_complex);
-
-extern void st_set_nml_var_log (void *, char *, int, int);
-export_proto(st_set_nml_var_log);
+/* Store the dimensional information for the namelist object. */
void
-st_set_nml_var_int (void * var_addr, char * var_name, int var_name_len,
- int kind)
+st_set_nml_var_dim (GFC_INTEGER_4 n_dim, GFC_INTEGER_4 stride,
+ GFC_INTEGER_4 lbound, GFC_INTEGER_4 ubound)
{
- st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_INTEGER, 0);
-}
+ namelist_info * nml;
+ int n;
-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);
-}
+ n = (int)n_dim;
-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);
-}
+ for (nml = ionml; nml->next; nml = nml->next);
-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);
+ nml->dim[n].stride = (ssize_t)stride;
+ nml->dim[n].lbound = (ssize_t)lbound;
+ nml->dim[n].ubound = (ssize_t)ubound;
}
-void
-st_set_nml_var_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);
-}
+extern void st_set_nml_var (void * ,char * ,
+ GFC_INTEGER_4 ,gfc_charlen_type ,GFC_INTEGER_4);
+export_proto(st_set_nml_var);
+
+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 5 Apr 2005 14:20:10 -0000 1.31
+++ libgfortran/io/write.c 23 Apr 2005 12:38:08 -0000 1.33
@@ -1,5 +1,6 @@
/* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
Contributed by Andy Vaught
+ Namelist output contibuted by Paul Thomas
This file is part of the GNU Fortran 95 runtime library (libgfortran).
@@ -29,6 +30,7 @@ Boston, MA 02111-1307, USA. */
#include "config.h"
#include <string.h>
+#include <ctype.h>
#include <float.h>
#include <stdio.h>
#include <stdlib.h>
@@ -44,6 +46,8 @@ typedef enum
sign_t;
+static int no_leading_blank = 0 ;
+
void
write_a (fnode * f, const char *source, int len)
{
@@ -576,7 +580,9 @@ output_float (fnode *f, double value, in
leadzero = 0;
/* Padd to full field width. */
- if (nblanks > 0)
+
+
+ if ( ( nblanks > 0 ) && !no_leading_blank )
{
memset (out, ' ', nblanks);
out += nblanks;
@@ -650,6 +656,13 @@ output_float (fnode *f, double value, in
#endif
memcpy (out, buffer, edigits);
}
+
+ if ( no_leading_blank )
+ {
+ out += edigits;
+ memset( out , ' ' , nblanks );
+ no_leading_blank = 0;
+ }
}
@@ -802,13 +815,24 @@ write_int (fnode *f, const char *source,
goto done;
}
+
+ if (!no_leading_blank)
+ {
memset (p, ' ', nblank);
p += nblank;
-
memset (p, '0', nzero);
p += nzero;
-
memcpy (p, q, digits);
+ }
+ else
+ {
+ memset (p, '0', nzero);
+ p += nzero;
+ memcpy (p, q, digits);
+ p += digits;
+ memset (p, ' ', nblank);
+ no_leading_blank = 0;
+ }
done:
return;
@@ -1102,9 +1126,16 @@ write_integer (const char *source, int l
if(width < digits )
width = digits ;
p = write_block (width) ;
-
+ if (no_leading_blank)
+ {
+ memcpy (p, q, digits);
+ memset(p + digits ,' ', width - digits) ;
+ }
+ else
+ {
memset(p ,' ', width - digits) ;
memcpy (p + width - digits, q, digits);
+ }
}
@@ -1269,60 +1300,321 @@ list_formatted_write (bt type, void *p,
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);
+/* NAMELIST OUTPUT
- if (ionml != NULL)
- {
- t1 = ionml;
- while (t1 != NULL)
+ nml_write_obj writes a namelist object to the output stream. It is called
+ recursively for derived type components:
+ obj = is the namelist_info for the current object.
+ offset = the offset relative to the address held by the object for
+ derived type arrays.
+ base = is the namelist_info of the derived type, when obj is a
+ component.
+ base_name = the full name for a derived type, including qualifiers
+ if any.
+ The returned value is a pointer to the object beyond the last one
+ accessed, including nested derived types. Notice that the namelist is
+ a linear linked list of objects, including derived types and their
+ components. A tree, of sorts, is implied by the compound names of
+ the derived type components and this is how this function recurses through
+ the list. */
+
+/* A generous estimate of the number of characters needed to print
+ repeat counts and indices, including commas, asterices and brackets. */
+
+#define NML_DIGITS 20
+
+/* Stores the delimiter to be used for character objects. */
+
+static char * nml_delim;
+
+static namelist_info *
+nml_write_obj (namelist_info * obj, index_type offset,
+ namelist_info * base, char * base_name)
+{
+ int rep_ctr;
+ int num;
+ int nml_carry;
+ index_type len;
+ index_type obj_size;
+ index_type nelem;
+ index_type dim_i;
+ index_type clen;
+ index_type elem_ctr;
+ index_type obj_name_len;
+ void * p ;
+ char cup;
+ char * obj_name;
+ char * ext_name;
+ char rep_buff[NML_DIGITS];
+ namelist_info * cmp;
+ namelist_info * retval = obj->next;
+
+ /* Write namelist variable names in upper case. If a derived type,
+ nothing is output. If a component, base and base_name are set. */
+
+ if (obj->type != GFC_DTYPE_DERIVED)
+ {
+ write_character ("\n ", 2);
+ len = 0;
+ if (base)
{
- num ++;
- t2 = t1;
- t1 = t1->next;
- if (t2->var_name)
+ len =strlen (base->var_name);
+ for (dim_i = 0; dim_i < strlen (base_name); dim_i++)
{
- write_character(t2->var_name, strlen(t2->var_name));
- write_character("=",1);
+ cup = toupper (base_name[dim_i]);
+ write_character (&cup, 1);
}
- len = t2->len;
- p = t2->mem_pos;
- switch (t2->type)
- {
- case BT_INTEGER:
+ }
+ for (dim_i =len; dim_i < strlen (obj->var_name); dim_i++)
+ {
+ cup = toupper (obj->var_name[dim_i]);
+ write_character (&cup, 1);
+ }
+ write_character ("=", 1);
+ }
+
+ /* Counts the number of data output on a line, including names. */
+
+ num = 1;
+
+ len = obj->len;
+ obj_size = len;
+ if (obj->type == GFC_DTYPE_COMPLEX)
+ obj_size = 2*len;
+ if (obj->type == GFC_DTYPE_CHARACTER)
+ obj_size = obj->string_length;
+ if (obj->var_rank)
+ obj_size = obj->size;
+
+ /* Set the index vector and count the number of elements. */
+
+ nelem = 1;
+ for (dim_i=0; dim_i < obj->var_rank; dim_i++)
+ {
+ obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
+ nelem = nelem * (obj->dim[dim_i].ubound + 1 - obj->dim[dim_i].lbound);
+ }
+
+ /* Main loop to output the data held in the object. */
+
+ rep_ctr = 1;
+ for (elem_ctr = 0; elem_ctr < nelem; elem_ctr++)
+ {
+
+ /* Build the pointer to the data value. The offset is passed by
+ recursive calls to this function for arrays of derived types.
+ Is NULL otherwise. */
+
+ p = (void *)(obj->mem_pos + elem_ctr * obj_size);
+ p += offset;
+
+ /* Check for repeat counts of intrinsic types. */
+
+ if ((elem_ctr < (nelem - 1)) &&
+ (obj->type != GFC_DTYPE_DERIVED) &&
+ !memcmp (p, (void*)(p + obj_size ), obj_size ))
+ {
+ rep_ctr++;
+ }
+
+ /* Execute a repeated output. Note the flag no_leading_blank that
+ is used in the functions used to output the intrinsic types. */
+
+ else
+ {
+ if (rep_ctr > 1)
+ {
+ st_sprintf(rep_buff, " %d*", rep_ctr);
+ write_character (rep_buff, strlen (rep_buff));
+ no_leading_blank = 1;
+ }
+ num++;
+
+ /* Output the data, if an intrinsic type, or recurse into this
+ routine to treat derived types. */
+
+ switch (obj->type)
+ {
+
+ case GFC_DTYPE_INTEGER:
write_integer (p, len);
break;
- case BT_LOGICAL:
+
+ case GFC_DTYPE_LOGICAL:
write_logical (p, len);
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;
- case BT_REAL:
+
+ case GFC_DTYPE_REAL:
write_real (p, len);
break;
- case BT_COMPLEX:
+
+ 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
+ + 1);
+
+ 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");
}
- 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)
{
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;
+ }
+ }
}
- write_character("/",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);
+ }
+
+ 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
+
--- gcc/testsuite/gfortran.dg/namelist_1.f90 22 Jan 2005 18:23:43 -0000 1.1
+++ gcc/testsuite/gfortran.dg/namelist_1.f90 17 Apr 2005 20:09:36 -0000 1.2
@@ -1,8 +1,7 @@
! { dg-do compile }
-! Check that public entities in private namelists are rejected
+! Check that private entities in public namelists are rejected
module namelist_1
public
integer,private :: x
namelist /n/ x ! { dg-error "cannot be member of PUBLIC namelist" "" }
end module
-
--- gcc/testsuite/gfortran.dg/namelist_11.f 1 Jan 1970 00:00:00 -0000
+++ gcc/testsuite/gfortran.dg/namelist_11.f 17 Apr 2005 20:09:37 -0000 1.1
@@ -0,0 +1,55 @@
+c { dg-do run }
+c This program tests: namelist comment, a blank line before the nameilist name, the namelist name,
+c a scalar qualifier, various combinations of space, comma and lf delimiters, f-formats, e-formats
+c a blank line within the data read, nulls, a range qualifier, a new object name before end of data
+c and an integer read. It also tests that namelist output can be re-read by namelist input.
+c provided by Paul Thomas - pault@gcc.gnu.org
+
+ program namelist_1
+
+ REAL*4 x(10)
+ REAL*8 xx
+ integer ier
+ namelist /mynml/ x, xx
+
+ do i = 1 , 10
+ x(i) = -1
+ end do
+ x(6) = 6.0
+ x(10) = 10.0
+ xx = 0d0
+
+ open (10,status="scratch")
+ write (10, *) "!mynml"
+ write (10, *) ""
+ write (10, *) "&gf /"
+ write (10, *) "&mynml x(7) =+99.0e0 x=1.0, 2.0 ,"
+ write (10, *) " 2*3.0, ,, 7.0e0,+0.08e+02 !comment"
+ write (10, *) ""
+ write (10, *) " 9000e-3 x(4:5)=4 ,5 "
+ write (10, *) " x=,,3.0, xx=10d0 /"
+ rewind (10)
+
+ read (10, nml=mynml, IOSTAT=ier)
+ if (ier.ne.0) call abort
+ rewind (10)
+
+ do i = 1 , 10
+ if ( abs( x(i) - real(i) ) .gt. 1e-8 ) call abort
+ end do
+ if ( abs( xx - 10d0 ) .gt. 1e-8 ) call abort
+
+ write (10, nml=mynml, iostat=ier)
+ if (ier.ne.0) call abort
+ rewind (10)
+
+ read (10, NML=mynml, IOSTAT=ier)
+ if (ier.ne.0) call abort
+ close (10)
+
+ do i = 1 , 10
+ if ( abs( x(i) - real(i) ) .gt. 1e-8 ) call abort
+ end do
+ if ( abs( xx - 10d0 ) .gt. 1e-8 ) call abort
+
+ end program
--- gcc/testsuite/gfortran.dg/namelist_12.f 1 Jan 1970 00:00:00 -0000
+++ gcc/testsuite/gfortran.dg/namelist_12.f 17 Apr 2005 20:09:37 -0000 1.1
@@ -0,0 +1,56 @@
+c{ dg-do run }
+c This program repeats many of the same tests as test_nml_1 but for integer instead of real.
+c It also tests repeat nulls, comma delimited character read, a triplet qualifier, a range with
+c and assumed start, a quote delimited string, a qualifier with an assumed end and a fully
+c explicit range. It also tests that integers and characters are successfully read back by
+c namelist.
+c Provided by Paul Thomas - pault@gcc.gnu.org
+
+ program namelist_12
+
+ integer*4 x(10)
+ integer*8 xx
+ integer ier
+ character*10 ch , check
+ namelist /mynml/ x, xx, ch
+
+c set debug = 0 or 1 in the namelist! (line 33)
+
+ do i = 1 , 10
+ x(i) = -1
+ end do
+ x(6) = 6
+ x(10) = 10
+ xx = 0
+ ch ="zzzzzzzzzz"
+ check="abcdefghij"
+
+ open (10,status="scratch")
+ write (10, *) "!mynml"
+ write (10, *) " "
+ write (10, *) "&mynml x(7) =+99 x=1, 2 ,"
+ write (10, *) " 2*3, ,, 2* !comment"
+ write (10, *) " 9 ch=qqqdefghqq , x(8:7:-1) = 8 , 7"
+ write (10, *) " ch(:3) =""abc"","
+ write (10, *) " ch(9:)='ij' x(4:5)=4 ,5 xx = 42/"
+ rewind (10)
+
+ read (10, nml=mynml, IOSTAT=ier)
+ if (ier.ne.0) call abort
+ rewind (10)
+
+ write (10, nml=mynml, iostat=ier)
+ if (ier.ne.0) call abort
+ rewind (10)
+
+ read (10, NML=mynml, IOSTAT=ier)
+ if (ier.ne.0) call abort
+ close (10)
+
+ do i = 1 , 10
+ if ( abs( x(i) - i ) .ne. 0 ) call abort ()
+ if ( ch(i:i).ne.check(I:I) ) call abort
+ end do
+ if (xx.ne.42) call abort ()
+
+ end program
--- gcc/testsuite/gfortran.dg/namelist_13.f90 1 Jan 1970 00:00:00 -0000
+++ gcc/testsuite/gfortran.dg/namelist_13.f90 17 Apr 2005 20:09:37 -0000 1.1
@@ -0,0 +1,38 @@
+!{ dg-do run }
+! Tests simple derived types.
+! Provided by Paul Thomas - pault@gcc.gnu.org
+
+program namelist_13
+
+ type :: yourtype
+ integer, dimension(2) :: yi = (/8,9/)
+ real, dimension(2) :: yx = (/80.,90./)
+ character(len=2) :: ych = "xx"
+ end type yourtype
+
+ type :: mytype
+ integer, dimension(2) :: myi = (/800,900/)
+ real, dimension(2) :: myx = (/8000.,9000./)
+ character(len=2) :: mych = "zz"
+ type(yourtype) :: my_yourtype
+ end type mytype
+
+ type(mytype) :: z
+ integer :: ier
+ integer :: zeros(10)
+ namelist /mynml/ zeros, z
+
+ zeros = 0
+ zeros(5) = 1
+
+ open(10,status="scratch")
+ write (10, nml=mynml, iostat=ier)
+ if (ier.ne.0) call abort
+
+ rewind (10)
+ read (10, NML=mynml, IOSTAT=ier)
+ if (ier.ne.0) call abort
+ close (10)
+
+end program namelist_13
+
--- gcc/testsuite/gfortran.dg/namelist_14.f90 1 Jan 1970 00:00:00 -0000
+++ gcc/testsuite/gfortran.dg/namelist_14.f90 17 Apr 2005 20:09:37 -0000 1.1
@@ -0,0 +1,94 @@
+!{ dg-do run }
+! Tests various combinations of intrinsic types, derived types, arrays,
+! dummy arguments and common to check nml_get_addr_expr in trans-io.c.
+! See comments below for selection.
+! provided by Paul Thomas - pault@gcc.gnu.org
+
+module global
+ type :: mt
+ integer :: ii(4)
+ end type mt
+end module global
+
+program namelist_14
+ use global
+ common /myc/ cdt
+ integer :: i(2) = (/101,201/)
+ type(mt) :: dt(2)
+ type(mt) :: cdt
+ real*8 :: pi = 3.14159_8
+ character*10 :: chs="singleton"
+ character*10 :: cha(2)=(/"first ","second "/)
+
+ dt = mt ((/99,999,9999,99999/))
+ cdt = mt ((/-99,-999,-9999,-99999/))
+ call foo (i,dt,pi,chs,cha)
+
+contains
+
+ logical function dttest (dt1, dt2)
+ use global
+ type(mt) :: dt1
+ type(mt) :: dt2
+ dttest = any(dt1%ii == dt2%ii)
+ end function dttest
+
+
+ subroutine foo (i, dt, pi, chs, cha)
+ use global
+ common /myc/ cdt
+ real *8 :: pi !local real scalar
+ integer :: i(2) !dummy arg. array
+ integer :: j(2) = (/21, 21/) !equivalenced array
+ integer :: jj ! -||- scalar
+ integer :: ier
+ type(mt) :: dt(2) !dummy arg., derived array
+ type(mt) :: dtl(2) !in-scope derived type array
+ type(mt) :: dts !in-scope derived type
+ type(mt) :: cdt !derived type in common block
+ character*10 :: chs !dummy arg. character var.
+ character*10 :: cha(:) !dummy arg. character array
+ character*10 :: chl="abcdefg" !in-scope character var.
+ equivalence (j,jj)
+ namelist /z/ dt, dtl, dts, cdt, j, jj, i, pi, chs, chl, cha
+
+ dts = mt ((/1, 2, 3, 4/))
+ dtl = mt ((/41, 42, 43, 44/))
+
+ open (10, status = "scratch")
+ write (10, nml = z, iostat = ier)
+ if (ier /= 0 ) call abort()
+ rewind (10)
+
+ i = 0
+ j = 0
+ jj = 0
+ pi = 0
+ dt = mt ((/0, 0, 0, 0/))
+ dtl = mt ((/0, 0, 0, 0/))
+ dts = mt ((/0, 0, 0, 0/))
+ cdt = mt ((/0, 0, 0, 0/))
+ chs = ""
+ cha = ""
+ chl = ""
+
+ read (10, nml = z, iostat = ier)
+ if (ier /= 0 ) call abort()
+ close (10)
+
+ if (.not.(dttest (dt(1), mt ((/99,999,9999,99999/))) .and. &
+ dttest (dt(2), mt ((/99,999,9999,99999/))) .and. &
+ dttest (dtl(1), mt ((/41, 42, 43, 44/))) .and. &
+ dttest (dtl(2), mt ((/41, 42, 43, 44/))) .and. &
+ dttest (dts, mt ((/1, 2, 3, 4/))) .and. &
+ dttest (cdt, mt ((/-99,-999,-9999,-99999/))) .and. &
+ all (j ==(/21, 21/)) .and. &
+ all (i ==(/101, 201/)) .and. &
+ (pi == 3.14159_8) .and. &
+ (chs == "singleton") .and. &
+ (chl == "abcdefg") .and. &
+ (cha(1)(1:10) == "first ") .and. &
+ (cha(2)(1:10) == "second "))) call abort ()
+
+ end subroutine foo
+end program namelist_14
--- gcc/testsuite/gfortran.dg/namelist_15.f90 1 Jan 1970 00:00:00 -0000
+++ gcc/testsuite/gfortran.dg/namelist_15.f90 17 Apr 2005 20:09:37 -0000 1.1
@@ -0,0 +1,58 @@
+!{ dg-do run }
+! Tests arrays of derived types containing derived type arrays whose
+! components are character arrays - exercises object name parser in
+! list_read.c. Checks that namelist output can be reread.
+! provided by Paul Thomas - pault@gcc.gnu.org
+
+module global
+ type :: mt
+ character(len=2) :: ch(2) = (/"aa","bb"/)
+ end type mt
+ type :: bt
+ integer :: i(2) = (/1,2/)
+ type(mt) :: m(2)
+ end type bt
+end module global
+
+program namelist_15
+ use global
+ type(bt) :: x(2)
+
+ namelist /mynml/ x
+
+ open (10, status = "scratch")
+ write (10, '(A)') "&MYNML"
+ write (10, '(A)') " x = 3, 4, 'dd', 'ee', 'ff', 'gg',"
+ write (10, '(A)') " 4, 5, 'hh', 'ii', 'jj', 'kk',"
+ write (10, '(A)') " x%i = , ,-3, -4"
+ write (10, '(A)') " x(2)%m(1)%ch(2) =q,"
+ write (10, '(A)') " x(2)%m(2)%ch(1)(1) =w,"
+ write (10, '(A)') " x%m%ch(:)(2) =z z z z z z z z,"
+ write (10, '(A)') "&end"
+
+ rewind (10)
+ read (10, nml = mynml, iostat = ier)
+ if (ier .ne. 0) call abort ()
+ close (10)
+
+ open (10, status = "scratch")
+ write (10, nml = mynml)
+ rewind (10)
+ read (10, nml = mynml, iostat = ier)
+ if (ier .ne. 0) call abort ()
+ close(10)
+
+ if (.not. ((x(1)%i(1) == 3) .and. &
+ (x(1)%i(2) == 4) .and. &
+ (x(1)%m(1)%ch(1) == "dz") .and. &
+ (x(1)%m(1)%ch(2) == "ez") .and. &
+ (x(1)%m(2)%ch(1) == "fz") .and. &
+ (x(1)%m(2)%ch(2) == "gz") .and. &
+ (x(2)%i(1) == -3) .and. &
+ (x(2)%i(2) == -4) .and. &
+ (x(2)%m(1)%ch(1) == "hz") .and. &
+ (x(2)%m(1)%ch(2) == "qz") .and. &
+ (x(2)%m(2)%ch(1) == "wz") .and. &
+ (x(2)%m(2)%ch(2) == "kz"))) call abort ()
+
+end program namelist_15
--- gcc/testsuite/gfortran.dg/namelist_16.f90 1 Jan 1970 00:00:00 -0000
+++ gcc/testsuite/gfortran.dg/namelist_16.f90 17 Apr 2005 20:09:37 -0000 1.1
@@ -0,0 +1,29 @@
+!{ dg-do run }
+! Tests namelist on complex variables
+! provided by Paul Thomas - pault@gcc.gnu.org
+program namelist_16
+ complex(kind=8), dimension(2) :: z
+ namelist /mynml/ z
+ z = (/(1.0,2.0), (3.0,4.0)/)
+
+ open (10, status = "scratch")
+ write (10, '(A)') "&mynml z(1)=(5.,6.) z(2)=(7.,8.) /"
+ rewind (10)
+
+ read (10, mynml, iostat = ier)
+ if (ier .ne. 0) call abort ()
+ close (10)
+
+ open (10, status = "scratch")
+ write (10, mynml, iostat = ier)
+ if (ier .ne. 0) call abort ()
+ rewind (10)
+
+ z = (/(1.0,2.0), (3.0,4.0)/)
+ read (10, mynml, iostat = ier)
+ if (ier .ne. 0) call abort ()
+ close (10)
+
+ if ((z(1) .ne. (5.0,6.0)) .or. (z(2) .ne. (7.0,8.0))) call abort ()
+
+end program namelist_16
--- gcc/testsuite/gfortran.dg/namelist_17.f90 1 Jan 1970 00:00:00 -0000
+++ gcc/testsuite/gfortran.dg/namelist_17.f90 17 Apr 2005 20:09:37 -0000 1.1
@@ -0,0 +1,30 @@
+!{ dg-do run }
+! Tests namelist on logical variables
+! provided by Paul Thomas - pault@gcc.gnu.org
+
+program namelist_17
+ logical, dimension(2) :: l
+ namelist /mynml/ l
+ l = (/.true., .false./)
+
+ open (10, status = "scratch")
+ write (10, '(A)') "&mynml l = F T /"
+ rewind (10)
+
+ read (10, mynml, iostat = ier)
+ if (ier .ne. 0) call abort ()
+ close (10)
+
+ open (10, status = "scratch")
+ write (10, mynml, iostat = ier)
+ if (ier .ne. 0) call abort ()
+ rewind (10)
+
+ l = (/.true., .false./)
+ read (10, mynml, iostat = ier)
+ if (ier .ne. 0) call abort ()
+ close (10)
+
+ if (l(1) .or. (.not.l(2))) call abort ()
+
+end program namelist_17
--- gcc/testsuite/gfortran.dg/namelist_18.f90 1 Jan 1970 00:00:00 -0000
+++ gcc/testsuite/gfortran.dg/namelist_18.f90 17 Apr 2005 20:09:37 -0000 1.1
@@ -0,0 +1,37 @@
+!{ dg-do run }
+! Tests character delimiters for namelist write
+! provided by Paul Thomas - pault@gcc.gnu.org
+
+program namelist_18
+ character*3 :: ch = "foo"
+ character*80 :: buffer
+ namelist /mynml/ ch
+
+ open (10, status = "scratch")
+ write (10, mynml)
+ rewind (10)
+ read (10, '(a)', iostat = ier) buffer
+ read (10, '(a)', iostat = ier) buffer
+ if (ier .ne. 0) call abort ()
+ close (10)
+ If ((buffer(5:5) /= "f") .or. (buffer(9:9) /= " ")) call abort ()
+
+ open (10, status = "scratch", delim ="quote")
+ write (10, mynml)
+ rewind (10)
+ read (10, '(a)', iostat = ier) buffer
+ read (10, '(a)', iostat = ier) buffer
+ if (ier .ne. 0) call abort ()
+ close (10)
+ If ((buffer(5:5) /= """") .or. (buffer(9:9) /= """")) call abort ()
+
+ open (10, status = "scratch", delim ="apostrophe")
+ write (10, mynml)
+ rewind (10)
+ read (10, '(a)', iostat = ier) buffer
+ read (10, '(a)', iostat = ier) buffer
+ if (ier .ne. 0) call abort ()
+ close (10)
+ If ((buffer(5:5) /= "'") .or. (buffer(9:9) /= "'")) call abort ()
+
+end program namelist_18
--- gcc/testsuite/gfortran.dg/namelist_19.f90 1 Jan 1970 00:00:00 -0000
+++ gcc/testsuite/gfortran.dg/namelist_19.f90 17 Apr 2005 20:09:37 -0000 1.1
@@ -0,0 +1,135 @@
+!{ dg-do run }
+! Test namelist error trapping.
+! provided by Paul Thomas - pault@gcc.gnu.org
+
+program namelist_19
+ character*80 wrong, right
+
+! "=" before any object name
+ wrong = "&z = i = 1,2 /"
+ right = "&z i = 1,2 /"
+ call test_err(wrong, right)
+
+! &* instead of &end for termination
+ wrong = "&z i = 1,2 &xxx"
+ right = "&z i = 1,2 &end"
+ call test_err(wrong, right)
+
+! bad data
+ wrong = "&z i = 1,q /"
+ right = "&z i = 1,2 /"
+ call test_err(wrong, right)
+
+! object name not matched
+ wrong = "&z j = 1,2 /"
+ right = "&z i = 1,2 /"
+ call test_err(wrong, right)
+
+! derived type component for intrinsic type
+ wrong = "&z i%j = 1,2 /"
+ right = "&z i = 1,2 /"
+ call test_err(wrong, right)
+
+! step other than 1 for substring qualifier
+ wrong = "&z ch(1:2:2) = 'a'/"
+ right = "&z ch(1:2) = 'ab' /"
+ call test_err(wrong, right)
+
+! qualifier for scalar
+ wrong = "&z k(2) = 1 /"
+ right = "&z k = 1 /"
+ call test_err(wrong, right)
+
+! no '=' after object name
+ wrong = "&z i 1,2 /"
+ right = "&z i = 1,2 /"
+ call test_err(wrong, right)
+
+! repeat count too large
+ wrong = "&z i = 3*2 /"
+ right = "&z i = 2*2 /"
+ call test_err(wrong, right)
+
+! too much data
+ wrong = "&z i = 1 2 3 /"
+ right = "&z i = 1 2 /"
+ call test_err(wrong, right)
+
+! no '=' after object name
+ wrong = "&z i 1,2 /"
+ right = "&z i = 1,2 /"
+ call test_err(wrong, right)
+
+! bad number of index fields
+ wrong = "&z i(1,2) = 1 /"
+ right = "&z i(1) = 1 /"
+ call test_err(wrong, right)
+
+! bad character in index field
+ wrong = "&z i(x) = 1 /"
+ right = "&z i(1) = 1 /"
+ call test_err(wrong, right)
+
+! null index field
+ wrong = "&z i( ) = 1 /"
+ right = "&z i(1) = 1 /"
+ call test_err(wrong, right)
+
+! null index field
+ wrong = "&z i(1::) = 1 2/"
+ right = "&z i(1:2:1) = 1 2 /"
+ call test_err(wrong, right)
+
+! null index field
+ wrong = "&z i(1:2:) = 1 2/"
+ right = "&z i(1:2:1) = 1 2 /"
+ call test_err(wrong, right)
+
+! index out of range
+ wrong = "&z i(10) = 1 /"
+ right = "&z i(1) = 1 /"
+ call test_err(wrong, right)
+
+! index out of range
+ wrong = "&z i(0:1) = 1 /"
+ right = "&z i(1:1) = 1 /"
+ call test_err(wrong, right)
+
+! bad range
+ wrong = "&z i(1:2:-1) = 1 2 /"
+ right = "&z i(1:2: 1) = 1 2 /"
+ call test_err(wrong, right)
+
+! bad range
+ wrong = "&z i(2:1: 1) = 1 2 /"
+ right = "&z i(2:1:-1) = 1 2 /"
+ call test_err(wrong, right)
+
+contains
+ subroutine test_err(wrong, right)
+ character*80 wrong, right
+ integer :: i(2) = (/0, 0/)
+ integer :: k =0
+ character*2 :: ch = " "
+ namelist /z/ i, k, ch
+
+! Check that wrong namelist input gives an error
+
+ open (10, status = "scratch")
+ write (10, '(A)') wrong
+ rewind (10)
+ read (10, z, iostat = ier)
+ close(10)
+ if (ier == 0) call abort ()
+
+! Check that right namelist input gives no error
+
+ open (10, status = "scratch")
+ write (10, '(A)') right
+ rewind (10)
+ read (10, z, iostat = ier)
+ close(10)
+ if (ier /= 0) call abort ()
+ end subroutine test_err
+
+end program namelist_19
--- gcc/testsuite/gfortran.dg/namelist_2.f90 1 Jan 1970 00:00:00 -0000
+++ gcc/testsuite/gfortran.dg/namelist_2.f90 17 Apr 2005 20:09:37 -0000 1.1
@@ -0,0 +1,7 @@
+! { dg-do compile }
+! Check that variable with intent(in) cannot be a member of a namelist
+subroutine namelist_2(x)
+ integer,intent(in) :: x
+ namelist /n/ x
+ read(*,n) ! { dg-error "is INTENT" "" }
+end subroutine namelist_2
--- gcc/testsuite/gfortran.dg/namelist_20.f90 1 Jan 1970 00:00:00 -0000
+++ gcc/testsuite/gfortran.dg/namelist_20.f90 17 Apr 2005 20:09:37 -0000 1.1
@@ -0,0 +1,35 @@
+!{ dg-do run }
+! Tests namelist io for an explicit shape array with negative bounds
+! provided by Paul Thomas - pault@gcc.gnu.org
+
+program namelist_20
+ integer, dimension (-4:-2) :: x
+ integer :: i, ier
+ namelist /a/ x
+
+ open (10, status = "scratch")
+ write (10, '(A)') "&a x(-5)=0 /" !-ve index below lbound
+ write (10, '(A)') "&a x(-1)=0 /" !-ve index above ubound
+ write (10, '(A)') "&a x(1:2)=0 /" !+ve indices
+ write (10, '(A)') "&a x(-4:-2)= -4,-3,-2 /" !correct
+ write (10, '(A)') " "
+ rewind (10)
+
+ ier=0
+ read(10, a, iostat=ier)
+ if (ier == 0) call abort ()
+ ier=0
+ read(10, a, iostat=ier)
+ if (ier == 0) call abort ()
+ ier=0
+ read(10, a, iostat=ier)
+ if (ier == 0) call abort ()
+
+ ier=0
+ read(10, a, iostat=ier)
+ if (ier /= 0) call abort ()
+ do i = -4,-2
+ if (x(i) /= i) call abort ()
+ end do
+
+end program namelist_20
--- gcc/testsuite/gfortran.dg/namelist_3.f90 1 Jan 1970 00:00:00 -0000
+++ gcc/testsuite/gfortran.dg/namelist_3.f90 17 Apr 2005 20:09:37 -0000 1.1
@@ -0,0 +1,7 @@
+! { dg-do compile }
+! Check that a pointer cannot be a member of a namelist
+program namelist_3
+ integer,pointer :: x
+ allocate (x)
+ namelist /n/ x ! { dg-error "NAMELIST attribute conflicts with POINTER attribute" "" }
+end program namelist_3
--- gcc/testsuite/gfortran.dg/pr12884.f 1 Jan 1970 00:00:00 -0000
+++ gcc/testsuite/gfortran.dg/pr12884.f 17 Apr 2005 20:09:37 -0000 1.1
@@ -0,0 +1,25 @@
+c { dg-do run }
+c pr 12884
+c test namelist with input file containg / before namelist. Also checks
+c non-standard use of $ instead of &
+c Based on example provided by jean-pierre.flament@univ-lille1.fr
+
+ program pr12884
+ integer ispher,nosym,runflg,noprop
+ namelist /cntrl/ ispher,nosym,runflg,noprop
+ ispher = 0
+ nosym = 0
+ runflg = 0
+ noprop = 0
+ open (10, status = "scratch")
+ write (10, '(A)') " $FILE"
+ write (10, '(A)') " pseu dir/file"
+ write (10, '(A)') " $END"
+ write (10, '(A)') " $cntrl ispher=1,nosym=2,"
+ write (10, '(A)') " runflg=3,noprop=4,$END"
+ write (10, '(A)')"/"
+ rewind (10)
+ read (10, cntrl)
+ if ((ispher.ne.1).or.(nosym.ne.2).or.(runflg.ne.3).or.
+ & (noprop.ne.4)) call abort ()
+ end
--- gcc/testsuite/gfortran.dg/pr17285.f90 1 Jan 1970 00:00:00 -0000
+++ gcc/testsuite/gfortran.dg/pr17285.f90 17 Apr 2005 20:09:37 -0000 1.1
@@ -0,0 +1,25 @@
+! { dg-do run }
+! pr 17285
+! Test that namelist can read its own output.
+! At the same time, check arrays and different terminations
+! Based on example provided by paulthomas2@wanadoo.fr
+
+program pr17285
+ implicit none
+ integer, dimension(10) :: number = 42
+ integer :: ctr, ierr
+ namelist /mynml/ number
+ open (10, status = "scratch")
+ write (10,'(A)') &
+ "&mynml number(:)=42,42,42,42,42,42,42,42,42,42,/ "
+ write (10,mynml)
+ write (10,'(A)') "&mynml number(1:10)=10*42 &end"
+ rewind (10)
+ do ctr = 1,3
+ number = 0
+ read (10, nml = mynml, iostat = ierr)
+ if ((ierr /= 0) .or. (any (number /= 42))) &
+ call abort ()
+ end do
+ close(10)
+end program pr17285
--- gcc/testsuite/gfortran.dg/pr17472.f 1 Jan 1970 00:00:00 -0000
+++ gcc/testsuite/gfortran.dg/pr17472.f 17 Apr 2005 20:09:37 -0000 1.1
@@ -0,0 +1,12 @@
+c { dg-do run }
+c pr 17472
+c test namelist handles arrays
+c Based on example provided by thomas.koenig@online.de
+
+ integer a(10), ctr
+ data a / 1,2,3,4,5,6,7,8,9,10 /
+ namelist /ints/ a
+ do ctr = 1,10
+ if (a(ctr).ne.ctr) call abort ()
+ end do
+ end
--- gcc/testsuite/gfortran.dg/pr18122.f90 1 Jan 1970 00:00:00 -0000
+++ gcc/testsuite/gfortran.dg/pr18122.f90 17 Apr 2005 20:09:37 -0000 1.1
@@ -0,0 +1,45 @@
+! { dg-do run }
+! test namelist with scalars and arrays.
+! Based on example provided by thomas.koenig@online.de
+
+program sechs_w
+ implicit none
+
+ integer, parameter :: dr=selected_real_kind(15)
+
+ integer, parameter :: nkmax=6
+ real (kind=dr) :: rb(nkmax)
+ integer :: z
+
+ real (kind=dr) :: dg
+ real (kind=dr) :: a
+ real (kind=dr) :: da
+ real (kind=dr) :: delta
+ real (kind=dr) :: s,t
+ integer :: nk
+ real (kind=dr) alpha0
+
+ real (kind=dr) :: phi, phi0, rad, rex, zk, z0, drdphi, dzdphi
+
+ namelist /schnecke/ z, dg, a, t, delta, s, nk, rb, alpha0
+
+ open (10,status="scratch")
+ write (10, *) "&SCHNECKE"
+ write (10, *) " z=1,"
+ write (10, *) " dg=58.4,"
+ write (10, *) " a=48.,"
+ write (10, *) " delta=0.4,"
+ write (10, *) " s=0.4,"
+ write (10, *) " nk=6,"
+ write (10, *) " rb=60, 0, 40,"
+ write (10, *) " alpha0=20.,"
+ write (10, *) "/"
+
+ rewind (10)
+ read (10,schnecke)
+ close (10)
+ if ((z /= 1) .or. (dg /= 58.4_dr) .or. (a /= 48.0_dr) .or. &
+ (delta /= 0.4_dr).or. (s /= 0.4_dr) .or. (nk /= 6) .or. &
+ (rb(1) /= 60._dr).or. (rb(2) /= 0.0_dr).or. (rb(3) /=40.0_dr).or. &
+ (alpha0 /= 20.0_dr)) call abort ()
+end program sechs_w
--- gcc/testsuite/gfortran.dg/pr18210.f90 1 Jan 1970 00:00:00 -0000
+++ gcc/testsuite/gfortran.dg/pr18210.f90 17 Apr 2005 20:09:37 -0000 1.1
@@ -0,0 +1,21 @@
+! { dg-do run }
+! Names in upper case and object names starting column 2
+! Based on example provided by thomas.koenig@online.de
+
+program pr18210
+
+ real :: a
+ character*80 :: buffer
+ namelist /foo/ a
+
+ a = 1.4
+ open (10, status = "scratch")
+ write (10,foo)
+ rewind (10)
+ read (10, '(a)') buffer
+ if (buffer(2:4) /= "FOO") call abort ()
+ read (10, '(a)') buffer
+ if (buffer(1:2) /= " A") call abort ()
+ close (10)
+
+end program pr18210
--- gcc/testsuite/gfortran.dg/pr18392.f90 1 Jan 1970 00:00:00 -0000
+++ gcc/testsuite/gfortran.dg/pr18392.f90 17 Apr 2005 20:09:37 -0000 1.1
@@ -0,0 +1,22 @@
+! { dg-do run }
+! pr 18392
+! test namelist with derived types
+! Based on example provided by thomas.koenig@online.de
+
+program pr18392
+ implicit none
+ type foo
+ integer a
+ real b
+ end type foo
+ type(foo) :: a
+ namelist /nl/ a
+ open (10, status="scratch")
+ write (10,*) " &NL"
+ write (10,*) " A%A = 10,"
+ write (10,*) "/"
+ rewind (10)
+ read (10,nl)
+ close (10)
+ IF (a%a /= 10.0) call abort ()
+end program pr18392
--- gcc/testsuite/gfortran.dg/pr19467.f90 1 Jan 1970 00:00:00 -0000
+++ gcc/testsuite/gfortran.dg/pr19467.f90 17 Apr 2005 20:09:37 -0000 1.1
@@ -0,0 +1,18 @@
+! { dg-do run }
+! pr 19467
+! test namelist with character arrays
+! Based on example provided by paulthomas2@wanadoo.fr
+
+program pr19467
+ implicit none
+ integer :: ier
+ character(len=2) :: ch(2)
+ character(len=2) :: dh(2)=(/"aa","bb"/)
+ namelist /a/ ch
+ open (10, status = "scratch")
+ write (10, *) "&A ch = 'aa' , 'bb' /"
+ rewind (10)
+ READ (10,nml=a, iostat = ier)
+ close (10)
+ if ((ier /= 0) .or. (any (ch /= dh))) call abort ()
+end program pr19467
--- gcc/testsuite/gfortran.dg/pr19657.f 1 Jan 1970 00:00:00 -0000
+++ gcc/testsuite/gfortran.dg/pr19657.f 17 Apr 2005 20:09:37 -0000 1.1
@@ -0,0 +1,21 @@
+c { dg-do run }
+c pr 19657
+c test namelist not skipped if ending with logical.
+c Based on example provided by fuyuki@ccsr.u-tokyo.ac.jp
+
+ program pr19657
+ implicit none
+ logical l
+ integer i, ctr
+ namelist /nm/ i, l
+ open (10, status = "scratch")
+ write (10,*) "&nm i=1,l=t &end"
+ write (10,*) "&nm i=2 &end"
+ write (10,*) "&nm i=3 &end"
+ rewind (10)
+ do ctr = 1,3
+ read (10,nm,end=190)
+ if (i.ne.ctr) call abort ()
+ enddo
+ 190 continue
+ end
--- gcc/fortran/gfortran.texi 24 Mar 2005 18:16:33 -0000 1.11
+++ gcc/fortran/gfortran.texi 23 Apr 2005 17:03:07 -0000 1.12
@@ -459,7 +459,6 @@ Usable with bugs:
@itemize @minus
@item Formatted sequential ('T' edit descriptor, and others)
-@item Namelist (can read a namelist that it writes, but not free-form)
@end itemize
Not recommended:
@@ -574,9 +573,6 @@ Set precision for fp units that support
Variables for setting fp rounding mode.
@item
-Support old style namelists ending in $end or &end.
-
-@item
Variable to fill uninitialized variables with a user-defined bit
pattern.
@@ -627,6 +623,7 @@ meaning.
@menu
* Old-style kind specifications::
* Old-style variable initialization::
+* Extensions to namelist::
@end menu
@node Old-style kind specifications
@@ -675,6 +672,54 @@ Examples of standard conforming code equ
DATA i,j,x /1,2,3*0.,1./
@end smallexample
+@node Extensions to namelist
+@section Extensions to namelist
+@cindex Namelist
+
+@command{gfortran} fully supports the fortran95 standard for namelist io
+including array qualifiers, substrings and fully qualified derived types.
+The output from a namelist write is compatible with namelist read. The
+output has all names in upper case and indentation to column 1 after the
+namelist name. Two extensions are permitted:
+
+Old-style use of $ instead of &
+@smallexample
+$MYNML
+ X(:)%Y(2) = 1.0 2.0 3.0
+ CH(1:4) = "abcd"
+$END
+@end smallexample
+
+It should be noticed that the default terminator is / rather than &END.
+
+Querying of the namelist when inputting from stdin. After at least
+one space, entering ? sends to stdout the namelist name and the names of
+the variables in the namelist:
+@smallexample
+?
+
+&mynml
+ x
+ x%y
+ ch
+&end
+@end smallexample
+
+Entering =? outputs the namelist to stdout, as if WRITE (*,NML = mynml)
+had been called:
+@smallexample
+=?
+
+&MYNML
+ X(1)%Y= 0.000000 , 1.000000 , 0.000000 ,
+ X(2)%Y= 0.000000 , 2.000000 , 0.000000 ,
+ X(3)%Y= 0.000000 , 3.000000 , 0.000000 ,
+ CH=abcd, /
+@end smallexample
+
+To aid this dialog, when input is from stdin, errors produce send their
+messages to stderr and execution continues, even if IOSTAT is set.
+
@include intrinsic.texi
@c ---------------------------------------------------------------------
@c Contributing
Jakub
More information about the Gcc-patches
mailing list