[F03] EXTENDS_TYPE_OF, CLASS IS and libgfortran

[Janus Weil-3]

Hi all,

since we have the newly-structured OOP implementation in the
fortran-dev branch now (cf. http://gcc.gnu.org/wiki/OOP), I'm starting
to think about EXTENDS_TYPE_OF (A,B) and CLASS IS.

Regarding EXTENDS_TYPE_OF: This is an F03 intrinsic function, which
takes two arguments A and B, both of a derived type or class, and
tells you whether the (dynamic) type of the first argument is an
extension of the (dynamic) type of the second.

My idea to implement this would be to add a new function to
libgfortran, let's call it IS_EXTENSION_OF, which would take two vtabs
as arguments, and would basically do the run-time work for
EXTENDS_TYPE_OF. Depending on the type of arguments which
EXTENDS_TYPE_OF gets (type/class), one could pass the corresponding
vtabs to IS_EXTENSION_OF. In addition one could also use
IS_EXTENSION_OF in the implementation of CLASS IS, calling it once for
each CLASS IS case in a SELECT TYPE block.

However, since my experience with libgfortran is practically zero, I
will need some help with this. What I would do is probably to add a
new file 'extends_type_of.c' to libgfortran/intrinsics/, whose content
could look something like this:


typedef struct vtype
{
  int hash;
  int size;
  vtype *extends;
}
vtype;

bool
is_extension_of (struct vtype *v1, struct vtype *v2)
{
  while (v1)
    {
      if (v1->hash == v2->hash) return true;
      v1 = v1->extends;
    }
  return false;
}


This code is only schematic, I haven't checked if it compiles, but it
should give you a rough idea of how the function should work.

Now, first technical question: How do I correctly tell the libgfortran
Makefile to pick up this file, and add the function to the library?

In the Fortran front end, I have already placed some hooks for
EXTENDS_TYPE_OF, and would just need to replace the call to
EXTENDS_TYPE_OF by a call to IS_EXTENSION_OF with the right arguments:
If I have a CLASS variable c, I just use c->$vptr. If it is a TYPE
variable, I can get its vtab at compile time.

Second question: What do you think of my plan in general? Does this
sound reasonable? Does it have any drawbacks? Is there a better way to
do it? Any kind of comment or suggestion is welcome ...

Cheers,
Janus

[Thomas Koenig-6]

On Mon, 2009-11-02 at 23:45 +0100, Janus Weil wrote:
> However, since my experience with libgfortran is practically zero, I
> will need some help with this. What I would do is probably to add a
> new file 'extends_type_of.c' to libgfortran/intrinsics/, whose content
> could look something like this:

[...]


> Now, first technical question: How do I correctly tell the libgfortran
> Makefile to pick up this file, and add the function to the library?

You add the file to Makefile.am, probably to the gfor_helper_src
variable.  Then you build everything.

This regenerates Makefile.in by running autoconf automatically.  Make
sure (beforehand :-) that you have the correct version of autoconf, and
make sure to check Makefile.in against the SVN version to catch any
unpleasant surprises that may suddenly raise their ugly head.

Declare your function if you want it to be callable from the front end,
and use the export_proto macro on the declaration.  You can do that in
the file itself, unless you want to call it from somewhere else; then it
should go into libgfortran.h (and you should use iexport_proto).

Add your new global symbol to gfortran.map.

HTH,

        Thomas

[Toon Moene-3]

Thomas Koenig wrote:

> On Mon, 2009-11-02 at 23:45 +0100, Janus Weil wrote:

>> Now, first technical question: How do I correctly tell the libgfortran
>> Makefile to pick up this file, and add the function to the library?
>
> You add the file to Makefile.am, probably to the gfor_helper_src
> variable.  Then you build everything.

Thomas, are you sure one doesn't need --enable-maintainer-mode for the
creation of Makefile.in from Makefile.am ?  In the standard svn output
Makefile.in is present (already generated).

Kind regards,

--
Toon Moene - e-mail: toon@... - phone: [phone]
Saturnushof 14, 3738 XG  Maartensdijk, The Netherlands
At home: http://moene.org/~toon/
Progress of GNU Fortran: http://gcc.gnu.org/gcc-4.5/changes.html

[Thomas Koenig-6]

Toon Moene wrote:
> Thomas, are you sure one doesn't need --enable-maintainer-mode for
> the
> creation of Makefile.in from Makefile.am ?

I think you're right.  I always enable it, which is why I forgot.

Thanks!

        Thomas

[Steve Kargl]

On Tue, Nov 03, 2009 at 08:52:01PM +0100, Thomas Koenig wrote:

> On Mon, 2009-11-02 at 23:45 +0100, Janus Weil wrote:
> > However, since my experience with libgfortran is practically zero, I
> > will need some help with this. What I would do is probably to add a
> > new file 'extends_type_of.c' to libgfortran/intrinsics/, whose content
> > could look something like this:
>
> [...]
>
>
> > Now, first technical question: How do I correctly tell the libgfortran
> > Makefile to pick up this file, and add the function to the library?
>
> You add the file to Makefile.am, probably to the gfor_helper_src
> variable.  Then you build everything.
>
> This regenerates Makefile.in by running autoconf automatically.  Make
> sure (beforehand :-) that you have the correct version of autoconf, and
> make sure to check Makefile.in against the SVN version to catch any
> unpleasant surprises that may suddenly raise their ugly head.
>
> Declare your function if you want it to be callable from the front end,
> and use the export_proto macro on the declaration.  You can do that in
> the file itself, unless you want to call it from somewhere else; then it
> should go into libgfortran.h (and you should use iexport_proto).
>
> Add your new global symbol to gfortran.map.
>

This is only the library side of the chnages.

If these are truly intrinsic procedures, you may need to add
code to intrinsic.c, check.c, simplify.c, iresolve.c, trans-intrinsic.c
and gfortran.h.

gfortran.h  --> see gfc_isym_id.
intrinsic.c --> add intrinsic procedure to the list of intrinsics with
                the right standard.
check.c     --> check that the arguments are valid.
simplify.c  --> if the arguments are constants, then simplify the expression.
iresolve.c  --> resolves the called procedure to the right library routine.
trans-intrinsic.c --> use the gfc_isym_id to determine the translation.
                      Note, if the procedures can be in-lined, you do it
                      here.
--
Steve

[Janus Weil-3]

2009/11/3 Thomas Koenig <tkoenig@...>:
> Toon Moene wrote:
>> Thomas, are you sure one doesn't need --enable-maintainer-mode for
>> the
>> creation of Makefile.in from Makefile.am ?
>
> I think you're right.  I always enable it, which is why I forgot.

Ah, that's why it didn't work for me before. I had modified
Makefile.am, but missed --enable-maintainer-mode.

Thanks for your help, guys :)

