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

Collapse All | Expand All

(-)a/gcc/fortran/decl.c (+47 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 "@". 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_notify_std (GFC_STD_F2003, "Fortran 2003: GENERIC name is the "
7022
			  "same as a derived-type name at %C") == FAILURE)
7023
	return MATCH_ERROR;
7024
7025
      if (gfc_get_symbol (gfc_get_string ("%s@", name), NULL, &sym_func))
7026
	return MATCH_ERROR;
7027
      str = sym_func->name;
7028
      ns = sym_func->ns;
7029
      old_symbol = sym_func->old_symbol;
7030
      tlink = sym_func->tlink;
7031
      refs = sym_func->refs;
7032
      *sym_func = *sym;
7033
      sym_func->name = str;
7034
      sym_func->ns = ns;
7035
      sym_func->declared_at = sym->declared_at;
7036
      sym_func->attr.dt_generic = 1;
7037
7038
      str = sym->name;
7039
      ns = sym->ns;
7040
      memset (sym, 0, sizeof (gfc_symbol));
7041
      gfc_clear_ts (&sym->ts);
7042
      gfc_clear_attr (&sym->attr);
7043
      sym->ns = ns;
7044
      sym->name = str;
7045
      sym->declared_at = gfc_current_locus;
7046
      sym->attr.dt_generic = 1;
7047
7048
      sym->old_symbol = sym_func->old_symbol;
7049
      sym->tlink = sym_func->tlink;
7050
      sym->refs = sym_func->refs;
7051
      sym_func->old_symbol = old_symbol;
7052
      sym_func->tlink = tlink;
7053
      sym_func->refs = refs;
7054
    }
7055
7009
  if (sym->ts.type != BT_UNKNOWN)
7056
  if (sym->ts.type != BT_UNKNOWN)
