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

Collapse All | Expand All

(-)gcc/fortran/interface.c (+3 lines)
Lines 374-379 Link Here
374
      if (dt1->dimension != dt2->dimension)
374
      if (dt1->dimension != dt2->dimension)
375
	return 0;
375
	return 0;
376
376
377
     if (dt1->allocatable != dt2->allocatable)
378
	return 0;
379
377
      if (dt1->dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
380
      if (dt1->dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
378
	return 0;
381
	return 0;
379
382
(-)gcc/fortran/intrinsic.c (+5 lines)
Lines 2391-2396 Link Here
2391
	      length, BT_INTEGER, di, OPTIONAL, st, BT_INTEGER, di, OPTIONAL,
2391
	      length, BT_INTEGER, di, OPTIONAL, st, BT_INTEGER, di, OPTIONAL,
2392
	      trim_name, BT_LOGICAL, dl, OPTIONAL);
2392
	      trim_name, BT_LOGICAL, dl, OPTIONAL);
2393
2393
2394
  add_sym_2s ("move_alloc", 0, 0, BT_UNKNOWN, 0, GFC_STD_F2003,
2395
	      gfc_check_move_alloc, NULL, NULL,
2396
	      f, BT_UNKNOWN, 0, REQUIRED,
2397
	      t, BT_UNKNOWN, 0, REQUIRED);
2398
2394
  add_sym_5s ("mvbits", 1, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2399
  add_sym_5s ("mvbits", 1, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2395
	      gfc_check_mvbits, gfc_simplify_mvbits, gfc_resolve_mvbits,
2400
	      gfc_check_mvbits, gfc_simplify_mvbits, gfc_resolve_mvbits,
2396
	      f, BT_INTEGER, di, REQUIRED, fp, BT_INTEGER, di, REQUIRED,
2401
	      f, BT_INTEGER, di, REQUIRED, fp, BT_INTEGER, di, REQUIRED,
(-)gcc/fortran/trans-array.c (-36 / +375 lines)
Lines 3236-3267 Link Here
3236
  tree size;
3236
  tree size;
3237
  gfc_expr **lower;
3237
  gfc_expr **lower;
3238
  gfc_expr **upper;
3238
  gfc_expr **upper;
3239
  gfc_ref *ref;
3239
  gfc_ref *ref, *prev_ref = NULL;
3240
  int allocatable_array;
3240
  bool allocatable_array;
3241
  int must_be_pointer;
3242
3241
3243
  ref = expr->ref;
3242
  ref = expr->ref;
3244
3243
3245
  /* In Fortran 95, components can only contain pointers, so that,
3246
     in ALLOCATE (foo%bar(2)), bar must be a pointer component.
3247
     We test this by checking for ref->next.
3248
     An implementation of TR 15581 would need to change this.  */
3249
3250
  if (ref)
3251
    must_be_pointer = ref->next != NULL;
3252
  else
3253
    must_be_pointer = 0;
3254
  
3255
  /* Find the last reference in the chain.  */
3244
  /* Find the last reference in the chain.  */
3256
  while (ref && ref->next != NULL)
3245
  while (ref && ref->next != NULL)
3257
    {
3246
    {
3258
      gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3247
      gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3248
      prev_ref = ref;
3259
      ref = ref->next;
3249
      ref = ref->next;
3260
    }
3250
    }
3261
3251
3262
  if (ref == NULL || ref->type != REF_ARRAY)
3252
  if (ref == NULL || ref->type != REF_ARRAY)
3263
    return false;
3253
    return false;
3264
3254
3255
  if (!prev_ref)
3256
    allocatable_array = expr->symtree->n.sym->attr.allocatable;
3257
  else
3258
    allocatable_array = prev_ref->u.c.component->allocatable;
3259
3265
  /* Figure out the size of the array.  */
3260
  /* Figure out the size of the array.  */
3266
  switch (ref->u.ar.type)
3261
  switch (ref->u.ar.type)
3267
    {
3262
    {
Lines 3294-3304 Link Here
3294
  tmp = gfc_conv_descriptor_data_addr (se->expr);
3289
  tmp = gfc_conv_descriptor_data_addr (se->expr);
3295
  pointer = gfc_evaluate_now (tmp, &se->pre);
3290
  pointer = gfc_evaluate_now (tmp, &se->pre);
3296
3291
3297
  if (must_be_pointer)
3298
    allocatable_array = 0;
3299
  else
3300
    allocatable_array = expr->symtree->n.sym->attr.allocatable;
3301
3302
  if (TYPE_PRECISION (gfc_array_index_type) == 32)
3292
  if (TYPE_PRECISION (gfc_array_index_type) == 32)
3303
    {
3293
    {
3304
      if (allocatable_array)
3294
      if (allocatable_array)
Lines 3325-3330 Link Here
3325
  tmp = gfc_conv_descriptor_offset (se->expr);
3315
  tmp = gfc_conv_descriptor_offset (se->expr);
3326
  gfc_add_modify_expr (&se->pre, tmp, offset);
3316
  gfc_add_modify_expr (&se->pre, tmp, offset);
3327
3317
3318
  if (expr->ts.type == BT_DERIVED
3319
	&& expr->ts.derived->attr.alloc_comp)
3320
    {
3321
      tmp = gfc_nullify_alloc_comp (expr->ts.derived, se->expr,
3322
				    ref->u.ar.as->rank);
3323
      gfc_add_expr_to_block (&se->pre, tmp);
3324
    }
3325
{tree signal;
3326
signal = gfc_create_var (gfc_array_index_type, "SIGNAL");
3327
gfc_add_modify_expr (&se->pre, signal, gfc_index_one_node);}
3328
3328
  return true;
3329
  return true;
3329
}
3330
}
3330
3331
Lines 3465-3470 Link Here
3465
        }
3466
        }
3466
      break;
3467
      break;
3467
3468
3469
    case EXPR_NULL:
3470
      return gfc_build_null_descriptor (type);
3471
3468
    default:
3472
    default:
3469
      gcc_unreachable ();
3473
      gcc_unreachable ();
3470
    }
3474
    }
Lines 4547-4552 Link Here
4547
  se->want_pointer = 1;
4551
  se->want_pointer = 1;
4548
  gfc_conv_expr_descriptor (se, expr, ss);
4552
  gfc_conv_expr_descriptor (se, expr, ss);
4549
4553
4554
  /* Deallocate the allocatable components of structures that are
4555
     not variable.  */
4556
  if (expr->ts.type == BT_DERIVED
4557
	&& expr->ts.derived->attr.alloc_comp
4558
	&& expr->expr_type != EXPR_VARIABLE)
4559
    {
4560
      tmp = build_fold_indirect_ref (se->expr);
4561
      tmp = gfc_deallocate_alloc_comp (expr->ts.derived, tmp, expr->rank);
4562
      gfc_add_expr_to_block (&se->post, tmp);
4563
    }
4564
4550
  if (g77)
4565
  if (g77)
4551
    {
4566
    {
4552
      desc = se->expr;
4567
      desc = se->expr;
Lines 4595-4619 Link Here
4595
gfc_trans_dealloc_allocated (tree descriptor)
4610
gfc_trans_dealloc_allocated (tree descriptor)
4596
{ 
4611
{ 
4597
  tree tmp;
4612
  tree tmp;
4598
  tree deallocate;
4613
  tree ptr;
4614
  tree var;
4599
  stmtblock_t block;
4615
  stmtblock_t block;
4600
4616
4601
  gfc_start_block (&block);
4617
  gfc_start_block (&block);
4602
  deallocate = gfc_array_deallocate (descriptor, null_pointer_node);
4603
4618
4604
  tmp = gfc_conv_descriptor_data_get (descriptor);
4619
  tmp = gfc_conv_descriptor_data_addr (descriptor);
4605
  tmp = build2 (NE_EXPR, boolean_type_node, tmp,
4620
  var = gfc_evaluate_now (tmp, &block);
4606
                build_int_cst (TREE_TYPE (tmp), 0));
4621
  tmp = gfc_create_var (gfc_array_index_type, NULL);
4607
  tmp = build3_v (COND_EXPR, tmp, deallocate, build_empty_stmt ());
4622
  ptr = build_fold_addr_expr (tmp);
4623
4624
  /* Call array_deallocate with an int* present in the second argument.
4625
     Although it is ignored here, it's presence ensures that arrays that
4626
     are already deallocated are ignored.  */
4627
  tmp = gfc_chainon_list (NULL_TREE, var);
4628
  tmp = gfc_chainon_list (tmp, ptr);
4629
  tmp = build_function_call_expr (gfor_fndecl_deallocate, tmp);
4608
  gfc_add_expr_to_block (&block, tmp);
4630
  gfc_add_expr_to_block (&block, tmp);
4631
  return gfc_finish_block (&block);
4632
}
4633
4634
4635
/* This helper function calculates the size in words of a full array.  */
4609
4636
4637
static tree
4638
get_full_array_size (stmtblock_t *block, tree decl, int rank)
4639
{
4640
  tree idx;
4641
  tree nelems;
4642
  tree tmp;
4643
  idx = gfc_rank_cst[rank - 1];
4644
  nelems = gfc_conv_descriptor_ubound (decl, idx);
4645
  tmp = gfc_conv_descriptor_lbound (decl, idx);
4646
  tmp = build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
4647
  tmp = build2 (PLUS_EXPR, gfc_array_index_type,
4648
		tmp, gfc_index_one_node);
4649
  tmp = gfc_evaluate_now (tmp, block);
4650
4651
  nelems = gfc_conv_descriptor_stride (decl, idx);
4652
  tmp = build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
4653
  return gfc_evaluate_now (tmp, block);
4654
}
4655
4656
4657
/* Allocate dest to the same size as src, and copy src -> dest.  */
4658
4659
tree
4660
gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank)
4661
{
4662
  tree tmp;
4663
  tree size;
4664
  tree nelems;
4665
  tree args;
4666
  tree null_cond;
4667
  tree null_data;
4668
  stmtblock_t block;
4669
4670
  /* If the source is null, set the destination to null. */
4671
  gfc_init_block (&block);
4672
  gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4673
  null_data = gfc_finish_block (&block);
4674
4675
  gfc_init_block (&block);
4676
4677
  nelems = get_full_array_size (&block, src, rank);
4678
  size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
4679
		      TYPE_SIZE_UNIT (gfc_get_element_type (type)));
4680
4681
  /* Allocate memory to the destination.  */
4682
  tmp = gfc_chainon_list (NULL_TREE, size);
4683
  if (gfc_index_integer_kind == 4)
4684
    tmp = build_function_call_expr (gfor_fndecl_internal_malloc, tmp);
4685
  else if (gfc_index_integer_kind == 8)
4686
    tmp = build_function_call_expr (gfor_fndecl_internal_malloc64, tmp);
4687
  else
4688
    gcc_unreachable ();
4689
  tmp = fold (convert (TREE_TYPE (gfc_conv_descriptor_data_get (src)),
4690
	      tmp));
4691
  gfc_conv_descriptor_data_set (&block, dest, tmp);
4692
4693
  /* We know the temporary and the value will be the same length,
4694
     so can use memcpy.  */
4695
  tmp = gfc_conv_descriptor_data_get (dest);
4696
  args = gfc_chainon_list (NULL_TREE, tmp);
4697
  tmp = gfc_conv_descriptor_data_get (src);
4698
  args = gfc_chainon_list (args, tmp);
4699
  args = gfc_chainon_list (args, size);
4700
  tmp = built_in_decls[BUILT_IN_MEMCPY];
4701
  tmp = build_function_call_expr (tmp, args);
4702
  gfc_add_expr_to_block (&block, tmp);
4610
  tmp = gfc_finish_block (&block);
4703
  tmp = gfc_finish_block (&block);
4611
4704
4612
  return tmp;
4705
  /* Null the destination if the source is null; otherwise do
4706
     the allocate and copy.  */
4707
  null_cond = gfc_conv_descriptor_data_get (src);
4708
  null_cond = convert (pvoid_type_node, null_cond);
4709
  null_cond = build2 (NE_EXPR, boolean_type_node, null_cond,
4710
		      null_pointer_node);
4711
  return build3_v (COND_EXPR, null_cond, tmp, null_data);
4613
}
4712
}
4614
4713
4615
4714
4616
/* NULLIFY an allocatable/pointer array on function entry, free it on exit.  */
4715
/* Recursively traverse an object of derived type, generating code to
4716
   deallocate, nullify or copy allocatable components.  This is the work horse
4717
   function for the functions named in this enum.  */
4718
4719
enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP};
4720
4721
static tree
4722
structure_alloc_comps (gfc_symbol * der_type, tree decl,
4723
		       tree dest, int rank, int purpose)
4724
{
4725
  gfc_component *c;
4726
  gfc_loopinfo loop;
4727
  stmtblock_t fnblock;
4728
  stmtblock_t loopbody;
4729
  tree tmp;
4730
  tree comp;
4731
  tree dcmp;
4732
  tree nelems;
4733
  tree index;
4734
  tree var;
4735
  tree cdecl;
4736
  tree ctype;
4737
  tree vref, dref;
4738
  tree null_cond = NULL_TREE;
4739
4740
  gfc_init_block (&fnblock);
4741
4742
  /* If this an array of derived types with allocatable components
4743
     build a loop and recursively call this function.  */
4744
  if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE
4745
	|| GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
4746
    {
4747
      tmp = gfc_conv_array_data (decl);
4748
      var = build_fold_indirect_ref (tmp);
4749
	
4750
      /* Get the number of elements - 1 and set the counter.  */
4751
      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
4752
	{
4753
	  /* Use the descriptor for an allocatable array.  Since this
4754
	     is a full array reference, we only need the descriptor
4755
	     information from dimension = rank.  */
4756
	  tmp = get_full_array_size (&fnblock, decl, rank);
4757
	  tmp = build2 (MINUS_EXPR, gfc_array_index_type,
4758
			tmp, gfc_index_one_node);
4759
4760
	  null_cond = gfc_conv_descriptor_data_get (decl);
4761
	  null_cond = build2 (NE_EXPR, boolean_type_node, null_cond,
4762
			      build_int_cst (TREE_TYPE (tmp), 0));
4763
	}
4764
      else
4765
	{
4766
	  /*  Otherwise use the TYPE_DOMAIN information.  */
4767
	  tmp =  array_type_nelts (TREE_TYPE (decl));
4768
	  tmp = fold_convert (gfc_array_index_type, tmp);
4769
	}
4770
4771
      /* Remember that this is, in fact, the no. of elements - 1.  */
4772
      nelems = gfc_evaluate_now (tmp, &fnblock);
4773
      index = gfc_create_var (gfc_array_index_type, "S");
4774
4775
      /* Build the body of the loop.  */
4776
      gfc_init_block (&loopbody);
4777
4778
      vref = gfc_build_array_ref (var, index);
4779
4780
      if (purpose == COPY_ALLOC_COMP)
4781
        {
4782
          tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank);
4783
	  gfc_add_expr_to_block (&fnblock, tmp);
4784
4785
	  tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest));
