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

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@98287 138bc75d-0d04-0410-961f-82ee72b054a4

6 files changed, 1396 insertions, 258 deletions

diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index 9fc0b63b51a..9c083ad8d99 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -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
diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h
index 05c4355ad00..4814d8daf22 100644
--- a/libgfortran/io/io.h
+++ b/libgfortran/io/io.h
@@ -74,32 +74,75 @@ stream;
 #define sseek(s, pos) ((s)->seek)(s, pos)
 #define struncate(s) ((s)->truncate)(s)
 
-/* Namelist represent object */
-/*
+/* Representation of a namelist object in libgfortran
+
    Namelist Records
-       &groupname  object=value [,object=value].../
+      &GROUPNAME  OBJECT=value[s] [,OBJECT=value[s]].../
      or
-       &groupname  object=value [,object=value]...&groupname
+      &GROUPNAME  OBJECT=value[s] [,OBJECT=value[s]]...&END
+
+   The object can be a fully qualified, compound name for an instrinsic
+   type, derived types or derived type components.  So, a substring
+   a(:)%b(4)%ch(2:4)(1:7) has to be treated correctly in namelist
+   read. Hence full information about the structure of the object has
+   to be available to list_read.c and write.
+
+   These requirements are met by the following data structures.
+
+   nml_loop_spec contains the variables for the loops over index ranges
+   that are encountered.  Since the variables can be negative, ssize_t
+   is used.  */
+
+typedef struct nml_loop_spec
+{
 
-  Even more complex, during the execution of a program containing a
-  namelist READ statement, you can specify a question mark character(?)
-  or a question mark character preceded by an equal sign(=?) to get
-  the information of the namelist group. By '?', the name of variables
-  in the namelist will be displayed, by '=?', the name and value of
-  variables will be displayed.
+  /* Index counter for this dimension.  */
+  ssize_t idx;
 
-  All these requirements need a new data structure to record all info
-  about the namelist.
-*/
+  /* Start for the index counter.  */
+  ssize_t start;
+
+  /* End for the index counter.  */
+  ssize_t end;
+
+  /* Step for the index counter.  */
+  ssize_t step;
+}
+nml_loop_spec;
+
+/* namelist_info type contains all the scalar information about the
+   object and arrays of descriptor_dimension and nml_loop_spec types for
+   arrays.  */
 
 typedef struct namelist_type
 {
+
+  /* Object type, stored as GFC_DTYPE_xxxx.  */
+  bt type;
+
+  /* Object name.  */
   char * var_name;
+
+  /* Address for the start of the object's data.  */
   void * mem_pos;
-  int  value_acquired;
+
+  /* Flag to show that a read is to be attempted for this node.  */
+  int touched;
+
+  /* Length of intrinsic type in bytes.  */
   int len;
-  int string_length;
-  bt type;
+
+  /* Rank of the object.  */
+  int var_rank;
+
+  /* Overall size of the object in bytes.  */
+  index_type size;
+
+  /* Length of character string.  */
+  index_type string_length;
+
+  descriptor_dimension * dim;
+  nml_loop_spec * ls;
   struct namelist_type * next;
 }
 namelist_info;
diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c
index 384df36f6c4..becf09edd06 100644
--- a/libgfortran/io/list_read.c
+++ b/libgfortran/io/list_read.c
@@ -1,5 +1,6 @@
-/* Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
+/* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
    Contributed by Andy Vaught
+   Namelist input contributed by Paul Thomas
 
 This file is part of the GNU Fortran 95 runtime library (libgfortran).
 
@@ -50,13 +51,22 @@ Boston, MA 02111-1307, USA.  */
    ourselves.  Data is buffered in scratch[] until it becomes too
    large, after which we start allocating memory on the heap.  */
 
-static int repeat_count, saved_length, saved_used, input_complete, at_eol;
-static int comma_flag, namelist_mode;
-
+static int repeat_count, saved_length, saved_used;
+static int input_complete, at_eol, comma_flag;
 static char last_char, *saved_string;
 static bt saved_type;
 
+/* A namelist specific flag used in the list directed library
+   to flag that calls are being made from namelist read (eg. to ignore
+   comments or to treat '/' as a terminator)  */
+
+static int namelist_mode;
+
+/* A namelist specific flag used in the list directed library to flag
+   read errors and return, so that an attempt can be made to read a
+   new object name.  */
 
+static int nml_read_error;
 
 /* Storage area for values except for strings.  Must be large enough
    to hold a complex value (two reals) of the largest kind.  */
@@ -226,12 +236,16 @@ eat_separator (void)
 
     case '/':
       input_complete = 1;
-      next_record (0);
-      at_eol = 1;
+      if (!namelist_mode)
+	{
+	  next_record (0);
+	  at_eol = 1;
+	}
       break;
 
     case '\n':
     case '\r':
+      at_eol = 1;
       break;
 
     case '!':
@@ -282,7 +296,7 @@ finish_separator (void)
 
     case '/':
       input_complete = 1;
-      next_record (0);
+      if (!namelist_mode) next_record (0);
       break;
 
     case '\n':
@@ -305,6 +319,21 @@ finish_separator (void)
     }
 }
 
