OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/47531 (SHAPE misses KIND= support)

Browse Source 
2011-01-29  Tobias Burnus  <burnus@net-b.de>

        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  <burnus@net-b.de>

        PR fortran/47531
        * gfortran.dg/shape_6.f90: New.

From-SVN: r169392
This commit is contained in:
Tobias Burnus 2011-01-29 18:36:18 +01:00 committed by Tobias Burnus
parent bd228fecfc
commit 7320cf0901
9 changed files with 78 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
gcc/fortran/ChangeLog
View File

@ -1,3 +1,14 @@
2011-01-29 Tobias Burnus <burnus@net-b.de>
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 <burnus@net-b.de>
PR fortran/47507

9
gcc/fortran/check.c
View File

@ -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;
}

5
gcc/fortran/intrinsic.c
View File

@ -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);

6
gcc/fortran/intrinsic.h
View File

@ -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 *);

9
gcc/fortran/intrinsic.texi
View File

@ -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

9
gcc/fortran/iresolve.c
View File

@ -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);

14
gcc/fortran/simplify.c
View File

@ -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)
{

5
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
2011-01-29 Tobias Burnus <burnus@net-b.de>
PR fortran/47531
* gfortran.dg/shape_6.f90: New.
2011-01-29 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR libgfortran/47434

29
gcc/testsuite/gfortran.dg/shape_6.f90 Normal file
View File

@ -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