4786
	  dref = gfc_build_array_ref (tmp, index);
4787
	  tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
4788
	}
4789
      else
4790
        tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
4791
4792
      gfc_add_expr_to_block (&loopbody, tmp);
4793
4794
      /* Build the loop and return. */
4795
      gfc_init_loopinfo (&loop);
4796
      loop.dimen = 1;
4797
      loop.from[0] = gfc_index_zero_node;
4798
      loop.loopvar[0] = index;
4799
      loop.to[0] = nelems;
4800
      gfc_trans_scalarizing_loops (&loop, &loopbody);
4801
      gfc_add_block_to_block (&fnblock, &loop.pre);
4802
4803
      tmp = gfc_finish_block (&fnblock);
4804
      if (null_cond != NULL_TREE)
4805
	tmp = build3_v (COND_EXPR, null_cond, tmp, build_empty_stmt ());
4806
4807
      return tmp;
4808
    }
4809
4810
  /* Otherwise, act on the components or recursively call self to
4811
     act on a chain of components. */
4812
  for (c = der_type->components; c; c = c->next)
4813
    {
4814
      bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED)
4815
				    && c->ts.derived->attr.alloc_comp;
4816
      cdecl = c->backend_decl;
4817
      ctype = TREE_TYPE (cdecl);
4818
4819
      switch (purpose)
4820
	{
4821
	case DEALLOCATE_ALLOC_COMP:
4822
	  /* Do not deallocate the components of ultimate pointer
4823
	     components.  */
4824
	  if (cmp_has_alloc_comps && !c->pointer)
4825
	    {
4826
	      comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
4827
	      rank = c->as ? c->as->rank : 0;
4828
	      tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
4829
					   rank, purpose);
4830
	      gfc_add_expr_to_block (&fnblock, tmp);
4831
	    }
4832
4833
	  if (c->allocatable)
4834
	    {
4835
	      comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
4836
	      tmp = gfc_trans_dealloc_allocated (comp);
4837
	      gfc_add_expr_to_block (&fnblock, tmp);
4838
	    }
4839
	  break;
4840
4841
	case NULLIFY_ALLOC_COMP:
4842
	  if (c->pointer)
4843
	    continue;
4844
	  else if (c->allocatable)
4845
	    {
4846
	      comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
4847
	      gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
4848
	    }
4849
          else if (cmp_has_alloc_comps)
4850
	    {
4851
	      comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
4852
	      rank = c->as ? c->as->rank : 0;
4853
	      tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
4854
					   rank, purpose);
4855
	      gfc_add_expr_to_block (&fnblock, tmp);
4856
	    }
4857
	  break;
4858
4859
	case COPY_ALLOC_COMP:
4860
	  if (c->pointer)
4861
	    continue;
4862
4863
	  /* We need source and destination components.  */
4864
	  comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
4865
	  dcmp = build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
4866
	  dcmp = fold_convert (TREE_TYPE (comp), dcmp);
4867
4868
	  if (c->allocatable && !cmp_has_alloc_comps)
4869
	    {
4870
	      tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, c->as->rank);
4871
	      gfc_add_expr_to_block (&fnblock, tmp);
4872
	    }
4873
4874
          if (cmp_has_alloc_comps)
4875
	    {
4876
	      rank = c->as ? c->as->rank : 0;
4877
	      tmp = fold_convert (TREE_TYPE (dcmp), comp);
4878
	      gfc_add_modify_expr (&fnblock, dcmp, tmp);
4879
	      tmp = structure_alloc_comps (c->ts.derived, comp, dcmp,
4880
					   rank, purpose);
4881
	      gfc_add_expr_to_block (&fnblock, tmp);
4882
	    }
4883
	  break;
4884
4885
	default:
4886
	  gcc_unreachable ();
4887
	  break;
4888
	}
4889
    }
4890
4891
  return gfc_finish_block (&fnblock);
4892
}
4893
4894
/* Recursively traverse an object of derived type, generating code to
4895
   nullify allocatable components.  */
4896
4897
tree
4898
gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
4899
{
4900
  return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
4901
				NULLIFY_ALLOC_COMP);
4902
}
4903
4904
4905
/* Recursively traverse an object of derived type, generating code to
4906
   deallocate allocatable components.  */
4907
4908
tree
4909
gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
4910
{
4911
  return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
4912
				DEALLOCATE_ALLOC_COMP);
4913
}
4914
4915
4916
/* Recursively traverse an object of derived type, generating code to
4917
   copy its allocatable components.  */
4918
4919
tree
4920
gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
4921
{
4922
  return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
4923
}
4924
4925
4926
/* NULLIFY an allocatable/pointer array on function entry, free it on exit.
4927
   Do likewise, recursively if necessary, with the allocatable components of
4928
   derived types.  */
4617
4929
4618
tree
4930
tree
4619
gfc_trans_deferred_array (gfc_symbol * sym, tree body)
4931
gfc_trans_deferred_array (gfc_symbol * sym, tree body)
Lines 4623-4638 Link Here
4623
  tree descriptor;
4935
  tree descriptor;
4624
  stmtblock_t fnblock;
4936
  stmtblock_t fnblock;
4625
  locus loc;
4937
  locus loc;
4938
  int rank;
4939
  bool sym_has_alloc_comp;
4940
4941
  sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
4942
			  && sym->ts.derived->attr.alloc_comp;
4626
4943
4627
  /* Make sure the frontend gets these right.  */
4944
  /* Make sure the frontend gets these right.  */
4628
  if (!(sym->attr.pointer || sym->attr.allocatable))
4945
  if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
4629
    fatal_error
4946
    fatal_error ("Possible frontend bug: Deferred array size without pointer, "
4630
      ("Possible frontend bug: Deferred array size without pointer or allocatable attribute.");
4947
		 "allocatable attribute or derived type without allocatable "
4948
		 "components.");
4631
4949
4632
  gfc_init_block (&fnblock);
4950
  gfc_init_block (&fnblock);
4633
4951
4634
  gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
4952
  gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
4635
                || TREE_CODE (sym->backend_decl) == PARM_DECL);
4953
		|| TREE_CODE (sym->backend_decl) == PARM_DECL);
4636
4954
4637
  if (sym->ts.type == BT_CHARACTER
4955
  if (sym->ts.type == BT_CHARACTER
4638
      && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4956
      && !INTEGER_CST_P (sym->ts.cl->backend_decl))
Lines 4653-4659 Link Here
4653
  gfc_set_backend_locus (&sym->declared_at);
4971
  gfc_set_backend_locus (&sym->declared_at);
4654
  descriptor = sym->backend_decl;
4972
  descriptor = sym->backend_decl;
4655
4973
4656
  if (TREE_STATIC (descriptor))
4974
  /* Although static, derived types with deafult initializers and
4975
     allocatable components must not be nulled wholesale; instead they
4976
     are treated component by component.  */
4977
  if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
4657
    {
4978
    {
4658
      /* SAVEd variables are not freed on exit.  */
4979
      /* SAVEd variables are not freed on exit.  */
4659
      gfc_trans_static_array_pointer (sym);
4980
      gfc_trans_static_array_pointer (sym);
Lines 4662-4683 Link Here
4662
4983
4663
  /* Get the descriptor type.  */
4984
  /* Get the descriptor type.  */
4664
  type = TREE_TYPE (sym->backend_decl);
4985
  type = TREE_TYPE (sym->backend_decl);
4665
  if (!GFC_DESCRIPTOR_TYPE_P (type))
4986
    
4987
  if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
4988
    {
4989
      rank = sym->as ? sym->as->rank : 0;
4990
      tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank);
4991
      gfc_add_expr_to_block (&fnblock, tmp);
4992
    }
4993
  else if (!GFC_DESCRIPTOR_TYPE_P (type))
4666
    {
4994
    {
4667
      /* If the backend_decl is not a descriptor, we must have a pointer
4995
      /* If the backend_decl is not a descriptor, we must have a pointer
4668
	 to one.  */
4996
	 to one.  */
4669
      descriptor = build_fold_indirect_ref (sym->backend_decl);
4997
      descriptor = build_fold_indirect_ref (sym->backend_decl);
4670
      type = TREE_TYPE (descriptor);
4998
      type = TREE_TYPE (descriptor);
4671
      gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
4672
    }
4999
    }
4673
5000
  
4674
  /* NULLIFY the data pointer.  */
5001
  /* NULLIFY the data pointer.  */
4675
  gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
5002
  if (GFC_DESCRIPTOR_TYPE_P (type))
5003
    gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
4676
5004
4677
  gfc_add_expr_to_block (&fnblock, body);
5005
  gfc_add_expr_to_block (&fnblock, body);
4678
5006
4679
  gfc_set_backend_locus (&loc);
5007
  gfc_set_backend_locus (&loc);
4680
  /* Allocatable arrays need to be freed when they go out of scope.  */
5008
5009
  /* Allocatable arrays need to be freed when they go out of scope.
5010
     The allocatable components of pointers must not be touched.  */
5011
  if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
5012
      && !sym->attr.pointer)
5013
    {
5014
      int rank;
5015
      rank = sym->as ? sym->as->rank : 0;
5016
      tmp = gfc_deallocate_alloc_comp (sym->ts.derived, descriptor, rank);
5017
      gfc_add_expr_to_block (&fnblock, tmp);
5018
    }
5019
4681
  if (sym->attr.allocatable)
5020
  if (sym->attr.allocatable)
4682
    {
5021
    {
4683
      tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
5022
      tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
(-)gcc/fortran/trans-expr.c (-16 / +184 lines)
Lines 1701-1707 Link Here
1701
1701
1702
  if (intent != INTENT_OUT)
1702
  if (intent != INTENT_OUT)
1703
    {
1703
    {
1704
      tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
1704
      tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
1705
      gfc_add_expr_to_block (&body, tmp);
1705
      gfc_add_expr_to_block (&body, tmp);
1706
      gcc_assert (rse.ss == gfc_ss_terminator);
1706
      gcc_assert (rse.ss == gfc_ss_terminator);
1707
      gfc_trans_scalarizing_loops (&loop, &body);
1707
      gfc_trans_scalarizing_loops (&loop, &body);
Lines 1792-1798 Link Here
1792
1792
1793
  gcc_assert (lse.ss == gfc_ss_terminator);
1793
  gcc_assert (lse.ss == gfc_ss_terminator);
1794
1794
1795
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
1795
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
1796
  gfc_add_expr_to_block (&body, tmp);
1796
  gfc_add_expr_to_block (&body, tmp);
1797
  
1797
  
1798
  /* Generate the copying loops.  */
1798
  /* Generate the copying loops.  */
Lines 1864-1869 Link Here
1864
  gfc_ss *argss;
1864
  gfc_ss *argss;
1865
  gfc_ss_info *info;
1865
  gfc_ss_info *info;
1866
  int byref;
1866
  int byref;
1867
  int parm_kind;
1867
  tree type;
1868
  tree type;
1868
  tree var;
1869
  tree var;
1869
  tree len;
1870
  tree len;
Lines 1877-1882 Link Here
1877
  gfc_expr *e;
1878
  gfc_expr *e;
1878
  gfc_symbol *fsym;
1879
  gfc_symbol *fsym;
1879
  stmtblock_t post;
1880
  stmtblock_t post;
1881
  enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
1880
1882
1881
  arglist = NULL_TREE;
1883
  arglist = NULL_TREE;
1882
  retargs = NULL_TREE;
1884
  retargs = NULL_TREE;
Lines 1919-1924 Link Here
1919
    {
1921
    {
1920
      e = arg->expr;
1922
      e = arg->expr;
1921
      fsym = formal ? formal->sym : NULL;
1923
      fsym = formal ? formal->sym : NULL;
1924
      parm_kind = MISSING;
1922
      if (e == NULL)
1925
      if (e == NULL)
1923
	{
1926
	{
1924
1927
Lines 1947-1952 Link Here
1947
	  /* An elemental function inside a scalarized loop.  */
1950
	  /* An elemental function inside a scalarized loop.  */
1948
          gfc_init_se (&parmse, se);
1951
          gfc_init_se (&parmse, se);
1949
          gfc_conv_expr_reference (&parmse, e);
1952
          gfc_conv_expr_reference (&parmse, e);
1953
	  parm_kind = ELEMENTAL;
1950
	}
1954
	}
1951
      else
1955
      else
1952
	{
1956
	{
Lines 1957-1968 Link Here
1957
	  if (argss == gfc_ss_terminator)
1961
	  if (argss == gfc_ss_terminator)
1958
            {
1962
            {
1959
	      gfc_conv_expr_reference (&parmse, e);
1963
	      gfc_conv_expr_reference (&parmse, e);
1964
	      parm_kind = SCALAR;
1960
              if (fsym && fsym->attr.pointer
1965
              if (fsym && fsym->attr.pointer
1961
		  && e->expr_type != EXPR_NULL)
1966
		  && e->expr_type != EXPR_NULL)
1962
                {
1967
                {
1963
                  /* Scalar pointer dummy args require an extra level of
1968
                  /* Scalar pointer dummy args require an extra level of
1964
		  indirection. The null pointer already contains
1969
		  indirection. The null pointer already contains
1965
		  this level of indirection.  */
1970
		  this level of indirection.  */
1971
		  parm_kind = SCALAR_POINTER;
1966
                  parmse.expr = build_fold_addr_expr (parmse.expr);
1972
                  parmse.expr = build_fold_addr_expr (parmse.expr);
1967
                }
1973
                }
1968
            }
1974
            }
Lines 2039-2044 Link Here
2039
	  parmse.string_length = e->symtree->n.sym->ts.cl->backend_decl;
2045
	  parmse.string_length = e->symtree->n.sym->ts.cl->backend_decl;
2040
	}
2046
	}
2041
2047
2048
      /* Allocated allocatable components of derived types must be
2049
	 deallocated for INTENT(OUT) dummy arguments and non-variable
2050
         scalars.  Non-variable arrays are dealt with in trans-array.c
2051
         (gfc_conv_array_parameter).  */
2052
      if (e && e->ts.type == BT_DERIVED
2053
	    && e->ts.derived->attr.alloc_comp
2054
	    && ((formal && formal->sym->attr.intent == INTENT_OUT)
2055
		   ||
2056
		(e->expr_type != EXPR_VARIABLE && !e->rank)))
2057
        {
2058
	  int parm_rank;
2059
	  tmp = build_fold_indirect_ref (parmse.expr);
2060
	  parm_rank = e->rank;
2061
	  switch (parm_kind)
2062
	    {
2063
	    case (ELEMENTAL):
2064
	    case (SCALAR):
2065
	      parm_rank = 0;
2066
	      break;
2067
2068
	    case (SCALAR_POINTER):
2069
              tmp = build_fold_indirect_ref (tmp);
2070
	      break;
2071
	    case (ARRAY):
2072
              tmp = parmse.expr;
2073
	      break;
2074
	    }
2075
2076
          tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
2077
	  if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
2078
	    tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym),
2079
			    tmp, build_empty_stmt ());
2080
2081
	  if (e->expr_type != EXPR_VARIABLE)
2082
	    /* Don't deallocate non-variables until they have been used.  */
2083
	    gfc_add_expr_to_block (&se->post, tmp);
2084
	  else 
2085
	    {
2086
	      gcc_assert (formal && formal->sym->attr.intent == INTENT_OUT);
2087
	      gfc_add_expr_to_block (&se->pre, tmp);
2088
	    }
2089
        }
2090
2042
      /* Character strings are passed as two parameters, a length and a
2091
      /* Character strings are passed as two parameters, a length and a
2043
         pointer.  */
2092
         pointer.  */
2044
      if (parmse.string_length != NULL_TREE)
2093
      if (parmse.string_length != NULL_TREE)
Lines 2625-2631 Link Here
2625
2674
2626
  gfc_conv_expr (&rse, expr);
2675
  gfc_conv_expr (&rse, expr);
2627
2676
2628
  tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
2677
  tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
2629
  gfc_add_expr_to_block (&body, tmp);
2678
  gfc_add_expr_to_block (&body, tmp);
2630
2679
2631
  gcc_assert (rse.ss == gfc_ss_terminator);
2680
  gcc_assert (rse.ss == gfc_ss_terminator);
Lines 2646-2662 Link Here
2646
  return gfc_finish_block (&block);
2695
  return gfc_finish_block (&block);
2647
}
2696
}
2648
2697
2698
2649
/* Assign a single component of a derived type constructor.  */
2699
/* Assign a single component of a derived type constructor.  */
2650
2700
2651
static tree
2701
static tree
2652
gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2702
gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2653
{
2703
{
2654
  gfc_se se;
2704
  gfc_se se;
2705
  gfc_se lse;
2655
  gfc_ss *rss;
2706
  gfc_ss *rss;
2656
  stmtblock_t block;
2707
  stmtblock_t block;
2657
  tree tmp;
2708
  tree tmp;
2709
  tree offset;
2710
  int n;
2658
2711
2659
  gfc_start_block (&block);
2712
  gfc_start_block (&block);
2713
2660
  if (cm->pointer)
2714
  if (cm->pointer)
2661
    {
2715
    {
2662
      gfc_init_se (&se, NULL);
2716
      gfc_init_se (&se, NULL);
Lines 2689-2696 Link Here
2689
    }
2743
    }
2690
  else if (cm->dimension)
2744
  else if (cm->dimension)
2691
    {
2745
    {
2692
      tmp = gfc_trans_subarray_assign (dest, cm, expr);
2746
      if (cm->allocatable && expr->expr_type == EXPR_NULL)
2693
      gfc_add_expr_to_block (&block, tmp);
2747
 	gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
2748
      else if (cm->allocatable)
2749
        {
2750
          tree tmp2;
2751
2752
          gfc_init_se (&se, NULL);
2753
 
2754
	  rss = gfc_walk_expr (expr);
2755
          se.want_pointer = 0;
2756
          gfc_conv_expr_descriptor (&se, expr, rss);
2757
	  gfc_add_block_to_block (&block, &se.pre);
2758
2759
	  tmp = fold_convert (TREE_TYPE (dest), se.expr);
2760
	  gfc_add_modify_expr (&block, dest, tmp);
2761
2762
          if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
2763
	    tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest,
2764
				       cm->as->rank);
2765
	  else
2766
            tmp = gfc_duplicate_allocatable (dest, se.expr,
2767
					     TREE_TYPE(cm->backend_decl),
2768
					     cm->as->rank);
2769
2770
          gfc_add_expr_to_block (&block, tmp);
2771
2772
          gfc_add_block_to_block (&block, &se.post);
2773
          gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
2774
2775
          /* Shift the lbound and ubound of temporaries to being unity, rather
2776
             than zero, based.  Calculate the offset for all cases.  */
2777
          offset = gfc_conv_descriptor_offset (dest);
2778
          gfc_add_modify_expr (&block, offset, gfc_index_zero_node);
2779
          tmp2 =gfc_create_var (gfc_array_index_type, NULL);
2780
          for (n = 0; n < expr->rank; n++)
2781
            {
2782
              if (expr->expr_type != EXPR_VARIABLE
2783
                  && expr->expr_type != EXPR_CONSTANT)
2784
                {
2785
                  tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
2786
                  gfc_add_modify_expr (&block, tmp,
2787
                                       fold_build2 (PLUS_EXPR,
2788
				      		    gfc_array_index_type,
2789
                                                    tmp, gfc_index_one_node));
2790
                  tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
2791
                  gfc_add_modify_expr (&block, tmp, gfc_index_one_node);
2792
                }
2793
              tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2794
                                 gfc_conv_descriptor_lbound (dest,
2795
							     gfc_rank_cst[n]),
2796
                                 gfc_conv_descriptor_stride (dest,
2797
							     gfc_rank_cst[n]));
2798
              gfc_add_modify_expr (&block, tmp2, tmp);
2799
              tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
2800
              gfc_add_modify_expr (&block, offset, tmp);
2801
            }
2802
        }
2803
      else
2804
        {
2805
	  tmp = gfc_trans_subarray_assign (dest, cm, expr);
2806
	  gfc_add_expr_to_block (&block, tmp);
2807
        }
2694
    }
2808
    }
2695
  else if (expr->ts.type == BT_DERIVED)
2809
  else if (expr->ts.type == BT_DERIVED)
2696
    {
2810
    {
Lines 2711-2718 Link Here
2711
  else
2825
  else
2712
    {
2826
    {
2713
      /* Scalar component.  */
2827
      /* Scalar component.  */
2714
      gfc_se lse;
2715
2716
      gfc_init_se (&se, NULL);
2828
      gfc_init_se (&se, NULL);
2717
      gfc_init_se (&lse, NULL);
2829
      gfc_init_se (&lse, NULL);
2718
2830
Lines 2720-2726 Link Here
2720
      if (cm->ts.type == BT_CHARACTER)
2832
      if (cm->ts.type == BT_CHARACTER)
2721
	lse.string_length = cm->ts.cl->backend_decl;
2833
	lse.string_length = cm->ts.cl->backend_decl;
2722
      lse.expr = dest;
2834
      lse.expr = dest;
2723
      tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type);
2835
      tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
2724
      gfc_add_expr_to_block (&block, tmp);
2836
      gfc_add_expr_to_block (&block, tmp);
2725
    }
2837
    }
2726
  return gfc_finish_block (&block);
2838
  return gfc_finish_block (&block);
Lines 2780-2791 Link Here
2780
    }
2892
    }
2781
2893
2782
  cm = expr->ts.derived->components;
2894
  cm = expr->ts.derived->components;
2895
2783
  for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
2896
  for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
2784
    {
2897
    {
2785
      /* Skip absent members in default initializers.  */
2898
      /* Skip absent members in default initializers and allocatable
2899
	 components.  */
2786
      if (!c->expr)
2900
      if (!c->expr)
2787
        continue;
2901
        continue;
2788
2902
2903
      gcc_assert (!cm->allocatable);
2904
2789
      val = gfc_conv_initializer (c->expr, &cm->ts,
2905
      val = gfc_conv_initializer (c->expr, &cm->ts,
2790
	  TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
2906
	  TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
2791
2907
Lines 3078-3093 Link Here
3078
3194
3079
3195
3080
/* Generate code for assignment of scalar variables.  Includes character
3196
/* Generate code for assignment of scalar variables.  Includes character
3081
   strings.  */
3197
   strings and derived types with allocatable components.  */
3082
3198
3083
tree
3199
tree
3084
gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
3200
gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
3201
			 bool l_is_temp, bool r_is_var)
3085
{
3202
{
3086
  stmtblock_t block;
3203
  stmtblock_t block;
3204
  tree tmp;
3205
  tree cond;
3087
3206
3088
  gfc_init_block (&block);
3207
  gfc_init_block (&block);
3089
3208
3090
  if (type == BT_CHARACTER)
3209
  if (ts.type == BT_CHARACTER)
3091
    {
3210
    {
3092
      gcc_assert (lse->string_length != NULL_TREE
3211
      gcc_assert (lse->string_length != NULL_TREE
3093
	      && rse->string_length != NULL_TREE);
3212
	      && rse->string_length != NULL_TREE);
Lines 3101-3106 Link Here
3101
      gfc_trans_string_copy (&block, lse->string_length, lse->expr,
3220
      gfc_trans_string_copy (&block, lse->string_length, lse->expr,
3102
			     rse->string_length, rse->expr);
3221
			     rse->string_length, rse->expr);
3103
    }
3222
    }
3223
  else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
3224
    {
3225
      cond = NULL_TREE;
3226
	
3227
      /* Are the rhs and the lhs the same?  */
3228
      if (r_is_var)
3229
	{
3230
	  cond = fold_build2 (EQ_EXPR, boolean_type_node,
3231
			      build_fold_addr_expr (lse->expr),
3232
			      build_fold_addr_expr (rse->expr));
3233
	  cond = gfc_evaluate_now (cond, &lse->pre);
3234
	}
3235
3236
      /* Deallocate the lhs allocated components as long as it is not
3237
	 the same as the rhs.  */
3238
      if (!l_is_temp)
3239
	{
3240
	  tmp = gfc_deallocate_alloc_comp (ts.derived, lse->expr, 0);
3241
	  if (r_is_var)
3242
	    tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
3243
	  gfc_add_expr_to_block (&lse->pre, tmp);
3244
	}
3245
	
3246
      gfc_add_block_to_block (&block, &lse->pre);
3247
      gfc_add_block_to_block (&block, &rse->pre);
3248
3249
      gfc_add_modify_expr (&block, lse->expr,
3250
			   fold_convert (TREE_TYPE (lse->expr), rse->expr));
3251
3252
      /* Do a deep copy if the rhs is a variable, if it is not the
3253
	 same as the lhs.  Otherwise, nullify the data fields so that the
3254
	 lhs retains the allocated resources.  */
3255
      if (r_is_var)
3256
	{
3257
	  tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
3258
	  tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
3259
	  gfc_add_expr_to_block (&block, tmp);
3260
	}
3261
      else
3262
	{
3263
	  tmp = gfc_nullify_alloc_comp (ts.derived, rse->expr, 0);
3264
	  gfc_add_expr_to_block (&block, tmp);
3265
	}
3266
    }
3104
  else
3267
  else
3105
    {
3268
    {
3106
      gfc_add_block_to_block (&block, &lse->pre);
3269
      gfc_add_block_to_block (&block, &lse->pre);
Lines 3206-3211 Link Here
3206
  tree tmp;
3369
  tree tmp;
3207
  stmtblock_t block;
3370
  stmtblock_t block;
3208
  stmtblock_t body;
3371
  stmtblock_t body;
3372
  bool l_is_temp;
3209
3373
3210
  /* Special case a single function returning an array.  */
3374
  /* Special case a single function returning an array.  */
3211
  if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
3375
  if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
Lines 3284-3293 Link Here
3284
  else
3448
  else
3285
    gfc_init_block (&body);
3449
    gfc_init_block (&body);
3286
3450
3451
  l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
3452
3287
  /* Translate the expression.  */
3453
  /* Translate the expression.  */
3288
  gfc_conv_expr (&rse, expr2);
3454
  gfc_conv_expr (&rse, expr2);
3289
3455
3290
  if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
3456
  if (l_is_temp)
3291
    {
3457
    {
3292
      gfc_conv_tmp_array_ref (&lse);
3458
      gfc_conv_tmp_array_ref (&lse);
3293
      gfc_advance_se_ss_chain (&lse);
3459
      gfc_advance_se_ss_chain (&lse);
Lines 3295-3301 Link Here
3295
  else
3461
  else
3296
    gfc_conv_expr (&lse, expr1);
3462
    gfc_conv_expr (&lse, expr1);
3297
3463
3298
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
3464
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, l_is_temp,
3465
				 expr2->expr_type == EXPR_VARIABLE);
3299
  gfc_add_expr_to_block (&body, tmp);
3466
  gfc_add_expr_to_block (&body, tmp);
3300
3467
3301
  if (lss == gfc_ss_terminator)
3468
  if (lss == gfc_ss_terminator)
Lines 3308-3314 Link Here
3308
      gcc_assert (lse.ss == gfc_ss_terminator
3475
      gcc_assert (lse.ss == gfc_ss_terminator
3309
		  && rse.ss == gfc_ss_terminator);
3476
		  && rse.ss == gfc_ss_terminator);
3310
3477
3311
      if (loop.temp_ss != NULL)
3478
      if (l_is_temp)
3312
	{
3479
	{
3313
	  gfc_trans_scalarized_loop_boundary (&loop, &body);
3480
	  gfc_trans_scalarized_loop_boundary (&loop, &body);
3314
3481
Lines 3328-3336 Link Here
3328
	  gcc_assert (lse.ss == gfc_ss_terminator
3495
	  gcc_assert (lse.ss == gfc_ss_terminator
3329
		      && rse.ss == gfc_ss_terminator);
3496
		      && rse.ss == gfc_ss_terminator);
3330
3497
3331
	  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
3498
	  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false);
3332
	  gfc_add_expr_to_block (&body, tmp);
3499
	  gfc_add_expr_to_block (&body, tmp);
3333
	}
3500
	}
3501
3334
      /* Generate the copying loops.  */
3502
      /* Generate the copying loops.  */
3335
      gfc_trans_scalarizing_loops (&loop, &body);
3503
      gfc_trans_scalarizing_loops (&loop, &body);
3336
3504
(-)gcc/fortran/symbol.c (+2 lines)
Lines 1523-1528 Link Here
1523
1523
1524
  c->dimension = attr->dimension;
1524
  c->dimension = attr->dimension;
1525
  c->pointer = attr->pointer;
1525
  c->pointer = attr->pointer;
1526
  c->allocatable = attr->allocatable;
1526
}
1527
}
1527
1528
1528
1529
Lines 1536-1541 Link Here
1536
  gfc_clear_attr (attr);
1537
  gfc_clear_attr (attr);
1537
  attr->dimension = c->dimension;
1538
  attr->dimension = c->dimension;
1538
  attr->pointer = c->pointer;
1539
  attr->pointer = c->pointer;
1540
  attr->allocatable = c->allocatable;
1539
}
1541
}
1540
1542
1541
1543
(-)gcc/fortran/intrinsic.h (+1 lines)
Lines 153-158 Link Here
153
try gfc_check_fstat_sub (gfc_expr *, gfc_expr *, gfc_expr *);
153
try gfc_check_fstat_sub (gfc_expr *, gfc_expr *, gfc_expr *);
154
try gfc_check_gerror (gfc_expr *);
154
try gfc_check_gerror (gfc_expr *);
155
try gfc_check_getlog (gfc_expr *);
155
try gfc_check_getlog (gfc_expr *);
156
try gfc_check_move_alloc (gfc_expr *, gfc_expr *);
156
try gfc_check_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
157
try gfc_check_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
157
		      gfc_expr *);
158
		      gfc_expr *);
158
try gfc_check_random_number (gfc_expr *);
159
try gfc_check_random_number (gfc_expr *);
(-)gcc/fortran/decl.c (-10 / +50 lines)
Lines 962-975 Link Here
962
962
963
  /* Check array components.  */
963
  /* Check array components.  */
964
  if (!c->dimension)
964
  if (!c->dimension)
965
    return SUCCESS;
965
    {
966
      if (c->allocatable)
967
	{
968
	  gfc_error ("Allocatable component at %C must be an array");
969
	  return FAILURE;
970
	}
971
      else
972
	return SUCCESS;
973
    }
966
974
967
  if (c->pointer)
975
  if (c->pointer)
968
    {
976
    {
969
      if (c->as->type != AS_DEFERRED)
977
      if (c->as->type != AS_DEFERRED)
970
	{
978
	{
971
	  gfc_error ("Pointer array component of structure at %C "
979
	  gfc_error ("Pointer array component of structure at %C must have a "
972
		     "must have a deferred shape");
980
		     "deferred shape");
981
	  return FAILURE;
982
	}
983
    }
984
  else if (c->allocatable)
985
    {
986
      if (c->as->type != AS_DEFERRED)
987
	{
988
	  gfc_error ("Allocatable component of structure at %C must have a "
989
		     "deferred shape");
973
	  return FAILURE;
990
	  return FAILURE;
974
	}
991
	}
975
    }
992
    }
Lines 1284-1289 Link Here
1284
	}
1301
	}
1285
    }
