From e079db8d5de396570c71a052e7cec3ff7e46f5ff Mon Sep 17 00:00:00 2001 From: burnus Date: Fri, 7 Jan 2011 16:19:29 +0000 Subject: [PATCH] 2011-01-07 Tobias Burnus 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 PR fortran/41580 * gfortran.dg/extends_type_of_3.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@168579 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 11 +++ gcc/fortran/intrinsic.c | 7 +- gcc/fortran/intrinsic.h | 4 +- gcc/fortran/simplify.c | 89 ++++++++++++++++++- gcc/testsuite/ChangeLog | 5 ++ gcc/testsuite/gfortran.dg/extends_type_of_3.f90 | 111 ++++++++++++++++++++++++ 6 files changed, 222 insertions(+), 5 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/extends_type_of_3.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index aadd14326d9..57b07100709 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,14 @@ +2011-01-07 Tobias Burnus + + 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 PR fortran/47189 diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index d17544c74b0..9458ca948f1 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 e9574e8a0e5..540cc8ebbf7 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 e45ed401085..3beac15177c 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/ChangeLog b/gcc/testsuite/ChangeLog index c95b4db2023..8ffb04983c4 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2011-01-07 Tobias Burnus + + PR fortran/41580 + * gfortran.dg/extends_type_of_3.f90: New. + 2011-01-07 Kai Tietz * 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 index 00000000000..346542fe5c3 --- /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" } } -- 2.11.4.GIT