7010
    {
7057
    {
7011
      gfc_error ("Derived type name '%s' at %C already has a basic type "
7058
      gfc_error ("Derived type name '%s' at %C already has a basic type "
(-)a/gcc/fortran/gfortran.h (-1 / +2 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
Lines 2760-2765 match gfc_match_rvalue (gfc_expr **); Link Here
2760
match gfc_match_varspec (gfc_expr*, int, bool, bool);
2760
match gfc_match_varspec (gfc_expr*, int, bool, bool);
2761
int gfc_check_digit (char, int);
2761
int gfc_check_digit (char, int);
2762
bool gfc_is_function_return_value (gfc_symbol *, gfc_namespace *);
2762
bool gfc_is_function_return_value (gfc_symbol *, gfc_namespace *);
2763
gfc_try gfc_convert_to_structure_constructor (gfc_expr *expr);
2763
2764
2764
/* trans.c */
2765
/* trans.c */
2765
void gfc_generate_code (gfc_namespace *);
2766
void gfc_generate_code (gfc_namespace *);
(-)a/gcc/fortran/interface.c (-2 / +30 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 + 2];
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
	  name[len] = '@';
228
	  name[len+1] = '\0';
229
230
	  if (gfc_get_symbol (name, NULL, &sym))
231
	    return MATCH_ERROR;
232
233
	  sym->attr.dt_generic = 1;
234
	}
235
215
      if (!sym->attr.generic 
236
      if (!sym->attr.generic 
216
	  && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
237
	  && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
217
	return MATCH_ERROR;
238
	return MATCH_ERROR;
Lines 275-281 gfc_match_abstract_interface (void) Link Here
275
match
296
match
276
gfc_match_end_interface (void)
297
gfc_match_end_interface (void)
277
{
298
{
278
  char name[GFC_MAX_SYMBOL_LEN + 1];
299
  char name[GFC_MAX_SYMBOL_LEN + 2];
279
  interface_type type;
300
  interface_type type;
280
  gfc_intrinsic_op op;
301
  gfc_intrinsic_op op;
281
  match m;
302
  match m;
Lines 338-343 gfc_match_end_interface (void) Link Here
338
      break;
359
      break;
339
360
340
    case INTERFACE_GENERIC:
361
    case INTERFACE_GENERIC:
362
      if (current_interface.sym->attr.dt_generic)
363
	{
364
	  size_t len = strlen (name);
365
	  name[len] = '@';
366
	  name[len+1] = '\0';
367
	}
368
341
      if (type != current_interface.type
369
      if (type != current_interface.type
342
	  || strcmp (current_interface.sym->name, name) != 0)
370
	  || strcmp (current_interface.sym->name, name) != 0)
343
	{
371
	{
(-)a/gcc/fortran/module.c (-2 / +12 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 3781-3787 static void Link Here
3781
load_generic_interfaces (void)
3787
load_generic_interfaces (void)
3782
{
3788
{
3783
  const char *p;
3789
  const char *p;
3784
  char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
3790
  char name[GFC_MAX_SYMBOL_LEN + 2], module[GFC_MAX_SYMBOL_LEN + 1];
3785
  gfc_symbol *sym;
3791
  gfc_symbol *sym;
3786
  gfc_interface *generic = NULL, *gen = NULL;
3792
  gfc_interface *generic = NULL, *gen = NULL;
3787
  int n, i, renamed;
3793
  int n, i, renamed;
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-1] == '@')
3870
		    sym->attr.dt_generic = 1;
3861
		}
3871
		}
3862
	    }
3872
	    }
3863
	  else
3873
	  else
(-)a/gcc/fortran/primary.c (-1 / +147 lines)
Lines 2238-2243 build_actual_constructor (gfc_structure_ctor_component **comp_head, Link Here
2238
  return SUCCESS;
2238
  return SUCCESS;
2239
}
2239
}
2240
2240
2241
2242
gfc_try
2243
gfc_convert_to_structure_constructor (gfc_expr *expr)
2244
{
2245
  gfc_actual_arglist *actual;
2246
  gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
2247
  gfc_constructor_base ctor_head = NULL;
2248
  gfc_component *comp; /* Is set NULL when named component is first seen */
2249
  const char* last_name = NULL;
2250
  gfc_symbol *sym;
2251
2252
  comp_tail = comp_head = NULL;
2253
  sym = expr->value.function.esym;
2254
2255
  if (sym->attr.abstract)
2256
    {
2257
      gfc_error ("Can't construct ABSTRACT type '%s' at %L",
2258
		 sym->name, &expr->where);
2259
      return FAILURE;
2260
    }
2261
2262
  comp = sym->components;
2263
  for (actual = expr->value.function.actual; actual; actual = actual->next)
2264
    {
2265
      gfc_component *this_comp = NULL;
2266
2267
      if (!comp_head)
2268
	comp_tail = comp_head = gfc_get_structure_ctor_component ();
2269
      else
2270
	{
2271
	  comp_tail->next = gfc_get_structure_ctor_component ();
2272
	  comp_tail = comp_tail->next;
2273
       	}
2274
      if (actual->name)
2275
	{
2276
	  comp_tail->name = xstrdup (actual->name); /*FIXME*/
2277
	  last_name = comp_tail->name;
2278
	  comp = NULL;
2279
	}
2280
      else
2281
	{
2282
	  /* Components without name are not allowed after the first named
2283
	     component initializer!  */
2284
	  if (!comp)
2285
	    {
2286
	      if (last_name)
2287
		gfc_error ("Component initializer without name after component"
2288
			   " named %s at %C!", last_name); /* FIXME: where. */
2289
	      else
2290
		gfc_error ("Too many components in structure constructor at "
2291
			   "%C!"); /* FIXME: where. */
2292
	      return FAILURE; /* goto cleanup;*/
2293
	    }
2294
2295
	  comp_tail->name = xstrdup (comp->name);
2296
	}
2297
2298
      /* Find the current component in the structure definition and check
2299
	     its access is not private.  */
2300
      if (comp)
2301
	this_comp = gfc_find_component (sym, comp->name, false, false);
2302
      else
2303
	{
2304
	  this_comp = gfc_find_component (sym, (const char *)comp_tail->name,
2305
					  false, false);
2306
	  comp = NULL; /* Reset needed!  */
2307
	}
2308
2309
      /* Here we can check if a component name is given which does not
2310
	 correspond to any component of the defined structure.  */
2311
      if (!this_comp)
2312
	return FAILURE; /*goto cleanup;*/
2313
2314
      /* Check if this component is already given a value.  */
2315
      for (comp_iter = comp_head; comp_iter != comp_tail; 
2316
	   comp_iter = comp_iter->next)
2317
	{
2318
	  gcc_assert (comp_iter);
2319
	  if (!strcmp (comp_iter->name, comp_tail->name))
2320
	    {
2321
	      gfc_error ("Component '%s' is initialized twice in the structure"
2322
			 " constructor at %C!", comp_tail->name); /* FIXME: where. */
2323
	      return FAILURE; /*goto cleanup;*/
2324
	    }
2325
	}
2326
2327
      actual->name = NULL;
2328
      comp_tail->val = actual->expr;
2329
      actual->expr = NULL;
2330
      /* FIXME: Gives a SEGV:  comp_tail->where = actual->expr->where; */
2331
2332
      /* F2008, R457/C725, for PURE C1283.  */
2333
      if (this_comp->attr.pointer && gfc_is_coindexed (comp_tail->val))
2334
     	{
2335
       	  gfc_error ("Coindexed expression to pointer component '%s' in "
2336
		     "structure constructor at %C!", comp_tail->name); /* FIXME: where. */
2337
	  return FAILURE; /*goto cleanup;*/
2338
	}
2339
2340
      if (comp)
2341
	comp = comp->next;
2342
    }
2343
2344
  if (build_actual_constructor (&comp_head, &ctor_head, sym) == FAILURE)
2345
    return FAILURE; /* FIXME: Cleanup.  */
2346
2347
  /* No component should be left, as this should have caused an error in the
2348
     loop constructing the component-list (name that does not correspond to any
2349
     component in the structure definition).  */
2350
  if (comp_head && sym->attr.extension)
2351
    {
2352
      for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
2353
	{
2354
	  gfc_error ("component '%s' at %L has already been set by a "
2355
		     "parent derived type constructor", comp_iter->name,
2356
		     &comp_iter->where);
2357
	}
2358
      return FAILURE; /*goto cleanup;*/
2359
    }
2360
  else
2361
    gcc_assert (!comp_head);
2362
2363
  expr->ts.u.derived = sym;
2364
  expr->ts.kind = 0;
2365
  expr->ts.type = BT_DERIVED;
2366
  expr->value.constructor = ctor_head;
2367
  expr->expr_type = EXPR_STRUCTURE;
2368
2369
  return SUCCESS;
2370
}
2371
2372
2241
match
2373
match
2242
gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
2374
gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
2243
				 bool parent)
2375
				 bool parent)
Lines 2490-2496 match Link Here
2490
gfc_match_rvalue (gfc_expr **result)
2622
gfc_match_rvalue (gfc_expr **result)
2491
{
2623
{
2492
  gfc_actual_arglist *actual_arglist;
2624
  gfc_actual_arglist *actual_arglist;
2493
  char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
2625
  char name[GFC_MAX_SYMBOL_LEN + 2], argname[GFC_MAX_SYMBOL_LEN + 1];
2494
  gfc_state_data *st;
2626
  gfc_state_data *st;
2495
  gfc_symbol *sym;
2627
  gfc_symbol *sym;
2496
  gfc_symtree *symtree;
2628
  gfc_symtree *symtree;
Lines 2629-2634 gfc_match_rvalue (gfc_expr **result) Link Here
2629
      sym = gfc_use_derived (sym);
2761
      sym = gfc_use_derived (sym);
2630
      if (sym == NULL)
2762
      if (sym == NULL)
2631
	m = MATCH_ERROR;
2763
	m = MATCH_ERROR;
2764
      else if (sym->attr.dt_generic)
2765
	{
2766
	  size_t len = strlen (name);
2767
	  name[len] = '@';
2768
	  name[len+1] = '\0';
2769
	  gfc_find_component (sym, NULL, false, true);
2770
	  goto generic_function;
2771
	}
2632
      else
2772
      else
2633
	m = gfc_match_structure_constructor (sym, &e, false);
2773
	m = gfc_match_structure_constructor (sym, &e, false);
2634
      break;
2774
      break;
Lines 2904-2909 gfc_match_rvalue (gfc_expr **result) Link Here
2904
      e->symtree = symtree;
3044
      e->symtree = symtree;
2905
      e->expr_type = EXPR_FUNCTION;
3045
      e->expr_type = EXPR_FUNCTION;
2906
3046
3047
      /* Save derived type in case one needs it later. */
3048
      if (sym->attr.dt_generic)
3049
	{
3050
	  e->value.function.esym = sym;
3051
	}
3052
2907
      m = gfc_match_actual_arglist (0, &e->value.function.actual);
3053
      m = gfc_match_actual_arglist (0, &e->value.function.actual);
2908
      break;
3054
      break;
2909
3055
(-)a/gcc/fortran/resolve.c (-35 / +71 lines)
Lines 1991-1999 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
      return FAILURE;
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
      if (gfc_convert_to_structure_constructor (expr) != SUCCESS)
2002
	return FAILURE;
2003
2004
      return resolve_structure_cons (expr);
1997
    }
2005
    }
1998
2006
1999
  m = gfc_intrinsic_func_interface (expr, 0);
2007
  m = gfc_intrinsic_func_interface (expr, 0);
Lines 5123-5128 resolve_typebound_static (gfc_expr* e, gfc_symtree** target, Link Here
5123
}
5131
}
5124
5132
5125
5133
5134
/* Get the ultimate declared type from an expression.  In addition,
5135
   return the last class/derived type reference and the copy of the
5136
   reference list.  */
5137
static gfc_symbol*
5138
get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
5139
			gfc_expr *e)
5140
{
5141
  gfc_symbol *declared;
5142
  gfc_ref *ref;
5143
5144
  declared = NULL;
5145
  if (class_ref)
5146
    *class_ref = NULL;
5147
  if (new_ref)
5148
    *new_ref = gfc_copy_ref (e->ref);
5149
5150
  for (ref = e->ref; ref; ref = ref->next)
5151
    {
5152
      if (ref->type != REF_COMPONENT)
5153
	continue;
5154
5155
      if (ref->u.c.component->ts.type == BT_CLASS
5156
	    || ref->u.c.component->ts.type == BT_DERIVED)
5157
	{
5158
	  declared = ref->u.c.component->ts.u.derived;
5159
	  if (class_ref)
5160
	    *class_ref = ref;
5161
	}
5162
    }
5163
5164
  if (declared == NULL)
5165
    declared = e->symtree->n.sym->ts.u.derived;
5166
5167
  return declared;
5168
}
5169
5170
5126
/* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5171
/* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5127
   which of the specific bindings (if any) matches the arglist and transform
5172
   which of the specific bindings (if any) matches the arglist and transform
5128
   the expression into a call of that binding.  */
5173
   the expression into a call of that binding.  */
Lines 5132-5137 resolve_typebound_generic_call (gfc_expr* e, const char **name) Link Here
5132
{
5177
{
5133
  gfc_typebound_proc* genproc;
5178
  gfc_typebound_proc* genproc;
5134
  const char* genname;
5179
  const char* genname;
5180
  gfc_symtree *st;
5181
  gfc_symbol *derived;
5135
5182
5136
  gcc_assert (e->expr_type == EXPR_COMPCALL);
5183
  gcc_assert (e->expr_type == EXPR_COMPCALL);
5137
  genname = e->value.compcall.name;
5184
  genname = e->value.compcall.name;
Lines 5199-5204 resolve_typebound_generic_call (gfc_expr* e, const char **name) Link Here
5199
  return FAILURE;
5246
  return FAILURE;
5200
5247
5201
success:
5248
success:
5249
  /* Make sure that we have the right specific instance for the name.  */
5250
  genname = e->value.compcall.tbp->u.specific->name;
5251
5252
  /* Is the symtree name a "unique name".  */
5253
  if (*genname == '@')
5254
    genname = e->value.compcall.tbp->u.specific->n.sym->name;
5255
5256
  derived = get_declared_from_expr (NULL, NULL, e);
5257
5258
  st = gfc_find_typebound_proc (derived, NULL, genname, false, &e->where);
5259
  if (st)
5260
    e->value.compcall.tbp = st->n.tb;
5261
5202
  return SUCCESS;
5262
  return SUCCESS;
5203
}
5263
}
5204
5264
Lines 5306-5343 resolve_compcall (gfc_expr* e, const char **name) Link Here
5306
}
5366
}
5307
5367
5308
5368
5309
/* Get the ultimate declared type from an expression.  In addition,
5310
   return the last class/derived type reference and the copy of the
5311
   reference list.  */