1302
    }
1286
1303
1304
  if (initializer != NULL && current_attr.allocatable
1305
	&& gfc_current_state () == COMP_DERIVED)
1306
    {
1307
      gfc_error ("Initialization of allocatable component at %C is not allowed");
1308
      m = MATCH_ERROR;
1309
      goto cleanup;
1310
    }
1311
1287
  /* Check if we are parsing an enumeration and if the current enumerator
1312
  /* Check if we are parsing an enumeration and if the current enumerator
1288
     variable has an initializer or not. If it does not have an
1313
     variable has an initializer or not. If it does not have an
1289
     initializer, the initialization value of the previous enumerator 
1314
     initializer, the initialization value of the previous enumerator 
Lines 1315-1322 Link Here
1315
    t = add_init_expr_to_sym (name, &initializer, &var_locus);
1340
    t = add_init_expr_to_sym (name, &initializer, &var_locus);
1316
  else
1341
  else
1317
    {
1342
    {
1318
      if (current_ts.type == BT_DERIVED && !current_attr.pointer
1343
      if (current_ts.type == BT_DERIVED
1319
	  && !initializer)
1344
	    && !current_attr.pointer
1345
	    && !current_attr.allocatable
1346
	    && !initializer)
1320
	initializer = gfc_default_initializer (&current_ts);
1347
	initializer = gfc_default_initializer (&current_ts);
1321
      t = build_struct (name, cl, &initializer, &as);
1348
      t = build_struct (name, cl, &initializer, &as);
1322
    }
1349
    }
Lines 2141-2151 Link Here
2141
	  && d != DECL_DIMENSION && d != DECL_POINTER
2168
	  && d != DECL_DIMENSION && d != DECL_POINTER
2142
	  && d != DECL_COLON && d != DECL_NONE)
2169
	  && d != DECL_COLON && d != DECL_NONE)
2143
	{
2170
	{
2144
2171
	  if (d == DECL_ALLOCATABLE)
2145
	  gfc_error ("Attribute at %L is not allowed in a TYPE definition",
2172
	    {
2146
		     &seen_at[d]);
2173
	      if (gfc_notify_std (GFC_STD_F2003, 
2147
	  m = MATCH_ERROR;
2174
				   "In the selected standard, the ALLOCATABLE "
2148
	  goto cleanup;
2175
				   "attribute at %C is not allowed in a TYPE "
2176
				   "definition") == FAILURE)         
2177
		{
2178
		  m = MATCH_ERROR;
2179
		  goto cleanup;
2180
		}
2181
            }
2182
          else
2183
	    {
2184
	      gfc_error ("Attribute at %L is not allowed in a TYPE definition",
2185
			  &seen_at[d]);
2186
	      m = MATCH_ERROR;
2187
	      goto cleanup;
2188
	    }
2149
	}
2189
	}
2150
2190
2151
      if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
2191
      if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
(-)gcc/fortran/trans-array.h (+9 lines)
Lines 43-48 Link Here
43
tree gfc_trans_g77_array (gfc_symbol *, tree);
43
tree gfc_trans_g77_array (gfc_symbol *, tree);
44
/* Generate code to deallocate an array, if it is allocated.  */
44
/* Generate code to deallocate an array, if it is allocated.  */
45
tree gfc_trans_dealloc_allocated (tree);
45
tree gfc_trans_dealloc_allocated (tree);
46
47
tree gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank);
48
49
tree gfc_nullify_alloc_comp (gfc_symbol *, tree, int);
50
51
tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int);
52
53
tree gfc_copy_alloc_comp (gfc_symbol *, tree, tree, int);
54
46
/* Add initialization for deferred arrays.  */
55
/* Add initialization for deferred arrays.  */
47
tree gfc_trans_deferred_array (gfc_symbol *, tree);
56
tree gfc_trans_deferred_array (gfc_symbol *, tree);
48
/* Generate an initializer for a static pointer or allocatable array.  */
57
/* Generate an initializer for a static pointer or allocatable array.  */
(-)gcc/fortran/gfortran.texi (-3 / +7 lines)
Lines 1370-1376 Link Here
1370
@itemize
1370
@itemize
1371
@item 
1371
@item 
1372
Intrinsics @code{command_argument_count}, @code{get_command},
1372
Intrinsics @code{command_argument_count}, @code{get_command},
1373
@code{get_command_argument}, and @code{get_environment_variable}.
1373
@code{get_command_argument}, @code{get_environment_variable}, and
1374
@code{move_alloc}.
1374
1375
1375
@item 
1376
@item 
1376
@cindex Array constructors
1377
@cindex Array constructors
Lines 1397-1410 Link Here
1397
1398
1398
@item
1399
@item
1399
@cindex TR 15581
1400
@cindex TR 15581
1400
The following parts of TR 15581:
1401
TR 15581:
1401
@itemize
1402
@itemize
1402
@item
1403
@item
1403
@cindex @code{ALLOCATABLE} dummy arguments
1404
@cindex @code{ALLOCATABLE} dummy arguments
1404
The @code{ALLOCATABLE} attribute for dummy arguments.
1405
@code{ALLOCATABLE} dummy arguments.
1405
@item
1406
@item
1406
@cindex @code{ALLOCATABLE} function results
1407
@cindex @code{ALLOCATABLE} function results
1407
@code{ALLOCATABLE} function results
1408
@code{ALLOCATABLE} function results
1409
@item
1410
@cindex @code{ALLOCATABLE} components of derived types
1411
@code{ALLOCATABLE} components of derived types
1408
@end itemize
1412
@end itemize
1409
1413
1410
@item
1414
@item
(-)gcc/fortran/gfortran.h (-1 / +5 lines)
Lines 532-537 Link Here
532
  /* Special attributes for Cray pointers, pointees.  */
532
  /* Special attributes for Cray pointers, pointees.  */
533
  unsigned cray_pointer:1, cray_pointee:1;
533
  unsigned cray_pointer:1, cray_pointee:1;
534
534
535
  /* The symbol is a derived type with allocatable components, possibly nested.
536
   */
537
  unsigned alloc_comp:1;
535
}
538
}
536
symbol_attribute;
539
symbol_attribute;
537
540
Lines 649-655 Link Here
649
  const char *name;
652
  const char *name;
650
  gfc_typespec ts;
653
  gfc_typespec ts;
651
654
652
  int pointer, dimension;
655
  int pointer, allocatable, dimension;
653
  gfc_array_spec *as;
656
  gfc_array_spec *as;
654
657
655
  tree backend_decl;
658
  tree backend_decl;
Lines 1969-1974 Link Here
1969
void gfc_free_actual_arglist (gfc_actual_arglist *);
1972
void gfc_free_actual_arglist (gfc_actual_arglist *);
1970
gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *);
1973
gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *);
1971
const char *gfc_extract_int (gfc_expr *, int *);
1974
const char *gfc_extract_int (gfc_expr *, int *);
1975
gfc_expr *gfc_expr_to_initialize (gfc_expr *);
1972
1976
1973
gfc_expr *gfc_build_conversion (gfc_expr *);
1977
gfc_expr *gfc_build_conversion (gfc_expr *);
1974
void gfc_free_ref_list (gfc_ref *);
1978
void gfc_free_ref_list (gfc_ref *);
(-)gcc/fortran/trans-stmt.c (-6 / +38 lines)
Lines 1802-1808 Link Here
1802
      gfc_conv_expr (&lse, expr);
1802
      gfc_conv_expr (&lse, expr);
1803
1803
1804
      /* Use the scalar assignment.  */
1804
      /* Use the scalar assignment.  */
1805
      tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
1805
      rse.string_length = lse.string_length;
1806
      tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
1806
1807
1807
      /* Form the mask expression according to the mask tree list.  */
1808
      /* Form the mask expression according to the mask tree list.  */
1808
      if (wheremask)
1809
      if (wheremask)
Lines 1897-1903 Link Here
1897
    }
1898
    }
1898
1899
1899
  /* Use the scalar assignment.  */
1900
  /* Use the scalar assignment.  */
1900
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts.type);
1901
  lse.string_length = rse.string_length;
1902
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts, true,
1903
				 expr2->expr_type == EXPR_VARIABLE);
1901
1904
1902
  /* Form the mask expression according to the mask tree list.  */
1905
  /* Form the mask expression according to the mask tree list.  */
1903
  if (wheremask)
1906
  if (wheremask)
Lines 2978-2984 Link Here
2978
    maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr);
2981
    maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr);
2979
2982
2980
  /* Use the scalar assignment as is.  */
2983
  /* Use the scalar assignment as is.  */
2981
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2984
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
2985
				 loop.temp_ss != NULL, false);
2982
  tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
2986
  tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
2983
2987
2984
  gfc_add_expr_to_block (&body, tmp);
2988
  gfc_add_expr_to_block (&body, tmp);
Lines 3031-3037 Link Here
3031
				    maskexpr);
3035
				    maskexpr);
3032
3036
3033
          /* Use the scalar assignment as is.  */
3037
          /* Use the scalar assignment as is.  */
3034
          tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
3038
          tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false);
3035
          tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
3039
          tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
3036
          gfc_add_expr_to_block (&body, tmp);
3040
          gfc_add_expr_to_block (&body, tmp);
3037
3041
Lines 3406-3413 Link Here
3406
        gfc_conv_expr (&edse, edst);
3410
        gfc_conv_expr (&edse, edst);
3407
    }
3411
    }
3408
3412
3409
  tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts.type);
3413
  tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, false);
3410
  estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts.type)
3414
  estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts, false, false)
3411
		 : build_empty_stmt ();
3415
		 : build_empty_stmt ();
3412
  tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
3416
  tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
3413
  gfc_add_expr_to_block (&body, tmp);
3417
  gfc_add_expr_to_block (&body, tmp);
Lines 3591-3596 Link Here
3591
				 parm, tmp, build_empty_stmt ());
3595
				 parm, tmp, build_empty_stmt ());
3592
	      gfc_add_expr_to_block (&se.pre, tmp);
3596
	      gfc_add_expr_to_block (&se.pre, tmp);
3593
	    }
3597
	    }
3598
3599
	  if (expr->ts.type == BT_DERIVED && expr->ts.derived->attr.alloc_comp)
3600
	    {
3601
	      tmp = build_fold_indirect_ref (se.expr);
3602
	      tmp = gfc_nullify_alloc_comp (expr->ts.derived, tmp, 0);
3603
	      gfc_add_expr_to_block (&se.pre, tmp);
3604
	    }
3605
3594
	}
3606
	}
3595
3607
3596
      tmp = gfc_finish_block (&se.pre);
3608
      tmp = gfc_finish_block (&se.pre);
Lines 3675-3680 Link Here
3675
      se.descriptor_only = 1;
3687
      se.descriptor_only = 1;
3676
      gfc_conv_expr (&se, expr);
3688
      gfc_conv_expr (&se, expr);
3677
3689
3690
      if (expr->ts.type == BT_DERIVED
3691
	    && expr->ts.derived->attr.alloc_comp)
3692
        {
3693
	  gfc_ref *ref;
3694
	  gfc_ref *last = NULL;
3695
	  for (ref = expr->ref; ref; ref = ref->next)
3696
	    if (ref->type == REF_COMPONENT)
3697
	      last = ref;
3698
3699
	  /* Do not deallocate the components of a derived type
3700
	     ultimate pointer component.  */
3701
	  if (!(last && last->u.c.component->pointer)
3702
		   && !(!last && expr->symtree->n.sym->attr.pointer))
3703
	    {
3704
	      tmp = gfc_deallocate_alloc_comp (expr->ts.derived, se.expr,
3705
						expr->rank);
3706
	      gfc_add_expr_to_block (&se.pre, tmp);
3707
	    }
3708
	}
3709
3678
      if (expr->rank)
3710
      if (expr->rank)
3679
	tmp = gfc_array_deallocate (se.expr, pstat);
3711
	tmp = gfc_array_deallocate (se.expr, pstat);
3680
      else
3712
      else
(-)gcc/fortran/module.c (-1 / +9 lines)
Lines 1435-1441 Link Here
1435
  AB_DATA, AB_IN_NAMELIST, AB_IN_COMMON, 
1435
  AB_DATA, AB_IN_NAMELIST, AB_IN_COMMON, 
1436
  AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, AB_ELEMENTAL, AB_PURE,
