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

Collapse All | Expand All

(-)a/gcc/fortran/class.c (-2 / +8 lines)
Lines 550-556 gfc_find_derived_vtab (gfc_symbol *derived, bool resolved) Link Here
550
550
551
  if (ns)
551
  if (ns)
552
    {
552
    {
553
      sprintf (name, "vtab$%s", derived->name);
553
      char *dt_name;
554
555
      dt_name = xstrdup (derived->name);
556
      dt_name[strlen (dt_name) - 1] = '\0';
557
      sprintf (name, "vtab$%s", dt_name);
558
554
      gfc_find_symbol (name, ns, 0, &vtab);
559
      gfc_find_symbol (name, ns, 0, &vtab);
555
560
556
      if (vtab == NULL)
561
      if (vtab == NULL)
Lines 563-569 gfc_find_derived_vtab (gfc_symbol *derived, bool resolved) Link Here
563
	  vtab->attr.vtab = 1;
568
	  vtab->attr.vtab = 1;
564
	  vtab->refs++;
569
	  vtab->refs++;
565
	  gfc_set_sym_referenced (vtab);
570
	  gfc_set_sym_referenced (vtab);
566
	  sprintf (name, "vtype$%s", derived->name);
571
	  sprintf (name, "vtype$%s", dt_name);
567
	  
572
	  
568
	  gfc_find_symbol (name, ns, 0, &vtype);
573
	  gfc_find_symbol (name, ns, 0, &vtype);
569
	  if (vtype == NULL)
574
	  if (vtype == NULL)
Lines 629-634 gfc_find_derived_vtab (gfc_symbol *derived, bool resolved) Link Here
629
634
630
	  vtab->ts.u.derived = vtype;
635
	  vtab->ts.u.derived = vtype;
631
	  vtab->value = gfc_default_initializer (&vtab->ts);
636
	  vtab->value = gfc_default_initializer (&vtab->ts);
637
	  gfc_free (dt_name);
632
	}
638
	}
633
    }
639
    }
634
640
(-)a/gcc/fortran/decl.c (-10 / +80 lines)
Lines 326-331 match_data_constant (gfc_expr **result) Link Here
326
  gfc_expr *expr;
326
  gfc_expr *expr;
327
  match m;
327
  match m;
328
  locus old_loc;
328
  locus old_loc;
329
  gfc_interface *intr = NULL;
329
330
330
  m = gfc_match_literal_constant (&expr, 1);
331
  m = gfc_match_literal_constant (&expr, 1);
331
  if (m == MATCH_YES)
332
  if (m == MATCH_YES)
Lines 365-379 match_data_constant (gfc_expr **result) Link Here
365
  if (gfc_find_symbol (name, NULL, 1, &sym))
366
  if (gfc_find_symbol (name, NULL, 1, &sym))
366
    return MATCH_ERROR;
367
    return MATCH_ERROR;
367
368
368
  if (sym == NULL
369
  /* Check for derived type.  */
369
      || (sym->attr.flavor != FL_PARAMETER && sym->attr.flavor != FL_DERIVED))
370
  if (sym && sym->attr.generic)
371
    for (intr = (sym ? sym->generic : NULL); intr; intr = intr->next)
372
      if (intr->sym->attr.flavor == FL_DERIVED)
373
	break;
374
375
  if (sym == NULL || (sym->attr.flavor != FL_PARAMETER && !intr))
370
    {
376
    {
371
      gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
377
      gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
372
		 name);
378
		 name);
373
      return MATCH_ERROR;
379
      return MATCH_ERROR;
374
    }
380
    }
375
  else if (sym->attr.flavor == FL_DERIVED)
381
  else if (intr)
376
    return gfc_match_structure_constructor (sym, result, false);
382
    /* FIXME: Consider replacing by gfc_convert_to_structure_constructor? */
383
    return gfc_match_structure_constructor (intr->sym, result, false);
377
384
378
  /* Check to see if the value is an initialization array expression.  */
385
  /* Check to see if the value is an initialization array expression.  */
379
  if (sym->value->expr_type == EXPR_ARRAY)
386
  if (sym->value->expr_type == EXPR_ARRAY)
Lines 2338-2344 done: Link Here
2338
match
2345
match
2339
gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
2346
gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
2340
{
2347
{
2341
  char name[GFC_MAX_SYMBOL_LEN + 1];
2348
  char name[GFC_MAX_SYMBOL_LEN + 2];
2342
  gfc_symbol *sym;
2349
  gfc_symbol *sym;
2343
  match m;
2350
  match m;
2344
  char c;
2351
  char c;
Lines 2444-2449 gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) Link Here
2444
	return MATCH_ERROR;
2451
	return MATCH_ERROR;
2445
    }
2452
    }
2446
2453
2454
  if (ts->type == BT_CLASS || ts->type == BT_DERIVED)
2455
    {
2456
      size_t len = strlen (name);
2457
      name[len] = '@';
2458
      name[len+1] = '\0';
2459
    }
2460
2447
  /* Defer association of the derived type until the end of the
2461
  /* Defer association of the derived type until the end of the
2448
     specification block.  However, if the derived type can be
2462
     specification block.  However, if the derived type can be
2449
     found, add it to the typespec.  */  
2463
     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;
2476
  sym = NULL;
2463
  if (ts->kind != -1 && gfc_get_ha_symbol (name, &sym))
2477
  if (ts->kind != -1 && gfc_get_ha_symbol (name, &sym))
2464
    {
2478
    {
2479
      if (ts->type == BT_CLASS || ts->type == BT_DERIVED)
2480
	name[strlen (name)-1] = '\0';
2481
2465
      gfc_error ("Type name '%s' at %C is ambiguous", name);
2482
      gfc_error ("Type name '%s' at %C is ambiguous", name);
2466
      return MATCH_ERROR;
2483
      return MATCH_ERROR;
2467
    }
2484
    }
Lines 2471-2476 gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) Link Here
2471
		    || gfc_current_ns->has_import_set;
2488
		    || gfc_current_ns->has_import_set;
