OSDN Git Service

-------------------------------------------------------------------
authorpault <pault@138bc75d-0d04-0410-961f-82ee72b054a4>
Sun, 17 Apr 2005 20:09:37 +0000 (20:09 +0000)
committerpault <pault@138bc75d-0d04-0410-961f-82ee72b054a4>
Sun, 17 Apr 2005 20:09:37 +0000 (20:09 +0000)
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@98287 138bc75d-0d04-0410-961f-82ee72b054a4

30 files changed:
gcc/fortran/ChangeLog
gcc/fortran/trans-io.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/namelist_1.f90
gcc/testsuite/gfortran.dg/namelist_11.f [new file with mode: 0644]
gcc/testsuite/gfortran.dg/namelist_12.f [new file with mode: 0644]
gcc/testsuite/gfortran.dg/namelist_13.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/namelist_14.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/namelist_15.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/namelist_16.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/namelist_17.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/namelist_18.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/namelist_19.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/namelist_2.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/namelist_20.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/namelist_3.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/pr12884.f [new file with mode: 0644]
gcc/testsuite/gfortran.dg/pr17285.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/pr17472.f [new file with mode: 0644]
gcc/testsuite/gfortran.dg/pr18122.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/pr18210.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/pr18392.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/pr19467.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/pr19657.f [new file with mode: 0644]
libgfortran/ChangeLog
libgfortran/io/io.h
libgfortran/io/list_read.c
libgfortran/io/lock.c
libgfortran/io/transfer.c
libgfortran/io/write.c

index 5864697..3fb03c3 100644 (file)
@@ -1,3 +1,19 @@
+2005-04-17 Paul Thomas <pault@gcc.gnu.org>
+
+       PR fortran/17472
+       PR fortran/18209
+       PR fortran/18396
+       PR fortran/19467
+       PR fortran/19657
+       * fortran/trans-io.c (gfc_build_io_library_fndecls): Create declaration for
+       st_set_nml_var and st_set_nml_var_dim. Remove declarations of old
+       namelist functions.
+       (build_dt): Simplified call to transfer_namelist_element.
+       (nml_get_addr_expr): Generates address expression for start of object data. New function.
+       (nml_full_name): Qualified name for derived type components. New function.
+       (transfer_namelist_element): Modified for calls to new functions and improved derived
+       type handling.
+
 2005-04-17  Richard Guenther  <rguenth@gcc.gnu.org>
 
        * scanner.c (gfc_next_char_literal): Reset truncation flag
index 4169321..8701d5e 100644 (file)
@@ -125,11 +125,8 @@ static GTY(()) tree iocall_iolength_done;
 static GTY(()) tree iocall_rewind;
 static GTY(()) tree iocall_backspace;
 static GTY(()) tree iocall_endfile;