1436
  AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, AB_ELEMENTAL, AB_PURE,
1437
  AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT, AB_CRAY_POINTER,
1437
  AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT, AB_CRAY_POINTER,
1438
  AB_CRAY_POINTEE, AB_THREADPRIVATE
1438
  AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP
1439
}
1439
}
1440
ab_attribute;
1440
ab_attribute;
1441
1441
Lines 1465-1470 Link Here
1465
    minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
1465
    minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
1466
    minit ("CRAY_POINTER", AB_CRAY_POINTER),
1466
    minit ("CRAY_POINTER", AB_CRAY_POINTER),
1467
    minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
1467
    minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
1468
    minit ("ALLOC_COMP", AB_ALLOC_COMP),
1468
    minit (NULL, -1)
1469
    minit (NULL, -1)
1469
};
1470
};
1470
1471
Lines 1556-1561 Link Here
1556
      if (attr->cray_pointee)
1557
      if (attr->cray_pointee)
1557
	MIO_NAME(ab_attribute) (AB_CRAY_POINTEE, attr_bits);
1558
	MIO_NAME(ab_attribute) (AB_CRAY_POINTEE, attr_bits);
1558
1559
1560
      if (attr->alloc_comp)
1561
	MIO_NAME(ab_attribute) (AB_ALLOC_COMP, attr_bits);
1562
1559
      mio_rparen ();
1563
      mio_rparen ();
1560
1564
1561
    }
1565
    }
Lines 1644-1649 Link Here
1644
	    case AB_CRAY_POINTEE:
1648
	    case AB_CRAY_POINTEE:
1645
	      attr->cray_pointee = 1;
1649
	      attr->cray_pointee = 1;
1646
	      break;
1650
	      break;
1651
	    case AB_ALLOC_COMP:
1652
	      attr->alloc_comp = 1;
1653
	      break;
1647
	    }
1654
	    }
1648
	}
1655
	}
1649
    }
1656
    }
Lines 1951-1956 Link Here
1951
1958
1952
  mio_integer (&c->dimension);
1959
  mio_integer (&c->dimension);
1953
  mio_integer (&c->pointer);
1960
  mio_integer (&c->pointer);
1961
  mio_integer (&c->allocatable);
1954
1962
1955
  mio_expr (&c->initializer);
1963
  mio_expr (&c->initializer);
1956
  mio_rparen ();
1964
  mio_rparen ();
(-)gcc/fortran/trans-types.c (-1 / +1 lines)
Lines 1550-1556 Link Here
1550
         required.  */
1550
         required.  */
1551
      if (c->dimension)
1551
      if (c->dimension)
1552
	{
1552
	{
1553
	  if (c->pointer)
1553
	  if (c->pointer || c->allocatable)
1554
	    {
1554
	    {
1555
	      /* Pointers to arrays aren't actually pointer types.  The
1555
	      /* Pointers to arrays aren't actually pointer types.  The
1556
	         descriptors are separate, but the data is common.  */
1556
	         descriptors are separate, but the data is common.  */
(-)gcc/fortran/trans.h (-1 / +1 lines)
Lines 307-313 Link Here
307
/* gfc_trans_* shouldn't call push/poplevel, use gfc_push/pop_scope */
307
/* gfc_trans_* shouldn't call push/poplevel, use gfc_push/pop_scope */
308
308
309
/* Generate code for a scalar assignment.  */
309
/* Generate code for a scalar assignment.  */
310
tree gfc_trans_scalar_assign (gfc_se *, gfc_se *, bt);
310
tree gfc_trans_scalar_assign (gfc_se *, gfc_se *, gfc_typespec, bool, bool);
311
311
312
/* Translate COMMON blocks.  */
312
/* Translate COMMON blocks.  */
313
void gfc_trans_common (gfc_namespace *);
313
void gfc_trans_common (gfc_namespace *);
(-)gcc/fortran/resolve.c (-12 / +39 lines)
Lines 596-611 Link Here
596
596
597
  for (; comp; comp = comp->next, cons = cons->next)
597
  for (; comp; comp = comp->next, cons = cons->next)
598
    {
598
    {
599
      if (! cons->expr)
599
      if (!cons->expr)
600
	continue;
601
602
      if (gfc_resolve_expr (cons->expr) == FAILURE)
600
	{
603
	{
601
	  t = FAILURE;
604
	  t = FAILURE;
602
	  continue;
605
	  continue;
603
	}
606
	}
604
607
605
      if (gfc_resolve_expr (cons->expr) == FAILURE)
608
      if (cons->expr->expr_type != EXPR_NULL
606
	{
609
	    && comp->as && comp->as->rank != cons->expr->rank
610
	    && (comp->allocatable || cons->expr->rank))
611
	{
612
	  gfc_error ("The rank of the element in the derived type "
613
		     "constructor at %L does not match that of the "
614
		     "component (%d/%d)", &cons->expr->where,
615
		     cons->expr->rank, comp->as ? comp->as->rank : 0);
607
	  t = FAILURE;
616
	  t = FAILURE;
608
	  continue;
609
	}
617
	}
610
618
611
      /* If we don't have the right type, try to convert it.  */
619
      /* If we don't have the right type, try to convert it.  */
Lines 918-926 Link Here
918
}
926
}
919
927
920
928
921
/* Do the checks of the actual argument list that are specific to elemental
929
  /* Do the checks of the actual argument list that are specific to elemental
922
   procedures.  If called with c == NULL, we have a function, otherwise if
930
     procedures.  If called with c == NULL, we have a function, otherwise if
923
   expr == NULL, we have a subroutine.  */
931
     expr == NULL, we have a subroutine.  */
924
static try
932
static try
925
resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
933
resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
926
{
934
{
Lines 973-979 Link Here
973
		&& arg->expr->symtree->n.sym->attr.optional)
981
		&& arg->expr->symtree->n.sym->attr.optional)
974
	    set_by_optional = true;
982
	    set_by_optional = true;
975
983
976
	  /* Function specific; set the result rank and shape.  */
984
	  /* Function specific.  */
977
	  if (expr)
985
	  if (expr)
978
	    {
986
	    {
979
	      expr->rank = rank;
987
	      expr->rank = rank;
Lines 3312-3318 Link Here
3312
3320
3313
/* Given the expression node e for an allocatable/pointer of derived type to be
3321
/* Given the expression node e for an allocatable/pointer of derived type to be
3314
   allocated, get the expression node to be initialized afterwards (needed for
3322
   allocated, get the expression node to be initialized afterwards (needed for
3315
   derived types with default initializers).  */
3323
   derived types with default initializers, and derived types with allocatable
3324
   components that need nullification.)  */
3316
3325
3317
static gfc_expr *
3326
static gfc_expr *
3318
expr_to_initialize (gfc_expr * e)
3327
expr_to_initialize (gfc_expr * e)
Lines 3417-3428 Link Here
3417
  /* Add default initializer for those derived types that need them.  */
3426
  /* Add default initializer for those derived types that need them.  */
3418
  if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
3427
  if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
3419
    {
3428
    {
3429
        gfc_component *cm;
3430
        gfc_constructor *c;
3431
3432
	cm = e->ts.derived->components;
3433
	for (c = init_e->value.constructor; c; c = c->next, cm = cm->next)
3434
	  if (cm->allocatable && c->expr == NULL)
3435
	    {
3436
	      c->expr = gfc_get_expr ();
3437
	      c->expr->expr_type = EXPR_NULL;
3438
	      c->expr->ts = cm->ts;
3439
	    }
3440
3420
        init_st = gfc_get_code ();
3441
        init_st = gfc_get_code ();
3421
        init_st->loc = code->loc;
3442
        init_st->loc = code->loc;
3422
        init_st->op = EXEC_ASSIGN;
3443
        init_st->op = EXEC_ASSIGN;
3423
        init_st->expr = expr_to_initialize (e);
3444
        init_st->expr = expr_to_initialize (e);
3424
        init_st->expr2 = init_e;
3445
	init_st->expr2 = init_e;
3425
3426
        init_st->next = code->next;
3446
        init_st->next = code->next;
3427
        code->next = init_st;
3447
        code->next = init_st;
3428
    }
3448
    }
Lines 4031-4036 Link Here
4031
	  return;
4051
	  return;
4032
	}
4052
	}
4033
4053
4054
      if (ts->derived->attr.alloc_comp)
4055
	{
4056
	  gfc_error ("Data transfer element at %L cannot have "
4057
		     "ALLOCATABLE components", &code->loc);
4058
	  return;
4059
	}
4060
4034
      if (derived_inaccessible (ts->derived))
4061
      if (derived_inaccessible (ts->derived))
4035
	{
4062
	{
4036
	  gfc_error ("Data transfer element at %L cannot have "
4063
	  gfc_error ("Data transfer element at %L cannot have "
Lines 5412-5418 Link Here
5412
	    }
5439
	    }
5413
	}
5440
	}
5414
5441
5415
      if (c->pointer || c->as == NULL)
5442
      if (c->pointer || c->allocatable ||  c->as == NULL)
5416
	continue;
5443
	continue;
5417
5444
5418
      for (i = 0; i < c->as->rank; i++)
5445
      for (i = 0; i < c->as->rank; i++)
(-)gcc/fortran/trans-decl.c (-3 / +28 lines)
Lines 957-962 Link Here
957
	GFC_DECL_PACKED_ARRAY (decl) = 1;
957
	GFC_DECL_PACKED_ARRAY (decl) = 1;
958
    }
958
    }
959
959
960
  if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
961
    gfc_defer_symbol_init (sym);
962
960
  gfc_finish_var_decl (decl, sym);
963
  gfc_finish_var_decl (decl, sym);
961
964
962
  if (sym->ts.type == BT_CHARACTER)
965
  if (sym->ts.type == BT_CHARACTER)
Lines 2559-2564 Link Here
2559
2562
2560
  for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
2563
  for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
2561
    {
2564
    {
2565
      bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
2566
				   && sym->ts.derived->attr.alloc_comp;
2562
      if (sym->attr.dimension)
2567
      if (sym->attr.dimension)
2563
	{
2568
	{
2564
	  switch (sym->as->type)
2569
	  switch (sym->as->type)
Lines 2601-2613 Link Here
2601
	      break;
2606
	      break;
2602
2607
2603
	    case AS_DEFERRED:
2608
	    case AS_DEFERRED:
2604
	      fnbody = gfc_trans_deferred_array (sym, fnbody);
2609
	      if (!sym_has_alloc_comp)
2610
		fnbody = gfc_trans_deferred_array (sym, fnbody);
2605
	      break;
2611
	      break;
2606
2612
2607
	    default:
2613
	    default:
2608
	      gcc_unreachable ();
2614
	      gcc_unreachable ();
2609
	    }
2615
	    }
2616
	  if (sym_has_alloc_comp)
2617
	    fnbody = gfc_trans_deferred_array (sym, fnbody);
2610
	}
2618
	}
2619
      else if (sym_has_alloc_comp)
2620
	fnbody = gfc_trans_deferred_array (sym, fnbody);
2611
      else if (sym->ts.type == BT_CHARACTER)
2621
      else if (sym->ts.type == BT_CHARACTER)
2612
	{
2622
	{
2613
	  gfc_get_backend_locus (&loc);
2623
	  gfc_get_backend_locus (&loc);
Lines 2959-2968 Link Here
2959
  tree old_context;
2969
  tree old_context;
2960
  tree decl;
2970
  tree decl;
2961
  tree tmp;
2971
  tree tmp;
2972
  tree tmp2;
2962
  stmtblock_t block;
2973
  stmtblock_t block;
2963
  stmtblock_t body;
2974
  stmtblock_t body;
2964
  tree result;
2975
  tree result;
2965
  gfc_symbol *sym;
2976
  gfc_symbol *sym;
2977
  int rank;
2966
2978
2967
  sym = ns->proc_name;
2979
  sym = ns->proc_name;
2968
2980
Lines 3122-3128 Link Here
3122
  tmp = gfc_finish_block (&body);
3134
  tmp = gfc_finish_block (&body);
3123
  /* Add code to create and cleanup arrays.  */
3135
  /* Add code to create and cleanup arrays.  */
3124
  tmp = gfc_trans_deferred_vars (sym, tmp);
3136
  tmp = gfc_trans_deferred_vars (sym, tmp);
3125
  gfc_add_expr_to_block (&block, tmp);
3126
3137
3127
  if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
3138
  if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
3128
    {
3139
    {
Lines 3137-3143 Link Here
3137
      else
3148
      else
3138
	result = sym->result->backend_decl;
3149
	result = sym->result->backend_decl;
3139
3150
3140
      if (result == NULL_TREE)
3151
      if (result != NULL_TREE && sym->attr.function
3152
	    && sym->ts.type == BT_DERIVED
3153
	    && sym->ts.derived->attr.alloc_comp)
3154
	{
3155
	  rank = sym->as ? sym->as->rank : 0;
3156
	  tmp2 = gfc_nullify_alloc_comp (sym->ts.derived, result, rank);
3157
	  gfc_add_expr_to_block (&block, tmp2);
3158
	}
3159
3160
     gfc_add_expr_to_block (&block, tmp);
3161
3162
     if (result == NULL_TREE)
3141
	warning (0, "Function return value not set");
3163
	warning (0, "Function return value not set");
3142
      else
3164
      else
3143
	{
3165
	{
Lines 3148-3153 Link Here
3148
	  gfc_add_expr_to_block (&block, tmp);
3170
	  gfc_add_expr_to_block (&block, tmp);
3149
	}
3171
	}
3150
    }
3172
    }
3173
  else
3174
    gfc_add_expr_to_block (&block, tmp);
3175
3151
3176
3152
  /* Add all the decls we created during processing.  */
3177
  /* Add all the decls we created during processing.  */
3153
  decl = saved_function_decls;
3178
  decl = saved_function_decls;
(-)gcc/fortran/parse.c (+14 lines)
Lines 1499-1504 Link Here
1499
  int compiling_type, seen_private, seen_sequence, seen_component, error_flag;
1499
  int compiling_type, seen_private, seen_sequence, seen_component, error_flag;
1500
  gfc_statement st;
1500
  gfc_statement st;
1501
  gfc_state_data s;
1501
  gfc_state_data s;
1502
  gfc_symbol *sym;
1503
  gfc_component *c;
1502
1504
1503
  error_flag = 0;
1505
  error_flag = 0;
1504
1506
Lines 1595-1600 Link Here
1595
	}
1597
	}
1596
    }
1598
    }
1597
1599
1600
  /* Look for allocatable components.  */
1601
  sym = gfc_current_block ();
1602
  for (c = sym->components; c; c = c->next)
