Re: [Patch, Fortran] PR 41580 Add compile-time simplification for Same_Type_As and Extends_Type_Of

[Tobias Burnus <burnus at net-b dot de>]

Hello Janus,

On 01/07/2011 02:03 PM, Janus Weil wrote:
> Some comments:
> 3) Could you expand a bit on why a BT_DERIVED would be simplified to
> .false.? I don't quite get that part ...

You mean the vtab part? Well, currently, for BT_CLASS one calls 
resolve_function. Via resolve_intrinsic the simplify function is first 
called - and as both arguments are BT_CLASS, "NULL" is returned.* Then 
one calls resolve_unknown_f, which via gfc_intrinsic_func_interface 
resolves the arguments - that is it replaces the variables of type 
BT_CLASS by the vtab entries which are of type BT_DERIVED. Afterwards, 
the gfc_simplify_{same_type_as,extends_type_of} function is called 
again. As then the arguments are BT_DERIVED and not BT_CLASS, they can 
directly be evaluated at compile time - and as the two vtab variable 
references are (usually) different, the result is (usually) false. -- 
Thus, one needs to exit if the arguments are already resolved to vtabs.

* For BT_CLASS a NULL is only returned if the types have the chance to 
be the same. Thus, if they have neither the same declared type nor one 
declared-type is the supertype of the other, one knows that the answer 
must be .FALSE., which is what the patch does.

Tobias
2011-01-07  Tobias Burnus  <burnus@net-b.de>

	PR fortran/41580
	* class.c (gfc_build_class_symbol): Mark __vtab as attr.vtab.
	* intrinsic.c (add_functions): Use simplify functions for
	EXTENDS_TYPE_OF and SAME_TYPE_AS.
	* intrinsic.h (gfc_simplify_extends_type_of,
	gfc_simplify_same_type_as): New prototypes.
	* simplify.c (is_last_ref_vtab, gfc_simplify_extends_type_of,
        gfc_simplify_same_type_as): New functions.

2011-01-07  Tobias Burnus  <burnus@net-b.de>

	PR fortran/41580
	* gfortran.dg/extends_type_of_3.f90: New.

diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index d17544c..9458ca9 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -1,7 +1,7 @@
 /* Build up a list of intrinsic subroutines and functions for the
    name-resolution stage.
    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-   2009, 2010
+   2009, 2010, 2011
    Free Software Foundation, Inc.
    Contributed by Andy Vaught & Katherine Holcomb
 
@@ -1663,7 +1663,8 @@ add_functions (void)
 
   add_sym_2 ("extends_type_of", GFC_ISYM_EXTENDS_TYPE_OF, CLASS_INQUIRY,
 	     ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003,
-	     gfc_check_same_type_as, NULL, gfc_resolve_extends_type_of,
+	     gfc_check_same_type_as, gfc_simplify_extends_type_of,
+	     gfc_resolve_extends_type_of,
 	     a, BT_UNKNOWN, 0, REQUIRED,
 	     mo, BT_UNKNOWN, 0, REQUIRED);
 
@@ -2481,7 +2482,7 @@ add_functions (void)
 
   add_sym_2 ("same_type_as", GFC_ISYM_SAME_TYPE_AS, CLASS_INQUIRY, ACTUAL_NO,
 	     BT_LOGICAL, dl, GFC_STD_F2003,
-	     gfc_check_same_type_as, NULL, NULL,
+	     gfc_check_same_type_as, gfc_simplify_same_type_as, NULL,
 	     a, BT_UNKNOWN, 0, REQUIRED,
 	     b, BT_UNKNOWN, 0, REQUIRED);
 
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index e9574e8..540cc8e 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -1,7 +1,7 @@
 /* Header file for intrinsics check, resolve and simplify function
    prototypes.
    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
-   2010 Free Software Foundation, Inc.
+   2010, 2011 Free Software Foundation, Inc.
    Contributed by Andy Vaught & Katherine Holcomb
 
 This file is part of GCC.
@@ -267,6 +267,7 @@ gfc_expr *gfc_simplify_erfc (gfc_expr *);
 gfc_expr *gfc_simplify_erfc_scaled (gfc_expr *);
 gfc_expr *gfc_simplify_exp (gfc_expr *);
 gfc_expr *gfc_simplify_exponent (gfc_expr *);
+gfc_expr *gfc_simplify_extends_type_of (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_float (gfc_expr *);
 gfc_expr *gfc_simplify_floor (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_fraction (gfc_expr *);
@@ -351,6 +352,7 @@ gfc_expr *gfc_simplify_reshape (gfc_expr *, gfc_expr *, gfc_expr *,
 				gfc_expr *);
 gfc_expr *gfc_simplify_rrspacing (gfc_expr *);
 gfc_expr *gfc_simplify_rshift (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_same_type_as (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_scale (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_scan (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_selected_char_kind (gfc_expr *);
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index e45ed40..3beac15 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -1,6 +1,6 @@
 /* Simplify intrinsic functions at compile-time.
    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
-   2010 Free Software Foundation, Inc.
+   2010, 2011 Free Software Foundation, Inc.
    Contributed by Andy Vaught & Katherine Holcomb
 
 This file is part of GCC.
@@ -2202,6 +2202,93 @@ gfc_simplify_float (gfc_expr *a)
 }
 
 
+static bool
+is_last_ref_vtab (gfc_expr *e)
+{
+  gfc_ref *ref;
+  gfc_component *comp = NULL;
+
+  if (e->expr_type != EXPR_VARIABLE)
+    return false;
+
+  for (ref = e->ref; ref; ref = ref->next)
+    if (ref->type == REF_COMPONENT)
+      comp = ref->u.c.component;
+
+  if (!e->ref || !comp)
+    return e->symtree->n.sym->attr.vtab;
+
+  if (comp->name[0] == '_' && strcmp (comp->name, "_vptr") == 0)
+    return true;
+
+  return false;
+}
+
+
+gfc_expr *
+gfc_simplify_extends_type_of (gfc_expr *a, gfc_expr *mold)
+{
+  /* Avoid simplification of resolved symbols.  */
+  if (is_last_ref_vtab (a) || is_last_ref_vtab (mold))
+    return NULL;
+
+  if (a->ts.type == BT_DERIVED && mold->ts.type == BT_DERIVED)
+    return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
+				 gfc_type_is_extension_of (mold->ts.u.derived,
+							   a->ts.u.derived));
+  /* Return .false. if the dynamic type can never be the same.  */
+  if ((a->ts.type == BT_CLASS && mold->ts.type == BT_CLASS
+       && !gfc_type_is_extension_of
+			(mold->ts.u.derived->components->ts.u.derived,
+			 a->ts.u.derived->components->ts.u.derived)
+       && !gfc_type_is_extension_of
+			(a->ts.u.derived->components->ts.u.derived,
+			 mold->ts.u.derived->components->ts.u.derived))
+      || (a->ts.type == BT_DERIVED && mold->ts.type == BT_CLASS
+	  && !gfc_type_is_extension_of
+			(a->ts.u.derived,
+			 mold->ts.u.derived->components->ts.u.derived)
+	  && !gfc_type_is_extension_of
+			(mold->ts.u.derived->components->ts.u.derived,
+			 a->ts.u.derived))
+      || (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED
+	  && !gfc_type_is_extension_of
+			(mold->ts.u.derived,
+			 a->ts.u.derived->components->ts.u.derived)))
+    return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
+
+  if (mold->ts.type == BT_DERIVED
+      && gfc_type_is_extension_of (mold->ts.u.derived,
+				   a->ts.u.derived->components->ts.u.derived))
+    return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, true);
+
+  return NULL;
+}
+
+
+gfc_expr *
+gfc_simplify_same_type_as (gfc_expr *a, gfc_expr *b)
+{
+  /* Avoid simplification of resolved symbols.  */
+  if (is_last_ref_vtab (a) || is_last_ref_vtab (b))
+    return NULL;
+
+  /* Return .false. if the dynamic type can never be the
+     same.  */
+  if ((a->ts.type == BT_CLASS || b->ts.type == BT_CLASS)
+      && !gfc_type_compatible (&a->ts, &b->ts)
+      && !gfc_type_compatible (&b->ts, &a->ts))
+    return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
+
+  if (a->ts.type != BT_DERIVED || b->ts.type != BT_DERIVED)
+     return NULL;
+
+  return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
+			       gfc_compare_derived_types (a->ts.u.derived,
+							  b->ts.u.derived));
+}
+
+
 gfc_expr *
 gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
 {
diff --git a/gcc/testsuite/gfortran.dg/extends_type_of_3.f90 b/gcc/testsuite/gfortran.dg/extends_type_of_3.f90
new file mode 100644
index 0000000..346542f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/extends_type_of_3.f90
@@ -0,0 +1,111 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! PR fortran/41580
+!
+! Compile-time simplification of SAME_TYPE_AS
+! and EXTENDS_TYPE_OF.
+!
+
+implicit none
+type t1
+  integer :: a
+end type t1
+type, extends(t1):: t11
+  integer :: b
+end type t11
+type, extends(t11):: t111
+  integer :: c
+end type t111
+type t2
+  integer :: a
+end type t2
+
+type(t1) a1
+type(t11) a11
+type(t2) a2
+class(t1), allocatable :: b1
+class(t11), allocatable :: b11
+class(t2), allocatable :: b2
+
+logical, parameter :: p1 = same_type_as(a1,a2)  ! F
+logical, parameter :: p2 = same_type_as(a2,a1)  ! F
+logical, parameter :: p3 = same_type_as(a1,a11) ! F
+logical, parameter :: p4 = same_type_as(a11,a1) ! F
+logical, parameter :: p5 = same_type_as(a11,a11)! T
+logical, parameter :: p6 = same_type_as(a1,a1)  ! T
+
+if (p1 .or. p2 .or. p3 .or. p4 .or. .not. p5 .or. .not. p6) call should_not_exist()
+
+! Not (trivially) compile-time simplifiable:
+if (same_type_as(b1,a1)  .neqv. .true.) call abort()
+if (same_type_as(b1,a11) .neqv. .false.) call abort()
+allocate(t1 :: b1)
+if (same_type_as(b1,a1)  .neqv. .true.) call abort()
+if (same_type_as(b1,a11) .neqv. .false.) call abort()
+deallocate(b1)
+allocate(t11 :: b1)
+if (same_type_as(b1,a1)  .neqv. .false.) call abort()
+if (same_type_as(b1,a11) .neqv. .true.) call abort()
+deallocate(b1)
+
+! .true. -> same type
+if (extends_type_of(a1,a1)   .neqv. .true.) call should_not_exist()
+if (extends_type_of(a11,a11) .neqv. .true.) call should_not_exist()
+if (extends_type_of(a2,a2)   .neqv. .true.) call should_not_exist()
+
+! .false. -> type compatibility possible
+if (extends_type_of(a1,a2)  .neqv. .false.) call should_not_exist()
+if (extends_type_of(a2,a1)  .neqv. .false.) call should_not_exist()
+if (extends_type_of(a11,a2) .neqv. .false.) call should_not_exist()
+if (extends_type_of(a2,a11) .neqv. .false.) call should_not_exist()
+
+if (extends_type_of(b1,b2)  .neqv. .false.) call should_not_exist()
+if (extends_type_of(b2,b1)  .neqv. .false.) call should_not_exist()
+if (extends_type_of(b11,b2) .neqv. .false.) call should_not_exist()
+if (extends_type_of(b2,b11) .neqv. .false.) call should_not_exist()
+
+if (extends_type_of(b1,a2)  .neqv. .false.) call should_not_exist()
+if (extends_type_of(b2,a1)  .neqv. .false.) call should_not_exist()
+if (extends_type_of(b11,a2) .neqv. .false.) call should_not_exist()
+if (extends_type_of(b2,a11) .neqv. .false.) call should_not_exist()
+
+if (extends_type_of(a1,b2)  .neqv. .false.) call should_not_exist()
+if (extends_type_of(a2,b1)  .neqv. .false.) call should_not_exist()
+if (extends_type_of(a11,b2) .neqv. .false.) call should_not_exist()
+if (extends_type_of(a2,b11) .neqv. .false.) call should_not_exist()
+
+! type extension possible, compile-time checkable
+if (extends_type_of(a1,a11) .neqv. .false.) call should_not_exist()
+if (extends_type_of(a11,a1) .neqv. .true.) call should_not_exist()
+if (extends_type_of(a1,a11) .neqv. .false.) call should_not_exist()
+
+if (extends_type_of(b1,a1)   .neqv. .true.) call should_not_exist()
+if (extends_type_of(b11,a1)  .neqv. .true.) call should_not_exist()
+if (extends_type_of(b11,a11) .neqv. .true.) call should_not_exist()
+if (extends_type_of(b1,a11)  .neqv. .false.) call should_not_exist()
+
+if (extends_type_of(a1,b11)  .neqv. .false.) call abort()
+
+! Special case, simplified at tree folding:
+if (extends_type_of(b1,b1)   .neqv. .true.) call abort()
+
+! All other possibilities are not compile-time checkable
+if (extends_type_of(b11,b1)  .neqv. .true.) call abort()
+!if (extends_type_of(b1,b11)  .neqv. .false.) call abort() ! FAILS due to PR 47189
+if (extends_type_of(a11,b11) .neqv. .true.) call abort()
+allocate(t11 :: b11)
+if (extends_type_of(a11,b11) .neqv. .true.) call abort()
+deallocate(b11)
+allocate(t111 :: b11)
+if (extends_type_of(a11,b11) .neqv. .false.) call abort()
+deallocate(b11)
+allocate(t11 :: b1)
+if (extends_type_of(a11,b1) .neqv. .true.) call abort()
+deallocate(b1)
+
+end
+
+! { dg-final { scan-tree-dump-times "abort" 13 "original" } }
+! { dg-final { scan-tree-dump-times "should_not_exist" 0 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }