[multiple changes]

2008-05-15  Steven G. Kargl  <kargls@comcast.net>

	* simplify.c (gfc_simplify_dble, gfc_simplify_float,
	simplify_bound, gfc_simplify_nearest, gfc_simplify_real): Plug
	possible memory leaks.
	(gfc_simplify_reshape): Plug possible memory leaks and dereferencing
	of NULL pointers.

2008-05-15  Steven G. Kargl  <kargls@comcast.net>

	PR fortran/36239
	* simplify.c (gfc_simplify_int, gfc_simplify_intconv): Replaced hand
	rolled integer conversion with gfc_int2int, gfc_real2int, and
	gfc_complex2int.
	(gfc_simplify_intconv): Renamed to simplify_intconv.

2008-05-15  Steven G. Kargl,   <kargl@comcast.net>
	* gfortran.dg/and_or_xor.f90: New test

	* fortran/simplify.c (gfc_simplify_and, gfc_simplify_or,
	gfc_simplify_xor): Don't range check logical results.

From-SVN: r135408

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index fb05a79faaa016c8b0282ddbaf1539399c8127a9..cea13bae56ea1c10c7dfd0e20bdcdd067dc87f7d 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,25 @@
+2008-05-15  Steven G. Kargl  <kargls@comcast.net>
+
+       * simplify.c (gfc_simplify_dble, gfc_simplify_float,
+       simplify_bound, gfc_simplify_nearest, gfc_simplify_real): Plug
+       possible memory leaks.
+       (gfc_simplify_reshape): Plug possible memory leaks and dereferencing
+       of NULL pointers.
+
+2008-05-15  Steven G. Kargl  <kargls@comcast.net>
+
+       PR fortran/36239
+       * simplify.c (gfc_simplify_int, gfc_simplify_intconv): Replaced hand
+       rolled integer conversion with gfc_int2int, gfc_real2int, and
+       gfc_complex2int.
+       (gfc_simplify_intconv): Renamed to simplify_intconv.
+       
+2008-05-15  Steven G. Kargl,   <kargl@comcast.net>
+       * gfortran.dg/and_or_xor.f90: New test
+
+       * fortran/simplify.c (gfc_simplify_and, gfc_simplify_or,
+       gfc_simplify_xor): Don't range check logical results.
+
 2008-05-15  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
 
        * trans-expr.c (gfc_conv_concat_op): Take care of nondefault

diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index 1a2d3ca68f27764d55b629f81438ed605cdab2f9..35400e23fbda9ba2d8b7e280e9906dd068136683 100644 (file)
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -1000,13 +1000,16 @@ Function
 
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
-@item @var{I} @tab The type shall be either @code{INTEGER(*)} or @code{LOGICAL}.
-@item @var{J} @tab The type shall be either @code{INTEGER(*)} or @code{LOGICAL}.
+@item @var{I} @tab The type shall be either a scalar @code{INTEGER(*)}
+type or a scalar @code{LOGICAL} type.
+@item @var{J} @tab The type shall be the same as the type of @var{I}.
 @end multitable
 
 @item @emph{Return value}:
-The return type is either @code{INTEGER(*)} or @code{LOGICAL} after
-cross-promotion of the arguments. 
+The return type is either a scalar @code{INTEGER(*)} or a scalar
+@code{LOGICAL}.  If the kind type parameters differ, then the
+smaller kind type is implicitly converted to larger kind, and the 
+return has the larger kind.
 
 @item @emph{Example}:
 @smallexample
@@ -8250,13 +8253,16 @@ Function
 
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
-@item @var{X} @tab The type shall be either @code{INTEGER(*)} or @code{LOGICAL}.
-@item @var{Y} @tab The type shall be either @code{INTEGER(*)} or @code{LOGICAL}.
+@item @var{X} @tab The type shall be either a scalar @code{INTEGER(*)}
+type or a scalar @code{LOGICAL} type.
+@item @var{Y} @tab The type shall be the same as the type of @var{X}.
 @end multitable
 
 @item @emph{Return value}:
-The return type is either @code{INTEGER(*)} or @code{LOGICAL} 
-after cross-promotion of the arguments.
+The return type is either a scalar @code{INTEGER(*)} or a scalar
+@code{LOGICAL}.  If the kind type parameters differ, then the
+smaller kind type is implicitly converted to larger kind, and the 
+return has the larger kind.
 
 @item @emph{Example}:
 @smallexample
@@ -10990,13 +10996,16 @@ Function
 
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
-@item @var{X} @tab The type shall be either @code{INTEGER(*)} or @code{LOGICAL}.
-@item @var{Y} @tab The type shall be either @code{INTEGER(*)} or @code{LOGICAL}.
+@item @var{X} @tab The type shall be either  a scalar @code{INTEGER(*)}
+type or a scalar @code{LOGICAL} type.
+@item @var{Y} @tab The type shall be the same as the type of @var{I}.
 @end multitable
 
 @item @emph{Return value}:
