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.
@@ -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;
}
@@ -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);
@@ -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 *);
@@ -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
@@ -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);
@@ -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);
- if (source->rank == 0)
- return gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind,
- &source->where);
+ result = gfc_get_array_expr (BT_INTEGER, k, &source->where);
- result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind,
- &source->where);
+ if (source->rank == 0)
+ 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)
{
@@ -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
+