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

Collapse All | Expand All

(-)a/gcc/fortran/class.c (-9 / +20 lines)
Lines 119-136 gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, Link Here
119
  gfc_symbol *fclass;
119
  gfc_symbol *fclass;
120
  gfc_symbol *vtab;
120
  gfc_symbol *vtab;
121
  gfc_component *c;
121
  gfc_component *c;
122
  char *dt_name;
123
124
  dt_name = xstrdup (ts->u.derived->name);
125
  dt_name[strlen (dt_name) - 1] = '\0';
122
126
123
  /* Determine the name of the encapsulating type.  */
127
  /* Determine the name of the encapsulating type.  */
124
  if ((*as) && (*as)->rank && attr->allocatable)
128
  if ((*as) && (*as)->rank && attr->allocatable)
125
    sprintf (name, "class$%s_%d_a", ts->u.derived->name, (*as)->rank);
129
    sprintf (name, "class$%s_%d_a", dt_name, (*as)->rank);
126
  else if ((*as) && (*as)->rank)
130
  else if ((*as) && (*as)->rank)
127
    sprintf (name, "class$%s_%d", ts->u.derived->name, (*as)->rank);
131
    sprintf (name, "class$%s_%d", dt_name, (*as)->rank);
128
  else if (attr->pointer)
132
  else if (attr->pointer)
129
    sprintf (name, "class$%s_p", ts->u.derived->name);
133
    sprintf (name, "class$%s_p", dt_name);
130
  else if (attr->allocatable)
134
  else if (attr->allocatable)
131
    sprintf (name, "class$%s_a", ts->u.derived->name);
135
    sprintf (name, "class$%s_a", dt_name);
132
  else
136
  else
133
    sprintf (name, "class$%s", ts->u.derived->name);
137
    sprintf (name, "class$%s", dt_name);
134
138
135
  gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass);
139
  gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass);
136
  if (fclass == NULL)
140
  if (fclass == NULL)
Lines 187-193 gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, Link Here
187
  if (ts->u.derived->attr.extension == 255)
191
  if (ts->u.derived->attr.extension == 255)
188
    {
192
    {
189
      gfc_error ("Maximum extension level reached with type '%s' at %L",
193
      gfc_error ("Maximum extension level reached with type '%s' at %L",
190
		 ts->u.derived->name, &ts->u.derived->declared_at);
194
		 dt_name, &ts->u.derived->declared_at);
191
      return FAILURE;
195
      return FAILURE;
192
    }
196
    }
193
    
197
    
Lines 196-201 gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, Link Here
196
  ts->u.derived = fclass;
200
  ts->u.derived = fclass;
197
  attr->allocatable = attr->pointer = attr->dimension = 0;
201
  attr->allocatable = attr->pointer = attr->dimension = 0;
198
  (*as) = NULL;  /* XXX */
202
  (*as) = NULL;  /* XXX */
203
  gfc_free (dt_name);
199
  return SUCCESS;
204
  return SUCCESS;
200
}
205
}
201
206
Lines 320-325 gfc_find_derived_vtab (gfc_symbol *derived) Link Here
320
{
325
{
321
  gfc_namespace *ns;
326
  gfc_namespace *ns;
322
  gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL;
327
  gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL;
328
  char *dt_name = NULL;
323
  char name[2 * GFC_MAX_SYMBOL_LEN + 8];
329
  char name[2 * GFC_MAX_SYMBOL_LEN + 8];
324
  
330
  
325
  /* Find the top-level namespace (MODULE or PROGRAM).  */
331
  /* Find the top-level namespace (MODULE or PROGRAM).  */
Lines 333-339 gfc_find_derived_vtab (gfc_symbol *derived) Link Here
333
    
339
    
334
  if (ns)
340
  if (ns)
335
    {
341
    {
336
      sprintf (name, "vtab$%s", derived->name);
342
343
      dt_name = xstrdup (derived->name);
344
      dt_name[strlen (dt_name) - 1] = '\0';
345
      sprintf (name, "vtab$%s", dt_name);
346
337
      gfc_find_symbol (name, ns, 0, &vtab);
347
      gfc_find_symbol (name, ns, 0, &vtab);
338
348
339
      if (vtab == NULL)
349
      if (vtab == NULL)
Lines 348-354 gfc_find_derived_vtab (gfc_symbol *derived) Link Here
348
	  vtab->attr.vtab = 1;
358
	  vtab->attr.vtab = 1;
349
	  vtab->attr.access = ACCESS_PUBLIC;
359
	  vtab->attr.access = ACCESS_PUBLIC;
350
	  gfc_set_sym_referenced (vtab);
360
	  gfc_set_sym_referenced (vtab);
351
	  sprintf (name, "vtype$%s", derived->name);
361
	  sprintf (name, "vtype$%s", dt_name);
352
	  
362
	  
353
	  gfc_find_symbol (name, ns, 0, &vtype);
363
	  gfc_find_symbol (name, ns, 0, &vtype);
354
	  if (vtype == NULL)
364
	  if (vtype == NULL)
Lines 420-426 gfc_find_derived_vtab (gfc_symbol *derived) Link Here
420
	      else
430
	      else
421
		{
431
		{
422
		  /* Construct default initialization variable.  */
432
		  /* Construct default initialization variable.  */
423
		  sprintf (name, "def_init$%s", derived->name);
433
		  sprintf (name, "def_init$%s", dt_name);
424
		  gfc_get_symbol (name, ns, &def_init);
434
		  gfc_get_symbol (name, ns, &def_init);
425
		  def_init->attr.target = 1;
435
		  def_init->attr.target = 1;
426
		  def_init->attr.save = SAVE_EXPLICIT;
436
		  def_init->attr.save = SAVE_EXPLICIT;
Lines 449-454 gfc_find_derived_vtab (gfc_symbol *derived) Link Here
449
cleanup:
459
cleanup:
450
  /* It is unexpected to have some symbols added at resolution or code
460
  /* It is unexpected to have some symbols added at resolution or code
451
     generation time. We commit the changes in order to keep a clean state.  */
461
     generation time. We commit the changes in order to keep a clean state.  */
462
  gfc_free (dt_name);
452
  if (found_sym)
463
  if (found_sym)
453
    {
464
    {
454
      gfc_commit_symbol (vtab);
465
      gfc_commit_symbol (vtab);
(-)a/gcc/fortran/decl.c (-10 / +80 lines)
Lines 327-332 match_data_constant (gfc_expr **result) Link Here
327
  gfc_expr *expr;
327
  gfc_expr *expr;
328
  match m;
328
  match m;
329
  locus old_loc;
329
  locus old_loc;
330
  gfc_interface *intr = NULL;
330
331
331
  m = gfc_match_literal_constant (&expr, 1);
332
  m = gfc_match_literal_constant (&expr, 1);
332
  if (m == MATCH_YES)
333
  if (m == MATCH_YES)
Lines 366-380 match_data_constant (gfc_expr **result) Link Here
366
  if (gfc_find_symbol (name, NULL, 1, &sym))
367
  if (gfc_find_symbol (name, NULL, 1, &sym))
367
    return MATCH_ERROR;
368
    return MATCH_ERROR;
368
369
369
  if (sym == NULL
370
  /* Check for derived type.  */
370
      || (sym->attr.flavor != FL_PARAMETER && sym->attr.flavor != FL_DERIVED))
371
  if (sym && sym->attr.generic)
372
    for (intr = (sym ? sym->generic : NULL); intr; intr = intr->next)
373
      if (intr->sym->attr.flavor == FL_DERIVED)
374
	break;
375
376
  if (sym == NULL || (sym->attr.flavor != FL_PARAMETER && !intr))
371
    {
377
    {
372
      gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
378
      gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
373
		 name);
379
		 name);
374
      return MATCH_ERROR;
380
      return MATCH_ERROR;
375
    }
381
    }
376
  else if (sym->attr.flavor == FL_DERIVED)
382
  else if (intr)
377
    return gfc_match_structure_constructor (sym, result, false);
383
    /* FIXME: Consider replacing by gfc_convert_to_structure_constructor? */
384
    return gfc_match_structure_constructor (intr->sym, result, false);
378
385
379
  /* Check to see if the value is an initialization array expression.  */
386
  /* Check to see if the value is an initialization array expression.  */
380
  if (sym->value->expr_type == EXPR_ARRAY)
387
  if (sym->value->expr_type == EXPR_ARRAY)
Lines 2438-2444 done: Link Here
2438
match
2445
match
2439
gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
2446
gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
2440
{
2447
{
2441
  char name[GFC_MAX_SYMBOL_LEN + 1];
2448
  char name[GFC_MAX_SYMBOL_LEN + 2];
2442
  gfc_symbol *sym;
2449
  gfc_symbol *sym;
2443
  match m;
2450
  match m;
2444
  char c;
2451
  char c;
Lines 2588-2593 gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) Link Here
2588
	return MATCH_ERROR;
2595
	return MATCH_ERROR;
2589
    }
2596
    }
2590
2597
2598
  if (ts->type == BT_CLASS || ts->type == BT_DERIVED)
2599
    {
2600
      size_t len = strlen (name);
2601
      name[len] = '@';
2602
      name[len+1] = '\0';
2603
    }
2604
2591
  /* Defer association of the derived type until the end of the
2605
  /* Defer association of the derived type until the end of the
2592
     specification block.  However, if the derived type can be
2606
     specification block.  However, if the derived type can be
2593
     found, add it to the typespec.  */  
2607
     found, add it to the typespec.  */  
Lines 2606-2611 gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) Link Here
2606
  sym = NULL;
2620
  sym = NULL;
2607
  if (ts->kind != -1 && gfc_get_ha_symbol (name, &sym))
2621
  if (ts->kind != -1 && gfc_get_ha_symbol (name, &sym))
2608
    {
2622
    {
2623
      if (ts->type == BT_CLASS || ts->type == BT_DERIVED)
2624
	name[strlen (name)-1] = '\0';
2625
2609
      gfc_error ("Type name '%s' at %C is ambiguous", name);
2626
      gfc_error ("Type name '%s' at %C is ambiguous", name);
2610
      return MATCH_ERROR;
2627
      return MATCH_ERROR;
2611
    }
2628
    }
Lines 2615-2620 gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) Link Here
2615
		    || gfc_current_ns->has_import_set;
2632
		    || gfc_current_ns->has_import_set;
2616
      if (gfc_find_symbol (name, NULL, iface, &sym))
2633
      if (gfc_find_symbol (name, NULL, iface, &sym))
2617
	{       
2634
	{       
2635
	  if (ts->type == BT_CLASS || ts->type == BT_DERIVED)
2636
	    name[strlen (name)-1] = '\0';
2637
2618
	  gfc_error ("Type name '%s' at %C is ambiguous", name);
2638
	  gfc_error ("Type name '%s' at %C is ambiguous", name);
2619
	  return MATCH_ERROR;
2639
	  return MATCH_ERROR;
2620
	}
2640
	}
Lines 2980-2985 gfc_match_import (void) Link Here
2980
	  sym->refs++;
3000
	  sym->refs++;
2981
	  sym->attr.imported = 1;
3001
	  sym->attr.imported = 1;
2982
3002
3003
	  /* Also import derived types.  */
3004
	  if (sym->attr.generic && sym->attr.function)
3005
	    {
3006
	      gfc_interface *intr = NULL;
3007
	      for (intr = sym->generic; intr; intr = intr->next)
3008
		if (intr->sym->attr.flavor == FL_DERIVED)
3009
		  break;
3010
	      if (intr == NULL)
3011
		goto next_item;
3012
3013
	      st = gfc_new_symtree (&gfc_current_ns->sym_root,
3014
				    intr->sym->name);
3015
	      st->n.sym = intr->sym;
3016
	      intr->sym->refs++;
3017
	      intr->sym->attr.imported = 1;
3018
            }
3019
2983
	  goto next_item;
3020
	  goto next_item;
2984
3021
2985
	case MATCH_NO:
3022
	case MATCH_NO:
Lines 5681-5687 set_enum_kind(void) Link Here
5681
match
5718
match
5682
gfc_match_end (gfc_statement *st)
5719
gfc_match_end (gfc_statement *st)
5683
{
5720
{
5684
  char name[GFC_MAX_SYMBOL_LEN + 1];
5721
  char name[GFC_MAX_SYMBOL_LEN + 2];
5685
  gfc_compile_state state;
5722
  gfc_compile_state state;
5686
  locus old_loc;
5723
  locus old_loc;
5687
  const char *block_name;
5724
  const char *block_name;
Lines 5888-5894 gfc_match_end (gfc_statement *st) Link Here
5888
  if (block_name == NULL)
5925
  if (block_name == NULL)
5889
    goto syntax;
5926
    goto syntax;
5890
5927
5891
  if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0)
5928
  if (*st == ST_END_TYPE)
5929
    {
5930
      size_t len = strlen (name);
5931
      name[len] = '@';
5932
      name[len+1] = '\0';
5933
      if (strcmp (name, block_name) != 0)
5934
	{
5935
	  strncpy (name, block_name, strlen (block_name)-1);
5936
	  gfc_error ("Expected label '%s' for %s statement at %C", name,
5937
	  gfc_ascii_statement (*st));
5938
	  goto cleanup;
5939
	}
5940
    }
5941
  else if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0)
5892
    {
5942
    {
5893
      gfc_error ("Expected label '%s' for %s statement at %C", block_name,
5943
      gfc_error ("Expected label '%s' for %s statement at %C", block_name,
5894
		 gfc_ascii_statement (*st));
5944
		 gfc_ascii_statement (*st));
Lines 7049-7055 check_extended_derived_type (char *name) Link Here
7049
{
7099
{
7050
  gfc_symbol *extended;
7100
  gfc_symbol *extended;
7051
7101
7052
  if (gfc_find_symbol (name, gfc_current_ns, 1, &extended))
7102
  if (gfc_find_symbol (gfc_get_string ("%s@", name), gfc_current_ns, 1, &extended))
7053
    {
7103
    {
7054
      gfc_error ("Ambiguous symbol in TYPE definition at %C");
7104
      gfc_error ("Ambiguous symbol in TYPE definition at %C");
7055
      return NULL;
7105
      return NULL;
Lines 7200-7206 hash_value (gfc_symbol *sym) Link Here
7200
match
7250
match
7201
gfc_match_derived_decl (void)
7251
gfc_match_derived_decl (void)
7202
{
7252
{
7203
  char name[GFC_MAX_SYMBOL_LEN + 1];
7253
  char name[GFC_MAX_SYMBOL_LEN + 2];
7204
  char parent[GFC_MAX_SYMBOL_LEN + 1];
7254
  char parent[GFC_MAX_SYMBOL_LEN + 1];
7205
  symbol_attribute attr;
7255
  symbol_attribute attr;
7206
  gfc_symbol *sym;
7256
  gfc_symbol *sym;
Lines 7208-7213 gfc_match_derived_decl (void) Link Here
7208
  match m;
7258
  match m;
7209
  match is_type_attr_spec = MATCH_NO;
7259
  match is_type_attr_spec = MATCH_NO;
7210
  bool seen_attr = false;
7260
  bool seen_attr = false;
7261
  gfc_interface *intr, *head;
7211
7262
7212
  if (gfc_current_state () == COMP_DERIVED)
7263
  if (gfc_current_state () == COMP_DERIVED)
7213
    return MATCH_NO;
7264
    return MATCH_NO;
Lines 7253-7259 gfc_match_derived_decl (void) Link Here
7253
      return MATCH_ERROR;
7304
      return MATCH_ERROR;
7254
    }
7305
    }
7255
7306
7256
  if (gfc_get_symbol (name, NULL, &sym))
7307
  if (gfc_get_symbol (gfc_get_string ("%s@", name), NULL, &sym))
7257
    return MATCH_ERROR;
7308
    return MATCH_ERROR;
7258
7309
7259
  if (sym->ts.type != BT_UNKNOWN)
7310
  if (sym->ts.type != BT_UNKNOWN)
Lines 7332-7337 gfc_match_derived_decl (void) Link Here
7332
7383
7333
  gfc_new_block = sym;
7384
  gfc_new_block = sym;
7334
7385
7386
  /* Generate an artificial generic function.  */
7387
  if (gfc_get_symbol (name, NULL, &sym))
7388
    return MATCH_ERROR;
7389
7390
  if (!sym->attr.generic
7391
      && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
7392
    return MATCH_ERROR;
7393
7394
  if (!sym->attr.function
7395
      && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
7396
    return MATCH_ERROR;
7397
7398
  head = sym->generic;
7399
  intr = gfc_get_interface ();
7400
  intr->sym = gfc_new_block;
7401
  intr->where = gfc_current_locus;
7402
  intr->next = head;
7403
  sym->generic = intr;
7404
7335
  return MATCH_YES;
7405
  return MATCH_YES;
7336
}
7406
}
7337
7407
(-)a/gcc/fortran/gfortran.h (+1 lines)
Lines 2856-2861 match gfc_match_rvalue (gfc_expr **); Link Here
2856
match gfc_match_varspec (gfc_expr*, int, bool, bool);
2856
match gfc_match_varspec (gfc_expr*, int, bool, bool);
2857
int gfc_check_digit (char, int);
2857
int gfc_check_digit (char, int);
2858
bool gfc_is_function_return_value (gfc_symbol *, gfc_namespace *);
2858
bool gfc_is_function_return_value (gfc_symbol *, gfc_namespace *);
2859
gfc_try gfc_convert_to_structure_constructor (gfc_expr *, gfc_symbol *);
2859
2860
2860
/* trans.c */
2861
/* trans.c */
2861
void gfc_generate_code (gfc_namespace *);
2862
void gfc_generate_code (gfc_namespace *);
(-)a/gcc/fortran/interface.c (-4 / +9 lines)
Lines 1101-1108 check_interface0 (gfc_interface *p, const char *interface_name) Link Here
1101
  /* Make sure all symbols in the interface have been defined as
1101
  /* Make sure all symbols in the interface have been defined as
1102
     functions or subroutines.  */
1102
     functions or subroutines.  */
1103
  for (; p; p = p->next)
1103
  for (; p; p = p->next)
1104
    if ((!p->sym->attr.function && !p->sym->attr.subroutine)
1104
    if (((!p->sym->attr.function && !p->sym->attr.subroutine)
1105
	|| !p->sym->attr.if_source)
1105
	 || !p->sym->attr.if_source)
1106
	&& p->sym->attr.flavor != FL_DERIVED)
1106
      {
1107
      {
1107
	if (p->sym->attr.external)
1108
	if (p->sym->attr.external)
1108
	  gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
1109
	  gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
Lines 1159-1166 check_interface1 (gfc_interface *p, gfc_interface *q0, Link Here
1159
	if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
1160
	if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
1160
	  continue;
1161
	  continue;
1161
1162
1162
	if (gfc_compare_interfaces (p->sym, q->sym, q->sym->name, generic_flag,
1163
	if (p->sym->attr.flavor != FL_DERIVED
1163
				    0, NULL, 0))
1164
	    && q->sym->attr.flavor != FL_DERIVED
1165
	    && gfc_compare_interfaces (p->sym, q->sym, q->sym->name,
1166
				       generic_flag, 0, NULL, 0))
1164
	  {
1167
	  {
1165
	    if (referenced)
1168
	    if (referenced)
1166
	      gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1169
	      gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
Lines 2738-2743 gfc_search_interface (gfc_interface *intr, int sub_flag, Link Here
2738
  gfc_symbol *elem_sym = NULL;
2741
  gfc_symbol *elem_sym = NULL;
2739
  for (; intr; intr = intr->next)
2742
  for (; intr; intr = intr->next)
2740
    {
2743
    {
2744
      if (intr->sym->attr.flavor == FL_DERIVED)
2745
	continue;
2741
      if (sub_flag && intr->sym->attr.function)
2746
      if (sub_flag && intr->sym->attr.function)
2742
	continue;
2747
	continue;
2743
      if (!sub_flag && intr->sym->attr.subroutine)
2748
      if (!sub_flag && intr->sym->attr.subroutine)
(-)a/gcc/fortran/match.c (-15 / +25 lines)
Lines 2707-2733 static match Link Here
2707
match_derived_type_spec (gfc_typespec *ts)
2707
match_derived_type_spec (gfc_typespec *ts)
2708
{
2708
{
2709
  locus old_locus; 
2709
  locus old_locus; 
2710
  gfc_symbol *derived;
2710
  match m;
2711
  char buffer[GFC_MAX_SYMBOL_LEN + 1];
2712
  gfc_symtree *st;
2711
2713
2712
  old_locus = gfc_current_locus; 
2714
  old_locus = gfc_current_locus; 
2713
2715
2714
  if (gfc_match_symbol (&derived, 1) == MATCH_YES)
2716
  m = gfc_match_name (buffer);
2717
  if (m != MATCH_YES)
2718
    goto no_match;
2719
2720
  /* We cannot use gfc_get_hat_sym_tree as it creates the symbol,
2721
     but we do not want to create a spurious symbol.  */
2722
  if (gfc_find_sym_tree (gfc_get_string ("%s@", buffer), gfc_current_ns, 1,
2723
      &st) || st == NULL)
2724
    goto no_match;
2725
  
2726
  if (st->n.sym->attr.flavor == FL_DERIVED)
2715
    {
2727
    {
2716
      if (derived->attr.flavor == FL_DERIVED)
2728
       ts->type = BT_DERIVED;
2717
	{
2729
       ts->u.derived = st->n.sym;
2718
	  ts->type = BT_DERIVED;
2730
       return MATCH_YES;
2719
	  ts->u.derived = derived;
2731
    }
2720
	  return MATCH_YES;
2732
  else
2721
	}
2733
    {
2722
      else
2734
       /* Enforce F03:C476.  */
2723
	{
2735
       gfc_error ("'%s' at %L is not an accessible derived type",
2724
	  /* Enforce F03:C476.  */
2736
		  buffer, &gfc_current_locus);
2725
	  gfc_error ("'%s' at %L is not an accessible derived type",
2737
       return MATCH_ERROR;
2726
		     derived->name, &gfc_current_locus);
2727
	  return MATCH_ERROR;
2728
	}
2729
    }
2738
    }
2730
2739
2740
no_match:
2731
  gfc_current_locus = old_locus; 
2741
  gfc_current_locus = old_locus; 
2732
  return MATCH_NO;
2742
  return MATCH_NO;
2733
}
2743
}
(-)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 (-6 / +33 lines)
Lines 4259-4271 read_module (void) Link Here
4259
{
4259
{
4260
  module_locus operator_interfaces, user_operators, extensions;
4260
  module_locus operator_interfaces, user_operators, extensions;
4261
  const char *p;
4261
  const char *p;
4262
  char name[GFC_MAX_SYMBOL_LEN + 1];
4262
  char name[GFC_MAX_SYMBOL_LEN + 2];
4263
  int i;
4263
  int i;
4264
  int ambiguous, j, nuse, symbol;
4264
  int ambiguous, j, nuse, symbol;
4265
  pointer_info *info, *q;
4265
  pointer_info *info, *q;
4266
  gfc_use_rename *u;
4266
  gfc_use_rename *u;
4267
  gfc_symtree *st;
4267
  gfc_symtree *st;
4268
  gfc_symbol *sym;
4268
  gfc_symbol *sym;
4269
  char *dt_name;
4269
4270
4270
  get_module_locus (&operator_interfaces);	/* Skip these for now.  */
4271
  get_module_locus (&operator_interfaces);	/* Skip these for now.  */
4271
  skip_list ();
4272
  skip_list ();
Lines 4363-4372 read_module (void) Link Here
4363
      if (nuse == 0)
4364
      if (nuse == 0)
4364
	nuse = 1;
4365
	nuse = 1;
4365
4366
4367
      /* Handle derived types.  */
4368
      if (name[strlen (name) - 1] == '@')
4369
	{
4370
	  dt_name = xstrdup (name);
4371
	  dt_name[strlen (dt_name) - 1] = '\0';
4372
	}
4373
      else
4374
	dt_name = NULL;
4375
4366
      for (j = 1; j <= nuse; j++)
4376
      for (j = 1; j <= nuse; j++)
4367
	{
4377
	{
4368
	  /* Get the jth local name for this symbol.  */
4378
	  /* Get the jth local name for this symbol.  */
4369
	  p = find_use_name_n (name, &j, false);
4379
	  p = find_use_name_n (dt_name ? dt_name : name, &j, false);
4370
4380
4371
	  if (p == NULL && strcmp (name, module_name) == 0)
4381
	  if (p == NULL && strcmp (name, module_name) == 0)
4372
	    p = name;
4382
	    p = name;
Lines 4396-4402 read_module (void) Link Here
4396
				module_name, 0))
4406
				module_name, 0))
4397
	    continue;
4407
	    continue;
4398
4408
4399
	  st = gfc_find_symtree (gfc_current_ns->sym_root, p);
4409
	  st = gfc_find_symtree (gfc_current_ns->sym_root,
4410
				 dt_name ? gfc_get_string ("%s@", p) : p);
4400
4411
4401
	  if (st != NULL)
4412
	  if (st != NULL)
4402
	    {
4413
	    {
Lines 4421-4429 read_module (void) Link Here
4421
4432
4422
	      /* Create a symtree node in the current namespace for this
4433
	      /* Create a symtree node in the current namespace for this
4423
		 symbol.  */
4434
		 symbol.  */
4424
	      st = check_unique_name (p)
4435
	      st = check_unique_name (dt_name ? gfc_get_string ("%s@", p) : p)
4425
		   ? gfc_get_unique_symtree (gfc_current_ns)
4436
		   ? gfc_get_unique_symtree (gfc_current_ns)
4426
		   : gfc_new_symtree (&gfc_current_ns->sym_root, p);
4437
		   : gfc_new_symtree (&gfc_current_ns->sym_root,
4438
				      dt_name ? gfc_get_string ("%s@", p) : p);
4427
	      st->ambiguous = ambiguous;
4439
	      st->ambiguous = ambiguous;
4428
4440
4429
	      sym = info->u.rsym.sym;
4441
	      sym = info->u.rsym.sym;
Lines 4461-4466 read_module (void) Link Here
4461
	      info->u.rsym.referenced = 1;
4473
	      info->u.rsym.referenced = 1;
4462
	    }
4474
	    }
4463
	}
4475
	}
4476
      if (dt_name)
4477
	gfc_free (dt_name);
4464
    }
4478
    }
4465
4479
4466
  mio_rparen ();
4480
  mio_rparen ();
Lines 5280-5286 import_iso_c_binding_module (void) Link Here
5280
    {
5294
    {
5281
      bool found = false;
5295
      bool found = false;
5282
      for (u = gfc_rename_list; u; u = u->next)
5296
      for (u = gfc_rename_list; u; u = u->next)
5283
	if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0)
5297
      {
5298
        bool str_found;
5299
	char use_name[GFC_MAX_SYMBOL_LEN + 2];
5300
	str_found = strcmp (c_interop_kinds_table[i].name, u->use_name) == 0;
5301
        if (!str_found)
5302
	  {
5303
	    size_t len = strlen (u->use_name);
5304
	    strcpy (use_name, u->use_name);
5305
	    use_name[len] = '@';
5306
	    use_name[len+1] = '\0';
5307
	    str_found = strcmp (c_interop_kinds_table[i].name, use_name) == 0;
5308
	  }
5309
	if (str_found)
5284
	  {
5310
	  {
5285
	    u->found = 1;
5311
	    u->found = 1;
5286
	    found = true;
5312
	    found = true;
Lines 5304-5309 import_iso_c_binding_module (void) Link Here
5304
								: u->use_name);
5330
								: u->use_name);
5305
	      }
5331
	      }
5306
	  }
5332
	  }
5333
      }
5307
5334
5308
      if (!found && !only_flag)
5335
      if (!found && !only_flag)
5309
	switch (i)
5336
	switch (i)
(-)a/gcc/fortran/primary.c (-2 / +171 lines)
Lines 2249-2254 build_actual_constructor (gfc_structure_ctor_component **comp_head, Link Here
2249
  return SUCCESS;
2249
  return SUCCESS;
2250
}
2250
}
2251
2251
2252
2253
gfc_try
2254
gfc_convert_to_structure_constructor (gfc_expr *expr, gfc_symbol *sym)
2255
{
2256
  gfc_actual_arglist *actual;
2257
  gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
2258
  gfc_constructor_base ctor_head = NULL;
2259
  gfc_component *comp; /* Is set NULL when named component is first seen */
2260
  const char* last_name = NULL;
2261
  locus old_locus;
2262
2263
  old_locus = gfc_current_locus;
2264
  gfc_current_locus = expr->where;
2265
2266
  comp_tail = comp_head = NULL;
2267
2268
  if (sym->attr.abstract)
2269
    {
2270
      char *name = xstrdup (sym->name);
2271
2272
      name[strlen (name) - 1] = '\0';
2273
      gfc_error ("Can't construct ABSTRACT type '%s' at %L",
2274
		 name, &expr->where);
2275
      gfc_free (name);
2276
      goto cleanup;
2277
    }
2278
2279
  comp = sym->components;
2280
  for (actual = expr->value.function.actual; actual; actual = actual->next)
2281
    {
2282
      gfc_component *this_comp = NULL;
2283
2284
      if (!comp_head)
2285
	comp_tail = comp_head = gfc_get_structure_ctor_component ();
2286
      else
2287
	{
2288
	  comp_tail->next = gfc_get_structure_ctor_component ();
2289
	  comp_tail = comp_tail->next;
2290
       	}
2291
      if (actual->name)
2292
	{
2293
	  comp_tail->name = xstrdup (actual->name); /*CONST_CAST (char *, actual->name);*/
2294
	  last_name = comp_tail->name;
2295
	  comp = NULL;
2296
	}
2297
      else
2298
	{
2299
	  /* Components without name are not allowed after the first named
2300
	     component initializer!  */
2301
	  if (!comp)
2302
	    {
2303
	      if (last_name)
2304
		gfc_error ("Component initializer without name after component"
2305
			   " named %s at %L!", last_name,
2306
			   actual->expr ? &actual->expr->where
2307
					: &gfc_current_locus);
2308
	      else
2309
		gfc_error ("Too many components in structure constructor at "
2310
			   "%L!", actual->expr ? &actual->expr->where
2311
					       : &gfc_current_locus);
2312
	      goto cleanup;
2313
	    }
2314
2315
	  comp_tail->name = xstrdup (comp->name); /*CONST_CAST (char *, comp->name);*/
2316
	}
2317
2318
      /* Find the current component in the structure definition and check
2319
	     its access is not private.  */
2320
      if (comp)
2321
	this_comp = gfc_find_component (sym, comp->name, false, false);
2322
      else
2323
	{
2324
	  this_comp = gfc_find_component (sym, (const char *)comp_tail->name,
2325
					  false, false);
2326
	  comp = NULL; /* Reset needed!  */
2327
	}
2328
2329
      /* Here we can check if a component name is given which does not
2330
	 correspond to any component of the defined structure.  */
2331
      if (!this_comp)
2332
	goto cleanup;
2333
2334
      comp_tail->val = actual->expr;
2335
      if (actual->expr != NULL)
2336
	comp_tail->where = actual->expr->where;
2337
      actual->expr = NULL;
2338
2339
      /* Check if this component is already given a value.  */
2340
      for (comp_iter = comp_head; comp_iter != comp_tail; 
2341
	   comp_iter = comp_iter->next)
2342
	{
2343
	  gcc_assert (comp_iter);
2344
	  if (!strcmp (comp_iter->name, comp_tail->name))
2345
	    {
2346
	      gfc_error ("Component '%s' is initialized twice in the structure"
2347
			 " constructor at %L!", comp_tail->name,
2348
			 comp_tail->val ? &comp_tail->where
2349
					: &gfc_current_locus);
2350
	      goto cleanup;
2351
	    }
2352
	}
2353
2354
      /* F2008, R457/C725, for PURE C1283.  */
2355
      if (this_comp->attr.pointer && comp_tail->val
2356
	  && gfc_is_coindexed (comp_tail->val))
2357
     	{
2358
       	  gfc_error ("Coindexed expression to pointer component '%s' in "
2359
		     "structure constructor at %L!", comp_tail->name,
2360
		     &comp_tail->where);
2361
	  goto cleanup;
2362
	}
2363
2364
      if (comp)
2365
	comp = comp->next;
2366
    }
2367
2368
  if (build_actual_constructor (&comp_head, &ctor_head, sym) == FAILURE)
2369
    goto cleanup;
2370
2371
  /* No component should be left, as this should have caused an error in the
2372
     loop constructing the component-list (name that does not correspond to any
2373
     component in the structure definition).  */
2374
  if (comp_head && sym->attr.extension)
2375
    {
2376
      for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
2377
	{
2378
	  gfc_error ("component '%s' at %L has already been set by a "
2379
		     "parent derived type constructor", comp_iter->name,
2380
		     &comp_iter->where);
2381
	}
2382
      goto cleanup;
2383
    }
2384
  else
2385
    gcc_assert (!comp_head);
2386
2387
  expr->ts.u.derived = sym;
2388
  expr->ts.kind = 0;
2389
  expr->ts.type = BT_DERIVED;
2390
  expr->value.constructor = ctor_head;
2391
  expr->expr_type = EXPR_STRUCTURE;
2392
2393
  gfc_current_locus = old_locus; 
2394
  return SUCCESS;
2395
2396
  cleanup:
2397
  gfc_current_locus = old_locus; 
2398
2399
  for (comp_iter = comp_head; comp_iter; )
2400
    {
2401
      gfc_structure_ctor_component *next = comp_iter->next;
2402
      gfc_free_structure_ctor_component (comp_iter);
2403
      comp_iter = next;
2404
    }
2405
/*  gfc_constructor_free (ctor_head);*/
2406
2407
  return FAILURE;
2408
}
2409
2410
2411
2252
match
2412
match
2253
gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
2413
gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
2254
				 bool parent)
2414
				 bool parent)
Lines 2273-2279 gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result, Link Here
2273
  /* Check that we're not about to construct an ABSTRACT type.  */
2433
  /* Check that we're not about to construct an ABSTRACT type.  */
2274
  if (!parent && sym->attr.abstract)
2434
  if (!parent && sym->attr.abstract)
2275
    {
2435
    {
2276
      gfc_error ("Can't construct ABSTRACT type '%s' at %C", sym->name);
2436
      char *name = xstrdup (sym->name);
2437
      name[strlen (name) - 1] = '\0';
2438
      gfc_error ("Can't construct ABSTRACT type '%s' at %C", name);
2439
      gfc_free (name);
2277
      return MATCH_ERROR;
2440
      return MATCH_ERROR;
2278
    }
2441
    }
2279
2442
Lines 2641-2647 gfc_match_rvalue (gfc_expr **result) Link Here
2641
      if (sym == NULL)
2804
      if (sym == NULL)
2642
	m = MATCH_ERROR;
2805
	m = MATCH_ERROR;
2643
      else
2806
      else
2644
	m = gfc_match_structure_constructor (sym, &e, false);
2807
	goto generic_function;
2645
      break;
2808
      break;
2646
2809
2647
    /* If we're here, then the name is known to be the name of a
2810
    /* If we're here, then the name is known to be the name of a
Lines 2915-2920 gfc_match_rvalue (gfc_expr **result) Link Here
2915
      e->symtree = symtree;
3078
      e->symtree = symtree;
2916
      e->expr_type = EXPR_FUNCTION;
3079
      e->expr_type = EXPR_FUNCTION;
2917
3080
3081
      if (sym->attr.flavor == FL_DERIVED)
3082
	{
3083
	  e->value.function.esym = sym;
3084
	  e->symtree->n.sym->attr.generic = 1;
3085
	}
3086
2918
      m = gfc_match_actual_arglist (0, &e->value.function.actual);
3087
      m = gfc_match_actual_arglist (0, &e->value.function.actual);
2919
      break;
3088
      break;
2920
3089
(-)a/gcc/fortran/resolve.c (-14 / +71 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 2257-2262 resolve_generic_f (gfc_expr *expr) Link Here
2257
{
2262
{
2258
  gfc_symbol *sym;
2263
  gfc_symbol *sym;
2259
  match m;
2264
  match m;
2265
  gfc_interface *intr = NULL;
2260
2266
2261
  sym = expr->symtree->n.sym;
2267
  sym = expr->symtree->n.sym;
2262
2268
Lines 2269-2274 resolve_generic_f (gfc_expr *expr) Link Here
2269
	return FAILURE;
2275
	return FAILURE;
2270
2276
2271
generic:
2277
generic:
2278
      if (!intr)
2279
	for (intr = sym->generic; intr; intr = intr->next)
2280
	  if (intr->sym->attr.flavor == FL_DERIVED)
2281
	    break;
2282
2272
      if (sym->ns->parent == NULL)
2283
      if (sym->ns->parent == NULL)
2273
	break;
2284
	break;
2274
      gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2285
      gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
Lines 2281-2296 generic: Link Here
2281
2292
2282
  /* Last ditch attempt.  See if the reference is to an intrinsic
2293
  /* Last ditch attempt.  See if the reference is to an intrinsic
2283
     that possesses a matching interface.  14.1.2.4  */
2294
     that possesses a matching interface.  14.1.2.4  */
2284
  if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
2295
  if (sym  && !intr && !gfc_is_intrinsic (sym, 0, expr->where))
2285
    {
2296
    {
2286
      gfc_error ("There is no specific function for the generic '%s' at %L",
2297
      gfc_error ("There is no specific function for the generic '%s' "
2287
		 expr->symtree->n.sym->name, &expr->where);
2298
		 "at %L", expr->symtree->n.sym->name, &expr->where);
2288
      return FAILURE;
2299
      return FAILURE;
2289
    }
2300
    }
2290
2301
2302
  if (intr)
2303
    {
2304
      if (gfc_convert_to_structure_constructor (expr, intr->sym) != SUCCESS)
2305
	return FAILURE;
2306
      return resolve_structure_cons (expr, 0);
2307
    }
2308
2291
  m = gfc_intrinsic_func_interface (expr, 0);
2309
  m = gfc_intrinsic_func_interface (expr, 0);
2292
  if (m == MATCH_YES)
2310
  if (m == MATCH_YES)
2293
    return SUCCESS;
2311
    return SUCCESS;
2312
2294
  if (m == MATCH_NO)
2313
  if (m == MATCH_NO)
2295
    gfc_error ("Generic function '%s' at %L is not consistent with a "
2314
    gfc_error ("Generic function '%s' at %L is not consistent with a "
2296
	       "specific intrinsic interface", expr->symtree->n.sym->name,
2315
	       "specific intrinsic interface", expr->symtree->n.sym->name,
Lines 11186-11197 resolve_fl_derived (gfc_symbol *sym) Link Here
11186
	}
11205
	}
11187
    }
11206
    }
11188
11207
11208
11189
  /* F2008, C432. */
11209
  /* F2008, C432. */
11190
  if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
11210
  if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
11191
    {
11211
    {
11212
      char *super_name = xstrdup (super_type->name);
11213
      char *name = xstrdup (sym->name);
11214
11215
      super_name[strlen (super_name)-1] = '\0';
11216
      name[strlen (super_name)-1] = '\0';
11217
11192
      gfc_error ("As extending type '%s' at %L has a coarray component, "
11218
      gfc_error ("As extending type '%s' at %L has a coarray component, "
11193
		 "parent type '%s' shall also have one", sym->name,
11219
		 "parent type '%s' shall also have one", name,
11194
		 &sym->declared_at, super_type->name);
11220
		 &sym->declared_at, super_name);
11221
      gfc_free (super_name);
11222
      gfc_free (name);
11195
      return FAILURE;
11223
      return FAILURE;
11196
    }
11224
    }
11197
11225
Lines 11202-11209 resolve_fl_derived (gfc_symbol *sym) Link Here
11202
  /* An ABSTRACT type must be extensible.  */
11230
  /* An ABSTRACT type must be extensible.  */
11203
  if (sym->attr.abstract && !gfc_type_is_extensible (sym))
11231
  if (sym->attr.abstract && !gfc_type_is_extensible (sym))
11204
    {
11232
    {
11233
      char *name = xstrdup (sym->name);
11234
11235
      name[strlen (name)-1] = '\0';
11205
      gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11236
      gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11206
		 sym->name, &sym->declared_at);
11237
		 name, &sym->declared_at);
11238
      gfc_free (name);
11207
      return FAILURE;
11239
      return FAILURE;
11208
    }
11240
    }
11209
11241
Lines 11384-11393 resolve_fl_derived (gfc_symbol *sym) Link Here
11384
	      || (me_arg->ts.type == BT_CLASS
11416
	      || (me_arg->ts.type == BT_CLASS
11385
		  && CLASS_DATA (me_arg)->ts.u.derived != sym))
11417
		  && CLASS_DATA (me_arg)->ts.u.derived != sym))
11386
	    {
11418
	    {
11419
	      char *name = xstrdup (sym->name);
11420
11421
	      name[strlen (name)-1] = '\0';
11387
	      gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11422
	      gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11388
			 " the derived type '%s'", me_arg->name, c->name,
11423
			 " the derived type '%s'", me_arg->name, c->name,
11389
			 me_arg->name, &c->loc, sym->name);
11424
			 me_arg->name, &c->loc, name);
11390
	      c->tb->error = 1;
11425
	      c->tb->error = 1;
11426
	      gfc_free (name);
11391
	      return FAILURE;
11427
	      return FAILURE;
11392
	    }