-The return type is either @code{INTEGER(*)} or @code{LOGICAL}
-after cross-promotion of the arguments.
+The return type is either a scalar @code{INTEGER(*)} or a scalar
+@code{LOGICAL}.  If the kind type parameters differ, then the
+smaller kind type is implicitly converted to larger kind, and the 
+return has the larger kind.
 
 @item @emph{Example}:
 @smallexample

diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 066bf283767e2d6fa881ef18f4e92031cc379c70..4159374f06e64ffec6b68f1c9861378d2dcbd1e1 100644 (file)
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -505,14 +505,15 @@ gfc_simplify_and (gfc_expr *x, gfc_expr *y)
     {
       result = gfc_constant_result (BT_INTEGER, kind, &x->where);
       mpz_and (result->value.integer, x->value.integer, y->value.integer);
+      return range_check (result, "AND");
     }
   else /* BT_LOGICAL */
     {
       result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
       result->value.logical = x->value.logical && y->value.logical;
+      return result;
     }
 
-  return range_check (result, "AND");
 }
 
 
@@ -1123,7 +1124,10 @@ gfc_simplify_dble (gfc_expr *e)
       ts.kind = gfc_default_double_kind;
       result = gfc_copy_expr (e);
       if (!gfc_convert_boz (result, &ts))
-       return &gfc_bad_expr;
+       {
+         gfc_free_expr (result);
+         return &gfc_bad_expr;
+       }
     }
 
   return range_check (result, "DBLE");
@@ -1346,7 +1350,10 @@ gfc_simplify_float (gfc_expr *a)
 
       result = gfc_copy_expr (a);
       if (!gfc_convert_boz (result, &ts))
-       return &gfc_bad_expr;
+       {
+         gfc_free_expr (result);
+         return &gfc_bad_expr;
+       }
     }
   else
     result = gfc_int2real (a, gfc_default_real_kind);
@@ -1866,7 +1873,7 @@ done:
 gfc_expr *
 gfc_simplify_int (gfc_expr *e, gfc_expr *k)
 {
-  gfc_expr *rpart, *rtrunc, *result;
+  gfc_expr *result = NULL;
   int kind;
 
   kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
@@ -1876,33 +1883,22 @@ gfc_simplify_int (gfc_expr *e, gfc_expr *k)
   if (e->expr_type != EXPR_CONSTANT)
     return NULL;
 
-  result = gfc_constant_result (BT_INTEGER, kind, &e->where);
-
   switch (e->ts.type)
     {
     case BT_INTEGER:
-      mpz_set (result->value.integer, e->value.integer);
+      result = gfc_int2int (e, kind);
       break;
 
     case BT_REAL:
-      rtrunc = gfc_copy_expr (e);
-      mpfr_trunc (rtrunc->value.real, e->value.real);
-      gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
-      gfc_free_expr (rtrunc);
+      result = gfc_real2int (e, kind);
       break;
 
     case BT_COMPLEX:
-      rpart = gfc_complex2real (e, kind);
-      rtrunc = gfc_copy_expr (rpart);
-      mpfr_trunc (rtrunc->value.real, rpart->value.real);
-      gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
-      gfc_free_expr (rpart);
-      gfc_free_expr (rtrunc);
+      result = gfc_complex2int (e, kind);
       break;
 
     default:
       gfc_error ("Argument of INT at %L is not a valid type", &e->where);
-      gfc_free_expr (result);
       return &gfc_bad_expr;
     }
 
@@ -1911,40 +1907,29 @@ gfc_simplify_int (gfc_expr *e, gfc_expr *k)
 
 
 static gfc_expr *
-gfc_simplify_intconv (gfc_expr *e, int kind, const char *name)
+simplify_intconv (gfc_expr *e, int kind, const char *name)
 {
-  gfc_expr *rpart, *rtrunc, *result;
+  gfc_expr *result = NULL;
 
   if (e->expr_type != EXPR_CONSTANT)
     return NULL;
 
-  result = gfc_constant_result (BT_INTEGER, kind, &e->where);
-
   switch (e->ts.type)
     {
     case BT_INTEGER:
-      mpz_set (result->value.integer, e->value.integer);
+      result = gfc_int2int (e, kind);
       break;
 
     case BT_REAL:
-      rtrunc = gfc_copy_expr (e);
-      mpfr_trunc (rtrunc->value.real, e->value.real);
-      gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
-      gfc_free_expr (rtrunc);
+      result = gfc_real2int (e, kind);
       break;
 
     case BT_COMPLEX:
-      rpart = gfc_complex2real (e, kind);
-      rtrunc = gfc_copy_expr (rpart);
-      mpfr_trunc (rtrunc->value.real, rpart->value.real);
-      gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
-      gfc_free_expr (rpart);
-      gfc_free_expr (rtrunc);
+      result = gfc_complex2int (e, kind);
       break;
 
     default:
       gfc_error ("Argument of %s at %L is not a valid type", name, &e->where);
-      gfc_free_expr (result);
       return &gfc_bad_expr;
     }
 
@@ -1955,21 +1940,21 @@ gfc_simplify_intconv (gfc_expr *e, int kind, const char *name)
 gfc_expr *
 gfc_simplify_int2 (gfc_expr *e)
 {
-  return gfc_simplify_intconv (e, 2, "INT2");
+  return simplify_intconv (e, 2, "INT2");
 }
 
 
 gfc_expr *
 gfc_simplify_int8 (gfc_expr *e)
 {
-  return gfc_simplify_intconv (e, 8, "INT8");
+  return simplify_intconv (e, 8, "INT8");
 }
 
 
 gfc_expr *
 gfc_simplify_long (gfc_expr *e)
 {
-  return gfc_simplify_intconv (e, 4, "LONG");
+  return simplify_intconv (e, 4, "LONG");
 }
 
 
@@ -2378,7 +2363,10 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
       k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
                    gfc_default_integer_kind); 
       if (k == -1)
-       return &gfc_bad_expr;
+       {
+         gfc_free_expr (e);
+         return &gfc_bad_expr;
+       }
       e->ts.kind = k;
 
       /* The result is a rank 1 array; its size is the rank of the first
@@ -2999,6 +2987,7 @@ gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
   if (mpfr_nan_p (result->value.real) && gfc_option.flag_range_check)
     {
       gfc_error ("Result of NEAREST is NaN at %L", &result->where);
+      gfc_free_expr (result);
       return &gfc_bad_expr;
     }
 
@@ -3109,14 +3098,14 @@ gfc_simplify_or (gfc_expr *x, gfc_expr *y)
     {
       result = gfc_constant_result (BT_INTEGER, kind, &x->where);
       mpz_ior (result->value.integer, x->value.integer, y->value.integer);
+      return range_check (result, "OR");
     }
   else /* BT_LOGICAL */
     {
       result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
       result->value.logical = x->value.logical || y->value.logical;
+      return result;
     }
-
-  return range_check (result, "OR");
 }
 
 