5312
static gfc_symbol*
5313
get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
5314
			gfc_expr *e)
5315
{
5316
  gfc_symbol *declared;
5317
  gfc_ref *ref;
5318
5319
  declared = NULL;
5320
  *class_ref = NULL;
5321
  *new_ref = gfc_copy_ref (e->ref);
5322
  for (ref = *new_ref; ref; ref = ref->next)
5323
    {
5324
      if (ref->type != REF_COMPONENT)
5325
	continue;
5326
5327
      if (ref->u.c.component->ts.type == BT_CLASS
5328
	    || ref->u.c.component->ts.type == BT_DERIVED)
5329
	{
5330
	  declared = ref->u.c.component->ts.u.derived;
5331
	  *class_ref = ref;
5332
	}
5333
    }
5334
5335
  if (declared == NULL)
5336
    declared = e->symtree->n.sym->ts.u.derived;
5337
5338
  return declared;
5339
}
5340
5341
5369
5342
/* Resolve a typebound function, or 'method'. First separate all
5370
/* Resolve a typebound function, or 'method'. First separate all
5343
   the non-CLASS references by calling resolve_compcall directly.  */
5371
   the non-CLASS references by calling resolve_compcall directly.  */
Lines 9537-9542 resolve_fl_procedure (gfc_symbol *sym, int mp_flag) Link Here
9537
	  sym->attr.is_bind_c = 0;
