From fc2a7c2711d61197795e86f34a978af6f71d8a34 Mon Sep 17 00:00:00 2001 From: pault Date: Sun, 17 Apr 2005 20:09:37 +0000 Subject: [PATCH] ------------------------------------------------------------------- git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@98287 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 16 + gcc/fortran/trans-io.c | 364 ++++++---- gcc/testsuite/ChangeLog | 24 + gcc/testsuite/gfortran.dg/namelist_1.f90 | 3 +- gcc/testsuite/gfortran.dg/namelist_11.f | 55 ++ gcc/testsuite/gfortran.dg/namelist_12.f | 56 ++ gcc/testsuite/gfortran.dg/namelist_13.f90 | 38 ++ gcc/testsuite/gfortran.dg/namelist_14.f90 | 94 +++ gcc/testsuite/gfortran.dg/namelist_15.f90 | 58 ++ gcc/testsuite/gfortran.dg/namelist_16.f90 | 29 + gcc/testsuite/gfortran.dg/namelist_17.f90 | 30 + gcc/testsuite/gfortran.dg/namelist_18.f90 | 37 ++ gcc/testsuite/gfortran.dg/namelist_19.f90 | 135 ++++ gcc/testsuite/gfortran.dg/namelist_2.f90 | 7 + gcc/testsuite/gfortran.dg/namelist_20.f90 | 35 + gcc/testsuite/gfortran.dg/namelist_3.f90 | 7 + gcc/testsuite/gfortran.dg/pr12884.f | 25 + gcc/testsuite/gfortran.dg/pr17285.f90 | 25 + gcc/testsuite/gfortran.dg/pr17472.f | 12 + gcc/testsuite/gfortran.dg/pr18122.f90 | 45 ++ gcc/testsuite/gfortran.dg/pr18210.f90 | 21 + gcc/testsuite/gfortran.dg/pr18392.f90 | 22 + gcc/testsuite/gfortran.dg/pr19467.f90 | 18 + gcc/testsuite/gfortran.dg/pr19657.f | 21 + libgfortran/ChangeLog | 40 ++ libgfortran/io/io.h | 75 ++- libgfortran/io/list_read.c | 1035 +++++++++++++++++++++++++---- libgfortran/io/lock.c | 24 +- libgfortran/io/transfer.c | 117 ++-- libgfortran/io/write.c | 363 +++++++++- 30 files changed, 2432 insertions(+), 399 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/namelist_11.f create mode 100644 gcc/testsuite/gfortran.dg/namelist_12.f create mode 100644 gcc/testsuite/gfortran.dg/namelist_13.f90 create mode 100644 gcc/testsuite/gfortran.dg/namelist_14.f90 create mode 100644 gcc/testsuite/gfortran.dg/namelist_15.f90 create mode 100644 gcc/testsuite/gfortran.dg/namelist_16.f90 create mode 100644 gcc/testsuite/gfortran.dg/namelist_17.f90 create mode 100644 gcc/testsuite/gfortran.dg/namelist_18.f90 create mode 100644 gcc/testsuite/gfortran.dg/namelist_19.f90 create mode 100644 gcc/testsuite/gfortran.dg/namelist_2.f90 create mode 100644 gcc/testsuite/gfortran.dg/namelist_20.f90 create mode 100644 gcc/testsuite/gfortran.dg/namelist_3.f90 create mode 100644 gcc/testsuite/gfortran.dg/pr12884.f create mode 100644 gcc/testsuite/gfortran.dg/pr17285.f90 create mode 100644 gcc/testsuite/gfortran.dg/pr17472.f create mode 100644 gcc/testsuite/gfortran.dg/pr18122.f90 create mode 100644 gcc/testsuite/gfortran.dg/pr18210.f90 create mode 100644 gcc/testsuite/gfortran.dg/pr18392.f90 create mode 100644 gcc/testsuite/gfortran.dg/pr19467.f90 create mode 100644 gcc/testsuite/gfortran.dg/pr19657.f diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 5864697..3fb03c3 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,19 @@ +2005-04-17 Paul Thomas + + PR fortran/17472 + PR fortran/18209 + PR fortran/18396 + PR fortran/19467 + PR fortran/19657 + * fortran/trans-io.c (gfc_build_io_library_fndecls): Create declaration for + st_set_nml_var and st_set_nml_var_dim. Remove declarations of old + namelist functions. + (build_dt): Simplified call to transfer_namelist_element. + (nml_get_addr_expr): Generates address expression for start of object data. New function. + (nml_full_name): Qualified name for derived type components. New function. + (transfer_namelist_element): Modified for calls to new functions and improved derived + type handling. + 2005-04-17 Richard Guenther * scanner.c (gfc_next_char_literal): Reset truncation flag diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index 4169321..8701d5e 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -125,11 +125,8 @@ static GTY(()) tree iocall_iolength_done; static GTY(()) tree iocall_rewind; static GTY(()) tree iocall_backspace; static GTY(()) tree iocall_endfile; -static GTY(()) tree iocall_set_nml_val_int; -static GTY(()) tree iocall_set_nml_val_float; -static GTY(()) tree iocall_set_nml_val_char; -static GTY(()) tree iocall_set_nml_val_complex; -static GTY(()) tree iocall_set_nml_val_log; +static GTY(()) tree iocall_set_nml_val; +static GTY(()) tree iocall_set_nml_val_dim; /* Variable for keeping track of what the last data transfer statement was. Used for deciding which subroutine to call when the data @@ -314,34 +311,19 @@ gfc_build_io_library_fndecls (void) gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")), gfc_int4_type_node, 0); - iocall_set_nml_val_int = - gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_int")), - void_type_node, 4, - pvoid_type_node, pvoid_type_node, - gfc_int4_type_node,gfc_int4_type_node); - iocall_set_nml_val_float = - gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_float")), - void_type_node, 4, - pvoid_type_node, pvoid_type_node, - gfc_int4_type_node,gfc_int4_type_node); - iocall_set_nml_val_char = - gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_char")), + iocall_set_nml_val = + gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var")), void_type_node, 5, pvoid_type_node, pvoid_type_node, - gfc_int4_type_node, gfc_int4_type_node, - gfc_charlen_type_node); - iocall_set_nml_val_complex = - gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_complex")), - void_type_node, 4, - pvoid_type_node, pvoid_type_node, - gfc_int4_type_node,gfc_int4_type_node); - iocall_set_nml_val_log = - gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_log")), - void_type_node, 4, - pvoid_type_node, pvoid_type_node, - gfc_int4_type_node,gfc_int4_type_node); + gfc_int4_type_node, gfc_charlen_type_node, + gfc_int4_type_node); + iocall_set_nml_val_dim = + gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_dim")), + void_type_node, 4, + gfc_int4_type_node, gfc_int4_type_node, + gfc_int4_type_node, gfc_int4_type_node); } @@ -815,11 +797,11 @@ gfc_trans_inquire (gfc_code * code) return gfc_finish_block (&block); } - static gfc_expr * gfc_new_nml_name_expr (const char * name) { gfc_expr * nml_name; + nml_name = gfc_get_expr(); nml_name->ref = NULL; nml_name->expr_type = EXPR_CONSTANT; @@ -832,114 +814,229 @@ gfc_new_nml_name_expr (const char * name) return nml_name; } -static gfc_expr * -get_new_var_expr(gfc_symbol * sym) +/* nml_full_name builds up the fully qualified name of a + derived type component. */ + +static char* +nml_full_name (const char* var_name, const char* cmp_name) { - gfc_expr * nml_var; - - 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; + 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; } -/* 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: +/* nml_get_addr_expr builds an address expression from the + gfc_symbol or gfc_component backend_decl's. An offset is + provided so that the address of an element of an array of + derived types is returned. This is used in the runtime to + determine that span of the derived type. */ + +static tree +nml_get_addr_expr (gfc_symbol * sym, gfc_component * c, + tree base_addr) +{ + tree decl = NULL_TREE; + tree tmp; + tree itmp; + int array_flagged; + int dummy_arg_flagged; + + if (sym) + { + sym->attr.referenced = 1; + decl = gfc_get_symbol_decl (sym); + } + else + decl = c->backend_decl; + + gcc_assert (decl && ((TREE_CODE (decl) == FIELD_DECL + || TREE_CODE (decl) == VAR_DECL + || TREE_CODE (decl) == PARM_DECL) + || TREE_CODE (decl) == COMPONENT_REF)); + + tmp = decl; + + /* Build indirect reference, if dummy argument. */ + + dummy_arg_flagged = POINTER_TYPE_P (TREE_TYPE(tmp)); - &foo bzz=1,2,3,4,5/ + itmp = (dummy_arg_flagged) ? gfc_build_indirect_ref (tmp) : tmp; - 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. */ + /* If an array, set flag and use indirect ref. if built. */ + + array_flagged = (TREE_CODE (TREE_TYPE (itmp)) == ARRAY_TYPE + && !TYPE_STRING_FLAG (TREE_TYPE (itmp))); + + if (array_flagged) + tmp = itmp; + + /* Treat the component of a derived type, using base_addr for + the derived type. */ + + if (TREE_CODE (decl) == FIELD_DECL) + tmp = build3 (COMPONENT_REF, TREE_TYPE (tmp), + base_addr, tmp, NULL_TREE); + + /* If we have a derived type component, a reference to the first + element of the array is built. This is done so that base_addr, + used in the build of the component reference, always points to + a RECORD_TYPE. */ + + if (array_flagged) + tmp = gfc_build_array_ref (tmp, gfc_index_zero_node); + + /* Now build the address expression. */ + + tmp = gfc_build_addr_expr (NULL, tmp); + + /* If scalar dummy, resolve indirect reference now. */ + + if (dummy_arg_flagged && !array_flagged) + tmp = gfc_build_indirect_ref (tmp); + + gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp))); + + return tmp; +} + +/* For an object VAR_NAME whose base address is BASE_ADDR, generate a + call to iocall_set_nml_val. For derived type variable, recursively + generate calls to iocall_set_nml_val for each 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) +transfer_namelist_element (stmtblock_t * block, const char * var_name, + gfc_symbol * sym, gfc_component * c, + tree base_addr) { - tree tmp, args, arg2; - tree expr; + gfc_typespec * ts = NULL; + gfc_array_spec * as = NULL; + tree addr_expr = NULL; + tree dt = NULL; + tree string; + tree tmp; + tree args; + tree dtype; + int n_dim; + int itype; + int rank = 0; - gcc_assert (POINTER_TYPE_P (TREE_TYPE (addr_expr))); + gcc_assert (sym || c); - 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) */ - default : - internal_error ("Bad namelist IO basetype (%d)", ts->type); - } + NML_FIRST_ARG (addr_expr); + NML_ADD_ARG (string); + NML_ADD_ARG (IARG (ts->kind)); + + if (ts->type == BT_CHARACTER) + NML_ADD_ARG (ts->cl->backend_decl); + else + NML_ADD_ARG (convert (gfc_charlen_type_node, integer_zero_node)); + NML_ADD_ARG (dtype); + tmp = gfc_build_function_call (iocall_set_nml_val, args); gfc_add_expr_to_block (block, tmp); + + /* If the object is an array, transfer rank times: + (null pointer, name, stride, lbound, ubound) */ + + for ( n_dim = 0 ; n_dim < rank ; n_dim++ ) + { + NML_FIRST_ARG (IARG (n_dim)); + NML_ADD_ARG (GFC_TYPE_ARRAY_STRIDE (dt, n_dim)); + NML_ADD_ARG (GFC_TYPE_ARRAY_LBOUND (dt, n_dim)); + NML_ADD_ARG (GFC_TYPE_ARRAY_UBOUND (dt, n_dim)); + tmp = gfc_build_function_call (iocall_set_nml_val_dim, args); + gfc_add_expr_to_block (block, tmp); + } + + if (ts->type == BT_DERIVED) + { + gfc_component *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 * code) stmtblock_t block, post_block; gfc_dt *dt; tree tmp; - gfc_expr *nmlname, *nmlvar; + gfc_expr *nmlname; gfc_namelist *nml; - gfc_se se,se2; gfc_init_block (&block); gfc_init_block (&post_block); @@ -1010,30 +1106,20 @@ build_dt (tree * function, gfc_code * code) if (dt->namelist) { - if (dt->format_expr || dt->format_label) - fatal_error("A format cannot be specified with a namelist"); - - nmlname = gfc_new_nml_name_expr(dt->namelist->name); - - set_string (&block, &post_block, ioparm_namelist_name, - ioparm_namelist_name_len, nmlname); - - 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); - } + if (dt->format_expr || dt->format_label) + gfc_internal_error ("build_dt: format with namelist"); + + nmlname = gfc_new_nml_name_expr(dt->namelist->name); + + set_string (&block, &post_block, ioparm_namelist_name, + ioparm_namelist_name_len, nmlname); + + if (last_dt == READ) + 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); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 023ccdd..73501f2 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,27 @@ +2005-04-17 Paul Thomas + + PR libfortran/12884 gfortran.dg/pr12884.f: New test + PR libfortran/17285 gfortran.dg/pr17285.f90: New test + PR libfortran/17472, 18396, 18209 gfortran.dg/pr17472.f: New test + PR libfortran/18122, 18591 gfortran.dg/pr18122.f90: New test + PR libfortran/18210 gfortran.dg/pr18210.f90: New test + PR libfortran/18392 gfortran.dg/pr18392.f90: New test + PR libfortran/19467 gfortran.dg/pr19467.f90: New test + PR libfortran/19657 gfortran.dg/pr19657.f90: New test + * gfortran.dg/namelist_1.f90: Correct comment (PUBLIC and PRIVATE wrong way round). + * gfortran.dg/namelist_2.f90: Variables with INTENT(IN) cannot be in namelists. New test + * gfortran.dg/namelist_3.f90: Pointers cannot be in namelists. New test + * gfortran.dg/namelist_11.f: Tests reals and qualifiers in namelist. New test + * gfortran.dg/namelist_12.f: Tests integers and qualifiers in namelist. New test + * gfortran.dg/namelist_13.f90: Tests derived types in namelist. New test + * gfortran.dg/namelist_14.f90: Tests trans-io.c namelist support. New test + * gfortran.dg/namelist_15.f90: Tests arrays of derived types in namelist. New test + * gfortran.dg/namelist_16.f90: Tests complex in namelist. New test + * gfortran.dg/namelist_17.f90: Tests logical in namelist. New test + * gfortran.dg/namelist_18.f90: Tests charcter delimiters in namelist. New test + * gfortran.dg/namelist_19.f90: Tests namelist errors. New test + * gfortran.dg/namelist_20.f90: Tests negative bounds for explicit arrays. New test + 2005-04-17 Richard Guenther * gfortran.dg/wtruncate.f: New testcase. diff --git a/gcc/testsuite/gfortran.dg/namelist_1.f90 b/gcc/testsuite/gfortran.dg/namelist_1.f90 index 9bebe77..ee028dd 100644 --- a/gcc/testsuite/gfortran.dg/namelist_1.f90 +++ b/gcc/testsuite/gfortran.dg/namelist_1.f90 @@ -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 - diff --git a/gcc/testsuite/gfortran.dg/namelist_11.f b/gcc/testsuite/gfortran.dg/namelist_11.f new file mode 100644 index 0000000..4145a90 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/namelist_11.f @@ -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 diff --git a/gcc/testsuite/gfortran.dg/namelist_12.f b/gcc/testsuite/gfortran.dg/namelist_12.f new file mode 100644 index 0000000..e6d1224 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/namelist_12.f @@ -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 diff --git a/gcc/testsuite/gfortran.dg/namelist_13.f90 b/gcc/testsuite/gfortran.dg/namelist_13.f90 new file mode 100644 index 0000000..5b7122c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/namelist_13.f90 @@ -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 + diff --git a/gcc/testsuite/gfortran.dg/namelist_14.f90 b/gcc/testsuite/gfortran.dg/namelist_14.f90 new file mode 100644 index 0000000..d22040f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/namelist_14.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/namelist_15.f90 b/gcc/testsuite/gfortran.dg/namelist_15.f90 new file mode 100644 index 0000000..8c64ab0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/namelist_15.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/namelist_16.f90 b/gcc/testsuite/gfortran.dg/namelist_16.f90 new file mode 100644 index 0000000..c6eb8f7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/namelist_16.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/namelist_17.f90 b/gcc/testsuite/gfortran.dg/namelist_17.f90 new file mode 100644 index 0000000..e3eac52 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/namelist_17.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/namelist_18.f90 b/gcc/testsuite/gfortran.dg/namelist_18.f90 new file mode 100644 index 0000000..eba8b6b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/namelist_18.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/namelist_19.f90 b/gcc/testsuite/gfortran.dg/namelist_19.f90 new file mode 100644 index 0000000..c06abf5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/namelist_19.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/namelist_2.f90 b/gcc/testsuite/gfortran.dg/namelist_2.f90 new file mode 100644 index 0000000..b92e459 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/namelist_2.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/namelist_20.f90 b/gcc/testsuite/gfortran.dg/namelist_20.f90 new file mode 100644 index 0000000..155cf6f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/namelist_20.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/namelist_3.f90 b/gcc/testsuite/gfortran.dg/namelist_3.f90 new file mode 100644 index 0000000..68cc7d5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/namelist_3.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/pr12884.f b/gcc/testsuite/gfortran.dg/pr12884.f new file mode 100644 index 0000000..425604c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr12884.f @@ -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 diff --git a/gcc/testsuite/gfortran.dg/pr17285.f90 b/gcc/testsuite/gfortran.dg/pr17285.f90 new file mode 100644 index 0000000..58aee32 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr17285.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/pr17472.f b/gcc/testsuite/gfortran.dg/pr17472.f new file mode 100644 index 0000000..4a1ecd9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr17472.f @@ -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 diff --git a/gcc/testsuite/gfortran.dg/pr18122.f90 b/gcc/testsuite/gfortran.dg/pr18122.f90 new file mode 100644 index 0000000..3907f0a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr18122.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/pr18210.f90 b/gcc/testsuite/gfortran.dg/pr18210.f90 new file mode 100644 index 0000000..6095984 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr18210.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/pr18392.f90 b/gcc/testsuite/gfortran.dg/pr18392.f90 new file mode 100644 index 0000000..de156f5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr18392.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/pr19467.f90 b/gcc/testsuite/gfortran.dg/pr19467.f90 new file mode 100644 index 0000000..ab4fa99 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr19467.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/pr19657.f b/gcc/testsuite/gfortran.dg/pr19657.f new file mode 100644 index 0000000..1fe32ac --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr19657.f @@ -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 diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 9fc0b63..9c083ad 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,43 @@ +2005-04-17 Paul Thomas + +* io/list_read.c (eat_separator): at_eol = 1 replaced(zapped at some time?). + +2005-04-17 Paul Thomas + + + PR libgfortran/12884 + PR libgfortran/17285 + PR libgfortran/18122 + PR libgfortran/18210 + PR libgfortran/18392 + PR libgfortran/18591 + PR libgfortran/18879 + * io/io.h (nml_ls): Declare. + (namelist_info): Modify for arrays. + * io/list_read.c (namelist_read): Reduced to call to new functions. + (match_namelist_name): Simplified. + (nml_query): Handles stdin queries ? and =?. New function. + (nml_get_obj_data): Parses object name. New function. + (touch_nml_nodes): Marks objects for read. New function. + (untouch_nml_nodes): Resets objects. New function. + (parse_qualifier): Parses and checks qualifiers. New function + (nml_read_object): Reads and stores object data. New function. + (eat_separator): No new_record on '/' in namelist. + (finish_separator): No new_record on '/' in namelist. + (read_logical): Error return for namelist. + (read_integer): Error return for namelist. + (read_complex): Error return for namelist. + (read_real): Error return for namelist. + * io/lock.c (library_end): Free extended namelist_info types. + * io/transfer.c (st_set_nml_var): Modified for arrays. + (st_set_nml_var_dim): Dimension descriptors. New function. + * io/write.c (namelist_write): Reduced to call to new functions. + (nml_write_obj): Writes output for object. New function. + (write_integer): Suppress leading blanks for repeat counts. + (write_int): Suppress leading blanks for repeat counts. + (write_float): Suppress leading blanks for repeat counts. + (output_float): Suppress leading blanks for repeat counts. + 2005-04-15 Thomas Koenig PR libfortran/18495 diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h index 05c4355..4814d8d 100644 --- a/libgfortran/io/io.h +++ b/libgfortran/io/io.h @@ -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 +{ - 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. + /* Index counter for this dimension. */ + ssize_t idx; - All these requirements need a new data structure to record all info - about the namelist. -*/ + /* Start for the index counter. */ + ssize_t start; + + /* End for the index counter. */ + ssize_t end; + + /* Step for the index counter. */ + ssize_t step; +} +nml_loop_spec; + +/* namelist_info type contains all the scalar information about the + object and arrays of descriptor_dimension and nml_loop_spec types for + arrays. */ typedef struct namelist_type { + + /* 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; diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c index 384df36..becf09e 100644 --- a/libgfortran/io/list_read.c +++ b/libgfortran/io/list_read.c @@ -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,910 @@ 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; } + 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. */ - while (name_len < len) +static void +nml_match_name (char *name, index_type len) +{ + index_type i; + char c; + nml_read_error = 0; + for (i = 0; i < len; i++) { c = next_char (); - 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 */ - len = nl->len; - p = nl->mem_pos; + 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); - /* skip any blanks or tabs after the = */ - eat_spaces (); + /* Reset the error flag and try to read next value, if + repeat_count=0 */ + + nml_read_error = 0; + nml_carry = 0; + if (--repeat_count <= 0) + { + if (input_complete) + return SUCCESS; + if (at_eol) + finish_separator (); + if (input_complete) + return SUCCESS; + + /* GFC_TYPE_UNKNOWN through for nulls and is detected + after the switch block. */ + + saved_type = GFC_DTYPE_UNKNOWN; + free_saved (); switch (nl->type) - { - 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) + 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; + } + } - 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. */ - case BT_NULL: - break; - } + prev_nl = nl; + if (nml_read_error) + return SUCCESS; - break; + 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 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; + } - default : - push_char(tolower(c)); + 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; } diff --git a/libgfortran/io/lock.c b/libgfortran/io/lock.c index 21d04d7..d85c9b8 100644 --- a/libgfortran/io/lock.c +++ b/libgfortran/io/lock.c @@ -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 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; } diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index 77e9439..bece250 100644 --- a/libgfortran/io/transfer.c +++ b/libgfortran/io/transfer.c @@ -1,5 +1,6 @@ /* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc. Contributed by Andy Vaught + Namelist transfer functions contributed by Paul Thomas This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -1623,94 +1624,78 @@ st_write_done (void) library_end (); } +/* Receives the scalar information for namelist objects and stores it + in a linked list of namelist_info types. */ -static void -st_set_nml_var (void * var_addr, char * var_name, int var_name_len, - int kind, bt type, int string_length) +void +st_set_nml_var (void * var_addr, char * var_name, GFC_INTEGER_4 len, + gfc_charlen_type string_length, GFC_INTEGER_4 dtype) { - namelist_info *t1 = NULL, *t2 = NULL; - namelist_info *nml = (namelist_info *) get_mem (sizeof (namelist_info)); + namelist_info *t1 = NULL; + namelist_info *nml; + + nml = (namelist_info*) get_mem (sizeof (namelist_info)); + nml->mem_pos = var_addr; - if (var_name) + + nml->var_name = (char*) get_mem (strlen (var_name) + 1); + strcpy (nml->var_name, var_name); + + nml->len = (int) len; + nml->string_length = (index_type) string_length; + + nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK); + nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT); + nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT); + + if (nml->var_rank > 0) { - assert (var_name_len > 0); - nml->var_name = (char*) get_mem (var_name_len+1); - strncpy (nml->var_name, var_name, var_name_len); - nml->var_name[var_name_len] = 0; + nml->dim = (descriptor_dimension*) + get_mem (nml->var_rank * sizeof (descriptor_dimension)); + nml->ls = (nml_loop_spec*) + get_mem (nml->var_rank * sizeof (nml_loop_spec)); } else { - assert (var_name_len == 0); - nml->var_name = NULL; + nml->dim = NULL; + nml->ls = NULL; } - nml->len = kind; - nml->type = type; - nml->string_length = string_length; - nml->next = NULL; if (ionml == NULL) - ionml = nml; + ionml = nml; else { - t1 = ionml; - while (t1 != NULL) - { - t2 = t1; - t1 = t1->next; - } - t2->next = nml; + for (t1 = ionml; t1->next; t1 = t1->next); + t1->next = nml; } + return; } -extern void st_set_nml_var_int (void *, char *, int, int); -export_proto(st_set_nml_var_int); - -extern void st_set_nml_var_float (void *, char *, int, int); -export_proto(st_set_nml_var_float); - -extern void st_set_nml_var_char (void *, char *, int, int, gfc_charlen_type); -export_proto(st_set_nml_var_char); - -extern void st_set_nml_var_complex (void *, char *, int, int); -export_proto(st_set_nml_var_complex); - -extern void st_set_nml_var_log (void *, char *, int, int); -export_proto(st_set_nml_var_log); +/* Store the dimensional information for the namelist object. */ void -st_set_nml_var_int (void * var_addr, char * var_name, int var_name_len, - int kind) +st_set_nml_var_dim (GFC_INTEGER_4 n_dim, GFC_INTEGER_4 stride, + GFC_INTEGER_4 lbound, GFC_INTEGER_4 ubound) { - st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_INTEGER, 0); -} + namelist_info * nml; + int n; -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); + diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c index d97caec..c57ebac 100644 --- a/libgfortran/io/write.c +++ b/libgfortran/io/write.c @@ -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 +#include #include #include #include @@ -44,6 +46,8 @@ typedef enum sign_t; +static int no_leading_blank = 0 ; + void write_a (fnode * f, const char *source, int len) { @@ -576,7 +580,9 @@ output_float (fnode *f, double value, int len) leadzero = 0; /* Padd to full field width. */ - if (nblanks > 0) + + + if ( ( nblanks > 0 ) && !no_leading_blank ) { memset (out, ' ', nblanks); out += nblanks; @@ -650,6 +656,13 @@ output_float (fnode *f, double value, int len) #endif memcpy (out, buffer, edigits); } + + if ( no_leading_blank ) + { + out += edigits; + memset( out , ' ' , nblanks ); + no_leading_blank = 0; + } } @@ -802,13 +815,24 @@ write_int (fnode *f, const char *source, int len, char *(*conv) (uint64_t)) goto done; } + + if (!no_leading_blank) + { memset (p, ' ', nblank); p += nblank; - memset (p, '0', nzero); p += nzero; - memcpy (p, q, digits); + } + else + { + memset (p, '0', nzero); + p += nzero; + memcpy (p, q, digits); + p += digits; + memset (p, ' ', nblank); + no_leading_blank = 0; + } done: return; @@ -1102,9 +1126,16 @@ write_integer (const char *source, int length) if(width < digits ) width = digits ; p = write_block (width) ; - + if (no_leading_blank) + { + memcpy (p, q, digits); + memset(p + digits ,' ', width - digits) ; + } + else + { memset(p ,' ', width - digits) ; memcpy (p + width - digits, q, digits); + } } @@ -1269,60 +1300,320 @@ list_formatted_write (bt type, void *p, int len) char_flag = (type == BT_CHARACTER); } -void -namelist_write (void) -{ - namelist_info * t1, *t2; - int len,num; - void * p; +/* NAMELIST OUTPUT - num = 0; - write_character("&",1); - write_character (ioparm.namelist_name, ioparm.namelist_name_len); - write_character("\n",1); + 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. */ - if (ionml != NULL) +/* 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) { - t1 = ionml; - while (t1 != NULL) + 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); + + 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; + } + } + } + + /* 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("/",1); + write_character (" /\n", 4); + + /* Recover the original delimiter. */ + + current_unit->flags.delim = tmp_delim; } + +#undef NML_DIGITS + -- 2.7.4