View | Details | Raw Unified | Return to bug 39427 | Differences between
and this patch

Collapse All | Expand All | Context: (Patch / File /
)

(-)a/gcc/fortran/decl.c (+43 lines)
 Lines 7006-7011   gfc_match_derived_decl (void) Link Here 
7006
  if (gfc_get_symbol (name, NULL, &sym))
7006
  if (gfc_get_symbol (name, NULL, &sym))
7007
    return MATCH_ERROR;
7007
    return MATCH_ERROR;
7008
7008
7009
  /* If there is already a generic interface with the same name as the derived
7010
     type, rename the interface have the suffix "@g". We cannot do a simple
7011
     rename of sym->name and sym->ns->sym_root->name as one needs then to
7012
     properly rebalence the symtree tree.  */
7013
  if (sym->attr.generic)
7014
    {
7015
      gfc_symbol *sym_func;
7016
      gfc_namespace *ns;
7017
      const char *str;
7018
      gfc_symbol *old_symbol, *tlink;
7019
      int refs;
7020
7021
      if (gfc_get_symbol (gfc_get_string ("%s@g", name), NULL, &sym_func))
7022
	return MATCH_ERROR;
7023
      str = sym_func->name;
7024
      ns = sym_func->ns;
7025
      old_symbol = sym_func->old_symbol;
7026
      tlink = sym_func->tlink;
7027
      refs = sym_func->refs;
7028
      *sym_func = *sym;
7029
      sym_func->name = str;
7030
      sym_func->ns = ns;
7031
      sym_func->declared_at = sym->declared_at;
7032
      sym_func->attr.dt_generic = 1;
7033
7034
      str = sym->name;
7035
      ns = sym->ns;
7036
      memset (sym, 0, sizeof (gfc_symbol));
7037
      gfc_clear_ts (&sym->ts);
7038
      gfc_clear_attr (&sym->attr);
7039
      sym->ns = ns;
7040
      sym->name = str;
7041
      sym->declared_at = gfc_current_locus;
7042
      sym->attr.dt_generic = 1;
7043
7044
      sym->old_symbol = sym_func->old_symbol;
7045
      sym->tlink = sym_func->tlink;
7046
      sym->refs = sym_func->refs;
7047
      sym_func->old_symbol = old_symbol;
7048
      sym_func->tlink = tlink;
7049
      sym_func->refs = refs;
7050
    }
7051
7009
  if (sym->ts.type != BT_UNKNOWN)
7052
  if (sym->ts.type != BT_UNKNOWN)
