This is the mail archive of the fortran@gcc.gnu.org mailing list for the GNU Fortran project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[patch, fortran] PR35862 [F2003] Implement new rounding modes for run time


Hi Folks,

The attached patch implements the F2003 rounding modes. This includes ROUND_UP, ROUND_DOWN, ROUND_ZERO, ROUND_NEAREST, ROUND_COMPATIBLE, and ROUND_PROCDEFINED. The patch also implements the respective format specifiers.

The implementation performs the appropriate rounding on formatted output. Input is not addressed.

ROUND_NEAREST rounds to even if the value is half way between, following the IEEE definition noted in the Fortran 2003 standard.

The code uses the existing gfortran rounding code by introducing a new variable to set the rounding threshold.

Also attached is a test case that Dominiq helped develop and test. The test case f2003_io_3.f03 is modified by the patch to eliminate the error.

Regression tested on x86-64-linux-gnu.

OK for trunk?

Regards,

Jerry

2009-09-27 Jerry DeLisle <jvdelisle@gcc.gnu.org>

	PR fortran/35862
	* io.c (format_token): Add enumerators for rounding format specifiers.
	(format_lex): Tokenize the rounding format specifiers.
	(gfc_match_open): Enable rounding modes in OPEN statement.

2009-09-27 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.




Index: gcc/testsuite/gfortran.dg/f2003_io_3.f03
===================================================================
--- gcc/testsuite/gfortran.dg/f2003_io_3.f03	(revision 152187)
+++ gcc/testsuite/gfortran.dg/f2003_io_3.f03	(working copy)
@@ -11,7 +11,7 @@ a = 43.21
 WRITE(99,'(10f8.3)',decimal="comma") a
 rewind(99)
 read(99,'(dc,10f8.3)',blank=msg) b
-write(99,'(dp,10f8.3)',round="up") ! { dg-error "not implemented" }
+write(99,'(dp,10f8.3)',round="up")
 rewind(99)
 read(99,'(10f8.3)',pad="yes")
 msg="suppress"
Index: gcc/fortran/io.c
===================================================================
--- gcc/fortran/io.c	(revision 152187)
+++ gcc/fortran/io.c	(working copy)
@@ -111,7 +111,8 @@ typedef enum
   FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_LPAREN,
   FMT_RPAREN, FMT_X, FMT_SIGN, FMT_BLANK, FMT_CHAR, FMT_P, FMT_IBOZ, FMT_F,
   FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END,
-  FMT_ERROR, FMT_DC, FMT_DP, FMT_T, FMT_TR, FMT_TL, FMT_STAR
+  FMT_ERROR, FMT_DC, FMT_DP, FMT_T, FMT_TR, FMT_TL, FMT_STAR, FMT_RC,
+  FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ
 }
 format_token;
 
@@ -467,6 +468,35 @@ format_lex (void)
 	}
       break;
 
+    case 'R':
+      c = next_char_not_space (&error);
+      switch (c)
+	{
+	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:
+	  token = FMT_UNKNOWN;
+	  unget_char ();
+	  break;
+	}
+      break;
+
     case '\0':
       token = FMT_END;
       break;
@@ -623,6 +653,12 @@ format_item_1:
     case FMT_BLANK:
     case FMT_DP:
     case FMT_DC:
+    case FMT_RC:
+    case FMT_RD:
+    case FMT_RN:
+    case FMT_RP:
+    case FMT_RU:
+    case FMT_RZ:
       goto between_desc;
 
     case FMT_CHAR:
@@ -1924,8 +1960,8 @@ gfc_match_open (void)
   /* Checks on the ROUND specifier.  */
   if (open->round)
     {
-      /* When implemented, change the following to use gfc_notify_std F2003.  */
-      gfc_error ("Fortran F2003: ROUND= specifier at %C not implemented");
+      if (gfc_notify_std (GFC_STD_F2003, "Fortran F2003: ROUND= at %C "
+	  "not allowed in Fortran 95") == FAILURE)
       goto cleanup;
 
       if (open->round->expr_type == EXPR_CONSTANT)
@@ -3275,12 +3311,9 @@ if (condition) \
 
   if (dt->round)
     {
-      /* When implemented, change the following to use gfc_notify_std F2003.
       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ROUND= at %C "
 	  "not allowed in Fortran 95") == FAILURE)
-	return MATCH_ERROR;  */
-      gfc_error ("F2003 Feature: ROUND= specifier at %C not implemented");
-      return MATCH_ERROR;
+	return MATCH_ERROR;
 
       if (dt->round->expr_type == EXPR_CONSTANT)
 	{
Index: libgfortran/io/io.h
===================================================================
--- libgfortran/io/io.h	(revision 152187)
+++ libgfortran/io/io.h	(working copy)
@@ -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: libgfortran/io/transfer.c
===================================================================
--- libgfortran/io/transfer.c	(revision 152187)
+++ libgfortran/io/transfer.c	(working copy)
@@ -101,7 +101,17 @@ 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},
   {"suppress", SIGN_SS},
@@ -1202,7 +1212,37 @@ formatted_transfer_scalar_read (st_parameter_dt *d
 	  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;
 	  dtp->u.p.scale_factor = f->u.k;
@@ -1566,6 +1606,36 @@ formatted_transfer_scalar_write (st_parameter_dt *
 	  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
   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->decimal_status == DECIMAL_UNSPECIFIED)
+	dtp->u.p.current_unit->decimal_status = dtp->u.p.current_unit->flags.decimal;
+
   /* Check the sign mode. */
   dtp->u.p.sign_status
 	= !(cf & IOPARM_DT_HAS_SIGN) ? SIGN_UNSPECIFIED :
Index: libgfortran/io/format.c
===================================================================
--- libgfortran/io/format.c	(revision 152187)
+++ libgfortran/io/format.c	(working copy)
@@ -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 *sav
       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: libgfortran/io/write_float.def
===================================================================
--- libgfortran/io/write_float.def	(revision 152187)
+++ libgfortran/io/write_float.def	(working copy)
@@ -68,7 +68,7 @@ output_float (st_parameter_dt *dtp, const fnode *f
   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
   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
       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
 
 	  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
 	}
     }
 
+  skip:
+
   /* Calculate the format of the exponent field.  */
   if (expchar)
     {

Attachment: round_1.f03
Description: Text document


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]