+/* This function is needed to catch bad conversions so that namelist can
+   attempt to see if saved_string contains a new object name rather than
+   a bad value.  */
+
+static int
+nml_bad_return (char c)
+{
+  if (namelist_mode)
+    {
+      nml_read_error = 1;
+      unget_char(c);
+      return 1;
+    }
+  return 0;
+}
 
 /* Convert an unsigned string to an integer.  The length value is -1
    if we are working on a repeat count.  Returns nonzero if we have a
@@ -525,6 +554,10 @@ read_logical (int length)
   return;
 
  bad_logical:
+
+  if (nml_bad_return (c))
+    return;
+
   st_sprintf (message, "Bad logical value while reading item %d",
 	      g.item_count);
 
@@ -641,6 +674,10 @@ read_integer (int length)
     }
 
  bad_integer:
+
+  if (nml_bad_return (c))
+    return;
+
   free_saved ();
 
   st_sprintf (message, "Bad integer for item %d in list input", g.item_count);
@@ -976,6 +1013,10 @@ read_complex (int length)
   return;
 
  bad_complex:
+
+  if (nml_bad_return (c))
+    return;
+
   st_sprintf (message, "Bad complex value in item %d of list input",
 	      g.item_count);
 
@@ -1186,6 +1227,10 @@ read_real (int length)
   return;
 
  bad_real:
+
+  if (nml_bad_return (c))
+    return;
+
   st_sprintf (message, "Bad real number in item %d of list input",
 	      g.item_count);
 
@@ -1380,184 +1425,910 @@ finish_list_read (void)
   while (c != '\n');
 }
 
+/*			NAMELIST INPUT
+
+void namelist_read (void)
+calls:
+   static void nml_match_name (char *name, int len)
+   static int nml_query (void)
+   static int nml_get_obj_data (void)
+calls:
+      static void nml_untouch_nodes (void)
+      static namelist_info * find_nml_node (char * var_name)
+      static int nml_parse_qualifier(descriptor_dimension * ad,
+				     nml_loop_spec * ls, int rank)
+      static void nml_touch_nodes (namelist_info * nl)
+      static int nml_read_obj (namelist_info * nl, index_type offset)
+calls:
+      -itself-  */
+
+/* Carries error messages from the qualifier parser.  */
+static char parse_err_msg[30];
+
+/* Carries error messages for error returns.  */
+static char nml_err_msg[100];
+
+/* Pointer to the previously read object, in case attempt is made to read
+   new object name.  Should this fail, error message can give previous
+   name.  */
+
+static namelist_info * prev_nl;
+
+/* Lower index for substring qualifier.  */
+
+static index_type clow;
+
+/* Upper index for substring qualifier.  */
+
+static index_type chigh;
+
+/* Inputs a rank-dimensional qualifier, which can contain
+   singlets, doublets, triplets or ':' with the standard meanings.  */
+
+static try
+nml_parse_qualifier(descriptor_dimension * ad,
+		    nml_loop_spec * ls, int rank)
+{
+  int dim;
+  int indx;
+  int neg;
+  int null_flag;
+  char c;
+
+  /* The next character in the stream should be the '('.  */
+
+  c = next_char ();
+
+  /* Process the qualifier, by dimension and triplet.  */
+
+  for (dim=0; dim < rank; dim++ )
+    {
+      for (indx=0; indx<3; indx++)
+	{
+	  free_saved ();
+	  eat_spaces ();
+	  neg = 0;
+
+	  /*process a potential sign.  */
+
+	  c = next_char ();
+	  switch (c)
+	    {
+	    case '-':
+	      neg = 1;
+	      break;
+
+	    case '+':
+	      break;
+
+	    default:
+	      unget_char (c);
+	      break;
+	    }
+
+	  /*process characters up to the next ':' , ',' or ')'  */
+
+	  for (;;)
+	    {
+	      c = next_char ();
+
+	      switch (c)
+		{
+		case ':':
+		  break;
+
+		case ',': case ')':
+		  if ( (c==',' && dim == rank -1)
+		    || (c==')' && dim  < rank -1))
+		    {
+		      st_sprintf (parse_err_msg,
+				  "Bad number of index fields");
+		      goto err_ret;
+		    }
+		  break;
+
+		CASE_DIGITS:
+		  push_char (c);
+		  continue;
+
+		case ' ': case '\t':
+		  eat_spaces ();
+		  c = next_char ();
+		  break;
+
+		default:
+		  st_sprintf (parse_err_msg, "Bad character in index");
+		  goto err_ret;
+		}
+
+	      if (( c==',' || c==')') && indx==0 && saved_string == 0 )
+		{
+		  st_sprintf (parse_err_msg, "Null index field");
+		  goto err_ret;
+		}
+
+	      if ( ( c==':' && indx==1 && saved_string == 0)
+		|| (indx==2 && saved_string == 0))
+		{
+		  st_sprintf(parse_err_msg, "Bad index triplet");
+		  goto err_ret;
+		}
+
+	      /* If '( : ? )' or '( ? : )' break and flag read failure.  */
+	      null_flag = 0;
+	      if ( (c==':'  && indx==0 && saved_string == 0)
+		|| (indx==1 && saved_string == 0))
+		{
+		  null_flag = 1;
+		  break;
+		}
+
+	      /* Now read the index.  */
+
+	      if (convert_integer (sizeof(int),neg))
+		{
+		  st_sprintf (parse_err_msg, "Bad integer in index");
+		  goto err_ret;
+		}
+	      break;
+	    }
+
+	  /*feed the index values to the triplet arrays.  */
+
+	  if (!null_flag)
+	    {
+	      if (indx == 0)
+		ls[dim].start = *(int *)value;
+	      if (indx == 1)
+		ls[dim].end   = *(int *)value;
+	      if (indx == 2)
+		ls[dim].step  = *(int *)value;
+	    }
+
+	  /*singlet or doublet indices  */
+
+	  if (c==',' || c==')')
+	    {
+	      if (indx == 0)
+		{
+		  ls[dim].start = *(int *)value;
+		  ls[dim].end = *(int *)value;
+		}
+	      break;
+	    }
+	}
+
+      /*Check the values of the triplet indices.  */
+
+      if ( (ls[dim].start > (ssize_t)ad[dim].ubound) 
+	|| (ls[dim].start < (ssize_t)ad[dim].lbound)
+	|| (ls[dim].end   > (ssize_t)ad[dim].ubound)
+	|| (ls[dim].end   < (ssize_t)ad[dim].lbound))
+	{
+	  st_sprintf (parse_err_msg, "Index %d out of range", dim + 1);
+	  goto err_ret;
+	}
+      if (((ls[dim].end - ls[dim].start ) * ls[dim].step < 0)
+	|| (ls[dim].step == 0))
+	{
+	  st_sprintf (parse_err_msg, "Bad range in index %d", dim + 1);
+	  goto err_ret;
+	}
+
+      /* Initialise the loop index counter.  */
+
+      ls[dim].idx = ls[dim].start;
+
+    }
+  eat_spaces ();
+  return SUCCESS;
+
+err_ret:
+
+  return FAILURE;
+}
+
 static namelist_info *
 find_nml_node (char * var_name)
 {
-   namelist_info * t = ionml;
-   while (t != NULL)
-     {
-       if (strcmp (var_name,t->var_name) == 0)
-         {
-           t->value_acquired = 1;
-           return t;
-         }
-       t = t->next;
-     }
+  namelist_info * t = ionml;
+  while (t != NULL)
+    {
+      if (strcmp (var_name,t->var_name) == 0)
+	{
+	  t->touched = 1;
+	  return t;
+	}
+      t = t->next;
+    }
   return NULL;
 }
 