7010
    {
7053
    {
7011
      gfc_error ("Derived type name '%s' at %C already has a basic type "
7054
      gfc_error ("Derived type name '%s' at %C already has a basic type "
(-)a/gcc/fortran/gfortran.h (-1 / +1 lines)
 Lines 683-689   typedef struct Link Here 
683
683
684
  unsigned in_namelist:1, in_common:1, in_equivalence:1;
684
  unsigned in_namelist:1, in_common:1, in_equivalence:1;
685
  unsigned function:1, subroutine:1, procedure:1;
685
  unsigned function:1, subroutine:1, procedure:1;
686
  unsigned generic:1, generic_copy:1;
686
  unsigned generic:1, generic_copy:1, dt_generic:1;
687
  unsigned implicit_type:1;	/* Type defined via implicit rules.  */
687
  unsigned implicit_type:1;	/* Type defined via implicit rules.  */
688
  unsigned untyped:1;		/* No implicit type could be found.  */
688
  unsigned untyped:1;		/* No implicit type could be found.  */
689
689
(-)a/gcc/fortran/interface.c (-2 / +34 lines)
 Lines 183-189   syntax: Link Here 
183
match
183
match
184
gfc_match_interface (void)
184
gfc_match_interface (void)
185
{
185
{
186
  char name[GFC_MAX_SYMBOL_LEN + 1];
186
  char name[GFC_MAX_SYMBOL_LEN + 3];
187
  interface_type type;
187
  interface_type type;
188
  gfc_symbol *sym;
188
  gfc_symbol *sym;
189
  gfc_intrinsic_op op;
189
  gfc_intrinsic_op op;
 Lines 212-217   gfc_match_interface (void) Link Here 
212
      if (gfc_get_symbol (name, NULL, &sym))
212
      if (gfc_get_symbol (name, NULL, &sym))
213
	return MATCH_ERROR;
213
	return MATCH_ERROR;
214
214
215
      /* Special case: Generic procedure with same name as a derived type.  */
216
      if (sym->attr.flavor == FL_DERIVED)
217
	{
218
	  size_t len;
219
	  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: GENERIC name is "
220
			      "the same as a derived-type name at %C")
221
	      == FAILURE)
222
	    return MATCH_ERROR;
223
224
	  sym->attr.dt_generic = 1;
225
226
	  len = strlen (name);
227
	  gcc_assert(len+3 <= sizeof (name));
228
	  name[len] = '@';
229
	  name[len+1] = 'g';
230
	  name[len+2] = '\0';
231
232
	  if (gfc_get_symbol (name, NULL, &sym))
233
	    return MATCH_ERROR;
234
235
	  sym->attr.dt_generic = 1;
236
	}
237
215
      if (!sym->attr.generic 
238
      if (!sym->attr.generic 
216
	  && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
239
	  && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
217
	return MATCH_ERROR;
240
	return MATCH_ERROR;
 Lines 275-281   gfc_match_abstract_interface (void) Link Here 
275
match
298
match
276
gfc_match_end_interface (void)
299
gfc_match_end_interface (void)
277
{
300
{
278
  char name[GFC_MAX_SYMBOL_LEN + 1];
301
  char name[GFC_MAX_SYMBOL_LEN + 3];
279
  interface_type type;
302
  interface_type type;
280
  gfc_intrinsic_op op;
303
  gfc_intrinsic_op op;
281
  match m;
304
  match m;
 Lines 338-343   gfc_match_end_interface (void) Link Here 
338
      break;
361
      break;
339
362
340
    case INTERFACE_GENERIC:
363
    case INTERFACE_GENERIC:
364
      if (current_interface.sym->attr.dt_generic)
365
	{
366
	  size_t len = strlen (name);
367
	  gcc_assert (len+3 <= sizeof (name));
368
	  name[len] = '@';
369
	  name[len+1] = 'g';
370
	  name[len+2] = '\0';
371
	}
372
341
      if (type != current_interface.type
373
      if (type != current_interface.type
342
	  || strcmp (current_interface.sym->name, name) != 0)
374
	  || strcmp (current_interface.sym->name, name) != 0)
343
	{
375
	{
(-)a/gcc/fortran/module.c (-1 / +11 lines)
 Lines 1674-1680   typedef enum Link Here 
1674
  AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED,
1674
  AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED,
1675
  AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
1675
  AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
1676
  AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
1676
  AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
1677
  AB_COARRAY_COMP, AB_VTYPE, AB_VTAB
1677
  AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_DT_GENERIC
1678
}
1678
}
1679
ab_attribute;
1679
ab_attribute;
1680
1680
 Lines 1722-1727   static const mstring attr_bits[] = Link Here 
1722
    minit ("PROC_POINTER", AB_PROC_POINTER),
1722
    minit ("PROC_POINTER", AB_PROC_POINTER),
1723
    minit ("VTYPE", AB_VTYPE),
1723
    minit ("VTYPE", AB_VTYPE),
1724
    minit ("VTAB", AB_VTAB),
1724
    minit ("VTAB", AB_VTAB),
1725
    minit ("DT_GENERIC", AB_DT_GENERIC),
1725
    minit (NULL, -1)
1726
    minit (NULL, -1)
1726
};
1727
};
1727
1728
 Lines 1886-1891   mio_symbol_attribute (symbol_attribute *attr) Link Here 
1886
	MIO_NAME (ab_attribute) (AB_VTYPE, attr_bits);
1887
	MIO_NAME (ab_attribute) (AB_VTYPE, attr_bits);
1887
      if (attr->vtab)
1888
      if (attr->vtab)
1888
	MIO_NAME (ab_attribute) (AB_VTAB, attr_bits);
1889
	MIO_NAME (ab_attribute) (AB_VTAB, attr_bits);
1890
      if (attr->dt_generic)
1891
	MIO_NAME (ab_attribute) (AB_DT_GENERIC, attr_bits);
1889
1892
1890
      mio_rparen ();
1893
      mio_rparen ();
1891
1894
 Lines 2028-2033   mio_symbol_attribute (symbol_attribute *attr) Link Here 
2028
	    case AB_VTAB:
2031
	    case AB_VTAB:
2029
	      attr->vtab = 1;
2032
	      attr->vtab = 1;
2030
	      break;
2033
	      break;
2034
	    case AB_DT_GENERIC:
2035
	      attr->dt_generic = 1;
2036
	      break;
2031
	    }
2037
	    }
2032
	}
2038
	}
2033
    }
2039
    }
 Lines 3852-3863   load_generic_interfaces (void) Link Here 