2472
      if (gfc_find_symbol (name, NULL, iface, &sym))
2489
      if (gfc_find_symbol (name, NULL, iface, &sym))
2473
	{       
2490
	{       
2491
	  if (ts->type == BT_CLASS || ts->type == BT_DERIVED)
2492
	    name[strlen (name)-1] = '\0';
2493
2474
	  gfc_error ("Type name '%s' at %C is ambiguous", name);
2494
	  gfc_error ("Type name '%s' at %C is ambiguous", name);
2475
	  return MATCH_ERROR;
2495
	  return MATCH_ERROR;
2476
	}
2496
	}
Lines 2816-2821 gfc_match_import (void) Link Here
2816
	  sym->refs++;
2836
	  sym->refs++;
2817
	  sym->attr.imported = 1;
2837
	  sym->attr.imported = 1;
2818
2838
2839
	  /* Also import derived types.  */
2840
	  if (sym->attr.generic && sym->attr.function)
2841
	    {
2842
	      gfc_interface *intr = NULL;
2843
	      for (intr = sym->generic; intr; intr = intr->next)
2844
		if (intr->sym->attr.flavor == FL_DERIVED)
2845
		  break;
2846
	      if (intr == NULL)
2847
		goto next_item;
2848
2849
	      st = gfc_new_symtree (&gfc_current_ns->sym_root,
2850
				    intr->sym->name);
2851
	      st->n.sym = intr->sym;
2852
	      intr->sym->refs++;
2853
	      intr->sym->attr.imported = 1;
2854
            }
2855
2819
	  goto next_item;
2856
	  goto next_item;
2820
2857
2821
	case MATCH_NO:
2858
	case MATCH_NO:
Lines 5467-5473 set_enum_kind(void) Link Here
5467
match
5504
match
5468
gfc_match_end (gfc_statement *st)
5505
gfc_match_end (gfc_statement *st)
5469
{
5506
{
5470
  char name[GFC_MAX_SYMBOL_LEN + 1];
5507
  char name[GFC_MAX_SYMBOL_LEN + 2];
5471
  gfc_compile_state state;
5508
  gfc_compile_state state;
5472
  locus old_loc;
5509
  locus old_loc;
5473
  const char *block_name;
5510
  const char *block_name;
Lines 5652-5658 gfc_match_end (gfc_statement *st) Link Here
5652
  if (block_name == NULL)
5689
  if (block_name == NULL)
5653
    goto syntax;
5690
    goto syntax;
5654
5691
5655
  if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0)
5692
  if (*st == ST_END_TYPE)
5693
    {
5694
      size_t len = strlen (name);
5695
      name[len] = '@';
5696
      name[len+1] = '\0';
5697
      if (strcmp (name, block_name) != 0)
5698
	{
5699
	  strncpy (name, block_name, strlen (block_name)-1);
5700
	  gfc_error ("Expected label '%s' for %s statement at %C", name,
5701
	  gfc_ascii_statement (*st));
5702
	  goto cleanup;
5703
	}
5704
    }
5705
  else if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0)