+/* Visits all the components of a derived type that have
+   not explicitly been identified in the namelist input.
+   touched is set and the loop specification initialised 
+   to default values  */
+
 static void
-match_namelist_name (char *name, int len)
+nml_touch_nodes (namelist_info * nl)
 {
-  int name_len;
-  char c;
-  char * namelist_name = name;
-
-  name_len = 0;
-  /* Match the name of the namelist.  */
-
-  if (tolower (next_char ()) != tolower (namelist_name[name_len++]))
+  index_type len = strlen (nl->var_name) + 1;
+  int dim;
+  char * ext_name = (char*)get_mem (len + 1);
+  strcpy (ext_name, nl->var_name);
+  strcat (ext_name, "%");
+  for (nl = nl->next; nl; nl = nl->next)
     {
-    wrong_name:
-      generate_error (ERROR_READ_VALUE, "Wrong namelist name found");
-      return;
+      if (strncmp (nl->var_name, ext_name, len) == 0)
+	{
+	  nl->touched = 1;
+	  for (dim=0; dim < nl->var_rank; dim++)
+	    {
+	      nl->ls[dim].step = 1;
+	      nl->ls[dim].end = nl->dim[dim].ubound;
+	      nl->ls[dim].start = nl->dim[dim].lbound;
+	      nl->ls[dim].idx = nl->ls[dim].start;
+	    }
+	}
+      else
+	break;
     }
+  return;
+}
+
+/* Resets touched for the entire list of nml_nodes, ready for a
+   new object.  */
+
+static void
+nml_untouch_nodes (void)
+{
+  namelist_info * t;
+  for (t = ionml; t; t = t->next)
+    t->touched = 0;
+  return;
+}
+
+/* Attempts to input name to namelist name.  Returns nml_read_error = 1
+   on no match.  */
 
-  while (name_len < len)
+static void
+nml_match_name (char *name, index_type len)
+{
+  index_type i;
+  char c;
+  nml_read_error = 0;
+  for (i = 0; i < len; i++)
     {
       c = next_char ();
-      if (tolower (c) != tolower (namelist_name[name_len++]))
-        goto wrong_name;
+      if (tolower (c) != tolower (name[i]))
+	{
+	  nml_read_error = 1;
+	  break;
+	}
     }
 }
 
+/* If the namelist read is from stdin, output the current state of the
+   namelist to stdout.  This is used to implement the non-standard query
+   features, ? and =?. If c == '=' the full namelist is printed. Otherwise
+   the names alone are printed.  */
 
