re PR fortran/46152 ([F03] ALLOCATE with type-spec fails for intrinsic types)

2010-10-30  Steven G. Kargl  <kargl@gcc.gnu.org>

	PR fortran/46152
	* gfortran.dg/select_type_11.f03: Update dg-error phrase.
	* gfortran.dg/allocate_with_typespec_4.f90: New test.
	* gfortran.dg/allocate_with_typespec_1.f90: New test.
	* gfortran.dg/allocate_with_typespec_2.f: New test.
	* gfortran.dg/allocate_with_typespec_3.f90: New test.
	* gfortran.dg/allocate_derived_1.f90: Delete an obselescent test.
	* gfortran.dg/select_type_1.f03: Update dg-error phrase.

2010-10-30  Steven G. Kargl  <kargl@gcc.gnu.org>

	PR fortran/46152
	* fortran/match.c (match_derived_type_spec): Reoplace gfc_match_symbol
	with a gfc_find_symbol to prevent namespace pollution.  Remove dead
	code.
	(match_type_spec): Remove parsing of '::'.  Collapse character
	kind checking to one location.
	(gfc_match_allocate): Use correct locus in error message.

From-SVN: r166140

gcc/fortran/ChangeLog

+2010-11-01  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/46152
+	* fortran/match.c (match_derived_type_spec): Reoplace gfc_match_symbol
+	with a gfc_find_symbol to prevent namespace pollution.  Remove dead
+	code.
+	(match_type_spec): Remove parsing of '::'.  Collapse character
+	kind checking to one location.
+	(gfc_match_allocate): Use correct locus in error message.
+
 2010-10-30  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
 	* gfortran.h (gfc_option_t):  Replace dump_parse_tree by

gcc/fortran/match.c

