2008-09-01 Basile Starynkevitch <basile@starynkevitch.net>

	MERGED WITH TRUNK rev139820
	* gcc/melt/warmelt-first.bysl: added location argument to inform.
	* gcc/warmelt-first-0.c: regenerated.
	* gcc/warmelt-macro-0.c: regenerated.
	* gcc/warmelt-normal-0.c: regenerated.
	* gcc/warmelt-genobj-0.c: regenerated.
	* gcc/warmelt-outobj-0.c: regenerated.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@139849 138bc75d-0d04-0410-961f-82ee72b054a4

2 files changed, 410 insertions, 123 deletions

diff --git a/libgfortran/io/read.c b/libgfortran/io/read.c
index cb88933bf97..8d25493b2fa 100644
--- a/libgfortran/io/read.c
+++ b/libgfortran/io/read.c
@@ -34,6 +34,8 @@ Boston, MA 02110-1301, USA.  */
 #include <ctype.h>
 #include <stdlib.h>
 
+typedef unsigned char uchar;
+
 /* read.c -- Deal with formatted reads */
 
 
@@ -236,78 +238,239 @@ read_l (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 }
 
 
-/* read_a()-- Read a character record.  This one is pretty easy. */
-
-void
-read_a (st_parameter_dt *dtp, const fnode *f, char *p, int length)
+static inline gfc_char4_t
+read_utf8 (st_parameter_dt *dtp, size_t *nbytes) 
 {
+  static const uchar masks[6] = { 0x7F, 0x1F, 0x0F, 0x07, 0x02, 0x01 };
+  static const uchar patns[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
+  static uchar buffer[6];
+  size_t i, nb, nread;
+  gfc_char4_t c;
+  int status;
   char *s;
-  int m, n, wi, status;
-  size_t w;
 
-  wi = f->u.w;
-  if (wi == -1) /* '(A)' edit descriptor  */
-    wi = length;
+  *nbytes = 1;
+  s = (char *) &buffer[0];
+  status = read_block_form (dtp, s, nbytes);
+  if (status == FAILURE)
+    return 0;
 
-  w = wi;
+  /* If this is a short read, just return.  */
+  if (*nbytes == 0)
+    return 0;
 
-  s = gfc_alloca (w);
+  c = buffer[0];
+  if (c < 0x80)
+    return c;
 
-  dtp->u.p.sf_read_comma = 0;
-  status = read_block_form (dtp, s, &w);
-  dtp->u.p.sf_read_comma =
-    dtp->u.p.decimal_status == DECIMAL_COMMA ? 0 : 1;
+  /* The number of leading 1-bits in the first byte indicates how many
+     bytes follow.  */
+  for (nb = 2; nb < 7; nb++)
+    if ((c & ~masks[nb-1]) == patns[nb-1])
+      goto found;
+  goto invalid;
+	
+ found:
+  c = (c & masks[nb-1]);
+  nread = nb - 1;
+
+  s = (char *) &buffer[1];
+  status = read_block_form (dtp, s, &nread);
+  if (status == FAILURE)
+    return 0;
+  /* Decode the bytes read.  */
+  for (i = 1; i < nb; i++)
+    {
+      gfc_char4_t n = *s++;
+
+      if ((n & 0xC0) != 0x80)
+	goto invalid;
+
+      c = ((c << 6) + (n & 0x3F));
+    }
+
+  /* Make sure the shortest possible encoding was used.  */
+  if (c <=      0x7F && nb > 1) goto invalid;
+  if (c <=     0x7FF && nb > 2) goto invalid;
+  if (c <=    0xFFFF && nb > 3) goto invalid;
+  if (c <=  0x1FFFFF && nb > 4) goto invalid;
+  if (c <= 0x3FFFFFF && nb > 5) goto invalid;
+
+  /* Make sure the character is valid.  */
+  if (c > 0x7FFFFFFF || (c >= 0xD800 && c <= 0xDFFF))
+    goto invalid;
+
+  return c;
+      
+ invalid:
+  generate_error (&dtp->common, LIBERROR_READ_VALUE, "Invalid UTF-8 encoding");
+  return (gfc_char4_t) '?';
+}
+
+
+static void
+read_utf8_char1 (st_parameter_dt *dtp, char *p, int len, size_t width)
+{
+  gfc_char4_t c;
+  char *dest;
+  size_t nbytes;
+  int i, j;
+
+  len = ((int) width < len) ? len : (int) width;
+
+  dest = (char *) p;
+
+  /* Proceed with decoding one character at a time.  */
+  for (j = 0; j < len; j++, dest++)
+    {
+      c = read_utf8 (dtp, &nbytes);
+
+      /* Check for a short read and if so, break out.  */
+      if (nbytes == 0)
+	break;
+
+      *dest = c > 255 ? '?' : (uchar) c;
+    }
+
+  /* If there was a short read, pad the remaining characters.  */
+  for (i = j; i < len; i++)
+    *dest++ = ' ';
+  return;
+}
+
+static void
+read_default_char1 (st_parameter_dt *dtp, char *p, int len, size_t width)
+{
+  char *s;
+  int m, n, status;
+
+  s = gfc_alloca (width);
+
+  status = read_block_form (dtp, s, &width);
+  
   if (status == FAILURE)
     return;
-  if (w > (size_t) length)
-     s += (w - length);
+  if (width > (size_t) len)
+     s += (width - len);
 
-  m = ((int) w > length) ? length : (int) w;
+  m = ((int) width > len) ? len : (int) width;
   memcpy (p, s, m);
 
-  n = length - w;
+  n = len - width;
   if (n > 0)
     memset (p + m, ' ', n);
 }
 
-void
-read_a_char4 (st_parameter_dt *dtp, const fnode *f, char *p, int length)
+
+static void
+read_utf8_char4 (st_parameter_dt *dtp, void *p, int len, size_t width)
 {
-  char *s;
   gfc_char4_t *dest;
-  int m, n, wi, status;
-  size_t w;
+  size_t nbytes;
+  int i, j;
 
-  wi = f->u.w;
-  if (wi == -1) /* '(A)' edit descriptor  */
-    wi = length;
+  len = ((int) width < len) ? len : (int) width;
 
-  w = wi;
+  dest = (gfc_char4_t *) p;
 
-  s = gfc_alloca (w);
+  /* Proceed with decoding one character at a time.  */
+  for (j = 0; j < len; j++, dest++)
+    {
+      *dest = read_utf8 (dtp, &nbytes);
 
-  /* Read in w bytes, treating comma as not a separator.  */
-  dtp->u.p.sf_read_comma = 0;
-  status = read_block_form (dtp, s, &w);
-  dtp->u.p.sf_read_comma =
-    dtp->u.p.decimal_status == DECIMAL_COMMA ? 0 : 1;
+      /* Check for a short read and if so, break out.  */
+      if (nbytes == 0)
+	break;
+    }
+
+  /* If there was a short read, pad the remaining characters.  */
+  for (i = j; i < len; i++)
+    *dest++ = (gfc_char4_t) ' ';
+  return;
+}
+
+
+static void
+read_default_char4 (st_parameter_dt *dtp, char *p, int len, size_t width)
+{
+  char *s;
+  gfc_char4_t *dest;
+  int m, n, status;
+
+  s = gfc_alloca (width);
+
+  status = read_block_form (dtp, s, &width);
   
   if (status == FAILURE)
     return;
-  if (w > (size_t) length)
-     s += (w - length);
+  if (width > (size_t) len)
+     s += (width - len);
 
-  m = ((int) w > length) ? length : (int) w;
+  m = ((int) width > len) ? len : (int) width;
   
   dest = (gfc_char4_t *) p;
   
   for (n = 0; n < m; n++, dest++, s++)
     *dest = (unsigned char ) *s;
 
-  for (n = 0; n < length - (int) w; n++, dest++)
+  for (n = 0; n < len - (int) width; n++, dest++)
     *dest = (unsigned char) ' ';
 }
 
+
+/* read_a()-- Read a character record into a KIND=1 character destination,
+   processing UTF-8 encoding if necessary.  */
+
+void
+read_a (st_parameter_dt *dtp, const fnode *f, char *p, int length)
+{
+  int wi;
+  size_t w;
+
+  wi = f->u.w;
+  if (wi == -1) /* '(A)' edit descriptor  */
+    wi = length;
+  w = wi;
+
+  /* Read in w characters, treating comma as not a separator.  */
+  dtp->u.p.sf_read_comma = 0;
+
+  if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
+    read_utf8_char1 (dtp, p, length, w);
+  else
+    read_default_char1 (dtp, p, length, w);
+  
+  dtp->u.p.sf_read_comma =
+    dtp->u.p.decimal_status == DECIMAL_COMMA ? 0 : 1;
+}
+
+
+/* read_a_char4()-- Read a character record into a KIND=4 character destination,
+   processing UTF-8 encoding if necessary.  */
+
+void
+read_a_char4 (st_parameter_dt *dtp, const fnode *f, char *p, int length)
+{
+  int wi;
+  size_t w;
+
+  wi = f->u.w;
+  if (wi == -1) /* '(A)' edit descriptor  */
+    wi = length;
+  w = wi;
+
+  /* Read in w characters, treating comma as not a separator.  */
+  dtp->u.p.sf_read_comma = 0;
+
+  if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
+    read_utf8_char4 (dtp, p, length, w);
+  else
+    read_default_char4 (dtp, p, length, w);
+  
+  dtp->u.p.sf_read_comma =
+    dtp->u.p.decimal_status == DECIMAL_COMMA ? 0 : 1;
+}
+
 /* eat_leading_spaces()-- Given a character pointer and a width,
  * ignore the leading spaces.  */
 
diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c
index ed50e0d5705..65210bcbe1f 100644
--- a/libgfortran/io/write.c
+++ b/libgfortran/io/write.c
@@ -36,10 +36,161 @@ Boston, MA 02110-1301, USA.  */
 #include <ctype.h>
 #include <stdlib.h>
 #include <stdbool.h>
+#include <errno.h>
 #define star_fill(p, n) memset(p, '*', n)
 
 #include "write_float.def"
 
+typedef unsigned char uchar;
+
+/* Write out default char4.  */
+
+static void
+write_default_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;
+  uchar d;
+      
+  /* Take care of preceding blanks.  */
+  if (w_len > src_len)
+    {
+      k = w_len - src_len;
+      p = write_block (dtp, k);
+      if (p == NULL)
+	return;
+      memset (p, ' ', k);
+    }
+
+  /* Get ready to handle delimiters if needed.  */
+
+  switch (dtp->u.p.delim_status)
+    {
+    case DELIM_APOSTROPHE:
+      d = '\'';
+      break;
+    case DELIM_QUOTE:
+      d = '"';
+      break;
+    default:
+      d = ' ';
+      break;
+    }
+
+  /* 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;
+    }
+}
+
+
+/* Write out UTF-8 converted from char4.  */
+
+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 };
+  size_t nbytes;
+  uchar buf[6], d, *q; 
+
+  /* Take care of preceding blanks.  */
+  if (w_len > src_len)
+    {
+      k = w_len - src_len;
+      p = write_block (dtp, k);
+      if (p == NULL)
+	return;
+      memset (p, ' ', k);
+    }
+
+  /* Get ready to handle delimiters if needed.  */
+
+  switch (dtp->u.p.delim_status)
+    {
+    case DELIM_APOSTROPHE:
+      d = '\'';
+      break;
+    case DELIM_QUOTE:
+      d = '"';
+      break;
+    default:
+      d = ' ';
+      break;
+    }
+
+  /* Now process the remaining characters, one at a time.  */
+  for (j = k; j < src_len; j++)
+    {
+      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
+	{
+	  /* Convert to UTF-8 sequence.  */
+	  nbytes = 1;
+	  q = &buf[6];
+
+	  do
+	    {
+	      *--q = ((c & 0x3F) | 0x80);
+	      c >>= 6;
+	      nbytes++;
+	    }
+	  while (c >= 0x3F || (c & limits[nbytes-1]));
+
+	  *--q = (c | masks[nbytes-1]);
+
+	  p = write_block (dtp, nbytes);
+	  if (p == NULL)
+	    return;
+
+	  while (q < &buf[6])
+	    *p++ = *q++;
+	}
+    }
+}
+
+
 void
 write_a (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
 {
@@ -126,17 +277,16 @@ write_a (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
 
 
 /* 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 take care
-   of endianess.  This currently implements encoding="default" which means we
-   write the lowest significant byte. If the 3 most significant bytes are
-   not representable emit a '?'.  TODO: Implement encoding="UTF-8"
-   which will process all 4 bytes and translate to the encoded output.  */
+   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.  */
 
 void
 write_a_char4 (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
 {
   int wlen;
-  char *p;
   gfc_char4_t *q;
 
   wlen = f->u.string.length < 0
@@ -158,6 +308,7 @@ write_a_char4 (st_parameter_dt *dtp, const fnode *f, const char *source, int len
       /* Write out any padding if needed.  */
       if (len < wlen)
 	{
+	  char *p;
 	  p = write_block (dtp, wlen - len);
 	  if (p == NULL)
 	    return;
@@ -173,19 +324,15 @@ write_a_char4 (st_parameter_dt *dtp, const fnode *f, const char *source, int len
 	      /* Write out the previously scanned characters in the string.  */
 	      if (bytes > 0)
 		{
-		  p = write_block (dtp, bytes);
-		  if (p == NULL)
-		    return;
-		  for (j = 0; j < bytes; j++)
-		    p[j] = q[j] > 255 ? '?' : (unsigned char) q[j];
+		  if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
+		    write_utf8_char4 (dtp, q, bytes, 0);
+		  else
+		    write_default_char4 (dtp, q, bytes, 0);
 		  bytes = 0;
 		}
 
 	      /* Write out the CR_LF sequence.  */ 
-	      p = write_block (dtp, 2);
-              if (p == NULL)
-                return;
-	      memcpy (p, crlf, 2);
+	      write_default_char4 (dtp, crlf, 2, 0);
 	    }
 	  else
 	    bytes++;
@@ -194,32 +341,19 @@ write_a_char4 (st_parameter_dt *dtp, const fnode *f, const char *source, int len
       /*  Write out any remaining bytes if no LF was found.  */
       if (bytes > 0)
 	{
-	  p = write_block (dtp, bytes);
-	  if (p == NULL)
-	    return;
-	  for (j = 0; j < bytes; j++)
-	    p[j] = q[j] > 255 ? '?' : (unsigned char) q[j];
+	  if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
+	    write_utf8_char4 (dtp, q, bytes, 0);
+	  else
+	    write_default_char4 (dtp, q, bytes, 0);
 	}
     }
   else
     {
 #endif
-      int j;
-      p = write_block (dtp, wlen);
-      if (p == NULL)
-	return;
-
-      if (wlen < len)
-	{
-	  for (j = 0; j < wlen; j++)
-	    p[j] = q[j] > 255 ? '?' : (unsigned char) q[j];
-	}
+      if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
+	write_utf8_char4 (dtp, q, len, wlen);
       else
-	{
-	  memset (p, ' ', wlen - len);
-	  for (j = wlen - len; j < wlen; j++)
-	    p[j] = q[j] > 255 ? '?' : (unsigned char) q[j];
-	}
+	write_default_char4 (dtp, q, len, wlen);
 #ifdef HAVE_CRLF
     }
 #endif
@@ -745,8 +879,6 @@ write_character (st_parameter_dt *dtp, const char *source, int kind, int length)
 {
   int i, extra;
   char *p, d;
-  gfc_char4_t *q;
-
 
   switch (dtp->u.p.delim_status)
     {
@@ -769,9 +901,9 @@ write_character (st_parameter_dt *dtp, const char *source, int kind, int length)
 	{
 	  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 (dtp, length + extra);
@@ -796,40 +928,24 @@ write_character (st_parameter_dt *dtp, const char *source, int kind, int length)
     }
   else
     {
-      /* We have to scan the source string looking for delimiters to determine
-	 how large the write block needs to be.  */
-      if (d == ' ')
-	extra = 0;
-      else
-	{
-	  extra = 2;
-
-	  q = (gfc_char4_t *) source;
-	  for (i = 0; i < length; i++, q++)
-	    if (*q == (gfc_char4_t) d)
-	      extra++;
-	}
-
-      p = write_block (dtp, length + extra);
-      if (p == NULL)
-	return;
-
       if (d == ' ')
 	{
-	  q = (gfc_char4_t *) source;
-	  for (i = 0; i < length; i++, q++)
-	    p[i] = *q > 255 ? '?' : (unsigned char) *q;
+	  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++ = d;
-	  q = (gfc_char4_t *) source;
-	  for (i = 0; i < length; i++, q++)
-	    {
-	      *p++ = *q > 255 ? '?' : (unsigned char) *q;
-	      if (*q == (gfc_char4_t) d)
-		*p++ = d;
-	    }
+	  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 = write_block (dtp, 1);
 	  *p = d;
 	}
     }
@@ -1000,6 +1116,22 @@ list_formatted_write (st_parameter_dt *dtp, bt type, void *p, int kind,
 
 #define NML_DIGITS 20
 
+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
+    }
+  else
+    write_character (dtp, " ", 1, 1);
+}
+
+
 static namelist_info *
 nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
 	       namelist_info * base, char * base_name)
@@ -1036,11 +1168,9 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
 
   if (obj->type != GFC_DTYPE_DERIVED)
     {
-#ifdef HAVE_CRLF
-      write_character (dtp, "\r\n ", 1, 3);
-#else
-      write_character (dtp, "\n ", 1, 2);
-#endif
+      namelist_write_newline (dtp);
+      write_character (dtp, " ", 1, 1);
+
       len = 0;
       if (base)
 	{
@@ -1245,11 +1375,8 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
 	  if (num > 5)
 	    {
 	      num = 0;
-#ifdef HAVE_CRLF
-	      write_character (dtp, "\r\n ", 1, 3);
-#else
-	      write_character (dtp, "\n ", 1, 2);
-#endif
+	      namelist_write_newline (dtp);
+	      write_character (dtp, " ", 1, 1);
 	    }
 	  rep_ctr = 1;
 	}
@@ -1276,6 +1403,7 @@ 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
@@ -1331,12 +1459,8 @@ namelist_write (st_parameter_dt *dtp)
 	}
     }
 
-#ifdef HAVE_CRLF
-  write_character (dtp, "  /\r\n", 1, 5);
-#else
-  write_character (dtp, "  /\n", 1, 4);
-#endif
-
+  write_character (dtp, "  /", 1, 3);
+  namelist_write_newline (dtp);
   /* Restore the original delimiter.  */
   dtp->u.p.delim_status = tmp_delim;
 }