-/********************************************************************
-      Namelist reads
-********************************************************************/
-
-/* Process a namelist read.  This subroutine initializes things,
-   positions to the first element and 
-   FIXME: was this comment ever complete?  */
-
-void
-namelist_read (void)
+static void
+nml_query (char c)
 {
-  char c;
-  int name_matched, next_name ;
+  gfc_unit * temp_unit;
   namelist_info * nl;
-  int len, m;
-  void * p;
+  index_type len;
+  char * p;
 
-  namelist_mode = 1;
+  if (current_unit->unit_number != options.stdin_unit)
+    return;
 
-  if (setjmp (g.eof_jump))
+  /* Store the current unit and transfer to stdout.  */
+
+  temp_unit = current_unit;
+  current_unit = find_unit (options.stdout_unit);
+
+  if (current_unit)
     {
-      generate_error (ERROR_END, NULL);
-      return;
+      g.mode =WRITING;
+      next_record (0);
+
+      /* Write the namelist in its entirety.  */
+
+      if (c == '=')
+	namelist_write ();
+
+      /* Or write the list of names.  */
+
+      else
+	{
+
+	  /* "&namelist_name\n"  */
+
+	  len = ioparm.namelist_name_len;
+	  p = write_block (len + 2);
+	  if (!p)
+	    goto query_return;
+	  memcpy (p, "&", 1);
+	  memcpy ((char*)(p + 1), ioparm.namelist_name, len);
+	  memcpy ((char*)(p + len + 1), "\n", 1);
+	  for (nl =ionml; nl; nl = nl->next)
+	    {
+
+	      /* " var_name\n"  */
+
+	      len = strlen (nl->var_name);
+	      p = write_block (len + 2);
+	      if (!p)
+		goto query_return;
+	      memcpy (p, " ", 1);
+	      memcpy ((char*)(p + 1), nl->var_name, len);
+	      memcpy ((char*)(p + len + 1), "\n", 1);
+	    }
+
+	  /* "&end\n"  */
+
+	  p = write_block (5);
+	  if (!p)
+	    goto query_return;
+	  memcpy (p, "&end\n", 5);
+	}
+
+      /* Flush the stream to force immediate output.  */
+
+      flush (current_unit->s);
     }
 
- restart:
-  c = next_char ();
-  switch (c)
-    {
-    case ' ':
-      goto restart;
-    case '!':
-      do
-        c = next_char ();
-      while (c != '\n');
+query_return:
 
-      goto restart;
+  /* Restore the current unit.  */
 
-    case '&':
+  current_unit = temp_unit;
+  g.mode = READING;
+  return;
+}
+
+/* Reads and stores the input for the namelist object nl.  For an array,
+   the function loops over the ranges defined by the loop specification.
+   This default to all the data or to the specification from a qualifier.
+   nml_read_obj recursively calls itself to read derived types. It visits
+   all its own components but only reads data for those that were touched
+   when the name was parsed.  If a read error is encountered, an attempt is
+   made to return to read a new object name because the standard allows too
+   little data to be available.  On the other hand, too much data is an
+   error.  */
+
+static try
+nml_read_obj (namelist_info * nl, index_type offset)
+{
+
+  namelist_info * cmp;
+  char * obj_name;
+  int nml_carry;
+  int len;
+  int dim;
+  index_type dlen;
+  index_type m;
+  index_type obj_name_len;
+  void * pdata ;
+
+  /* This object not touched in name parsing.  */
+
+  if (!nl->touched)
+    return SUCCESS;
+
+  repeat_count = 0;
+  eat_spaces();
+
+  len = nl->len;
+  switch (nl->type)
+  {
+
+    case GFC_DTYPE_INTEGER:
+    case GFC_DTYPE_LOGICAL:
+    case GFC_DTYPE_REAL:
+      dlen = len;
+      break;
+
+    case GFC_DTYPE_COMPLEX:
+      dlen = 2* len;
+      break;
+
+    case GFC_DTYPE_CHARACTER:
+      dlen = chigh ? (chigh - clow + 1) : nl->string_length;
       break;
 
     default:
-      generate_error (ERROR_READ_VALUE, "Invalid character in namelist");
-      return;
+      dlen = 0;
     }
 
-  /* Match the name of the namelist.  */
-  match_namelist_name(ioparm.namelist_name, ioparm.namelist_name_len);
-
-  /* Ready to read namelist elements.  */
-  while (!input_complete)
+  do
     {
-      c = next_char ();
-      switch (c)
-        {
-        case '/':
-          input_complete = 1;
-          next_record (0);
-          break;
-        case '&':
-          match_namelist_name("end",3);
-          return;
-        case '\\':
-          return;
-        case ' ':
-        case '\n':
-       case '\r':
-        case '\t':
-          break;
-        case ',':
-          next_name = 1;
-          break;
 
-        case '=':
-          name_matched = 1;
-          nl = find_nml_node (saved_string);
-          if (nl == NULL)
-            internal_error ("Can not match a namelist variable");
-          free_saved();
+      /* Update the pointer to the data, using the current index vector  */
 
-          len = nl->len;
-          p = nl->mem_pos;
+      pdata = (void*)(nl->mem_pos + offset);
+      for (dim = 0; dim < nl->var_rank; dim++)
+	pdata = (void*)(pdata + (nl->ls[dim].idx - nl->dim[dim].lbound) *
+		 nl->dim[dim].stride * nl->size);
 
-          /* skip any blanks or tabs after the = */
-          eat_spaces ();
+      /* Reset the error flag and try to read next value, if 
+	 repeat_count=0  */
+
+      nml_read_error = 0;
+      nml_carry = 0;
+      if (--repeat_count <= 0)
+	{
+	  if (input_complete)
+	    return SUCCESS;
+	  if (at_eol)
+	    finish_separator ();
+	  if (input_complete)
+	    return SUCCESS;
+
+	  /* GFC_TYPE_UNKNOWN through for nulls and is detected
+	     after the switch block.  */
+
+	  saved_type = GFC_DTYPE_UNKNOWN;
+	  free_saved ();
  
           switch (nl->type)
-            {
-            case BT_INTEGER:
+	  {
+	  case GFC_DTYPE_INTEGER:
               read_integer (len);
               break;
-            case BT_LOGICAL:
+
+	  case GFC_DTYPE_LOGICAL:
               read_logical (len);
               break;
-            case BT_CHARACTER:
+
+	  case GFC_DTYPE_CHARACTER:
               read_character (len);
               break;
-            case BT_REAL:
+
+	  case GFC_DTYPE_REAL:
               read_real (len);
               break;
-            case BT_COMPLEX:
+
+	  case GFC_DTYPE_COMPLEX:
               read_complex (len);
               break;
-            default:
-              internal_error ("Bad type for namelist read");
-            }
-
-           switch (saved_type)
-            {
-            case BT_COMPLEX:
-              len = 2 * len;
-              /* Fall through...  */
-
-            case BT_INTEGER:
-            case BT_REAL:
-            case BT_LOGICAL:
-              memcpy (p, value, len);
-              break;
 
-            case BT_CHARACTER:
-              m = (len < saved_used) ? len : saved_used;
-              memcpy (p, saved_string, m);
+	  case GFC_DTYPE_DERIVED:
+	    obj_name_len = strlen (nl->var_name) + 1;
+	    obj_name = get_mem (obj_name_len+1);
+	    strcpy (obj_name, nl->var_name);
+	    strcat (obj_name, "%");
+
+	    /* Now loop over the components. Update the component pointer
+	       with the return value from nml_write_obj.  This loop jumps
+	       past nested derived types by testing if the potential 
+	       component name contains '%'.  */
+
+	    for (cmp = nl->next;
+		 cmp &&
+		   !strncmp (cmp->var_name, obj_name, obj_name_len) &&
+		   !strchr (cmp->var_name + obj_name_len, '%');
+		 cmp = cmp->next)
+	      {
+
+		if (nml_read_obj (cmp, (index_type)(pdata - nl->mem_pos)) == FAILURE)
+		  return FAILURE;
+
+		if (input_complete)
+		  return SUCCESS;
+	      }
+
+	    free_mem (obj_name);
+	    goto incr_idx;
+
+          default:
+	    st_sprintf (nml_err_msg, "Bad type for namelist object %s",
+			nl->var_name );
+	    internal_error (nml_err_msg);
+	    goto nml_err_ret;
+          }
+        }
 
-              if (m < len)
-                memset (((char *) p) + m, ' ', len - m);
-              break;
+      /* The standard permits array data to stop short of the number of
+	 elements specified in the loop specification.  In this case, we
+	 should be here with nml_read_error != 0.  Control returns to 
+	 nml_get_obj_data and an attempt is made to read object name.  */
 
-            case BT_NULL:
-              break;
-            }
+      prev_nl = nl;
+      if (nml_read_error)
+	return SUCCESS;
 
-          break;
+      if (saved_type == GFC_DTYPE_UNKNOWN)
+	goto incr_idx;
+
+
+      /* Note the switch from GFC_DTYPE_type to BT_type at this point.
+	 This comes about because the read functions return BT_types.  */
+
+      switch (saved_type)
+      {
+
+	case BT_COMPLEX:
+	case BT_REAL:
+	case BT_INTEGER:
+	case BT_LOGICAL:
+	  memcpy (pdata, value, dlen);
+	  break;
+
+	case BT_CHARACTER:
+	  m = (dlen < saved_used) ? dlen : saved_used;
+	  pdata = (void*)( pdata + clow - 1 );
+	  memcpy (pdata, saved_string, m);
+	  if (m < dlen)
+	    memset ((void*)( pdata + m ), ' ', dlen - m);
+	break;
+
+	default:
+	  break;
+      }
+
+      /* Break out of loop if scalar.  */
+
+      if (!nl->var_rank)
+	break;
+
+      /* Now increment the index vector.  */
+
+incr_idx:
+
+      nml_carry = 1;
+      for (dim = 0; dim < nl->var_rank; dim++)
+	{
+	  nl->ls[dim].idx += nml_carry * nl->ls[dim].step;
+	  nml_carry = 0;
+	  if (((nl->ls[dim].step > 0) && (nl->ls[dim].idx > nl->ls[dim].end))
+	      ||
+	      ((nl->ls[dim].step < 0) && (nl->ls[dim].idx < nl->ls[dim].end)))
+	    {
+	      nl->ls[dim].idx = nl->ls[dim].start;
+	      nml_carry = 1;
+	    }
+        }
+    } while (!nml_carry);
+
+  if (repeat_count > 1)
+    {
+       st_sprintf (nml_err_msg, "Repeat count too large for namelist object %s" ,
+		   nl->var_name );
+       goto nml_err_ret;
+    }
+  return SUCCESS;
+
+nml_err_ret:
+
+  return FAILURE;
+}
+
+/* Parses the object name, including array and substring qualifiers.  It
+   iterates over derived type components, touching those components and
+   setting their loop specifications, if there is a qualifier.  If the
+   object is itself a derived type, its components and subcomponents are
+   touched.  nml_read_obj is called at the end and this reads the data in
+   the manner specified by the object name.  */
+
+static try
+nml_get_obj_data (void)
+{
+  char c;
+  char * ext_name;
+  namelist_info * nl;
+  namelist_info * first_nl;
+  namelist_info * root_nl;
+  int dim;
+  int component_flag;
+
+  /* Look for end of input or object name.  If '?' or '=?' are encountered
+     in stdin, print the node names or the namelist to stdout.  */
+
+  eat_separator ();
+  if (input_complete)
+    return SUCCESS;
+
+  if ( at_eol )
+    finish_separator ();
+  if (input_complete)
+    return SUCCESS;
+
+  c = next_char ();
+  switch (c)
+    {
+    case '=':
+      c = next_char ();
+      if (c != '?')
+	{
+	  st_sprintf (nml_err_msg, "namelist read: missplaced = sign");
+	  goto nml_err_ret;
+	}
+      nml_query ('=');
+      return SUCCESS;
+
+    case '?':
+      nml_query ('?');
+      return SUCCESS;
+
+    case '$':
+    case '&':
+      nml_match_name ("end", 3);
+      if (nml_read_error)
+	{
+	  st_sprintf (nml_err_msg, "namelist not terminated with / or &end");
+	  goto nml_err_ret;
+	}
+    case '/':
+      input_complete = 1;
+      return SUCCESS;
+
+    default :
+      break;
+    }
+
+  /* Untouch all nodes of the namelist and reset the flag that is set for
+     derived type components.  */
+
+  nml_untouch_nodes();
+  component_flag = 0;
+
+  /* Get the object name - should '!' and '\n' be permitted separators?  */
+
+get_name:
+
+  free_saved ();
+
+  do
+    {
+      push_char(tolower(c));
+      c = next_char ();
+    } while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' ));
+
+  unget_char (c);
+
+  /* Check that the name is in the namelist and get pointer to object.
+     Three error conditions exist: (i) An attempt is being made to
+     identify a non-existent object, following a failed data read or
+     (ii) The object name does not exist or (iii) Too many data items
+     are present for an object.  (iii) gives the same error message
+     as (i)  */
+
+  push_char ('\0');
+
+  if (component_flag)
+    {
+      ext_name = (char*)get_mem (strlen (root_nl->var_name) +
+		  saved_string ? strlen (saved_string) : 0 + 1);
+      strcpy (ext_name, root_nl->var_name);
+      strcat (ext_name, saved_string);
+      nl = find_nml_node (ext_name);
+    }
+  else
+    nl = find_nml_node (saved_string);
+
+  if (nl == NULL)
+    {
+      if (nml_read_error && prev_nl)
+	st_sprintf (nml_err_msg, "Bad data for namelist object %s",
+		    prev_nl->var_name);
+
+      else
+	st_sprintf (nml_err_msg, "Cannot match namelist object name %s",
+		    saved_string);
+
+      goto nml_err_ret;
+    }
+
+  /* Get the length, data length, base pointer and rank of the variable.
+     Set the default loop specification first.  */
+
+  for (dim=0; dim < nl->var_rank; dim++)
+    {
+      nl->ls[dim].step = 1;
+      nl->ls[dim].end = nl->dim[dim].ubound;
+      nl->ls[dim].start = nl->dim[dim].lbound;
+      nl->ls[dim].idx = nl->ls[dim].start;
+    }
+
+/* Check to see if there is a qualifier: if so, parse it.*/
+
+  if (c == '(' && nl->var_rank)
+    {
+      if (nml_parse_qualifier (nl->dim, nl->ls, nl->var_rank) == FAILURE)
+	{
+	  st_sprintf (nml_err_msg, "%s for namelist variable %s",
+		      parse_err_msg, nl->var_name);
+	  goto nml_err_ret;
+	}
+      c = next_char ();
+      unget_char (c);
+    }
+
+  /* Now parse a derived type component. The root namelist_info address
+     is backed up, as is the previous component level.  The  component flag
+     is set and the iteration is made by jumping back to get_name.  */
+
+  if (c == '%')
+    {
+
+      if (nl->type != GFC_DTYPE_DERIVED)
+	{
+	  st_sprintf (nml_err_msg, "Attempt to get derived component for %s",
+		      nl->var_name);
+	  goto nml_err_ret;
+	}
+
+      if (!component_flag)
+	first_nl = nl;
+
+      root_nl = nl;
+      component_flag = 1;
+      c = next_char ();
+      goto get_name;
+
+    }
+
+  /* Parse a character qualifier, if present.  chigh = 0 is a default
+     that signals that the string length = string_length.  */
+
+  clow = 1;
+  chigh = 0;
+
+  if (c == '(' && nl->type == GFC_DTYPE_CHARACTER)
+    {
+      descriptor_dimension chd[1] = {1, clow, nl->string_length};
+      nml_loop_spec ind[1] = {1, clow, nl->string_length, 1};
+
+      if (nml_parse_qualifier (chd, ind, 1) == FAILURE)
+	{
+	  st_sprintf (nml_err_msg, "%s for namelist variable %s",
+		      parse_err_msg, nl->var_name);
+	  goto nml_err_ret;
+	}
+
+      clow = ind[0].start;
+      chigh = ind[0].end;
+
+      if (ind[0].step != 1)
+	{
+	  st_sprintf (nml_err_msg,
+		      "Bad step in substring for namelist object %s",
+		      nl->var_name);
+	  goto nml_err_ret;
+	}
+
+      c = next_char ();
+      unget_char (c);
+    }
+
+  /* If a derived type touch its components and restore the root
+     namelist_info if we have parsed a qualified derived type
+     component.  */
+
+  if (nl->type == GFC_DTYPE_DERIVED)
+    nml_touch_nodes (nl);
+  if (component_flag)
+    nl = first_nl;
+
+  /*make sure no extraneous qualifiers are there.*/
+
+  if (c == '(')
+    {
+      st_sprintf (nml_err_msg, "Qualifier for a scalar or non-character"
+		  " namelist object %s", nl->var_name);
+      goto nml_err_ret;
+    }
+
+/* According to the standard, an equal sign MUST follow an object name. The
+   following is possibly lax - it allows comments, blank lines and so on to
+   intervene.  eat_spaces (); c = next_char (); would be compliant*/
+
+  free_saved ();
+
+  eat_separator ();
+  if (input_complete)
+    return SUCCESS;
+
+  if (at_eol)
+    finish_separator ();
+  if (input_complete)
+    return SUCCESS;
+
+  c = next_char ();
+
+  if (c != '=')
+    {
+      st_sprintf (nml_err_msg, "Equal sign must follow namelist object name %s",
+		  nl->var_name);
+      goto nml_err_ret;
+    }
 
-        default :
-          push_char(tolower(c));
+  if (nml_read_obj (nl, 0) == FAILURE)
+    goto nml_err_ret;
+
+  return SUCCESS;
+
+nml_err_ret:
+
+  return FAILURE;
+}
+
+/* Entry point for namelist input.  Goes through input until namelist name
+  is matched.  Then cycles through nml_get_obj_data until the input is
+  completed or there is an error.  */
+
+void
+namelist_read (void)
+{
+  char c;
+
+  namelist_mode = 1;
+  input_complete = 0;
+
+  if (setjmp (g.eof_jump))
+    {
+      generate_error (ERROR_END, NULL);
+      return;
+    }
+
+  /* Look for &namelist_name .  Skip all characters, testing for $nmlname.
+     Exit on success or EOF. If '?' or '=?' encountered in stdin, print
+     node names or namelist on stdout.  */
+
+find_nml_name:
+  switch (c = next_char ())
+    {
+    case '$':
+    case '&':
           break;
+
+    case '=':
+      c = next_char ();
+      if (c == '?')
+	nml_query ('=');
+      else
+	unget_char (c);
+      goto find_nml_name;
+
+    case '?':
+      nml_query ('?');
+
+    default:
+      goto find_nml_name;
+    }
+
+  /* Match the name of the namelist.  */
+
+  nml_match_name (ioparm.namelist_name, ioparm.namelist_name_len);
+
+  if (nml_read_error)
+    goto find_nml_name;
+
+  /* Ready to read namelist objects.  If there is an error in input
+     from stdin, output the error message and continue.  */
+
+  while (!input_complete)
+    {
+      if (nml_get_obj_data ()  == FAILURE)
+	{
+	  if (current_unit->unit_number != options.stdin_unit)
+	    goto nml_err_ret;
+
+	  st_printf ("%s\n", nml_err_msg);
+	  flush (find_unit (options.stderr_unit)->s);
         }
+
    }
+
+  return;
+
+  /* All namelist error calls return from here */
+
+nml_err_ret:
+
+  generate_error (ERROR_READ_VALUE , nml_err_msg);
+  return;
 }
diff --git a/libgfortran/io/lock.c b/libgfortran/io/lock.c
index 21d04d720ac..d85c9b8c93f 100644
--- a/libgfortran/io/lock.c
+++ b/libgfortran/io/lock.c
@@ -1,5 +1,5 @@
 /* Thread/recursion locking
-   Copyright 2002 Free Software Foundation, Inc.
+   Copyright 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
    Contributed by Paul Brook <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;
 }
diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index 77e943964d8..bece250d78c 100644
--- a/libgfortran/io/transfer.c
+++ b/libgfortran/io/transfer.c
@@ -1,5 +1,6 @@
 /* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
    Contributed by Andy Vaught
+   Namelist transfer functions contributed by Paul Thomas
 
 This file is part of the GNU Fortran 95 runtime library (libgfortran).
 
@@ -1623,94 +1624,78 @@ st_write_done (void)
   library_end ();
 }
 
+/* Receives the scalar information for namelist objects and stores it
+   in a linked list of namelist_info types.  */
 
-static void
-st_set_nml_var (void * var_addr, char * var_name, int var_name_len,
-                int kind, bt type, int string_length)
+void
+st_set_nml_var (void * var_addr, char * var_name, GFC_INTEGER_4 len,
+		gfc_charlen_type string_length, GFC_INTEGER_4 dtype)
 {
-  namelist_info *t1 = NULL, *t2 = NULL;
-  namelist_info *nml = (namelist_info *) get_mem (sizeof (namelist_info));
+  namelist_info *t1 = NULL;
+  namelist_info *nml;
+
+  nml = (namelist_info*) get_mem (sizeof (namelist_info));
+
   nml->mem_pos = var_addr;
-  if (var_name)
+
+  nml->var_name = (char*) get_mem (strlen (var_name) + 1);
+  strcpy (nml->var_name, var_name);
+
+  nml->len = (int) len;
+  nml->string_length = (index_type) string_length;
+
+  nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK);
+  nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT);
+  nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT);
+
+  if (nml->var_rank > 0)
     {
-      assert (var_name_len > 0);
-      nml->var_name = (char*) get_mem (var_name_len+1);
-      strncpy (nml->var_name, var_name, var_name_len);
-      nml->var_name[var_name_len] = 0;
+      nml->dim = (descriptor_dimension*)
+		   get_mem (nml->var_rank * sizeof (descriptor_dimension));
+      nml->ls = (nml_loop_spec*)
+		  get_mem (nml->var_rank * sizeof (nml_loop_spec));
     }
   else
     {
-      assert (var_name_len == 0);
-      nml->var_name = NULL;
+      nml->dim = NULL;
+      nml->ls = NULL;
     }
 
