View | Details | Raw Unified | Return to bug 37336
Collapse All | Expand All

(-)gcc/fortran/symbol.c (+20 lines)
Lines 2311-2316 gfc_get_unique_symtree (gfc_namespace *n Link Here
2311
}
2311
}
2312
2312
2313
2313
2314
/* Generate a local variable for use as temporary.  */
2315
2316
gfc_symbol*
2317
gfc_get_temporary_variable (gfc_namespace* ns)
2318
{
2319
  static int id = 0;
2320
  char name[16]; /* "__tmpvar_XXXXXX\0" => 16 characters.  */
2321
  gfc_symbol* var;
2322
2323
  /* XXX: Is this done correctly?  Need to set any more members?  */
2324
  /* XXX: Maybe use gfc_get_unique_symtree?  */
2325
  snprintf(name, sizeof (name), "__tmpvar_%d", id++);
2326
  gfc_get_symbol (name, ns, &var);
2327
  gfc_commit_symbols ();
2328
  gfc_set_sym_referenced (var);
2329
2330
  return var;
2331
}
2332
2333
2314
/* Given a name find a user operator node, creating it if it doesn't
2334
/* Given a name find a user operator node, creating it if it doesn't
2315
   exist.  These are much simpler than symbols because they can't be
2335
   exist.  These are much simpler than symbols because they can't be
2316
   ambiguous with one another.  */
2336
   ambiguous with one another.  */
(-)gcc/fortran/gfortran.h (+6 lines)
Lines 2203-2208 gfc_symtree *gfc_new_symtree (gfc_symtre Link Here
2203
gfc_symtree *gfc_find_symtree (gfc_symtree *, const char *);
2203
gfc_symtree *gfc_find_symtree (gfc_symtree *, const char *);
2204
void gfc_delete_symtree (gfc_symtree **, const char *);
2204
void gfc_delete_symtree (gfc_symtree **, const char *);
2205
gfc_symtree *gfc_get_unique_symtree (gfc_namespace *);
2205
gfc_symtree *gfc_get_unique_symtree (gfc_namespace *);
2206
gfc_symbol *gfc_get_temporary_variable (gfc_namespace *);
2206
gfc_user_op *gfc_get_uop (const char *);
2207
gfc_user_op *gfc_get_uop (const char *);
2207
gfc_user_op *gfc_find_uop (const char *, gfc_namespace *);
2208
gfc_user_op *gfc_find_uop (const char *, gfc_namespace *);
2208
void gfc_free_symbol (gfc_symbol *);
2209
void gfc_free_symbol (gfc_symbol *);
Lines 2336-2341 bool gfc_traverse_expr (gfc_expr *, gfc_ Link Here
2336
			int);
2337
			int);