5656
    {
5706
    {
5657
      gfc_error ("Expected label '%s' for %s statement at %C", block_name,
5707
      gfc_error ("Expected label '%s' for %s statement at %C", block_name,
5658
		 gfc_ascii_statement (*st));
5708
		 gfc_ascii_statement (*st));
Lines 6799-6805 check_extended_derived_type (char *name) Link Here
6799
{
6849
{
6800
  gfc_symbol *extended;
6850
  gfc_symbol *extended;
6801
6851
6802
  if (gfc_find_symbol (name, gfc_current_ns, 1, &extended))
6852
  if (gfc_find_symbol (gfc_get_string ("%s@", name), gfc_current_ns, 1, &extended))
6803
    {
6853
    {
6804
      gfc_error ("Ambiguous symbol in TYPE definition at %C");
6854
      gfc_error ("Ambiguous symbol in TYPE definition at %C");
6805
      return NULL;
6855
      return NULL;
Lines 6950-6956 hash_value (gfc_symbol *sym) Link Here
6950
match
7000
match
6951
gfc_match_derived_decl (void)
7001
gfc_match_derived_decl (void)
6952
{
7002
{
6953
  char name[GFC_MAX_SYMBOL_LEN + 1];
7003
  char name[GFC_MAX_SYMBOL_LEN + 2];
6954
  char parent[GFC_MAX_SYMBOL_LEN + 1];
7004
  char parent[GFC_MAX_SYMBOL_LEN + 1];
6955
  symbol_attribute attr;
7005
  symbol_attribute attr;
6956
  gfc_symbol *sym;
7006
  gfc_symbol *sym;
Lines 6958-6963 gfc_match_derived_decl (void) Link Here
6958
  match m;
7008
  match m;
6959
  match is_type_attr_spec = MATCH_NO;
7009
  match is_type_attr_spec = MATCH_NO;
6960
  bool seen_attr = false;
7010
  bool seen_attr = false;
7011
  gfc_interface *intr, *head;
6961
7012
6962
  if (gfc_current_state () == COMP_DERIVED)
7013
  if (gfc_current_state () == COMP_DERIVED)
6963
    return MATCH_NO;
7014
    return MATCH_NO;
Lines 7003-7009 gfc_match_derived_decl (void) Link Here
7003
      return MATCH_ERROR;
7054
      return MATCH_ERROR;
7004
    }
7055
    }
7005
7056
7006
  if (gfc_get_symbol (name, NULL, &sym))
7057
  if (gfc_get_symbol (gfc_get_string ("%s@", name), NULL, &sym))
7007
    return MATCH_ERROR;
7058
    return MATCH_ERROR;
7008
7059
7009
  if (sym->ts.type != BT_UNKNOWN)
7060
  if (sym->ts.type != BT_UNKNOWN)
Lines 7082-7087 gfc_match_derived_decl (void) Link Here
7082
7133
7083
  gfc_new_block = sym;
7134
  gfc_new_block = sym;
7084
7135
7136
  /* Generate an artificial generic function.  */
7137
  if (gfc_get_symbol (name, NULL, &sym))
7138
    return MATCH_ERROR;
7139
7140
  if (!sym->attr.generic
7141
      && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
7142
    return MATCH_ERROR;
7143
7144
  if (!sym->attr.function
7145
      && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
7146
    return MATCH_ERROR;
7147
7148
  head = sym->generic;
7149
  intr = gfc_get_interface ();
7150
  intr->sym = gfc_new_block;
7151
  intr->where = gfc_current_locus;
7152
  intr->next = head;
7153
  sym->generic = intr;
7154
7085
  return MATCH_YES;
7155
  return MATCH_YES;
7086
}
7156
}
7087
7157
(-)a/gcc/fortran/gfortran.h (+1 lines)
Lines 2750-2755 match gfc_match_rvalue (gfc_expr **); Link Here
2750
match gfc_match_varspec (gfc_expr*, int, bool, bool);
2750
match gfc_match_varspec (gfc_expr*, int, bool, bool);
2751
int gfc_check_digit (char, int);
2751
int gfc_check_digit (char, int);
2752
bool gfc_is_function_return_value (gfc_symbol *, gfc_namespace *);
2752
bool gfc_is_function_return_value (gfc_symbol *, gfc_namespace *);
2753
gfc_try gfc_convert_to_structure_constructor (gfc_expr *, gfc_symbol *);
2753
2754
2754
/* trans.c */
2755
/* trans.c */
2755
void gfc_generate_code (gfc_namespace *);
2756
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 (-15 / +25 lines)
Lines 2546-2572 static match Link Here
2546
match_derived_type_spec (gfc_typespec *ts)
2546
match_derived_type_spec (gfc_typespec *ts)
2547
{
2547
{
2548
  locus old_locus; 
2548
  locus old_locus; 
2549
  gfc_symbol *derived;
2549
  match m;
2550
  char buffer[GFC_MAX_SYMBOL_LEN + 1];
2551
  gfc_symtree *st;
2550
2552
2551
  old_locus = gfc_current_locus; 
2553
  old_locus = gfc_current_locus; 
2552
2554
2553
  if (gfc_match_symbol (&derived, 1) == MATCH_YES)
2555
  m = gfc_match_name (buffer);
2556
  if (m != MATCH_YES)
2557
    goto no_match;
2558
2559
  /* We cannot use gfc_get_hat_sym_tree as it creates the symbol,
2560
     but we do not want to create a spurious symbol.  */
2561
  if (gfc_find_sym_tree (gfc_get_string ("%s@", buffer), gfc_current_ns, 1,
2562
      &st) || st == NULL)
2563
    goto no_match;
2564
  
2565
  if (st->n.sym->attr.flavor == FL_DERIVED)
2554
    {
2566
    {
2555
      if (derived->attr.flavor == FL_DERIVED)
2567
       ts->type = BT_DERIVED;
2556
	{
2568
       ts->u.derived = st->n.sym;
2557
	  ts->type = BT_DERIVED;
2569
       return MATCH_YES;
2558
	  ts->u.derived = derived;
2570
    }
2559
	  return MATCH_YES;
2571
  else
2560
	}
2572
    {
2561
      else
2573
       /* Enforce F03:C476.  */
2562
	{
2574
       gfc_error ("'%s' at %L is not an accessible derived type",
2563
	  /* Enforce F03:C476.  */
2575
		  buffer, &gfc_current_locus);
2564
	  gfc_error ("'%s' at %L is not an accessible derived type",
2576
       return MATCH_ERROR;
2565
		     derived->name, &gfc_current_locus);
2566
	  return MATCH_ERROR;
2567
	}
2568
    }
2577
    }
2569
2578
2579
no_match:
2570
  gfc_current_locus = old_locus; 
2580
  gfc_current_locus = old_locus; 
2571
  return MATCH_NO;
2581
  return MATCH_NO;
2572
}
2582
}
(-)a/gcc/fortran/misc.c (-6 / +13 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;
Lines 299-305 gfc_done_2 (void) Link Here
299
   kind with the given name (c_kind_name) was found.  */
306
   kind with the given name (c_kind_name) was found.  */
300
307
301
int
308
int
302
get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])
309
get_c_kind (const char *c_kind_name, CInteropKind_t kinds_table[])
303
{
310
{
304
  int index = 0;
311
  int index = 0;
305
312
(-)a/gcc/fortran/module.c (-8 / +46 lines)
Lines 4245-4257 read_module (void) Link Here
4245
{
4245
{
4246
  module_locus operator_interfaces, user_operators, extensions;
4246
  module_locus operator_interfaces, user_operators, extensions;
4247
  const char *p;
4247
  const char *p;
4248
  char name[GFC_MAX_SYMBOL_LEN + 1];
4248
  char name[GFC_MAX_SYMBOL_LEN + 2];
4249
  int i;
4249
  int i;
4250
  int ambiguous, j, nuse, symbol;
4250
  int ambiguous, j, nuse, symbol;
4251
  pointer_info *info, *q;
4251
  pointer_info *info, *q;
4252
  gfc_use_rename *u;
4252
  gfc_use_rename *u;
4253
  gfc_symtree *st;
4253
  gfc_symtree *st;
4254
  gfc_symbol *sym;
4254
  gfc_symbol *sym;
4255
  char *dt_name;
4255
4256
4256
  get_module_locus (&operator_interfaces);	/* Skip these for now.  */
4257
  get_module_locus (&operator_interfaces);	/* Skip these for now.  */
4257
  skip_list ();
4258
  skip_list ();
Lines 4349-4358 read_module (void) Link Here
4349
      if (nuse == 0)
4350
      if (nuse == 0)
4350
	nuse = 1;
4351
	nuse = 1;
4351
4352
4353
      /* Handle derived types.  */
4354
      if (name[strlen (name) - 1] == '@')
4355
	{
4356
	  dt_name = xstrdup (name);
4357
	  dt_name[strlen (dt_name) - 1] = '\0';
4358
	}
4359
      else
4360
	dt_name = NULL;
4361
4352
      for (j = 1; j <= nuse; j++)
4362
      for (j = 1; j <= nuse; j++)
4353
	{
4363
	{
4354
	  /* Get the jth local name for this symbol.  */
4364
	  /* Get the jth local name for this symbol.  */
4355
	  p = find_use_name_n (name, &j, false);
4365
	  p = find_use_name_n (dt_name ? dt_name : name, &j, false);
4356
4366
4357
	  if (p == NULL && strcmp (name, module_name) == 0)
4367
	  if (p == NULL && strcmp (name, module_name) == 0)
4358
	    p = name;
4368
	    p = name;
Lines 4377-4383 read_module (void) Link Here
4377
				module_name, 0))
4387
				module_name, 0))
4378
	    continue;
4388
	    continue;
4379
4389
4380
	  st = gfc_find_symtree (gfc_current_ns->sym_root, p);
4390
	  st = gfc_find_symtree (gfc_current_ns->sym_root,
4391
				 dt_name ? gfc_get_string ("%s@", p) : p);
4381
4392
4382
	  if (st != NULL)
4393
	  if (st != NULL)
4383
	    {
4394
	    {
Lines 4402-4410 read_module (void) Link Here
4402
4413
4403
	      /* Create a symtree node in the current namespace for this
4414
	      /* Create a symtree node in the current namespace for this
4404
		 symbol.  */
4415
		 symbol.  */
4405
	      st = check_unique_name (p)
4416
	      st = check_unique_name (dt_name ? gfc_get_string ("%s@", p) : p)
4406
		   ? gfc_get_unique_symtree (gfc_current_ns)
4417
		   ? gfc_get_unique_symtree (gfc_current_ns)
4407
		   : gfc_new_symtree (&gfc_current_ns->sym_root, p);
4418
		   : gfc_new_symtree (&gfc_current_ns->sym_root,
4419
				      dt_name ? gfc_get_string ("%s@", p) : p);
4408
	      st->ambiguous = ambiguous;
4420
	      st->ambiguous = ambiguous;
4409
4421
4410
	      sym = info->u.rsym.sym;
4422
	      sym = info->u.rsym.sym;
Lines 4442-4447 read_module (void) Link Here
4442
	      info->u.rsym.referenced = 1;
4454
	      info->u.rsym.referenced = 1;
4443
	    }
4455
	    }
4444
	}
4456
	}
4457
      if (dt_name)
4458
	gfc_free (dt_name);
4445
    }
4459
    }
4446
4460
4447
  mio_rparen ();
4461
  mio_rparen ();
Lines 5197-5202 sort_iso_c_rename_list (void) Link Here
5197
  for (curr = gfc_rename_list; curr; curr = curr->next)
5211
  for (curr = gfc_rename_list; curr; curr = curr->next)
5198
    {
5212
    {
5199
      c_kind = get_c_kind (curr->use_name, c_interop_kinds_table);
5213
      c_kind = get_c_kind (curr->use_name, c_interop_kinds_table);
5214
5215
      if (c_kind == ISOCBINDING_INVALID || c_kind == ISOCBINDING_LAST)
5216
	c_kind = get_c_kind (gfc_get_string ("%s@", curr->use_name),
5217
			     c_interop_kinds_table);
5218
5200
      if (c_kind == ISOCBINDING_INVALID || c_kind == ISOCBINDING_LAST)
5219
      if (c_kind == ISOCBINDING_INVALID || c_kind == ISOCBINDING_LAST)
5201
	{
5220
	{
5202
	  gfc_error ("Symbol '%s' referenced at %L does not exist in "
5221
	  gfc_error ("Symbol '%s' referenced at %L does not exist in "
Lines 5245-5251 import_iso_c_binding_module (void) Link Here
5245
  const char *iso_c_module_name = "__iso_c_binding";
5264
  const char *iso_c_module_name = "__iso_c_binding";
5246
  gfc_use_rename *u;
5265
  gfc_use_rename *u;
5247
  int i;
5266
  int i;
5248
  char *local_name;
5267
  const char *local_name;
5249
5268
5250
  /* Look only in the current namespace.  */
5269
  /* Look only in the current namespace.  */
5251
  mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name);
5270
  mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name);
Lines 5279-5287 import_iso_c_binding_module (void) Link Here
5279
      for (u = gfc_rename_list; u; u = u->next)
5298
      for (u = gfc_rename_list; u; u = u->next)
5280
	{
5299
	{
5281
	  i = get_c_kind (u->use_name, c_interop_kinds_table);
5300
	  i = get_c_kind (u->use_name, c_interop_kinds_table);
5301
	  local_name = u->local_name;
5282
5302
5283
	  if (i == ISOCBINDING_INVALID || i == ISOCBINDING_LAST)
5303
	  if (i == ISOCBINDING_INVALID || i == ISOCBINDING_LAST)
5284
	    {
5304
	    {
5305
	      i = get_c_kind (gfc_get_string ("%s@", u->use_name),
5306
			      c_interop_kinds_table);
5307
	      local_name = gfc_get_string ("%s@", u->local_name);
5308
	    }
5309
	
5310
	  if (i == ISOCBINDING_INVALID || i == ISOCBINDING_LAST)
5311
	    {
5285
	      gfc_error ("Symbol '%s' referenced at %L does not exist in "
5312
	      gfc_error ("Symbol '%s' referenced at %L does not exist in "
5286
			 "intrinsic module ISO_C_BINDING.", u->use_name,
5313
			 "intrinsic module ISO_C_BINDING.", u->use_name,
5287
			 &u->where);
5314
			 &u->where);
Lines 5289-5296 import_iso_c_binding_module (void) Link Here
5289
	    }
5316
	    }
5290
	  
5317
	  
5291
	  generate_isocbinding_symbol (iso_c_module_name,
5318
	  generate_isocbinding_symbol (iso_c_module_name,
5292
				       (iso_c_binding_symbol) i,
5319
				       (iso_c_binding_symbol) i, local_name);
5293
				       u->local_name);
5294
	}
5320
	}
5295
    }
5321
    }
5296
  else
5322
  else
Lines 5307-5312 import_iso_c_binding_module (void) Link Here
5307
		  break;
5333
		  break;
5308
		}
5334
		}
5309
	    }
5335
	    }
5336
	  for (u = gfc_rename_list; u; u = u->next)
5337
	    {
5338
	      if (u->found)
5339
		continue;
5340
	      if (strcmp (c_interop_kinds_table[i].name,
5341
			  gfc_get_string ("%s@", u->use_name)) == 0)
5342
		{
5343
		  local_name = gfc_get_string ("%s@", u->local_name);
5344
		  u->found = 1;
5345
		  break;
5346
		}
5347
	    }
5310
	  generate_isocbinding_symbol (iso_c_module_name,
5348
	  generate_isocbinding_symbol (iso_c_module_name,
5311
				       (iso_c_binding_symbol) i,
5349
				       (iso_c_binding_symbol) i,
5312
				       local_name);
5350
				       local_name);
(-)a/gcc/fortran/primary.c (-2 / +171 lines)
Lines 2237-2242 build_actual_constructor (gfc_structure_ctor_component **comp_head, Link Here
2237
  return SUCCESS;
2237
  return SUCCESS;
2238
}
2238
}
2239
2239
2240
2241
gfc_try
2242
gfc_convert_to_structure_constructor (gfc_expr *expr, gfc_symbol *sym)
2243
{
2244
  gfc_actual_arglist *actual;
2245
  gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
2246
  gfc_constructor_base ctor_head = NULL;
2247
  gfc_component *comp; /* Is set NULL when named component is first seen */
2248
  const char* last_name = NULL;
2249
  locus old_locus;
2250
2251
  old_locus = gfc_current_locus;
2252
  gfc_current_locus = expr->where;
2253
2254
  comp_tail = comp_head = NULL;
2255
2256
  if (sym->attr.abstract)
2257
    {
2258
      char *name = xstrdup (sym->name);
2259
2260
      name[strlen (name) - 1] = '\0';
2261
      gfc_error ("Can't construct ABSTRACT type '%s' at %L",
2262
		 name, &expr->where);
2263
      gfc_free (name);
2264
      goto cleanup;
2265
    }
2266
2267
  comp = sym->components;
2268
  for (actual = expr->value.function.actual; actual; actual = actual->next)
2269
    {
2270
      gfc_component *this_comp = NULL;
2271
2272
      if (!comp_head)
2273
	comp_tail = comp_head = gfc_get_structure_ctor_component ();
2274
      else
2275
	{
2276
	  comp_tail->next = gfc_get_structure_ctor_component ();
2277
	  comp_tail = comp_tail->next;
2278
       	}
2279
      if (actual->name)
2280
	{
2281
	  comp_tail->name = xstrdup (actual->name); /*CONST_CAST (char *, actual->name);*/
2282
	  last_name = comp_tail->name;
2283
	  comp = NULL;
2284
	}
2285
      else
2286
	{
2287
	  /* Components without name are not allowed after the first named
2288
	     component initializer!  */
2289
	  if (!comp)
2290
	    {
2291
	      if (last_name)
2292
		gfc_error ("Component initializer without name after component"
2293
			   " named %s at %L!", last_name,
2294
			   actual->expr ? &actual->expr->where
2295
					: &gfc_current_locus);
2296
	      else
2297
		gfc_error ("Too many components in structure constructor at "
2298
			   "%L!", actual->expr ? &actual->expr->where
2299
					       : &gfc_current_locus);
2300
	      goto cleanup;
2301
	    }
2302
2303
	  comp_tail->name = xstrdup (comp->name); /*CONST_CAST (char *, comp->name);*/
2304
	}
2305
2306
      /* Find the current component in the structure definition and check
2307
	     its access is not private.  */
2308
      if (comp)
2309
	this_comp = gfc_find_component (sym, comp->name, false, false);
2310
      else
2311
	{
2312
	  this_comp = gfc_find_component (sym, (const char *)comp_tail->name,
2313
					  false, false);
2314
	  comp = NULL; /* Reset needed!  */
2315
	}
2316
2317
      /* Here we can check if a component name is given which does not
2318
	 correspond to any component of the defined structure.  */
2319
      if (!this_comp)
2320
	goto cleanup;
2321
2322
      comp_tail->val = actual->expr;
2323
      if (actual->expr != NULL)
2324
	comp_tail->where = actual->expr->where;
2325
      actual->expr = NULL;
2326
2327
      /* Check if this component is already given a value.  */
2328
      for (comp_iter = comp_head; comp_iter != comp_tail; 
2329
	   comp_iter = comp_iter->next)
2330
	{
2331
	  gcc_assert (comp_iter);
2332
	  if (!strcmp (comp_iter->name, comp_tail->name))
2333
	    {
2334
	      gfc_error ("Component '%s' is initialized twice in the structure"
2335
			 " constructor at %L!", comp_tail->name,
2336
			 comp_tail->val ? &comp_tail->where
2337
					: &gfc_current_locus);
2338
	      goto cleanup;
2339
	    }
2340
	}
2341
2342
      /* F2008, R457/C725, for PURE C1283.  */
2343
      if (this_comp->attr.pointer && comp_tail->val
2344
	  && gfc_is_coindexed (comp_tail->val))
2345
     	{
2346
       	  gfc_error ("Coindexed expression to pointer component '%s' in "
2347
		     "structure constructor at %L!", comp_tail->name,
2348
		     &comp_tail->where);
2349
	  goto cleanup;
2350
	}
2351
2352
      if (comp)
2353
	comp = comp->next;
2354
    }
2355
2356
  if (build_actual_constructor (&comp_head, &ctor_head, sym) == FAILURE)
2357
    goto cleanup;
2358
2359
  /* No component should be left, as this should have caused an error in the
2360
     loop constructing the component-list (name that does not correspond to any
2361
     component in the structure definition).  */
2362
  if (comp_head && sym->attr.extension)
2363
    {
2364
      for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
2365
	{
2366
	  gfc_error ("component '%s' at %L has already been set by a "
2367
		     "parent derived type constructor", comp_iter->name,
2368
		     &comp_iter->where);
2369
	}
2370
      goto cleanup;
2371
    }
2372
  else
2373
    gcc_assert (!comp_head);
2374
2375
  expr->ts.u.derived = sym;
2376
  expr->ts.kind = 0;
2377
  expr->ts.type = BT_DERIVED;
2378
  expr->value.constructor = ctor_head;
2379
  expr->expr_type = EXPR_STRUCTURE;
2380
2381
  gfc_current_locus = old_locus; 
2382
  return SUCCESS;
2383
2384
  cleanup:
2385
  gfc_current_locus = old_locus; 
2386
2387
  for (comp_iter = comp_head; comp_iter; )
2388
    {
2389
      gfc_structure_ctor_component *next = comp_iter->next;
2390
      gfc_free_structure_ctor_component (comp_iter);
2391
      comp_iter = next;
2392
    }
2393
/*  gfc_constructor_free (ctor_head);*/
2394
2395
  return FAILURE;
2396
}
2397
2398
2399
2240
match
2400
match
2241
gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
2401
gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
2242
				 bool parent)