11428
	    }
11393
11429
Lines 11441-11449 resolve_fl_derived (gfc_symbol *sym) Link Here
11441
      if (super_type && !sym->attr.is_class
11477
      if (super_type && !sym->attr.is_class
11442
	  && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
11478
	  && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
11443
	{
11479
	{
11480
	  char *name = xstrdup (sym->name);
11481
11482
	  name[strlen (name)-1] = '\0';
11444
	  gfc_error ("Component '%s' of '%s' at %L has the same name as an"
11483
	  gfc_error ("Component '%s' of '%s' at %L has the same name as an"
11445
		     " inherited type-bound procedure",
11484
		     " inherited type-bound procedure",
11446
		     c->name, sym->name, &c->loc);
11485
		     c->name, name, &c->loc);
11486
	  gfc_free (name);
11447
	  return FAILURE;
11487
	  return FAILURE;
11448
	}
11488
	}
11449
11489
Lines 11467-11478 resolve_fl_derived (gfc_symbol *sym) Link Here
11467
	  && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
11507
	  && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
11468
	  && !c->ts.u.derived->attr.use_assoc
11508
	  && !c->ts.u.derived->attr.use_assoc
11469
	  && !gfc_check_access (c->ts.u.derived->attr.access,
11509
	  && !gfc_check_access (c->ts.u.derived->attr.access,
11470
				c->ts.u.derived->ns->default_access)
11510
				c->ts.u.derived->ns->default_access))
11471
	  && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
11511
	{
11512
	  char *name = xstrdup (sym->name);
11513
11514
	  name[strlen (name)-1] = '\0';
11515
	  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
11472
			     "is a PRIVATE type and cannot be a component of "
11516
			     "is a PRIVATE type and cannot be a component of "
11473
			     "'%s', which is PUBLIC at %L", c->name,
11517
			     "'%s', which is PUBLIC at %L", c->name,
11474
			     sym->name, &sym->declared_at) == FAILURE)
