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

Collapse All | Expand All | Context: (Patch / File /
)

(-)a/resolve.c (-3 / +15 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
  if (sym->ts.type == BT_CLASS)
1581
    return CLASS_DATA (sym)->as;
1582
  else
1583
    return sym->as;
1584
}
1585
1586
1577
/* Resolve an actual argument list.  Most of the time, this is just
1587
/* Resolve an actual argument list.  Most of the time, this is just
1578
   resolving the expressions in the list.
1588
   resolving the expressions in the list.
1579
   The exception is that we sometimes have to decide whether arguments
1589
   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:
1749
    got_variable:
1740
      e->expr_type = EXPR_VARIABLE;
1750
      e->expr_type = EXPR_VARIABLE;
1741
      e->ts = sym->ts;
1751
      e->ts = sym->ts;
1742
      if (sym->as != NULL)
1752
      if (symbol_as (sym) != NULL)
1743
	{
1753
	{
1744
	  e->rank = sym->as->rank;
1754
	  gfc_array_spec *as = symbol_as (sym);
1755
1756
	  e->rank = as->rank;
1745
	  e->ref = gfc_get_ref ();
1757
	  e->ref = gfc_get_ref ();
1746
	  e->ref->type = REF_ARRAY;
1758
	  e->ref->type = REF_ARRAY;
1747
	  e->ref->u.ar.type = AR_FULL;
1759
	  e->ref->u.ar.type = AR_FULL;
1748
	  e->ref->u.ar.as = sym->as;
1760
	  e->ref->u.ar.as = as;
1749
	}
1761
	}
1750
1762
1751
      /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1763
      /* Expressions are assigned a default ts.type of BT_PROCEDURE in
(-)a/trans-array.c (-28 / +43 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 8375-8381   gfc_reverse_ss (gfc_ss * ss) Link Here 
8375
8375
8376
gfc_ss *
8376
gfc_ss *
8377
gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
8377
gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
8378
				  gfc_expr *proc_expr, gfc_ss_type type)
8378
				  gfc_symbol *proc_ifc, gfc_ss_type type)
8379
{
8379
{
8380
  gfc_formal_arglist *dummy_arg;
8380
  gfc_formal_arglist *dummy_arg;
8381
  int scalar;
8381
  int scalar;
 Lines 8386-8409   gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg, Link Here 
8386
  head = gfc_ss_terminator;
8386
  head = gfc_ss_terminator;
8387
  tail = NULL;
8387
  tail = NULL;
8388
8388
8389
  if (proc_expr)
8389
  if (proc_ifc)
8390
    {
8390
    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
8391
  else
8408
    dummy_arg = NULL;
8392
    dummy_arg = NULL;
8409
8393
 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);
8405
	  newss = gfc_get_scalar_ss (head, arg->expr);
8422
	  newss->info->type = type;
8406
	  newss->info->type = type;
8423
8407
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
	}
8408
	}
8432
      else
8409
      else
8433
	scalar = 0;
8410
	scalar = 0;
8434
8411
8412
      if (dummy_arg != NULL
8413
	  && dummy_arg->sym->attr.optional
8414
	  && arg->expr->expr_type == EXPR_VARIABLE
8415
	  && (gfc_expr_attr (arg->expr).optional
8416
	      || gfc_expr_attr (arg->expr).allocatable
8417
	      || gfc_expr_attr (arg->expr).pointer))
8418
	newss->info->can_be_null_ref = true;
8419
8435
      head = newss;
8420
      head = newss;
8436
      if (!tail)
8421
      if (!tail)
8437
        {
8422
        {
 Lines 8458-8463   gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg, Link Here 
8458
}
8443
}
8459
8444
8460
8445
8446
/* Given an expression refering to a procedure, return the symbol of its
8447
   interface.  We can't get the procedure symbol directly as we have to handle
8448
   the case of (deferred) type-bound procedures.  */
8449
8450
gfc_symbol *
8451
gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref)
8452
{
8453
  gfc_symbol *sym;
8454
  gfc_ref *ref;
8455
8456
  if (procedure_ref == NULL)
8457
    return NULL;
8458
8459
  sym = procedure_ref->symtree->n.sym;
8460
8461
  for (ref = procedure_ref->ref; ref; ref = ref->next)
8462
    {
8463
      if (ref->type == REF_COMPONENT
8464
	  && ref->u.c.component->attr.proc_pointer
8465
	  && ref->u.c.component->ts.interface)
8466
	sym = ref->u.c.component->ts.interface;
8467
      else
8468
	sym = NULL;
8469
    }
8470
8471
  return sym;
8472
}
8473
8474
8461
/* Walk a function call.  Scalar functions are passed back, and taken out of
8475
/* Walk a function call.  Scalar functions are passed back, and taken out of
8462
   scalarization loops.  For elemental functions we walk their arguments.
8476
   scalarization loops.  For elemental functions we walk their arguments.
8463
   The result of functions returning arrays is stored in a temporary outside
8477
   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.  */
8505
     by reference.  */
8492
  if (sym->attr.elemental || (comp && comp->attr.elemental))
8506
  if (sym->attr.elemental || (comp && comp->attr.elemental))
8493
    return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
8507
    return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
8494
					     expr, GFC_SS_REFERENCE);
