From 7320cf0901b5409c45d68b3c10cdd22eaf918fe5 Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Sat, 29 Jan 2011 18:36:18 +0100 Subject: [PATCH] re PR fortran/47531 (SHAPE misses KIND= support) 2011-01-29 Tobias Burnus PR fortran/47531 * check.c (gfc_check_shape): Support kind argument in SHAPE. * intrinsic.c (add_functions): Ditto. * resolve.c (gfc_resolve_shape): Ditto. * simplify.c (gfc_simplify_shape): Ditto. * intrinsic.h (gfc_check_shape, gfc_resolve_shape, gfc_simplify_shape): Update prototypes. * intrinisc.text (SHAPE): Document kind argument. 2011-01-29 Tobias Burnus PR fortran/47531 * gfortran.dg/shape_6.f90: New. From-SVN: r169392 --- gcc/fortran/ChangeLog | 11 ++++++++++ gcc/fortran/check.c | 9 ++++++++- gcc/fortran/intrinsic.c | 5 +++-- gcc/fortran/intrinsic.h | 6 +++--- gcc/fortran/intrinsic.texi | 9 ++++++--- gcc/fortran/iresolve.c | 9 +++++++-- gcc/fortran/simplify.c | 14 ++++++------- gcc/testsuite/ChangeLog | 5 +++++ gcc/testsuite/gfortran.dg/shape_6.f90 | 29 +++++++++++++++++++++++++++ 9 files changed, 78 insertions(+), 19 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/shape_6.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index b7064921b43..b1df4053d52 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,14 @@ +2011-01-29 Tobias Burnus + + PR fortran/47531 + * check.c (gfc_check_shape): Support kind argument in SHAPE. + * intrinsic.c (add_functions): Ditto. + * resolve.c (gfc_resolve_shape): Ditto. + * simplify.c (gfc_simplify_shape): Ditto. + * intrinsic.h (gfc_check_shape, gfc_resolve_shape, + gfc_simplify_shape): Update prototypes. + * intrinisc.text (SHAPE): Document kind argument. + 2011-01-28 Tobias Burnus PR fortran/47507 diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 20163f99a55..adb4b95368d 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -3255,7 +3255,7 @@ gfc_check_set_exponent (gfc_expr *x, gfc_expr *i) gfc_try -gfc_check_shape (gfc_expr *source) +gfc_check_shape (gfc_expr *source, gfc_expr *kind) { gfc_array_ref *ar; @@ -3271,6 +3271,13 @@ gfc_check_shape (gfc_expr *source) return FAILURE; } + if (kind_check (kind, 1, BT_INTEGER) == FAILURE) + return FAILURE; + if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic " + "with KIND argument at %L", + gfc_current_intrinsic, &kind->where) == FAILURE) + return FAILURE; + return SUCCESS; } diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 9458ca948f1..80dbaa8dd4a 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -2541,9 +2541,10 @@ add_functions (void) make_generic ("set_exponent", GFC_ISYM_SET_EXPONENT, GFC_STD_F95); - add_sym_1 ("shape", GFC_ISYM_SHAPE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, + add_sym_2 ("shape", GFC_ISYM_SHAPE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, gfc_check_shape, gfc_simplify_shape, gfc_resolve_shape, - src, BT_REAL, dr, REQUIRED); + src, BT_REAL, dr, REQUIRED, + kind, BT_INTEGER, di, OPTIONAL); make_generic ("shape", GFC_ISYM_SHAPE, GFC_STD_F95); diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 540cc8ebbf7..033bae0f68c 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -135,7 +135,7 @@ gfc_try gfc_check_selected_char_kind (gfc_expr *); gfc_try gfc_check_selected_int_kind (gfc_expr *); gfc_try gfc_check_selected_real_kind (gfc_expr *, gfc_expr *, gfc_expr *); gfc_try gfc_check_set_exponent (gfc_expr *, gfc_expr *); -gfc_try gfc_check_shape (gfc_expr *); +gfc_try gfc_check_shape (gfc_expr *, gfc_expr *); gfc_try gfc_check_shift (gfc_expr *, gfc_expr *); gfc_try gfc_check_size (gfc_expr *, gfc_expr *, gfc_expr *); gfc_try gfc_check_sign (gfc_expr *, gfc_expr *); @@ -360,7 +360,7 @@ gfc_expr *gfc_simplify_selected_int_kind (gfc_expr *); gfc_expr *gfc_simplify_selected_real_kind (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_set_exponent (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_sign (gfc_expr *, gfc_expr *); -gfc_expr *gfc_simplify_shape (gfc_expr *); +gfc_expr *gfc_simplify_shape (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_shifta (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_shiftl (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_shiftr (gfc_expr *, gfc_expr *); @@ -531,7 +531,7 @@ void gfc_resolve_scan (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, void gfc_resolve_second_sub (gfc_code *); void gfc_resolve_secnds (gfc_expr *, gfc_expr *); void gfc_resolve_set_exponent (gfc_expr *, gfc_expr *, gfc_expr *); -void gfc_resolve_shape (gfc_expr *, gfc_expr *); +void gfc_resolve_shape (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_shift (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_sign (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_signal (gfc_expr *, gfc_expr *, gfc_expr *); diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index 49f1b6ebc40..d8a97c55971 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -10836,26 +10836,29 @@ END PROGRAM Determines the shape of an array. @item @emph{Standard}: -Fortran 95 and later +Fortran 95 and later, with @var{KIND} argument Fortran 2003 and later @item @emph{Class}: Inquiry function @item @emph{Syntax}: -@code{RESULT = SHAPE(SOURCE)} +@code{RESULT = SHAPE(SOURCE [, KIND])} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @item @var{SOURCE} @tab Shall be an array or scalar of any type. If @var{SOURCE} is a pointer it must be associated and allocatable arrays must be allocated. +@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization +expression indicating the kind parameter of the result. @end multitable @item @emph{Return value}: An @code{INTEGER} array of rank one with as many elements as @var{SOURCE} has dimensions. The elements of the resulting array correspond to the extend of @var{SOURCE} along the respective dimensions. If @var{SOURCE} is a scalar, -the result is the rank one array of size zero. +the result is the rank one array of size zero. If @var{KIND} is absent, the +return value has the default integer kind otherwise the specified kind. @item @emph{Example}: @smallexample diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 12854fbf638..ec9dd422fb6 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -2185,10 +2185,15 @@ gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x, void -gfc_resolve_shape (gfc_expr *f, gfc_expr *array) +gfc_resolve_shape (gfc_expr *f, gfc_expr *array, gfc_expr *kind) { f->ts.type = BT_INTEGER; - f->ts.kind = gfc_default_integer_kind; + + if (kind) + f->ts.kind = mpz_get_si (kind->value.integer); + else + f->ts.kind = gfc_default_integer_kind; + f->rank = 1; f->shape = gfc_get_shape (1); mpz_init_set_ui (f->shape[0], array->rank); diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 3beac15177c..ba8804401bf 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -5496,20 +5496,19 @@ gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i) gfc_expr * -gfc_simplify_shape (gfc_expr *source) +gfc_simplify_shape (gfc_expr *source, gfc_expr *kind) { mpz_t shape[GFC_MAX_DIMENSIONS]; gfc_expr *result, *e, *f; gfc_array_ref *ar; int n; gfc_try t; + int k = get_kind (BT_INTEGER, kind, "SHAPE", gfc_default_integer_kind); + + result = gfc_get_array_expr (BT_INTEGER, k, &source->where); if (source->rank == 0) - return gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, - &source->where); - - result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, - &source->where); + return result; if (source->expr_type == EXPR_VARIABLE) { @@ -5530,8 +5529,7 @@ gfc_simplify_shape (gfc_expr *source) for (n = 0; n < source->rank; n++) { - e = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, - &source->where); + e = gfc_get_constant_expr (BT_INTEGER, k, &source->where); if (t == SUCCESS) { diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index cefa8a7a0d4..0468506d415 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2011-01-29 Tobias Burnus + + PR fortran/47531 + * gfortran.dg/shape_6.f90: New. + 2011-01-29 Jerry DeLisle PR libgfortran/47434 diff --git a/gcc/testsuite/gfortran.dg/shape_6.f90 b/gcc/testsuite/gfortran.dg/shape_6.f90 new file mode 100644 index 00000000000..d68f7bef58a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/shape_6.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! +! PR fortran/47531 +! +! Contributed by James Van Buskirk +! +! Check for the presence of the optional kind= argument +! of F2003. +! + +program bug1 + use ISO_C_BINDING + implicit none + real,allocatable :: weevil(:,:) + + write(*,*) achar(64,C_CHAR) + write(*,*) char(64,C_CHAR) + write(*,*) iachar('A',C_INTPTR_T) + write(*,*) ichar('A',C_INTPTR_T) + write(*,*) len('A',C_INTPTR_T) + write(*,*) len_trim('A',C_INTPTR_T) + allocate(weevil(2,2)) + weevil = 42 + write(*,*) ceiling(weevil,C_INTPTR_T) + write(*,*) floor(weevil,C_INTPTR_T) + write(*,*) shape(weevil,C_INTPTR_T) + write(*,*) storage_size(weevil,C_INTPTR_T) +end program bug1 +