-static GTY(()) tree iocall_set_nml_val_int;
-static GTY(()) tree iocall_set_nml_val_float;
-static GTY(()) tree iocall_set_nml_val_char;
-static GTY(()) tree iocall_set_nml_val_complex;
-static GTY(()) tree iocall_set_nml_val_log;
+static GTY(()) tree iocall_set_nml_val;
+static GTY(()) tree iocall_set_nml_val_dim;
 
 /* Variable for keeping track of what the last data transfer statement
    was.  Used for deciding which subroutine to call when the data
@@ -314,34 +311,19 @@ gfc_build_io_library_fndecls (void)
     gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
                                     gfc_int4_type_node, 0);
 
-  iocall_set_nml_val_int =
-    gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_int")),
-                                     void_type_node, 4,
-                                     pvoid_type_node, pvoid_type_node,
-                                     gfc_int4_type_node,gfc_int4_type_node);
 
-  iocall_set_nml_val_float =
-    gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_float")),
-                                     void_type_node, 4,
-                                     pvoid_type_node, pvoid_type_node,
-                                     gfc_int4_type_node,gfc_int4_type_node);
-  iocall_set_nml_val_char =
-    gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_char")),
+  iocall_set_nml_val =
+    gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var")),
                                      void_type_node, 5,
                                      pvoid_type_node, pvoid_type_node,
-                                     gfc_int4_type_node, gfc_int4_type_node, 
-                                     gfc_charlen_type_node);
-  iocall_set_nml_val_complex =
-    gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_complex")),
-                                     void_type_node, 4,
-                                     pvoid_type_node, pvoid_type_node,
-                                     gfc_int4_type_node,gfc_int4_type_node);
-  iocall_set_nml_val_log =
-    gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_log")),
-                                     void_type_node, 4,
-                                     pvoid_type_node, pvoid_type_node,
-                                     gfc_int4_type_node,gfc_int4_type_node);
+                                     gfc_int4_type_node, gfc_charlen_type_node, 
+                                    gfc_int4_type_node);
 
+  iocall_set_nml_val_dim =
+    gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_dim")),
+                                    void_type_node, 4,
+                                    gfc_int4_type_node, gfc_int4_type_node,
+                                    gfc_int4_type_node, gfc_int4_type_node);
 }
 
 
@@ -815,11 +797,11 @@ gfc_trans_inquire (gfc_code * code)
   return gfc_finish_block (&block);
 }
 
-
 static gfc_expr *
 gfc_new_nml_name_expr (const char * name)
 {
    gfc_expr * nml_name;
+
    nml_name = gfc_get_expr();
    nml_name->ref = NULL;
    nml_name->expr_type = EXPR_CONSTANT;
@@ -832,114 +814,229 @@ gfc_new_nml_name_expr (const char * name)
    return nml_name;
 }
 
-static gfc_expr *
-get_new_var_expr(gfc_symbol * sym)
+/* nml_full_name builds up the fully qualified name of a
+   derived type component. */
+
+static char*
+nml_full_name (const char* var_name, const char* cmp_name)
 {
-  gfc_expr * nml_var;
-
-  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);
index 023ccdd..73501f2 100644 (file)
@@ -1,3 +1,27 @@
+2005-04-17 Paul Thomas <pault@gcc.gnu.org>
+
+       PR libfortran/12884 gfortran.dg/pr12884.f: New test
+       PR libfortran/17285 gfortran.dg/pr17285.f90: New test
+       PR libfortran/17472, 18396, 18209 gfortran.dg/pr17472.f: New test
+       PR libfortran/18122, 18591 gfortran.dg/pr18122.f90: New test
+       PR libfortran/18210 gfortran.dg/pr18210.f90: New test
+       PR libfortran/18392 gfortran.dg/pr18392.f90: New test
+       PR libfortran/19467 gfortran.dg/pr19467.f90: New test
+       PR libfortran/19657 gfortran.dg/pr19657.f90: New test
+       * gfortran.dg/namelist_1.f90: Correct comment (PUBLIC and PRIVATE wrong way round).
+       * gfortran.dg/namelist_2.f90: Variables with INTENT(IN) cannot be in namelists. New test
+       * gfortran.dg/namelist_3.f90: Pointers cannot be in namelists. New test
+       * gfortran.dg/namelist_11.f: Tests reals and qualifiers in namelist. New test
+       * gfortran.dg/namelist_12.f: Tests integers and qualifiers in namelist. New test
+       * gfortran.dg/namelist_13.f90: Tests derived types in namelist. New test
+       * gfortran.dg/namelist_14.f90: Tests trans-io.c namelist support. New test
+       * gfortran.dg/namelist_15.f90: Tests arrays of derived types in namelist. New test
+       * gfortran.dg/namelist_16.f90: Tests complex in namelist. New test
+       * gfortran.dg/namelist_17.f90: Tests logical in namelist. New test
+       * gfortran.dg/namelist_18.f90: Tests charcter delimiters in namelist. New test
+       * gfortran.dg/namelist_19.f90: Tests namelist errors. New test
+       * gfortran.dg/namelist_20.f90: Tests negative bounds for explicit arrays. New test
+
 2005-04-17  Richard Guenther  <rguenth@gcc.gnu.org>
 
        * gfortran.dg/wtruncate.f: New testcase.
index 9bebe77..ee028dd 100644 (file)
@@ -1,8 +1,7 @@
 ! { dg-do compile }