2402
				 bool parent)
Lines 2261-2267 gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result, Link Here
2261
  /* Check that we're not about to construct an ABSTRACT type.  */
2421
  /* Check that we're not about to construct an ABSTRACT type.  */
2262
  if (!parent && sym->attr.abstract)
2422
  if (!parent && sym->attr.abstract)
2263
    {
2423
    {
2264
      gfc_error ("Can't construct ABSTRACT type '%s' at %C", sym->name);
2424
      char *name = xstrdup (sym->name);
2425
      name[strlen (name) - 1] = '\0';
2426
      gfc_error ("Can't construct ABSTRACT type '%s' at %C", name);
2427
      gfc_free (name);
2265
      return MATCH_ERROR;
2428
      return MATCH_ERROR;
2266
    }
2429
    }
2267
2430
Lines 2629-2635 gfc_match_rvalue (gfc_expr **result) Link Here
2629
      if (sym == NULL)
2792
      if (sym == NULL)
2630
	m = MATCH_ERROR;
2793
	m = MATCH_ERROR;
2631
      else
2794
      else
2632
	m = gfc_match_structure_constructor (sym, &e, false);
2795
	goto generic_function;
2633
      break;
2796
      break;
2634
2797
2635
    /* If we're here, then the name is known to be the name of a
2798
    /* If we're here, then the name is known to be the name of a
Lines 2903-2908 gfc_match_rvalue (gfc_expr **result) Link Here
2903
      e->symtree = symtree;
3066
      e->symtree = symtree;
2904
      e->expr_type = EXPR_FUNCTION;
3067
      e->expr_type = EXPR_FUNCTION;
2905
3068
3069
      if (sym->attr.flavor == FL_DERIVED)
3070
	{
3071
	  e->value.function.esym = sym;
3072
	  e->symtree->n.sym->attr.generic = 1;
3073
	}
3074
2906
      m = gfc_match_actual_arglist (0, &e->value.function.actual);
3075
      m = gfc_match_actual_arglist (0, &e->value.function.actual);
2907
      break;
3076
      break;
2908
3077
(-)a/gcc/fortran/resolve.c (-14 / +75 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 1950-1955 resolve_generic_f (gfc_expr *expr) Link Here
1950
{
1955
{
1951
  gfc_symbol *sym;
1956
  gfc_symbol *sym;
1952
  match m;
1957
  match m;
1958
  gfc_interface *intr = NULL;
1953
1959
1954
  sym = expr->symtree->n.sym;
1960
  sym = expr->symtree->n.sym;
1955
1961
Lines 1962-1967 resolve_generic_f (gfc_expr *expr) Link Here
1962
	return FAILURE;
1968
	return FAILURE;
1963
1969
1964
generic:
1970
generic:
1971
      if (!intr)
1972
	for (intr = sym->generic; intr; intr = intr->next)
1973
	  if (intr->sym->attr.flavor == FL_DERIVED)
1974
	    break;
1975
1965
      if (sym->ns->parent == NULL)
1976
      if (sym->ns->parent == NULL)
1966
	break;
1977
	break;
1967
      gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1978
      gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
Lines 1974-1989 generic: Link Here
1974
1985
1975
  /* Last ditch attempt.  See if the reference is to an intrinsic
1986
  /* Last ditch attempt.  See if the reference is to an intrinsic
1976
     that possesses a matching interface.  14.1.2.4  */
