X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=libgfortran%2Fio%2Fwrite.c;h=ee2ce0c391513c3b544dc5d7878e04039fa7de48;hb=09c759aaf6da911aa1a44898d2b84121991bced9;hp=c7abf2bbd7d8abace4c59b6fa45928eb26fa477d;hpb=17716b74d77eda5c4bc28b5dae0a94ab5f0a95f7;p=pf3gnuchains%2Fgcc-fork.git

diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c
index c7abf2bbd7d..ee2ce0c3915 100644
--- a/libgfortran/io/write.c
+++ b/libgfortran/io/write.c
@@ -1,843 +1,498 @@
-/* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
+/* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+   Free Software Foundation, Inc.
    Contributed by Andy Vaught
-   Namelist output contibuted by Paul Thomas
+   Namelist output contributed by Paul Thomas
+   F2003 I/O support contributed by Jerry DeLisle
 
-This file is part of the GNU Fortran 95 runtime library (libgfortran).
+This file is part of the GNU Fortran runtime library (libgfortran).
 
 Libgfortran is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
+the Free Software Foundation; either version 3, or (at your option)
 any later version.
 
-In addition to the permissions in the GNU General Public License, the
-Free Software Foundation gives you unlimited permission to link the
-compiled version of this file into combinations with other programs,
-and to distribute those combinations without any restriction coming
-from the use of this file.  (The General Public License restrictions
-do apply in other respects; for example, they cover modification of
-the file, and distribution when not linked into a combine
-executable.)
-
 Libgfortran is distributed in the hope that it will be useful,
 but WITHOUT ANY WARRANTY; without even the implied warranty of
 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 GNU General Public License for more details.
 
-You should have received a copy of the GNU General Public License
-along with Libgfortran; see the file COPYING.  If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA.  */
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
 
-#include "config.h"
+#include "io.h"
+#include "format.h"
+#include "unix.h"
+#include <assert.h>
 #include <string.h>
 #include <ctype.h>
-#include <float.h>
-#include <stdio.h>
 #include <stdlib.h>
-#include "libgfortran.h"
-#include "io.h"
-
+#include <stdbool.h>
+#include <errno.h>
 #define star_fill(p, n) memset(p, '*', n)
 
+#include "write_float.def"
 
-typedef enum
-{ SIGN_NONE, SIGN_MINUS, SIGN_PLUS }
-sign_t;
-
+typedef unsigned char uchar;
 
-static int no_leading_blank = 0 ;
+/* Write out default char4.  */
 
-void
-write_a (fnode * f, const char *source, int len)
+static void
+write_default_char4 (st_parameter_dt *dtp, gfc_char4_t *source,
+		     int src_len, int w_len)
 {
-  int wlen;
   char *p;
-
-  wlen = f->u.string.length < 0 ? len : f->u.string.length;
-
-  p = write_block (wlen);
-  if (p == NULL)
-    return;
-
-  if (wlen < len)
-    memcpy (p, source, wlen);
-  else
+  int j, k = 0;
+  gfc_char4_t c;
+  uchar d;
+      
+  /* Take care of preceding blanks.  */
+  if (w_len > src_len)
     {
-      memset (p, ' ', wlen - len);
-      memcpy (p + wlen - len, source, len);
+      k = w_len - src_len;
+      p = write_block (dtp, k);
+      if (p == NULL)
+	return;
+      memset (p, ' ', k);
     }
-}
-
-static GFC_INTEGER_LARGEST
-extract_int (const void *p, int len)
-{
-  GFC_INTEGER_LARGEST i = 0;
 
-  if (p == NULL)
-    return i;
-
-  switch (len)
+  /* Get ready to handle delimiters if needed.  */
+  switch (dtp->u.p.current_unit->delim_status)
     {
-    case 1:
-      i = *((const GFC_INTEGER_1 *) p);
-      break;
-    case 2:
-      i = *((const GFC_INTEGER_2 *) p);
-      break;
-    case 4:
-      i = *((const GFC_INTEGER_4 *) p);
-      break;
-    case 8:
-      i = *((const GFC_INTEGER_8 *) p);
+    case DELIM_APOSTROPHE:
+      d = '\'';
       break;
-#ifdef HAVE_GFC_INTEGER_16
-    case 16:
-      i = *((const GFC_INTEGER_16 *) p);
+    case DELIM_QUOTE:
+      d = '"';
       break;
-#endif
     default:
-      internal_error ("bad integer kind");
+      d = ' ';
+      break;
     }
 
-  return i;
+  /* Now process the remaining characters, one at a time.  */
+  for (j = k; j < src_len; j++)
+    {
+      c = source[j];
+    
+      /* Handle delimiters if any.  */
+      if (c == d && d != ' ')
+	{
+	  p = write_block (dtp, 2);
+	  if (p == NULL)
+	    return;
+	  *p++ = (uchar) c;
+	}
+      else
+	{
+	  p = write_block (dtp, 1);
+	  if (p == NULL)
+	    return;
+	}
+      *p = c > 255 ? '?' : (uchar) c;
+    }
 }
 