-! Check that public entities in private namelists are rejected
+! Check that private entities in public namelists are rejected
 module namelist_1
   public
   integer,private :: x
   namelist /n/ x ! { dg-error "cannot be member of PUBLIC namelist" "" }
 end module
-
diff --git a/gcc/testsuite/gfortran.dg/namelist_11.f b/gcc/testsuite/gfortran.dg/namelist_11.f
new file mode 100644 (file)
index 0000000..4145a90
--- /dev/null
@@ -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 (file)
index 0000000..e6d1224
--- /dev/null
@@ -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 (file)
index 0000000..5b7122c
--- /dev/null
@@ -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 (file)
index 0000000..d22040f
--- /dev/null
@@ -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 (file)
index 0000000..8c64ab0
--- /dev/null
@@ -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 (file)
index 0000000..c6eb8f7
--- /dev/null
@@ -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 (file)
index 0000000..e3eac52
--- /dev/null
@@ -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 (file)
index 0000000..eba8b6b
--- /dev/null
@@ -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 (file)
index 0000000..c06abf5
--- /dev/null
@@ -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 (file)
index 0000000..b92e459
--- /dev/null
@@ -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 (file)
index 0000000..155cf6f
--- /dev/null
@@ -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 (file)
index 0000000..68cc7d5
--- /dev/null
@@ -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 (file)
index 0000000..425604c
--- /dev/null
@@ -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 (file)
index 0000000..58aee32
--- /dev/null
@@ -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 (file)
index 0000000..4a1ecd9
--- /dev/null
@@ -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 (file)
index 0000000..3907f0a
--- /dev/null
@@ -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 (file)
index 0000000..6095984
--- /dev/null
@@ -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 (file)
index 0000000..de156f5
--- /dev/null
@@ -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 (file)
index 0000000..ab4fa99
--- /dev/null
@@ -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 (file)
index 0000000..1fe32ac
--- /dev/null
@@ -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
index 9fc0b63..9c083ad 100644 (file)
@@ -1,3 +1,43 @@
+2005-04-17 Paul Thomas <pault@gcc.gnu.org>
+
+* io/list_read.c (eat_separator): at_eol = 1 replaced(zapped at some time?).
+
+2005-04-17 Paul Thomas <pault@gcc.gnu.org>
+
+
+       PR libgfortran/12884
+       PR libgfortran/17285
+       PR libgfortran/18122
+       PR libgfortran/18210
+       PR libgfortran/18392
+       PR libgfortran/18591
+       PR libgfortran/18879
+       * io/io.h (nml_ls): Declare.
+       (namelist_info): Modify for arrays.
+       * io/list_read.c (namelist_read): Reduced to call to new functions.
+       (match_namelist_name): Simplified.
+       (nml_query): Handles stdin queries ? and =?. New function.
+       (nml_get_obj_data): Parses object name. New function.
+       (touch_nml_nodes): Marks objects for read. New function.
+       (untouch_nml_nodes): Resets objects. New function.
+       (parse_qualifier): Parses and checks qualifiers. New function
+       (nml_read_object): Reads and stores object data. New function.
+       (eat_separator): No new_record on '/' in namelist.
+       (finish_separator): No new_record on '/' in namelist.
+       (read_logical): Error return for namelist.
+       (read_integer): Error return for namelist.
+       (read_complex): Error return for namelist.
+       (read_real): Error return for namelist.
+       * io/lock.c (library_end): Free extended namelist_info types.
+       * io/transfer.c (st_set_nml_var): Modified for arrays.
+       (st_set_nml_var_dim): Dimension descriptors. New function.
+       * io/write.c (namelist_write): Reduced to call to new functions.
+       (nml_write_obj): Writes output for object. New function.
+       (write_integer): Suppress leading blanks for repeat counts.
+       (write_int): Suppress leading blanks for repeat counts.
+       (write_float): Suppress leading blanks for repeat counts.
+       (output_float): Suppress leading blanks for repeat counts.
+
 2005-04-15  Thomas Koenig  <Thomas.Koenig@online.de>
 
        PR libfortran/18495
