GCC Bugzilla has been upgraded from version 4.4.9 to 5.0rc3. If you see any problem, please report it to bug 64968.
View | Details | Raw Unified | Return to bug 39427 | Differences between
and this patch

Collapse All | Expand All

(-)a/gcc/fortran/decl.c (-6 / +52 lines)
Lines 2338-2344 done: Link Here
2338
match
2338
match
2339
gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
2339
gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
2340
{
2340
{
2341
  char name[GFC_MAX_SYMBOL_LEN + 1];
2341
  char name[GFC_MAX_SYMBOL_LEN + 2];
2342
  gfc_symbol *sym;
2342
  gfc_symbol *sym;
2343
  match m;
2343
  match m;
2344
  char c;
2344
  char c;
Lines 2444-2449 gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) Link Here
2444
	return MATCH_ERROR;
2444
	return MATCH_ERROR;
2445
    }
2445
    }
2446
2446
2447
  if (ts->type == BT_CLASS || ts->type == BT_DERIVED)
2448
    {
2449
      size_t len = strlen (name);
2450
      name[len] = '@';
2451
      name[len+1] = '\0';
2452
    }
2453
2447
  /* Defer association of the derived type until the end of the
2454
  /* Defer association of the derived type until the end of the
2448
     specification block.  However, if the derived type can be
2455
     specification block.  However, if the derived type can be
2449
     found, add it to the typespec.  */  
2456
     found, add it to the typespec.  */  
Lines 2462-2467 gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) Link Here
2462
  sym = NULL;
2469
  sym = NULL;
2463
  if (ts->kind != -1 && gfc_get_ha_symbol (name, &sym))
2470
  if (ts->kind != -1 && gfc_get_ha_symbol (name, &sym))
2464
    {
2471
    {
2472
      if (ts->type == BT_CLASS || ts->type == BT_DERIVED)
2473
	name[strlen (name)-1] = '\0';
2474
2465
      gfc_error ("Type name '%s' at %C is ambiguous", name);
2475
      gfc_error ("Type name '%s' at %C is ambiguous", name);
2466
      return MATCH_ERROR;
2476
      return MATCH_ERROR;
2467
    }
2477
    }
Lines 2471-2476 gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) Link Here
2471
		    || gfc_current_ns->has_import_set;
2481
		    || gfc_current_ns->has_import_set;
2472
      if (gfc_find_symbol (name, NULL, iface, &sym))
2482
      if (gfc_find_symbol (name, NULL, iface, &sym))
2473
	{       
2483
	{       
2484
	  if (ts->type == BT_CLASS || ts->type == BT_DERIVED)
2485
	    name[strlen (name)-1] = '\0';
2486
2474
	  gfc_error ("Type name '%s' at %C is ambiguous", name);
2487
	  gfc_error ("Type name '%s' at %C is ambiguous", name);
2475
	  return MATCH_ERROR;
2488
	  return MATCH_ERROR;
2476
	}
2489
	}
Lines 5467-5473 set_enum_kind(void) Link Here
5467
match
5480
match
5468
gfc_match_end (gfc_statement *st)
5481
gfc_match_end (gfc_statement *st)
5469
{
5482
{
5470
  char name[GFC_MAX_SYMBOL_LEN + 1];
5483
  char name[GFC_MAX_SYMBOL_LEN + 2];
5471
  gfc_compile_state state;
5484
  gfc_compile_state state;
5472
  locus old_loc;
5485
  locus old_loc;
5473
  const char *block_name;
5486
  const char *block_name;
Lines 5652-5658 gfc_match_end (gfc_statement *st) Link Here
5652
  if (block_name == NULL)
5665
  if (block_name == NULL)
5653
    goto syntax;
5666
    goto syntax;
5654
5667
5655
  if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0)
5668
  if (*st == ST_END_TYPE)
5669
    {
5670
      size_t len = strlen (name);
5671
      name[len] = '@';
5672
      name[len+1] = '\0';
5673
      if (strcmp (name, block_name) != 0)
5674
	{
5675
	  strncpy (name, block_name, strlen (block_name)-1);
5676
	  gfc_error ("Expected label '%s' for %s statement at %C", name,
5677
	  gfc_ascii_statement (*st));
5678
	  goto cleanup;
5679
	}
5680
    }
5681
  else if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0)
