User account creation filtered due to spam.

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

Collapse All | Expand All

(-)a/class.c (+66 lines)
Lines 52-57 along with GCC; see the file COPYING3. If not see Link Here
52
#include "constructor.h"
52
#include "constructor.h"
53
53
54
54
55
static void
56
insert_component_ref (gfc_typespec *ts, gfc_ref **ref, const char * const name)
57
{
58
  gfc_symbol *base_sym;
59
  gfc_ref *new_ref;
60
61
  gcc_assert (ts->type == BT_DERIVED || ts->type == BT_CLASS);
62
  base_sym = ts->u.derived;
63
64
  new_ref = gfc_get_ref ();
65
  new_ref->type = REF_COMPONENT;
66
  new_ref->next = *ref;
67
  new_ref->u.c.sym = base_sym;
68
  new_ref->u.c.component = gfc_find_component (base_sym, name, true, true);
69
  gcc_assert(new_ref->u.c.component);
70
71
  if (new_ref->next)
72
    {
73
      gfc_ref *next = NULL;
74
75
      if (new_ref->next->type == REF_COMPONENT)
76
	next = new_ref->next;
77
      else if (new_ref->next->type == REF_ARRAY
78
	       && new_ref->next->next
79
	       && new_ref->next->next->type == REF_COMPONENT)
80
	next = new_ref->next->next;
81
82
      if (next != NULL)
83
	{
84
	  gcc_assert (new_ref->u.c.component->ts.type == BT_CLASS
85
		      || new_ref->u.c.component->ts.type == BT_DERIVED);
86
	  next->u.c.sym = new_ref->u.c.component->ts.u.derived;
87
	}
88
    }
89
90
  *ref = new_ref;
91
}
92
93
94
void
95
gfc_fix_class_component_refs (gfc_expr *e)
96
{
97
  gfc_typespec *ts;
98
  gfc_ref **ref;
99
100
  if ((e->expr_type != EXPR_VARIABLE
101
       && e->expr_type != EXPR_FUNCTION)
102
      || (e->expr_type == EXPR_FUNCTION
103
	  && e->value.function.isym != NULL))
104
    return;
105
106
  ts = &e->symtree->n.sym->ts;
107
108
  for (ref = &(e->ref); *ref != NULL; ref = &(*ref)->next)
109
    {
110
      if (ts->type == BT_CLASS
111
	  && ((*ref)->type != REF_COMPONENT
112
	      || (*ref)->u.c.component->name[0] != '_'))
113
	insert_component_ref (ts, ref, "_data");
114
	  
115
      if ((*ref)->type == REF_COMPONENT)
116
	ts = &(*ref)->u.c.component->ts;
117
    }
118
}
119
120
55
/* Insert a reference to the component of the given name.
121
/* Insert a reference to the component of the given name.
56
   Only to be used with CLASS containers and vtables.  */
122
   Only to be used with CLASS containers and vtables.  */
57
123
(-)a/gfortran.h (+1 lines)
Lines 2919-2924 gfc_try gfc_calculate_transfer_sizes (gfc_expr*, gfc_expr*, gfc_expr*, Link Here
2919
				      size_t*, size_t*, size_t*);
2919
				      size_t*, size_t*, size_t*);