1603
    {
1604
      if (c->allocatable || (c->ts.type == BT_DERIVED
1605
		    	     && c->ts.derived->attr.alloc_comp))
1606
	{
1607
	  sym->attr.alloc_comp = 1;
1608
	  break;
1609
	}
1610
     }
1611
1598
  pop_state ();
1612
  pop_state ();
1599
}
1613
}
1600
1614
(-)gcc/fortran/check.c (-1 / +62 lines)
Lines 477-489 Link Here
477
try
477
try
478
gfc_check_allocated (gfc_expr * array)
478
gfc_check_allocated (gfc_expr * array)
479
{
479
{
480
  symbol_attribute attr;
481
480
  if (variable_check (array, 0) == FAILURE)
482
  if (variable_check (array, 0) == FAILURE)
481
    return FAILURE;
483
    return FAILURE;
482
484
483
  if (array_check (array, 0) == FAILURE)
485
  if (array_check (array, 0) == FAILURE)
484
    return FAILURE;
486
    return FAILURE;
485
487
486
  if (!array->symtree->n.sym->attr.allocatable)
488
  attr = gfc_variable_attr (array, NULL);
489
  if (!attr.allocatable)
487
    {
490
    {
488
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
491
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
489
		 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
492
		 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
Lines 1814-1819 Link Here
1814
  return SUCCESS;
1817
  return SUCCESS;
1815
}
1818
}
1816
1819
1820
try
1821
gfc_check_move_alloc (gfc_expr * from, gfc_expr * to)
1822
{
1823
  symbol_attribute attr;
1824
1825
  if (variable_check (from, 0) == FAILURE)
1826
    return FAILURE;
1827
1828
  if (array_check (from, 0) == FAILURE)
1829
    return FAILURE;
1830
1831
  attr = gfc_variable_attr (from, NULL);
1832
  if (!attr.allocatable)
1833
    {
1834
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
1835
		 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
1836
		 &from->where);
1837
      return FAILURE;
1838
    }
1839
1840
  if (variable_check (to, 0) == FAILURE)
1841
    return FAILURE;
1842
1843
  if (array_check (to, 0) == FAILURE)
1844
    return FAILURE;
1845
1846
  attr = gfc_variable_attr (to, NULL);
1847
  if (!attr.allocatable)
1848
    {
1849
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
1850
		 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
1851
		 &to->where);
1852
      return FAILURE;
1853
    }
1854
1855
  if (same_type_check (from, 0, to, 1) == FAILURE)
1856
    return FAILURE;
1857
1858
  if (to->rank != from->rank)
1859
    {
1860
      gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
1861
		 "have the same rank %d/%d", gfc_current_intrinsic_arg[0],
1862
		 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
1863
		 &to->where,  from->rank, to->rank);
1864
      return FAILURE;
1865
    }
1866
1867
  if (to->ts.kind != from->ts.kind)
1868
    {
1869
      gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
1870
		 "be of the same kind %d/%d", gfc_current_intrinsic_arg[0],
1871
		 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
1872
		 &to->where, from->ts.kind, to->ts.kind);
1873
      return FAILURE;
1874
    }
1875
1876
  return SUCCESS;
1877
}
1817
1878
1818
try
1879
try
1819
gfc_check_nearest (gfc_expr * x, gfc_expr * s)
1880
gfc_check_nearest (gfc_expr * x, gfc_expr * s)
(-)gcc/fortran/primary.c (-4 / +7 lines)
Lines 1711-1717 Link Here
1711
symbol_attribute
1711
symbol_attribute
1712
gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
1712
gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
1713
{
1713
{
1714
  int dimension, pointer, target;
1714
  int dimension, pointer, allocatable, target;
1715
  symbol_attribute attr;
1715
  symbol_attribute attr;
1716
  gfc_ref *ref;
1716
  gfc_ref *ref;
1717
1717
Lines 1723-1728 Link Here
1723
1723
1724
  dimension = attr.dimension;
1724
  dimension = attr.dimension;
1725
  pointer = attr.pointer;
1725
  pointer = attr.pointer;
1726
  allocatable = attr.allocatable;
1726
1727
1727
  target = attr.target;
1728
  target = attr.target;
1728
  if (pointer)
1729
  if (pointer)
Lines 1743-1754 Link Here
1743
	    break;
1744
	    break;
1744
1745
1745
	  case AR_SECTION:
1746
	  case AR_SECTION:
1746
	    pointer = 0;
1747
	    allocatable = pointer = 0;
1747
	    dimension = 1;
1748
	    dimension = 1;
1748
	    break;
1749
	    break;
1749
1750
1750
	  case AR_ELEMENT:
1751
	  case AR_ELEMENT:
1751
	    pointer = 0;
1752
	    allocatable = pointer = 0;
1752
	    break;
1753
	    break;
1753
1754
1754
	  case AR_UNKNOWN:
1755
	  case AR_UNKNOWN:
Lines 1763-1780 Link Here
1763
	  *ts = ref->u.c.component->ts;
1764
	  *ts = ref->u.c.component->ts;
1764
1765
1765
	pointer = ref->u.c.component->pointer;
1766
	pointer = ref->u.c.component->pointer;
1767
	allocatable = ref->u.c.component->allocatable;
1766
	if (pointer)
1768
	if (pointer)
1767
	  target = 1;
1769
	  target = 1;
1768
1770
1769
	break;
1771
	break;
1770
1772
1771
      case REF_SUBSTRING:
1773
      case REF_SUBSTRING:
1772
	pointer = 0;
1774
	allocatable = pointer = 0;
1773
	break;
1775
	break;
1774
      }
1776
      }
1775
1777
1776
  attr.dimension = dimension;
1778
  attr.dimension = dimension;
1777
  attr.pointer = pointer;
1779
  attr.pointer = pointer;
1780
  attr.allocatable = allocatable;
1778
  attr.target = target;
1781
  attr.target = target;
1779
1782
1780
  return attr;
1783
  return attr;
(-)gcc/fortran/intrinsic.texi (+45 lines)
Lines 181-186 Link Here
181
* @code{MINVAL}:        MINVAL,    Minimum value of an array
181
* @code{MINVAL}:        MINVAL,    Minimum value of an array
182
* @code{MOD}:           MOD,       Remainder function
182
* @code{MOD}:           MOD,       Remainder function
183
* @code{MODULO}:        MODULO,    Modulo function
183
* @code{MODULO}:        MODULO,    Modulo function
184
* @code{MOVE_ALLOC}:    MOVE_ALLOC, Move allocation from one object to another
184
* @code{MVBITS}:        MVBITS,    Move bits from one integer to another
185
* @code{MVBITS}:        MVBITS,    Move bits from one integer to another
185
* @code{NEAREST}:       NEAREST,   Nearest representable number
186
* @code{NEAREST}:       NEAREST,   Nearest representable number
186
* @code{NINT}:          NINT,      Nearest whole number
187
* @code{NINT}:          NINT,      Nearest whole number
Lines 5833-5838 Link Here
5833
5834
5834
5835
5835
5836
5837
@node MOVE_ALLOC
5838
@section @code{MOVE_ALLOC} --- Move allocation from one object to another
5839
@findex @code{MOVE_ALLOC} intrinsic
5840
@cindex MOVE_ALLOC
5841
5842
@table @asis
5843
@item @emph{Description}:
5844
@code{MOVE_ALLOC(SRC, DEST)} moves the allocation from @var{SRC} to
5845
@var{DEST}.  @var{SRC} will become deallocated in the process.
5846
5847
@item @emph{Option}:
5848
f2003, gnu
5849
5850
@item @emph{Class}:
5851
Subroutine
5852
5853
@item @emph{Syntax}:
5854
@code{CALL MOVE_ALLOC(SRC, DEST)}
5855
5856
@item @emph{Arguments}:
5857
@multitable @columnfractions .15 .80
5858
@item @var{SRC} @tab @code{ALLOCATABLE}, @code{INTENT(INOUT)}, may be of any type and kind.
5859
@item @var{DEST} @tab @code{ALLOCATABLE}, @code{INTENT(OUT)}, shall be of the same type, kind and rank as @var{SRC}
5860
@end multitable
5861
5862
@item @emph{Return value}:
5863
None
5864
5865
@item @emph{Example}:
5866
@smallexample
5867
program test_move_alloc
5868
    integer, allocatable :: a(:), b(:)
5869
5870
    allocate(a(3))
5871
    a = [ 1, 2, 3 ]
5872
    call move_alloc(a, b)
5873
    print *, allocated(a), allocated(b)
5874
    print *, b
5875
end program test_move_alloc
5876
@end smallexample
5877
@end table
5878
5879
5880
5836
@node NEAREST
5881
@node NEAREST
5837
@section @code{NEAREST} --- Nearest representable number
5882
@section @code{NEAREST} --- Nearest representable number
5838
@findex @code{NEAREST} intrinsic
5883
@findex @code{NEAREST} intrinsic
(-)libgfortran/Makefile.in (-10 / +19 lines)
Lines 167-178 Link Here
167
	eoshift2.lo etime.lo exit.lo fget.lo flush.lo fnum.lo ftell.lo \
167
	eoshift2.lo etime.lo exit.lo fget.lo flush.lo fnum.lo ftell.lo \
168
	gerror.lo getcwd.lo getlog.lo getXid.lo hyper.lo hostnm.lo \
168
	gerror.lo getcwd.lo getlog.lo getXid.lo hyper.lo hostnm.lo \
169
	kill.lo ierrno.lo ishftc.lo link.lo malloc.lo mvbits.lo \
169
	kill.lo ierrno.lo ishftc.lo link.lo malloc.lo mvbits.lo \
170
	pack_generic.lo perror.lo signal.lo size.lo sleep.lo \
170
	move_alloc.lo pack_generic.lo perror.lo signal.lo size.lo \
171
	spread_generic.lo string_intrinsics.lo system.lo rand.lo \
171
	sleep.lo spread_generic.lo string_intrinsics.lo system.lo \
172
	random.lo rename.lo reshape_generic.lo reshape_packed.lo \
172
	rand.lo random.lo rename.lo reshape_generic.lo \
173
	selected_int_kind.lo selected_real_kind.lo stat.lo symlnk.lo \
173
	reshape_packed.lo selected_int_kind.lo selected_real_kind.lo \
174
	system_clock.lo time.lo transpose_generic.lo tty.lo umask.lo \
174
	stat.lo symlnk.lo system_clock.lo time.lo transpose_generic.lo \
175
	unlink.lo unpack_generic.lo in_pack_generic.lo \
175
	tty.lo umask.lo unlink.lo unpack_generic.lo in_pack_generic.lo \
176
	in_unpack_generic.lo
176
	in_unpack_generic.lo
177
am__objects_31 =
177
am__objects_31 =
178
am__objects_32 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \
178
am__objects_32 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \
Lines 264-269 Link Here
264
AUTOMAKE = @AUTOMAKE@
264
AUTOMAKE = @AUTOMAKE@
265
AWK = @AWK@
265
AWK = @AWK@
266
CC = @CC@
266
CC = @CC@
267
CFLAGS = @CFLAGS@
267
CPP = @CPP@
268
CPP = @CPP@
268
CPPFLAGS = @CPPFLAGS@
269
CPPFLAGS = @CPPFLAGS@
269
CYGPATH_W = @CYGPATH_W@
270
CYGPATH_W = @CYGPATH_W@
Lines 276-281 Link Here
276
FC = @FC@
277
FC = @FC@
277
FCFLAGS = @FCFLAGS@
278
FCFLAGS = @FCFLAGS@
278
FPU_HOST_HEADER = @FPU_HOST_HEADER@
279
FPU_HOST_HEADER = @FPU_HOST_HEADER@
280
GREP = @GREP@
279
INSTALL_DATA = @INSTALL_DATA@
281
INSTALL_DATA = @INSTALL_DATA@
280
INSTALL_PROGRAM = @INSTALL_PROGRAM@
282
INSTALL_PROGRAM = @INSTALL_PROGRAM@
281
INSTALL_SCRIPT = @INSTALL_SCRIPT@
283
INSTALL_SCRIPT = @INSTALL_SCRIPT@
Lines 303-314 Link Here
303
SHELL = @SHELL@
305
SHELL = @SHELL@
304
STRIP = @STRIP@
306
STRIP = @STRIP@
305
VERSION = @VERSION@
307
VERSION = @VERSION@
306
ac_ct_AR = @ac_ct_AR@
307
ac_ct_AS = @ac_ct_AS@
308
ac_ct_CC = @ac_ct_CC@
308
ac_ct_CC = @ac_ct_CC@
309
ac_ct_FC = @ac_ct_FC@
309
ac_ct_FC = @ac_ct_FC@
310
ac_ct_RANLIB = @ac_ct_RANLIB@
311
ac_ct_STRIP = @ac_ct_STRIP@
312
am__leading_dot = @am__leading_dot@
310
am__leading_dot = @am__leading_dot@
313
am__tar = @am__tar@
311
am__tar = @am__tar@
314
am__untar = @am__untar@
312
am__untar = @am__untar@
Lines 321-326 Link Here
321
build_subdir = @build_subdir@
319
build_subdir = @build_subdir@
322
build_vendor = @build_vendor@
320
build_vendor = @build_vendor@
323
datadir = @datadir@
321
datadir = @datadir@
322
datarootdir = @datarootdir@
323
docdir = @docdir@
324
dvidir = @dvidir@
324
enable_shared = @enable_shared@
325
enable_shared = @enable_shared@
325
enable_static = @enable_static@
326
enable_static = @enable_static@
326
exec_prefix = @exec_prefix@
327
exec_prefix = @exec_prefix@
Lines 331-348 Link Here
331
host_os = @host_os@
332
host_os = @host_os@
332
host_subdir = @host_subdir@
333
host_subdir = @host_subdir@
333
host_vendor = @host_vendor@
334
host_vendor = @host_vendor@
335
htmldir = @htmldir@
334
includedir = @includedir@
336
includedir = @includedir@
335
infodir = @infodir@
337
infodir = @infodir@
336
install_sh = @install_sh@
338
install_sh = @install_sh@
337
libdir = @libdir@
339
libdir = @libdir@
338
libexecdir = @libexecdir@
340
libexecdir = @libexecdir@
341
localedir = @localedir@
339
localstatedir = @localstatedir@
342
localstatedir = @localstatedir@
340
mandir = @mandir@
343
mandir = @mandir@
341
mkdir_p = @mkdir_p@
344
mkdir_p = @mkdir_p@
342
multi_basedir = @multi_basedir@
345
multi_basedir = @multi_basedir@
343
oldincludedir = @oldincludedir@
346
oldincludedir = @oldincludedir@
347
pdfdir = @pdfdir@
344
prefix = @prefix@
348
prefix = @prefix@
345
program_transform_name = @program_transform_name@
349
program_transform_name = @program_transform_name@
350
psdir = @psdir@
346
sbindir = @sbindir@
351
sbindir = @sbindir@
347
sharedstatedir = @sharedstatedir@
352
sharedstatedir = @sharedstatedir@
348
sysconfdir = @sysconfdir@
353
sysconfdir = @sysconfdir@
Lines 418-423 Link Here
418
intrinsics/link.c \
423
intrinsics/link.c \
419
intrinsics/malloc.c \
424
intrinsics/malloc.c \
420
intrinsics/mvbits.c \
425
intrinsics/mvbits.c \
426
intrinsics/move_alloc.c \
421
intrinsics/pack_generic.c \
427
intrinsics/pack_generic.c \
422
intrinsics/perror.c \
428
intrinsics/perror.c \
423
intrinsics/signal.c \
429
intrinsics/signal.c \
Lines 2304-2309 Link Here
2304
mvbits.lo: intrinsics/mvbits.c
2310
mvbits.lo: intrinsics/mvbits.c
2305
	$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o mvbits.lo `test -f 'intrinsics/mvbits.c' || echo '$(srcdir)/'`intrinsics/mvbits.c
