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/trans-array.c (-23 / +38 lines)
Lines 8334-8340 gfc_reverse_ss (gfc_ss * ss) Link Here
8334
8334
8335
gfc_ss *
8335
gfc_ss *
8336
gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
8336
gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
8337
				  gfc_expr *proc_expr, gfc_ss_type type)
8337
				  gfc_symbol *proc_ifc, gfc_ss_type type)
8338
{
8338
{
8339
  gfc_formal_arglist *dummy_arg;
8339
  gfc_formal_arglist *dummy_arg;
8340
  int scalar;
8340
  int scalar;
Lines 8345-8368 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg, Link Here
8345
  head = gfc_ss_terminator;
8345
  head = gfc_ss_terminator;
8346
  tail = NULL;
8346
  tail = NULL;
8347
8347
8348
  if (proc_expr)
8348
  if (proc_ifc)
8349
    {
8349
    dummy_arg = proc_ifc->formal;
8350
      gfc_ref *ref;
8351
8352
      /* Normal procedure case.  */
8353
      dummy_arg = proc_expr->symtree->n.sym->formal;
8354
8355
      /* Typebound procedure case.  */
8356
      for (ref = proc_expr->ref; ref; ref = ref->next)
8357
	{
8358
	  if (ref->type == REF_COMPONENT
8359
	      && ref->u.c.component->attr.proc_pointer
8360
	      && ref->u.c.component->ts.interface)
8361
	    dummy_arg = ref->u.c.component->ts.interface->formal;
8362
	  else
8363
	    dummy_arg = NULL;
8364
	}
8365
    }
8366
  else
8350
  else
8367
    dummy_arg = NULL;
8351
    dummy_arg = NULL;
8368
8352
Lines 8382-8390 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg, Link Here
8382
8366
8383
	  if (dummy_arg != NULL
8367
	  if (dummy_arg != NULL
8384
	      && dummy_arg->sym->attr.optional
8368
	      && dummy_arg->sym->attr.optional
8385
	      && arg->expr->symtree
8369
	      && arg->expr->expr_type == EXPR_VARIABLE
8386
	      && arg->expr->symtree->n.sym->attr.optional
8370
	      && (gfc_expr_attr(arg->expr).optional
8387
	      && arg->expr->ref == NULL)
8371
		  || gfc_expr_attr (arg->expr).allocatable
8372
		  || gfc_expr_attr (arg->expr).pointer))
8388
	    newss->info->data.scalar.can_be_null_ref = true;
8373
	    newss->info->data.scalar.can_be_null_ref = true;
8389
	}
8374
	}
8390
      else
8375
      else
Lines 8416-8421 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg, Link Here
8416
}
8401
}
8417
8402
8418
8403
8404
/* Given an expression refering to a procedure, return the symbol of its
8405
   interface.  We can't get the procedure symbol directly as we have to handle
8406
   the case of (deferred) type-bound procedures.  */
8407
8408
gfc_symbol *
8409
gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref)
8410
{
8411
  gfc_symbol *sym;
8412
  gfc_ref *ref;
8413
8414
  if (procedure_ref == NULL)
8415
    return NULL;
8416
8417
  sym = procedure_ref->symtree->n.sym;
8418
8419
  for (ref = procedure_ref->ref; ref; ref = ref->next)
8420
    {
8421
      if (ref->type == REF_COMPONENT
8422
	  && ref->u.c.component->attr.proc_pointer
8423
	  && ref->u.c.component->ts.interface)
8424
	sym = ref->u.c.component->ts.interface;
8425
      else
8426
	sym = NULL;
8427
    }
8428
8429
  return sym;
8430
}
8431
8432
8419
/* Walk a function call.  Scalar functions are passed back, and taken out of
8433
/* Walk a function call.  Scalar functions are passed back, and taken out of
8420
   scalarization loops.  For elemental functions we walk their arguments.
8434
   scalarization loops.  For elemental functions we walk their arguments.
8421
   The result of functions returning arrays is stored in a temporary outside
8435
   The result of functions returning arrays is stored in a temporary outside
Lines 8449-8455 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr) Link Here
8449
     by reference.  */