3852
		 better make one.  */
3858
		 better make one.  */
3853
	      if (!sym)
3859
	      if (!sym)
3854
		{
3860
		{
3861
		  size_t len;
3855
		  gfc_get_symbol (p, NULL, &sym);
3862
		  gfc_get_symbol (p, NULL, &sym);
3856
		  sym->name = gfc_get_string (name);
3863
		  sym->name = gfc_get_string (name);
3857
		  sym->module = gfc_get_string (module_name);
3864
		  sym->module = gfc_get_string (module_name);
3858
		  sym->attr.flavor = FL_PROCEDURE;
3865
		  sym->attr.flavor = FL_PROCEDURE;
3859
		  sym->attr.generic = 1;
3866
		  sym->attr.generic = 1;
3860
		  sym->attr.use_assoc = 1;
3867
		  sym->attr.use_assoc = 1;
3868
                  len = strlen (name);
3869
		  if (name[len-2] == '@' && name[len-1] == 'g')
3870
		    sym->attr.dt_generic = 1;
3861
		}
3871
		}
3862
	    }
3872
	    }
3863
	  else
3873
	  else
(-)a/gcc/fortran/primary.c (-1 / +10 lines)
 Lines 2490-2496   match Link Here 
2490
gfc_match_rvalue (gfc_expr **result)
2490
gfc_match_rvalue (gfc_expr **result)
2491
{
2491
{
2492
  gfc_actual_arglist *actual_arglist;
2492
  gfc_actual_arglist *actual_arglist;
2493
  char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
2493
  char name[GFC_MAX_SYMBOL_LEN + 3], argname[GFC_MAX_SYMBOL_LEN + 1];
2494
  gfc_state_data *st;
2494
  gfc_state_data *st;
2495
  gfc_symbol *sym;
2495
  gfc_symbol *sym;
2496
  gfc_symtree *symtree;
2496
  gfc_symtree *symtree;
 Lines 2629-2634   gfc_match_rvalue (gfc_expr **result) Link Here 
2629
      sym = gfc_use_derived (sym);
2629
      sym = gfc_use_derived (sym);
2630
      if (sym == NULL)
2630
      if (sym == NULL)
2631
	m = MATCH_ERROR;
2631
	m = MATCH_ERROR;
2632
      else if (sym->attr.dt_generic)
2633
	{
2634
	  size_t len = strlen (name);
2635
	  gcc_assert (len+2 <= sizeof (name));
2636
	  name[len] = '@';
2637
	  name[len+1] = 'g';
2638
	  name[len+2] = '\0';
2639
	  goto generic_function;
2640
	}
2632
      else
2641
      else
2633
	m = gfc_match_structure_constructor (sym, &e, false);
2642
	m = gfc_match_structure_constructor (sym, &e, false);
2634
      break;
2643
      break;
(-)a/gcc/fortran/resolve.c (-2 / +12 lines)
 Lines 1991-1998   generic: Link Here 
1991
     that possesses a matching interface.  14.1.2.4  */
1991
     that possesses a matching interface.  14.1.2.4  */
1992
  if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
1992
  if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
1993
    {
1993
    {
1994
      gfc_error ("There is no specific function for the generic '%s' at %L",
1994
      if (!sym->attr.dt_generic)
1995
		 expr->symtree->n.sym->name, &expr->where);
1995
	{
1996
	  gfc_error ("There is no specific function for the generic '%s' "
1997
		     "at %L", expr->symtree->n.sym->name, &expr->where);
1998
	  return FAILURE;
1999
	}
2000
2001
      /* FIXME: Convert expr->value.function.actual into gfc_constructor
2002
	 to be useable for resolve_structure_cons; see also:
2003
	 gfc_match_structure_constructor.  */
2004
      gfc_error ("Sorry, calling structure constructor '%s' not yet possible "
2005
		 "at %L", expr->symtree->n.sym->name, &expr->where);
1996
      return FAILURE;
2006
      return FAILURE;
1997
    }
2007
    }
1998
2008
(-)a/gcc/fortran/symbol.c (+2 lines)
 Lines 1756-1761   gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where) Link Here 
1756
    goto fail;
1756
    goto fail;
1757
  if (src->subroutine && gfc_add_subroutine (dest, NULL, where) == FAILURE)
1757
  if (src->subroutine && gfc_add_subroutine (dest, NULL, where) == FAILURE)
1758
    goto fail;
1758
    goto fail;
1759
  if (src->dt_generic)
1760
    dest->dt_generic = 1;
1759
1761
1760
  if (src->sequence && gfc_add_sequence (dest, NULL, where) == FAILURE)
1762
  if (src->sequence && gfc_add_sequence (dest, NULL, where) == FAILURE)
1761
    goto fail;
1763
    goto fail;
1762
 interface foo
1764
 interface foo
1763
   procedure constructor
1765
   procedure constructor
1764
 end interface
1766
 end interface
1765
 type foo
1767
 type foo
1766
   integer :: bar
1768
   integer :: bar
1767
 end type
1769
 end type
1768
 type(foo) function constructor()
1770
 type(foo) function constructor()
1769
   constructor%bar = 1
1771
   constructor%bar = 1
1770
 end function
1772
 end function
1771
 subroutine test_foo()
1773
 subroutine test_foo()
1772
   type(foo) :: f
1774
   type(foo) :: f
1773
   f = foo()
1775
   f = foo()
1774
   print *, f%bar, '(expected: 1)'
1776
   print *, f%bar, '(expected: 1)'
1775
   !f = foo(2) ! Sorry
1777
   !f = foo(2) ! Sorry
1776
   !print *, f%bar, '(expected: 2)'
1778
   !print *, f%bar, '(expected: 2)'
1777
 end subroutine test_foo
1779
 end subroutine test_foo
1778
 type bar
1780
 type bar
1779
   integer :: bar
1781
   integer :: bar
1780
 end type
1782
 end type
1781
 interface bar
1783
 interface bar
1782
   procedure constructor
1784
   procedure constructor
1783
 end interface
1785
 end interface
1784
 type(bar) function constructor()
1786
 type(bar) function constructor()
1785
   constructor%bar = 3
1787
   constructor%bar = 3
1786
 end function
1788
 end function
1787
 subroutine test_bar()
1789
 subroutine test_bar()
1788
   type(bar) :: f
1790
   type(bar) :: f
1789
   f = bar()
1791
   f = bar()
1790
   print *, f%bar, '(expected: 3)'
1792
   print *, f%bar, '(expected: 3)'
1791
   !f = bar(4) ! Sorry
1793
   !f = bar(4) ! Sorry
1792
   !print *, f%bar, '(expected: 4)'
1794
   !print *, f%bar, '(expected: 4)'
1793
 end subroutine test_bar
1795
 end subroutine test_bar
1794
 use foo_module
1796
 use foo_module
1795
 use bar_module
1797
 use bar_module
1796
 implicit none
1798
 implicit none
1797
 type(foo) :: f
1799
 type(foo) :: f
1798
 type(bar) :: b
1800
 type(bar) :: b
1799
 call test_foo()
1801
 call test_foo()
1800
 f = foo()
1802
 f = foo()
1801
 print *, f%bar, '(expected: 1)'
1803
 print *, f%bar, '(expected: 1)'
1802
 !f = foo(2) ! Sorry
1804
 !f = foo(2) ! Sorry
1803
 !print *, f%bar, '(expected: 2)'
1805
 !print *, f%bar, '(expected: 2)'
1804
 call test_bar()
1806
 call test_bar()
1805
 b = bar()
1807
 b = bar()
1806
 print *, b%bar, '(expected: 3)'
1808
 print *, b%bar, '(expected: 3)'
1807
 !b = bar(4) ! Sorry
1809
 !b = bar(4) ! Sorry
1808
 !print *, b%bar, '(expected: 4)'
1810
 !print *, b%bar, '(expected: 4)'

Return to bug 39427