Re: [F03] EXTENDS_TYPE_OF, CLASS IS and libgfortran

[Janus Weil <janus at gcc dot gnu dot org>]

> So, I'd say EXTENDS_TYPE_OF is basically done. I will check if there
> are any details missing, and then move on to CLASS IS.

Before I start with CLASS IS, I'd like to get this patch into the
branch. The attached version regtests fine and provides all
functionality for EXTENDS_TYPE_OF, AFAICS. Is it ok if I commit to the
branch?

Cheers,
Janus


2009-11-04  Janus Weil  <janus@gcc.gnu.org>

	* intrinsic.h (gfc_resolve_extends_type_of): Add prototype
	* intrinsic.c (add_functions): Use 'gfc_resolve_extends_type_of'.
	* iresolve.c (gfc_resolve_extends_type_of): New function, which replaces
	the call to EXTENDS_TYPE_OF by the library function 'is_extension_of'
	and modifies the arguments.
	* trans-intrinsic.c (gfc_conv_extends_type_of): Removed.
	(gfc_conv_intrinsic_function): FOR EXTENDS_TYPE_OF, don't call
	gfc_conv_extends_type_of but gfc_conv_intrinsic_funcall.


2009-11-04  Janus Weil  <janusw@gcc.gnu.org>

	* gfortran.map: Add _gfortran_is_extension_of.
	* Makefile.am: Add intrinsics/extends_type_of.c.
	* Makefile.in: Regenerated.
	* intrinsics/extends_type_of.c: New file.


2009-11-04  Janus Weil  <janusw@gcc.gnu.org>

	* gfortran.dg/extends_type_of_1.f03: New test.
	* gfortran.dg/same_type_as_1.f03: Extended.

Index: gcc/testsuite/gfortran.dg/same_type_as_1.f03
===================================================================
--- gcc/testsuite/gfortran.dg/same_type_as_1.f03	(revision 153893)
+++ gcc/testsuite/gfortran.dg/same_type_as_1.f03	(working copy)
@@ -1,6 +1,6 @@
 ! { dg-do compile }
 !
-! Error checking for the intrinsic function SAME_TYPE_AS.
+! Error checking for the intrinsic functions SAME_TYPE_AS and EXTENDS_TYPE_OF.
 !
 ! Contributed by Janus Weil <janus@gcc.gnu.org>
 
@@ -18,7 +18,10 @@
 
  integer :: i
 
- print *, SAME_TYPE_AS (l,x1)   ! { dg-error "must be of a derived type" }
+ print *, SAME_TYPE_AS (i,x1)   ! { dg-error "must be of a derived type" }
  print *, SAME_TYPE_AS (x1,x2)  ! { dg-error "must be of an extensible type" }
 
+ print *, EXTENDS_TYPE_OF (i,x1)   ! { dg-error "must be of a derived type" }
+ print *, EXTENDS_TYPE_OF (x1,x2)  ! { dg-error "must be of an extensible type" }
+
 end
Index: gcc/fortran/intrinsic.c
===================================================================
--- gcc/fortran/intrinsic.c	(revision 153893)
+++ gcc/fortran/intrinsic.c	(working copy)
@@ -1601,7 +1601,7 @@ 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, NULL,
+	     gfc_check_same_type_as, NULL, gfc_resolve_extends_type_of,
 	     a, BT_UNKNOWN, 0, REQUIRED,
 	     mo, BT_UNKNOWN, 0, REQUIRED);
 
