OSDN Git Service

2009-09-28 Jerry DeLisle <jvdelisle@gcc.gnu.org>
authorjvdelisle <jvdelisle@138bc75d-0d04-0410-961f-82ee72b054a4>
Tue, 29 Sep 2009 02:47:54 +0000 (02:47 +0000)
committerjvdelisle <jvdelisle@138bc75d-0d04-0410-961f-82ee72b054a4>
Tue, 29 Sep 2009 02:47:54 +0000 (02:47 +0000)
PR libgfortran/35862
* io.h (gfc_unit): Add round_status.
(format_token): Add enumerators for rounding format specifiers.
* transfer.c (round_opt): New options table.
(formatted_transfer_scalar_read): Add set round_status for each rounding
format token. (formatted_transfer_scalar_write): Likewise.
* format.c (format_lex): Tokenize the rounding format specifiers.
(parse_format_list): Parse the rounding format specifiers.
* write_float.def (outout_float): Modify rounding code to use new
variable rchar to set the appropriate rounding. Fix some whitespace.
* unit.c (get_internal_unit): Initialize rounding mode for internal
units. (init_units): Likewise.

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

libgfortran/ChangeLog
libgfortran/io/format.c
libgfortran/io/io.h
libgfortran/io/transfer.c
libgfortran/io/unit.c
libgfortran/io/write_float.def

index ab6348b..2530bf7 100644 (file)
@@ -1,3 +1,18 @@
+2009-09-28  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+       PR libgfortran/35862
+       * io.h (gfc_unit): Add round_status.
+       (format_token): Add enumerators for rounding format specifiers.
+       * transfer.c (round_opt): New options table.
+       (formatted_transfer_scalar_read): Add set round_status for each rounding
+       format token. (formatted_transfer_scalar_write): Likewise.
+       * format.c (format_lex): Tokenize the rounding format specifiers.
+       (parse_format_list): Parse the rounding format specifiers.
+       * write_float.def (outout_float): Modify rounding code to use new
+       variable rchar to set the appropriate rounding. Fix some whitespace.
+       * unit.c (get_internal_unit): Initialize rounding mode for internal
+       units. (init_units): Likewise.
+
 2009-09-19  Iain Sandoe  <iain.sandoe@sandoe-acoustics.co.uk>
 
        * configure.ac: Check for GFORTRAN_C99_1.1 funcs in OS libm.
index e888a2e..4ab70e8 100644 (file)
@@ -564,6 +564,34 @@ format_lex (format_data *fmt)
        }
       break;
 
+    case 'R':
+      switch (next_char (fmt, 0))
+       {
+       case 'C':
+         token = FMT_RC;
+         break;
+       case 'D':
+         token = FMT_RD;
+         break;
+       case 'N':
+         token = FMT_RN;
+         break;
+       case 'P':
+         token = FMT_RP;
+         break;
+       case 'U':
+         token = FMT_RU;
+         break;
+       case 'Z':
+         token = FMT_RZ;
+         break;
+       default:
+         unget_char (fmt);
+         token = FMT_UNKNOWN;
+         break;
+       }
+      break;
+
     case -1:
       token = FMT_END;
       break;
@@ -713,6 +741,18 @@ parse_format_list (st_parameter_dt *dtp, bool *save_ok)
       tail->u.string.length = fmt->value;
       tail->repeat = 1;
       goto optional_comma;
+      
+    case FMT_RC:
+    case FMT_RD:
+    case FMT_RN:
+    case FMT_RP:
+    case FMT_RU:
+    case FMT_RZ:
+      notify_std (&dtp->common, GFC_STD_F2003, "Fortran 2003: Round "
+                 "descriptor not allowed");
+      get_fnode (fmt, &head, &tail, t);
+      tail->repeat = 1;
+      goto between_desc;
 
     case FMT_DC:
     case FMT_DP:
index 9ca6d38..51143f5 100644 (file)
@@ -602,6 +602,7 @@ typedef struct gfc_unit
   unit_pad pad_status;
   unit_decimal decimal_status;
   unit_delim delim_status;