@@ -2711,26 +2711,25 @@ gfc_free_alloc_list (gfc_alloc *p)
 static match
 match_derived_type_spec (gfc_typespec *ts)
 {
+  char name[GFC_MAX_SYMBOL_LEN + 1];
   locus old_locus; 
   gfc_symbol *derived;
 
-  old_locus = gfc_current_locus; 
+  old_locus = gfc_current_locus;
 
-  if (gfc_match_symbol (&derived, 1) == MATCH_YES)
+  if (gfc_match ("%n", name) != MATCH_YES)
     {
-      if (derived->attr.flavor == FL_DERIVED)
-	{
-	  ts->type = BT_DERIVED;
-	  ts->u.derived = derived;
-	  return MATCH_YES;
-	}
-      else
-	{
-	  /* Enforce F03:C476.  */
-	  gfc_error ("'%s' at %L is not an accessible derived type",
-		     derived->name, &gfc_current_locus);
-	  return MATCH_ERROR;
-	}
+       gfc_current_locus = old_locus;
+       return MATCH_NO;
+    }
+
+  gfc_find_symbol (name, NULL, 1, &derived);
+
+  if (derived && derived->attr.flavor == FL_DERIVED)
+    {
+      ts->type = BT_DERIVED;
+      ts->u.derived = derived;
+      return MATCH_YES;
     }
 
   gfc_current_locus = old_locus; 
@@ -2752,17 +2751,12 @@ match_type_spec (gfc_typespec *ts)
   locus old_locus;
 
   gfc_clear_ts (ts);
-  gfc_gobble_whitespace();
+  gfc_gobble_whitespace ();
   old_locus = gfc_current_locus;
 
-  m = match_derived_type_spec (ts);
-  if (m == MATCH_YES)
+  if (match_derived_type_spec (ts) == MATCH_YES)
     {
-      old_locus = gfc_current_locus;
-      if (gfc_match (" :: ") != MATCH_YES)
-	return MATCH_ERROR;
-      gfc_current_locus = old_locus;
-      /* Enfore F03:C401.  */
+      /* Enforce F03:C401.  */
       if (ts->u.derived->attr.abstract)
 	{
 	  gfc_error ("Derived type '%s' at %L may not be ABSTRACT",
@@ -2771,10 +2765,6 @@ match_type_spec (gfc_typespec *ts)
 	}
       return MATCH_YES;
     }
-  else if (m == MATCH_ERROR && gfc_match (" :: ") == MATCH_YES)
-    return MATCH_ERROR;
-
-  gfc_current_locus = old_locus;
 
   if (gfc_match ("integer") == MATCH_YES)
     {
@@ -2807,7 +2797,13 @@ match_type_spec (gfc_typespec *ts)
   if (gfc_match ("character") == MATCH_YES)
     {
       ts->type = BT_CHARACTER;
-      goto char_selector;
+
+      m = gfc_match_char_spec (ts);
+
+      if (m == MATCH_NO)
+	m = MATCH_YES;
+
+      return m;
     }
 
   if (gfc_match ("logical") == MATCH_YES)
@@ -2836,15 +2832,6 @@ kind_selector:
     m = MATCH_YES;		/* No kind specifier found.  */
 
   return m;
-
-char_selector:
-
-  m = gfc_match_char_spec (ts);
-
-  if (m == MATCH_NO)
-    m = MATCH_YES;		/* No kind specifier found.  */
-
-  return m;
 }
 
 
@@ -2874,7 +2861,17 @@ gfc_match_allocate (void)
   if (m == MATCH_ERROR)
     goto cleanup;
   else if (m == MATCH_NO)
-    ts.type = BT_UNKNOWN;
+    {
+      char name[GFC_MAX_SYMBOL_LEN + 3];
+
+      if (gfc_match ("%n :: ", name) == MATCH_YES)
+	{
+	  gfc_error ("Error in type-spec at %L", &old_locus);
+	  goto cleanup;
+	}
+
+      ts.type = BT_UNKNOWN;
+    }
   else
     {
       if (gfc_match (" :: ") == MATCH_YES)
@@ -2957,8 +2954,8 @@ gfc_match_allocate (void)
 		|| sym->ns->proc_name->attr.proc_pointer);
       if (b1 && b2 && !b3)
 	{
-	  gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
-		     "or an allocatable variable");
+	  gfc_error ("Allocate-object at %L is not a nonprocedure pointer "
+		     "or an allocatable variable", &tail->expr->where);
 	  goto cleanup;
 	}
 

gcc/testsuite/ChangeLog

+2010-11-01  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/46152
+	* gfortran.dg/select_type_11.f03: Update dg-error phrase.
+	* gfortran.dg/allocate_with_typespec_4.f90: New test.
+	* gfortran.dg/allocate_with_typespec_1.f90: New test.
+	* gfortran.dg/allocate_with_typespec_2.f: New test.
+	* gfortran.dg/allocate_with_typespec_3.f90: New test.
+	* gfortran.dg/allocate_derived_1.f90: Update dg-error phrase.
+	* gfortran.dg/select_type_1.f03: Update dg-error phrase.
+
 2010-11-01  H.J. Lu  <hongjiu.lu@intel.com>
 	    Nathan Froyd  <froydnj@codesourcery.com>
 

gcc/testsuite/gfortran.dg/allocate_derived_1.f90

@@ -32,7 +32,7 @@
  allocate(t1 :: x(2))
  allocate(t2 :: x(3))
  allocate(t3 :: x(4))
- allocate(tx :: x(5))  ! { dg-error "is not an accessible derived type" }
+ allocate(tx :: x(5))  ! { dg-error "Error in type-spec at" }
  allocate(u0 :: x(6))  ! { dg-error "may not be ABSTRACT" }
  allocate(v1 :: x(7))  ! { dg-error "is type incompatible with typespec" }
 

gcc/testsuite/gfortran.dg/allocate_with_typespec_1.f90

+! { dg-do compile }
+!
+! Allocation of arrays with a type-spec specification with implicit none.
+!
+subroutine implicit_none_test1
+
+   implicit none
+
+   real, allocatable :: x(:)
+   real(4), allocatable :: x4(:)
+   real(8), allocatable :: x8(:)
+   double precision, allocatable :: d1(:)
+   doubleprecision, allocatable :: d2(:)
+   character, allocatable :: c1(:)
+   character(len=4), allocatable :: c2(:)
+
+   type a
+      integer mytype
+   end type a
+
+   type(a), allocatable :: b(:)
+
+   allocate(real :: x(1))
+   allocate(real(4) :: x4(1))
+   allocate(real(8) :: x8(1))
+   allocate(double precision :: d1(1))
+   allocate(doubleprecision :: d2(1))
+   allocate(character :: c1(1))
+   allocate(character(len=4) :: c2(1))
+   allocate(a :: b(1))
+
+end subroutine implicit_none_test1
+!
+! Allocation of a scalar with a type-spec specification with implicit none
+!
+subroutine implicit_none_test2
+
+   implicit none
+
+   real, allocatable :: x
+   real(4), allocatable :: x4
+   real(8), allocatable :: x8
+   double precision, allocatable :: d1
+   doubleprecision, allocatable :: d2
+   character, allocatable :: c1
+   character(len=4), allocatable :: c2
+
+   type a
+      integer mytype
+   end type a
+
+   type(a), allocatable :: b
+
+   allocate(real :: x)
+   allocate(real(4) :: x4)
+   allocate(real(8) :: x8)
+   allocate(double precision :: d1)
+   allocate(doubleprecision :: d2)
+   allocate(character :: c1)
+   allocate(character(len=4) :: c2)
+   allocate(a :: b)
+
+end subroutine implicit_none_test2
+!
+! Allocation of arrays with a type-spec specification with implicit none.
+!
+subroutine implicit_test3
+
+   real, allocatable :: x(:)
+   real(4), allocatable :: x4(:)
+   real(8), allocatable :: x8(:)
+   double precision, allocatable :: d1(:)
+   doubleprecision, allocatable :: d2(:)
+   character, allocatable :: c1(:)
+   character(len=4), allocatable :: c2(:)
+
+   type a
+      integer mytype
+   end type a
+
+   type(a), allocatable :: b(:)
+
+   allocate(real :: x(1))
+   allocate(real(4) :: x4(1))
+   allocate(real(8) :: x8(1))
+   allocate(double precision :: d1(1))
+   allocate(doubleprecision :: d2(1))
+   allocate(character :: c1(1))
+   allocate(character(len=4) :: c2(1))
+   allocate(a :: b(1))
+
+end subroutine implicit_test3
+!
+! Allocation of a scalar with a type-spec specification without implicit none
+!
+subroutine implicit_test4
+
+   real, allocatable :: x
+   real(4), allocatable :: x4
+   real(8), allocatable :: x8
+   double precision, allocatable :: d1
+   doubleprecision, allocatable :: d2
+   character, allocatable :: c1
+   character(len=4), allocatable :: c2
+
+   type a
+      integer mytype
+   end type a
+
+   type(a), allocatable :: b
+
+   allocate(real :: x)
+   allocate(real(4) :: x4)
+   allocate(real(8) :: x8)
+   allocate(double precision :: d1)
+   allocate(doubleprecision :: d2)
+   allocate(character :: c1)
+   allocate(character(len=4) :: c2)
+   allocate(a :: b)
+
+end subroutine implicit_test4

gcc/testsuite/gfortran.dg/allocate_with_typespec_2.f

+C { dg-do compile }
+C
+C Allocation of arrays with a type-spec specification with implicit none.
+C
+       subroutine implicit_none_test1
+
+          implicit none
+
+          real, allocatable :: x(:)
+          real(4), allocatable :: x4(:)
+          real(8), allocatable :: x8(:)
+          double precision, allocatable :: d1(:)
+          doubleprecision, allocatable :: d2(:)
+          character, allocatable :: c1(:)
+          character(len=4), allocatable :: c2(:)
+
+          type a
+             integer mytype
+          end type a
+
+          type(a), allocatable :: b(:)
+
+          allocate(real :: x(1))
+          allocate(real(4) :: x4(1))
+          allocate(real(8) :: x8(1))
+          allocate(double precision :: d1(1))
+          allocate(doubleprecision :: d2(1))
+          allocate(character :: c1(1))
+          allocate(character(len=4) :: c2(1))
+          allocate(a :: b(1))
+
+       end
+C
+C Allocation of a scalar with a type-spec specification with implicit none
+C
+       subroutine implicit_none_test2
+
+          implicit none
+
+          real, allocatable :: x
+          real(4), allocatable :: x4
+          real(8), allocatable :: x8
+          double precision, allocatable :: d1
+          doubleprecision, allocatable :: d2
+          character, allocatable :: c1
+          character(len=4), allocatable :: c2
+
+          type a
+             integer mytype
+          end type a
+
+          type(a), allocatable :: b
+
+          allocate(real :: x)
+          allocate(real(4) :: x4)
+          allocate(real(8) :: x8)
+          allocate(double precision :: d1)
+          allocate(doubleprecision :: d2)
+          allocate(character :: c1)
+          allocate(character(len=4) :: c2)
+          allocate(a :: b)
+
+       end subroutine implicit_none_test2
+C
+C Allocation of arrays with a type-spec specification with implicit none.
+C
+       subroutine implicit_test3
+
+          real, allocatable :: x(:)
+          real(4), allocatable :: x4(:)
+          real(8), allocatable :: x8(:)
+          double precision, allocatable :: d1(:)
+          doubleprecision, allocatable :: d2(:)
+          character, allocatable :: c1(:)
+          character(len=4), allocatable :: c2(:)
+
+          type a
+             integer mytype
+          end type a
+
+          type(a), allocatable :: b(:)
+
+          allocate(real :: x(1))
+          allocate(real(4) :: x4(1))
+          allocate(real(8) :: x8(1))
+          allocate(double precision :: d1(1))
+          allocate(doubleprecision :: d2(1))
+          allocate(character :: c1(1))
+          allocate(character(len=4) :: c2(1))
+          allocate(a :: b(1))
+
+       end
+C
+C Allocation of a scalar with a type-spec specification without implicit none
+C
+       subroutine implicit_test4
+
+          real, allocatable :: x
+          real(4), allocatable :: x4
+          real(8), allocatable :: x8
+          double precision, allocatable :: d1
+          doubleprecision, allocatable :: d2
+          character, allocatable :: c1
+          character(len=4), allocatable :: c2
+
+          type a
+             integer mytype
+          end type a
+
+          type(a), allocatable :: b
+
+          allocate(real :: x)
+          allocate(real(4) :: x4)
+          allocate(real(8) :: x8)
+          allocate(double precision :: d1)
+          allocate(doubleprecision :: d2)
+          allocate(character :: c1)
+          allocate(character(len=4) :: c2)
+          allocate(a :: b)
+
+       end

gcc/testsuite/gfortran.dg/allocate_with_typespec_3.f90

+! { dg-do compile }
+!
+! Allocation of arrays with a type-spec specification with implicit none.
+!
+subroutine implicit_none_test1
+
+   implicit none
+
+   real, allocatable :: x(:)
+   real(4), allocatable :: x4(:)
+   real(8), allocatable :: x8(:)
+   double precision, allocatable :: d1(:)
+   doubleprecision, allocatable :: d2(:)
+   character, allocatable :: c1(:)
+
+   type a
+      integer mytype
+   end type a
+
+   type(a), allocatable :: b(:)
+
+   allocate(complex :: x(1))       ! { dg-error "is type incompatible" }
+   allocate(real(8) :: x4(1))      ! { dg-error "differs from the kind type parameter" }
+   allocate(real(4) :: x8(1))      ! { dg-error "differs from the kind type parameter" }
+   allocate(double :: d1(1))       ! { dg-error "Error in type-spec at" }
+   allocate(character(:) :: c1(1)) ! { dg-error "Syntax error in CHARACTER declaration" }
+   allocate(real :: b(1))          ! { dg-error "is type incompatible" }
+
+end subroutine implicit_none_test1
+!
+! Allocation of a scalar with a type-spec specification with implicit none
+!
+subroutine implicit_none_test2
+
+   implicit none
+
+   real, allocatable :: x
+   real(4), allocatable :: x4
+   real(8), allocatable :: x8
+   double precision, allocatable :: d1
+   character, allocatable :: c1
+
+   type a
+      integer mytype
+   end type a
+
+   type(a), allocatable :: b
+
+   allocate(complex :: x)       ! { dg-error "is type incompatible" }
+   allocate(real(8) :: x4)      ! { dg-error "differs from the kind type parameter" }
+   allocate(real(4) :: x8)      ! { dg-error "differs from the kind type parameter" }
+   allocate(double :: d1)       ! { dg-error "Error in type-spec at" }
+   allocate(character(:) :: c1) ! { dg-error "Syntax error in CHARACTER declaration" }
+   allocate(real :: b)          ! { dg-error "is type incompatible" }
+
+end subroutine implicit_none_test2
+!
+! Allocation of arrays with a type-spec specification with implicit none.
+!
+subroutine implicit_test3
+
+   real, allocatable :: x(:)
+   real(4), allocatable :: x4(:)
+   real(8), allocatable :: x8(:)
+   double precision, allocatable :: d1(:)
+   doubleprecision, allocatable :: d2(:)
+   character, allocatable :: c1(:)
+
+   type a
+      integer mytype
+   end type a
+
+   type(a), allocatable :: b(:)
+
+   allocate(complex :: x(1))       ! { dg-error "is type incompatible" }
+   allocate(real(8) :: x4(1))      ! { dg-error "differs from the kind type parameter" }
+   allocate(real(4) :: x8(1))      ! { dg-error "differs from the kind type parameter" }
+   allocate(double :: d1(1))       ! { dg-error "Error in type-spec" }
+   allocate(character(:) :: c1(1)) ! { dg-error "Syntax error in CHARACTER declaration" }
+   allocate(real :: b(1))          ! { dg-error "is type incompatible" }
+
+end subroutine implicit_test3
+!
+! Allocation of a scalar with a type-spec specification without implicit none
+!
+subroutine implicit_test4
+
+   real, allocatable :: x
+   real(4), allocatable :: x4
+   real(8), allocatable :: x8
+   double precision, allocatable :: d1
+   character, allocatable :: c1
+
+   type a
+      integer mytype
+   end type a
+
+   type(a), allocatable :: b
+
+   allocate(complex :: x)       ! { dg-error "is type incompatible" }
+   allocate(real(8) :: x4)      ! { dg-error "differs from the kind type parameter" }
+   allocate(real(4) :: x8)      ! { dg-error "differs from the kind type parameter" }
+   allocate(double :: d1)       ! { dg-error "Error in type-spec at" }
+   allocate(character(:) :: c1) ! { dg-error "Syntax error in CHARACTER declaration" }
+   allocate(real :: b)          ! { dg-error "is type incompatible" }
+
+end subroutine implicit_test4

gcc/testsuite/gfortran.dg/allocate_with_typespec_4.f90

+! { dg-do compile }
+! { dg-options "-w" }
+subroutine not_an_f03_intrinsic
+
+   implicit none
+
+   byte, allocatable :: x, y(:)
+   real*8, allocatable :: x8, y8(:)
+   double complex :: z
+
+   type real_type
+      integer mytype
+   end type real_type
+
+   type(real_type), allocatable :: b, c(:)
+
+   allocate(byte :: x)            ! { dg-error "Error in type-spec at" }
+   allocate(byte :: y(1))         ! { dg-error "Error in type-spec at" }
+
+   allocate(real*8 :: x)          ! { dg-error "Invalid type-spec at" }
+   allocate(real*8 :: y(1))       ! { dg-error "Invalid type-spec at" }
+   allocate(real*4 :: x8)         ! { dg-error "Invalid type-spec at" }
+   allocate(real*4 :: y8(1))      ! { dg-error "Invalid type-spec at" }
+   allocate(double complex :: d1) ! { dg-error "not a nonprocedure pointer or an allocatable" }
+   allocate(real_type :: b)
+   allocate(real_type :: c(1))
+
+end subroutine not_an_f03_intrinsic

gcc/testsuite/gfortran.dg/select_type_1.f03

@@ -45,7 +45,7 @@
     print *,"a is TYPE(ts)"
   type is (t3)   ! { dg-error "must be an extension of" }
     print *,"a is TYPE(t3)"
-  type is (t4)   ! { dg-error "is not an accessible derived type" }
+  type is (t4)   ! { dg-error "error in TYPE IS specification" }
     print *,"a is TYPE(t3)"
   class is (t1)
     print *,"a is CLASS(t1)"

gcc/testsuite/gfortran.dg/select_type_11.f03

@@ -19,7 +19,7 @@ contains
     class(vector_class),        intent(in)    :: v
 
     select type (v)
-    class is (bad_id)                    ! { dg-error "is not an accessible derived type" }
+    class is (bad_id)                    ! { dg-error " error in CLASS IS specification" }
        this%elements(:) = v%elements(:)  ! { dg-error "is not a member of" }
     end select