From d93712d9ff419405a47063a9fcaeeb1c1151cdac Mon Sep 17 00:00:00 2001 From: "Steven G. Kargl" Date: Fri, 16 May 2008 03:41:17 +0000 Subject: [PATCH] [multiple changes] 2008-05-15 Steven G. Kargl * 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 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, * 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 --- gcc/fortran/ChangeLog | 22 +++++++++ gcc/fortran/intrinsic.texi | 33 +++++++++----- gcc/fortran/simplify.c | 93 ++++++++++++++++++-------------------- 3 files changed, 88 insertions(+), 60 deletions(-) diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index fb05a79faaa..cea13bae56e 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,25 @@ +2008-05-15 Steven G. Kargl + + * 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 + + 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, + * 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 * trans-expr.c (gfc_conv_concat_op): Take care of nondefault diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index 1a2d3ca68f2..35400e23fbd 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 066bf283767..4159374f06e 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"); } -- 2.30.2