1987
     that possesses a matching interface.  14.1.2.4  */
1977
  if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
1988
  if (sym  && !intr && !gfc_is_intrinsic (sym, 0, expr->where))
1978
    {
1989
    {
1979
      gfc_error ("There is no specific function for the generic '%s' at %L",
1990
      gfc_error ("There is no specific function for the generic '%s' "
1980
		 expr->symtree->n.sym->name, &expr->where);
1991
		 "at %L", expr->symtree->n.sym->name, &expr->where);
1981
      return FAILURE;
1992
      return FAILURE;
1982
    }
1993
    }
1983
1994
1995
  if (intr)
1996
    {
1997
      if (gfc_convert_to_structure_constructor (expr, intr->sym) != SUCCESS)
1998
	return FAILURE;
1999
      return resolve_structure_cons (expr);
2000
    }
2001
1984
  m = gfc_intrinsic_func_interface (expr, 0);
2002
  m = gfc_intrinsic_func_interface (expr, 0);
1985
  if (m == MATCH_YES)
2003
  if (m == MATCH_YES)
1986
    return SUCCESS;
2004
    return SUCCESS;
2005
1987
  if (m == MATCH_NO)
2006
  if (m == MATCH_NO)
1988
    gfc_error ("Generic function '%s' at %L is not consistent with a "
2007
    gfc_error ("Generic function '%s' at %L is not consistent with a "
1989
	       "specific intrinsic interface", expr->symtree->n.sym->name,
2008
	       "specific intrinsic interface", expr->symtree->n.sym->name,
Lines 10575-10586 resolve_fl_derived (gfc_symbol *sym) Link Here
10575
10594
10576
  super_type = gfc_get_derived_super_type (sym);
10595
  super_type = gfc_get_derived_super_type (sym);
10577
10596
10597
10578
  /* F2008, C432. */
10598
  /* F2008, C432. */
10579
  if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
10599
  if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
10580
    {
10600
    {
10601
      char *super_name = xstrdup (super_type->name);
10602
      char *name = xstrdup (sym->name);
10603
10604
      super_name[strlen (super_name)-1] = '\0';
10605
      name[strlen (super_name)-1] = '\0';
10606
10581
      gfc_error ("As extending type '%s' at %L has a coarray component, "
10607
      gfc_error ("As extending type '%s' at %L has a coarray component, "
10582
		 "parent type '%s' shall also have one", sym->name,
10608
		 "parent type '%s' shall also have one", name,
10583
		 &sym->declared_at, super_type->name);
10609
		 &sym->declared_at, super_name);
10610
      gfc_free (super_name);
10611
      gfc_free (name);
10584
      return FAILURE;
10612
      return FAILURE;
10585
    }
10613
    }
10586
10614
Lines 10591-10598 resolve_fl_derived (gfc_symbol *sym) Link Here
10591
  /* An ABSTRACT type must be extensible.  */
10619
  /* An ABSTRACT type must be extensible.  */
10592
  if (sym->attr.abstract && !gfc_type_is_extensible (sym))
10620
  if (sym->attr.abstract && !gfc_type_is_extensible (sym))
10593
    {
10621
    {
10622
      char *name = xstrdup (sym->name);
10623
10624
      name[strlen (name)-1] = '\0';
10594
      gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
10625
      gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
10595
		 sym->name, &sym->declared_at);
10626
		 name, &sym->declared_at);
10627
      gfc_free (name);
10596
      return FAILURE;
10628
      return FAILURE;
10597
    }
10629
    }