2311
	$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o mvbits.lo `test -f 'intrinsics/mvbits.c' || echo '$(srcdir)/'`intrinsics/mvbits.c
2306
2312
2313
move_alloc.lo: intrinsics/move_alloc.c
2314
	$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o move_alloc.lo `test -f 'intrinsics/move_alloc.c' || echo '$(srcdir)/'`intrinsics/move_alloc.c
2315
2307
pack_generic.lo: intrinsics/pack_generic.c
2316
pack_generic.lo: intrinsics/pack_generic.c
2308
	$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o pack_generic.lo `test -f 'intrinsics/pack_generic.c' || echo '$(srcdir)/'`intrinsics/pack_generic.c
2317
	$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o pack_generic.lo `test -f 'intrinsics/pack_generic.c' || echo '$(srcdir)/'`intrinsics/pack_generic.c
2309
2318
(-)libgfortran/intrinsics/move_alloc.c (+67 lines)
Line 0 Link Here
1
/* Generic implementation of the MOVE_ALLOC intrinsic
2
   Copyright (C) 2006 Free Software Foundation, Inc.
3
   Contributed by Paul Thomas
4
5
This file is part of the GNU Fortran 95 runtime library (libgfortran).
6
7
Libgfortran is free software; you can redistribute it and/or
8
modify it under the terms of the GNU General Public
9
License as published by the Free Software Foundation; either
10
version 2 of the License, or (at your option) any later version.
11
12
In addition to the permissions in the GNU General Public License, the
13
Free Software Foundation gives you unlimited permission to link the
14
compiled version of this file into combinations with other programs,
15
and to distribute those combinations without any restriction coming
16
from the use of this file.  (The General Public License restrictions
17
do apply in other respects; for example, they cover modification of
18
the file, and distribution when not linked into a combine
19
executable.)
20
21
Ligbfortran is distributed in the hope that it will be useful,
22
but WITHOUT ANY WARRANTY; without even the implied warranty of
23
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
24
GNU General Public License for more details.
25
26
You should have received a copy of the GNU General Public
27
License along with libgfortran; see the file COPYING.  If not,
28
write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
29
Boston, MA 02110-1301, USA.  */
30
31
#include "libgfortran.h"
32
33
extern void move_alloc (gfc_array_char *, gfc_array_char *);
34
export_proto(move_alloc);
35
36
void
37
move_alloc (gfc_array_char * from, gfc_array_char * to)
38
{
39
  int i;
40
41
  internal_free (to->data);
42
43
  for (i = 0; i < GFC_DESCRIPTOR_RANK (from); i++)
44
    {
45
      to->dim[i].lbound = from->dim[i].lbound;
46
      to->dim[i].ubound = from->dim[i].ubound;
47
      to->dim[i].stride = from->dim[i].stride;
48
      from->dim[i].stride = 0;
49
      from->dim[i].ubound = from->dim[i].lbound;
50
    }
51
52
  to->offset = from->offset;
53
  to->dtype = from->dtype;
54
  to->data = from->data;
55
  from->data = NULL;
56
}
57
58
extern void move_alloc_c (gfc_array_char *, GFC_INTEGER_4,
59
			  gfc_array_char *, GFC_INTEGER_4);
60
export_proto(move_alloc_c);
61
62
void
63
move_alloc_c (gfc_array_char * from, GFC_INTEGER_4 from_length __attribute__((unused)),
64
	      gfc_array_char * to, GFC_INTEGER_4 to_length __attribute__((unused)))
65
{
66
  move_alloc (from, to);
67
}
(-)libgfortran/Makefile.am (+1 lines)
Lines 74-79 Link Here
74
intrinsics/link.c \
74
intrinsics/link.c \
75
intrinsics/malloc.c \
75
intrinsics/malloc.c \
76
intrinsics/mvbits.c \
76
intrinsics/mvbits.c \
77
intrinsics/move_alloc.c \
77
intrinsics/pack_generic.c \
78
intrinsics/pack_generic.c \
78
intrinsics/perror.c \
79
intrinsics/perror.c \
79
intrinsics/signal.c \
80
intrinsics/signal.c \
(-)gcc/testsuite/gfortran.dg/alloc_comp_assign_1.f90 (+57 lines)
Line 0 Link Here
1
! { dg-do run }
2
! Test assignments of derived type with allocatable components (PR 20541).
3
!
4
! Contributed by Erik Edelmann  <eedelmann@gcc.gnu.org>
5
!            and Paul Thomas  <pault@gcc.gnu.org>
6
!
7
  type :: ivs
8
    character(1), allocatable :: chars(:)
9
  end type ivs
10
11
  type(ivs) :: a, b
12
  type(ivs) :: x(3), y(3)
13
  
14
  allocate(a%chars(5))
15
  a%chars = (/"h","e","l","l","o"/)
16
17
! An intrinsic assignment must deallocate the l-value and copy across
18
! the array from the r-value.
19
  b = a
20
  if (any (b%chars .ne. (/"h","e","l","l","o"/))) call abort ()
21
  if (allocated (a%chars) .eqv. .false.) call abort ()
22
23
! Scalar to array needs to copy the derived type, to its ultimate components,
24
! to each of the l-value elements.  */
25
  x = b
26
  x(2)%chars = (/"g","'","d","a","y"/)
27
  if (any (x(1)%chars .ne. (/"h","e","l","l","o"/))) call abort ()