2920
2920
2921
/* class.c */
2921
/* class.c */
2922
void gfc_fix_class_component_refs (gfc_expr *e);
2922
void gfc_add_component_ref (gfc_expr *, const char *);
2923
void gfc_add_component_ref (gfc_expr *, const char *);
2923
void gfc_add_class_array_ref (gfc_expr *);
2924
void gfc_add_class_array_ref (gfc_expr *);
2924
#define gfc_add_data_component(e)     gfc_add_component_ref(e,"_data")
2925
#define gfc_add_data_component(e)     gfc_add_component_ref(e,"_data")
(-)a/resolve.c (-3 / +18 lines)
Lines 1574-1579 resolve_procedure_expression (gfc_expr* expr) Link Here
1574
}
1574
}
1575
1575
1576
1576
1577
gfc_array_spec *
1578
symbol_as (gfc_symbol *sym)
1579
{
1580
  gfc_array_spec *as;
1581
1582
  as = sym->as;
1583
  if (as == NULL && sym->ts.type == BT_CLASS)
1584
    return CLASS_DATA (sym)->as;
1585
1586
  return as;
1587
}
1588
1589
1577
/* Resolve an actual argument list.  Most of the time, this is just
1590
/* Resolve an actual argument list.  Most of the time, this is just
1578
   resolving the expressions in the list.
1591
   resolving the expressions in the list.
1579
   The exception is that we sometimes have to decide whether arguments
1592
   The exception is that we sometimes have to decide whether arguments
Lines 1739-1751 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, Link Here
1739
    got_variable:
1752
    got_variable:
1740
      e->expr_type = EXPR_VARIABLE;
1753
      e->expr_type = EXPR_VARIABLE;
1741
      e->ts = sym->ts;
1754
      e->ts = sym->ts;
1742
      if (sym->as != NULL)
1755
      if (symbol_as (sym) != NULL)
1743
	{
1756
	{
1744
	  e->rank = sym->as->rank;
1757
	  gfc_array_spec *as = symbol_as (sym);
1758
1759
	  e->rank = as->rank;
1745
	  e->ref = gfc_get_ref ();
1760
	  e->ref = gfc_get_ref ();
1746
	  e->ref->type = REF_ARRAY;
1761
	  e->ref->type = REF_ARRAY;
1747
	  e->ref->u.ar.type = AR_FULL;
1762
	  e->ref->u.ar.type = AR_FULL;
1748
	  e->ref->u.ar.as = sym->as;
1763
	  e->ref->u.ar.as = as;
1749
	}
1764
	}
1750
1765
1751
      /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1766
      /* Expressions are assigned a default ts.type of BT_PROCEDURE in
(-)a/trans-array.c (-28 / +44 lines)
Lines 2448-2454 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, Link Here
2448
	case GFC_SS_REFERENCE:
2448
	case GFC_SS_REFERENCE:
2449
	  /* Scalar argument to elemental procedure.  */
2449
	  /* Scalar argument to elemental procedure.  */
2450
	  gfc_init_se (&se, NULL);
2450
	  gfc_init_se (&se, NULL);
2451
	  if (ss_info->data.scalar.can_be_null_ref)
2451
	  if (ss_info->can_be_null_ref)
2452
	    {
2452
	    {
2453
	      /* If the actual argument can be absent (in other words, it can
2453
	      /* If the actual argument can be absent (in other words, it can
2454
		 be a NULL reference), don't try to evaluate it; pass instead
2454
		 be a NULL reference), don't try to evaluate it; pass instead
Lines 2568-2573 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base) Link Here
2568
  gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE);
2568
  gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE);
2569
  gfc_init_se (&se, NULL);
2569
  gfc_init_se (&se, NULL);
2570
  se.descriptor_only = 1;
2570
  se.descriptor_only = 1;
2571
  gfc_fix_class_component_refs (ss_info->expr);
2571
  gfc_conv_expr_lhs (&se, ss_info->expr);
2572
  gfc_conv_expr_lhs (&se, ss_info->expr);
2572
  gfc_add_block_to_block (block, &se.pre);
2573
  gfc_add_block_to_block (block, &se.pre);
2573
  info->descriptor = se.expr;
2574
  info->descriptor = se.expr;
Lines 8375-8381 gfc_reverse_ss (gfc_ss * ss) Link Here
8375
8376
8376
gfc_ss *
8377
gfc_ss *
8377
gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
8378
gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
8378
				  gfc_expr *proc_expr, gfc_ss_type type)
8379
				  gfc_symbol *proc_ifc, gfc_ss_type type)
8379
{
8380
{
8380
  gfc_formal_arglist *dummy_arg;
8381
  gfc_formal_arglist *dummy_arg;
8381
  int scalar;
8382
  int scalar;
Lines 8386-8409 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg, Link Here
8386
  head = gfc_ss_terminator;
8387
  head = gfc_ss_terminator;
8387
  tail = NULL;
8388
  tail = NULL;
8388
8389
8389
  if (proc_expr)
8390
  if (proc_ifc)
8390
    {
8391
    dummy_arg = proc_ifc->formal;
8391
      gfc_ref *ref;
8392
8393
      /* Normal procedure case.  */
8394
      dummy_arg = proc_expr->symtree->n.sym->formal;
8395
8396
      /* Typebound procedure case.  */
8397
      for (ref = proc_expr->ref; ref; ref = ref->next)
8398
	{
8399
	  if (ref->type == REF_COMPONENT
8400
	      && ref->u.c.component->attr.proc_pointer
8401
	      && ref->u.c.component->ts.interface)
8402
	    dummy_arg = ref->u.c.component->ts.interface->formal;
8403
	  else
8404
	    dummy_arg = NULL;
8405
	}
8406
    }
8407
  else
8392
  else
8408
    dummy_arg = NULL;
8393
    dummy_arg = NULL;
8409
8394
Lines 8421-8437 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg, Link Here
8421
	  newss = gfc_get_scalar_ss (head, arg->expr);
8406
	  newss = gfc_get_scalar_ss (head, arg->expr);
8422
	  newss->info->type = type;
8407
	  newss->info->type = type;
8423
8408
8424
	  if (dummy_arg != NULL
8425
	      && dummy_arg->sym->attr.optional
8426
	      && arg->expr->expr_type == EXPR_VARIABLE
8427
	      && (gfc_expr_attr (arg->expr).optional
8428
		  || gfc_expr_attr (arg->expr).allocatable
8429
		  || gfc_expr_attr (arg->expr).pointer))
8430
	    newss->info->data.scalar.can_be_null_ref = true;
8431
	}