Index: gcc/fortran/intrinsic.h
===================================================================
--- gcc/fortran/intrinsic.h	(revision 153893)
+++ gcc/fortran/intrinsic.h	(working copy)
@@ -390,6 +390,7 @@ void gfc_resolve_eoshift (gfc_expr *, gfc_expr *,
 void gfc_resolve_etime_sub (gfc_code *);
 void gfc_resolve_exp (gfc_expr *, gfc_expr *);
 void gfc_resolve_exponent (gfc_expr *, gfc_expr *);
+void gfc_resolve_extends_type_of (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_fdate (gfc_expr *);
 void gfc_resolve_floor (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_fnum (gfc_expr *, gfc_expr *);
Index: gcc/fortran/iresolve.c
===================================================================
--- gcc/fortran/iresolve.c	(revision 153893)
+++ gcc/fortran/iresolve.c	(working copy)
@@ -806,7 +806,58 @@ gfc_resolve_exponent (gfc_expr *f, gfc_expr *x)
 }
 
 
+/* Resolve the EXTENDS_TYPE_OF intrinsic function.  */
+
 void
+gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
+{
+  gfc_symbol *vtab;
+  gfc_symtree *st;
+
+  /* Prevent double resolution.  */
+  if (f->ts.type == BT_LOGICAL)
+    return;
+
+  /* Replace the first argument with the corresponding vtab.  */
+  if (a->ts.type == BT_CLASS)
+    gfc_add_component_ref (a, "$vptr");
+  else if (a->ts.type == BT_DERIVED)
+    {
+      vtab = gfc_find_derived_vtab (a->ts.u.derived);
+      /* Clear the old expr.  */
+      gfc_free_ref_list (a->ref);
+      memset (a, '\0', sizeof (gfc_expr));
+      /* Construct a new one.  */
+      a->expr_type = EXPR_VARIABLE;
+      st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
+      a->symtree = st;
+      a->ts = vtab->ts;
+    }
+
+  /* Replace the second argument with the corresponding vtab.  */
+  if (mo->ts.type == BT_CLASS)
+    gfc_add_component_ref (mo, "$vptr");
+  else if (mo->ts.type == BT_DERIVED)
+    {
+      vtab = gfc_find_derived_vtab (mo->ts.u.derived);
+      /* Clear the old expr.  */
+      gfc_free_ref_list (mo->ref);
+      memset (mo, '\0', sizeof (gfc_expr));
+      /* Construct a new one.  */
+      mo->expr_type = EXPR_VARIABLE;
+      st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
+      mo->symtree = st;
+      mo->ts = vtab->ts;
+    }
+
+  f->ts.type = BT_LOGICAL;
+  f->ts.kind = gfc_default_logical_kind;
+  /* Call library function.  */
+  f->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
+}
+
+
+void
 gfc_resolve_fdate (gfc_expr *f)
 {
   f->ts.type = BT_CHARACTER;
Index: gcc/fortran/trans-intrinsic.c
===================================================================
--- gcc/fortran/trans-intrinsic.c	(revision 153893)
+++ gcc/fortran/trans-intrinsic.c	(working copy)
@@ -4745,21 +4745,6 @@ gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
 }
 
 
-/* Generate code for the EXTENDS_TYPE_OF intrinsic.  */
-
-static void
-gfc_conv_extends_type_of (gfc_se *se, gfc_expr *expr)
-{
-  gfc_expr *e;
-  /* TODO: Implement EXTENDS_TYPE_OF.  */
-  gfc_error ("Intrinsic EXTENDS_TYPE_OF at %L not yet implemented",
-	     &expr->where);
-  /* Just return 'false' for now.  */
-  e = gfc_logical_expr (false, &expr->where);
-  gfc_conv_expr (se, e);
-}
-
-
 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function.  */
 
 static void
@@ -5172,10 +5157,6 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr
       gfc_conv_same_type_as (se, expr);
       break;
 
-    case GFC_ISYM_EXTENDS_TYPE_OF:
-      gfc_conv_extends_type_of (se, expr);
-      break;
-
     case GFC_ISYM_ABS:
       gfc_conv_intrinsic_abs (se, expr);
       break;
@@ -5553,6 +5534,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr
     case GFC_ISYM_CHMOD:
     case GFC_ISYM_DTIME:
     case GFC_ISYM_ETIME:
+    case GFC_ISYM_EXTENDS_TYPE_OF:
     case GFC_ISYM_FGET:
     case GFC_ISYM_FGETC:
     case GFC_ISYM_FNUM:
Index: libgfortran/Makefile.in
===================================================================
--- libgfortran/Makefile.in	(revision 153893)
+++ libgfortran/Makefile.in	(working copy)
@@ -433,15 +433,15 @@ am__libgfortran_la_SOURCES_DIST = runtime/backtrac
 	intrinsics/date_and_time.c intrinsics/dtime.c intrinsics/env.c \
 	intrinsics/eoshift0.c intrinsics/eoshift2.c \
 	intrinsics/erfc_scaled.c intrinsics/etime.c intrinsics/exit.c \
-	intrinsics/fnum.c intrinsics/gerror.c intrinsics/getcwd.c \
-	intrinsics/getlog.c intrinsics/getXid.c intrinsics/hostnm.c \
-	intrinsics/ierrno.c intrinsics/ishftc.c \
-	intrinsics/iso_c_generated_procs.c intrinsics/iso_c_binding.c \
-	intrinsics/kill.c intrinsics/link.c intrinsics/malloc.c \
-	intrinsics/mvbits.c intrinsics/move_alloc.c \
-	intrinsics/pack_generic.c intrinsics/perror.c \
-	intrinsics/selected_char_kind.c intrinsics/signal.c \
-	intrinsics/size.c intrinsics/sleep.c \
+	intrinsics/extends_type_of.c intrinsics/fnum.c \
+	intrinsics/gerror.c intrinsics/getcwd.c intrinsics/getlog.c \
+	intrinsics/getXid.c intrinsics/hostnm.c intrinsics/ierrno.c \
+	intrinsics/ishftc.c intrinsics/iso_c_generated_procs.c \
+	intrinsics/iso_c_binding.c intrinsics/kill.c intrinsics/link.c \
+	intrinsics/malloc.c intrinsics/mvbits.c \
+	intrinsics/move_alloc.c intrinsics/pack_generic.c \
+	intrinsics/perror.c intrinsics/selected_char_kind.c \
+	intrinsics/signal.c intrinsics/size.c intrinsics/sleep.c \
 	intrinsics/spread_generic.c intrinsics/string_intrinsics.c \
 	intrinsics/system.c intrinsics/rand.c intrinsics/random.c \
 	intrinsics/rename.c intrinsics/reshape_generic.c \
@@ -725,15 +725,16 @@ am__objects_36 = associated.lo abort.lo access.lo
 	bit_intrinsics.lo c99_functions.lo chdir.lo chmod.lo clock.lo \
 	cpu_time.lo cshift0.lo ctime.lo date_and_time.lo dtime.lo \
 	env.lo eoshift0.lo eoshift2.lo erfc_scaled.lo etime.lo exit.lo \
-	fnum.lo gerror.lo getcwd.lo getlog.lo getXid.lo hostnm.lo \
-	ierrno.lo ishftc.lo iso_c_generated_procs.lo iso_c_binding.lo \
-	kill.lo link.lo malloc.lo mvbits.lo move_alloc.lo \
-	pack_generic.lo perror.lo selected_char_kind.lo signal.lo \
-	size.lo sleep.lo spread_generic.lo string_intrinsics.lo \
-	system.lo rand.lo random.lo rename.lo reshape_generic.lo \
-	reshape_packed.lo selected_int_kind.lo selected_real_kind.lo \
-	stat.lo symlnk.lo system_clock.lo time.lo transpose_generic.lo \
-	umask.lo unlink.lo unpack_generic.lo in_pack_generic.lo \
+	extends_type_of.lo fnum.lo gerror.lo getcwd.lo getlog.lo \
+	getXid.lo hostnm.lo ierrno.lo ishftc.lo \
+	iso_c_generated_procs.lo iso_c_binding.lo kill.lo link.lo \
+	malloc.lo mvbits.lo move_alloc.lo pack_generic.lo perror.lo \
+	selected_char_kind.lo signal.lo size.lo sleep.lo \
+	spread_generic.lo string_intrinsics.lo system.lo rand.lo \
+	random.lo rename.lo reshape_generic.lo reshape_packed.lo \
+	selected_int_kind.lo selected_real_kind.lo stat.lo symlnk.lo \
+	system_clock.lo time.lo transpose_generic.lo umask.lo \
+	unlink.lo unpack_generic.lo in_pack_generic.lo \
 	in_unpack_generic.lo
 am__objects_37 =
 am__objects_38 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \
@@ -1027,6 +1028,7 @@ intrinsics/eoshift2.c \
 intrinsics/erfc_scaled.c \
 intrinsics/etime.c \
 intrinsics/exit.c \
+intrinsics/extends_type_of.c \
 intrinsics/fnum.c \
 intrinsics/gerror.c \
 intrinsics/getcwd.c \
@@ -1889,6 +1891,7 @@ distclean-compile:
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/exponent_r16.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/exponent_r4.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/exponent_r8.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/extends_type_of.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/fbuf.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/file_pos.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/fmain.Plo@am__quote@
@@ -5475,6 +5478,13 @@ exit.lo: intrinsics/exit.c
 @AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 @am__fastdepCC_FALSE@	$(LIBTOOL)  --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o exit.lo `test -f 'intrinsics/exit.c' || echo '$(srcdir)/'`intrinsics/exit.c
 
+extends_type_of.lo: intrinsics/extends_type_of.c
+@am__fastdepCC_TRUE@	$(LIBTOOL)  --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT extends_type_of.lo -MD -MP -MF $(DEPDIR)/extends_type_of.Tpo -c -o extends_type_of.lo `test -f 'intrinsics/extends_type_of.c' || echo '$(srcdir)/'`intrinsics/extends_type_of.c
+@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/extends_type_of.Tpo $(DEPDIR)/extends_type_of.Plo
+@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='intrinsics/extends_type_of.c' object='extends_type_of.lo' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@	$(LIBTOOL)  --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o extends_type_of.lo `test -f 'intrinsics/extends_type_of.c' || echo '$(srcdir)/'`intrinsics/extends_type_of.c
+
 fnum.lo: intrinsics/fnum.c
 @am__fastdepCC_TRUE@	$(LIBTOOL)  --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT fnum.lo -MD -MP -MF $(DEPDIR)/fnum.Tpo -c -o fnum.lo `test -f 'intrinsics/fnum.c' || echo '$(srcdir)/'`intrinsics/fnum.c
 @am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/fnum.Tpo $(DEPDIR)/fnum.Plo
Index: libgfortran/intrinsics/extends_type_of.c
===================================================================
--- libgfortran/intrinsics/extends_type_of.c	(revision 0)
+++ libgfortran/intrinsics/extends_type_of.c	(revision 0)
@@ -0,0 +1,61 @@
+/* Implementation of the EXTENDS_TYPE_OF intrinsic.
+   Copyright (C) 2004, 2007, 2009 Free Software Foundation, Inc.
+   Contributed by Janus Weil <janus@gcc.gnu.org>.
+
+This file is part of the GNU Fortran 95 runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */ 
+
+
+#include "libgfortran.h"
+
+#ifdef HAVE_STDLIB_H
+#include <stdlib.h>
+#endif
+
+
+typedef struct vtype
+{
+  GFC_INTEGER_4 hash;
+  GFC_INTEGER_4 size;
+  struct vtype *extends;
+}
+vtype;
+
+
+extern GFC_LOGICAL_4 is_extension_of (struct vtype *, struct vtype *);
+export_proto(is_extension_of);
+
+
+/* This is a helper function for the F2003 intrinsic EXTENDS_TYPE_OF.
+   While EXTENDS_TYPE_OF accepts CLASS or TYPE arguments, this one here gets
+   passed the corresponding vtabs. Each call to EXTENDS_TYPE_OF is translated
+   to a call to is_extension_of.  */
+
+GFC_LOGICAL_4
+is_extension_of (struct vtype *v1, struct vtype *v2)
+{
+  while (v1)
+    {
+      if (v1->hash == v2->hash) return 1;
+      v1 = v1->extends;
+    }
+  return 0;
+}
Index: libgfortran/gfortran.map
===================================================================
--- libgfortran/gfortran.map	(revision 153893)
+++ libgfortran/gfortran.map	(working copy)
@@ -1095,6 +1095,7 @@ GFORTRAN_1.2 {
   global:
     _gfortran_clz128;
     _gfortran_ctz128;
+    _gfortran_is_extension_of;
 } GFORTRAN_1.1; 
 
 F2C_1.0 {
Index: libgfortran/Makefile.am
===================================================================
--- libgfortran/Makefile.am	(revision 153893)
+++ libgfortran/Makefile.am	(working copy)
@@ -82,6 +82,7 @@ intrinsics/eoshift2.c \
 intrinsics/erfc_scaled.c \
 intrinsics/etime.c \
 intrinsics/exit.c \
+intrinsics/extends_type_of.c \
 intrinsics/fnum.c \
 intrinsics/gerror.c \
 intrinsics/getcwd.c \

Attachment: extends_type_of_1.f03
Description: Binary data