View | Details | Raw Unified | Return to bug 42385
Collapse All | Expand All | Context: (Patch / File /
)

(-)gcc/fortran/resolve.c (-32 / +64 lines)
 Lines 5468-5477    Link Here 
5468
  gfc_ref *class_ref;
5468
  gfc_ref *class_ref;
5469
  gfc_symtree *st;
5469
  gfc_symtree *st;
5470
  const char *name;
5470
  const char *name;
5471
  const char *genname;
5472
  gfc_typespec ts;
5471
  gfc_typespec ts;
5472
  gfc_expr *expr;
5473
5473
5474
  st = e->symtree;
5474
  st = e->symtree;
5475
5476
  /* Deal with typebound operators for CLASS objects.  */
5477
  expr = e->value.compcall.base_object;
5478
  if (expr != NULL && expr->symtree->n.sym->ts.type == BT_CLASS)
5479
    {
5480
      /* Since the typebound operators are generic, we have to ensure
5481
	 that any delays in reolution are corrected and that the vtab
5482
	 is present.  */
5483
      ts = expr->symtree->n.sym->ts;
5484
      declared = ts.u.derived;
5485
      c = gfc_find_component (declared, "$vptr", true, true);
5486
      if (c->ts.u.derived == NULL)
5487
	c->ts.u.derived = gfc_find_derived_vtab (declared);
5488
5489
      if (resolve_compcall (e, &name) == FAILURE)
5490
	return FAILURE;
5491
5492
      e->symtree = expr->symtree;
5493
      expr->symtree->n.sym->ts.u.derived = declared;
5494
      gfc_add_component_ref (e, "$vptr");
5495
5496
      /* Use the generic name if it is there.  */
5497
      if (name)
5498
	gfc_add_component_ref (e, name);
5499
      else
5500
	gfc_add_component_ref (e, e->value.function.esym->name);
5501
      e->value.function.esym = NULL;
5502
      return SUCCESS;
5503
    }
5504
5475
  if (st == NULL)
5505
  if (st == NULL)
5476
    return resolve_compcall (e, NULL);
5506
    return resolve_compcall (e, NULL);
5477
5507
 Lines 5492-5502    Link Here 
5492
  c = gfc_find_component (declared, "$data", true, true);
5522
  c = gfc_find_component (declared, "$data", true, true);
5493
  declared = c->ts.u.derived;
5523
  declared = c->ts.u.derived;
5494
5524
5495
  /* Keep the generic name so that the vtab reference can be made.  */
5496
  genname = NULL; 
5497
  if (e->value.compcall.tbp->is_generic)
5498
    genname = e->value.compcall.name;
5499
5500
  /* Treat the call as if it is a typebound procedure, in order to roll
5525
  /* Treat the call as if it is a typebound procedure, in order to roll
5501
     out the correct name for the specific function.  */
5526
     out the correct name for the specific function.  */
5502
  if (resolve_compcall (e, &name) == FAILURE)
5527
  if (resolve_compcall (e, &name) == FAILURE)
 Lines 5512-5526    Link Here 
5512
5537
5513
  /* '$vptr' points to the vtab, which contains the procedure pointers.  */
5538
  /* '$vptr' points to the vtab, which contains the procedure pointers.  */
5514
  gfc_add_component_ref (e, "$vptr");
5539
  gfc_add_component_ref (e, "$vptr");
5515
  if (genname)
5516
    {
5517
      /* A generic procedure needs the subsidiary vtabs and vtypes for
5518
	 the specific procedures to have been build.  */
5519
      gfc_symbol *vtab;
5520
      vtab = gfc_find_derived_vtab (declared, true);
5521
      gcc_assert (vtab);
5522
      gfc_add_component_ref (e, genname);
5523
    }
5524
  gfc_add_component_ref (e, name);
5540
  gfc_add_component_ref (e, name);
5525
5541
5526
  /* Recover the typespec for the expression.  This is really only
5542
  /* Recover the typespec for the expression.  This is really only
 Lines 5543-5553    Link Here 
5543
  gfc_ref *new_ref;
5559
  gfc_ref *new_ref;
5544
  gfc_ref *class_ref;
5560
  gfc_ref *class_ref;
5545
  gfc_symtree *st;
5561
  gfc_symtree *st;
5546
  const char *genname;
5547
  const char *name;
5562
  const char *name;
5548
  gfc_typespec ts;
5563
  gfc_typespec ts;
5564
  gfc_expr *expr;
5549
5565
5550
  st = code->expr1->symtree;
5566
  st = code->expr1->symtree;
5567
5568
  /* Deal with typebound operators for CLASS objects.  */
5569
  expr = code->expr1->value.compcall.base_object;
5570
  if (expr != NULL && expr->symtree->n.sym->ts.type == BT_CLASS)
5571
    {
5572
      /* Since the typebound operators are generic, we have to ensure
5573
	 that any delays in reolution are corrected and that the vtab
5574
	 is present.  */
5575
      ts = expr->symtree->n.sym->ts;
5576
      declared = ts.u.derived;
5577
      c = gfc_find_component (declared, "$vptr", true, true);
5578
      if (c->ts.u.derived == NULL)
5579
	c->ts.u.derived = gfc_find_derived_vtab (declared);
5580
5581
      if (resolve_typebound_call (code, &name) == FAILURE)
5582
	return FAILURE;
5583
5584
      code->expr1->symtree = expr->symtree;
5585
      expr->symtree->n.sym->ts.u.derived = declared;
5586
      gfc_add_component_ref (code->expr1, "$vptr");
5587
5588
      /* Use the generic name if it is there.  */
5589
      if (name)
5590
	gfc_add_component_ref (code->expr1, name);
5591
      else
5592
	gfc_add_component_ref (code->expr1, code->expr1->value.function.esym->name);
5593
      code->expr1->value.function.esym = NULL;
5594
      return SUCCESS;
5595
    }