8409
	}
8432
      else
8410
      else
8433
	scalar = 0;
8411
	scalar = 0;
8434
8412
8413
      if (dummy_arg != NULL
8414
	  && dummy_arg->sym->attr.optional
8415
	  && arg->expr->expr_type == EXPR_VARIABLE
8416
	  && (gfc_expr_attr (arg->expr).optional
8417
	      || gfc_expr_attr (arg->expr).allocatable
8418
	      || gfc_expr_attr (arg->expr).pointer))
8419
	newss->info->can_be_null_ref = true;
8420
8435
      head = newss;
8421
      head = newss;
8436
      if (!tail)
8422
      if (!tail)
8437
        {
8423
        {
Lines 8458-8463 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg, Link Here
8458
}
8444
}
8459
8445
8460
8446
8447
/* Given an expression refering to a procedure, return the symbol of its
8448
   interface.  We can't get the procedure symbol directly as we have to handle
8449
   the case of (deferred) type-bound procedures.  */
8450
8451
gfc_symbol *
8452
gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref)
8453
{
8454
  gfc_symbol *sym;
8455
  gfc_ref *ref;
8456
8457
  if (procedure_ref == NULL)
8458
    return NULL;
8459
8460
  sym = procedure_ref->symtree->n.sym;
8461
8462
  for (ref = procedure_ref->ref; ref; ref = ref->next)
8463
    {
8464
      if (ref->type == REF_COMPONENT
8465
	  && ref->u.c.component->attr.proc_pointer
8466
	  && ref->u.c.component->ts.interface)
8467
	sym = ref->u.c.component->ts.interface;
8468
      else
8469
	sym = NULL;
8470
    }
8471
8472
  return sym;
8473
}
8474
8475
8461
/* Walk a function call.  Scalar functions are passed back, and taken out of
8476
/* Walk a function call.  Scalar functions are passed back, and taken out of
8462
   scalarization loops.  For elemental functions we walk their arguments.
8477
   scalarization loops.  For elemental functions we walk their arguments.
8463
   The result of functions returning arrays is stored in a temporary outside
8478
   The result of functions returning arrays is stored in a temporary outside
Lines 8491-8497 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr) Link Here
8491
     by reference.  */
8506
     by reference.  */
8492
  if (sym->attr.elemental || (comp && comp->attr.elemental))
8507
  if (sym->attr.elemental || (comp && comp->attr.elemental))
8493
    return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
8508
    return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
8494
					     expr, GFC_SS_REFERENCE);
8509
					     gfc_get_proc_ifc_for_expr (expr),
8510
					     GFC_SS_REFERENCE);
8495
8511
8496
  /* Scalar functions are OK as these are evaluated outside the scalarization
8512
  /* Scalar functions are OK as these are evaluated outside the scalarization
8497
     loop.  Pass back and let the caller deal with it.  */
8513
     loop.  Pass back and let the caller deal with it.  */
