[Patch, fortran] Preliminary patch for derived type extension

["Paul Richard Thomas" <paul dot richard dot thomas at gmail dot com>]

This patch provides a more or less functional implementation of
derived type extension.  In the course of preparing the testcase, I
have identified two problems, both of which can be fixed quite
readily:

(i)  as noted in comment #1, array constructors of derived type
extensions should allow the components of the parent derived type as
arguments, as well as the parent derived type.   I intend to provide
this feature by adding a function to
array.c(gfc_resolve_array_constructor) that gathers the components of
the parent derived type into a structure constructor of that type;
iteratively if necessary.

(ii) I am not sure, as in comment #2, if a renamed, use associated
parent type should appear as a component with the new name or the
original.  This is trivially corrected if it is incorrect as it
stands.  I have not had time to check the standard for correct usage.
If anybody knows which is right, please let me know.

Barring these problems, the attached patch is already usable and gives
an indication of what the final patch will look like.  It is also
ready for basic tests of inheritance of derived type parameters or
type bound procedures, if anybody is so minded to give it a try.

Bootstrapped and regtested on x86_ia64/FC8 - watch this space over the
next few days:-)

Paul

2008-07-22  Paul Thomas  <pault@gcc.gnu.org>

	* symbol.c (gfc_add_component): Check that component name in a
	derived type extension does not appear in parent.
	(gfc_find_component): For a derived type extension, check if
	the component appears in the parent derived type by calling
	self.
	* decl.c (check_extended_derived_type): Check that a parent
	derived type exists and that it is OK for exension.
	(gfc_get_type_attr_spec): Add extra argument 'name' and return
	it if extends is specified.
	(gfc_match_derived_decl): Match derived type extension and
	build a first component of the parent derived type if OK. Add
	the f2k namespace if not present.
	* gfortran.h : Add the extension attribute.
	* match.h : Modify the prototype for gfc_get_type_attr_spec.
	

2008-07-22  Paul Thomas  <pault@gcc.gnu.org>

	* gfortran.dg/extends_1.f90: New test.


-- 
The knack of flying is learning how to throw yourself at the ground and miss.
 --Hitchhikers Guide to the Galaxy

Index: gcc/fortran/symbol.c
===================================================================
*** gcc/fortran/symbol.c	(revision 138065)
--- gcc/fortran/symbol.c	(working copy)
*************** gfc_add_component (gfc_symbol *sym, cons
*** 1701,1706 ****
--- 1701,1714 ----
        tail = p;
      }
  
+   if (sym->attr.extension
+ 	&& gfc_find_component (sym->components->ts.derived, name))
+     {
+       gfc_error ("Component '%s' at %C already in the parent type "
+ 		 "at %L", name, &sym->components->ts.derived->declared_at);
+       return FAILURE;
+     }
+ 
    /* Allocate a new component.  */
    p = gfc_get_component ();
  
*************** gfc_find_component (gfc_symbol *sym, con
*** 1830,1835 ****
--- 1838,1848 ----
      if (strcmp (p->name, name) == 0)
        break;
  
+   if (p == NULL
+ 	&& sym->components->ts.type == BT_DERIVED
+ 	&& sym->components->ts.derived->f2k_derived)
+     p = gfc_find_component (sym->components->ts.derived, name);
+ 
    if (p == NULL)
      gfc_error ("'%s' at %C is not a member of the '%s' structure",
  	       name, sym->name);
Index: gcc/fortran/decl.c
===================================================================
*** gcc/fortran/decl.c	(revision 138065)
--- gcc/fortran/decl.c	(working copy)
*************** syntax:
*** 6228,6233 ****
--- 6228,6276 ----
  }
  
  
+ /* Check a derived type that is being extended.  */
+ static gfc_symbol*
+ check_extended_derived_type (char *name)
+ {
+   gfc_symbol *extended;
+ 
+   if (gfc_find_symbol (name, gfc_current_ns, 1, &extended))
+     {
+       gfc_error ("Ambiguous symbol in TYPE definition at %C");
+       return NULL;
+     }
+ 
+   if (!extended)
+     {
+       gfc_error ("No such symbol in TYPE definition at %C");
+       return NULL;
+     }
+ 
+   if (extended->attr.flavor != FL_DERIVED)
+     {
+       gfc_error ("'%s' in EXTENDS expression at %C is not a "
+ 		 "derived type", name);
+       return NULL;
+     }
+ 
+   if (extended->attr.is_bind_c)
+     {
+       gfc_error ("'%s' cannot be extended at %C because it "
+ 		 "is BIND(C)", extended->name);
+       return NULL;
+     }
+ 
+   if (extended->attr.sequence)
+     {
+       gfc_error ("'%s' cannot be extended at %C because it "
+ 		 "is a SEQUENCE type", extended->name);
+       return NULL;
+     }
+ 
+   return extended;
+ }
+ 
+ 
  /* Match the optional attribute specifiers for a type declaration.
     Return MATCH_ERROR if an error is encountered in one of the handled
     attributes (public, private, bind(c)), MATCH_NO if what's found is
*************** syntax:
*** 6235,6241 ****
     checking on attribute conflicts needs to be done.  */
  
  match