-  nml->len = kind;
-  nml->type = type;
-  nml->string_length = string_length;
-
   nml->next = NULL;
 
   if (ionml == NULL)
-     ionml = nml;
+    ionml = nml;
   else
     {
-      t1 = ionml;
-      while (t1 != NULL)
-       {
-         t2 = t1;
-         t1 = t1->next;
-       }
-       t2->next = nml;
+      for (t1 = ionml; t1->next; t1 = t1->next);
+      t1->next = nml;
     }
+  return;
 }
 
-extern void st_set_nml_var_int (void *, char *, int, int);
-export_proto(st_set_nml_var_int);
-
-extern void st_set_nml_var_float (void *, char *, int, int);
-export_proto(st_set_nml_var_float);
-
-extern void st_set_nml_var_char (void *, char *, int, int, gfc_charlen_type);
-export_proto(st_set_nml_var_char);
-
-extern void st_set_nml_var_complex (void *, char *, int, int);
-export_proto(st_set_nml_var_complex);
-
-extern void st_set_nml_var_log (void *, char *, int, int);
-export_proto(st_set_nml_var_log);
+/* Store the dimensional information for the namelist object.  */
 
 void
-st_set_nml_var_int (void * var_addr, char * var_name, int var_name_len,
-		    int kind)
+st_set_nml_var_dim (GFC_INTEGER_4 n_dim, GFC_INTEGER_4 stride,
+		    GFC_INTEGER_4 lbound, GFC_INTEGER_4 ubound)
 {
-  st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_INTEGER, 0);
-}
+  namelist_info * nml;
+  int n;
 