9565
	  sym->attr.is_bind_c = 0;
9538
	}
9566
	}
9539
    }
9567
    }
9568
9569
  if (sym->attr.dt_generic && !sym->generic->sym->attr.function)
9570
    {
9571
      gfc_error ("GENERIC interface '%s' must contain functions as the name "
9572
		 "is the same as a derived-type name at %L", sym->name,
9573
		 &sym->declared_at);
9574
	  return FAILURE;
9575
    }
9540
  
9576
  
9541
  if (!sym->attr.proc_pointer)
9577
  if (!sym->attr.proc_pointer)
9542
    {
9578
    {
(-)a/gcc/fortran/symbol.c (-1 / +3 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;
Lines 1914-1920 gfc_use_derived (gfc_symbol *sym) Link Here
1914
  gfc_symtree *st;
1916
  gfc_symtree *st;
1915
  int i;
1917
  int i;
1916
1918
1917
  if (sym->components != NULL || sym->attr.zero_comp)
1919
  if (!sym || sym->components != NULL || sym->attr.zero_comp)
1918
    return sym;               /* Already defined.  */
1920
    return sym;               /* Already defined.  */
1919
1921
1920
  if (sym->ns->parent == NULL)
1922
  if (sym->ns->parent == NULL)
1921
 interface foo
1923
 interface foo
1922
   procedure constructor
1924
   procedure constructor
1923
 end interface
1925
 end interface
1924
 type foo
1926
 type foo
1925
   integer :: bar = -42
1927
   integer :: bar = -42
1926
 end type
1928
 end type
1927
 type(foo) function constructor()
1929
 type(foo) function constructor()
1928
   constructor%bar = 1
1930
   constructor%bar = 1
1929
 end function
1931
 end function
1930
 subroutine test_foo()
1932
 subroutine test_foo()
1931
   type(foo) :: f
1933
   type(foo) :: f
1932
   f = foo()
1934
   f = foo()
1933
   if (f%bar /= 1) call abort ()
1935
   if (f%bar /= 1) call abort ()
1934
   f = foo(2)
1936
   f = foo(2)
1935
   if (f%bar /= 2) call abort ()
1937
   if (f%bar /= 2) call abort ()
1936
   f = foo(bar=22)
1938
   f = foo(bar=22)
1937
   if (f%bar /= 22) call abort ()
1939
   if (f%bar /= 22) call abort ()
1938
 end subroutine test_foo
1940
 end subroutine test_foo
1939
 type bar
1941
 type bar
1940
   integer :: bar = -43
1942
   integer :: bar = -43
1941
 end type
1943
 end type
1942
 interface bar
1944
 interface bar
1943
   procedure constructor
1945
   procedure constructor
1944
 end interface
1946
 end interface
1945
 type(bar) function constructor()
1947
 type(bar) function constructor()
1946
   constructor%bar = 3
1948
   constructor%bar = 3
1947
 end function
1949
 end function
1948
 subroutine test_bar()
1950
 subroutine test_bar()
1949
   type(bar) :: f
1951
   type(bar) :: f
1950
   f = bar()
1952
   f = bar()
1951
   if (f%bar /= 3) call abort ()
1953
   if (f%bar /= 3) call abort ()
1952
   f = bar(4)
1954
   f = bar(4)
1953
   if (f%bar /= 4) call abort ()
1955
   if (f%bar /= 4) call abort ()
1954
   f = bar(bar=44)
1956
   f = bar(bar=44)
1955
   if (f%bar /= 44) call abort ()
1957
   if (f%bar /= 44) call abort ()
1956
 end subroutine test_bar
1958
 end subroutine test_bar
1957
 use foo_module
1959
 use foo_module
1958
 use bar_module
1960
 use bar_module
1959
 implicit none
1961
 implicit none
1960
 type(foo) :: f
1962
 type(foo) :: f
1961
 type(bar) :: b
1963
 type(bar) :: b
1962
 call test_foo()
1964
 call test_foo()
1963
 f = foo()
1965
 f = foo()
1964
 if (f%bar /= 1) call abort ()
1966
 if (f%bar /= 1) call abort ()
1965
 f = foo(2)
1967
 f = foo(2)
1966
 if (f%bar /= 2) call abort ()
1968
 if (f%bar /= 2) call abort ()
1967
 f = foo(bar=22)
1969
 f = foo(bar=22)
1968
 if (f%bar /= 22) call abort ()
1970
 if (f%bar /= 22) call abort ()
1969
 call test_bar()
1971
 call test_bar()
1970
 b = bar()
1972
 b = bar()
1971
 if (b%bar /= 3) call abort ()
1973
 if (b%bar /= 3) call abort ()
1972
 b = bar(4)
1974
 b = bar(4)
1973
 if (b%bar /= 4) call abort ()
1975
 if (b%bar /= 4) call abort ()
1974
 b = bar(bar=44)
1976
 b = bar(bar=44)
1975
 if (b%bar /= 44) call abort ()
1977
 if (b%bar /= 44) call abort ()

Return to bug 39427