OSDN Git Service

(root) / pf3gnuchains / gcc-fork.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
2009-01-12 Jerry DeLisle <jvdelisle@gcc.gnu.org>
[pf3gnuchains/gcc-fork.git] / libgfortran / io / read.c
diff --git a/libgfortran/io/read.c b/libgfortran/io/read.c
index 3ce9f1d..a8ae3d7 100644 (file)
--- a/libgfortran/io/read.c
+++ b/libgfortran/io/read.c
@@ -1,5 +1,6 @@
-/* Copyright (C) 2002-2003 Free Software Foundation, Inc.
+/* Copyright (C) 2002, 2003, 2005, 2007, 2008 Free Software Foundation, Inc.
    Contributed by Andy Vaught
    Contributed by Andy Vaught
+   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 95 runtime library (libgfortran).
 
@@ -8,6 +9,15 @@ it under the terms of the GNU General Public License as published by
 the Free Software Foundation; either version 2, or (at your option)
 any later version.
 
 the Free Software Foundation; either version 2, 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
 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
@@ -15,43 +25,62 @@ 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
 
 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.  */
-
+the Free Software Foundation, 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA.  */
 
 
-#include "config.h"
+#include "io.h"
 #include <string.h>
 #include <errno.h>
 #include <ctype.h>
 #include <stdlib.h>
 #include <string.h>
 #include <errno.h>
 #include <ctype.h>
 #include <stdlib.h>
-#include "libgfortran.h"
-#include "io.h"
+
+typedef unsigned char uchar;
 
 /* read.c -- Deal with formatted reads */
 
 
 /* read.c -- Deal with formatted reads */
 
+
 /* set_integer()-- All of the integer assignments come here to
  * actually place the value into memory.  */
 
 void
 /* set_integer()-- All of the integer assignments come here to
  * actually place the value into memory.  */
 
 void
-set_integer (void *dest, int64_t value, int length)
+set_integer (void *dest, GFC_INTEGER_LARGEST value, int length)
 {
 {
-
   switch (length)
     {
   switch (length)
     {
+#ifdef HAVE_GFC_INTEGER_16
+    case 16:
+      {
+       GFC_INTEGER_16 tmp = value;
+       memcpy (dest, (void *) &tmp, length);
+      }
+      break;
+#endif
     case 8:
     case 8:
-      *((int64_t *) dest) = value;
+      {
+       GFC_INTEGER_8 tmp = value;
+       memcpy (dest, (void *) &tmp, length);
+      }
       break;
     case 4:
       break;
     case 4:
-      *((int32_t *) dest) = value;
+      {
+       GFC_INTEGER_4 tmp = value;
+       memcpy (dest, (void *) &tmp, length);
+      }
       break;
     case 2:
       break;
     case 2:
-      *((int16_t *) dest) = value;
+      {
+       GFC_INTEGER_2 tmp = value;
+       memcpy (dest, (void *) &tmp, length);
+      }
       break;
     case 1:
       break;
     case 1:
-      *((int8_t *) dest) = value;
+      {
+       GFC_INTEGER_1 tmp = value;
+       memcpy (dest, (void *) &tmp, length);
+      }
       break;
     default:
       break;
     default:
-      internal_error ("Bad integer kind");
+      internal_error (NULL, "Bad integer kind");
     }
 }
 
     }
 }
 
@@ -59,13 +88,26 @@ set_integer (void *dest, int64_t value, int length)
 /* max_value()-- Given a length (kind), return the maximum signed or
  * unsigned value */
 
 /* max_value()-- Given a length (kind), return the maximum signed or
  * unsigned value */
 