+  unit_round round_status;
 
   /* recl                 -- Record length of the file.
      last_record          -- Last record number read or written
@@ -654,7 +655,7 @@ typedef enum
   FMT_LPAREN, FMT_RPAREN, FMT_X, FMT_S, FMT_SS, FMT_SP, FMT_STRING,
   FMT_BADSTRING, FMT_P, FMT_I, FMT_B, FMT_BN, FMT_BZ, FMT_O, FMT_Z, FMT_F,
   FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, FMT_DC,
-  FMT_DP, FMT_STAR
+  FMT_DP, FMT_STAR, FMT_RC, FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ
 }
 format_token;
 
index 4525bb4..06a1d2e 100644 (file)
@@ -101,6 +101,16 @@ static const st_option decimal_opt[] = {
   {NULL, 0}
 };
 
+static const st_option round_opt[] = {
+  {"up", ROUND_UP},
+  {"down", ROUND_DOWN},
+  {"zero", ROUND_ZERO},
+  {"nearest", ROUND_NEAREST},
+  {"compatible", ROUND_COMPATIBLE},
+  {"processor_defined", ROUND_PROCDEFINED},
+  {NULL, 0}
+};
+
 
 static const st_option sign_opt[] = {
   {"plus", SIGN_SP},
@@ -1202,6 +1212,36 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind
          consume_data_flag = 0;
          dtp->u.p.current_unit->decimal_status = DECIMAL_POINT;
          break;
+       
+       case FMT_RC:
+         consume_data_flag = 0;
+         dtp->u.p.current_unit->round_status = ROUND_COMPATIBLE;
+         break;
+
+       case FMT_RD:
+         consume_data_flag = 0;
+         dtp->u.p.current_unit->round_status = ROUND_DOWN;
+         break;
+
+       case FMT_RN:
+         consume_data_flag = 0;
+         dtp->u.p.current_unit->round_status = ROUND_NEAREST;
+         break;
+
+       case FMT_RP:
+         consume_data_flag = 0;
+         dtp->u.p.current_unit->round_status = ROUND_PROCDEFINED;
+         break;
+
+       case FMT_RU:
+         consume_data_flag = 0;
+         dtp->u.p.current_unit->round_status = ROUND_UP;
+         break;
+
+       case FMT_RZ:
+         consume_data_flag = 0;
+         dtp->u.p.current_unit->round_status = ROUND_ZERO;
+         break;
 
        case FMT_P:
          consume_data_flag = 0;
@@ -1566,6 +1606,36 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
          dtp->u.p.current_unit->decimal_status = DECIMAL_POINT;
          break;
 
+       case FMT_RC:
+         consume_data_flag = 0;
+         dtp->u.p.current_unit->round_status = ROUND_COMPATIBLE;
+         break;
+
+       case FMT_RD:
+         consume_data_flag = 0;
+         dtp->u.p.current_unit->round_status = ROUND_DOWN;
+         break;
+
+       case FMT_RN:
+         consume_data_flag = 0;
+         dtp->u.p.current_unit->round_status = ROUND_NEAREST;
+         break;
+
+       case FMT_RP:
+         consume_data_flag = 0;
+         dtp->u.p.current_unit->round_status = ROUND_PROCDEFINED;
+         break;
+
+       case FMT_RU:
+         consume_data_flag = 0;
+         dtp->u.p.current_unit->round_status = ROUND_UP;
+         break;
+
+       case FMT_RZ:
+         consume_data_flag = 0;
+         dtp->u.p.current_unit->round_status = ROUND_ZERO;
+         break;
+
        case FMT_P:
          consume_data_flag = 0;
          dtp->u.p.scale_factor = f->u.k;
@@ -2252,6 +2322,16 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
   if (dtp->u.p.current_unit->decimal_status == DECIMAL_UNSPECIFIED)
        dtp->u.p.current_unit->decimal_status = dtp->u.p.current_unit->flags.decimal;
 
+  /* Check the round mode.  */
+  dtp->u.p.current_unit->round_status
+       = !(cf & IOPARM_DT_HAS_ROUND) ? ROUND_UNSPECIFIED :
+         find_option (&dtp->common, dtp->round, dtp->round_len,
+                       round_opt, "Bad ROUND parameter in data transfer "
+                       "statement");
+
+  if (dtp->u.p.current_unit->round_status == ROUND_UNSPECIFIED)
+       dtp->u.p.current_unit->round_status = dtp->u.p.current_unit->flags.round;
+
   /* Check the sign mode. */
   dtp->u.p.sign_status
        = !(cf & IOPARM_DT_HAS_SIGN) ? SIGN_UNSPECIFIED :