Cheers,
Janus

[Janus Weil-3]

2009/11/3 Steve Kargl <sgk@...>:

> On Tue, Nov 03, 2009 at 08:52:01PM +0100, Thomas Koenig wrote:
>> On Mon, 2009-11-02 at 23:45 +0100, Janus Weil wrote:
>> > However, since my experience with libgfortran is practically zero, I
>> > will need some help with this. What I would do is probably to add a
>> > new file 'extends_type_of.c' to libgfortran/intrinsics/, whose content
>> > could look something like this:
>>
>> [...]
>>
>>
>> > Now, first technical question: How do I correctly tell the libgfortran
>> > Makefile to pick up this file, and add the function to the library?
>>
>> You add the file to Makefile.am, probably to the gfor_helper_src
>> variable.  Then you build everything.
>>
>> This regenerates Makefile.in by running autoconf automatically.  Make
>> sure (beforehand :-) that you have the correct version of autoconf, and
>> make sure to check Makefile.in against the SVN version to catch any
>> unpleasant surprises that may suddenly raise their ugly head.
>>
>> Declare your function if you want it to be callable from the front end,
>> and use the export_proto macro on the declaration.  You can do that in
>> the file itself, unless you want to call it from somewhere else; then it
>> should go into libgfortran.h (and you should use iexport_proto).
>>
>> Add your new global symbol to gfortran.map.
>>
>
> This is only the library side of the chnages.
>
> If these are truly intrinsic procedures, you may need to add
> code to intrinsic.c, check.c, simplify.c, iresolve.c, trans-intrinsic.c
> and gfortran.h.
>
> gfortran.h  --> see gfc_isym_id.
> intrinsic.c --> add intrinsic procedure to the list of intrinsics with
>                the right standard.
> check.c     --> check that the arguments are valid.
> simplify.c  --> if the arguments are constants, then simplify the expression.
> iresolve.c  --> resolves the called procedure to the right library routine.
> trans-intrinsic.c --> use the gfc_isym_id to determine the translation.
>                      Note, if the procedures can be in-lined, you do it
>                      here.