(-)a/trans-array.h (-1 / +2 lines)
Lines 66-71 void gfc_trans_deferred_array (gfc_symbol *, gfc_wrapped_block *); Link Here
66
/* Generate an initializer for a static pointer or allocatable array.  */
66
/* Generate an initializer for a static pointer or allocatable array.  */
67
void gfc_trans_static_array_pointer (gfc_symbol *);
67
void gfc_trans_static_array_pointer (gfc_symbol *);
68
68
69
gfc_symbol *gfc_get_proc_ifc_for_expr (gfc_expr *);
69
/* Generate scalarization information for an expression.  */
70
/* Generate scalarization information for an expression.  */
70
gfc_ss *gfc_walk_expr (gfc_expr *);
71
gfc_ss *gfc_walk_expr (gfc_expr *);
71
/* Workhorse for gfc_walk_expr.  */
72
/* Workhorse for gfc_walk_expr.  */
Lines 74-80 gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *); Link Here
74
gfc_ss *gfc_walk_array_ref (gfc_ss *, gfc_expr *, gfc_ref * ref);
75
gfc_ss *gfc_walk_array_ref (gfc_ss *, gfc_expr *, gfc_ref * ref);
75
/* Walk the arguments of an elemental function.  */
76
/* Walk the arguments of an elemental function.  */
76
gfc_ss *gfc_walk_elemental_function_args (gfc_ss *, gfc_actual_arglist *,
77
gfc_ss *gfc_walk_elemental_function_args (gfc_ss *, gfc_actual_arglist *,
77
					  gfc_expr *, gfc_ss_type);
78
					  gfc_symbol *, gfc_ss_type);
78
/* Walk an intrinsic function.  */
79
/* Walk an intrinsic function.  */
79
gfc_ss *gfc_walk_intrinsic_function (gfc_ss *, gfc_expr *,
80
gfc_ss *gfc_walk_intrinsic_function (gfc_ss *, gfc_expr *,
80
				     gfc_intrinsic_sym *);
81
				     gfc_intrinsic_sym *);
(-)a/trans-expr.c (-4 / +92 lines)
Lines 178-189 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, Link Here
178
  /* Now set the data field.  */
178
  /* Now set the data field.  */
179
  ctree =  gfc_class_data_get (var);
179
  ctree =  gfc_class_data_get (var);
180
180
181
  if (parmse->ss && parmse->ss->info->useflags)
181
  ss = parmse->ss;
182
  if (ss && ss->info->useflags)
182
    {
183
    {
183
      /* For an array reference in an elemental procedure call we need
184
      /* For an array reference in an elemental procedure call we need
184
	 to retain the ss to provide the scalarized array reference.  */
185
	 to retain the ss to provide the scalarized array reference.  */
185
      gfc_conv_expr_reference (parmse, e);
186
      gfc_conv_expr_reference (parmse, e);
186
      tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
187
      tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
188
      if (ss->info->can_be_null_ref && ss->info->type != GFC_SS_REFERENCE)
189
	{
190
	  tree cond;
191
192
	  cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
193
				  ss->info->data.array.data,
194
				  build_int_cst (pvoid_type_node, 0));
195
196
	  tmp = fold_build3_loc (input_location, COND_EXPR,
197
				 TREE_TYPE (ctree),
198
				 gfc_unlikely (cond),
199
				 build_int_cst (TREE_TYPE (ctree), 0),
200
				 parmse->expr);
201
	}
202
187
      gfc_add_modify (&parmse->pre, ctree, tmp);
203
      gfc_add_modify (&parmse->pre, ctree, tmp);
188
    }
204
    }
189
  else
205
  else
Lines 588-593 gfc_conv_expr_present (gfc_symbol * sym) Link Here
588
  cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, decl,
604
  cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, decl,
589
			  fold_convert (TREE_TYPE (decl), null_pointer_node));
605
			  fold_convert (TREE_TYPE (decl), null_pointer_node));
590
606
607
  if (sym->ts.type == BT_CLASS)
608
    {
609
      tree tmp;
610
611
      decl = gfc_class_data_get (decl);
612
      if (sym->as == NULL && CLASS_DATA (sym)->as == NULL)
613
	{
614
	  tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
615
				 decl, fold_convert (TREE_TYPE (decl),
616
						     null_pointer_node));
617
	  cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
618
				  boolean_type_node, cond, tmp);
619
	}
620
    }
621
591
  /* Fortran 2008 allows to pass null pointers and non-associated pointers
622
  /* Fortran 2008 allows to pass null pointers and non-associated pointers
592
     as actual argument to denote absent dummies. For array descriptors,
623
     as actual argument to denote absent dummies. For array descriptors,
593
     we thus also need to check the array descriptor.  */