2337
void gfc_expr_set_symbols_referenced (gfc_expr *);
2338
void gfc_expr_set_symbols_referenced (gfc_expr *);
2338
2339
2340
bool gfc_is_type_finalizable (const gfc_typespec*, bool);
2341
bool gfc_finalize_expr (gfc_expr*, bool, gfc_code*, locus);
2342
2339
/* st.c */
2343
/* st.c */
2340
extern gfc_code new_st;
2344
extern gfc_code new_st;
2341
2345
Lines 2359-2364 gfc_try gfc_resolve_dim_arg (gfc_expr *) Link Here
2359
int gfc_is_formal_arg (void);
2363
int gfc_is_formal_arg (void);
2360
void gfc_resolve_substring_charlen (gfc_expr *);
2364
void gfc_resolve_substring_charlen (gfc_expr *);
2361
match gfc_iso_c_sub_interface(gfc_code *, gfc_symbol *);
2365
match gfc_iso_c_sub_interface(gfc_code *, gfc_symbol *);
2366
void gfc_resolve_code (gfc_code *, gfc_namespace *);
2367
gfc_try gfc_resolve_call (gfc_code *);
2362
2368
2363
2369
2364
/* array.c */
2370
/* array.c */
(-)gcc/fortran/expr.c (+617 lines)
Lines 3266-3268 gfc_expr_set_symbols_referenced (gfc_exp Link Here
3266
{
3266
{
3267
  gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
3267
  gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
3268
}
3268
}
3269
3270
3271
/* Check if a given type is finalizable or if it has finalizable components.
3272
   ALLOCATABLE components are always "finalizable" in this context as they ought
3273
   to be auto-deallocated.  */
3274
3275
bool
3276
gfc_is_type_finalizable (const gfc_typespec* ts, bool comp_only)
3277
{
3278
  gfc_component* comp;
3279
3280
  /* Only derived types are finalizable.  */
3281
  if (ts->type != BT_DERIVED)
3282
    return false;
3283
3284
  /* See if we have finalizable components.  */
3285
  for (comp = ts->derived->components; comp; comp = comp->next)
3286
    if (comp->allocatable || (!comp->pointer 
3287
			      && gfc_is_type_finalizable (&comp->ts, false)))
3288
      return true;
3289
3290
  /* If components only is requested, return here.  */
3291
  if (comp_only)
3292
    return false;
3293
3294
  /* Now the type is finalizable if and only if it has finalizer procedures.  */
3295
  return ts->derived->f2k_derived && ts->derived->f2k_derived->finalizers;
3296
}
3297
3298
3299
/* Helper function to generate a gfc_expr from another one and adding one more
3300
   reference to the ref-chain.  This reference itself is not filled, only a
3301
   pointer to it returned and the caller must ensure it is initialized
3302
   properly.  */
3303
/* XXX:  Make this a global, general purpose function?  */
3304
3305
static gfc_expr*
3306
generate_reference_expr (gfc_expr* expr, gfc_ref** reftail, ref_type type)
3307
{
3308
  gfc_expr* ref_expr = gfc_copy_expr (expr);
3309
3310
  /* Find the tail of the references-list.  */
3311
  if (!ref_expr->ref)
3312
    {
3313
      ref_expr->ref = *reftail = gfc_get_ref ();
3314
      (*reftail)->next = NULL;
3315
    }
3316
  else
3317
    {
3318
      for (*reftail = ref_expr->ref; (*reftail)->next;
3319
	   *reftail = (*reftail)->next)
3320
	{
3321
	  /* If we're looking for an array reference and have found one, return
3322
	     here.  */
3323
	  if (type == REF_ARRAY && (*reftail)->type == REF_ARRAY
3324
	      && (*reftail)->u.ar.type != AR_ELEMENT)
3325
	    break;
3326
	}
3327
3328
      /* At most one array reference is allowed per reference chain, so if we
3329
	 already have one at the end, we can't just append a new one but have
3330
	 to adapt the existing one.  Otherwise, create a new node in the list
3331
	 of references.  */
3332
      if (type != REF_ARRAY || (*reftail)->type != REF_ARRAY)
3333
      {
3334
	(*reftail)->next = gfc_get_ref ();
3335
	*reftail = (*reftail)->next;
3336
	(*reftail)->next = NULL;
3337
3338
	/* If we generated a new array reference, initialize type so we know
3339
	   it is new.  */
3340
	if (type == REF_ARRAY)
3341
	  (*reftail)->u.ar.type = AR_UNKNOWN;
3342
      }
3343
    }
3344
3345
  /* Initialize with what is already known about the reference.  */
3346
  (*reftail)->type = type;
3347
3348
  return ref_expr;
3349
}
3350
3351
3352
/* Helper-function to build an intrinsic-call expression given some arguments.
3353
   This is used in finalization both for the ALLOCATED and SIZE intrinsics.  */
3354
/* XXX: Is this already somewhere implemented?  Make it general-purpose method?
3355
   Something else?  */
3356
static gfc_expr* build_intrinsic_call (const char* name, ...)
3357
{
3358
  gfc_expr* result;
3359
  gfc_actual_arglist** args_out;
3360
  va_list args_in;
3361
3362
  /* Build the basic function expression.  */
3363
  result = gfc_get_expr ();
3364
  result->expr_type = EXPR_FUNCTION;
3365
  result->ts.type = BT_UNKNOWN;
3366
  gfc_get_sym_tree (name, NULL, &result->symtree);
3367
  gfc_commit_symbols (); /* XXX: Need this here?  */
3368
  gfc_set_sym_referenced (result->symtree->n.sym);
3369
  result->symtree->n.sym->attr.flavor = FL_PROCEDURE;
3370
  result->value.function.isym = gfc_find_function (name);
3371
  result->value.function.esym = NULL;
3372
3373
  /* Walk the arguments and build the list of actual args.  */
3374
  va_start (args_in, name);
3375
  result->value.function.actual = NULL;
3376
  for (args_out = &result->value.function.actual; ;
3377
       args_out = &(*args_out)->next)
3378
    {
3379
      gfc_expr* cur_arg;
3380
3381
      cur_arg = va_arg (args_in, gfc_expr*);
3382
      if (!cur_arg)
3383
      break;
3384
3385
      gcc_assert (*args_out == NULL);
3386
      *args_out = gfc_get_actual_arglist ();
3387
      (*args_out)->expr = gfc_copy_expr (cur_arg);
3388
      (*args_out)->next = NULL;
3389
    }
3390
  gcc_assert (*args_out == NULL);
3391
  va_end (args_in);
3392
3393
  return result;
3394
}
3395
3396
3397
/* Build DO-loops to scalarize the finalization of components of
3398
   arrays of derived types.  This function is used as a helper-function within
3399
   finalize_derived_components.  */
3400
3401
/* XXX: Can/should we somehow re-use existing scalarization logic for this
3402
   one?  I don't really see a possibility, though.  */
3403
3404
static bool finalize_derived_components (gfc_expr*, gfc_code*);
3405
3406
static bool
3407
scalarize_derived_component_finalization (gfc_expr* expr, gfc_code* code,
3408
					  gfc_array_spec* as)
3409
{
3410
  gfc_code* code_head;
3411
  gfc_code* code_tail;
3412
  gfc_code* loop;
3413
  gfc_expr* aref_expr;
3414
  gfc_expr* orig_expr;
3415
  gfc_expr* vector_subscripts[GFC_MAX_DIMENSIONS];
3416
  gfc_ref* aref;
3417
  int dim;
3418
  int rank;
3419
  bool generated;
3420
3421
  /* XXX: Do we need special care for as->type == AS_UNKNOWN or AS_ASSUMED_SIZE
3422
     or do we always know the rank and can call UBOUND/LBOUND to get the
3423
     boundaries?  */
3424
3425
  /* Copy the expression and generate an array-reference as tail.  */
3426
  aref_expr = generate_reference_expr (expr, &aref, REF_ARRAY);
3427
  gcc_assert (aref->type == REF_ARRAY);
3428
3429
  /* An already existing node should not be AR_ELEMENT as that would not need to
3430
     be finalized.  */
3431
  gcc_assert (aref->u.ar.type != AR_ELEMENT);
3432
3433
  /* If we are adapting an existing AR_SECTION reference, get the original
3434
     expression without even that one so we can call LBOUND/UBOUND on it to get
3435
     the real boundaries.  Otherwise we can simply use the expression given as
3436
     argument for this purpose.  */
3437
  if (aref->u.ar.type == AR_SECTION)
3438
    {
3439
      gfc_ref* r;
3440
3441
      orig_expr = gfc_copy_expr (expr);
3442
      gcc_assert (orig_expr->ref);
3443
      for (r = orig_expr->ref; r; r = r->next)
3444
	if (r->type == REF_ARRAY && r->u.ar.type == AR_SECTION)
3445
	  {
3446
	    for (dim = 0; dim != r->u.ar.dimen; ++dim)
3447
	    {
3448
	      gfc_free_expr (r->u.ar.start[dim]);
3449
	      gfc_free_expr (r->u.ar.end[dim]);
3450
	      gfc_free_expr (r->u.ar.stride[dim]);
3451
	      r->u.ar.start[dim] = NULL;
3452
	      r->u.ar.end[dim] = NULL;
3453
	      r->u.ar.stride[dim] = NULL;
3454
	    }
3455
	    r->u.ar.type = AR_FULL;
3456
	  }
3457
3458
      orig_expr->shape = NULL;
3459
      gfc_resolve_expr (orig_expr);
3460
    }
3461
  else
3462
    orig_expr = expr;
3463
  rank = orig_expr->rank;
3464
3465
  /* Build the introduction code.  If we adapt an existing AR_SECTION reference
3466
     that contains vector subscripts, create temporary variables holding the
3467
     subscript-vectors and initialize them here; otherwise create a NOP.  The
3468
     temporary variables are stored in the vector_subscripts array.  Only those
3469
     values used later will be initialized.  */
3470
  code_head = code_tail = gfc_get_code ();
3471
  code_head->op = EXEC_NOP;
3472
  code_head->next = NULL;
3473
  if (aref->u.ar.type == AR_SECTION)
3474
    for (dim = 0; dim != rank; ++dim)
3475
      if (aref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3476
      {
3477
	gfc_symbol* vector_temp;
3478
	gfc_expr* vect;
3479
	gfc_expr* arr_length;
3480
3481
	vect = aref->u.ar.start[dim];
3482
3483
	gcc_assert (vect->expr_type == EXPR_ARRAY);
3484
	gcc_assert (gfc_is_constant_expr (vect));
3485
	gcc_assert (vect->rank == 1);
3486
	gcc_assert (vect->shape);
3487
3488
	/* Find the length of the subscript vector.  */
3489
	arr_length = gfc_int_expr (mpz_get_si (vect->shape[0]));
3490
	
3491
	/* Build integer array variable.  */
3492
	vector_temp = gfc_get_temporary_variable (gfc_current_ns);
3493
	vector_temp->ts.type = BT_INTEGER;
3494
	vector_temp->ts.kind = gfc_default_integer_kind;
3495
	vector_temp->attr.dimension = true;
3496
	vector_temp->as = gfc_get_array_spec ();
3497
	vector_temp->as->rank = 1;
3498
	vector_temp->as->type = AS_EXPLICIT;
3499
	vector_temp->as->lower[0] = gfc_int_expr (1);
3500
	vector_temp->as->upper[0] = arr_length;
3501
3502
	/* Save it in vector_subscripts.  */
3503
	vector_subscripts[dim] = gfc_lval_expr_from_sym (vector_temp);
3504
3505
	/* Build the assignment-statement to initialize this variable.  */
3506
	code_tail->next = gfc_get_code ();
3507
	code_tail = code_tail->next;
3508
	code_tail->next = NULL;
3509
	code_tail->op = EXEC_ASSIGN;
3510
	code_tail->expr = gfc_copy_expr (vector_subscripts[dim]);
3511
	code_tail->expr2 = gfc_copy_expr (vect);
3512
      }
3513
3514
  /* Loop over the dimensions and build the nested loops.  */
3515
  loop = NULL;
3516
  for (dim = 0; dim != rank; ++dim)
3517
    {
3518
      gfc_symbol* itervar;
3519
      gfc_expr* bounds_expr;
3520
      int bounds_dim;
3521
3522
      /* If adapting an existing AR_SECTION reference and the current dimension
3523
	 is already a single element one, nothing needs to be done.  */
3524
      if (aref->u.ar.type == AR_SECTION
3525
	  && aref->u.ar.dimen_type[dim] == DIMEN_ELEMENT)
3526
	continue;
3527
3528
      /* Generate an INTEGER iteration-variable.  */
3529
      itervar = gfc_get_temporary_variable (gfc_current_ns);
3530
      itervar->ts.type = BT_INTEGER;
3531
      itervar->ts.kind = gfc_default_integer_kind;
3532
3533
      /* Build a loop over the leading index.  */
3534
      /* TODO: These could be DO CONCURRENT loops once supported.  */
3535
3536
      if (!loop)
3537
	{
3538
	  loop = gfc_get_code ();
3539
	  code_tail->next = loop;
3540
	  code_tail = loop;
3541
	}
3542
      else
3543
      {
3544
	loop->block->next = gfc_get_code ();
3545
	loop = loop->block->next;
3546
      }
3547
3548
      loop->op = EXEC_DO;
3549
      loop->next = NULL;
3550
      loop->ext.iterator = gfc_get_iterator ();
3551
      loop->ext.iterator->var = gfc_lval_expr_from_sym (itervar);
3552
      loop->ext.iterator->start = loop->ext.iterator->end = NULL;
3553
      loop->ext.iterator->step = NULL;
3554
3555
      /* If adapting an existing reference with DIMEN_RANGE, take the bounds
3556
	 from there.  */
3557
      if (aref->u.ar.type == AR_SECTION
3558
	  && aref->u.ar.dimen_type[dim] == DIMEN_RANGE)
3559
	{
3560
	  if (aref->u.ar.start[dim])
3561
	    loop->ext.iterator->start = gfc_copy_expr (aref->u.ar.start[dim]);
3562
	  if (aref->u.ar.end[dim])
3563
	    loop->ext.iterator->end = gfc_copy_expr (aref->u.ar.end[dim]);
3564
	  if (aref->u.ar.stride[dim])
3565
	    loop->ext.iterator->step = gfc_copy_expr (aref->u.ar.stride[dim]);
3566
	}
3567
3568
      /* If we have DIMEN_VECTOR, use the vector subscript as expression to
3569
	 loop over for bounds-determination.  */
3570
      if (aref->u.ar.type == AR_SECTION
3571
	  && aref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3572
	{
3573
	  bounds_expr = vector_subscripts[dim];
3574
	  bounds_dim = 1;
3575
	}
3576
      else
3577
	{
3578
	  bounds_expr = orig_expr;
3579
	  bounds_dim = dim + 1;
3580
	}
3581
3582
      /* Use default values if not yet set.  */
3583
      if (!loop->ext.iterator->start)
3584
	loop->ext.iterator->start =
3585
	  build_intrinsic_call ("lbound", bounds_expr,
3586
				gfc_int_expr (bounds_dim),
3587
				gfc_int_expr (gfc_default_integer_kind), NULL);
3588
      if (!loop->ext.iterator->end)
3589
	loop->ext.iterator->end =
3590
	  build_intrinsic_call ("ubound", bounds_expr,
3591
				gfc_int_expr (bounds_dim),
3592
				gfc_int_expr (gfc_default_integer_kind), NULL);
3593
      if (!loop->ext.iterator->step)
3594
	loop->ext.iterator->step = gfc_int_expr(1);
3595
3596
      /* Generate the entry-point for the loop-body.  */
3597
      loop->block = gfc_get_code ();
3598
      loop->block->op = EXEC_DO;
3599
      loop->block->next = NULL;
3600
3601
      /* Index with our itervar into the current dimension.  If we have a vector
3602
	 subscript to scalarize, index instead with itervar into the subscript
3603
	 vector and use that value as final index.  */
3604
      if (aref->u.ar.type == AR_SECTION
3605
	  && aref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3606
	{
3607
	  gfc_ref* tref;
3608
	  gfc_expr* index;
3609
3610
	  index = generate_reference_expr (vector_subscripts[dim], &tref,
3611
					   REF_ARRAY);
3612
	  gcc_assert (tref->u.ar.type == AR_FULL);
3613
	  gcc_assert (tref->u.ar.dimen == 1);
3614
	  tref->u.ar.type = AR_ELEMENT;
3615
	  tref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
3616
	  tref->u.ar.start[0] = gfc_lval_expr_from_sym (itervar);
3617
	  tref->u.ar.stride[0] = tref->u.ar.end[0] = NULL;
3618
3619
	  gfc_resolve_expr (index);
3620
	  gcc_assert (index->rank == 0);
3621
3622
	  /* This was copied above, we can free it now.  */
3623
	  gfc_free_expr (vector_subscripts[dim]);
3624
3625
	  aref->u.ar.start[dim] = index;
3626
	}
3627
      else
3628
	aref->u.ar.start[dim] = gfc_lval_expr_from_sym (itervar);
3629
      aref->u.ar.dimen_type[dim] = DIMEN_ELEMENT;
3630
      aref->u.ar.stride[dim] = aref->u.ar.end[dim] = NULL;
3631
    }
3632
  gcc_assert (code_head && code_tail && loop);
3633
3634
  /* Initialize the general members of the reference node, we don't need the old
3635
     values any longer from now on.  */
3636
  if (aref->u.ar.type != AR_SECTION)
3637
    aref->u.ar.as = as;
3638
  else
3639
    gcc_assert (aref->u.ar.as && aref->u.ar.as->rank == rank);
3640
  aref->u.ar.type = AR_ELEMENT;
3641
  aref->u.ar.offset = NULL;
3642
  aref->u.ar.dimen = rank;
3643
3644
  /* Try to finalize the scalarized expression.  */
3645
  gfc_resolve_expr (aref_expr);
3646
  gcc_assert (aref_expr->rank == 0);
3647
  generated = finalize_derived_components (aref_expr, loop->block);
3648
3649
  /* If nothing was generated, free everything done so far.  This can happen
3650
     even for types with finalizable components if no matching finalizer was
3651
     found there.  */
3652
  if (!generated)
3653
    {
3654
      gfc_free_statements (code_head);
3655
      return false;
3656
    }
3657
3658
  /* Otherwise, put the code in the chain.  */
3659
  gfc_resolve_code (code_head, gfc_current_ns);
3660
  code_tail->next = code->next;
3661
  code->next = code_head;
3662
3663
  return true;
3664
}
3665
3666
3667
/* Finalize the components of a derived type.  */
3668
3669
static bool
3670
finalize_derived_components (gfc_expr* expr, gfc_code* code)
3671
{
3672
  gfc_component* comp;
3673
  gfc_array_spec* as;
3674
  int rank;
3675
  bool generated = false;
3676
3677
  if (!gfc_is_type_finalizable (&expr->ts, true))
3678
    return false;
3679
3680
  /* XXX: How to do component ref for non-variable expressions?  Might this even
3681
     ever be needed?  I don't think so.  */
3682
  gcc_assert (expr->expr_type == EXPR_VARIABLE);
3683
  gcc_assert (expr->symtree);
3684
3685
  /* Find array-specification and rank.  */
3686
  as = expr->symtree->n.sym->as;
3687
  rank = expr->rank;
3688
  if (expr->ref)
3689
    {
3690
      gfc_ref* ref;
3691
      for (ref = expr->ref; ref; ref = ref->next)
3692
      if (ref->type == REF_COMPONENT)
3693
	as = ref->u.c.component->as;
3694
    }
3695
  gcc_assert (rank == 0 || as);
3696
3697
  /* Scalarize finalization of components if the expression we're about to
3698
     finalize is an array of a derived type with finalizable components.  */
3699
  if (rank > 0)
3700
    {
3701
      gcc_assert (as);
3702
      return scalarize_derived_component_finalization (expr, code, as);
3703
    }
3704
3705
  /* Finalize each finalizable, non-pointer component.  ALLOCATABLE components
3706
     are finalized, too, as they are auto-deallocated.  */
3707
  for (comp = expr->ts.derived->components; comp; comp = comp->next)
3708
    if (comp->allocatable || (!comp->pointer 
3709
			      && gfc_is_type_finalizable (&comp->ts, false)))
3710
      {
3711
	gfc_expr* cref_expr;
3712
	gfc_ref* reftail;
3713
3714
	cref_expr = generate_reference_expr (expr, &reftail, REF_COMPONENT);
3715
	cref_expr->ts = comp->ts;
3716
3717
	reftail->u.c.component = comp;
3718
	reftail->u.c.sym = expr->ts.derived;
3719
3720
	if (comp->as)
3721
	  {
3722
	    cref_expr = generate_reference_expr (cref_expr, &reftail,
3723
						 REF_ARRAY);
3724
3725
	      if (reftail->u.ar.type == AR_UNKNOWN)
3726
		{
3727
		  reftail->u.ar.type = AR_FULL;
3728
		  /* XXX: I'm generally unsure if all places where I do/do not
3729
		     copy things rather than referencing them directly are
3730
		     correct as they are done.  */
3731
		  reftail->u.ar.as = gfc_copy_array_spec (comp->as);
3732
		}
3733
	  }
3734
3735
	cref_expr->rank = 0;
3736
	if (comp->as)
3737
	  cref_expr->rank = comp->as->rank;
3738
3739
	gfc_resolve_expr (cref_expr);
3740
	gcc_assert ((!comp->as && cref_expr->rank == 0)
3741
		    || (comp->as && cref_expr->rank == comp->as->rank));
3742
3743
	/* Finalize this expression.  */
3744
	if (gfc_finalize_expr (cref_expr, comp->allocatable, code, comp->loc))
3745
	  generated = true;
3746
      }
3747
3748
  return generated;
3749
}
3750
3751
3752
/* Generate code to finalize a given expression if it needs to be finalized.
3753
   The generated code is attached to the code-chain given.  This method is the
3754
   hook for finalization, implementing what the standard calls the "finalization
3755
   process" and is called from the various places where expressions need to be
3756
   finalized.
3757
   While ALLOCATABLE components are always auto-deallocated after the
3758
   finalization process, if dealloc_self is true, too, the entity itself will
3759
   be auto-deallocated after its finalization; this also wraps the whole
3760
   generated code inside a IF (ALLOCATED (expr)) condition.
3761
   True is returned if any code was generated.  */
3762
3763
bool
3764
gfc_finalize_expr (gfc_expr* expr, bool dealloc_self, gfc_code* code,
3765
		   locus where)
3766
{
3767
  gfc_code* whole_code = NULL;
3768
  gfc_code* final_after = NULL;
3769
  gfc_finalizer* f;
3770
  gfc_symtree* proc;
3771
  int expr_rank;
3772
  bool generated = false;
3773
3774
  gcc_assert (expr);
3775
3776
  /* If this entity itself is autodeallocated, insert conditional around all
3777
     generated code to check if it is allocated at runtime.  */
3778
  if (dealloc_self)
3779
    {
3780
      /* Build an IF (ALLOCATED (expr)) statement wrapping the whole
3781
	 finalization-logic following.  */
3782
3783
      whole_code = gfc_get_code ();
3784
      whole_code->op = EXEC_IF;
3785
      whole_code->expr = NULL;
3786
      whole_code->next = NULL;
3787
3788
      whole_code->block = gfc_get_code ();
3789
      whole_code->block->op = EXEC_IF;
3790
      whole_code->block->expr = build_intrinsic_call ("allocated", expr, NULL);
3791
      whole_code->block->next = NULL;
3792
      final_after = whole_code->block;
3793
    }
3794
  else
3795
    {
3796
      /* Build a NOP instead of the IF to chain finalization code to.  */
3797
      whole_code = gfc_get_code ();
3798
      whole_code->op = EXEC_NOP;
3799
      whole_code->next = NULL;
3800
      final_after = whole_code;
3801
    }
3802
3803
  /* If we are no derived type or don't have a finalizer ourself, skip this
3804
     self-finalization part.  */
3805
  if (expr->ts.type != BT_DERIVED || !expr->ts.derived->f2k_derived 
3806
      || !expr->ts.derived->f2k_derived->finalizers)
3807
    goto finish;
3808
3809
  expr_rank = expr->rank; /* Easy for expressions.  */
3810
3811
  /* Find a finalizer with the correct rank or an elemental
3812
     finalizer and call it.  */
3813
  /* TODO:  Also check for correct kind type parameters once those are
3814
     implemented in gfortran.  */
3815
  proc = NULL;
3816
  f = expr->ts.derived->f2k_derived->finalizers;
3817
  for (; f && !proc; f = f->next)
3818
    {
3819
      int proc_rank = 0;
3820
      gcc_assert (f->proc_tree);
3821
      gcc_assert (f->proc_tree->n.sym->formal);
3822
      if (f->proc_tree->n.sym->formal->sym->as)
3823
      proc_rank = f->proc_tree->n.sym->formal->sym->as->rank;
3824
3825
      if (expr_rank == proc_rank)
3826
      proc = f->proc_tree;
3827
    }
3828
3829
  f = expr->ts.derived->f2k_derived->finalizers;
3830
  for (; f && !proc; f = f->next)
3831
    {
3832
      if (f->proc_tree->n.sym->attr.elemental)
3833
      proc = f->proc_tree;
3834
    }
3835
3836
  /* Warn if we didn't find a suitable finalizer but others are defined for this
3837
     type.  In this case, the standard mandates to simply call no procedure, but
3838
     this is probably something not intended by the user.  */
3839
  if (!proc)
3840
    {
3841
      gfc_warning ("No matching finalizer found for derived type '%s' and"
3842
		   " rank %d at %L", expr->ts.derived->name, expr_rank, &where);
3843
      goto finish;
3844
    }
3845
3846
  /* Build the subroutine call.  */
3847
  gcc_assert (!final_after->next);
3848
  final_after->next = gfc_get_code ();
3849
  final_after = final_after->next;
3850
  final_after->loc = gfc_current_locus;
3851
  final_after->op = EXEC_CALL;
3852
  final_after->symtree = proc;
3853
  final_after->ext.actual = gfc_get_actual_arglist();
3854
  final_after->ext.actual->next = NULL;
3855
  final_after->ext.actual->expr = gfc_copy_expr (expr);
3856
  final_after->next = NULL;
3857
  generated = true;
3858
3859
finish:
3860
3861
  /* Finalize components, should be after our own finalizer call.  */
3862
  if (finalize_derived_components (expr, final_after))
3863
    generated = true;
3864
3865
  /* TODO:  Here we could insert the auto-deallocation EXEC_DEALLOCATE statement
3866
     when moving auto-deallocation from trans to resolution.  */
3867
3868
  /* If anything was generated, resolve our code and insert it into the
3869
     code-chain.  */
3870
  if (generated)
3871
    {
3872
      gfc_code* tail;
3873
3874
      gfc_resolve_code (whole_code, gfc_current_ns);
3875
      
3876
      for (tail = whole_code; tail->next; )
3877
	tail = tail->next;
3878
      tail->next = code->next;
3879
      code->next = whole_code;
3880
    }
3881
  else if (whole_code)
3882
    gfc_free_statements (whole_code);
3883
3884
  return generated;
3885
}
(-)gcc/fortran/resolve.c (-22 / +21 lines)
Lines 39-45 typedef enum seq_type Link Here
39
seq_type;
39
seq_type;
40
40
41
/* Stack to keep track of the nesting of blocks as we move through the
41
/* Stack to keep track of the nesting of blocks as we move through the
42
   code.  See resolve_branch() and resolve_code().  */
42
   code.  See resolve_branch() and gfc_resolve_code().  */
43
43
44
typedef struct code_stack
44
typedef struct code_stack
45
{
45
{
Lines 2772-2779 found: Link Here
2772
   for functions, subroutines and functions are stored differently and this
2772
   for functions, subroutines and functions are stored differently and this
2773
   makes things awkward.  */
2773
   makes things awkward.  */
2774
2774
2775
static gfc_try
2775
gfc_try
2776
resolve_call (gfc_code *c)
2776
gfc_resolve_call (gfc_code *c)
2777
{
2777
{
2778
  gfc_try t;
2778
  gfc_try t;
2779
  procedure_type ptype = PROC_INTRINSIC;
2779
  procedure_type ptype = PROC_INTRINSIC;
Lines 4069-4075 resolve_variable (gfc_expr *e) Link Here
4069
  if (check_assumed_size_reference (sym, e))
4069
  if (check_assumed_size_reference (sym, e))
4070
    return FAILURE;
4070
    return FAILURE;
4071
4071
4072
  /* Deal with forward references to entries during resolve_code, to
4072
  /* Deal with forward references to entries during gfc_resolve_code, to
4073
     satisfy, at least partially, 12.5.2.5.  */
4073
     satisfy, at least partially, 12.5.2.5.  */
4074
  if (gfc_current_ns->entries
4074
  if (gfc_current_ns->entries
4075
      && current_entry_id == sym->entry_id
4075
      && current_entry_id == sym->entry_id
Lines 5710-5719 resolve_where (gfc_code *code, gfc_expr Link Here
5710
5710
5711
  
5711
  
5712
	    case EXEC_ASSIGN_CALL:
5712
	    case EXEC_ASSIGN_CALL:
5713
	      resolve_call (cnext);
5713
	      gfc_resolve_call (cnext);
5714
	      if (!cnext->resolved_sym->attr.elemental)
5714
	      if (!cnext->resolved_sym->attr.elemental)
5715
		gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
5715
		gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at"
5716
			  &cnext->ext.actual->expr->where);
5716
			  " %L", &cnext->ext.actual->expr->where);
5717
	      break;
5717
	      break;
5718
5718
5719
	    /* WHERE or WHERE construct is part of a where-body-construct */
5719
	    /* WHERE or WHERE construct is part of a where-body-construct */
Lines 5795-5804 gfc_resolve_where_code_in_forall (gfc_co Link Here
5795
  
5795
  
5796
	    /* WHERE operator assignment statement */
5796
	    /* WHERE operator assignment statement */
5797
	    case EXEC_ASSIGN_CALL:
5797
	    case EXEC_ASSIGN_CALL:
5798
	      resolve_call (cnext);
5798
	      gfc_resolve_call (cnext);
5799
	      if (!cnext->resolved_sym->attr.elemental)
5799
	      if (!cnext->resolved_sym->attr.elemental)
5800
		gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
5800
		gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at"
5801
			  &cnext->ext.actual->expr->where);
5801
			  " %L", &cnext->ext.actual->expr->where);
5802
	      break;
5802
	      break;
5803
5803
5804
	    /* WHERE or WHERE construct is part of a where-body-construct */
5804
	    /* WHERE or WHERE construct is part of a where-body-construct */
Lines 5840-5846 gfc_resolve_forall_body (gfc_code *code, Link Here
5840
	  break;
5840
	  break;
5841
5841
5842
	case EXEC_ASSIGN_CALL:
5842
	case EXEC_ASSIGN_CALL:
5843
	  resolve_call (c);
5843
	  gfc_resolve_call (c);
5844
	  break;
5844
	  break;
5845
5845
5846
	/* Because the gfc_resolve_blocks() will handle the nested FORALL,
5846
	/* Because the gfc_resolve_blocks() will handle the nested FORALL,
Lines 5929-5936 gfc_resolve_forall (gfc_code *code, gfc_ Link Here
5929
/* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
5929
/* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
5930
   DO code nodes.  */
5930
   DO code nodes.  */
5931
5931
5932
static void resolve_code (gfc_code *, gfc_namespace *);
5933
5934
void
5932
void
5935
gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
5933
gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
5936
{
5934
{
Lines 5993-5999 gfc_resolve_blocks (gfc_code *b, gfc_nam Link Here
5993
	  gfc_internal_error ("resolve_block(): Bad block type");
5991
	  gfc_internal_error ("resolve_block(): Bad block type");
5994
	}
5992
	}
5995
5993
5996
      resolve_code (b->next, ns);
5994
      gfc_resolve_code (b->next, ns);
5997
    }
5995
    }
5998
}
5996
}
5999
5997
Lines 6142-6149 resolve_ordinary_assign (gfc_code *code, Link Here
6142
/* Given a block of code, recursively resolve everything pointed to by this
6140
/* Given a block of code, recursively resolve everything pointed to by this
6143
   code block.  */
6141
   code block.  */
6144
6142
6145
static void
6143
void
6146
resolve_code (gfc_code *code, gfc_namespace *ns)
6144
gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
6147
{
6145
{
6148
  int omp_workshare_save;
6146
  int omp_workshare_save;
6149
  int forall_save;
6147
  int forall_save;
Lines 6304-6310 resolve_code (gfc_code *code, gfc_namesp Link Here
6304
6302
6305
	case EXEC_CALL:
6303
	case EXEC_CALL:
6306
	call:
6304
	call:
6307
	  resolve_call (code);
6305
	  gfc_resolve_call (code);
6308
	  break;
6306
	  break;
6309
6307
6310
	case EXEC_SELECT:
6308
	case EXEC_SELECT:
Lines 6324-6330 resolve_code (gfc_code *code, gfc_namesp Link Here
6324
6322
6325
	case EXEC_DO_WHILE:
6323
	case EXEC_DO_WHILE:
6326
	  if (code->expr == NULL)
6324
	  if (code->expr == NULL)
6327
	    gfc_internal_error ("resolve_code(): No expression on DO WHILE");
6325
	    gfc_internal_error ("gfc_resolve_code():  No expression on"
6326
				" DO WHILE");
6328
	  if (t == SUCCESS
6327
	  if (t == SUCCESS
6329
	      && (code->expr->rank != 0
6328
	      && (code->expr->rank != 0
6330
		  || code->expr->ts.type != BT_LOGICAL))
6329
		  || code->expr->ts.type != BT_LOGICAL))
Lines 6440-6446 resolve_code (gfc_code *code, gfc_namesp Link Here
6440
	  break;
6439
	  break;
6441
6440
6442
	default:
6441
	default:
6443
	  gfc_internal_error ("resolve_code(): Bad statement code");
6442
	  gfc_internal_error ("gfc_resolve_code(): Bad statement code");
6444
	}
6443
	}
6445
    }
6444
    }
6446
6445
Lines 9251-9257 gfc_resolve_uops (gfc_symtree *symtree) Link Here
9251
   assign types to all intermediate expressions, make sure that all
9250
   assign types to all intermediate expressions, make sure that all
9252
   assignments are to compatible types and figure out which names
9251
   assignments are to compatible types and figure out which names
9253
   refer to which functions or subroutines.  It doesn't check code
9252
   refer to which functions or subroutines.  It doesn't check code
9254
   block, which is handled by resolve_code.  */
9253
   block, which is handled by gfc_resolve_code.  */
9255
9254
9256
static void
9255
static void
9257
resolve_types (gfc_namespace *ns)
9256
resolve_types (gfc_namespace *ns)
Lines 9320-9326 resolve_types (gfc_namespace *ns) Link Here
9320
}
9319
}
9321
9320
9322
9321
9323
/* Call resolve_code recursively.  */
9322
/* Call gfc_resolve_code recursively.  */
9324
9323
9325
static void
9324
static void
9326
resolve_codes (gfc_namespace *ns)
9325
resolve_codes (gfc_namespace *ns)
Lines 9336-9342 resolve_codes (gfc_namespace *ns) Link Here
9336
  current_entry_id = -1;
9335
  current_entry_id = -1;
9337
9336
9338
  bitmap_obstack_initialize (&labels_obstack);
9337
  bitmap_obstack_initialize (&labels_obstack);
9339
  resolve_code (ns->code, ns);
9338
  gfc_resolve_code (ns->code, ns);
9340
  bitmap_obstack_release (&labels_obstack);
9339
  bitmap_obstack_release (&labels_obstack);
9341
}
9340
}
9342
9341

Return to bug 37336