Yes, most of this has been done already for EXTENDS_TYPE_OF, including
a function 'gfc_conv_extends_type_of' in trans-intrinsic.c, which so
far just outputs an error message ("... not implemented ...").

And as Tobias noted in PR41580, we may need to add simplifiers later.

Still, thanks for the reminder, Steve :)

Cheers,
Janus

[Janus Weil-3]

Hi all,

>> Now, first technical question: How do I correctly tell the libgfortran
>> Makefile to pick up this file, and add the function to the library?
>
> You add the file to Makefile.am, probably to the gfor_helper_src
> variable.  Then you build everything.
>
> This regenerates Makefile.in by running autoconf automatically.  Make
> sure (beforehand :-) that you have the correct version of autoconf, and
> make sure to check Makefile.in against the SVN version to catch any
> unpleasant surprises that may suddenly raise their ugly head.
>
> Declare your function if you want it to be callable from the front end,
> and use the export_proto macro on the declaration.  You can do that in
> the file itself, unless you want to call it from somewhere else; then it
> should go into libgfortran.h (and you should use iexport_proto).
>
> Add your new global symbol to gfortran.map.

Ok, I have now concocted a patch, following Thomas' suggestions.
However, when I use it to compile a simple test case, I get the
following:

/tmp/ccOHXez5.o: In function `MAIN__':
test.f90:(.text+0x6a): undefined reference to `_gfortran_is_extension_of'

Does anyone have an idea what I'm doing wrong?

Cheers,
Janus

[extends_type_of.diff]

---

