diff mbox

[Fortran] PR 41580 Add compile-time simplification for Same_Type_As and Extends_Type_Of

Message ID 4D27066B.2070103@net-b.de
State New
Headers show

Commit Message

Tobias Burnus Jan. 7, 2011, 12:26 p.m. UTC 
This patch adds support for Same_Type_As and Extends_Type_Of; the patch 
is relatively straight forward, except that after gfc_resolve_* the 
simplify functions are called again - thus one needs to exit early 
otherwise the BT_DERIVED (as the vtab is internally represented) is 
simplified to .FALSE.

Build and regtested on x86-64-linux.
OK for the trunk? -- If so, which one: 4.6 or 4.7?

Tobias

Comments

Janus Weil Jan. 7, 2011, 1:03 p.m. UTC | #1 
Hi Tobias,

> This patch adds support for Same_Type_As and Extends_Type_Of; the patch is
> relatively straight forward, except that after gfc_resolve_* the simplify
> functions are called again - thus one needs to exit early otherwise the
> BT_DERIVED (as the vtab is internally represented) is simplified to .FALSE.
>
> Build and regtested on x86-64-linux.
> OK for the trunk? -- If so, which one: 4.6 or 4.7?

I think in principle your patch is ok, and I would like to see it in 4.6.

Some comments:

1) I don't particularly like the following part:

@@ -240,6 +240,7 @@ gfc_build_class_symbol (gfc_typespec *ts,
symbol_attribute *attr,
 	}
       c->attr.access = ACCESS_PRIVATE;
       c->attr.pointer = 1;
+      c->attr.vtab = 1;
     }


Up to now we are using the "vtab" attribute to indicate that a symbol
is a vtable entry for a particular type. Now here you use it to mark a
"_vptr" component of a class container, which is a different thing (it
usually *points* to a vtab), and I'm not sure if this mix-up could
create problems somehow.

If you want to check for a _vptr component, you could just check for
the name (I think I've also been doing this in a recent patch).


2) A very minor thing: I think "DONT_EXISTS" is not a very
grammatically correct name for a subroutine. Not that subroutine names
are required to be grammatically correct in any Fortran standard I
know of, but I just stumbled over it ;)


3) Could you expand a bit on why a BT_DERIVED would be simplified to
.false.? I don't quite get that part ...


Thanks for working on this!

Cheers,
Janus
diff mbox

Patch

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/class.c b/gcc/fortran/class.c
index 7095d3e..d6a55b0 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -1,5 +1,5 @@ 
 /* Implementation of Fortran 2003 Polymorphism.
-   Copyright (C) 2009, 2010
+   Copyright (C) 2009, 2010, 2011
    Free Software Foundation, Inc.
    Contributed by Paul Richard Thomas <pault@gcc.gnu.org>
    and Janus Weil <janus@gcc.gnu.org>
@@ -240,6 +240,7 @@  gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
 	}
       c->attr.access = ACCESS_PRIVATE;
       c->attr.pointer = 1;
+      c->attr.vtab = 1;
     }
 
   /* Since the extension field is 8 bit wide, we can only have
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..6150c63 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,90 @@  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;
+
+  return comp->attr.vtab;    
+}
+
+
+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..426de75
--- /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 dont_exists()
+
+! 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 dont_exists()
+if (extends_type_of(a11,a11) .neqv. .true.) call dont_exists()
+if (extends_type_of(a2,a2)   .neqv. .true.) call dont_exists()
+
+! .false. -> type compatibility possible
+if (extends_type_of(a1,a2)  .neqv. .false.) call dont_exists()
+if (extends_type_of(a2,a1)  .neqv. .false.) call dont_exists()
+if (extends_type_of(a11,a2) .neqv. .false.) call dont_exists()
+if (extends_type_of(a2,a11) .neqv. .false.) call dont_exists()
+
+if (extends_type_of(b1,b2)  .neqv. .false.) call dont_exists()
+if (extends_type_of(b2,b1)  .neqv. .false.) call dont_exists()
+if (extends_type_of(b11,b2) .neqv. .false.) call dont_exists()
+if (extends_type_of(b2,b11) .neqv. .false.) call dont_exists()
+
+if (extends_type_of(b1,a2)  .neqv. .false.) call dont_exists()
+if (extends_type_of(b2,a1)  .neqv. .false.) call dont_exists()
+if (extends_type_of(b11,a2) .neqv. .false.) call dont_exists()
+if (extends_type_of(b2,a11) .neqv. .false.) call dont_exists()
+
+if (extends_type_of(a1,b2)  .neqv. .false.) call dont_exists()
+if (extends_type_of(a2,b1)  .neqv. .false.) call dont_exists()
+if (extends_type_of(a11,b2) .neqv. .false.) call dont_exists()
+if (extends_type_of(a2,b11) .neqv. .false.) call dont_exists()
+
+! type extension possible, compile-time checkable
+if (extends_type_of(a1,a11) .neqv. .false.) call dont_exists()
+if (extends_type_of(a11,a1) .neqv. .true.) call dont_exists()
+if (extends_type_of(a1,a11) .neqv. .false.) call dont_exists()
+
+if (extends_type_of(b1,a1)   .neqv. .true.) call dont_exists()
+if (extends_type_of(b11,a1)  .neqv. .true.) call dont_exists()
+if (extends_type_of(b11,a11) .neqv. .true.) call dont_exists()
+if (extends_type_of(b1,a11)  .neqv. .false.) call dont_exists()
+
+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 "dont_exists" 0 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }