re PR fortran/41580 ([OOP] SAME_TYPE_AS and EXTENDS_TYPE_OF - add compile-time simpli...

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.

From-SVN: r168579

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index aadd14326d91a9988125d64818a8b0030ec7947d..57b071007098d856a92ea4388d7912f20a19dcad 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,14 @@
+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  Janus Weil  <janus@gcc.gnu.org>
 
        PR fortran/47189

diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index d17544c74b0d3b2c2b814c5e3049f9a24a851209..9458ca948f167cbf195f672b03b532f2a8ac3f7f 100644 (file)
--- 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 e9574e8a0e51fd40b953993157d02ac45eb7f128..540cc8ebbf7ffff2a1f0c19e80f741d0c09e23f2 100644 (file)
--- 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 e45ed401085ffd37d4612002b41c5795b6daf1e4..3beac15177cb9a5f70691ebe70943155ccc41804 100644 (file)
--- 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/ChangeLog b/gcc/testsuite/ChangeLog
index c95b4db20238d69793591fc84c9c3b3733801363..8ffb04983c42db07c4a162c7e3e29591acc43306 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2011-01-07  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/41580
+       * gfortran.dg/extends_type_of_3.f90: New.
+
 2011-01-07  Kai Tietz  <kai.tietz@onevision.com>
 
        * g++.dg/ext/dllexport-MI1.C: Adjust test.

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 (file)
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" } }