Index: gcc/fortran/intrinsic.c
===================================================================
--- gcc/fortran/intrinsic.c (revision 153872)
+++ 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 153872)
+++ 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 153872)
+++ gcc/fortran/iresolve.c (working copy)
@@ -806,7 +806,16 @@ 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)
+{
+  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 153872)
+++ 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 153872)
+++ 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,56 @@
+/* Implementation of the EXTENDS_TYPE_OF intrinsic.
+   Copyright (C) 2004, 2007, 2009 Free Software Foundation, Inc.
+   Contributed by Janus Weil <janus@...>.
+
+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_INTEGER_4 is_extension_of (struct vtype *, struct vtype *);
+export_proto(is_extension_of);
+
+
+GFC_INTEGER_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 153872)
+++ 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 153872)
+++ 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 \

---

[Janus Weil-3]

2009/11/4 Janus Weil <janus@...>:

> Hi all,
>
>>> Now, first technical question: How do I correctly tell the libgfortran
>>> Makefile to pick up this file, and add the function to the library?
>>
>> You add the file to Makefile.am, probably to the gfor_helper_src
>> variable.  Then you build everything.
>>
>> This regenerates Makefile.in by running autoconf automatically.  Make
>> sure (beforehand :-) that you have the correct version of autoconf, and
>> make sure to check Makefile.in against the SVN version to catch any
>> unpleasant surprises that may suddenly raise their ugly head.
>>
>> Declare your function if you want it to be callable from the front end,
>> and use the export_proto macro on the declaration.  You can do that in
>> the file itself, unless you want to call it from somewhere else; then it
>> should go into libgfortran.h (and you should use iexport_proto).
>>
>> Add your new global symbol to gfortran.map.
>
> Ok, I have now concocted a patch, following Thomas' suggestions.
> However, when I use it to compile a simple test case, I get the
> following:
>
> /tmp/ccOHXez5.o: In function `MAIN__':
> test.f90:(.text+0x6a): undefined reference to `_gfortran_is_extension_of'

Uh, sorry for the noise, guys. I simply had a syntax error in the
gfortran.map file (it was just too late last night). It works now, and
I can successfully compile and link my test program.

Now I just need to replace the arguments, so that the function can
give sensible results.

Cheers,
Janus

[extends_type_of.diff]

---

Index: gcc/fortran/intrinsic.c
===================================================================
--- gcc/fortran/intrinsic.c (revision 153888)
+++ 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 153888)
+++ 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 153888)
+++ gcc/fortran/iresolve.c (working copy)
@@ -806,7 +806,18 @@ 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)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_default_integer_kind;
+  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 153888)
+++ 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 153888)
+++ 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,56 @@
+/* Implementation of the EXTENDS_TYPE_OF intrinsic.
+   Copyright (C) 2004, 2007, 2009 Free Software Foundation, Inc.
+   Contributed by Janus Weil <janus@...>.
+
+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_INTEGER_4 is_extension_of (struct vtype *, struct vtype *);
+export_proto(is_extension_of);
+
+
+GFC_INTEGER_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 153888)
+++ 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 153888)
+++ 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 \

---

[Janus Weil-3]

> Now I just need to replace the arguments, so that the function can
> give sensible results.

Update: Argument replacement works now, and the attached test case
gives the correct output:

 T
 F
 T
 T
 F
 T
 T
 F
 T
 T

A look at the dump shows that all EXTENDS_TYPE_OF statement are
correctly being translated:

      D.1389 = _gfortran_is_extension_of (c1.$vptr, c1.$vptr);
      D.1392 = _gfortran_is_extension_of (c1.$vptr, c2.$vptr);
      D.1395 = _gfortran_is_extension_of (c2.$vptr, c1.$vptr);
      D.1398 = _gfortran_is_extension_of (&vtab$t1, &vtab$t1);
      D.1401 = _gfortran_is_extension_of (&vtab$t1, &vtab$t2);
      D.1404 = _gfortran_is_extension_of (&vtab$t2, &vtab$t1);
      D.1407 = _gfortran_is_extension_of (c1.$vptr, &vtab$t1);
      D.1410 = _gfortran_is_extension_of (c1.$vptr, &vtab$t2);
      D.1413 = _gfortran_is_extension_of (&vtab$t1, c1.$vptr);
      D.1416 = _gfortran_is_extension_of (&vtab$t2, c1.$vptr);

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.

Cheers,
Janus

[extends_type_of.diff]

---

Index: gcc/fortran/intrinsic.c
===================================================================
--- gcc/fortran/intrinsic.c (revision 153888)
+++ 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 153888)
+++ 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 153888)
+++ gcc/fortran/iresolve.c (working copy)
@@ -806,7 +806,51 @@ 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;
+
+  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;
+    }
+
+  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;
+  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 153888)
+++ 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 153888)
+++ 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,56 @@
+/* Implementation of the EXTENDS_TYPE_OF intrinsic.
+   Copyright (C) 2004, 2007, 2009 Free Software Foundation, Inc.
+   Contributed by Janus Weil <janus@...>.
+
+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);
+
+
+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 153888)
+++ 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 153888)
+++ 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 \

---

[Paul Richard Thomas]

Janus,

The EXTENDS_TYPE_OF patch looks fine to me.  Are you going to use the
library call to do the runtime resolution of  CLASS IS or will you
write another library function to do that? I guess that you could add
a flag that determines if gfortran_is_extension_of goes only to the
parent or all the way up the ancestral tree.

To give you an update on dynamic dispatch: I am now past the blockage
that the buglet in the revamping of the use of vtabs caused me.  It
was entirely self-inflicted because I was convinced that my work was
causing the ICEs and never cleaned up and retested :-)  I am now
adding procedure pointer components for specific procedures that seem
to be OK, baring adding the formal argument list for PASS bindings.
The next step is to get the initialization to work and then I will
cycle back to generic procedures and tidying up.

Cheers

Paul

[Janus Weil-3]

Hi Paul,

> The EXTENDS_TYPE_OF patch looks fine to me.  Are you going to use the
> library call to do the runtime resolution of  CLASS IS or will you
> write another library function to do that?

yes, the plan is to use this library function also for CLASS IS. This
is the nice thing about this way of doing it: You need only one
library function, which can be used for both things.

However, for this to work, one has to sort the CLASS IS cases
beforehand, so that they can be translated to

if (is_extension_of (...))
...
else if (is_extension_of (...))
...
else
...
end if

where extended types always have to appear before their parents (so
that you run into the most 'special' one when several cases match).


> I guess that you could add
> a flag that determines if gfortran_is_extension_of goes only to the
> parent or all the way up the ancestral tree.

Hm. What for? To use it also for SAME_TYPE_AS?  (which we currently do
inline...)


> To give you an update on dynamic dispatch: I am now past the blockage
> that the buglet in the revamping of the use of vtabs caused me.  It
> was entirely self-inflicted because I was convinced that my work was
> causing the ICEs and never cleaned up and retested :-)  I am now
> adding procedure pointer components for specific procedures that seem
> to be OK, baring adding the formal argument list for PASS bindings.
> The next step is to get the initialization to work and then I will
> cycle back to generic procedures and tidying up.

Sounds great. Once you have a working version, feel free to post it to
the list, so that we can commit it to the branch soon.

Cheers,
Janus

[Paul Richard Thomas]

Janus,

>
>> I guess that you could add
>> a flag that determines if gfortran_is_extension_of goes only to the
>> parent or all the way up the ancestral tree.
>
> Hm. What for? To use it also for SAME_TYPE_AS?  (which we currently do
> inline...)

No, that's not what I had in mind. What I was thinking, though, is wrong :-)

BTW CLASS IS must, presumably, only refer to the declared type of the
object, rather than it being enclosed by extension.  Early on, I had a
notion that the CLASS container should have a pointer to the declared
type vtab....

Cheers

Paul

[Janus Weil-3]

>>> I guess that you could add
>>> a flag that determines if gfortran_is_extension_of goes only to the
>>> parent or all the way up the ancestral tree.
>>
>> Hm. What for? To use it also for SAME_TYPE_AS?  (which we currently do
>> inline...)
>
> No, that's not what I had in mind. What I was thinking, though, is wrong :-)
>
> BTW CLASS IS must, presumably, only refer to the declared type of the
> object, rather than it being enclosed by extension.

I don't see what you mean. SELECT TYPE is all about the *dynamic* type
of the selector, isn't it? And for "CLASS IS (X)", X is the name of a
derived type, not a variable object. So, what 'object' do you refer
to?


> Early on, I had a
> notion that the CLASS container should have a pointer to the declared
> type vtab....

I still don't think this is necessary (as discussed before).

Cheers,
Janus

[Janus Weil-3]

> 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@...>

        * 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@...>

        * 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@...>

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

[extends_type_of.diff]

---

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@...>
 
@@ -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@...>.
+
+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 \

---