aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran
diff options
context:
space:
mode:
authorSteven G. Kargl <kargls@comcast.net>2008-05-16 03:41:17 +0000
committerJerry DeLisle <jvdelisle@gcc.gnu.org>2008-05-16 03:41:17 +0000
commitd93712d9ff419405a47063a9fcaeeb1c1151cdac (patch)
tree06f05b3524b7e9fbf23e3061314bfdb8188ba0df /gcc/fortran
parentb362cad04548e826027712558b71fb88884e7261 (diff)
downloadgcc-d93712d9ff419405a47063a9fcaeeb1c1151cdac.zip
gcc-d93712d9ff419405a47063a9fcaeeb1c1151cdac.tar.gz
gcc-d93712d9ff419405a47063a9fcaeeb1c1151cdac.tar.bz2
[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
Diffstat (limited to 'gcc/fortran')
-rw-r--r--gcc/fortran/ChangeLog22
-rw-r--r--gcc/fortran/intrinsic.texi33
-rw-r--r--gcc/fortran/simplify.c93
3 files changed, 88 insertions, 60 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index fb05a79..cea13ba 100644
--- 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 1a2d3ca..35400e2 100644
--- 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 066bf28..4159374 100644
--- 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");
}