10598
10630
Lines 10765-10774 resolve_fl_derived (gfc_symbol *sym) Link Here
10765
	      || (me_arg->ts.type == BT_CLASS
10797
	      || (me_arg->ts.type == BT_CLASS
10766
		  && me_arg->ts.u.derived->components->ts.u.derived != sym))
10798
		  && me_arg->ts.u.derived->components->ts.u.derived != sym))
10767
	    {
10799
	    {
10800
	      char *name = xstrdup (sym->name);
10801
10802
	      name[strlen (name)-1] = '\0';
10768
	      gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
10803
	      gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
10769
			 " the derived type '%s'", me_arg->name, c->name,
10804
			 " the derived type '%s'", me_arg->name, c->name,
10770
			 me_arg->name, &c->loc, sym->name);
10805
			 me_arg->name, &c->loc, name);
10771
	      c->tb->error = 1;
10806
	      c->tb->error = 1;
10807
	      gfc_free (name);
10772
	      return FAILURE;
10808
	      return FAILURE;
10773
	    }
10809
	    }
10774
10810
Lines 10822-10830 resolve_fl_derived (gfc_symbol *sym) Link Here
10822
      if (super_type && !sym->attr.is_class
10858
      if (super_type && !sym->attr.is_class
10823
	  && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
10859
	  && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
10824
	{
10860
	{
10861
	  char *name = xstrdup (sym->name);
10862
10863
	  name[strlen (name)-1] = '\0';
10825
	  gfc_error ("Component '%s' of '%s' at %L has the same name as an"
10864
	  gfc_error ("Component '%s' of '%s' at %L has the same name as an"
10826
		     " inherited type-bound procedure",
10865
		     " inherited type-bound procedure",
10827
		     c->name, sym->name, &c->loc);
10866
		     c->name, name, &c->loc);
10867
	  gfc_free (name);
10828
	  return FAILURE;
10868
	  return FAILURE;
10829
	}
10869
	}
10830
10870
Lines 10848-10859 resolve_fl_derived (gfc_symbol *sym) Link Here
10848
	  && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
10888
	  && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
10849
	  && !c->ts.u.derived->attr.use_assoc
10889
	  && !c->ts.u.derived->attr.use_assoc
10850
	  && !gfc_check_access (c->ts.u.derived->attr.access,
10890
	  && !gfc_check_access (c->ts.u.derived->attr.access,
10851
				c->ts.u.derived->ns->default_access)
10891
				c->ts.u.derived->ns->default_access))
10852
	  && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
10892
	{
10893
	  char *name = xstrdup (sym->name);
10894
10895
	  name[strlen (name)-1] = '\0';
10896
	  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
10853
			     "is a PRIVATE type and cannot be a component of "
10897
			     "is a PRIVATE type and cannot be a component of "
10854
			     "'%s', which is PUBLIC at %L", c->name,
10898
			     "'%s', which is PUBLIC at %L", c->name,
10855
			     sym->name, &sym->declared_at) == FAILURE)