8508
					     gfc_get_proc_ifc_for_expr (expr),
8509
					     GFC_SS_REFERENCE);
8495
8510
8496
  /* Scalar functions are OK as these are evaluated outside the scalarization
8511
  /* Scalar functions are OK as these are evaluated outside the scalarization
8497
     loop.  Pass back and let the caller deal with it.  */
8512
     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 (-3 / +61 lines)
 Lines 3259-3264   conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, Link Here 
3259
}
3259
}
3260
3260
3261
3261
3262
static bool
3263
needs_class_data_ref (gfc_expr *e)
3264
{
3265
  gfc_ref *ref;
3266
  bool result;
3267
3268
  if (e->expr_type != EXPR_VARIABLE)
3269
    return false;
3270
3271
  if (e->symtree->n.sym->ts.type == BT_CLASS)
3272
    result = true;
3273
  else
3274
    result = false;
3275
3276
  for (ref = e->ref; ref; ref = ref->next)
3277
    {
3278
      if (ref->type != REF_COMPONENT)
3279
	{
3280
	  result = false;
3281
	  continue;
3282
	}
3283
3284
      if (ref->u.c.component->ts.type == BT_CLASS)
3285
	result = true; 
3286
      else if (!strcmp (ref->u.c.component->name, "_data"))
3287
	result = false;
3288
    }
3289
3290
  return result;
3291
}
3292
3262
/* Generate code for a procedure call.  Note can return se->post != NULL.
3293
/* 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.
3294
   If se->direct_byref is set then se->expr contains the return parameter.
3264
   Return nonzero, if the call has alternate specifiers.
3295
   Return nonzero, if the call has alternate specifiers.
 Lines 3419-3430   gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, Link Here 
3419
	}
3450
	}
3420
      else if (se->ss && se->ss->info->useflags)
3451
      else if (se->ss && se->ss->info->useflags)
3421
	{
3452
	{
3453
	  gfc_ss *ss;
3454
3455
	  ss = se->ss;
3456
3422
	  /* An elemental function inside a scalarized loop.  */
3457
	  /* An elemental function inside a scalarized loop.  */
3423
	  gfc_init_se (&parmse, se);
3458
	  gfc_init_se (&parmse, se);
3424
	  parm_kind = ELEMENTAL;
3459
	  parm_kind = ELEMENTAL;
3425
3460
3426
	  if (se->ss->dimen > 0
3461
	  if (ss->dimen > 0
3427
	      && se->ss->info->data.array.ref == NULL)
3462
	      && ss->info->data.array.ref == NULL)
3428
	    {
3463
	    {
3429
	      gfc_conv_tmp_array_ref (&parmse);
3464
	      gfc_conv_tmp_array_ref (&parmse);
3430
	      if (e->ts.type == BT_CHARACTER)
3465
	      if (e->ts.type == BT_CHARACTER)
 Lines 3435-3440   gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, Link Here 
3435
	  else
3470
	  else
3436
	    gfc_conv_expr_reference (&parmse, e);
3471
	    gfc_conv_expr_reference (&parmse, e);
3437
3472
3473
	  if (fsym && fsym->ts.type == BT_DERIVED && needs_class_data_ref (e))
3474
	    parmse.expr = gfc_class_data_get (parmse.expr);
3475
3476
	  if (ss->info->can_be_null_ref && ss->info->type != GFC_SS_REFERENCE)
3477
	    {
3478
	      tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
3479
				     ss->info->data.array.data,
3480
				     build_int_cst (pvoid_type_node, 0));
3481
3482
	      parmse.expr
3483
		= fold_build3_loc (input_location, COND_EXPR,
3484
				   TREE_TYPE (parmse.expr),
3485
				   gfc_unlikely (tmp),
3486
				   build_int_cst (TREE_TYPE (parmse.expr), 0),
3487
				   parmse.expr);
3488
	    }
3489
						
3490
3438
	  /* The scalarizer does not repackage the reference to a class
3491
	  /* The scalarizer does not repackage the reference to a class
3439
	     array - instead it returns a pointer to the data element.  */
3492
	     array - instead it returns a pointer to the data element.  */
3440
	  if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
3493
	  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,
3562
		    base_object = build_fold_indirect_ref_loc (input_location,
3510
							       parmse.expr);
3563
							       parmse.expr);
3511
3564
3565
3566
		  if (fsym && fsym->ts.type == BT_DERIVED
3567
		      && needs_class_data_ref (e))
3568
		    parmse.expr = gfc_class_data_get (parmse.expr);
3569
3512
		  /* A class array element needs converting back to be a
3570
		  /* A class array element needs converting back to be a
3513
		     class object, if the formal argument is a class object.  */
3571
		     class object, if the formal argument is a class object.  */
3514
		  if (fsym && fsym->ts.type == BT_CLASS
3572
		  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;
5405
      se->expr = ss_info->data.scalar.value;
5348
      /* If the reference can be NULL, the value field contains the reference,
5406
      /* 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).  */
5407
	 not the value the reference points to (see gfc_add_loop_ss_code).  */
5350
      if (ss_info->data.scalar.can_be_null_ref)
5408
      if (ss_info->can_be_null_ref)
5351
	se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
5409
	se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
5352
5410
5353
      se->string_length = ss_info->string_length;
5411
      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