28
  if (any (x(2)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
29
  if (allocated (b%chars) .eqv. .false.) call abort ()
30
  deallocate (x(1)%chars, x(2)%chars, x(3)%chars)
31
32
! Array intrinsic assignments are like their scalar counterpart and
33
! must deallocate each element of the l-value and copy across the
34
! arrays from the r-value elements.
35
  allocate(x(1)%chars(5), x(2)%chars(5), x(3)%chars(5))
36
  x(1)%chars = (/"h","e","l","l","o"/)
37
  x(2)%chars = (/"g","'","d","a","y"/)
38
  x(3)%chars = (/"g","o","d","a","g"/)
39
  y(2:1:-1) = x(1:2)
40
  if (any (y(1)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
41
  if (any (y(2)%chars .ne. (/"h","e","l","l","o"/))) call abort ()
42
  if (any (x(3)%chars .ne. (/"g","o","d","a","g"/))) call abort ()
43
44
! In the case of an assignment where there is a dependency, so that a
45
! temporary is necessary, each element must be copied to its
46
! destination after it has been deallocated.
47
  y(2:3) = y(1:2)
48
  if (any (y(1)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
49
  if (any (y(2)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
50
  if (any (y(3)%chars .ne. (/"h","e","l","l","o"/))) call abort ()
51
52
! An identity assignment must not do any deallocation....!
53
  y = y
54
  if (any (y(1)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
55
  if (any (y(2)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
56
  if (any (y(3)%chars .ne. (/"h","e","l","l","o"/))) call abort ()
57
end
(-)gcc/testsuite/gfortran.dg/alloc_comp_basics_3.f90 (+15 lines)
Line 0 Link Here
1
  type :: a
2
    integer, allocatable :: i(:)
3
  end type a
4
5
6
  type :: c
7
    integer, allocatable :: i(:)
8
  end type c
9
10
  type (c) :: x
11
12
  print *, x%i(1)
13
14
end
15
(-)gcc/testsuite/gfortran.dg/alloc_comp_assign_2.f90 (+57 lines)
Line 0 Link Here
1
! { dg-do run }
2
! Test FORALL and WHERE with derived types with allocatable components (PR 20541).
3
!
4
! Contributed by Erik Edelmann  <eedelmann@gcc.gnu.org>
5
!            and Paul Thomas  <pault@gcc.gnu.org>
6
!
7
  type :: a
8
    integer, allocatable :: i(:)
9
  end type a
10
11
  type :: b
12
    type (a), allocatable :: at(:)
13
  end type b
14
15
  type(a) :: x(2)
16
  type(b) :: y(2), z(2)
17
  integer i, m(4)
18
19
! Start with scalar and array element assignments in FORALL.
20
21
  x(1) = a ((/1, 2, 3, 4/))
22
  x(2) = a ((/1, 2, 3, 4/) + 10)
23
  forall (j = 1:2, i = 1:4, x(j)%i(i) > 2 + (j-1)*10)  x(j)%i(i) =  j*4-i
24
  if (any ((/((x(i)%i(j), j = 1,4), i = 1,2)/) .ne. &
25
          (/1, 2, 1, 0, 11, 12, 5, 4/))) call abort ()
26
27
  y(1) = b ((/x(1),x(2)/))
28
  y(2) = b ((/x(2),x(1)/))
29
  forall (k = 1:2, j=1:2, i = 1:4, y(k)%at(j)%i(i) <= 10)
30
    y(k)%at(j)%i(i) =  j*4-i+k
31
  end forall
32
  if (any ((/(((y(k)%at(i)%i(j), j = 1,4), i = 1,2), k = 1,2)/) .ne. &
33
         (/4,3,2,1,11,12,6,5,11,12,3,2,9,8,7,6/))) call abort () 
34
35
! Now simple assignments in WHERE.
36
37
  where (y(1)%at(1)%i > 2) y(1)%at(1)%i = 0
38
  if (any( (/(((y(k)%at(i)%i(j), j = 1,4), i = 1,2), k = 1,2)/) .ne. &
39
         (/0,0,2,1,11,12,6,5,11,12,3,2,9,8,7,6/))) call abort () 
40
41
  where (y((2))%at(:)%i(2) > 8)
42
    y(2)%at(:)%i(2) = 77
43
  end where
44
  if (any ((/(((y(k)%at(i)%i(j), j = 1,4), i = 1,2), k = 1,2)/) .ne. &
45
         (/0,0,2,1,11,12,6,5,11,77,3,2,9,8,7,6/))) call abort ()
46
47
! Check that temporaries and full array  alloctable component assignments
48
! are correctly handled in FORALL.
49
50
  x = (/a ((/1,2,3,4/)),a ((/5,6,7,8/))/)
51
  forall (i=1:2) y(i) = b ((/x(i)/))
52
  forall (i=1:2) y(i) = y(3-i)      ! This needs a temporary.
53
  forall (i=1:2) z(i) = y(i)
54
  if (any ((/(((z(k)%at(i)%i(j), j = 1,4), i = 1,1), k = 1,2)/) .ne. &
55
         (/(/5,6,7,8/),(/1,2,3,4/)/))) call abort ()
56
57
end
(-)gcc/testsuite/gfortran.dg/alloc_comp_assign_3.f90 (+36 lines)
Line 0 Link Here
1
! { dg-do run }
2
! Test assignments of nested derived types with allocatable components(PR 20541).
3
!
4
! Contributed by Erik Edelmann  <eedelmann@gcc.gnu.org>
5
!            and Paul Thomas  <pault@gcc.gnu.org>
6
!
7
  type :: a
8
    integer, allocatable :: i(:)
9
  end type a
10
11
  type :: b
12
    type (a), allocatable :: at(:)
13
  end type b
14
15
  type(a) :: x(2)
16
  type(b) :: y(2), z(2)
17
  integer i, m(4)
18
19
  x(1) = a((/1,2,3,4/))
20
  x(2) = a((/1,2,3,4/)+10)
21
22
  y(1) = b((/x(1),x(2)/))
23
  y(2) = b((/x(2),x(1)/))
24
25
  y(2) = y(1)
26
  forall (j=1:2,k=1:4, y(1)%at(j)%i(k) .ne. y(2)%at(j)%i(k)) &
27
                             y(1)%at(j)%i(k) = 999
28
  if (any ((/((y(1)%at(j)%i(k), k=1,4),j=1,2)/) .eq. 999)) call abort ()
29
30
31
  z = y
32
  forall (i=1:2,j=1:2,k=1:4, z(i)%at(j)%i(k) .ne. y(i)%at(j)%i(k)) &
33
                             z(i)%at(j)%i(k) = 999
34
  if (any ((/(((z(i)%at(j)%i(k), k=1,4),j=1,2),i=1,2)/) .eq. 999)) call abort ()
35
36
end
(-)gcc/testsuite/gfortran.dg/alloc_comp_initializer_1.f90 (+71 lines)
Line 0 Link Here
1
! { dg-do run }
2
! This checks the correct functioning of derived types with default initializers
3
! and allocatable components.
4
!
5
! Contributed by Salvatore Filippone  <salvatore.filippone@uniroma2.it>
6
!
7
module p_type_mod
8
9
  type m_type
10
    integer, allocatable :: p(:)
11
  end type m_type
12
13
  type basep_type
14
    type(m_type), allocatable :: av(:)
15
    type(m_type), pointer :: ap => null ()
16
    integer :: i = 101
17
  end type basep_type
18
19
  type p_type
20
    type(basep_type), allocatable :: basepv(:)
21
    integer :: p1 , p2 = 1
22
  end type p_type
23
end module p_type_mod
24
25
program foo
26
 
27
 use p_type_mod
28
  implicit none
29
30
  type(m_type), target :: a
31
  type(p_type) :: pre
32
  type(basep_type) :: wee
33
34
  call test_ab8 ()
35
36
  a = m_type ((/101,102/))  
37
38
  call p_bld (a, pre)
39
40
  if (associated (wee%ap) .or. wee%i /= 101) call abort ()
41
  wee%ap => a
42
  if (.not.associated (wee%ap) .or. allocated (wee%av)) call abort ()
43
  wee = basep_type ((/m_type ((/201, 202, 203/))/), null (), 99)
44
  if (.not.allocated (wee%av) .or. associated (wee%ap) .or. (wee%i .ne. 99)) call abort () 
45
46
contains
47
48
! Check that allocatable components are nullified after allocation.
49
  subroutine test_ab8 ()
50
    type(p_type)    :: p
51
    integer :: ierr
52
  
53
    if (.not.allocated(p%basepv)) then 
54
      allocate(p%basepv(1),stat=ierr)
55
    endif
56
    if (allocated (p%basepv) .neqv. .true.) call abort ()
57
    if (allocated (p%basepv(1)%av) .neqv. .false.) call abort
58
    if (p%basepv(1)%i .ne. 101) call abort ()
59
60
  end subroutine test_ab8
61
62
    subroutine p_bld (a, p)
63
      use p_type_mod
64
      type (m_type) :: a
65
      type(p_type) :: p
66
      if (any (a%p .ne. (/101,102/))) call abort ()
67
      if (allocated (p%basepv) .or. (p%p2 .ne. 1)) call abort ()
68
    end subroutine p_bld
69
70
end program foo
71
! { dg-final { cleanup-modules "p_type_mod" } }
(-)gcc/testsuite/gfortran.dg/alloc_comp_assign_4.f90 (+63 lines)
Line 0 Link Here
1
! { dg-do run }
2
! Test assignments of nested derived types with character allocatable
3
! components(PR 20541). Subroutine test_ab6 checks out a bug in a test
4
! version of gfortran's allocatable arrays.
5
!
6
! Contributed by Erik Edelmann  <eedelmann@gcc.gnu.org>
7
!            and Paul Thomas  <pault@gcc.gnu.org>
8
!
9
  type :: a
10
    character(4), allocatable :: ch(:)
11
  end type a
12
13
  type :: b
14
    type (a), allocatable :: at(:)
15
  end type b
16
17
  type(a) :: x(2)
18
  type(b) :: y(2), z(2)
19
20
  character(4) :: chr1(4) = (/"abcd","efgh","ijkl","mnop"/)
21
  character(4) :: chr2(4) = (/"qrst","uvwx","yz12","3456"/)
22
23
  x(1) = a(chr1)
24
25
 ! Check constructor with character array constructors.
26
  x(2) = a((/"qrst","uvwx","yz12","3456"/))
27
28
  y(1) = b((/x(1),x(2)/))
29
  y(2) = b((/x(2),x(1)/))
30
31
  y(2) = y(1)
32
33
  if (any((/((y(2)%at(i)%ch(j),j=1,4),i=1,2)/) .ne. &
34
          (/chr1, chr2/))) call abort ()
35
36
  call test_ab6 ()
37
38
contains
39
40
  subroutine test_ab6 ()
41
! This subroutine tests the presence of a scalar derived type, intermediate
42
! in a chain of derived types with allocatable components.
43
! Contributed by Salvatore Filippone  <salvatore.filippone@uniroma2.it>
44
45
    type b
46
      type(a)  :: a
47
    end type b
48
49
    type c
50
      type(b), allocatable :: b(:) 
51
    end type c
52
53
    type(c)    :: p
54
    type(b)   :: bv
55
56
    p = c((/b(a((/"Mary","Lamb"/)))/))
57
    bv = p%b(1)
58
59
    if (any ((bv%a%ch(:)) .ne. (/"Mary","Lamb"/))) call abort ()
60
61
end subroutine test_ab6
62
63
end
(-)gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90 (+108 lines)
Line 0 Link Here
1
! { dg-do run }
2
! { dg-options "-fdump-tree-original" }
3
! Test constructors of derived type with allocatable components (PR 20541).
4
!
5
! Contributed by Erik Edelmann  <eedelmann@gcc.gnu.org>
6
!            and Paul Thomas  <pault@gcc.gnu.org>
7
!
8
9
Program test_constructor
10
11
    implicit none
12
13
    type :: thytype
14
        integer(4) :: a(2,2)
15
    end type thytype
16
17
    type :: mytype
18
        integer(4), allocatable :: a(:, :)
19
        type(thytype), allocatable :: q(:)
20
    end type mytype
21
22
    type (mytype) :: x
23
    type (thytype) :: foo = thytype(reshape ([43, 100, 54, 76], [2,2]))
24
    integer :: y(0:1, -1:0) = reshape ([42, 99, 55, 77], [2,2])
25
    integer, allocatable :: yy(:,:)
26
    type (thytype), allocatable :: bar(:)
27
    integer :: i
28
29
    ! Check that null() works
30
    x = mytype(null(), null())
31
    if (allocated(x%a) .or. allocated(x%q)) call abort()
32
33
    ! Check that unallocated allocatables work
34
    x = mytype(yy, bar)
35
    if (allocated(x%a) .or. allocated(x%q)) call abort()
36
37
    ! Check that non-allocatables work
38
    x = mytype(y, [foo, foo])
39
    if (.not.allocated(x%a) .or. .not.allocated(x%q)) call abort()
40
    if (any(lbound(x%a) /= lbound(y))) call abort()
41
    if (any(ubound(x%a) /= ubound(y))) call abort()
42
    if (any(x%a /= y)) call abort()
43
    if (size(x%q) /= 2) call abort()
44
    do i = 1, 2
45
        if (any(x%q(i)%a /= foo%a)) call abort()
46
    end do
47
48
    ! Check that allocated allocatables work
49
    allocate(yy(size(y,1), size(y,2)))
50
    yy = y
51
    allocate(bar(2))
52
    bar = [foo, foo]
53
    x = mytype(yy, bar)
54
    if (.not.allocated(x%a) .or. .not.allocated(x%q)) call abort()
55
    if (any(x%a /= y)) call abort()
56
    if (size(x%q) /= 2) call abort()
57
    do i = 1, 2
58
        if (any(x%q(i)%a /= foo%a)) call abort()
59
    end do
60
61
    ! Functions returning arrays
62
    x = mytype(bluhu(), null())
63
    if (.not.allocated(x%a) .or. allocated(x%q)) call abort()
64
    if (any(x%a /= reshape ([41, 98, 54, 76], [2,2]))) call abort()
65
66
    ! Functions returning allocatable arrays
67
    x = mytype(blaha(), null())
68
    if (.not.allocated(x%a) .or. allocated(x%q)) call abort()
69
    if (any(x%a /= reshape ([40, 97, 53, 75], [2,2]))) call abort()
70
71
    ! Check that passing the constructor to a procedure works
72
    call check_mytype (mytype(y, [foo, foo]))
73
74
contains
75
76
    subroutine check_mytype(x)
77
        type(mytype), intent(in) :: x
78
        integer :: i
79
80
        if (.not.allocated(x%a) .or. .not.allocated(x%q)) call abort()
81
        if (any(lbound(x%a) /= lbound(y))) call abort()
82
        if (any(ubound(x%a) /= ubound(y))) call abort()
83
        if (any(x%a /= y)) call abort()
84
        if (size(x%q) /= 2) call abort()
85
        do i = 1, 2
86
            if (any(x%q(i)%a /= foo%a)) call abort()
87
        end do
88
89
    end subroutine check_mytype
90
91
92
    function bluhu()
93
        integer :: bluhu(2,2)
94
95
        bluhu = reshape ([41, 98, 54, 76], [2,2])
96
    end function bluhu
97
98
99
    function blaha()
100
        integer, allocatable :: blaha(:,:)
101
102
        allocate(blaha(2,2))
103
        blaha = reshape ([40, 97, 53, 75], [2,2])
104
    end function blaha
105
106
end program test_constructor
107
! { dg-final { scan-tree-dump-times "deallocate" 18 "original" } }
108
! { dg-final { cleanup-tree-dump "original" } }
(-)gcc/testsuite/gfortran.dg/alloc_comp_constructor_2.f90 (+26 lines)
Line 0 Link Here
1
! { dg-do run }
2
! Test constructors of nested derived types with allocatable components(PR 20541).
3
!
4
! Contributed by Erik Edelmann  <eedelmann@gcc.gnu.org>
5
!            and Paul Thomas  <pault@gcc.gnu.org>
6
!
7
  type :: thytype
8
    integer(4), allocatable :: h(:)
9
  end type thytype
10
11
  type :: mytype
12
    type(thytype), allocatable :: q(:)
13
  end type mytype
14
15
  type (mytype) :: x
16
  type (thytype) :: w(2)
17
  integer :: y(2) =(/1,2/)
18
19
  w = (/thytype(y), thytype (2*y)/)
20
  x = mytype (w)
21
  if (any ((/((x%q(j)%h(i),j=1,2),i=1,2)/) .ne. (/1,2,2,4/))) call abort ()
22
23
  x = mytype ((/thytype(3*y), thytype (4*y)/))
24
  if (any ((/((x%q(j)%h(i),j=1,2),i=1,2)/) .ne. (/3,4,6,8/))) call abort ()
25
26
end
(-)gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90 (+143 lines)
Line 0 Link Here
1
! { dg-do run}
2
! { dg-options "-O2 -fdump-tree-original" }
3
!
4
! Check some basic functionality of allocatable components, including that they
5
! are nullified when created and automatically deallocated when
6
! 1. A variable goes out of scope
7
! 2. INTENT(OUT) dummies
8
! 3. Function results
9
!
10
!
11
! Contributed by Erik Edelmann  <eedelmann@gcc.gnu.org>
12
!            and Paul Thomas  <pault@gcc.gnu.org>
13
!
14
module alloc_m
15
16
    implicit none
17
18
    type :: alloc1
19
        real, allocatable :: x(:)
20
    end type alloc1
21
22
end module alloc_m
23
24
25
program alloc
26
27
    use alloc_m
28
29
    implicit none
30
31
    type :: alloc2
32
        type(alloc1), allocatable :: a1(:)
33
        integer, allocatable :: a2(:)
34
    end type alloc2
35
36
    type(alloc2) :: b
37
    integer :: i
38
    type(alloc2), allocatable :: c(:)
39
40
    if (allocated(b%a2) .OR. allocated(b%a1)) then
41
        write (0, *) 'main - 1'
42
        call abort()
43
    end if
44
45
    ! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy)
46
    call allocate_alloc2(b)
47
    call check_alloc2(b)
48
49
    do i = 1, size(b%a1)
50
        ! 1 call to _gfortran_deallocate
51
        deallocate(b%a1(i)%x)
52
    end do
53
54
    ! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy)
55
    call allocate_alloc2(b)
56
57
    call check_alloc2(return_alloc2())
58
    ! 3 calls to _gfortran_deallocate (function result)
59
60
    allocate(c(1))
61
    ! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy)
62
    call allocate_alloc2(c(1))
63
    ! 4 calls to _gfortran_deallocate
64
    deallocate(c)
65
66
    ! 7 calls to _gfortran_deallocate (b (3) and c(4) goes aout of scope)
67
68
contains
69
70
    subroutine allocate_alloc2(b)
71
        type(alloc2), intent(out) :: b
72
        integer :: i
73
74
        if (allocated(b%a2) .OR. allocated(b%a1)) then
75
            write (0, *) 'allocate_alloc2 - 1'
76
            call abort()
77
        end if
78
79
        allocate (b%a2(3))
80
        b%a2 = [ 1, 2, 3 ]
81
82
        allocate (b%a1(3))
83
84
        do i = 1, 3
85
            if (allocated(b%a1(i)%x)) then
86
                write (0, *) 'allocate_alloc2 - 2', i
87
                call abort()
88
            end if
89
            allocate (b%a1(i)%x(3))
90
            b%a1(i)%x = i + [ 1.0, 2.0, 3.0 ]
91
        end do
92
93
    end subroutine allocate_alloc2
94
95
96
    type(alloc2) function return_alloc2() result(b)
97
        if (allocated(b%a2) .OR. allocated(b%a1)) then
98
            write (0, *) 'return_alloc2 - 1'
99
            call abort()
100
        end if
101
102
        allocate (b%a2(3))
103
        b%a2 = [ 1, 2, 3 ]
104
105
        allocate (b%a1(3))
106
107
        do i = 1, 3
108
            if (allocated(b%a1(i)%x)) then
109
                write (0, *) 'return_alloc2 - 2', i
110
                call abort()
111
            end if
112
            allocate (b%a1(i)%x(3))
113
            b%a1(i)%x = i + [ 1.0, 2.0, 3.0 ]
114
        end do
115
    end function return_alloc2
116
117
118
    subroutine check_alloc2(b)
119
        type(alloc2), intent(in) :: b
120
121
        if (.NOT.(allocated(b%a2) .AND. allocated(b%a1))) then
122
            write (0, *) 'check_alloc2 - 1'
123
            call abort()
124
        end if
125
        if (any(b%a2 /= [ 1, 2, 3 ])) then
126
            write (0, *) 'check_alloc2 - 2'
127
            call abort()
128
        end if
129
        do i = 1, 3
130
            if (.NOT.allocated(b%a1(i)%x)) then
131
                write (0, *) 'check_alloc2 - 3', i
132
                call abort()
133
            end if
134
            if (any(b%a1(i)%x /= i + [ 1.0, 2.0, 3.0 ])) then
135
                write (0, *) 'check_alloc2 - 4', i
136
                call abort()
137
            end if
138
        end do
139
    end subroutine check_alloc2
140
141
end program alloc
142
! { dg-final { scan-tree-dump-times "deallocate" 24 "original" } }
143
! { dg-final { cleanup-tree-dump "original" } }
(-)gcc/testsuite/gfortran.dg/alloc_comp_basics_2.f90 (+39 lines)
Line 0 Link Here
1
! { dg-do run }
2
! Check "double" allocations of allocatable components (PR 20541).
3
!
4
! Contributed by Erik Edelmann  <eedelmann@gcc.gnu.org>
5
!            and Paul Thomas  <pault@gcc.gnu.org>
6
!
7
program main
8
9
  implicit none
10
11
  type foo
12
     integer, dimension(:), allocatable :: array
13
  end type foo
14
15
  type(foo),allocatable,dimension(:) :: mol
16
  type(foo),pointer,dimension(:) :: molp
17
  integer :: i
18
19
  allocate (mol(1))
20
  allocate (mol(1), stat=i)
21
  !print *, i  ! /= 0
22
  if (i == 0) call abort()
23
24
  allocate (mol(1)%array(5))
25
  allocate (mol(1)%array(5),stat=i)
26
  !print *, i  ! /= 0
27
  if (i == 0) call abort()
28
29
  allocate (molp(1))
30
  allocate (molp(1), stat=i)
31
  !print *, i  ! == 0
32
  if (i /= 0) call abort()
33
34
  allocate (molp(1)%array(5))
35
  allocate (molp(1)%array(5),stat=i)
36
  !print *, i  ! /= 0
37
  if (i == 0) call abort()
38
39
end program main

Return to bug 20541