re PR libfortran/35862 ([F2003] Implement new rounding modes for run time)

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.

From-SVN: r152263

6 files changed, 210 insertions, 15 deletions

diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index ab6348b..2530bf7 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -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.
diff --git a/libgfortran/io/format.c b/libgfortran/io/format.c
index e888a2e..4ab70e8 100644
--- a/libgfortran/io/format.c
+++ b/libgfortran/io/format.c
@@ -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:
diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h
index 9ca6d38..51143f5 100644
--- a/libgfortran/io/io.h
+++ b/libgfortran/io/io.h
@@ -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;
 
diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index 4525bb4..06a1d2e 100644
--- a/libgfortran/io/transfer.c
+++ b/libgfortran/io/transfer.c
@@ -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 :
diff --git a/libgfortran/io/unit.c b/libgfortran/io/unit.c
index d8d0c29..5dc3538 100644
--- a/libgfortran/io/unit.c
+++ b/libgfortran/io/unit.c
@@ -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;
diff --git a/libgfortran/io/write_float.def b/libgfortran/io/write_float.def
index 9804d7b..e688002 100644
--- a/libgfortran/io/write_float.def
+++ b/libgfortran/io/write_float.def
@@ -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)
     {