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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@169392 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index b7064921b43c85b1f3ef41066b2d1a8381329745..b1df4053d52bf8752aecb2602017257f8e4547db 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -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

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 20163f99a556cc873a237521b036cb601f044d11..adb4b95368d3205befcdeabc955641f745e5b206 100644 (file)
--- 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 9458ca948f167cbf195f672b03b532f2a8ac3f7f..80dbaa8dd4a79ed31d13465aa60481e4e6503e29 100644 (file)
--- 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 540cc8ebbf7ffff2a1f0c19e80f741d0c09e23f2..033bae0f68cc7a5bd158c80f80432597c7a063f6 100644 (file)
--- 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 49f1b6ebc404094687fb3e6128743b881013aa5b..d8a97c55971afdceae658b5417631cb85828850c 100644 (file)
--- 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 12854fbf638ba797880531bc41830ea67f988fd5..ec9dd422fb626e12f8f351e6397bf8069a2909b9 100644 (file)
--- 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 3beac15177cb9a5f70691ebe70943155ccc41804..ba8804401bf53b774bc21e4202406e7aae1f2c33 100644 (file)
--- 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);
 
-  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)
        {

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index cefa8a7a0d4c2d75a0606ee7e8f22ce697b164f2..0468506d4159e40ebffcd651f0582ec13888e732 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -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

diff --git a/gcc/testsuite/gfortran.dg/shape_6.f90 b/gcc/testsuite/gfortran.dg/shape_6.f90
new file mode 100644 (file)
index 0000000..d68f7be
--- /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
+