! gfc_get_type_attr_spec (symbol_attribute *attr)
  {
    /* See if the derived type is marked as private.  */
    if (gfc_match (" , private") == MATCH_YES)
--- 6278,6284 ----
     checking on attribute conflicts needs to be done.  */
  
  match
! gfc_get_type_attr_spec (symbol_attribute *attr, char *name)
  {
    /* See if the derived type is marked as private.  */
    if (gfc_match (" , private") == MATCH_YES)
*************** gfc_get_type_attr_spec (symbol_attribute
*** 6273,6278 ****
--- 6316,6327 ----
  
        /* TODO: attr conflicts need to be checked, probably in symbol.c.  */
      }
+   else if (name && gfc_match(" , extends ( %n )", name) == MATCH_YES)
+     {
+       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: derived type "
+ 	    "extended at %C") == FAILURE)
+ 	return MATCH_ERROR;
+     }
    else
      return MATCH_NO;
  
*************** gfc_match_derived_decl (void)
*** 6291,6296 ****
--- 6340,6346 ----
    char name[GFC_MAX_SYMBOL_LEN + 1];
    symbol_attribute attr;
    gfc_symbol *sym;
+   gfc_symbol *extended;
    match m;
    match is_type_attr_spec = MATCH_NO;
    bool seen_attr = false;