11518
			     sym->name, &sym->declared_at) == FAILURE)
11475
	return FAILURE;
11519
	    {
11520
	      gfc_free (name);
11521
	      return FAILURE;
11522
	    }
11523
	  gfc_free (name);
11524
	}
11476
11525
11477
      if (sym->attr.sequence)
11526
      if (sym->attr.sequence)
11478
	{
11527
	{
Lines 11489-11497 resolve_fl_derived (gfc_symbol *sym) Link Here
11489
	  && c->attr.pointer && c->ts.u.derived->components == NULL
11538
	  && c->attr.pointer && c->ts.u.derived->components == NULL
11490
	  && !c->ts.u.derived->attr.zero_comp)
11539
	  && !c->ts.u.derived->attr.zero_comp)
11491
	{
11540
	{
11541
	  char *name = xstrdup (sym->name);
11542
11543
	  name[strlen (name)-1] = '\0';
11492
	  gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11544
	  gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11493
		     "that has not been declared", c->name, sym->name,
11545
		     "that has not been declared", c->name, sym->name,
11494
		     &c->loc);
11546
		     &c->loc);
11547
	  gfc_free (name);
11495
	  return FAILURE;
11548
	  return FAILURE;
11496
	}
11549
	}
11497
11550
Lines 11499-11507 resolve_fl_derived (gfc_symbol *sym) Link Here
11499
	  && CLASS_DATA (c)->ts.u.derived->components == NULL
