From: Harald Anlauf <anlauf@gmx.de>
Date: Thu, 14 Oct 2021 18:18:14 +0000 (+0200)
Subject: Fortran: fix order of checks for the SHAPE intrinsic
X-Git-Tag: releases/gcc-11.3.0~734
X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=d97dbf60dda22e0668dc33ca3a536adcb0963a65;p=thirdparty%2Fgcc.git

Fortran: fix order of checks for the SHAPE intrinsic

gcc/fortran/ChangeLog:

	PR fortran/102716
	* check.c (gfc_check_shape): Reorder checks so that invalid KIND
	arguments can be detected.

gcc/testsuite/ChangeLog:

	PR fortran/102716
	* gfortran.dg/shape_10.f90: New test.

(cherry picked from commit 1b115daf62d94337b3d0b2962b0bbbf005a450e0)
---

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 851af1b30dc1..06acb80e3ac6 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -5082,6 +5082,13 @@ gfc_check_shape (gfc_expr *source, gfc_expr *kind)
   if (gfc_invalid_null_arg (source))
     return false;
 
+  if (!kind_check (kind, 1, BT_INTEGER))
+    return false;
+  if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
+			       "with KIND argument at %L",
+			       gfc_current_intrinsic, &kind->where))
+    return false;
+
   if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
     return true;
 
@@ -5094,13 +5101,6 @@ gfc_check_shape (gfc_expr *source, gfc_expr *kind)
       return false;
     }
 
-  if (!kind_check (kind, 1, BT_INTEGER))
-    return false;
-  if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
-			       "with KIND argument at %L",
-			       gfc_current_intrinsic, &kind->where))
-    return false;
-
   return true;
 }
 
diff --git a/gcc/testsuite/gfortran.dg/shape_10.f90 b/gcc/testsuite/gfortran.dg/shape_10.f90
new file mode 100644
index 000000000000..4943c21b1d2e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/shape_10.f90
@@ -0,0 +1,6 @@
+! { dg-do compile }
+! PR fortran/102716
+
+program p
+  integer, parameter :: a(1) = shape([2], [1]) ! { dg-error "must be a scalar" }
+end