re PR fortran/20373 (INTRINSIC symbols can be given the wrong type)

gcc/fortran:
2007-06-30  Daniel Franke  <franke.daniel@gmail.com>

	PR fortran/20373
	* intrinsic.c (add_functions): Additional function types.
	(gfc_convert_type_warn): Remove intrinsic-flag from conversion
	functions.
	* resolve.c (resolve_symbol): Added type checks to explicitly defined
	intrinsics.

gcc/testsuite:
2007-06-28  Daniel Franke  <franke.daniel@gmail.com>

	PR fortran/20373
	* gfortran.dg/intrinsic.f90: New test.

From-SVN: r126153

5 files changed, 85 insertions, 14 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 19ab391..7c0618d 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,12 @@
+2007-06-30  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/20373
+	* intrinsic.c (add_functions): Additional function types.
+	(gfc_convert_type_warn): Remove intrinsic-flag from
+	conversion functions.
+	* resolve.c (resolve_symbol): Added type checks to 
+	explicitly defined intrinsics.
+
 2007-06-30  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/32555
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 69d296a..7fbda18 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -1014,7 +1014,7 @@ add_functions (void)
 
   make_generic ("aint", GFC_ISYM_AINT, GFC_STD_F77);
 
-  add_sym_2 ("all", GFC_ISYM_ALL, NOT_ELEMENTAL, ACTUAL_NO, BT_UNKNOWN, 0, GFC_STD_F95,
+  add_sym_2 ("all", GFC_ISYM_ALL, NOT_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95,
 	     gfc_check_all_any, NULL, gfc_resolve_all,
 	     msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
 
@@ -1036,7 +1036,7 @@ add_functions (void)
 
   make_generic ("anint", GFC_ISYM_ANINT, GFC_STD_F77);
 
-  add_sym_2 ("any", GFC_ISYM_ANY, NOT_ELEMENTAL, ACTUAL_NO, BT_UNKNOWN, 0, GFC_STD_F95,
+  add_sym_2 ("any", GFC_ISYM_ANY, NOT_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95,
 	     gfc_check_all_any, NULL, gfc_resolve_any,
 	     msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
 
@@ -1310,7 +1310,7 @@ add_functions (void)
 
   make_generic ("dim", GFC_ISYM_DIM, GFC_STD_F77);
 
-  add_sym_2 ("dot_product", GFC_ISYM_DOT_PRODUCT, NOT_ELEMENTAL, ACTUAL_NO, BT_UNKNOWN, 0,
+  add_sym_2 ("dot_product", GFC_ISYM_DOT_PRODUCT, NOT_ELEMENTAL, ACTUAL_NO, BT_REAL, dr,
 	     GFC_STD_F95, gfc_check_dot_product, NULL, gfc_resolve_dot_product,
 	     va, BT_REAL, dr, REQUIRED, vb, BT_REAL, dr, REQUIRED);
 
@@ -1503,7 +1503,7 @@ add_functions (void)
 
   make_generic ("iand", GFC_ISYM_IAND, GFC_STD_F95);
 
-  add_sym_2 ("and", GFC_ISYM_AND, NOT_ELEMENTAL, ACTUAL_NO, BT_UNKNOWN, 0, GFC_STD_GNU,
+  add_sym_2 ("and", GFC_ISYM_AND, NOT_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_GNU,
 	     gfc_check_and, gfc_simplify_and, gfc_resolve_and,
 	     i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED);
 
@@ -1545,7 +1545,7 @@ add_functions (void)
 
   make_generic ("ieor", GFC_ISYM_IEOR, GFC_STD_F95);
 
-  add_sym_2 ("xor", GFC_ISYM_XOR, NOT_ELEMENTAL, ACTUAL_NO, BT_UNKNOWN, 0, GFC_STD_GNU,
+  add_sym_2 ("xor", GFC_ISYM_XOR, NOT_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_GNU,
 	     gfc_check_and, gfc_simplify_xor, gfc_resolve_xor,
 	     i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED);
 
@@ -1605,7 +1605,7 @@ add_functions (void)
 
   make_generic ("ior", GFC_ISYM_IOR, GFC_STD_F95);
 
-  add_sym_2 ("or", GFC_ISYM_OR, NOT_ELEMENTAL, ACTUAL_NO, BT_UNKNOWN, 0, GFC_STD_GNU,
+  add_sym_2 ("or", GFC_ISYM_OR, NOT_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_GNU,
 	     gfc_check_and, gfc_simplify_or, gfc_resolve_or,
 	     i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED);
 
@@ -2188,7 +2188,7 @@ add_functions (void)
 
   make_generic ("stat", GFC_ISYM_STAT, GFC_STD_GNU);
 
-  add_sym_3red ("sum", GFC_ISYM_SUM, NOT_ELEMENTAL, ACTUAL_NO, BT_UNKNOWN, 0, GFC_STD_F95,
+  add_sym_3red ("sum", GFC_ISYM_SUM, NOT_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
 		gfc_check_product_sum, NULL, gfc_resolve_sum,
 		ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
 		msk, BT_LOGICAL, dl, OPTIONAL);
@@ -3562,7 +3562,6 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag)
   new->symtree->n.sym->ts = *ts;
   new->symtree->n.sym->attr.flavor = FL_PROCEDURE;
   new->symtree->n.sym->attr.function = 1;
-  new->symtree->n.sym->attr.intrinsic = 1;
   new->symtree->n.sym->attr.elemental = 1;
   new->symtree->n.sym->attr.pure = 1;
   new->symtree->n.sym->attr.referenced = 1;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 8cc0c42..43711cd 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -6282,6 +6282,34 @@ resolve_symbol (gfc_symbol *sym)
      can.  */
   mp_flag = (sym->result != NULL && sym->result != sym);
 
+
+  /* Make sure that the intrinsic is consistent with its internal 
+     representation. This needs to be done before assigning a default 
+     type to avoid spurious warnings.  */
+  if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic)
+    {
+      if (gfc_intrinsic_name (sym->name, 0))
+	{
+	  if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising)
+	    gfc_warning ("Type specified for intrinsic function '%s' at %L is ignored",
+			 sym->name, &sym->declared_at);
+	}
+      else if (gfc_intrinsic_name (sym->name, 1))
+	{
+	  if (sym->ts.type != BT_UNKNOWN)
+	    {
+	      gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type specifier", 
+			 sym->name, &sym->declared_at);
+	      return;
+	    }
+	}
+      else
+	{
+	  gfc_error ("Intrinsic '%s' at %L does not exist", sym->name, &sym->declared_at);
+	  return;
+	}
+     }
+
   /* Assign default type to symbols that need one and don't have one.  */
   if (sym->ts.type == BT_UNKNOWN)
     {
@@ -6418,12 +6446,6 @@ resolve_symbol (gfc_symbol *sym)
       break;
     }
 
-  /* Make sure that intrinsic exist */
-  if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
-      && !gfc_intrinsic_name(sym->name, 0)
-      && !gfc_intrinsic_name(sym->name, 1))
-    gfc_error("Intrinsic at %L does not exist", &sym->declared_at);
-
   /* Resolve array specifier. Check as well some constraints
      on COMMON blocks.  */
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index d6a6dba..59237fa 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2007-06-30  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/20373
+	* gfortran.dg/intrinsic.f90: New test.
+
 2007-06-30  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/32555
diff --git a/gcc/testsuite/gfortran.dg/intrinsic.f90 b/gcc/testsuite/gfortran.dg/intrinsic.f90
new file mode 100644
index 0000000..8bb41fd
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/intrinsic.f90
@@ -0,0 +1,36 @@
+! { dg-do compile }
+! { dg-options "-c -Wall" }
+
+subroutine valid
+  intrinsic :: abs                 ! ok, intrinsic function
+  intrinsic :: cpu_time            ! ok, intrinsic subroutine
+end subroutine
+
+subroutine warnings
+  ! the follow three are ok in general, but ANY 
+  ! type is ignored, even the correct one
+  real, intrinsic :: sin           ! { dg-warning "is ignored" }
+
+  real :: asin                     ! { dg-warning "is ignored" }
+  intrinsic :: asin
+
+  intrinsic :: tan                 ! { dg-warning "is ignored" }
+  real :: tan
+
+  ! wrong types here
+  integer, intrinsic :: cos        ! { dg-warning "is ignored" }
+
+  integer :: acos                  ! { dg-warning "is ignored" }
+  intrinsic :: acos
+
+  ! ordering shall not matter
+  intrinsic :: atan                ! { dg-warning "is ignored" }
+  integer :: atan
+end subroutine
+
+subroutine errors
+  intrinsic :: foo                 ! { dg-error "does not exist" }
+  real, intrinsic :: bar           ! { dg-error "does not exist" }
+
+  real, intrinsic :: mvbits        ! { dg-error "shall not have a type" }
+end subroutine