11552
	  && CLASS_DATA (c)->ts.u.derived->components == NULL
11500
	  && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp)
11553
	  && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp)
11501
	{
11554
	{
11555
	  char *name = xstrdup (sym->name);
11556
11557
	  name[strlen (name)-1] = '\0';
11502
	  gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11558
	  gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11503
		     "that has not been declared", c->name, sym->name,
11559
		     "that has not been declared", c->name, sym->name,
11504
		     &c->loc);
11560
		     &c->loc);
11561
	  gfc_free (name);
11505
	  return FAILURE;
11562
	  return FAILURE;
11506
	}
11563
	}
11507
11564
(-)a/gcc/fortran/symbol.c (-2 / +42 lines)
Lines 1971-1978 gfc_use_derived (gfc_symbol *sym) Link Here
1971
  return s;
1971
  return s;
1972
1972
1973
bad:
1973
bad:
1974
  gfc_error ("Derived type '%s' at %C is being used before it is defined",
1974
  {
1975
	     sym->name);
1975
    char *name = xstrdup (sym->name);
1976
    name[strlen (name) - 1] = '\0';
1977
    gfc_error ("Derived type '%s' at %C is being used before it is defined",
1978
	       name);
1979
    gfc_free (name);
1980
  }
1976
  return NULL;