10899
			     sym->name, &sym->declared_at) == FAILURE)
10856
	return FAILURE;
10900
	    {
10901
	      gfc_free (name);
10902
	      return FAILURE;
10903
	    }
10904
	  gfc_free (name);
10905
	}
10857
10906
10858
      if (sym->attr.sequence)
10907
      if (sym->attr.sequence)
10859
	{
10908
	{
Lines 10870-10878 resolve_fl_derived (gfc_symbol *sym) Link Here
10870
	  && c->ts.u.derived->components == NULL
10919
	  && c->ts.u.derived->components == NULL
10871
	  && !c->ts.u.derived->attr.zero_comp)
10920
	  && !c->ts.u.derived->attr.zero_comp)
10872
	{
10921
	{
10922
	  char *name = xstrdup (sym->name);
10923
10924
	  name[strlen (name)-1] = '\0';
10873
	  gfc_error ("The pointer component '%s' of '%s' at %L is a type "
10925
	  gfc_error ("The pointer component '%s' of '%s' at %L is a type "
10874
		     "that has not been declared", c->name, sym->name,
10926
		     "that has not been declared", c->name, sym->name,
10875
		     &c->loc);
10927
		     &c->loc);
10928
	  gfc_free (name);
10876
	  return FAILURE;
10929
	  return FAILURE;
10877
	}
10930
	}