-void
-st_set_nml_var_float (void * var_addr, char * var_name, int var_name_len,
-		      int kind)
-{
-  st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_REAL, 0);
-}
+  n = (int)n_dim;
 
-void
-st_set_nml_var_char (void * var_addr, char * var_name, int var_name_len,
-		     int kind, gfc_charlen_type string_length)
-{
-  st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_CHARACTER,
-		  string_length);
-}
+  for (nml = ionml; nml->next; nml = nml->next);
 
-void
-st_set_nml_var_complex (void * var_addr, char * var_name, int var_name_len,
-			int kind)
-{
-  st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_COMPLEX, 0);
+  nml->dim[n].stride = (ssize_t)stride;
+  nml->dim[n].lbound = (ssize_t)lbound;
+  nml->dim[n].ubound = (ssize_t)ubound;
 }
 
-void
-st_set_nml_var_log (void * var_addr, char * var_name, int var_name_len,
-		    int kind)
-{
-   st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_LOGICAL, 0);
-}
+extern void st_set_nml_var (void * ,char * ,
+			    GFC_INTEGER_4 ,gfc_charlen_type ,GFC_INTEGER_4);
+export_proto(st_set_nml_var);
+
+extern void st_set_nml_var_dim (GFC_INTEGER_4, GFC_INTEGER_4,
+				GFC_INTEGER_4 ,GFC_INTEGER_4);
+export_proto(st_set_nml_var_dim);
+
diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c
index d97caec8bc7..c57ebac6219 100644
--- a/libgfortran/io/write.c
+++ b/libgfortran/io/write.c
@@ -1,5 +1,6 @@
 /* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
    Contributed by Andy Vaught
+   Namelist output contibuted by Paul Thomas
 
 This file is part of the GNU Fortran 95 runtime library (libgfortran).
 
@@ -29,6 +30,7 @@ Boston, MA 02111-1307, USA.  */
 
 #include "config.h"
 #include <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
+