5596
5551
  if (st == NULL)
5597
  if (st == NULL)
5552
    return resolve_typebound_call (code, NULL);
5598
    return resolve_typebound_call (code, NULL);
5553
5599
 Lines 5568-5578    Link Here 
5568
  c = gfc_find_component (declared, "$data", true, true);
5614
  c = gfc_find_component (declared, "$data", true, true);
5569
  declared = c->ts.u.derived;
5615
  declared = c->ts.u.derived;
5570
5616
5571
  /* Keep the generic name so that the vtab reference can be made.  */
5572
  genname = NULL; 
5573
  if (code->expr1->value.compcall.tbp->is_generic)
5574
    genname = code->expr1->value.compcall.name;
5575
5576
  if (resolve_typebound_call (code, &name) == FAILURE)
5617
  if (resolve_typebound_call (code, &name) == FAILURE)
5577
    return FAILURE;
5618
    return FAILURE;
5578
  ts = code->expr1->ts;
5619
  ts = code->expr1->ts;
 Lines 5586-5600    Link Here 
5586
5627
5587
  /* '$vptr' points to the vtab, which contains the procedure pointers.  */
5628
  /* '$vptr' points to the vtab, which contains the procedure pointers.  */
5588
  gfc_add_component_ref (code->expr1, "$vptr");
5629
  gfc_add_component_ref (code->expr1, "$vptr");
5589
  if (genname)
5590
    {
5591
      /* A generic procedure needs the subsidiary vtabs and vtypes for
5592
	 the specific procedures to have been build.  */
5593
      gfc_symbol *vtab;
5594
      vtab = gfc_find_derived_vtab (declared, true);
5595
      gcc_assert (vtab);
5596
      gfc_add_component_ref (code->expr1, genname);
5597
    }
5598
  gfc_add_component_ref (code->expr1, name);
5630
  gfc_add_component_ref (code->expr1, name);
5599
5631
5600
  /* Recover the typespec for the expression.  This is really only
5632
  /* Recover the typespec for the expression.  This is really only
 Lines 7496-7502    Link Here 
7496
	  new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
7528
	  new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
7497
	  new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
7529
	  new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
7498
	  gfc_add_component_ref (new_st->expr1->value.function.actual->expr, "$vptr");
7530
	  gfc_add_component_ref (new_st->expr1->value.function.actual->expr, "$vptr");
7499
	  vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived, true);
7531
	  vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived);
7500
	  st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
7532
	  st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
7501
	  new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
7533
	  new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
7502
	  new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
7534
	  new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
 Lines 10769-10775    Link Here 
10769
      gfc_component *vptr = gfc_find_component (sym, "$vptr", true, true);
10801
      gfc_component *vptr = gfc_find_component (sym, "$vptr", true, true);
10770
      if (vptr->ts.u.derived == NULL)
10802
      if (vptr->ts.u.derived == NULL)
10771
	{
10803
	{
10772
	  gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived, false);
10804
	  gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
10773
	  gcc_assert (vtab);
10805
	  gcc_assert (vtab);
10774
	  vptr->ts.u.derived = vtab->ts.u.derived;
10806
	  vptr->ts.u.derived = vtab->ts.u.derived;
10775
	}
10807
	}
(-)gcc/fortran/interface.c (-1 / +5 lines)
 Lines 2781-2786    Link Here 
2781
   procedure defined as operator-target as well as the base-object to use
2781
   procedure defined as operator-target as well as the base-object to use
2782
   (which is the found derived-type argument with operator).  */
2782
   (which is the found derived-type argument with operator).  */
2783
2783
2784
static const char *gname;
2785
2784
static gfc_typebound_proc*
2786
static gfc_typebound_proc*
2785
matching_typebound_op (gfc_expr** tb_base,
2787
matching_typebound_op (gfc_expr** tb_base,
2786
		       gfc_actual_arglist* args,
2788
		       gfc_actual_arglist* args,
 Lines 2850-2855    Link Here 
2850
		if (matches)
2852
		if (matches)
2851
		  {
2853
		  {
2852
		    *tb_base = base->expr;
2854
		    *tb_base = base->expr;
2855
		    gname = g->specific_st->name;
2853
		    return g->specific;
2856
		    return g->specific;
2854
		  }
2857
		  }
2855
	      }
2858
	      }
 Lines 2872-2878    Link Here 
2872
{
2875
{
2873
  e->expr_type = EXPR_COMPCALL;
2876
  e->expr_type = EXPR_COMPCALL;
2874
  e->value.compcall.tbp = target;
2877
  e->value.compcall.tbp = target;
2875
  e->value.compcall.name = "operator"; /* Should not matter.  */
2878
  e->value.compcall.name = gname ? gname : "operator";
2876
  e->value.compcall.actual = actual;
2879
  e->value.compcall.actual = actual;
2877
  e->value.compcall.base_object = base;
2880
  e->value.compcall.base_object = base;
2878
  e->value.compcall.ignore_pass = 1;
2881
  e->value.compcall.ignore_pass = 1;
 Lines 2905-2910    Link Here 
2905
  actual->expr = e->value.op.op1;
2908
  actual->expr = e->value.op.op1;
2906
2909
2907
  *real_error = false;
2910
  *real_error = false;
2911
  gname = NULL;
2908
2912
2909
  if (e->value.op.op2 != NULL)
2913
  if (e->value.op.op2 != NULL)
2910
    {
2914
    {

Return to bug 42385