10878
10931
Lines 10880-10888 resolve_fl_derived (gfc_symbol *sym) Link Here
10880
	  && c->ts.u.derived->components->ts.u.derived->components == NULL
10933
	  && c->ts.u.derived->components->ts.u.derived->components == NULL
10881
	  && !c->ts.u.derived->components->ts.u.derived->attr.zero_comp)
10934
	  && !c->ts.u.derived->components->ts.u.derived->attr.zero_comp)
10882
	{
10935
	{
10936
	  char *name = xstrdup (sym->name);
10937
10938
	  name[strlen (name)-1] = '\0';
10883
	  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 "
10884
		     "that has not been declared", c->name, sym->name,
10940
		     "that has not been declared", c->name, sym->name,
10885
		     &c->loc);
10941
		     &c->loc);
10942
	  gfc_free (name);
10886
	  return FAILURE;
10943
	  return FAILURE;
10887
	}
10944
	}
10888
10945
Lines 10919-10927 resolve_fl_derived (gfc_symbol *sym) Link Here
10919
	      || (resolve_index_expr (c->as->upper[i]) == FAILURE)
10976
	      || (resolve_index_expr (c->as->upper[i]) == FAILURE)
10920
	      || !gfc_is_constant_expr (c->as->upper[i]))
10977
	      || !gfc_is_constant_expr (c->as->upper[i]))
10921
	    {
10978
	    {
10979
	      char *name = xstrdup (sym->name);
10980
10981
	      name[strlen (name)-1] = '\0';
10922
	      gfc_error ("Component '%s' of '%s' at %L must have "
10982
	      gfc_error ("Component '%s' of '%s' at %L must have "
10923
			 "constant array bounds",
10983
			 "constant array bounds",
10924
			 c->name, sym->name, &c->loc);
10984
			 c->name, sym->name, &c->loc);
10985
	      gfc_free (name);
10925
	      return FAILURE;
10986
	      return FAILURE;
10926
	    }
10987
	    }
10927
	}
10988
	}
(-)a/gcc/fortran/symbol.c (-2 / +42 lines)
Lines 1954-1961 gfc_use_derived (gfc_symbol *sym) Link Here
1954
  return s;
1954
  return s;
1955
1955
1956
bad:
1956
bad:
1957
  gfc_error ("Derived type '%s' at %C is being used before it is defined",
1957
  {
1958
	     sym->name);
1958
    char *name = xstrdup (sym->name);
1959
    name[strlen (name) - 1] = '\0';
1960
    gfc_error ("Derived type '%s' at %C is being used before it is defined",
1961
	       name);
1962
    gfc_free (name);
1963
  }
1959
  return NULL;
1964
  return NULL;
1960
}
1965
}
1961
1966
Lines 4407-4412 generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s, Link Here
4407
4412
4408
        /* Make it use associated (iso_c_binding module).  */
4413
        /* Make it use associated (iso_c_binding module).  */
4409
        tmp_sym->attr.use_assoc = 1;
4414
        tmp_sym->attr.use_assoc = 1;
4415
4416
	/* Generate an artificial generic function.  */
4417
	{
4418
	  gfc_interface *intr, *head;
4419
	  char *gen_name = xstrdup (name);
4420
4421
	  gen_name[strlen (gen_name) - 1] = '\0';
4422
	  tmp_symtree = NULL;
4423
	  gfc_get_sym_tree (gen_name, gfc_current_ns, &tmp_symtree, false);
4424
	  gfc_free (gen_name);
4425
4426
	  if (!tmp_symtree)
4427
	    gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4428
				"create symbol");
4429
	  head = tmp_symtree->n.sym->generic;
4430
	  intr = gfc_get_interface ();
4431
	  intr->sym = tmp_sym;
4432
	  intr->where = gfc_current_locus;
4433
	  intr->next = head;
4434
	  tmp_sym = tmp_symtree->n.sym;
4435
	  tmp_sym->generic = intr;
4436
	}
4437
4438
	/* Say what module this symbol belongs to.  */
4439
	tmp_sym->module = gfc_get_string (mod_name);
4440
	tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
4441
4442
	if (!tmp_sym->attr.generic
4443
	    && gfc_add_generic (&tmp_sym->attr, name, NULL) == FAILURE)
4444
	  return;
4445
4446
	if (!tmp_sym->attr.function
4447
	    && gfc_add_function (&tmp_sym->attr, name, NULL) == FAILURE)
4448
	  return;
4449
4410
	break;
4450
	break;
4411
4451
4412
      case ISOCBINDING_NULL_PTR:
4452
      case ISOCBINDING_NULL_PTR:
(-)a/gcc/fortran/trans-types.c (-1 / +1 lines)
Lines 320-326 void init_c_interop_kinds (void) Link Here
320
  c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
320
  c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
321
  c_interop_kinds_table[a].value = c;
321
  c_interop_kinds_table[a].value = c;
322
#define DERIVED_TYPE(a,b,c) \
322
#define DERIVED_TYPE(a,b,c) \
323
  strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
323
  strncpy (c_interop_kinds_table[a].name, b "@", strlen(b) + 2); \
324
  c_interop_kinds_table[a].f90_type = BT_DERIVED; \
324
  c_interop_kinds_table[a].f90_type = BT_DERIVED; \
325
  c_interop_kinds_table[a].value = c;
325
  c_interop_kinds_table[a].value = c;
326
#define PROCEDURE(a,b) \
326
#define PROCEDURE(a,b) \

Return to bug 39427