index d8d0c29..5dc3538 100644 (file)
@@ -441,6 +441,7 @@ get_internal_unit (st_parameter_dt *dtp)
   iunit->flags.decimal = DECIMAL_POINT;
   iunit->flags.encoding = ENCODING_DEFAULT;
   iunit->flags.async = ASYNC_NO;
+  iunit->flags.round = ROUND_COMPATIBLE;
 
   /* Initialize the data transfer parameters.  */
 
@@ -531,6 +532,7 @@ init_units (void)
       u->flags.decimal = DECIMAL_POINT;
       u->flags.encoding = ENCODING_DEFAULT;
       u->flags.async = ASYNC_NO;
+      u->flags.round = ROUND_COMPATIBLE;
      
       u->recl = options.default_recl;
       u->endfile = NO_ENDFILE;
@@ -560,6 +562,7 @@ init_units (void)
       u->flags.decimal = DECIMAL_POINT;
       u->flags.encoding = ENCODING_DEFAULT;
       u->flags.async = ASYNC_NO;
+      u->flags.round = ROUND_COMPATIBLE;
 
       u->recl = options.default_recl;
       u->endfile = AT_ENDFILE;
@@ -589,6 +592,7 @@ init_units (void)
       u->flags.decimal = DECIMAL_POINT;
       u->flags.encoding = ENCODING_DEFAULT;
       u->flags.async = ASYNC_NO;
+      u->flags.round = ROUND_COMPATIBLE;
 
       u->recl = options.default_recl;
       u->endfile = AT_ENDFILE;
index 9804d7b..e688002 100644 (file)
@@ -68,7 +68,7 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size,
   char *out;
   char *digits;
   int e;
-  char expchar;
+  char expchar, rchar;
   format_token ft;
   int w;
   int d;
@@ -89,6 +89,7 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size,
   w = f->u.real.w;
   d = f->u.real.d;
 
+  rchar = '5';
   nzero_real = -1;
 
   /* We should always know the field width and precision.  */
@@ -235,24 +236,75 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size,
       internal_error (&dtp->common, "Unexpected format token");
     }
 
-  /* Round the value.  */
+  /* Round the value.  The value being rounded is an unsigned magnitude.
+     The ROUND_COMPATIBLE is rounding away from zero when there is a tie.  */
+  switch (dtp->u.p.current_unit->round_status)
+    {
+      case ROUND_ZERO: /* Do nothing and truncation occurs.  */
+       goto skip;
+      case ROUND_UP:
+       if (sign_bit)
+         goto skip;
+       rchar = '0';
+       break;
+      case ROUND_DOWN:
+       if (!sign_bit)
+         goto skip;
+       rchar = '0';
+       break;
+      case ROUND_NEAREST:
+       /* Round compatible unless there is a tie. A tie is a 5 with
+          all trailing zero's.  */
+       i = nafter + 1;
+       if (digits[i] == '5')
+         {
+           for(i++ ; i < ndigits; i++)
+             {
+               if (digits[i] != '0')
+                 goto do_rnd;
+             }
+           /* It is a  tie so round to even.  */
+           switch (digits[nafter])
+             {
+               case '1':
+               case '3':
+               case '5':
+               case '7':
+               case '9':
+                 /* If odd, round away from zero to even.  */
+                 break;
+               default:
+                 /* If even, skip rounding, truncate to even.  */
+                 goto skip;
+             }
+         }
+        /* Fall through.  */ 
+      case ROUND_PROCDEFINED:
+      case ROUND_UNSPECIFIED:
+      case ROUND_COMPATIBLE:
+       rchar = '5';
+       /* Just fall through and do the actual rounding.  */
+    }
+    
+  do_rnd:
   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;
-        }
+      if (nzero_real == d && digits[0] >= rchar)
+       {
+         /* We rounded to zero but shouldn't have */
+         nzero--;
+         nafter = 1;
+         digits[0] = '1';
+         ndigits = 1;
+       }
     }
   else if (nbefore + nafter < ndigits)
     {
       ndigits = nbefore + nafter;
       i = ndigits;
-      if (digits[i] >= '5')
+      if (digits[i] >= rchar)
        {
          /* Propagate the carry.  */
          for (i--; i >= 0; i--)
@@ -267,9 +319,10 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size,
 
          if (i < 0)
            {
-             /* 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.  */
+             /* 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)
@@ -297,6 +350,8 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size,
        }
     }
 
+  skip:
+
   /* Calculate the format of the exponent field.  */
   if (expchar)
     {