1981
  return NULL;
1977
}
1982
}
1978
1983
Lines 4474-4479 generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s, Link Here
4474
4479
4475
        /* Make it use associated (iso_c_binding module).  */
4480
        /* Make it use associated (iso_c_binding module).  */
4476
        tmp_sym->attr.use_assoc = 1;
4481
        tmp_sym->attr.use_assoc = 1;
4482
4483
	/* Generate an artificial generic function.  */
4484
	{
4485
	  gfc_interface *intr, *head;
4486
	  char *gen_name = xstrdup (name);
4487
4488
	  gen_name[strlen (gen_name) - 1] = '\0';
4489
	  tmp_symtree = NULL;
4490
	  gfc_get_sym_tree (gen_name, gfc_current_ns, &tmp_symtree, false);
4491
	  gfc_free (gen_name);
4492
4493
	  if (!tmp_symtree)
4494
	    gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4495
				"create symbol");
4496
	  head = tmp_symtree->n.sym->generic;
4497
	  intr = gfc_get_interface ();
4498
	  intr->sym = tmp_sym;
4499
	  intr->where = gfc_current_locus;
4500
	  intr->next = head;
4501
	  tmp_sym = tmp_symtree->n.sym;
4502
	  tmp_sym->generic = intr;
4503
	}