*************** gfc_match_derived_decl (void)
*** 6298,6314 ****
    if (gfc_current_state () == COMP_DERIVED)
      return MATCH_NO;
  
    gfc_clear_attr (&attr);
  
    do
      {
!       is_type_attr_spec = gfc_get_type_attr_spec (&attr);
        if (is_type_attr_spec == MATCH_ERROR)
  	return MATCH_ERROR;
        if (is_type_attr_spec == MATCH_YES)
  	seen_attr = true;
      } while (is_type_attr_spec == MATCH_YES);
  
    if (gfc_match (" ::") != MATCH_YES && seen_attr)
      {
        gfc_error ("Expected :: in TYPE definition at %C");
--- 6348,6373 ----
    if (gfc_current_state () == COMP_DERIVED)
      return MATCH_NO;
  
+   name[0] = '\0';
    gfc_clear_attr (&attr);
+   extended = NULL;
  
    do
      {
!       is_type_attr_spec = gfc_get_type_attr_spec (&attr, name);
        if (is_type_attr_spec == MATCH_ERROR)
  	return MATCH_ERROR;
        if (is_type_attr_spec == MATCH_YES)
  	seen_attr = true;
      } while (is_type_attr_spec == MATCH_YES);
  
+   /* Deal with derived type extensions.  */
+   if (name[0])
+     extended = check_extended_derived_type (name);
+ 
+   if (name[0] && !extended)
+     return MATCH_ERROR;
+ 
    if (gfc_match (" ::") != MATCH_YES && seen_attr)
      {
        gfc_error ("Expected :: in TYPE definition at %C");
*************** gfc_match_derived_decl (void)
*** 6361,6369 ****
    if (attr.is_bind_c != 0)
      sym->attr.is_bind_c = attr.is_bind_c;
  
!   /* Construct the f2k_derived namespace if it is not yet there.  */
!   if (!sym->f2k_derived)
!     sym->f2k_derived = gfc_get_namespace (NULL, 0);
  
    gfc_new_block = sym;
  
--- 6420,6449 ----
    if (attr.is_bind_c != 0)
      sym->attr.is_bind_c = attr.is_bind_c;
  
!   if (extended && !sym->components)
!     {
!       gfc_component *p;
!       gfc_symtree *st;
! 
!       /* Construct the f2k_derived namespace if it is not yet there.  */
!       if (!sym->f2k_derived)
! 	sym->f2k_derived = gfc_get_namespace (NULL, 0);
! 
!       /* Add the extended derived type as the first component.  */
!       gfc_add_component (sym, extended->name, &p);
!       sym->attr.extension = 1;
!       extended->refs++;
! 
!       p->ts.type = BT_DERIVED;
!       p->ts.derived = extended;
!       p->initializer = gfc_default_initializer (&p->ts);
! 
!       /* Provide the links between the extended type and its extension.  */
!       if (!extended->f2k_derived)
! 	extended->f2k_derived = gfc_get_namespace (NULL, 0);
!       st = gfc_new_symtree (&extended->f2k_derived->sym_root, sym->name);
!       st->n.sym = sym;
!     }
  
    gfc_new_block = sym;
  
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h	(revision 138065)
--- gcc/fortran/gfortran.h	(working copy)
*************** typedef struct
*** 640,645 ****
--- 640,646 ----
    unsigned untyped:1;           /* No implicit type could be found.  */
  
    unsigned is_bind_c:1;		/* say if is bound to C */
+   unsigned extension:1;		/* extends a derived type */
  
    /* These flags are both in the typespec and attribute.  The attribute
       list is what gets read from/written to a module file.  The typespec
*************** typedef struct gfc_symbol
*** 1018,1026 ****
  
    gfc_formal_arglist *formal;
    struct gfc_namespace *formal_ns;
- 
-   /* The namespace containing type-associated procedure symbols.  */
-   /* TODO: Make this union with formal?  */
    struct gfc_namespace *f2k_derived;
  
    struct gfc_expr *value;	/* Parameter/Initializer value */
--- 1019,1024 ----
Index: gcc/fortran/match.h
===================================================================
*** gcc/fortran/match.h	(revision 138065)
--- gcc/fortran/match.h	(working copy)
*************** try get_bind_c_idents (void);
*** 182,188 ****
  match gfc_match_bind_c_stmt (void);
  match gfc_match_suffix (gfc_symbol *, gfc_symbol **);
  match gfc_match_bind_c (gfc_symbol *, bool);
! match gfc_get_type_attr_spec (symbol_attribute *);
  
  /* primary.c.  */
  match gfc_match_structure_constructor (gfc_symbol *, gfc_expr **);
--- 182,188 ----
  match gfc_match_bind_c_stmt (void);
  match gfc_match_suffix (gfc_symbol *, gfc_symbol **);
  match gfc_match_bind_c (gfc_symbol *, bool);
! match gfc_get_type_attr_spec (symbol_attribute *, char*);
  
  /* primary.c.  */
  match gfc_match_structure_constructor (gfc_symbol *, gfc_expr **);
Index: gcc/testsuite/gfortran.dg/extends_1.f03
===================================================================
*** gcc/testsuite/gfortran.dg/extends_1.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/extends_1.f03	(revision 0)
***************
*** 0 ****
--- 1,61 ----
+ ! { dg-do run }
+ ! A basic functional test of derived type extension.
+ !
+ ! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+ !
+ module mymod
+   type :: a
+     integer :: ia = 1
+     integer, private :: iaa = 100
+   end type a
+ contains
+   integer function get_iaa (arg)
+     type(a) :: arg
+     get_iaa = arg%iaa
+   end function
+ end module mymod
+   
+   use mymod
+   type, extends(a) :: b
+     integer :: ib = 2
+   end type b
+   
+   type, extends(b) :: c
+     integer :: ic = 3
+   end type c
+   
+   type(c) :: x
+   if (x%ib .ne. 2) call abort
+   if (x%ia .ne. 1) call abort
+   if (x%ia .ne. x%b%ia) call abort
+   if (x%ia .ne. x%b%a%ia) call abort
+ 
+   x%ia = 99
+   if (x%b%a%ia .ne. 99) call abort
+ 
+   x%b = b (a (42), 99)               ! comment #1: b (42, 99) should work
+   if (x%b%a%ia .ne. 42) call abort
+   
+   call foo
+ contains
+   subroutine foo
+     use mymod, only: e => a
+ 
+     type, extends(a) :: d
+       integer :: id = 4
+     end type d
+ 
+     type, extends(e) :: f
+       integer :: if = 5
+     end type f
+ 
+     type(d) :: y
+     type(f) :: z
+ 
+     if (y%ia .ne. 1) call abort
+     if (z%a%ia .ne. 1) call abort     ! comment #2: Should this be z%e%ia ?
+     if (get_iaa (y%a) .ne. 100) call abort
+   end subroutine 
+ end
+ 
+ ! { dg-final { cleanup-modules "mymod" } }