index 05c4355..4814d8d 100644 (file)
@@ -74,32 +74,75 @@ stream;
 #define sseek(s, pos) ((s)->seek)(s, pos)
 #define struncate(s) ((s)->truncate)(s)
 
-/* Namelist represent object */
-/*
+/* Representation of a namelist object in libgfortran
+
    Namelist Records
-       &groupname  object=value [,object=value].../
+      &GROUPNAME  OBJECT=value[s] [,OBJECT=value[s]].../
      or
-       &groupname  object=value [,object=value]...&groupname
+      &GROUPNAME  OBJECT=value[s] [,OBJECT=value[s]]...&END
+
+   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;
index 384df36..becf09e 100644 (file)
@@ -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;
 }
index 21d04d7..d85c9b8 100644 (file)
@@ -1,5 +1,5 @@
 /* Thread/recursion locking
-   Copyright 2002 Free Software Foundation, Inc.
+   Copyright 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org> and Andy Vaught
 
 This file is part of the GNU Fortran 95 runtime library (libgfortran).
@@ -73,20 +73,28 @@ library_end (void)
   g.in_library = 0;
   filename = NULL;
   line = 0;
-
   t = ioparm.library_return;
+
+  /* Delete the namelist, if it exists.  */
+
   if (ionml != NULL)
     {
       t1 = ionml;
       while (t1 != NULL)
-       {
-         t2 = t1;
-         t1 = t1->next;
-         free_mem (t2);
-       }
+       {
+         t2 = t1;
+         t1 = t1->next;
+         free_mem (t2->var_name);
+         if (t2->var_rank)
+           {
+            free_mem (t2->dim);
+            free_mem (t2->ls);
+           }
+         free_mem (t2);
+       }
     }
-  
   ionml = NULL;
+
   memset (&ioparm, '\0', sizeof (ioparm));
   ioparm.library_return = t;
 }
index 77e9439..bece250 100644 (file)
@@ -1,5 +1,6 @@
 /* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
    Contributed by Andy Vaught
+   Namelist transfer functions contributed by Paul Thomas
 
 This file is part of the GNU Fortran 95 runtime library (libgfortran).
 
@@ -1623,94 +1624,78 @@ st_write_done (void)
   library_end ();
 }
 
+/* Receives the scalar information for namelist objects and stores it
+   in a linked list of namelist_info types.  */
 
-static void
-st_set_nml_var (void * var_addr, char * var_name, int var_name_len,
-                int kind, bt type, int string_length)
+void
+st_set_nml_var (void * var_addr, char * var_name, GFC_INTEGER_4 len,
+               gfc_charlen_type string_length, GFC_INTEGER_4 dtype)
 {
-  namelist_info *t1 = NULL, *t2 = NULL;
-  namelist_info *nml = (namelist_info *) get_mem (sizeof (namelist_info));
+  namelist_info *t1 = NULL;
+  namelist_info *nml;
+
+  nml = (namelist_info*) get_mem (sizeof (namelist_info));
+
   nml->mem_pos = var_addr;
-  if (var_name)
+
+  nml->var_name = (char*) get_mem (strlen (var_name) + 1);
+  strcpy (nml->var_name, var_name);
+
+  nml->len = (int) len;
+  nml->string_length = (index_type) string_length;
+
+  nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK);
+  nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT);
+  nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT);
+
+  if (nml->var_rank > 0)
     {
-      assert (var_name_len > 0);
-      nml->var_name = (char*) get_mem (var_name_len+1);
-      strncpy (nml->var_name, var_name, var_name_len);
-      nml->var_name[var_name_len] = 0;
+      nml->dim = (descriptor_dimension*)
+                  get_mem (nml->var_rank * sizeof (descriptor_dimension));
+      nml->ls = (nml_loop_spec*)
+                 get_mem (nml->var_rank * sizeof (nml_loop_spec));
     }
   else
     {
-      assert (var_name_len == 0);
-      nml->var_name = NULL;
+      nml->dim = NULL;
+      nml->ls = NULL;
     }
 
-  nml->len = kind;
-  nml->type = type;
-  nml->string_length = string_length;
-
   nml->next = NULL;
 
   if (ionml == NULL)