624
     we thus also need to check the array descriptor.  */
Lines 3259-3264 conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, Link Here
3259
}
3290
}
3260
3291
3261
3292
3293
static bool
3294
needs_class_data_ref (gfc_expr *e)
3295
{
3296
  gfc_ref *ref;
3297
  bool result;
3298
3299
  if (e->expr_type != EXPR_VARIABLE)
3300
    return false;
3301
3302
  if (e->symtree->n.sym->ts.type == BT_CLASS)
3303
    result = true;
3304
  else
3305
    result = false;
3306
3307
  for (ref = e->ref; ref; ref = ref->next)
3308
    {
3309
      if (ref->type != REF_COMPONENT)
3310
	{
3311
	  result = false;
3312
	  continue;
3313
	}
3314
3315
      if (ref->u.c.component->ts.type == BT_CLASS)
3316
	result = true; 
3317
      else if (ref->u.c.component->name[0] == '_')
3318
	result = false;
3319
    }
3320
3321
  return result;
3322
}
3323
3262
/* Generate code for a procedure call.  Note can return se->post != NULL.
3324
/* Generate code for a procedure call.  Note can return se->post != NULL.
3263
   If se->direct_byref is set then se->expr contains the return parameter.
3325
   If se->direct_byref is set then se->expr contains the return parameter.
3264
   Return nonzero, if the call has alternate specifiers.
3326
   Return nonzero, if the call has alternate specifiers.
Lines 3419-3430 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, Link Here
3419
	}
3481
	}
3420
      else if (se->ss && se->ss->info->useflags)
3482
      else if (se->ss && se->ss->info->useflags)
3421
	{
3483
	{
3484
	  gfc_ss *ss;
3485
3486
	  ss = se->ss;
3487
3422
	  /* An elemental function inside a scalarized loop.  */
3488
	  /* An elemental function inside a scalarized loop.  */
3423
	  gfc_init_se (&parmse, se);
3489
	  gfc_init_se (&parmse, se);
3424
	  parm_kind = ELEMENTAL;
3490
	  parm_kind = ELEMENTAL;
3425
3491
3426
	  if (se->ss->dimen > 0
3492
	  if (ss->dimen > 0
3427
	      && se->ss->info->data.array.ref == NULL)
3493
	      && ss->info->data.array.ref == NULL)