-static GFC_UINTEGER_LARGEST
-extract_uint (const void *p, int len)
-{
-  GFC_UINTEGER_LARGEST i = 0;
 
-  if (p == NULL)
-    return i;
+/* Write out UTF-8 converted from char4.  */
 
-  switch (len)
+static void
+write_utf8_char4 (st_parameter_dt *dtp, gfc_char4_t *source,
+		     int src_len, int w_len)
+{
+  char *p;
+  int j, k = 0;
+  gfc_char4_t c;
+  static const uchar masks[6] =  { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
+  static const uchar limits[6] = { 0x80, 0xE0, 0xF0, 0xF8, 0xFC, 0xFE };
+  int nbytes;
+  uchar buf[6], d, *q; 
+
+  /* Take care of preceding blanks.  */
+  if (w_len > src_len)
     {
-    case 1:
-      i = (GFC_UINTEGER_1) *((const GFC_INTEGER_1 *) p);
-      break;
-    case 2:
-      i = (GFC_UINTEGER_2) *((const GFC_INTEGER_2 *) p);
-      break;
-    case 4:
-      i = (GFC_UINTEGER_4) *((const GFC_INTEGER_4 *) p);
-      break;
-    case 8:
-      i = (GFC_UINTEGER_8) *((const GFC_INTEGER_8 *) p);
-      break;
-#ifdef HAVE_GFC_INTEGER_16
-    case 16:
-      i = (GFC_UINTEGER_16) *((const GFC_INTEGER_16 *) p);
-      break;
-#endif
-    default:
-      internal_error ("bad integer kind");
+      k = w_len - src_len;
+      p = write_block (dtp, k);
+      if (p == NULL)
+	return;
+      memset (p, ' ', k);
     }
 
-  return i;
-}
-
-static GFC_REAL_LARGEST
-extract_real (const void *p, int len)
-{
-  GFC_REAL_LARGEST i = 0;
-  switch (len)
+  /* Get ready to handle delimiters if needed.  */
+  switch (dtp->u.p.current_unit->delim_status)
     {
-    case 4:
-      i = *((const GFC_REAL_4 *) p);
-      break;
-    case 8:
-      i = *((const GFC_REAL_8 *) p);
-      break;
-#ifdef HAVE_GFC_REAL_10
-    case 10:
-      i = *((const GFC_REAL_10 *) p);
+    case DELIM_APOSTROPHE:
+      d = '\'';
       break;
-#endif
-#ifdef HAVE_GFC_REAL_16
-    case 16:
-      i = *((const GFC_REAL_16 *) p);
+    case DELIM_QUOTE:
+      d = '"';
       break;
-#endif
     default:
-      internal_error ("bad real kind");
-    }
-  return i;
-}
-
-
-/* Given a flag that indicate if a value is negative or not, return a
-   sign_t that gives the sign that we need to produce.  */
-
-static sign_t
-calculate_sign (int negative_flag)
-{
-  sign_t s = SIGN_NONE;
-
-  if (negative_flag)
-    s = SIGN_MINUS;
-  else
-    switch (g.sign_status)
-      {
-      case SIGN_SP:
-	s = SIGN_PLUS;
-	break;
-      case SIGN_SS:
-	s = SIGN_NONE;
-	break;
-      case SIGN_S:
-	s = options.optional_plus ? SIGN_PLUS : SIGN_NONE;
-	break;
-      }
-
-  return s;
-}
-
-
-/* Returns the value of 10**d.  */
-
-static GFC_REAL_LARGEST
-calculate_exp (int d)
-{
-  int i;
-  GFC_REAL_LARGEST r = 1.0;
-
-  for (i = 0; i< (d >= 0 ? d : -d); i++)
-    r *= 10;
-
-  r = (d >= 0) ? r : 1.0 / r;
-
-  return r;
-}
-
-
-/* Generate corresponding I/O format for FMT_G output.
-   The rules to translate FMT_G to FMT_E or FMT_F from DEC fortran
-   LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is:
-
-   Data Magnitude                              Equivalent Conversion
-   0< m < 0.1-0.5*10**(-d-1)                   Ew.d[Ee]
-   m = 0                                       F(w-n).(d-1), n' '
-   0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d)     F(w-n).d, n' '
-   1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1)      F(w-n).(d-1), n' '
-   10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2)  F(w-n).(d-2), n' '
-   ................                           ..........
-   10**(d-1)-0.5*10**(-1)<= m <10**d-0.5       F(w-n).0,n(' ')
-   m >= 10**d-0.5                              Ew.d[Ee]
-
-   notes: for Gw.d ,  n' ' means 4 blanks
-          for Gw.dEe, n' ' means e+2 blanks  */
-
-static fnode *
-calculate_G_format (fnode *f, GFC_REAL_LARGEST value, int *num_blank)
-{
-  int e = f->u.real.e;
-  int d = f->u.real.d;
-  int w = f->u.real.w;
-  fnode *newf;
-  GFC_REAL_LARGEST m, exp_d;
-  int low, high, mid;
-  int ubound, lbound;
-
-  newf = get_mem (sizeof (fnode));
-
-  /* Absolute value.  */
-  m = (value > 0.0) ? value : -value;
-
-  /* In case of the two data magnitude ranges,
-     generate E editing, Ew.d[Ee].  */
-  exp_d = calculate_exp (d);
-  if ((m > 0.0 && m < 0.1 - 0.05 / exp_d) || (m >= exp_d - 0.5 ))
-    {
-      newf->format = FMT_E;
-      newf->u.real.w = w;
-      newf->u.real.d = d;
-      newf->u.real.e = e;
-      *num_blank = 0;
-      return newf;
+      d = ' ';
+      break;
     }
 
-  /* Use binary search to find the data magnitude range.  */
-  mid = 0;
-  low = 0;
-  high = d + 1;
-  lbound = 0;
-  ubound = d + 1;
-
-  while (low <= high)
+  /* Now process the remaining characters, one at a time.  */
+  for (j = k; j < src_len; j++)
     {
-      GFC_REAL_LARGEST temp;
-      mid = (low + high) / 2;
-
-      /* 0.1 * 10**mid - 0.5 * 10**(mid-d-1)  */
-      temp = 0.1 * calculate_exp (mid) - 0.5 * calculate_exp (mid - d - 1);
-
-      if (m < temp)
-        {
-          ubound = mid;
-          if (ubound == lbound + 1)
-            break;
-          high = mid - 1;
-        }
-      else if (m > temp)
-        {
-          lbound = mid;
-          if (ubound == lbound + 1)
-            {
-              mid ++;
-              break;
-            }
-          low = mid + 1;
-        }
+      c = source[j];
+      if (c < 0x80)
+	{
+	  /* Handle the delimiters if any.  */
+	  if (c == d && d != ' ')
+	    {
+	      p = write_block (dtp, 2);
+	      if (p == NULL)
+		return;
+	      *p++ = (uchar) c;
+	    }
+	  else
+	    {
+	      p = write_block (dtp, 1);
+	      if (p == NULL)
+		return;
+	    }
+	  *p = (uchar) c;
+	}
       else
-        break;
-    }
+	{
+	  /* Convert to UTF-8 sequence.  */
+	  nbytes = 1;
+	  q = &buf[6];
 
-  /* Pad with blanks where the exponent would be.  */
-  if (e < 0)
-    *num_blank = 4;
-  else
-    *num_blank = e + 2;
+	  do
+	    {
+	      *--q = ((c & 0x3F) | 0x80);
+	      c >>= 6;
+	      nbytes++;
+	    }
+	  while (c >= 0x3F || (c & limits[nbytes-1]));
 
-  /* Generate the F editing. F(w-n).(-(mid-d-1)), n' '.  */
-  newf->format = FMT_F;
-  newf->u.real.w = f->u.real.w - *num_blank;
+	  *--q = (c | masks[nbytes-1]);
 
-  /* Special case.  */
-  if (m == 0.0)
-    newf->u.real.d = d - 1;
-  else
-    newf->u.real.d = - (mid - d - 1);
+	  p = write_block (dtp, nbytes);
+	  if (p == NULL)
+	    return;
 
-  /* For F editing, the scale factor is ignored.  */
-  g.scale_factor = 0;
-  return newf;
+	  while (q < &buf[6])
+	    *p++ = *q++;
+	}
+    }
 }
 
 
-/* Output a real number according to its format which is FMT_G free.  */
-
-static void
-output_float (fnode *f, GFC_REAL_LARGEST value)
+void
+write_a (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
 {
-  /* This must be large enough to accurately hold any value.  */
-  char buffer[32];
-  char *out;
-  char *digits;
-  int e;
-  char expchar;
-  format_token ft;
-  int w;
-  int d;
-  int edigits;
-  int ndigits;
-  /* Number of digits before the decimal point.  */
-  int nbefore;
-  /* Number of zeros after the decimal point.  */
-  int nzero;
-  /* Number of digits after the decimal point.  */
-  int nafter;
-  /* Number of zeros after the decimal point, whatever the precision.  */
-  int nzero_real;
-  int leadzero;
-  int nblanks;
-  int i;
-  sign_t sign;
-  double abslog;
-
-  ft = f->format;
-  w = f->u.real.w;
-  d = f->u.real.d;
-
-  nzero_real = -1;
-
-
-  /* We should always know the field width and precision.  */
-  if (d < 0)
-    internal_error ("Unspecified precision");
+  int wlen;
+  char *p;
 
-  /* Use sprintf to print the number in the format +D.DDDDe+ddd
-     For an N digit exponent, this gives us (32-6)-N digits after the
-     decimal point, plus another one before the decimal point.  */
-  sign = calculate_sign (value < 0.0);
-  if (value < 0)
-    value = -value;
+  wlen = f->u.string.length < 0
+	 || (f->format == FMT_G && f->u.string.length == 0)
+	 ? len : f->u.string.length;
 
-  /* Printf always prints at least two exponent digits.  */
-  if (value == 0)
-    edigits = 2;
-  else
+#ifdef HAVE_CRLF
+  /* If this is formatted STREAM IO convert any embedded line feed characters
+     to CR_LF on systems that use that sequence for newlines.  See F2003
+     Standard sections 10.6.3 and 9.9 for further information.  */
+  if (is_stream_io (dtp))
     {
-#if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
-      abslog = fabs((double) log10l(value));
-#else
-      abslog = fabs(log10(value));
-#endif
-      if (abslog < 100)
-	edigits = 2;
-      else
-        edigits = 1 + (int) log10(abslog);
-    }
+      const char crlf[] = "\r\n";
+      int i, q, bytes;
+      q = bytes = 0;
 
-  if (ft == FMT_F || ft == FMT_EN
-      || ((ft == FMT_D || ft == FMT_E) && g.scale_factor != 0))
-    {
-      /* Always convert at full precision to avoid double rounding.  */
-      ndigits = 27 - edigits;
-    }
-  else
-    {
-      /* We know the number of digits, so can let printf do the rounding
-	 for us.  */
-      if (ft == FMT_ES)
-	ndigits = d + 1;
-      else
-	ndigits = d;
-      if (ndigits > 27 - edigits)
-	ndigits = 27 - edigits;
-    }
-
-  /* #   The result will always contain a decimal point, even if no
-   *     digits follow it
-   *
-   * -   The converted value is to be left adjusted on the field boundary
-   *
-   * +   A sign (+ or -) always be placed before a number
-   *
-   * 31  minimum field width
-   *
-   * *   (ndigits-1) is used as the precision
-   *
-   *   e format: [-]d.ddde±dd where there is one digit before the
-   *   decimal-point character and the number of digits after it is
-   *   equal to the precision. The exponent always contains at least two
-   *   digits; if the value is zero, the exponent is 00.
-   */
-  sprintf (buffer, "%+-#31.*" GFC_REAL_LARGEST_FORMAT "e",
-           ndigits - 1, value);
-
-  /* Check the resulting string has punctuation in the correct places.  */
-  if (buffer[2] != '.' || buffer[ndigits + 2] != 'e')
-      internal_error ("printf is broken");
-
-  /* Read the exponent back in.  */
-  e = atoi (&buffer[ndigits + 3]) + 1;
-
-  /* Make sure zero comes out as 0.0e0.  */
-  if (value == 0.0)
-    e = 0;
-
-  /* Normalize the fractional component.  */
-  buffer[2] = buffer[1];
-  digits = &buffer[2];
-
-  /* Figure out where to place the decimal point.  */
-  switch (ft)
-    {
-    case FMT_F:
-      nbefore = e + g.scale_factor;
-      if (nbefore < 0)
-	{
-	  nzero = -nbefore;
-          nzero_real = nzero;
-	  if (nzero > d)
-	    nzero = d;
-	  nafter = d - nzero;
-	  nbefore = 0;
-	}
-      else
+      /* Write out any padding if needed.  */
+      if (len < wlen)
 	{
-	  nzero = 0;
-	  nafter = d;
+	  p = write_block (dtp, wlen - len);
+	  if (p == NULL)
+	    return;
+	  memset (p, ' ', wlen - len);
 	}
-      expchar = 0;
-      break;
 
-    case FMT_E:
-    case FMT_D:
-      i = g.scale_factor;
-      if (value != 0.0)
-	e -= i;
-      if (i < 0)
-	{
-	  nbefore = 0;
-	  nzero = -i;
-	  nafter = d + i;
-	}
-      else if (i > 0)
+      /* Scan the source string looking for '\n' and convert it if found.  */
+      for (i = 0; i < wlen; i++)
 	{
-	  nbefore = i;
-	  nzero = 0;
-	  nafter = (d - i) + 1;
+	  if (source[i] == '\n')
+	    {
+	      /* Write out the previously scanned characters in the string.  */
+	      if (bytes > 0)
+		{
+		  p = write_block (dtp, bytes);
+		  if (p == NULL)
+		    return;
+		  memcpy (p, &source[q], bytes);
+		  q += bytes;
+		  bytes = 0;
+		}
+
+	      /* Write out the CR_LF sequence.  */ 
+	      q++;
+	      p = write_block (dtp, 2);
+              if (p == NULL)
+                return;
+	      memcpy (p, crlf, 2);
+	    }
+	  else
+	    bytes++;
 	}
-      else /* i == 0 */
+
+      /*  Write out any remaining bytes if no LF was found.  */
+      if (bytes > 0)
 	{
-	  nbefore = 0;
-	  nzero = 0;
-	  nafter = d;
+	  p = write_block (dtp, bytes);
+	  if (p == NULL)
+	    return;
+	  memcpy (p, &source[q], bytes);
 	}
+    }
+  else
+    {
+#endif
+      p = write_block (dtp, wlen);
+      if (p == NULL)
+	return;
 
-      if (ft == FMT_E)
-	expchar = 'E';
-      else
-	expchar = 'D';
-      break;
-
-    case FMT_EN:
-      /* The exponent must be a multiple of three, with 1-3 digits before
-	 the decimal point.  */
-      if (value != 0.0)
-        e--;
-      if (e >= 0)
-	nbefore = e % 3;
+      if (wlen < len)
+	memcpy (p, source, wlen);
       else
 	{
-	  nbefore = (-e) % 3;
-	  if (nbefore != 0)
-	    nbefore = 3 - nbefore;
+	  memset (p, ' ', wlen - len);
+	  memcpy (p + wlen - len, source, len);
 	}
-      e -= nbefore;
-      nbefore++;
-      nzero = 0;
-      nafter = d;
-      expchar = 'E';
-      break;
+#ifdef HAVE_CRLF
+    }
+#endif
+}
 
-    case FMT_ES:
-      if (value != 0.0)
-        e--;
-      nbefore = 1;
-      nzero = 0;
-      nafter = d;
-      expchar = 'E';
-      break;
 
-    default:
-      /* Should never happen.  */
-      internal_error ("Unexpected format token");
-    }
+/* The primary difference between write_a_char4 and write_a is that we have to
+   deal with writing from the first byte of the 4-byte character and pay
+   attention to the most significant bytes.  For ENCODING="default" write the
+   lowest significant byte. If the 3 most significant bytes contain
+   non-zero values, emit a '?'.  For ENCODING="utf-8", convert the UCS-32 value
+   to the UTF-8 encoded string before writing out.  */
 
-  /* Round the value.  */
-  if (nbefore + nafter == 0)
-    {
-      ndigits = 0;
-      if (nzero_real == d && digits[0] >= '5')
-        {
-          /* We rounded to zero but shouldn't have */
-          nzero--;
-          nafter = 1;
-          digits[0] = '1';
-          ndigits = 1;
-        }
-    }
-  else if (nbefore + nafter < ndigits)
+void
+write_a_char4 (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
+{
+  int wlen;
+  gfc_char4_t *q;
+
+  wlen = f->u.string.length < 0
+	 || (f->format == FMT_G && f->u.string.length == 0)
+	 ? len : f->u.string.length;
+
+  q = (gfc_char4_t *) source;
+#ifdef HAVE_CRLF
+  /* If this is formatted STREAM IO convert any embedded line feed characters
+     to CR_LF on systems that use that sequence for newlines.  See F2003
+     Standard sections 10.6.3 and 9.9 for further information.  */
+  if (is_stream_io (dtp))
     {
-      ndigits = nbefore + nafter;
-      i = ndigits;
-      if (digits[i] >= '5')
+      const gfc_char4_t crlf[] = {0x000d,0x000a};
+      int i, bytes;
+      gfc_char4_t *qq;
+      bytes = 0;
+
+      /* Write out any padding if needed.  */
+      if (len < wlen)
 	{
-	  /* Propagate the carry.  */
-	  for (i--; i >= 0; i--)
-	    {
-	      if (digits[i] != '9')
-		{
-		  digits[i]++;
-		  break;
-		}
-	      digits[i] = '0';
-	    }
+	  char *p;
+	  p = write_block (dtp, wlen - len);
+	  if (p == NULL)
+	    return;
+	  memset (p, ' ', wlen - len);
+	}
 
-	  if (i < 0)
+      /* Scan the source string looking for '\n' and convert it if found.  */
+      qq = (gfc_char4_t *) source;
+      for (i = 0; i < wlen; i++)
+	{
+	  if (qq[i] == '\n')
 	    {
-	      /* The carry overflowed.  Fortunately we have some spare space
-		 at the start of the buffer.  We may discard some digits, but
-		 this is ok because we already know they are zero.  */
-	      digits--;
-	      digits[0] = '1';
-	      if (ft == FMT_F)
+	      /* Write out the previously scanned characters in the string.  */
+	      if (bytes > 0)
 		{
-		  if (nzero > 0)
-		    {
-		      nzero--;
-		      nafter++;
-		    }
+		  if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
+		    write_utf8_char4 (dtp, q, bytes, 0);
 		  else
-		    nbefore++;
-		}
-	      else if (ft == FMT_EN)
-		{
-		  nbefore++;
-		  if (nbefore == 4)
-		    {
-		      nbefore = 1;
-		      e += 3;
-		    }
+		    write_default_char4 (dtp, q, bytes, 0);
+		  bytes = 0;
 		}
-	      else
-		e++;
-	    }
-	}
-    }
 
-  /* Calculate the format of the exponent field.  */
-  if (expchar)
-    {
-      edigits = 1;
-      for (i = abs (e); i >= 10; i /= 10)
-	edigits++;
-
-      if (f->u.real.e < 0)
-	{
-	  /* Width not specified.  Must be no more than 3 digits.  */
-	  if (e > 999 || e < -999)
-	    edigits = -1;
-	  else
-	    {
-	      edigits = 4;
-	      if (e > 99 || e < -99)
-		expchar = ' ';
+	      /* Write out the CR_LF sequence.  */ 
+	      write_default_char4 (dtp, crlf, 2, 0);
 	    }
+	  else
+	    bytes++;
 	}
-      else
+
+      /*  Write out any remaining bytes if no LF was found.  */
+      if (bytes > 0)
 	{
-	  /* Exponent width specified, check it is wide enough.  */
-	  if (edigits > f->u.real.e)
-	    edigits = -1;
+	  if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
+	    write_utf8_char4 (dtp, q, bytes, 0);
 	  else
-	    edigits = f->u.real.e + 2;
+	    write_default_char4 (dtp, q, bytes, 0);
 	}
     }
   else
-    edigits = 0;
-
-  /* Pick a field size if none was specified.  */
-  if (w <= 0)
-    w = nbefore + nzero + nafter + (sign != SIGN_NONE ? 2 : 1);
-
-  /* Create the ouput buffer.  */
-  out = write_block (w);
-  if (out == NULL)
-    return;
-
-  /* Zero values always output as positive, even if the value was negative
-     before rounding.  */
-  for (i = 0; i < ndigits; i++)
-    {
-      if (digits[i] != '0')
-	break;
-    }
-  if (i == ndigits)
-    sign = calculate_sign (0);
-
-  /* Work out how much padding is needed.  */
-  nblanks = w - (nbefore + nzero + nafter + edigits + 1);
-  if (sign != SIGN_NONE)
-    nblanks--;
-
-  /* Check the value fits in the specified field width.  */
-  if (nblanks < 0 || edigits == -1)
     {
-      star_fill (out, w);
-      return;
-    }
-
-  /* See if we have space for a zero before the decimal point.  */
-  if (nbefore == 0 && nblanks > 0)
-    {
-      leadzero = 1;
-      nblanks--;
-    }
-  else
-    leadzero = 0;
-
-  /* Padd to full field width.  */
-
-
-  if ( ( nblanks > 0 ) && !no_leading_blank )
-    {
-      memset (out, ' ', nblanks);
-      out += nblanks;
+#endif
+      if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
+	write_utf8_char4 (dtp, q, len, wlen);
+      else
+	write_default_char4 (dtp, q, len, wlen);
+#ifdef HAVE_CRLF
     }
+#endif
+}
 
-  /* Output the initial sign (if any).  */
-  if (sign == SIGN_PLUS)
-    *(out++) = '+';
-  else if (sign == SIGN_MINUS)
-    *(out++) = '-';
-
-  /* Output an optional leading zero.  */
-  if (leadzero)
-    *(out++) = '0';
 
-  /* Output the part before the decimal point, padding with zeros.  */
-  if (nbefore > 0)
-    {
-      if (nbefore > ndigits)
-	i = ndigits;
-      else
-	i = nbefore;
-
-      memcpy (out, digits, i);
-      while (i < nbefore)
-	out[i++] = '0';
+static GFC_INTEGER_LARGEST
+extract_int (const void *p, int len)
+{
+  GFC_INTEGER_LARGEST i = 0;
 
-      digits += i;
-      ndigits -= i;
-      out += nbefore;
-    }
-  /* Output the decimal point.  */
-  *(out++) = '.';
+  if (p == NULL)
+    return i;
 
-  /* Output leading zeros after the decimal point.  */
-  if (nzero > 0)
+  switch (len)
     {
-      for (i = 0; i < nzero; i++)
-	*(out++) = '0';
+    case 1:
+      {
+	GFC_INTEGER_1 tmp;
+	memcpy ((void *) &tmp, p, len);
+	i = tmp;
+      }
+      break;
+    case 2:
+      {
+	GFC_INTEGER_2 tmp;
+	memcpy ((void *) &tmp, p, len);
+	i = tmp;
+      }
+      break;
+    case 4:
+      {
+	GFC_INTEGER_4 tmp;
+	memcpy ((void *) &tmp, p, len);
+	i = tmp;
+      }
+      break;
+    case 8:
+      {
+	GFC_INTEGER_8 tmp;
+	memcpy ((void *) &tmp, p, len);
+	i = tmp;
+      }
+      break;
+#ifdef HAVE_GFC_INTEGER_16
+    case 16:
+      {
+	GFC_INTEGER_16 tmp;
+	memcpy ((void *) &tmp, p, len);
+	i = tmp;
+      }
+      break;
+#endif
+    default:
+      internal_error (NULL, "bad integer kind");
     }
 
-  /* Output digits after the decimal point, padding with zeros.  */
-  if (nafter > 0)
-    {
-      if (nafter > ndigits)
-	i = ndigits;
-      else
-	i = nafter;
+  return i;
+}
 
-      memcpy (out, digits, i);
-      while (i < nafter)
-	out[i++] = '0';
+static GFC_UINTEGER_LARGEST
+extract_uint (const void *p, int len)
+{
+  GFC_UINTEGER_LARGEST i = 0;
 
-      digits += i;
-      ndigits -= i;
-      out += nafter;
-    }
+  if (p == NULL)
+    return i;
 
-  /* Output the exponent.  */
-  if (expchar)
+  switch (len)
     {
-      if (expchar != ' ')
-	{
-	  *(out++) = expchar;
-	  edigits--;
-	}
-#if HAVE_SNPRINTF
-      snprintf (buffer, 32, "%+0*d", edigits, e);
-#else
-      sprintf (buffer, "%+0*d", edigits, e);
+    case 1:
+      {
+	GFC_INTEGER_1 tmp;
+	memcpy ((void *) &tmp, p, len);
+	i = (GFC_UINTEGER_1) tmp;
+      }
+      break;
+    case 2:
+      {
+	GFC_INTEGER_2 tmp;
+	memcpy ((void *) &tmp, p, len);
+	i = (GFC_UINTEGER_2) tmp;
+      }
+      break;
+    case 4:
+      {
+	GFC_INTEGER_4 tmp;
+	memcpy ((void *) &tmp, p, len);
+	i = (GFC_UINTEGER_4) tmp;
+      }
+      break;
+    case 8:
+      {
+	GFC_INTEGER_8 tmp;
+	memcpy ((void *) &tmp, p, len);
+	i = (GFC_UINTEGER_8) tmp;
+      }
+      break;
+#ifdef HAVE_GFC_INTEGER_16
+    case 10:
+    case 16:
+      {
+	GFC_INTEGER_16 tmp = 0;
+	memcpy ((void *) &tmp, p, len);
+	i = (GFC_UINTEGER_16) tmp;
+      }
+      break;
 #endif
-      memcpy (out, buffer, edigits);
+    default:
+      internal_error (NULL, "bad integer kind");
     }
 
-  if ( no_leading_blank )
-    {
-      out += edigits;
-      memset( out , ' ' , nblanks );
-      no_leading_blank = 0;
-    }
+  return i;
 }
 
 
 void
-write_l (fnode * f, char *source, int len)
+write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len)
 {
   char *p;
+  int wlen;
   GFC_INTEGER_LARGEST n;
 
-  p = write_block (f->u.w);
+  wlen = (f->format == FMT_G && f->u.w == 0) ? 1 : f->u.w;
+  
+  p = write_block (dtp, wlen);
   if (p == NULL)
-    return;
-
-  memset (p, ' ', f->u.w - 1);
-  n = extract_int (source, len);
-  p[f->u.w - 1] = (n) ? 'T' : 'F';
-}
-
-/* Output a real number according to its format.  */
-
-static void
-write_float (fnode *f, const char *source, int len)
-{
-  GFC_REAL_LARGEST n;
-  int nb =0, res, save_scale_factor;
-  char * p, fin;
-  fnode *f2 = NULL;
-
-  n = extract_real (source, len);
-
-  if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z)
-    {
-      /* TODO: there are some systems where isfinite is not able to work
-               with long double variables. We should detect this case and
-	       provide our own version for isfinite.  */
-      res = isfinite (n); 
-      if (res == 0)
-	{
-	  nb =  f->u.real.w;
-	  p = write_block (nb);
-	  if (nb < 3)
-	    {
-	      memset (p, '*',nb);
-	      return;
-	    }
-
-	  memset(p, ' ', nb);
-	  res = !isnan (n);
-	  if (res != 0)
-	    {
-	      if (signbit(n))
-		fin = '-';
-	      else
-		fin = '+';
-
-	      if (nb > 7)
-		memcpy(p + nb - 8, "Infinity", 8);
-	      else
-		memcpy(p + nb - 3, "Inf", 3);
-	      if (nb < 8 && nb > 3)
-		p[nb - 4] = fin;
-	      else if (nb > 8)
-		p[nb - 9] = fin;
-	    }
-	  else
-	    memcpy(p + nb - 3, "NaN", 3);
-	  return;
-	}
-    }
+    return;
 
-  if (f->format != FMT_G)
-    {
-      output_float (f, n);
-    }
-  else
-    {
-      save_scale_factor = g.scale_factor;
-      f2 = calculate_G_format(f, n, &nb);
-      output_float (f2, n);
-      g.scale_factor = save_scale_factor;
-      if (f2 != NULL)
-        free_mem(f2);
-
-      if (nb > 0)
-        {
-          p = write_block (nb);
-          memset (p, ' ', nb);
-        }
-    }
+  memset (p, ' ', wlen - 1);
+  n = extract_int (source, len);
+  p[wlen - 1] = (n) ? 'T' : 'F';
 }
 
 
 static void