5656
    {
5682
    {
5657
      gfc_error ("Expected label '%s' for %s statement at %C", block_name,
5683
      gfc_error ("Expected label '%s' for %s statement at %C", block_name,
5658
		 gfc_ascii_statement (*st));
5684
		 gfc_ascii_statement (*st));
Lines 6799-6805 check_extended_derived_type (char *name) Link Here
6799
{
6825
{
6800
  gfc_symbol *extended;
6826
  gfc_symbol *extended;
6801
6827
6802
  if (gfc_find_symbol (name, gfc_current_ns, 1, &extended))
6828
  if (gfc_find_symbol (gfc_get_string ("%s@", name), gfc_current_ns, 1, &extended))
6803
    {
6829
    {
6804
      gfc_error ("Ambiguous symbol in TYPE definition at %C");
6830
      gfc_error ("Ambiguous symbol in TYPE definition at %C");
6805
      return NULL;
6831
      return NULL;
Lines 6950-6956 hash_value (gfc_symbol *sym) Link Here
6950
match
6976
match
6951
gfc_match_derived_decl (void)
6977
gfc_match_derived_decl (void)
6952
{
6978
{
6953
  char name[GFC_MAX_SYMBOL_LEN + 1];
6979
  char name[GFC_MAX_SYMBOL_LEN + 2];
6954
  char parent[GFC_MAX_SYMBOL_LEN + 1];
6980
  char parent[GFC_MAX_SYMBOL_LEN + 1];
6955
  symbol_attribute attr;
6981
  symbol_attribute attr;
6956
  gfc_symbol *sym;
6982
  gfc_symbol *sym;
Lines 6958-6963 gfc_match_derived_decl (void) Link Here
6958
  match m;
6984
  match m;
6959
  match is_type_attr_spec = MATCH_NO;
6985
  match is_type_attr_spec = MATCH_NO;
6960
  bool seen_attr = false;
6986
  bool seen_attr = false;
6987
  gfc_interface *intr, *head;
6961
6988
6962
  if (gfc_current_state () == COMP_DERIVED)
6989
  if (gfc_current_state () == COMP_DERIVED)
6963
    return MATCH_NO;
6990
    return MATCH_NO;
Lines 7003-7009 gfc_match_derived_decl (void) Link Here
7003
      return MATCH_ERROR;
7030
      return MATCH_ERROR;
7004
    }
7031
    }
7005
7032
7006
  if (gfc_get_symbol (name, NULL, &sym))
7033
  if (gfc_get_symbol (gfc_get_string ("%s@", name), NULL, &sym))
7007
    return MATCH_ERROR;
7034
    return MATCH_ERROR;
7008
7035
7009
  if (sym->ts.type != BT_UNKNOWN)
7036
  if (sym->ts.type != BT_UNKNOWN)
Lines 7082-7087 gfc_match_derived_decl (void) Link Here
7082
7109
7083
  gfc_new_block = sym;
7110
  gfc_new_block = sym;
7084
7111
7112
  /* Generate an artificial generic function.  */
7113
  if (gfc_get_symbol (name, NULL, &sym))
7114
    return MATCH_ERROR;
7115
7116
  if (!sym->attr.generic
7117
      && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
7118
    return MATCH_ERROR;
7119
7120
  if (!sym->attr.function
7121
      && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
7122
    return MATCH_ERROR;
7123
7124
  head = sym->generic;
7125
  intr = gfc_get_interface ();
7126
  intr->sym = gfc_new_block;
7127
  intr->where = gfc_current_locus;
7128
  intr->next = head;
7129
  sym->generic = intr;
7130
7085
  return MATCH_YES;
7131
  return MATCH_YES;
7086
}
7132
}
7087
7133
(-)a/gcc/fortran/gfortran.h (+1 lines)
Lines 2748-2753 match gfc_match_rvalue (gfc_expr **); Link Here
2748
match gfc_match_varspec (gfc_expr*, int, bool, bool);
2748
match gfc_match_varspec (gfc_expr*, int, bool, bool);
2749
int gfc_check_digit (char, int);
2749
int gfc_check_digit (char, int);
2750
bool gfc_is_function_return_value (gfc_symbol *, gfc_namespace *);
2750
bool gfc_is_function_return_value (gfc_symbol *, gfc_namespace *);
2751
gfc_try gfc_convert_to_structure_constructor (gfc_expr *, gfc_symbol *);
2751
2752
2752
/* trans.c */
2753
/* trans.c */
2753
void gfc_generate_code (gfc_namespace *);
2754
void gfc_generate_code (gfc_namespace *);
(-)a/gcc/fortran/interface.c (-4 / +9 lines)
Lines 1071-1078 check_interface0 (gfc_interface *p, const char *interface_name) Link Here
1071
  /* Make sure all symbols in the interface have been defined as
1071
  /* Make sure all symbols in the interface have been defined as
1072
     functions or subroutines.  */
1072
     functions or subroutines.  */
1073
  for (; p; p = p->next)
1073
  for (; p; p = p->next)
1074
    if ((!p->sym->attr.function && !p->sym->attr.subroutine)
1074
    if (((!p->sym->attr.function && !p->sym->attr.subroutine)
1075
	|| !p->sym->attr.if_source)
1075
	 || !p->sym->attr.if_source)
1076
	&& p->sym->attr.flavor != FL_DERIVED)
1076
      {
1077
      {
1077
	if (p->sym->attr.external)
1078
	if (p->sym->attr.external)
1078
	  gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
1079
	  gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
Lines 1129-1136 check_interface1 (gfc_interface *p, gfc_interface *q0, Link Here
1129
	if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
1130
	if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
1130
	  continue;
1131
	  continue;
1131
1132
1132
	if (gfc_compare_interfaces (p->sym, q->sym, q->sym->name, generic_flag,
1133
	if (p->sym->attr.flavor != FL_DERIVED
1133
				    0, NULL, 0))
1134
	    && q->sym->attr.flavor != FL_DERIVED
1135
	    && gfc_compare_interfaces (p->sym, q->sym, q->sym->name,
1136
				       generic_flag, 0, NULL, 0))
1134
	  {
1137
	  {
1135
	    if (referenced)
1138
	    if (referenced)
1136
	      gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1139
	      gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
Lines 2646-2651 gfc_search_interface (gfc_interface *intr, int sub_flag, Link Here
2646
  gfc_symbol *elem_sym = NULL;
2649
  gfc_symbol *elem_sym = NULL;
2647
  for (; intr; intr = intr->next)
2650
  for (; intr; intr = intr->next)
2648
    {
2651
    {
2652
      if (intr->sym->attr.flavor == FL_DERIVED)
2653
	continue;
2649
      if (sub_flag && intr->sym->attr.function)
2654
      if (sub_flag && intr->sym->attr.function)
2650
	continue;
2655
	continue;
2651
      if (!sub_flag && intr->sym->attr.subroutine)
2656
      if (!sub_flag && intr->sym->attr.subroutine)
(-)a/gcc/fortran/match.c (-14 / +24 lines)
Lines 2541-2566 match_derived_type_spec (gfc_typespec *ts) Link Here
2541
{
2541
{
2542
  locus old_locus; 
2542
  locus old_locus; 
2543
  gfc_symbol *derived;
2543
  gfc_symbol *derived;
2544
  match m;
2545
  char buffer[GFC_MAX_SYMBOL_LEN + 1];
2546
  gfc_symtree *st;
2544
2547
2545
  old_locus = gfc_current_locus; 
2548
  old_locus = gfc_current_locus; 
2546
2549
2547
  if (gfc_match_symbol (&derived, 1) == MATCH_YES)
2550
  m = gfc_match_name (buffer);
2551
  if (m != MATCH_YES)
2552
    goto no_match;
2553
2554
  if (gfc_get_ha_sym_tree (gfc_get_string ("%s@", buffer), &st))
2555
    goto no_match;
2556
2557
  derived = st->n.sym;
2558
2559
  if (derived->attr.flavor == FL_DERIVED)
2548
    {
2560
    {
2549
      if (derived->attr.flavor == FL_DERIVED)
2561
       ts->type = BT_DERIVED;
2550
	{
2562
       ts->u.derived = derived;
2551
	  ts->type = BT_DERIVED;
2563
       return MATCH_YES;
2552
	  ts->u.derived = derived;
2564
    }
2553
	  return MATCH_YES;
2565
  else
2554
	}
2566
    {
2555
      else
2567
       /* Enforce F03:C476.  */
2556
	{
2568
       gfc_error ("'%s' at %L is not an accessible derived type",
2557
	  /* Enforce F03:C476.  */
2569
		  buffer, &gfc_current_locus);
2558
	  gfc_error ("'%s' at %L is not an accessible derived type",
2570
       return MATCH_ERROR;
2559
		     derived->name, &gfc_current_locus);
2560
	  return MATCH_ERROR;
2561
	}
2562
    }
2571
    }
2563
2572
2573
no_match:
2564
  gfc_current_locus = old_locus; 
2574
  gfc_current_locus = old_locus; 
2565
  return MATCH_NO;
2575
  return MATCH_NO;
2566
}
2576
}
(-)a/gcc/fortran/misc.c (-5 / +12 lines)
Lines 186-197 gfc_typename (gfc_typespec *ts) Link Here
186
      sprintf (buffer, "HOLLERITH");
186
      sprintf (buffer, "HOLLERITH");
187
      break;
187
      break;
188
    case BT_DERIVED:
188
    case BT_DERIVED:
189
      sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
190
      break;
191
    case BT_CLASS:
189
    case BT_CLASS:
192
      sprintf (buffer, "CLASS(%s)",
190
      {
193
	       ts->u.derived->components->ts.u.derived->name);
191
	char *name = xstrdup (ts->u.derived->name);
194
      break;
192
	int len = strlen (name);
193
	gcc_assert (name[len-1] == '@');
194
	name[len-1] = '\0';
195
	if (ts->type == BT_DERIVED)
196
	  sprintf (buffer, "TYPE(%s)", name);
197
	else
198
	  sprintf (buffer, "CLASS(%s)", name);
199
	gfc_free (name);
200
        break;
201
      }
195
    case BT_PROCEDURE:
202
    case BT_PROCEDURE:
196
      strcpy (buffer, "PROCEDURE");
203
      strcpy (buffer, "PROCEDURE");
197
      break;
204
      break;
(-)a/gcc/fortran/primary.c (-2 / +167 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, gfc_symbol *sym)
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
  locus old_locus;
2251
2252
  old_locus = gfc_current_locus;
2253
  gfc_current_locus = expr->where;
2254
2255
  comp_tail = comp_head = NULL;
2256
2257
  if (sym->attr.abstract)
2258
    {
2259
      gfc_error ("Can't construct ABSTRACT type '%s' at %L",
2260
		 sym->name, &expr->where);
2261
      goto cleanup;
2262
    }
2263
2264
  comp = sym->components;
2265
  for (actual = expr->value.function.actual; actual; actual = actual->next)
2266
    {
2267
      gfc_component *this_comp = NULL;
2268
2269
      if (!comp_head)
2270
	comp_tail = comp_head = gfc_get_structure_ctor_component ();
2271
      else
2272
	{
2273
	  comp_tail->next = gfc_get_structure_ctor_component ();
2274
	  comp_tail = comp_tail->next;
2275
       	}
2276
      if (actual->name)
2277
	{
2278
	  comp_tail->name = xstrdup (actual->name); /*CONST_CAST (char *, actual->name);*/
2279
	  last_name = comp_tail->name;
2280
	  comp = NULL;
2281
	}
2282
      else
2283
	{
2284
	  /* Components without name are not allowed after the first named
2285
	     component initializer!  */
2286
	  if (!comp)
2287
	    {
2288
	      if (last_name)
2289
		gfc_error ("Component initializer without name after component"
2290
			   " named %s at %L!", last_name,
2291
			   actual->expr ? &actual->expr->where
2292
					: &gfc_current_locus);
2293
	      else
2294
		gfc_error ("Too many components in structure constructor at "
2295
			   "%L!", actual->expr ? &actual->expr->where
2296
					       : &gfc_current_locus);
2297
	      goto cleanup;
2298
	    }
2299
2300
	  comp_tail->name = xstrdup (comp->name); /*CONST_CAST (char *, comp->name);*/
2301
	}
2302
2303
      /* Find the current component in the structure definition and check
2304
	     its access is not private.  */
2305
      if (comp)
2306
	this_comp = gfc_find_component (sym, comp->name, false, false);
2307
      else
2308
	{
2309
	  this_comp = gfc_find_component (sym, (const char *)comp_tail->name,
2310
					  false, false);
2311
	  comp = NULL; /* Reset needed!  */
2312
	}
2313
2314
      /* Here we can check if a component name is given which does not
2315
	 correspond to any component of the defined structure.  */
2316
      if (!this_comp)
2317
	goto cleanup;
2318
2319
      comp_tail->val = actual->expr;
2320
      if (actual->expr != NULL)
2321
	comp_tail->where = actual->expr->where;
2322
2323
2324
      /* Check if this component is already given a value.  */
2325
      for (comp_iter = comp_head; comp_iter != comp_tail; 
2326
	   comp_iter = comp_iter->next)
2327
	{
2328
	  gcc_assert (comp_iter);
2329
	  if (!strcmp (comp_iter->name, comp_tail->name))
2330
	    {
2331
	      gfc_error ("Component '%s' is initialized twice in the structure"
2332
			 " constructor at %L!", comp_tail->name,
2333
			 actual->expr ? &actual->expr->where
2334
				      : &gfc_current_locus);
2335
	      goto cleanup;
2336
	    }
2337
	}
2338
2339
      /* F2008, R457/C725, for PURE C1283.  */
2340
      if (this_comp->attr.pointer && comp_tail->val
2341
	  && gfc_is_coindexed (comp_tail->val))
2342
     	{
2343
       	  gfc_error ("Coindexed expression to pointer component '%s' in "
2344
		     "structure constructor at %L!", comp_tail->name,
2345
		     &comp_tail->where);
2346
	  goto cleanup;
2347
	}
2348
2349
      if (comp)
2350
	comp = comp->next;
2351
    }
2352
2353
  if (build_actual_constructor (&comp_head, &ctor_head, sym) == FAILURE)
2354
    goto cleanup;
2355
2356
  /* No component should be left, as this should have caused an error in the
2357
     loop constructing the component-list (name that does not correspond to any
2358
     component in the structure definition).  */
2359
  if (comp_head && sym->attr.extension)
2360
    {
2361
      for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
2362
	{
2363
	  gfc_error ("component '%s' at %L has already been set by a "
2364
		     "parent derived type constructor", comp_iter->name,
2365
		     &comp_iter->where);
2366
	}
2367
      goto cleanup;
2368
    }
2369
  else
2370
    gcc_assert (!comp_head);
2371
2372
  expr->ts.u.derived = sym;
2373
  expr->ts.kind = 0;
2374
  expr->ts.type = BT_DERIVED;
2375
  expr->value.constructor = ctor_head;
2376
  expr->expr_type = EXPR_STRUCTURE;
2377
2378
  gfc_current_locus = old_locus; 
2379
  return SUCCESS;
2380
2381
  cleanup:
2382
  gfc_current_locus = old_locus; 
2383
2384
  for (comp_iter = comp_head; comp_iter; )
2385
    {
2386
      gfc_structure_ctor_component *next = comp_iter->next;
2387
      gfc_free_structure_ctor_component (comp_iter);
2388
      comp_iter = next;
2389
    }
2390
/*  gfc_constructor_free (ctor_head);*/
2391
2392
  return FAILURE;
2393
}
2394
2395
2396
2241
match
2397
match
2242
gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
2398
gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
2243
				 bool parent)
2399
				 bool parent)
Lines 2262-2268 gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result, Link Here
2262
  /* Check that we're not about to construct an ABSTRACT type.  */
2418
  /* Check that we're not about to construct an ABSTRACT type.  */
2263
  if (!parent && sym->attr.abstract)
2419
  if (!parent && sym->attr.abstract)
2264
    {
2420
    {
2265
      gfc_error ("Can't construct ABSTRACT type '%s' at %C", sym->name);
2421
      char *name = xstrdup (sym->name);
2422
      name[strlen (name) - 1] = '\0';
2423
      gfc_error ("Can't construct ABSTRACT type '%s' at %C", name);
2424
      gfc_free (name);
2266
      return MATCH_ERROR;
2425
      return MATCH_ERROR;
2267
    }
2426
    }
2268
2427
Lines 2630-2636 gfc_match_rvalue (gfc_expr **result) Link Here
2630
      if (sym == NULL)
2789
      if (sym == NULL)
2631
	m = MATCH_ERROR;
2790
	m = MATCH_ERROR;
2632
      else
2791
      else
2633
	m = gfc_match_structure_constructor (sym, &e, false);
2792
	goto generic_function;
2634
      break;
2793
      break;
2635
2794
2636
    /* If we're here, then the name is known to be the name of a
2795
    /* If we're here, then the name is known to be the name of a
Lines 2904-2909 gfc_match_rvalue (gfc_expr **result) Link Here
2904
      e->symtree = symtree;
3063
      e->symtree = symtree;
2905
      e->expr_type = EXPR_FUNCTION;
3064
      e->expr_type = EXPR_FUNCTION;
2906
3065
3066
      if (sym->attr.flavor == FL_DERIVED)
3067
	{
3068
	  e->value.function.esym = sym;
3069
	  e->symtree->n.sym->attr.generic = 1;
3070
	}
3071
2907
      m = gfc_match_actual_arglist (0, &e->value.function.actual);
3072
      m = gfc_match_actual_arglist (0, &e->value.function.actual);
2908
      break;
3073
      break;
2909
3074
(-)a/gcc/fortran/resolve.c (-14 / +74 lines)
Lines 111-122 resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name) Link Here
111
    {
111
    {
112
      if (where)
112
      if (where)
113
	{
113
	{
114
	  char *str = xstrdup (ts->u.derived->name);
115
	  str[strlen (str)-1] = '\0';
114
	  if (name)
116
	  if (name)
115
	    gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
117
	    {
116
		       name, where, ts->u.derived->name);
118
	      gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
119
			 name, where, str);
120
	    }
117
	  else
121
	  else
118
	    gfc_error ("ABSTRACT type '%s' used at %L",
122
	    gfc_error ("ABSTRACT type '%s' used at %L",
119
		       ts->u.derived->name, where);
123
		       str, where);
124
	  gfc_free (str);
120
	}
125
	}
121
126
122
      return FAILURE;
127
      return FAILURE;
Lines 1960-1970 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym) Link Here
1960
}
1965
}
1961
1966
1962
1967
1963
static gfc_try
1968
gfc_try
1969
resolve_generic_f (gfc_expr *expr);
1970
/*static */ gfc_try
1964
resolve_generic_f (gfc_expr *expr)
1971
resolve_generic_f (gfc_expr *expr)
1965
{
1972
{
1966
  gfc_symbol *sym;
1973
  gfc_symbol *sym;
1967
  match m;
1974
  match m;
1975
  gfc_interface *intr;
1968
1976
1969
  sym = expr->symtree->n.sym;
1977
  sym = expr->symtree->n.sym;
1970
1978
Lines 1991-2004 generic: Link Here
1991
     that possesses a matching interface.  14.1.2.4  */
1999
     that possesses a matching interface.  14.1.2.4  */
1992
  if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
2000
  if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
1993
    {
2001
    {
1994
      gfc_error ("There is no specific function for the generic '%s' at %L",
2002
      for (intr = sym->generic; intr; intr = intr->next)
1995
		 expr->symtree->n.sym->name, &expr->where);
2003
	if (intr->sym->attr.flavor == FL_DERIVED)
2004
	 {
2005
	   if (gfc_convert_to_structure_constructor (expr, intr->sym)
2006
	       != SUCCESS)
2007
	     return FAILURE;
2008
	   return resolve_structure_cons (expr);
2009
	 }
2010
2011
      gfc_error ("There is no specific function for the generic '%s' "
2012
		 "at %L", expr->symtree->n.sym->name, &expr->where);
1996
      return FAILURE;
2013
      return FAILURE;
1997
    }
2014
    }
1998
2015
1999
  m = gfc_intrinsic_func_interface (expr, 0);
2016
  m = gfc_intrinsic_func_interface (expr, 0);
2000
  if (m == MATCH_YES)
2017
  if (m == MATCH_YES)
2001
    return SUCCESS;
2018
    return SUCCESS;
2019
2002
  if (m == MATCH_NO)
2020
  if (m == MATCH_NO)
2003
    gfc_error ("Generic function '%s' at %L is not consistent with a "
2021
    gfc_error ("Generic function '%s' at %L is not consistent with a "
2004
	       "specific intrinsic interface", expr->symtree->n.sym->name,
2022
	       "specific intrinsic interface", expr->symtree->n.sym->name,
Lines 10590-10601 resolve_fl_derived (gfc_symbol *sym) Link Here
10590
10608
10591
  super_type = gfc_get_derived_super_type (sym);
10609
  super_type = gfc_get_derived_super_type (sym);
10592
10610
10611
10593
  /* F2008, C432. */
10612
  /* F2008, C432. */
10594
  if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
10613
  if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
10595
    {
10614
    {
10615
      char *super_name = xstrdup (super_type->name);
10616
      char *name = xstrdup (sym->name);
10617
10618
      super_name[strlen (super_name)-1] = '\0';
10619
      name[strlen (super_name)-1] = '\0';
10620
10596
      gfc_error ("As extending type '%s' at %L has a coarray component, "
10621
      gfc_error ("As extending type '%s' at %L has a coarray component, "
10597
		 "parent type '%s' shall also have one", sym->name,
10622
		 "parent type '%s' shall also have one", name,
10598
		 &sym->declared_at, super_type->name);
10623
		 &sym->declared_at, super_name);
10624
      gfc_free (super_name);
10625
      gfc_free (name);
10599
      return FAILURE;
10626
      return FAILURE;
10600
    }
10627
    }
10601
10628
Lines 10606-10613 resolve_fl_derived (gfc_symbol *sym) Link Here
10606
  /* An ABSTRACT type must be extensible.  */
10633
  /* An ABSTRACT type must be extensible.  */
10607
  if (sym->attr.abstract && !gfc_type_is_extensible (sym))
10634
  if (sym->attr.abstract && !gfc_type_is_extensible (sym))
10608
    {
10635
    {
10636
      char *name = xstrdup (sym->name);
10637
10638
      name[strlen (name)-1] = '\0';
10609
      gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
10639
      gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
10610
		 sym->name, &sym->declared_at);
10640
		 name, &sym->declared_at);
10641
      gfc_free (name);
10611
      return FAILURE;
10642
      return FAILURE;
10612
    }
10643
    }
10613
10644
Lines 10780-10789 resolve_fl_derived (gfc_symbol *sym) Link Here
10780
	      || (me_arg->ts.type == BT_CLASS
10811
	      || (me_arg->ts.type == BT_CLASS
10781
		  && me_arg->ts.u.derived->components->ts.u.derived != sym))
10812
		  && me_arg->ts.u.derived->components->ts.u.derived != sym))
10782
	    {
10813
	    {
10814
	      char *name = xstrdup (sym->name);
10815
10816
	      name[strlen (name)-1] = '\0';
10783
	      gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
10817
	      gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
10784
			 " the derived type '%s'", me_arg->name, c->name,
10818
			 " the derived type '%s'", me_arg->name, c->name,
10785
			 me_arg->name, &c->loc, sym->name);
10819
			 me_arg->name, &c->loc, name);
10786
	      c->tb->error = 1;
10820
	      c->tb->error = 1;
10821
	      gfc_free (name);
10787
	      return FAILURE;
10822
	      return FAILURE;
10788
	    }
10823
	    }
10789
10824
Lines 10837-10845 resolve_fl_derived (gfc_symbol *sym) Link Here
10837
      if (super_type && !sym->attr.is_class
10872
      if (super_type && !sym->attr.is_class
10838
	  && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
10873
	  && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
10839
	{
10874
	{
10875
	  char *name = xstrdup (sym->name);
10876
10877
	  name[strlen (name)-1] = '\0';
10840
	  gfc_error ("Component '%s' of '%s' at %L has the same name as an"
10878
	  gfc_error ("Component '%s' of '%s' at %L has the same name as an"
10841
		     " inherited type-bound procedure",
10879
		     " inherited type-bound procedure",
10842
		     c->name, sym->name, &c->loc);
10880
		     c->name, name, &c->loc);
10881
	  gfc_free (name);
10843
	  return FAILURE;
10882
	  return FAILURE;
10844
	}
10883
	}
10845
10884
Lines 10863-10874 resolve_fl_derived (gfc_symbol *sym) Link Here
10863
	  && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
10902
	  && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
10864
	  && !c->ts.u.derived->attr.use_assoc
10903
	  && !c->ts.u.derived->attr.use_assoc
10865
	  && !gfc_check_access (c->ts.u.derived->attr.access,
10904
	  && !gfc_check_access (c->ts.u.derived->attr.access,
10866
				c->ts.u.derived->ns->default_access)
10905
				c->ts.u.derived->ns->default_access))
10867
	  && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
10906
	{
10907
	  char *name = xstrdup (sym->name);
10908
10909
	  name[strlen (name)-1] = '\0';
10910
	  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
10868
			     "is a PRIVATE type and cannot be a component of "
10911
			     "is a PRIVATE type and cannot be a component of "
10869
			     "'%s', which is PUBLIC at %L", c->name,
10912
			     "'%s', which is PUBLIC at %L", c->name,
10870
			     sym->name, &sym->declared_at) == FAILURE)
10913
			     sym->name, &sym->declared_at) == FAILURE)
10871
	return FAILURE;
10914
	    {
10915
	      gfc_free (name);
10916
	      return FAILURE;
10917
	    }
10918
	  gfc_free (name);
10919
	}
10872
10920
10873
      if (sym->attr.sequence)
10921
      if (sym->attr.sequence)
10874
	{
10922
	{
Lines 10885-10893 resolve_fl_derived (gfc_symbol *sym) Link Here
10885
	  && c->ts.u.derived->components == NULL
10933
	  && c->ts.u.derived->components == NULL
10886
	  && !c->ts.u.derived->attr.zero_comp)
10934
	  && !c->ts.u.derived->attr.zero_comp)
10887
	{
10935
	{
10936
	  char *name = xstrdup (sym->name);
10937
10938
	  name[strlen (name)-1] = '\0';
10888
	  gfc_error ("The pointer component '%s' of '%s' at %L is a type "
10939
	  gfc_error ("The pointer component '%s' of '%s' at %L is a type "
10889
		     "that has not been declared", c->name, sym->name,
10940
		     "that has not been declared", c->name, sym->name,
10890
		     &c->loc);
10941
		     &c->loc);
10942
	  gfc_free (name);
10891
	  return FAILURE;
10943
	  return FAILURE;
10892
	}
10944
	}
10893
10945
Lines 10895-10903 resolve_fl_derived (gfc_symbol *sym) Link Here
10895
	  && c->ts.u.derived->components->ts.u.derived->components == NULL
10947
	  && c->ts.u.derived->components->ts.u.derived->components == NULL
10896
	  && !c->ts.u.derived->components->ts.u.derived->attr.zero_comp)
10948
	  && !c->ts.u.derived->components->ts.u.derived->attr.zero_comp)
10897
	{
10949
	{
10950
	  char *name = xstrdup (sym->name);
10951
10952
	  name[strlen (name)-1] = '\0';
10898
	  gfc_error ("The pointer component '%s' of '%s' at %L is a type "
10953
	  gfc_error ("The pointer component '%s' of '%s' at %L is a type "
10899
		     "that has not been declared", c->name, sym->name,
10954
		     "that has not been declared", c->name, sym->name,
10900
		     &c->loc);
10955
		     &c->loc);
10956
	  gfc_free (name);
10901
	  return FAILURE;
10957
	  return FAILURE;
10902
	}
10958
	}
10903
10959
Lines 10934-10942 resolve_fl_derived (gfc_symbol *sym) Link Here
10934
	      || (resolve_index_expr (c->as->upper[i]) == FAILURE)
10990
	      || (resolve_index_expr (c->as->upper[i]) == FAILURE)
10935
	      || !gfc_is_constant_expr (c->as->upper[i]))
10991
	      || !gfc_is_constant_expr (c->as->upper[i]))
10936
	    {
10992
	    {
10993
	      char *name = xstrdup (sym->name);
10994
10995
	      name[strlen (name)-1] = '\0';
10937
	      gfc_error ("Component '%s' of '%s' at %L must have "
10996
	      gfc_error ("Component '%s' of '%s' at %L must have "
10938
			 "constant array bounds",
10997
			 "constant array bounds",
10939
			 c->name, sym->name, &c->loc);
10998
			 c->name, sym->name, &c->loc);
10999
	      gfc_free (name);
10940
	      return FAILURE;
11000
	      return FAILURE;
10941
	    }
11001
	    }
10942
	}
11002
	}
10943
 type t
11003
 type t
10944
   integer :: i
11004
   integer :: i
10945
 end type t
11005
 end type t
10946
 procedure func
11006
 procedure func
10947
 integer function func()
11007
 integer function func()
10948
   func = 44
11008
   func = 44
10949
 end function func
11009
 end function func
10950
 procedure func
11010
 procedure func
10951
 type(t) function func(x,y)
11011
 type(t) function func(x,y)
10952
   real :: x,y
11012
   real :: x,y
10953
   func = t(49)
11013
   func = t(49)
10954
 end function func
11014
 end function func

Return to bug 39427