8463
     by reference.  */
8450
  if (sym->attr.elemental || (comp && comp->attr.elemental))
8464
  if (sym->attr.elemental || (comp && comp->attr.elemental))
8451
    return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
8465
    return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
8452
					     expr, GFC_SS_REFERENCE);
8466
					     gfc_get_proc_ifc_for_expr (expr),
8467
					     GFC_SS_REFERENCE);
8453
8468
8454
  /* Scalar functions are OK as these are evaluated outside the scalarization
8469
  /* Scalar functions are OK as these are evaluated outside the scalarization
8455
     loop.  Pass back and let the caller deal with it.  */
8470
     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 (+8 lines)
Lines 3435-3440 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, Link Here
3435
	  else
3435
	  else
3436
	    gfc_conv_expr_reference (&parmse, e);
3436
	    gfc_conv_expr_reference (&parmse, e);
3437
3437
3438
	  if (fsym && fsym->ts.type == BT_DERIVED && e->ts.type == BT_CLASS)
3439
	    parmse.expr = gfc_class_data_get (parmse.expr);
3440
3438
	  /* The scalarizer does not repackage the reference to a class
3441
	  /* The scalarizer does not repackage the reference to a class
3439
	     array - instead it returns a pointer to the data element.  */
3442
	     array - instead it returns a pointer to the data element.  */
3440
	  if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
3443
	  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,
3512
		    base_object = build_fold_indirect_ref_loc (input_location,
3510
							       parmse.expr);
3513
							       parmse.expr);
3511
3514
3515
3516
		  if (fsym && fsym->ts.type == BT_DERIVED
3517
		      && e->ts.type == BT_CLASS)
3518
		    parmse.expr = gfc_class_data_get (parmse.expr);
3519
3512
		  /* A class array element needs converting back to be a
3520
		  /* A class array element needs converting back to be a
3513
		     class object, if the formal argument is a class object.  */
3521
		     class object, if the formal argument is a class object.  */
3514
		  if (fsym && fsym->ts.type == BT_CLASS
3522
		  if (fsym && fsym->ts.type == BT_CLASS
(-)a/trans-stmt.c (-1 / +23 lines)
Lines 325-330 gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse, Link Here
325
}
325
}
326
326
327
327
328
/* Get the interface symbol for the procedure corresponding to the given call.
329
   We can't get the procedure symbol directly as we have to handle the case
330
   of (deferred) type-bound procedures.  */
331
332
static gfc_symbol *
333
get_proc_ifc_for_call (gfc_code *c)
334
{
335
  gfc_symbol *sym;
336
337
  gcc_assert (c->op == EXEC_ASSIGN_CALL || c->op == EXEC_CALL);
338
339
  sym = gfc_get_proc_ifc_for_expr (c->expr1);
340
341
  /* Fall back/last resort try.  */
342
  if (sym == NULL)
343
    sym = c->resolved_sym;
344
345
  return sym;
346
}
347
348
328
/* Translate the CALL statement.  Builds a call to an F95 subroutine.  */
349
/* Translate the CALL statement.  Builds a call to an F95 subroutine.  */
329
350
330
tree
351
tree
Lines 349-355 gfc_trans_call (gfc_code * code, bool dependency_check, Link Here
349
  ss = gfc_ss_terminator;
370
  ss = gfc_ss_terminator;
350
  if (code->resolved_sym->attr.elemental)
371
  if (code->resolved_sym->attr.elemental)
351
    ss = gfc_walk_elemental_function_args (ss, code->ext.actual,
372
    ss = gfc_walk_elemental_function_args (ss, code->ext.actual,
352
					   code->expr1, GFC_SS_REFERENCE);
373
					   get_proc_ifc_for_call (code),
374
					   GFC_SS_REFERENCE);
353
375
354
  /* Is not an elemental subroutine call with array valued arguments.  */
376
  /* Is not an elemental subroutine call with array valued arguments.  */
355
  if (ss == gfc_ss_terminator)
377
  if (ss == gfc_ss_terminator)

Return to bug 50981