@@ -3239,8 +3228,12 @@ gfc_simplify_real (gfc_expr *e, gfc_expr *k)
       ts.kind = kind;
       result = gfc_copy_expr (e);
       if (!gfc_convert_boz (result, &ts))
-       return &gfc_bad_expr;
+       {
+         gfc_free_expr (result);
+         return &gfc_bad_expr;
+       }
     }
+
   return range_check (result, "REAL");
 }
 
@@ -3449,13 +3442,11 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
          goto bad_reshape;
        }
 
-      gfc_free_expr (e);
-
       if (rank >= GFC_MAX_DIMENSIONS)
        {
          gfc_error ("Too many dimensions in shape specification for RESHAPE "
                     "at %L", &e->where);
-
+         gfc_free_expr (e);
          goto bad_reshape;
        }
 
@@ -3463,9 +3454,11 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
        {
          gfc_error ("Shape specification at %L cannot be negative",
                     &e->where);
+         gfc_free_expr (e);
          goto bad_reshape;
        }
 
+      gfc_free_expr (e);
       rank++;
     }
 
@@ -3505,12 +3498,11 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
              goto bad_reshape;
            }
 
-         gfc_free_expr (e);
-
          if (order[i] < 1 || order[i] > rank)
            {
              gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
                         &e->where);
+             gfc_free_expr (e);
              goto bad_reshape;
            }
 
@@ -3520,9 +3512,12 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
            {
              gfc_error ("Invalid permutation in ORDER parameter at %L",
                         &e->where);
+             gfc_free_expr (e);
              goto bad_reshape;
            }
 
+         gfc_free_expr (e);
+
          x[order[i]] = 1;
        }
     }
@@ -3562,7 +3557,7 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
        }
 
       if (mpz_cmp_ui (index, INT_MAX) > 0)
-       gfc_internal_error ("Reshaped array too large at %L", &e->where);
+       gfc_internal_error ("Reshaped array too large at %C");
 
       j = mpz_get_ui (index);
 
@@ -3694,6 +3689,7 @@ gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
       || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
     {
       gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
+      gfc_free_expr (result);
       return &gfc_bad_expr;
     }
 
@@ -4612,15 +4608,16 @@ gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
     {
       result = gfc_constant_result (BT_INTEGER, kind, &x->where);
       mpz_xor (result->value.integer, x->value.integer, y->value.integer);
+      return range_check (result, "XOR");
     }
   else /* BT_LOGICAL */
     {
       result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
       result->value.logical = (x->value.logical && !y->value.logical)
                              || (!x->value.logical && y->value.logical);
+      return result;
     }
 
-  return range_check (result, "XOR");
 }