-uint64_t
+GFC_UINTEGER_LARGEST
 max_value (int length, int signed_flag)
 {
 max_value (int length, int signed_flag)
 {
-  uint64_t value;
+  GFC_UINTEGER_LARGEST value;
+#if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
+  int n;
+#endif
 
   switch (length)
     {
 
   switch (length)
     {
+#if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
+    case 16:
+    case 10:
+      value = 1;
+      for (n = 1; n < 4 * length; n++)
+        value = (value << 2) + 3;
+      if (! signed_flag)
+        value = 2*value+1;
+      break;
+#endif
     case 8:
       value = signed_flag ? 0x7fffffffffffffff : 0xffffffffffffffff;
       break;
     case 8:
       value = signed_flag ? 0x7fffffffffffffff : 0xffffffffffffffff;
       break;
@@ -79,7 +121,7 @@ max_value (int length, int signed_flag)
       value = signed_flag ? 0x7f : 0xff;
       break;
     default:
       value = signed_flag ? 0x7f : 0xff;
       break;
     default:
-      internal_error ("Bad integer kind");
+      internal_error (NULL, "Bad integer kind");
     }
 
   return value;
     }
 
   return value;
@@ -89,157 +131,77 @@ max_value (int length, int signed_flag)
 /* convert_real()-- Convert a character representation of a floating
  * point number to the machine number.  Returns nonzero if there is a
  * range problem during conversion.  TODO: handle not-a-numbers and
 /* convert_real()-- Convert a character representation of a floating
  * point number to the machine number.  Returns nonzero if there is a
  * range problem during conversion.  TODO: handle not-a-numbers and
- * infinities.  Handling of kind 4 is probably wrong because of double
- * rounding. */
+ * infinities.  */
 
 int
 
 int
-convert_real (void *dest, const char *buffer, int length)
+convert_real (st_parameter_dt *dtp, void *dest, const char *buffer, int length)
 {
 {
-
   errno = 0;
 
   switch (length)
     {
     case 4:
   errno = 0;
 
   switch (length)
     {
     case 4:
-      *((float *) dest) = (float) strtod (buffer, NULL);
+      {
+       GFC_REAL_4 tmp =
+#if defined(HAVE_STRTOF)
+         strtof (buffer, NULL);
+#else
+         (GFC_REAL_4) strtod (buffer, NULL);
+#endif
+       memcpy (dest, (void *) &tmp, length);
+      }
       break;
     case 8:
       break;
     case 8:
-      *((double *) dest) = strtod (buffer, NULL);
+      {
+       GFC_REAL_8 tmp = strtod (buffer, NULL);
+       memcpy (dest, (void *) &tmp, length);
+      }
+      break;
+#if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD)
+    case 10:
+      {
+       GFC_REAL_10 tmp = strtold (buffer, NULL);
+       memcpy (dest, (void *) &tmp, length);
+      }
       break;
       break;
+#endif
+#if defined(HAVE_GFC_REAL_16) && defined (HAVE_STRTOLD)
+    case 16:
+      {
+       GFC_REAL_16 tmp = strtold (buffer, NULL);
+       memcpy (dest, (void *) &tmp, length);
+      }
+      break;
+#endif
     default:
     default:
-      internal_error ("Bad real number kind");
+      internal_error (&dtp->common, "Unsupported real kind during IO");
     }
 
     }
 
-  if (errno != 0)
+  if (errno == EINVAL)
     {
     {
-      generate_error (ERROR_READ_VALUE,
-                     "Range error during floating point read");
+      generate_error (&dtp->common, LIBERROR_READ_VALUE,
+                     "Error during floating point read");
+      next_record (dtp, 1);
       return 1;
     }
 
   return 0;
 }
 
       return 1;
     }
 
   return 0;
 }
 
-static int
-convert_precision_real (void *dest, int sign,
-                       char *buffer, int length, int exponent)
-{
-  int w, new_dp_pos, i, slen, k, dp;
-  char * p, c;
-  double fval;
-  float tf;
-
-  fval =0.0;
-  tf = 0.0;
-  dp = 0;
-  new_dp_pos = 0;
-
-  slen = strlen (buffer);
-  w = slen;
-  p = buffer;
-
-/*  for (i = w - 1; i > 0; i --)
-    {
-       if (buffer[i] == '0' || buffer[i] == 0)
-         buffer[i] = 0;
-       else
-         break;
-    }
-*/
-  for (i = 0; i < w; i++)
-    {
-       if (buffer[i] == '.')
-         break;
-    }
-
-  new_dp_pos = i;
-  new_dp_pos += exponent;
-
-  while (w > 0)
-    {
-      c = *p;
-      switch (c)
-        {
-        case '0':
-        case '1':
-        case '2':
-        case '3':
-        case '4':
-        case '5':
-        case '6':
-        case '7':
-        case '8':
-        case '9':
-          fval = fval * 10.0 + c - '0';
-          p++;
-          w--;
-          break;
-
-        case '.':
-          dp = 1;
-          p++;
-          w--;
-          break;
-
-       default:
-          p++;
-          w--;
-          break;
-     }
-  }
-
-  if (sign)
-    fval = - fval;
-
-  i = new_dp_pos - slen + dp;
-  k = abs(i);
-  tf = 1.0;
-
-  while (k > 0)
-    {
-       tf *= 10.0 ;
-       k -- ;
-    }
-
-  if (fval != 0.0)
-    {
-       if (i < 0)
-         {
-           fval = fval / tf;
-         }
-        else
-         {
-           fval = fval * tf;
-         }
-    }
-
-  switch (length)
-    {
-    case 4:
-      *((float *) dest) = (float)fval;
-      break;
-    case 8:
-      *((double *) dest) = fval;
-      break;
-    default:
-      internal_error ("Bad real number kind");
-    }
-
-  return 0;
-}
-
 
 /* read_l()-- Read a logical value */
 
 void
 
 /* read_l()-- Read a logical value */
 
 void
-read_l (fnode * f, char *dest, int length)
+read_l (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 {
   char *p;
 {
   char *p;
-  int w;
+  size_t w;
 
   w = f->u.w;
 
   w = f->u.w;
-  p = read_block (&w);
-  if (p == NULL)
+
+  p = gfc_alloca (w);
+
+  if (read_block_form (dtp, p, &w) == FAILURE)
     return;
 
   while (*p == ' ')
     return;
 
   while (*p == ' ')
@@ -260,54 +222,261 @@ read_l (fnode * f, char *dest, int length)
     {
     case 't':
     case 'T':
     {
     case 't':
     case 'T':
-      set_integer (dest, 1, length);
+      set_integer (dest, (GFC_INTEGER_LARGEST) 1, length);
       break;
     case 'f':
     case 'F':
       break;
     case 'f':
     case 'F':
-      set_integer (dest, 0, length);
+      set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
       break;
     default:
     bad:
       break;
     default:
     bad:
-      generate_error (ERROR_READ_VALUE, "Bad value on logical read");
+      generate_error (&dtp->common, LIBERROR_READ_VALUE,
+                     "Bad value on logical read");
+      next_record (dtp, 1);
       break;
     }
 }
 
 
       break;
     }
 }
 
 
-/* read_a()-- Read a character record.  This one is pretty easy. */
+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;
+
+  *nbytes = 1;
+  s = (char *) &buffer[0];
+  status = read_block_form (dtp, s, nbytes);
+  if (status == FAILURE)
+    return 0;
+
+  /* If this is a short read, just return.  */
+  if (*nbytes == 0)
+    return 0;
+
+  c = buffer[0];
+  if (c < 0x80)
+    return c;
 
 
-void
-read_a (fnode * f, char *p, int length)
+  /* 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)
 {
 {
-  char *source;
-  int w, m, n;
+  gfc_char4_t c;
+  char *dest;
+  size_t nbytes;
+  int i, j;
 
 
-  w = f->u.w;
-  if (w == -1) /* '(A)' edit descriptor  */
-    w = length;
+  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;
+    }
 
 
-  source = read_block (&w);
-  if (source == NULL)
+  /* 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;
     return;
-  if (w > length)
-     source += (w - length);
+  if (width > (size_t) len)
+     s += (width - len);
 
 
-  m = (w > length) ? length : w;
-  memcpy (p, source, m);
+  m = ((int) width > len) ? len : (int) width;
+  memcpy (p, s, m);
 
 
-  n = length - w;
+  n = len - width;
   if (n > 0)
     memset (p + m, ' ', n);
 }
 
 
   if (n > 0)
     memset (p + m, ' ', n);
 }
 
 
+static void
+read_utf8_char4 (st_parameter_dt *dtp, void *p, int len, size_t width)
+{
+  gfc_char4_t *dest;
+  size_t nbytes;
+  int i, j;
+
+  len = ((int) width < len) ? len : (int) width;
+
+  dest = (gfc_char4_t *) p;
+
+  /* Proceed with decoding one character at a time.  */
+  for (j = 0; j < len; j++, dest++)
+    {
+      *dest = read_utf8 (dtp, &nbytes);
+
+      /* 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 (width > (size_t) len)
+     s += (width - len);
+
+  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 < 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.current_unit->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.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
+}
+
 /* eat_leading_spaces()-- Given a character pointer and a width,
  * ignore the leading spaces.  */
 
 static char *
 eat_leading_spaces (int *width, char *p)
 {
 /* eat_leading_spaces()-- Given a character pointer and a width,
  * ignore the leading spaces.  */
 
 static char *
 eat_leading_spaces (int *width, char *p)
 {
-
   for (;;)
     {
       if (*width == 0 || *p != ' ')
   for (;;)
     {
       if (*width == 0 || *p != ' ')
@@ -322,7 +491,7 @@ eat_leading_spaces (int *width, char *p)
 
 
 static char
 
 
 static char
-next_char (char **p, int *w)
+next_char (st_parameter_dt *dtp, char **p, int *w)
 {
   char c, *q;
 
 {
   char c, *q;
 
@@ -337,8 +506,8 @@ next_char (char **p, int *w)
 
   if (c != ' ')
     return c;
 
   if (c != ' ')
     return c;
-  if (g.blank_status == BLANK_ZERO)
-    return '0';
+  if (dtp->u.p.blank_status != BLANK_UNSPECIFIED)
+    return ' ';  /* return a blank to signal a null */ 
 
   /* At this point, the rest of the field has to be trailing blanks */
 
 
   /* At this point, the rest of the field has to be trailing blanks */
 
@@ -358,21 +527,27 @@ next_char (char **p, int *w)
  * signed values. */
 
 void
  * signed values. */
 
 void
-read_decimal (fnode * f, char *dest, int length)
+read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 {
 {
-  unsigned value, maxv, maxv_10;
-  int v, w, negative;
+  GFC_UINTEGER_LARGEST value, maxv, maxv_10;
+  GFC_INTEGER_LARGEST v;
+  int w, negative; 
+  size_t wu;
   char c, *p;
 
   char c, *p;
 
-  w = f->u.w;
-  p = read_block (&w);
-  if (p == NULL)
+  wu = f->u.w;
+
+  p = gfc_alloca (wu);
+
+  if (read_block_form (dtp, p, &wu) == FAILURE)
     return;
 
     return;
 
+  w = wu;
+
   p = eat_leading_spaces (&w, p);
   if (w == 0)
     {
   p = eat_leading_spaces (&w, p);
   if (w == 0)
     {
-      set_integer (dest, 0, length);
+      set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
       return;
     }
 
       return;
     }
 
@@ -403,39 +578,48 @@ read_decimal (fnode * f, char *dest, int length)
 
   for (;;)
     {
 
   for (;;)
     {
-      c = next_char (&p, &w);
+      c = next_char (dtp, &p, &w);
       if (c == '\0')
        break;
       if (c == '\0')
        break;
-
+       
+      if (c == ' ')
+        {
+         if (dtp->u.p.blank_status == BLANK_NULL) continue;
+         if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
+        }
+        
       if (c < '0' || c > '9')
        goto bad;
 
       if (c < '0' || c > '9')
        goto bad;
 
-      if (value > maxv_10)
+      if (value > maxv_10 && compile_options.range_check == 1)
        goto overflow;
 
       c -= '0';
       value = 10 * value;
 
        goto overflow;
 
       c -= '0';
       value = 10 * value;
 
-      if (value > maxv - c)
+      if (value > maxv - c && compile_options.range_check == 1)
        goto overflow;
       value += c;
     }
 
        goto overflow;
       value += c;
     }
 
-  v = (signed int) value;
+  v = value;
   if (negative)
     v = -v;
 
   set_integer (dest, v, length);
   return;
 
   if (negative)
     v = -v;
 
   set_integer (dest, v, length);
   return;
 
-bad:
-  generate_error (ERROR_READ_VALUE, "Bad value during integer read");
+ bad:
+  generate_error (&dtp->common, LIBERROR_READ_VALUE,
+                 "Bad value during integer read");
+  next_record (dtp, 1);
   return;
 
   return;
 
-overflow:
-  generate_error (ERROR_READ_OVERFLOW,
+ overflow:
+  generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
                  "Value overflowed during integer read");
                  "Value overflowed during integer read");
-  return;
+  next_record (dtp, 1);
+
 }
 
 
 }
 
 
@@ -445,21 +629,28 @@ overflow:
  * the top bit is set, the value will be incorrect. */
 
 void
  * the top bit is set, the value will be incorrect. */
 
 void
-read_radix (fnode * f, char *dest, int length, int radix)
+read_radix (st_parameter_dt *dtp, const fnode *f, char *dest, int length,
+           int radix)
 {
 {
-  unsigned value, maxv, maxv_r;
-  int v, w, negative;
+  GFC_UINTEGER_LARGEST value, maxv, maxv_r;
+  GFC_INTEGER_LARGEST v;
+  int w, negative;
   char c, *p;
   char c, *p;
+  size_t wu;
 
 
-  w = f->u.w;
-  p = read_block (&w);
-  if (p == NULL)
+  wu = f->u.w;
+
+  p = gfc_alloca (wu);
+
+  if (read_block_form (dtp, p, &wu) == FAILURE)
     return;
 
     return;
 
+  w = wu;
+
   p = eat_leading_spaces (&w, p);
   if (w == 0)
     {
   p = eat_leading_spaces (&w, p);
   if (w == 0)
     {
-      set_integer (dest, 0, length);
+      set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
       return;
     }
 
       return;
     }
 
@@ -490,9 +681,14 @@ read_radix (fnode * f, char *dest, int length, int radix)
 
   for (;;)
     {
 
   for (;;)
     {
-      c = next_char (&p, &w);
+      c = next_char (dtp, &p, &w);
       if (c == '\0')
        break;
       if (c == '\0')
        break;
+      if (c == ' ')
+        {
+         if (dtp->u.p.blank_status == BLANK_NULL) continue;
+         if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
+        }
 
       switch (radix)
        {
 
       switch (radix)
        {
@@ -526,6 +722,7 @@ read_radix (fnode * f, char *dest, int length, int radix)
            case 'c':
            case 'd':
            case 'e':
            case 'c':
            case 'd':
            case 'e':
+           case 'f':
              c = c - 'a' + '9' + 1;
              break;
 
              c = c - 'a' + '9' + 1;
              break;
 
@@ -534,6 +731,7 @@ read_radix (fnode * f, char *dest, int length, int radix)
            case 'C':
            case 'D':
            case 'E':
            case 'C':
            case 'D':
            case 'E':
+           case 'F':
              c = c - 'A' + '9' + 1;
              break;
 
              c = c - 'A' + '9' + 1;
              break;
 
@@ -555,93 +753,105 @@ read_radix (fnode * f, char *dest, int length, int radix)
       value += c;
     }
 
       value += c;
     }
 
-  v = (signed int) value;
+  v = value;
   if (negative)
     v = -v;
 
   set_integer (dest, v, length);
   return;
 
   if (negative)
     v = -v;
 
   set_integer (dest, v, length);
   return;
 
-bad:
-  generate_error (ERROR_READ_VALUE, "Bad value during integer read");
+ bad:
+  generate_error (&dtp->common, LIBERROR_READ_VALUE,
+                 "Bad value during integer read");
+  next_record (dtp, 1);
   return;
 
   return;
 
-overflow:
-  generate_error (ERROR_READ_OVERFLOW,
+ overflow:
+  generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
                  "Value overflowed during integer read");
                  "Value overflowed during integer read");
-  return;
+  next_record (dtp, 1);
+
 }
 
 
 /* read_f()-- Read a floating point number with F-style editing, which
 }
 
 
 /* read_f()-- Read a floating point number with F-style editing, which
- * is what all of the other floating point descriptors behave as.  The
- * tricky part is that optional spaces are allowed after an E or D,
- * and the implicit decimal point if a decimal point is not present in
- * the input. */
+   is what all of the other floating point descriptors behave as.  The
+   tricky part is that optional spaces are allowed after an E or D,
+   and the implicit decimal point if a decimal point is not present in
+   the input.  */
 
 void
 
 void
-read_f (fnode * f, char *dest, int length)
+read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 {
 {
+  size_t wu;
   int w, seen_dp, exponent;
   int exponent_sign, val_sign;
   int w, seen_dp, exponent;
   int exponent_sign, val_sign;
-  char *p, *buffer, *n;
-
-  val_sign = 0;
+  int ndigits;
+  int edigits;
+  int i;
+  char *p, *buffer;
+  char *digits;
+  char scratch[SCRATCH_SIZE];
+
+  val_sign = 1;
   seen_dp = 0;
   seen_dp = 0;
-  w = f->u.w;
-  p = read_block (&w);
-  if (p == NULL)
-    return;
-
-  p = eat_leading_spaces (&w, p);
-  if (w == 0)
-    {
-      switch (length)
-       {
-       case 4:
-         *((float *) dest) = 0.0;
-         break;
-
-       case 8:
-         *((double *) dest) = 0.0;
-         break;
-       }
+  wu = f->u.w;
 
 
-      return;
-    }
+  p = gfc_alloca (wu);
 
 
-  if (w + 2 < SCRATCH_SIZE)
-    buffer = scratch;
-  else
-    buffer = get_mem (w + 2);
+  if (read_block_form (dtp, p, &wu) == FAILURE)
+    return;
 
 
-  memset(buffer, 0, w + 2);
+  w = wu;
 
 
-  n = buffer;
+  p = eat_leading_spaces (&w, p);
+  if (w == 0)
+    goto zero;
 
   /* Optional sign */
 
   if (*p == '-' || *p == '+')
     {
       if (*p == '-')
 
   /* Optional sign */
 
   if (*p == '-' || *p == '+')
     {
       if (*p == '-')
-        val_sign = 1;
+        val_sign = -1;
       p++;
       p++;
-
-      if (--w == 0)
-       goto bad_float;
+      w--;
     }
 
   exponent_sign = 1;
     }
 
   exponent_sign = 1;
+  p = eat_leading_spaces (&w, p);
+  if (w == 0)
+    goto zero;
 
 
-  /* A digit (or a '.') is required at this point */
+  /* A digit, a '.' or a exponent character ('e', 'E', 'd' or 'D')
+     is required at this point */
 
 
-  if (!isdigit (*p) && *p != '.')
+  if (!isdigit (*p) && *p != '.' && *p != ',' && *p != 'd' && *p != 'D'
+      && *p != 'e' && *p != 'E')
     goto bad_float;
 
     goto bad_float;
 
+  /* Remember the position of the first digit.  */
+  digits = p;
+  ndigits = 0;
+
+  /* Scan through the string to find the exponent.  */
   while (w > 0)
     {
       switch (*p)
        {
   while (w > 0)
     {
       switch (*p)
        {
+       case ',':
+         if (dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA
+               && *p == ',')
+           *p = '.';
+         else
+           goto bad_float;
+         /* Fall through */
+       case '.':
+         if (seen_dp)
+           goto bad_float;
+         seen_dp = 1;
+         /* Fall through */
+
        case '0':
        case '1':
        case '2':
        case '0':
        case '1':
        case '2':
@@ -652,22 +862,8 @@ read_f (fnode * f, char *dest, int length)
        case '7':
        case '8':
        case '9':
        case '7':
        case '8':
        case '9':
-         *n++ = *p++;
-         w--;
-         break;
-
-       case '.':
-         if (seen_dp)
-           goto bad_float;
-         seen_dp = 1;
-
-         *n++ = *p++;
-         w--;
-         break;
-
        case ' ':
        case ' ':
-         if (g.blank_status == BLANK_ZERO)
-           *n++ = '0';
+         ndigits++;
          p++;
          w--;
          break;
          p++;
          w--;
          break;
@@ -694,20 +890,47 @@ read_f (fnode * f, char *dest, int length)
        }
     }
 
        }
     }
 
-/* No exponent has been seen, so we use the current scale factor */
-
-  exponent = -g.scale_factor;
+  /* No exponent has been seen, so we use the current scale factor */
+  exponent = -dtp->u.p.scale_factor;
   goto done;
 
   goto done;
 
-bad_float:
-  generate_error (ERROR_READ_VALUE, "Bad value during floating point read");
-  if (buffer != scratch)
-     free_mem (buffer);
+ bad_float:
+  generate_error (&dtp->common, LIBERROR_READ_VALUE,
+                 "Bad value during floating point read");
+  next_record (dtp, 1);
   return;
 
   return;
 
-/* At this point the start of an exponent has been found */
+  /* The value read is zero */
+ zero:
+  switch (length)
+    {
+      case 4:
+       *((GFC_REAL_4 *) dest) = 0;
+       break;
+
+      case 8:
+       *((GFC_REAL_8 *) dest) = 0;
+       break;
+
+#ifdef HAVE_GFC_REAL_10
+      case 10:
+       *((GFC_REAL_10 *) dest) = 0;
+       break;
+#endif
+
+#ifdef HAVE_GFC_REAL_16
+      case 16:
+       *((GFC_REAL_16 *) dest) = 0;
+       break;
+#endif
+
+      default:
+       internal_error (&dtp->common, "Unsupported real kind during IO");
+    }
+  return;
 
 
-exp1:
+  /* At this point the start of an exponent has been found */
+ exp1:
   while (w > 0 && *p == ' ')
     {
       w--;
   while (w > 0 && *p == ' ')
     {
       w--;
@@ -729,54 +952,117 @@ exp1:
   if (w == 0)
     goto bad_float;
 
   if (w == 0)
     goto bad_float;
 
-/* At this point a digit string is required.  We calculate the value
- * of the exponent in order to take account of the scale factor and
- * the d parameter before explict conversion takes place. */
+  /* At this point a digit string is required.  We calculate the value
+     of the exponent in order to take account of the scale factor and
+     the d parameter before explict conversion takes place. */
+ exp2:
+  /* Normal processing of exponent */
+  exponent = 0;
+  if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
+    {
+      while (w > 0 && isdigit (*p))
+        {
+          exponent = 10 * exponent + *p - '0';
+          p++;
+          w--;
+        }
+        
+      /* Only allow trailing blanks */
 
 
-exp2:
-  if (!isdigit (*p))
-    goto bad_float;
+      while (w > 0)
+        {
+          if (*p != ' ')
+           goto bad_float;
+          p++;
+          w--;
+        }
+    }    
+  else  /* BZ or BN status is enabled */
+    {
+      while (w > 0)
+        {
+          if (*p == ' ')
+            {
+             if (dtp->u.p.blank_status == BLANK_ZERO) *p = '0';
+             if (dtp->u.p.blank_status == BLANK_NULL)
+                {
+                  p++;
+                  w--;
+                  continue;
+                }
+            }
+          else if (!isdigit (*p))
+            goto bad_float;
+
+          exponent = 10 * exponent + *p - '0';
+          p++;
+          w--;
+        }
+    }
 
 
-  exponent = *p - '0';
-  p++;
-  w--;
+  exponent = exponent * exponent_sign;
 
 
-  while (w > 0 && isdigit (*p))
-    {
-      exponent = 10 * exponent + *p - '0';
-      if (exponent > 999999)
-       goto bad_float;
+ done:
+  /* Use the precision specified in the format if no decimal point has been
+     seen.  */
+  if (!seen_dp)
+    exponent -= f->u.real.d;
 
 
-      p++;
-      w--;
+  if (exponent > 0)
+    {
+      edigits = 2;
+      i = exponent;
+    }
+  else
+    {
+      edigits = 3;
+      i = -exponent;
     }
 
     }
 
-  /* Only allow trailing blanks */
-
-  while (w > 0)
+  while (i >= 10)
     {
     {
-      if (*p != ' ')
-       goto bad_float;
-      p++;
-      w--;
+      i /= 10;
+      edigits++;
     }
 
     }
 
-  exponent = exponent * exponent_sign;
+  i = ndigits + edigits + 1;
+  if (val_sign < 0)
+    i++;
 
 
-done:
-  if (!seen_dp)
-    exponent -= f->u.real.d;
+  if (i < SCRATCH_SIZE) 
+    buffer = scratch;
+  else
+    buffer = get_mem (i);
 
 
-  /* The number is syntactically correct and ready for conversion.
-   * The only thing that can go wrong at this point is overflow or
-   * underflow. */
+  /* Reformat the string into a temporary buffer.  As we're using atof it's
+     easiest to just leave the decimal point in place.  */
+  p = buffer;
+  if (val_sign < 0)
+    *(p++) = '-';
+  for (; ndigits > 0; ndigits--)
+    {
+      if (*digits == ' ')
+        {
+         if (dtp->u.p.blank_status == BLANK_ZERO) *digits = '0';
+         if (dtp->u.p.blank_status == BLANK_NULL)
+            {
+              digits++;
+              continue;
+            } 
+        }
+      *p = *digits;
+      p++;
+      digits++;
+    }
+  *(p++) = 'e';
+  sprintf (p, "%d", exponent);
 
 
-  convert_precision_real (dest, val_sign, buffer, length, exponent);
+  /* Do the actual conversion.  */
+  convert_real (dtp, dest, buffer, length);
 
   if (buffer != scratch)
      free_mem (buffer);
 
 
   if (buffer != scratch)
      free_mem (buffer);
 
-  return;
 }
 
 
 }
 
 
@@ -784,10 +1070,16 @@ done:
  * and never look at it. */
 
 void
  * and never look at it. */
 
 void
-read_x (fnode * f)
+read_x (st_parameter_dt * dtp, int n)
 {
 {
-  int n;
+  if ((dtp->u.p.current_unit->pad_status == PAD_NO || is_internal_unit (dtp))
+       && dtp->u.p.current_unit->bytes_left < n)
+    n = dtp->u.p.current_unit->bytes_left;
 
 
-  n = f->u.n;
-  read_block (&n);
+  dtp->u.p.sf_read_comma = 0;
+  if (n > 0)
+    read_sf (dtp, &n, 1);
+  dtp->u.p.sf_read_comma = 1;
+  dtp->u.p.current_unit->strm_pos += (gfc_offset) n;
 }
 }
+
About OSDN
Find Software
Develop Software
Help