4504
4505
	/* Say what module this symbol belongs to.  */
4506
	tmp_sym->module = gfc_get_string (mod_name);
4507
	tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
4508
4509
	if (!tmp_sym->attr.generic
4510
	    && gfc_add_generic (&tmp_sym->attr, name, NULL) == FAILURE)
4511
	  return;
4512
4513
	if (!tmp_sym->attr.function
4514
	    && gfc_add_function (&tmp_sym->attr, name, NULL) == FAILURE)
4515
	  return;
4516
4477
	break;
4517
	break;
4478
4518
4479
      case ISOCBINDING_NULL_PTR:
4519
      case ISOCBINDING_NULL_PTR:
(-)a/gcc/fortran/trans-types.c (-2 / +7 lines)
Lines 325-331 void init_c_interop_kinds (void) Link Here
325
  c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
325
  c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
326
  c_interop_kinds_table[a].value = c;
326
  c_interop_kinds_table[a].value = c;
327
#define DERIVED_TYPE(a,b,c) \
327
#define DERIVED_TYPE(a,b,c) \
328
  strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
328
  strncpy (c_interop_kinds_table[a].name, b "@", strlen(b) + 2); \
329
  c_interop_kinds_table[a].f90_type = BT_DERIVED; \
329
  c_interop_kinds_table[a].f90_type = BT_DERIVED; \