-write_int (fnode *f, const char *source, int len,
-           char *(*conv) (GFC_UINTEGER_LARGEST))
+write_boz (st_parameter_dt *dtp, const fnode *f, const char *q, int n)
 {
-  GFC_UINTEGER_LARGEST n = 0;
   int w, m, digits, nzero, nblank;
-  char *p, *q;
+  char *p;
 
   w = f->u.integer.w;
   m = f->u.integer.m;
 
-  n = extract_uint (source, len);
-
   /* Special case:  */
 
   if (m == 0 && n == 0)
@@ -845,7 +500,7 @@ write_int (fnode *f, const char *source, int len,
       if (w == 0)
         w = 1;
 
-      p = write_block (w);
+      p = write_block (dtp, w);
       if (p == NULL)
         return;
 
@@ -853,7 +508,6 @@ write_int (fnode *f, const char *source, int len,
       goto done;
     }
 
-  q = conv (n);
   digits = strlen (q);
 
   /* Select a width if none was specified.  The idea here is to always
@@ -862,7 +516,7 @@ write_int (fnode *f, const char *source, int len,
   if (w == 0)
     w = ((digits < m) ? m : digits);
 
-  p = write_block (w);
+  p = write_block (dtp, w);
   if (p == NULL)
     return;
 
@@ -880,14 +534,13 @@ write_int (fnode *f, const char *source, int len,
       goto done;
     }
 
-
-  if (!no_leading_blank)
+  if (!dtp->u.p.no_leading_blank)
     {
-  memset (p, ' ', nblank);
-  p += nblank;
-  memset (p, '0', nzero);
-  p += nzero;
-  memcpy (p, q, digits);
+      memset (p, ' ', nblank);
+      p += nblank;
+      memset (p, '0', nzero);
+      p += nzero;
+      memcpy (p, q, digits);
     }
   else
     {
@@ -896,7 +549,7 @@ write_int (fnode *f, const char *source, int len,
       memcpy (p, q, digits);
       p += digits;
       memset (p, ' ', nblank);
-      no_leading_blank = 0;
+      dtp->u.p.no_leading_blank = 0;
     }
 
  done:
@@ -904,27 +557,29 @@ write_int (fnode *f, const char *source, int len,
 }
 
 static void
-write_decimal (fnode *f, const char *source, int len,
-               char *(*conv) (GFC_INTEGER_LARGEST))
+write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source,
+	       int len,
+               const char *(*conv) (GFC_INTEGER_LARGEST, char *, size_t))
 {
   GFC_INTEGER_LARGEST n = 0;
   int w, m, digits, nsign, nzero, nblank;
-  char *p, *q;
+  char *p;
+  const char *q;
   sign_t sign;
+  char itoa_buf[GFC_BTOA_BUF_SIZE];
 
   w = f->u.integer.w;
-  m = f->u.integer.m;
+  m = f->format == FMT_G ? -1 : f->u.integer.m;
 
   n = extract_int (source, len);
 
   /* Special case:  */
-
   if (m == 0 && n == 0)
     {
       if (w == 0)
         w = 1;
 
-      p = write_block (w);
+      p = write_block (dtp, w);
       if (p == NULL)
         return;
 
@@ -932,12 +587,19 @@ write_decimal (fnode *f, const char *source, int len,
       goto done;
     }
 
-  sign = calculate_sign (n < 0);
+  sign = calculate_sign (dtp, n < 0);
   if (n < 0)
     n = -n;
-
-  nsign = sign == SIGN_NONE ? 0 : 1;
-  q = conv (n);
+  nsign = sign == S_NONE ? 0 : 1;
+  
+  /* conv calls itoa which sets the negative sign needed
+     by write_integer. The sign '+' or '-' is set below based on sign
+     calculated above, so we just point past the sign in the string
+     before proceeding to avoid double signs in corner cases.
+     (see PR38504)  */
+  q = conv (n, itoa_buf, sizeof (itoa_buf));
+  if (*q == '-')
+    q++;
 
   digits = strlen (q);
 
@@ -947,7 +609,7 @@ write_decimal (fnode *f, const char *source, int len,
   if (w == 0)
     w = ((digits < m) ? m : digits) + nsign;
 
-  p = write_block (w);
+  p = write_block (dtp, w);
   if (p == NULL)
     return;
 
@@ -970,13 +632,13 @@ write_decimal (fnode *f, const char *source, int len,
 
   switch (sign)
     {
-    case SIGN_PLUS:
+    case S_PLUS:
       *p++ = '+';
       break;
-    case SIGN_MINUS:
+    case S_MINUS:
       *p++ = '-';
       break;
-    case SIGN_NONE:
+    case S_NONE:
       break;
     }
 
@@ -992,133 +654,407 @@ write_decimal (fnode *f, const char *source, int len,
 
 /* Convert unsigned octal to ascii.  */
 
-static char *
-otoa (GFC_UINTEGER_LARGEST n)
+static const char *
+otoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
 {
   char *p;
 
+  assert (len >= GFC_OTOA_BUF_SIZE);
+
   if (n == 0)
-    {
-      scratch[0] = '0';
-      scratch[1] = '\0';
-      return scratch;
-    }
+    return "0";
 
-  p = scratch + SCRATCH_SIZE - 1;
-  *p-- = '\0';
+  p = buffer + GFC_OTOA_BUF_SIZE - 1;
+  *p = '\0';
 
   while (n != 0)
     {
-      *p = '0' + (n & 7);
-      p--;
+      *--p = '0' + (n & 7);
       n >>= 3;
     }
 
-  return ++p;
+  return p;
 }
 
 
 /* Convert unsigned binary to ascii.  */
 
-static char *
-btoa (GFC_UINTEGER_LARGEST n)
+static const char *
+btoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
 {
   char *p;
 
+  assert (len >= GFC_BTOA_BUF_SIZE);
+
   if (n == 0)
-    {
-      scratch[0] = '0';
-      scratch[1] = '\0';
-      return scratch;
-    }
+    return "0";
 
-  p = scratch + SCRATCH_SIZE - 1;
-  *p-- = '\0';
+  p = buffer + GFC_BTOA_BUF_SIZE - 1;
+  *p = '\0';
 
   while (n != 0)
     {
-      *p-- = '0' + (n & 1);
+      *--p = '0' + (n & 1);
       n >>= 1;
     }
 
-  return ++p;
+  return p;
+}
+
+/* The following three functions, btoa_big, otoa_big, and ztoa_big, are needed
+   to convert large reals with kind sizes that exceed the largest integer type
+   available on certain platforms.  In these cases, byte by byte conversion is
+   performed. Endianess is taken into account.  */
+
+/* Conversion to binary.  */
+
+static const char *
+btoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
+{
+  char *q;
+  int i, j;
+  
+  q = buffer;
+  if (big_endian)
+    {
+      const char *p = s;
+      for (i = 0; i < len; i++)
+	{
+	  char c = *p;
+
+	  /* Test for zero. Needed by write_boz later.  */
+	  if (*p != 0)
+	    *n = 1;
+
+	  for (j = 0; j < 8; j++)
+	    {
+	      *q++ = (c & 128) ? '1' : '0';
+	      c <<= 1;
+	    }
+	  p++;
+	}
+    }
+  else
+    {
+      const char *p = s + len - 1;
+      for (i = 0; i < len; i++)
+	{
+	  char c = *p;
+
+	  /* Test for zero. Needed by write_boz later.  */
+	  if (*p != 0)
+	    *n = 1;
+
+	  for (j = 0; j < 8; j++)
+	    {
+	      *q++ = (c & 128) ? '1' : '0';
+	      c <<= 1;
+	    }
+	  p--;
+	}
+    }
+
+  *q = '\0';
+
+  if (*n == 0)
+    return "0";
+
+  /* Move past any leading zeros.  */  
+  while (*buffer == '0')
+    buffer++;
+
+  return buffer;
+
+}
+
+/* Conversion to octal.  */
+
+static const char *
+otoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
+{
+  char *q;
+  int i, j, k;
+  uint8_t octet;
+
+  q = buffer + GFC_OTOA_BUF_SIZE - 1;
+  *q = '\0';
+  i = k = octet = 0;
+
+  if (big_endian)
+    {
+      const char *p = s + len - 1;
+      char c = *p;
+      while (i < len)
+	{
+	  /* Test for zero. Needed by write_boz later.  */
+	  if (*p != 0)
+	    *n = 1;
+
+	  for (j = 0; j < 3 && i < len; j++)
+	    {
+	      octet |= (c & 1) << j;
+	      c >>= 1;
+	      if (++k > 7)
+	        {
+		  i++;
+		  k = 0;
+		  c = *--p;
+		}
+	    }
+	  *--q = '0' + octet;
+	  octet = 0;
+	}
+    }
+  else
+    {
+      const char *p = s;
+      char c = *p;
+      while (i < len)
+	{
+	  /* Test for zero. Needed by write_boz later.  */
+	  if (*p != 0)
+	    *n = 1;
+
+	  for (j = 0; j < 3 && i < len; j++)
+	    {
+	      octet |= (c & 1) << j;
+	      c >>= 1;
+	      if (++k > 7)
+	        {
+		  i++;
+		  k = 0;
+		  c = *++p;
+		}
+	    }
+	  *--q = '0' + octet;
+	  octet = 0;
+	}
+    }
+
+  if (*n == 0)
+    return "0";
+
+  /* Move past any leading zeros.  */  
+  while (*q == '0')
+    q++;
+
+  return q;
+}
+
+/* Conversion to hexidecimal.  */
+
+static const char *
+ztoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
+{
+  static char a[16] = {'0', '1', '2', '3', '4', '5', '6', '7',
+    '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'};
+
+  char *q;
+  uint8_t h, l;
+  int i;
+  
+  q = buffer;
+  
+  if (big_endian)
+    {
+      const char *p = s;
+      for (i = 0; i < len; i++)
+	{
+	  /* Test for zero. Needed by write_boz later.  */
+	  if (*p != 0)
+	    *n = 1;
+
+	  h = (*p >> 4) & 0x0F;
+	  l = *p++ & 0x0F;
+	  *q++ = a[h];
+	  *q++ = a[l];
+	}
+    }
+  else
+    {
+      const char *p = s + len - 1;
+      for (i = 0; i < len; i++)
+	{
+	  /* Test for zero. Needed by write_boz later.  */
+	  if (*p != 0)
+	    *n = 1;
+
+	  h = (*p >> 4) & 0x0F;
+	  l = *p-- & 0x0F;
+	  *q++ = a[h];
+	  *q++ = a[l];
+	}
+    }
+
+  *q = '\0';
+  
+  if (*n == 0)
+    return "0";
+    
+  /* Move past any leading zeros.  */  
+  while (*buffer == '0')
+    buffer++;
+
+  return buffer;
+}
+
+/* gfc_itoa()-- Integer to decimal conversion.
+   The itoa function is a widespread non-standard extension to standard
+   C, often declared in <stdlib.h>.  Even though the itoa defined here
+   is a static function we take care not to conflict with any prior
+   non-static declaration.  Hence the 'gfc_' prefix, which is normally
+   reserved for functions with external linkage.  */
+
+static const char *
+gfc_itoa (GFC_INTEGER_LARGEST n, char *buffer, size_t len)
+{
+  int negative;
+  char *p;
+  GFC_UINTEGER_LARGEST t;
+
+  assert (len >= GFC_ITOA_BUF_SIZE);
+
+  if (n == 0)
+    return "0";
+
+  negative = 0;
+  t = n;
+  if (n < 0)
+    {
+      negative = 1;
+      t = -n; /*must use unsigned to protect from overflow*/
+    }
+
+  p = buffer + GFC_ITOA_BUF_SIZE - 1;
+  *p = '\0';
+
+  while (t != 0)
+    {
+      *--p = '0' + (t % 10);
+      t /= 10;
+    }
+
+  if (negative)
+    *--p = '-';
+  return p;
 }
 
 
 void
-write_i (fnode * f, const char *p, int len)
+write_i (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 {
-  write_decimal (f, p, len, (void *) gfc_itoa);
+  write_decimal (dtp, f, p, len, (void *) gfc_itoa);
 }
 
 
 void
-write_b (fnode * f, const char *p, int len)
+write_b (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
 {
-  write_int (f, p, len, btoa);
+  const char *p;
+  char itoa_buf[GFC_BTOA_BUF_SIZE];
+  GFC_UINTEGER_LARGEST n = 0;
+
+  if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
+    {
+      p = btoa_big (source, itoa_buf, len, &n);
+      write_boz (dtp, f, p, n);
+    }
+  else
+    {
+      n = extract_uint (source, len);
+      p = btoa (n, itoa_buf, sizeof (itoa_buf));
+      write_boz (dtp, f, p, n);
+    }
 }
 
 
 void
-write_o (fnode * f, const char *p, int len)
+write_o (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
 {
-  write_int (f, p, len, otoa);
+  const char *p;
+  char itoa_buf[GFC_OTOA_BUF_SIZE];
+  GFC_UINTEGER_LARGEST n = 0;
+  
+  if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
+    {
+      p = otoa_big (source, itoa_buf, len, &n);
+      write_boz (dtp, f, p, n);
+    }
+  else
+    {
+      n = extract_uint (source, len);
+      p = otoa (n, itoa_buf, sizeof (itoa_buf));
+      write_boz (dtp, f, p, n);
+    }
 }
 
 void
-write_z (fnode * f, const char *p, int len)
+write_z (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
 {
-  write_int (f, p, len, xtoa);
+  const char *p;
+  char itoa_buf[GFC_XTOA_BUF_SIZE];
+  GFC_UINTEGER_LARGEST n = 0;
+
+  if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
+    {
+      p = ztoa_big (source, itoa_buf, len, &n);
+      write_boz (dtp, f, p, n);
+    }
+  else
+    {
+      n = extract_uint (source, len);
+      p = gfc_xtoa (n, itoa_buf, sizeof (itoa_buf));
+      write_boz (dtp, f, p, n);
+    }
 }
 
 
 void
-write_d (fnode *f, const char *p, int len)
+write_d (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 {
-  write_float (f, p, len);
+  write_float (dtp, f, p, len);
 }
 
 
 void
-write_e (fnode *f, const char *p, int len)
+write_e (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 {
-  write_float (f, p, len);
+  write_float (dtp, f, p, len);
 }
 
 
 void
-write_f (fnode *f, const char *p, int len)
+write_f (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 {
-  write_float (f, p, len);
+  write_float (dtp, f, p, len);
 }
 
 
 void
-write_en (fnode *f, const char *p, int len)
+write_en (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 {
-  write_float (f, p, len);
+  write_float (dtp, f, p, len);
 }
 
 
 void
-write_es (fnode *f, const char *p, int len)
+write_es (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 {
-  write_float (f, p, len);
+  write_float (dtp, f, p, len);
 }
 
 
 /* Take care of the X/TR descriptor.  */
 
 void
-write_x (int len, int nspaces)
+write_x (st_parameter_dt *dtp, int len, int nspaces)
 {
   char *p;
 
-  p = write_block (len);
+  p = write_block (dtp, len);
   if (p == NULL)
     return;
-
-  if (nspaces > 0)
+  if (nspaces > 0 && len - nspaces >= 0)
     memset (&p[len - nspaces], ' ', nspaces);
 }
 
@@ -1130,11 +1066,11 @@ write_x (int len, int nspaces)
    something goes wrong.  */
 
 static int
-write_char (char c)
+write_char (st_parameter_dt *dtp, char c)
 {
   char *p;
 
-  p = write_block (1);
+  p = write_block (dtp, 1);
   if (p == NULL)
     return 1;
 
@@ -1147,23 +1083,24 @@ write_char (char c)
 /* Write a list-directed logical value.  */
 
 static void
-write_logical (const char *source, int length)
+write_logical (st_parameter_dt *dtp, const char *source, int length)
 {
-  write_char (extract_int (source, length) ? 'T' : 'F');
+  write_char (dtp, extract_int (source, length) ? 'T' : 'F');
 }
 
 
 /* Write a list-directed integer value.  */
 
 static void
-write_integer (const char *source, int length)
+write_integer (st_parameter_dt *dtp, const char *source, int length)
 {
   char *p;
   const char *q;
   int digits;
   int width;
+  char itoa_buf[GFC_ITOA_BUF_SIZE];
 
-  q = gfc_itoa (extract_int (source, length));
+  q = gfc_itoa (extract_int (source, length), itoa_buf, sizeof (itoa_buf));
 
   switch (length)
     {
@@ -1190,18 +1127,20 @@ write_integer (const char *source, int length)
 
   digits = strlen (q);
 
-  if(width < digits )
-    width = digits ;
-  p = write_block (width) ;
-  if (no_leading_blank)
+  if (width < digits)
+    width = digits;
+  p = write_block (dtp, width);
+  if (p == NULL)
+    return;
+  if (dtp->u.p.no_leading_blank)
     {
       memcpy (p, q, digits);
-      memset(p + digits ,' ', width - digits) ;
+      memset (p + digits, ' ', width - digits);
     }
   else
     {
-  memset(p ,' ', width - digits) ;
-  memcpy (p + width - digits, q, digits);
+      memset (p, ' ', width - digits);
+      memcpy (p + width - digits, q, digits);
     }
 }
 
@@ -1210,12 +1149,12 @@ write_integer (const char *source, int length)
    the strings if the file has been opened in that mode.  */
 
 static void
-write_character (const char *source, int length)
+write_character (st_parameter_dt *dtp, const char *source, int kind, int length)
 {
   int i, extra;
   char *p, d;
 
-  switch (current_unit->flags.delim)
+  switch (dtp->u.p.current_unit->delim_status)
     {
     case DELIM_APOSTROPHE:
       d = '\'';
@@ -1228,89 +1167,153 @@ write_character (const char *source, int length)
       break;
     }
 
-  if (d == ' ')
-    extra = 0;
-  else
+  if (kind == 1)
     {
-      extra = 2;
+      if (d == ' ')
+	extra = 0;
+      else
+	{
+	  extra = 2;
 
-      for (i = 0; i < length; i++)
-	if (source[i] == d)
-	  extra++;
-    }
+	  for (i = 0; i < length; i++)
+	    if (source[i] == d)
+	      extra++;
+	}
 
-  p = write_block (length + extra);
-  if (p == NULL)
-    return;
+      p = write_block (dtp, length + extra);
+      if (p == NULL)
+	return;
+
+      if (d == ' ')
+	memcpy (p, source, length);
+      else
+	{
+	  *p++ = d;
 
-  if (d == ' ')
-    memcpy (p, source, length);
+	  for (i = 0; i < length; i++)
+            {
+              *p++ = source[i];
+              if (source[i] == d)
+		*p++ = d;
+	    }
+
+	  *p = d;
+	}
+    }
   else
     {
-      *p++ = d;
-
-      for (i = 0; i < length; i++)
+      if (d == ' ')
 	{
-	  *p++ = source[i];
-	  if (source[i] == d)
-	    *p++ = d;
+	  if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
+	    write_utf8_char4 (dtp, (gfc_char4_t *) source, length, 0);
+	  else
+	    write_default_char4 (dtp, (gfc_char4_t *) source, length, 0);
 	}
+      else
+	{
+	  p = write_block (dtp, 1);
+	  *p = d;
+
+	  if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
+	    write_utf8_char4 (dtp, (gfc_char4_t *) source, length, 0);
+	  else
+	    write_default_char4 (dtp, (gfc_char4_t *) source, length, 0);
 
-      *p = d;
+	  p = write_block (dtp, 1);
+	  *p = d;
+	}
     }
 }
 
 
-/* Output a real number with default format.
-   This is 1PG14.7E2 for REAL(4) and 1PG23.15E3 for REAL(8).  */
+/* Set an fnode to default format.  */
 
 static void
-write_real (const char *source, int length)
+set_fnode_default (st_parameter_dt *dtp, fnode *f, int length)
 {
-  fnode f ;
-  int org_scale = g.scale_factor;
-  f.format = FMT_G;
-  g.scale_factor = 1;
-  if (length < 8)
-    {
-      f.u.real.w = 14;
-      f.u.real.d = 7;
-      f.u.real.e = 2;
-    }
-  else
+  f->format = FMT_G;
+  switch (length)
     {
-      f.u.real.w = 23;
-      f.u.real.d = 15;
-      f.u.real.e = 3;
+    case 4:
+      f->u.real.w = 15;
+      f->u.real.d = 8;
+      f->u.real.e = 2;
+      break;
+    case 8:
+      f->u.real.w = 25;
+      f->u.real.d = 17;
+      f->u.real.e = 3;
+      break;
+    case 10:
+      f->u.real.w = 29;
+      f->u.real.d = 20;
+      f->u.real.e = 4;
+      break;
+    case 16:
+      f->u.real.w = 44;
+      f->u.real.d = 35;
+      f->u.real.e = 4;
+      break;
+    default:
+      internal_error (&dtp->common, "bad real kind");
+      break;
     }
-  write_float (&f, source , length);
-  g.scale_factor = org_scale;
+}
+/* Output a real number with default format.
+   This is 1PG14.7E2 for REAL(4), 1PG23.15E3 for REAL(8),
+   1PG28.19E4 for REAL(10) and 1PG43.34E4 for REAL(16).  */
+
+void
+write_real (st_parameter_dt *dtp, const char *source, int length)
+{
+  fnode f ;
+  int org_scale = dtp->u.p.scale_factor;
+  dtp->u.p.scale_factor = 1;
+  set_fnode_default (dtp, &f, length);
+  write_float (dtp, &f, source , length);
+  dtp->u.p.scale_factor = org_scale;
+}
+
+
+void
+write_real_g0 (st_parameter_dt *dtp, const char *source, int length, int d)
+{
+  fnode f ;
+  set_fnode_default (dtp, &f, length);
+  if (d > 0)
+    f.u.real.d = d;
+  dtp->u.p.g0_no_blanks = 1;
+  write_float (dtp, &f, source , length);
+  dtp->u.p.g0_no_blanks = 0;
 }
 
 
 static void
-write_complex (const char *source, int len)
+write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
 {
-  if (write_char ('('))
+  char semi_comma =
+	dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
+
+  if (write_char (dtp, '('))
     return;
-  write_real (source, len);
+  write_real (dtp, source, kind);
 
-  if (write_char (','))
+  if (write_char (dtp, semi_comma))
     return;
-  write_real (source + len, len);
+  write_real (dtp, source + size / 2, kind);
 
-  write_char (')');
+  write_char (dtp, ')');
 }
 
 
 /* Write the separator between items.  */
 
 static void
-write_separator (void)
+write_separator (st_parameter_dt *dtp)
 {
   char *p;
 
-  p = write_block (options.separator_len);
+  p = write_block (dtp, options.separator_len);
   if (p == NULL)
     return;
 
@@ -1322,49 +1325,67 @@ write_separator (void)
    TODO: handle skipping to the next record correctly, particularly
    with strings.  */
 
-void
-list_formatted_write (bt type, void *p, int len)
+static void
+list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
+			     size_t size)
 {
-  static int char_flag;
-
-  if (current_unit == NULL)
+  if (dtp->u.p.current_unit == NULL)
     return;
 
-  if (g.first_item)
+  if (dtp->u.p.first_item)
     {
-      g.first_item = 0;
-      char_flag = 0;
-      write_char (' ');
+      dtp->u.p.first_item = 0;
+      write_char (dtp, ' ');
     }
   else
     {
-      if (type != BT_CHARACTER || !char_flag ||
-	  current_unit->flags.delim != DELIM_NONE)
-	write_separator ();
+      if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
+	dtp->u.p.current_unit->delim_status != DELIM_NONE)
+      write_separator (dtp);
     }
 
   switch (type)
     {
     case BT_INTEGER:
-      write_integer (p, len);
+      write_integer (dtp, p, kind);
       break;
     case BT_LOGICAL:
-      write_logical (p, len);
+      write_logical (dtp, p, kind);
       break;
     case BT_CHARACTER:
-      write_character (p, len);
+      write_character (dtp, p, kind, size);
       break;
     case BT_REAL:
-      write_real (p, len);
+      write_real (dtp, p, kind);
       break;
     case BT_COMPLEX:
-      write_complex (p, len);
+      write_complex (dtp, p, kind, size);
       break;
     default:
-      internal_error ("list_formatted_write(): Bad type");
+      internal_error (&dtp->common, "list_formatted_write(): Bad type");
     }
 
-  char_flag = (type == BT_CHARACTER);
+  dtp->u.p.char_flag = (type == BT_CHARACTER);
+}
+
+
+void
+list_formatted_write (st_parameter_dt *dtp, bt type, void *p, int kind,
+		      size_t size, size_t nelems)
+{
+  size_t elem;
+  char *tmp;
+  size_t stride = type == BT_CHARACTER ?
+		  size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
+
+  tmp = (char *) p;
+
+  /* Big loop over all the elements.  */
+  for (elem = 0; elem < nelems; elem++)
+    {
+      dtp->u.p.item_count++;
+      list_formatted_write_scalar (dtp, type, tmp + elem * stride, kind, size);
+    }
 }
 
 /*			NAMELIST OUTPUT
@@ -1390,24 +1411,63 @@ list_formatted_write (bt type, void *p, int len)
 
 #define NML_DIGITS 20
 
-/* Stores the delimiter to be used for character objects.  */
+static void
+namelist_write_newline (st_parameter_dt *dtp)
+{
+  if (!is_internal_unit (dtp))
+    {
+#ifdef HAVE_CRLF
+      write_character (dtp, "\r\n", 1, 2);
+#else
+      write_character (dtp, "\n", 1, 1);
+#endif
+      return;
+    }
+
+  if (is_array_io (dtp))
+    {
+      gfc_offset record;
+      int finished;
+
+      /* Now that the current record has been padded out,
+	 determine where the next record in the array is. */
+      record = next_array_record (dtp, dtp->u.p.current_unit->ls,
+				  &finished);
+      if (finished)
+	dtp->u.p.current_unit->endfile = AT_ENDFILE;
+      else
+	{
+	  /* Now seek to this record */
+	  record = record * dtp->u.p.current_unit->recl;
+
+	  if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
+	    {
+	      generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
+	      return;
+	    }
+
+	  dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
+	}
+    }
+  else
+    write_character (dtp, " ", 1, 1);
+}
 
-static const char * nml_delim;
 
 static namelist_info *
-nml_write_obj (namelist_info * obj, index_type offset,
+nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
 	       namelist_info * base, char * base_name)
 {
   int rep_ctr;
   int num;
   int nml_carry;
-  index_type len;
+  int len;
   index_type obj_size;
   index_type nelem;
-  index_type dim_i;
-  index_type clen;
+  size_t dim_i;
+  size_t clen;
   index_type elem_ctr;
-  index_type obj_name_len;
+  size_t obj_name_len;
   void * p ;
   char cup;
   char * obj_name;
@@ -1415,29 +1475,43 @@ nml_write_obj (namelist_info * obj, index_type offset,
   char rep_buff[NML_DIGITS];
   namelist_info * cmp;
   namelist_info * retval = obj->next;
+  size_t base_name_len;
+  size_t base_var_name_len;
+  size_t tot_len;
+  unit_delim tmp_delim;
+  
+  /* Set the character to be used to separate values
+     to a comma or semi-colon.  */
+
+  char semi_comma =
+	dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
 
   /* Write namelist variable names in upper case. If a derived type,
      nothing is output.  If a component, base and base_name are set.  */
 
   if (obj->type != GFC_DTYPE_DERIVED)
     {
-      write_character ("\n ", 2);
+      namelist_write_newline (dtp);
+      write_character (dtp, " ", 1, 1);
+
       len = 0;
       if (base)
 	{
-	  len =strlen (base->var_name);
-	  for (dim_i = 0; dim_i < (index_type) strlen (base_name); dim_i++)
+	  len = strlen (base->var_name);
+	  base_name_len = strlen (base_name);
+	  for (dim_i = 0; dim_i < base_name_len; dim_i++)
             {
 	      cup = toupper (base_name[dim_i]);
-	      write_character (&cup, 1);
+	      write_character (dtp, &cup, 1, 1);
             }
 	}
-      for (dim_i =len; dim_i < (index_type) strlen (obj->var_name); dim_i++)
+      clen = strlen (obj->var_name);
+      for (dim_i = len; dim_i < clen; dim_i++)
 	{
 	  cup = toupper (obj->var_name[dim_i]);
-	  write_character (&cup, 1);
+	  write_character (dtp, &cup, 1, 1);
 	}
-      write_character ("=", 1);
+      write_character (dtp, "=", 1, 1);
     }
 
   /* Counts the number of data output on a line, including names.  */
@@ -1445,21 +1519,36 @@ nml_write_obj (namelist_info * obj, index_type offset,
   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;
+
+  switch (obj->type)
+    {
+
+    case GFC_DTYPE_REAL:
+      obj_size = size_from_real_kind (len);
+      break;
+
+    case GFC_DTYPE_COMPLEX:
+      obj_size = size_from_complex_kind (len);
+      break;
+
+    case GFC_DTYPE_CHARACTER:
+      obj_size = obj->string_length;
+      break;
+
+    default:
+      obj_size = len;      
+    }
+
   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++)
+  for (dim_i = 0; dim_i < (size_t) 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);
+      obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj, dim_i);
+      nelem = nelem * GFC_DESCRIPTOR_EXTENT (obj, dim_i);
     }
 
   /* Main loop to output the data held in the object.  */
@@ -1491,9 +1580,9 @@ nml_write_obj (namelist_info * obj, index_type offset,
 	{
 	  if (rep_ctr > 1)
 	    {
-	      st_sprintf(rep_buff, " %d*", rep_ctr);
-	      write_character (rep_buff, strlen (rep_buff));
-	      no_leading_blank = 1;
+	      sprintf(rep_buff, " %d*", rep_ctr);
+	      write_character (dtp, rep_buff, 1, strlen (rep_buff));
+	      dtp->u.p.no_leading_blank = 1;
 	    }
 	  num++;
 
@@ -1504,29 +1593,31 @@ nml_write_obj (namelist_info * obj, index_type offset,
 	    {
 
 	    case GFC_DTYPE_INTEGER:
-              write_integer (p, len);
+	      write_integer (dtp, p, len);
               break;
 
 	    case GFC_DTYPE_LOGICAL:
-              write_logical (p, len);
+	      write_logical (dtp, p, len);
               break;
 
 	    case GFC_DTYPE_CHARACTER:
-	      if (nml_delim)
-		write_character (nml_delim, 1);
-	      write_character (p, obj->string_length);
-	      if (nml_delim)
-		write_character (nml_delim, 1);
+	      tmp_delim = dtp->u.p.current_unit->delim_status;
+	      if (dtp->u.p.nml_delim == '"')
+		dtp->u.p.current_unit->delim_status = DELIM_QUOTE;
+	      if (dtp->u.p.nml_delim == '\'')
+		dtp->u.p.current_unit->delim_status = DELIM_APOSTROPHE;
+	      write_character (dtp, p, 1, obj->string_length);
+		dtp->u.p.current_unit->delim_status = tmp_delim;
               break;
 
 	    case GFC_DTYPE_REAL:
-              write_real (p, len);
+	      write_real (dtp, p, len);
               break;
 
-	    case GFC_DTYPE_COMPLEX:
-	      no_leading_blank = 0;
+	   case GFC_DTYPE_COMPLEX:
+	      dtp->u.p.no_leading_blank = 0;
 	      num++;
-              write_complex (p, len);
+              write_complex (dtp, p, len, obj_size);
               break;
 
 	    case GFC_DTYPE_DERIVED:
@@ -1541,32 +1632,43 @@ nml_write_obj (namelist_info * obj, index_type offset,
 
 	      /* 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)
+	      base_name_len = base_name ? strlen (base_name) : 0;
+	      base_var_name_len = base ? strlen (base->var_name) : 0;
+	      ext_name = (char*)get_mem ( base_name_len
+					+ base_var_name_len
 					+ strlen (obj->var_name)
 					+ obj->var_rank * NML_DIGITS
 					+ 1);
 
-	      strcpy(ext_name, base_name ? base_name : "");
-	      clen = base ? strlen (base->var_name) : 0;
-	      strcat (ext_name, obj->var_name + clen);
-
+	      memcpy (ext_name, base_name, base_name_len);
+	      clen = strlen (obj->var_name + base_var_name_len);
+	      memcpy (ext_name + base_name_len, 
+		      obj->var_name + base_var_name_len, clen);
+	      
 	      /* Append the qualifier.  */
 
-	      for (dim_i = 0; dim_i < obj->var_rank; dim_i++)
+	      tot_len = base_name_len + clen;
+	      for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++)
 		{
-		  strcat (ext_name, dim_i ? "" : "(");
-		  clen = strlen (ext_name);
-		  st_sprintf (ext_name + clen, "%d", (int) obj->ls[dim_i].idx);
-		  strcat (ext_name, (dim_i == obj->var_rank - 1) ? ")" : ",");
+		  if (!dim_i)
+		    {
+		      ext_name[tot_len] = '(';
+		      tot_len++;
+		    }
+		  sprintf (ext_name + tot_len, "%d", (int) obj->ls[dim_i].idx);
+		  tot_len += strlen (ext_name + tot_len);
+		  ext_name[tot_len] = ((int) dim_i == obj->var_rank - 1) ? ')' : ',';
+		  tot_len++;
 		}
 
+	      ext_name[tot_len] = '\0';
+
 	      /* 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, "%");
+	      memcpy (obj_name, obj->var_name, obj_name_len-1);
+	      memcpy (obj_name + obj_name_len-1, "%", 2);
 
 	      /* Now loop over the components. Update the component pointer
 		 with the return value from nml_write_obj => this loop jumps
@@ -1576,28 +1678,30 @@ nml_write_obj (namelist_info * obj, index_type offset,
 		   cmp && !strncmp (cmp->var_name, obj_name, obj_name_len);
 		   cmp = retval)
 		{
-		  retval = nml_write_obj (cmp, (index_type)(p - obj->mem_pos),
+		  retval = nml_write_obj (dtp, cmp,
+					  (index_type)(p - obj->mem_pos),
 					  obj, ext_name);
 		}
 
-	      free_mem (obj_name);
-	      free_mem (ext_name);
+	      free (obj_name);
+	      free (ext_name);
 	      goto obj_loop;
 
             default:
-              internal_error ("Bad type for namelist write");
+	      internal_error (&dtp->common, "Bad type for namelist write");
             }
 
-	  /* Reset the leading blank suppression, write a comma and, if 5
-	     values have been output, write a newline and advance to column
-	     2. Reset the repeat counter.  */
+	  /* Reset the leading blank suppression, write a comma (or semi-colon)
+	     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);
+	  dtp->u.p.no_leading_blank = 0;
+	  write_character (dtp, &semi_comma, 1, 1);
 	  if (num > 5)
 	    {
 	      num = 0;
-	      write_character ("\n ", 2);
+	      namelist_write_newline (dtp);
+	      write_character (dtp, " ", 1, 1);
 	    }
 	  rep_ctr = 1;
 	}
@@ -1607,13 +1711,13 @@ nml_write_obj (namelist_info * obj, index_type offset,
 obj_loop:
 
     nml_carry = 1;
-    for (dim_i = 0; nml_carry && (dim_i < obj->var_rank); dim_i++)
+    for (dim_i = 0; nml_carry && (dim_i < (size_t) 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)
+ 	if (obj->ls[dim_i].idx  > (ssize_t) GFC_DESCRIPTOR_UBOUND(obj,dim_i))
 	  {
-	    obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
+ 	    obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj,dim_i);
 	    nml_carry = 1;
 	  }
        }
@@ -1624,63 +1728,53 @@ obj_loop:
   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_write (st_parameter_dt *dtp)
 {
   namelist_info * t1, *t2, *dummy = NULL;
   index_type i;
   index_type dummy_offset = 0;
   char c;
   char * dummy_name = NULL;
-  unit_delim tmp_delim;
+  unit_delim tmp_delim = DELIM_UNSPECIFIED;
 
   /* Set the delimiter for namelist output.  */
+  tmp_delim = dtp->u.p.current_unit->delim_status;
 
-  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;
+  dtp->u.p.nml_delim = tmp_delim == DELIM_APOSTROPHE ? '\'' : '"';
 
-    default:
-      nml_delim = NULL;
-    }
+  /* Temporarily disable namelist delimters.  */
+  dtp->u.p.current_unit->delim_status = DELIM_NONE;
 
-  write_character ("&",1);
+  write_character (dtp, "&", 1, 1);
 
   /* Write namelist name in upper case - f95 std.  */
-
-  for (i = 0 ;i < ioparm.namelist_name_len ;i++ )
+  for (i = 0 ;i < dtp->namelist_name_len ;i++ )
     {
-      c = toupper (ioparm.namelist_name[i]);
-      write_character (&c ,1);
-	    }
+      c = toupper (dtp->namelist_name[i]);
+      write_character (dtp, &c, 1 ,1);
+    }
 
-  if (ionml != NULL)
+  if (dtp->u.p.ionml != NULL)
     {
-      t1 = ionml;
+      t1 = dtp->u.p.ionml;
       while (t1 != NULL)
 	{
 	  t2 = t1;
-	  t1 = nml_write_obj (t2, dummy_offset, dummy, dummy_name);
+	  t1 = nml_write_obj (dtp, t2, dummy_offset, dummy, dummy_name);
 	}
     }
-  write_character ("  /\n", 4);
-
-  /* Recover the original delimiter.  */
 
-  current_unit->flags.delim = tmp_delim;
+  namelist_write_newline (dtp);
+  write_character (dtp, " /", 1, 2);
+  /* Restore the original delimiter.  */
+  dtp->u.p.current_unit->delim_status = tmp_delim;
 }
 
 #undef NML_DIGITS