3428
	    {
3494
	    {
3429
	      gfc_conv_tmp_array_ref (&parmse);
3495
	      gfc_conv_tmp_array_ref (&parmse);
3430
	      if (e->ts.type == BT_CHARACTER)
3496
	      if (e->ts.type == BT_CHARACTER)
Lines 3435-3440 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, Link Here
3435
	  else
3501
	  else
3436
	    gfc_conv_expr_reference (&parmse, e);
3502
	    gfc_conv_expr_reference (&parmse, e);
3437
3503
3504
	  if (fsym && fsym->ts.type == BT_DERIVED && needs_class_data_ref (e))
3505
	    parmse.expr = gfc_class_data_get (parmse.expr);
3506
3507
	  if (ss->info->can_be_null_ref && ss->info->type != GFC_SS_REFERENCE)
3508
	    {
3509
	      tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
3510
				     ss->info->data.array.data,
3511
				     build_int_cst (pvoid_type_node, 0));
3512
3513
	      parmse.expr
3514
		= fold_build3_loc (input_location, COND_EXPR,
3515
				   TREE_TYPE (parmse.expr),
3516
				   gfc_unlikely (tmp),
3517
				   build_int_cst (TREE_TYPE (parmse.expr), 0),
3518
				   parmse.expr);
3519
	    }
3520
3438
	  /* The scalarizer does not repackage the reference to a class
3521
	  /* The scalarizer does not repackage the reference to a class
3439
	     array - instead it returns a pointer to the data element.  */
3522
	     array - instead it returns a pointer to the data element.  */
3440
	  if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
3523
	  if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
Lines 3509-3514 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, Link Here
3509
		    base_object = build_fold_indirect_ref_loc (input_location,
3592
		    base_object = build_fold_indirect_ref_loc (input_location,
3510
							       parmse.expr);
3593
							       parmse.expr);
3511
3594
3595
3596
		  if (fsym && fsym->ts.type == BT_DERIVED
3597
		      && needs_class_data_ref (e))
3598
		    parmse.expr = gfc_class_data_get (parmse.expr);
3599
3512
		  /* A class array element needs converting back to be a
3600
		  /* A class array element needs converting back to be a
3513
		     class object, if the formal argument is a class object.  */
3601
		     class object, if the formal argument is a class object.  */
3514
		  if (fsym && fsym->ts.type == BT_CLASS
3602
		  if (fsym && fsym->ts.type == BT_CLASS
Lines 5347-5353 gfc_conv_expr (gfc_se * se, gfc_expr * expr) Link Here
5347
      se->expr = ss_info->data.scalar.value;
5435
      se->expr = ss_info->data.scalar.value;
5348
      /* If the reference can be NULL, the value field contains the reference,
5436
      /* If the reference can be NULL, the value field contains the reference,
5349
	 not the value the reference points to (see gfc_add_loop_ss_code).  */
5437
	 not the value the reference points to (see gfc_add_loop_ss_code).  */
5350
      if (ss_info->data.scalar.can_be_null_ref)
5438
      if (ss_info->can_be_null_ref)
5351
	se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
5439
	se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
5352
5440
5353
      se->string_length = ss_info->string_length;
5441
      se->string_length = ss_info->string_length;
(-)a/trans-stmt.c (-1 / +23 lines)
Lines 348-353 gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse, Link Here
348
}
348
}
349
349
350
350
351
/* Get the interface symbol for the procedure corresponding to the given call.
352
   We can't get the procedure symbol directly as we have to handle the case
353
   of (deferred) type-bound procedures.  */
354
355
static gfc_symbol *
356
get_proc_ifc_for_call (gfc_code *c)
357
{
358
  gfc_symbol *sym;
359
360
  gcc_assert (c->op == EXEC_ASSIGN_CALL || c->op == EXEC_CALL);
361
362
  sym = gfc_get_proc_ifc_for_expr (c->expr1);
363
364
  /* Fall back/last resort try.  */
365
  if (sym == NULL)
366
    sym = c->resolved_sym;
367
368
  return sym;
369
}
370
371
351
/* Translate the CALL statement.  Builds a call to an F95 subroutine.  */
372
/* Translate the CALL statement.  Builds a call to an F95 subroutine.  */
352
373
353
tree
374
tree
Lines 372-378 gfc_trans_call (gfc_code * code, bool dependency_check, Link Here
372
  ss = gfc_ss_terminator;
393
  ss = gfc_ss_terminator;
373
  if (code->resolved_sym->attr.elemental)
394
  if (code->resolved_sym->attr.elemental)
374
    ss = gfc_walk_elemental_function_args (ss, code->ext.actual,
395
    ss = gfc_walk_elemental_function_args (ss, code->ext.actual,
375
					   code->expr1, GFC_SS_REFERENCE);
396
					   get_proc_ifc_for_call (code),
397
					   GFC_SS_REFERENCE);
376
398
377
  /* Is not an elemental subroutine call with array valued arguments.  */
399
  /* Is not an elemental subroutine call with array valued arguments.  */
378
  if (ss == gfc_ss_terminator)
400
  if (ss == gfc_ss_terminator)
(-)a/trans.h (-3 / +5 lines)
Lines 198-206 typedef struct gfc_ss_info Link Here
198
    struct
198
    struct
199
    {
199
    {
200
      tree value;
200
      tree value;
201
      /* Tells whether the reference can be null in the GFC_SS_REFERENCE case.
202
	 Used to handle elemental procedures' optional arguments.  */
203
      bool can_be_null_ref;
204
    }
201
    }
205
    scalar;
202
    scalar;
206
203
Lines 223-228 typedef struct gfc_ss_info Link Here
223
220
224
  /* Suppresses precalculation of scalars in WHERE assignments.  */
221
  /* Suppresses precalculation of scalars in WHERE assignments.  */
225
  unsigned where:1;
222
  unsigned where:1;
223
224
  /* Tells whether the SS is for an actual argument which can be a NULL
225
     reference.  In other words, the associated dummy argument is OPTIONAL.
226
     Used to handle elemental procedures.  */
227
  bool can_be_null_ref;
226
}
228
}
227
gfc_ss_info;
229
gfc_ss_info;
228
230

Return to bug 50981