-     ionml = nml;
+    ionml = nml;
   else
     {
-      t1 = ionml;
-      while (t1 != NULL)
-       {
-         t2 = t1;
-         t1 = t1->next;
-       }
-       t2->next = nml;
+      for (t1 = ionml; t1->next; t1 = t1->next);
+      t1->next = nml;
     }
+  return;
 }
 
-extern void st_set_nml_var_int (void *, char *, int, int);
-export_proto(st_set_nml_var_int);
-
-extern void st_set_nml_var_float (void *, char *, int, int);
-export_proto(st_set_nml_var_float);
-
-extern void st_set_nml_var_char (void *, char *, int, int, gfc_charlen_type);
-export_proto(st_set_nml_var_char);
-
-extern void st_set_nml_var_complex (void *, char *, int, int);
-export_proto(st_set_nml_var_complex);
-
-extern void st_set_nml_var_log (void *, char *, int, int);
-export_proto(st_set_nml_var_log);
+/* Store the dimensional information for the namelist object.  */
 
 void
-st_set_nml_var_int (void * var_addr, char * var_name, int var_name_len,
-                   int kind)
+st_set_nml_var_dim (GFC_INTEGER_4 n_dim, GFC_INTEGER_4 stride,
+                   GFC_INTEGER_4 lbound, GFC_INTEGER_4 ubound)
 {
-  st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_INTEGER, 0);
-}
+  namelist_info * nml;
+  int n;
 
-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);
+
index d97caec..c57ebac 100644 (file)
@@ -1,5 +1,6 @@
 /* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
    Contributed by Andy Vaught
+   Namelist output contibuted by Paul Thomas
 
 This file is part of the GNU Fortran 95 runtime library (libgfortran).
 
@@ -29,6 +30,7 @@ Boston, MA 02111-1307, USA.  */
 
 #include "config.h"
 #include <string.h>
+#include <ctype.h>
 #include <float.h>
 #include <stdio.h>
 #include <stdlib.h>
@@ -44,6 +46,8 @@ typedef enum
 sign_t;
 
 
+static int no_leading_blank = 0 ;
+
 void
 write_a (fnode * f, const char *source, int len)
 {
@@ -576,7 +580,9 @@ output_float (fnode *f, double value, int len)
     leadzero = 0;
 
   /* Padd to full field width.  */
-  if (nblanks > 0)
+
+
+  if ( ( nblanks > 0 ) && !no_leading_blank )
     {
       memset (out, ' ', nblanks);
       out += nblanks;
@@ -650,6 +656,13 @@ output_float (fnode *f, double value, int len)
 #endif
       memcpy (out, buffer, edigits);
     }
+
+  if ( no_leading_blank )
+    {
+      out += edigits;
+      memset( out , ' ' , nblanks );
+      no_leading_blank = 0;
+    }
 }
 
 
@@ -802,13 +815,24 @@ write_int (fnode *f, const char *source, int len, char *(*conv) (uint64_t))
       goto done;
     }
 
+
+  if (!no_leading_blank)
+    {
   memset (p, ' ', nblank);
   p += nblank;
-
   memset (p, '0', nzero);
   p += nzero;
-
   memcpy (p, q, digits);
+    }
+  else
+    {
+      memset (p, '0', nzero);
+      p += nzero;
+      memcpy (p, q, digits);
+      p += digits;
+      memset (p, ' ', nblank);
+      no_leading_blank = 0;
+    }
 
  done:
   return;
@@ -1102,9 +1126,16 @@ write_integer (const char *source, int length)
   if(width < digits )
     width = digits ;
   p = write_block (width) ;
-
+  if (no_leading_blank)
+    {
+      memcpy (p, q, digits);
+      memset(p + digits ,' ', width - digits) ;
+    }
+  else
+    {
   memset(p ,' ', width - digits) ;
   memcpy (p + width - digits, q, digits);
+    }
 }
 
 
@@ -1269,60 +1300,320 @@ list_formatted_write (bt type, void *p, int len)
   char_flag = (type == BT_CHARACTER);
 }
 
-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
+