330
  c_interop_kinds_table[a].value = c;
330
  c_interop_kinds_table[a].value = c;
331
#define PROCEDURE(a,b) \
331
#define PROCEDURE(a,b) \
Lines 2078-2087 gfc_get_derived_type (gfc_symbol * derived) Link Here
2078
    }
2078
    }
2079
  else
2079
  else
2080
    {
2080
    {
2081
      char *dt_name;
2081
      /* We see this derived type first time, so build the type node.  */
2082
      /* We see this derived type first time, so build the type node.  */
2082
      typenode = make_node (RECORD_TYPE);
2083
      typenode = make_node (RECORD_TYPE);
2083
      TYPE_NAME (typenode) = get_identifier (derived->name);
2084
2085
      dt_name = xstrdup (derived->name);
2086
      dt_name[strlen (dt_name) - 1] = '\0';
2087
      TYPE_NAME (typenode) = get_identifier (dt_name);
2084
      TYPE_PACKED (typenode) = gfc_option.flag_pack_derived;
2088
      TYPE_PACKED (typenode) = gfc_option.flag_pack_derived;
2089
      gfc_free (dt_name);
2085
      derived->backend_decl = typenode;
2090
      derived->backend_decl = typenode;
2086
    }
2091
    }
2087
2092
2088
 interface foo
2093
 interface foo
2089
   procedure constructor
2094
   procedure constructor
2090
 end interface
2095
 end interface
2091
 type foo
2096
 type foo
2092
   integer :: bar
2097
   integer :: bar
2093
 end type
2098
 end type
2094
 type(foo) function constructor()
2099
 type(foo) function constructor()
2095
   constructor%bar = 1
2100
   constructor%bar = 1
2096
 end function
2101
 end function
2097
 subroutine test_foo()
2102
 subroutine test_foo()
2098
   type(foo) :: f
2103
   type(foo) :: f
2099
   f = foo()
2104
   f = foo()
2100
   print *, f%bar, '(expected: 1)'
2105
   print *, f%bar, '(expected: 1)'
2101
   !f = foo(2) ! Sorry
2106
   !f = foo(2) ! Sorry
2102
   !print *, f%bar, '(expected: 2)'
2107
   !print *, f%bar, '(expected: 2)'
2103
 end subroutine test_foo
2108
 end subroutine test_foo
2104
 type bar
2109
 type bar
2105
   integer :: bar
2110
   integer :: bar
2106
 end type
2111
 end type
2107
 interface bar
2112
 interface bar
2108
   procedure constructor
2113
   procedure constructor
2109
 end interface
2114
 end interface
2110
 type(bar) function constructor()
2115
 type(bar) function constructor()
2111
   constructor%bar = 3
2116
   constructor%bar = 3
2112
 end function
2117
 end function
2113
 subroutine test_bar()
2118
 subroutine test_bar()
2114
   type(bar) :: f
2119
   type(bar) :: f
2115
   f = bar()
2120
   f = bar()
2116
   print *, f%bar, '(expected: 3)'
2121
   print *, f%bar, '(expected: 3)'
2117
   !f = bar(4) ! Sorry
2122
   !f = bar(4) ! Sorry
2118
   !print *, f%bar, '(expected: 4)'
2123
   !print *, f%bar, '(expected: 4)'
2119
 end subroutine test_bar
2124
 end subroutine test_bar
2120
 use foo_module
2125
 use foo_module
2121
 use bar_module
2126
 use bar_module
2122
 implicit none
2127
 implicit none
2123
 type(foo) :: f
2128
 type(foo) :: f
2124
 type(bar) :: b
2129
 type(bar) :: b
2125
 call test_foo()
2130
 call test_foo()
2126
 f = foo()
2131
 f = foo()
2127
 print *, f%bar, '(expected: 1)'
2132
 print *, f%bar, '(expected: 1)'
2128
 !f = foo(2) ! Sorry
2133
 !f = foo(2) ! Sorry
2129
 !print *, f%bar, '(expected: 2)'
2134
 !print *, f%bar, '(expected: 2)'
2130
 call test_bar()
2135
 call test_bar()
2131
 b = bar()
2136
 b = bar()
2132
 print *, b%bar, '(expected: 3)'
2137
 print *, b%bar, '(expected: 3)'
2133
 !b = bar(4) ! Sorry
2138
 !b = bar(4) ! Sorry
2134
 !print *, b%bar, '(expected: 4)'
2139
 !print *, b%bar, '(expected: 4)'
2135
 FAILING TESTCASES:
2140
 FAILING TESTCASES:

Return to bug 39427