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

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

gcc/fortran/ChangeLog

+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

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

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

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

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

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

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

gcc/testsuite/ChangeLog

+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

gcc/testsuite/gfortran.dg/shape_6.f90

+! { 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
+