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 (-17 / +336 lines)
Lines 3316-3321 Link Here
3316
  tmp = gfc_conv_descriptor_offset (se->expr);
3316
  tmp = gfc_conv_descriptor_offset (se->expr);
3317
  gfc_add_modify_expr (&se->pre, tmp, offset);
3317
  gfc_add_modify_expr (&se->pre, tmp, offset);
3318
3318
3319
  if (expr->ts.type == BT_DERIVED && 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
3319
  return true;
3326
  return true;
3320
}
3327
}
3321
3328
Lines 3456-3461 Link Here
3456
        }
3463
        }
3457
      break;
3464
      break;
3458
3465
3466
    case EXPR_NULL:
3467
      return gfc_build_null_descriptor (type);
3468
3459
    default:
3469
    default:
3460
      gcc_unreachable ();
3470
      gcc_unreachable ();
3461
    }
3471
    }
Lines 4538-4543 Link Here
4538
  se->want_pointer = 1;
4548
  se->want_pointer = 1;
4539
  gfc_conv_expr_descriptor (se, expr, ss);
4549
  gfc_conv_expr_descriptor (se, expr, ss);
4540
4550
4551
  /* Deallocate the allocatable components of structures that are
4552
     not variable.  */
4553
  if (expr->ts.type == BT_DERIVED
4554
	&& expr->ts.derived->attr.alloc_comp
4555
	&& expr->expr_type != EXPR_VARIABLE)
4556
    {
4557
      tmp = build_fold_indirect_ref (se->expr);
4558
      tmp = gfc_deallocate_alloc_comp (expr->ts.derived, tmp, expr->rank);
4559
      gfc_add_expr_to_block (&se->post, tmp);
4560
    }
4561
4541
  if (g77)
4562
  if (g77)
4542
    {
4563
    {
4543
      desc = se->expr;
4564
      desc = se->expr;
Lines 4586-4609 Link Here
4586
gfc_trans_dealloc_allocated (tree descriptor)
4607
gfc_trans_dealloc_allocated (tree descriptor)
4587
{ 
4608
{ 
4588
  tree tmp;
4609
  tree tmp;
4589
  tree deallocate;
4610
  tree ptr;
4611
  tree var;
4590
  stmtblock_t block;
4612
  stmtblock_t block;
4591
4613
4592
  gfc_start_block (&block);
4614
  gfc_start_block (&block);
4593
  deallocate = gfc_array_deallocate (descriptor, null_pointer_node);
4594
4615
4595
  tmp = gfc_conv_descriptor_data_get (descriptor);
4616
  tmp = gfc_conv_descriptor_data_addr (descriptor);
4596
  tmp = build2 (NE_EXPR, boolean_type_node, tmp,
4617
  var = gfc_evaluate_now (tmp, &block);
4597
                build_int_cst (TREE_TYPE (tmp), 0));
4618
  tmp = gfc_create_var (gfc_array_index_type, NULL);
4598
  tmp = build3_v (COND_EXPR, tmp, deallocate, build_empty_stmt ());
4619
  ptr = build_fold_addr_expr (tmp);
4620
4621
  /* Call array_deallocate with an int* present in the second argument.
4622
     Although it is ignored here, it's presence ensures that arrays that
4623
     are already deallocated are ignored.  */
4624
  tmp = gfc_chainon_list (NULL_TREE, var);
4625
  tmp = gfc_chainon_list (tmp, ptr);
4626
  tmp = build_function_call_expr (gfor_fndecl_deallocate, tmp);
4599
  gfc_add_expr_to_block (&block, tmp);
4627
  gfc_add_expr_to_block (&block, tmp);
4628
  return gfc_finish_block (&block);
4629
}
4600
4630
4601
  tmp = gfc_finish_block (&block);
4602
4631
4603
  return tmp;
4632
/* This helper function calculates the size in words of a full array.  */
4633
4634
static tree
4635
get_full_array_size (stmtblock_t *block, tree decl, int rank)
4636
{
4637
  tree idx;
4638
  tree nelems;
4639
  tree tmp;
4640
  idx = gfc_rank_cst[rank - 1];
4641
  nelems = gfc_conv_descriptor_ubound (decl, idx);
4642
  tmp = gfc_conv_descriptor_lbound (decl, idx);
4643
  tmp = build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
4644
  tmp = build2 (PLUS_EXPR, gfc_array_index_type,
4645
		tmp, gfc_index_one_node);
4646
  tmp = gfc_evaluate_now (tmp, block);
4647
4648
  nelems = gfc_conv_descriptor_stride (decl, idx);
4649
  tmp = build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
4650
  return gfc_evaluate_now (tmp, block);
4604
}
4651
}
4605
4652
4606
4653
4654
/* Recursively traverse an object of derived type, generating code to deallocate,
4655
   nullify or copy allocatable components.  This is the work horse function for
4656
   the functions named in this enum.  */
4657
enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP};
4658
4659
static tree
4660
structure_alloc_comps (gfc_symbol * der_type, tree decl,
4661
		       tree dest, int rank, int purpose)
4662
{
4663
  gfc_component *c;
4664
  gfc_loopinfo loop;
4665
  stmtblock_t fnblock;
4666
  stmtblock_t loopbody;
4667
  tree tmp;
4668
  tree comp;
4669
  tree dcmp;
4670
  tree nelems;
4671
  tree index;
4672
  tree var, dvar;
4673
  tree cdecl;
4674
  tree ctype;
4675
  tree vref, dref;
4676
4677
  gfc_init_block (&fnblock);
4678
4679
  /* If this an array of derived types with allocatable components
4680
     build a loop and recursively call this function.  */
4681
  if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE
4682
	|| GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
4683
    {
4684
      tmp = gfc_conv_array_data (decl);
4685
      var = build_fold_indirect_ref (tmp);
4686
	
4687
      /* Get the number of elements - 1 and set the counter.  */
4688
      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
4689
	{
4690
	  /* Use the descriptor for an allocatable array.  Since this
4691
	     is a full array reference, we only need the descriptor
4692
	     information from dimension = rank.  */
4693
	  nelems = get_full_array_size (&fnblock, decl, rank);
4694
4695
	  /* Set the result to -1 if already deallocated, so that the
4696
	     loop does not run.  */
4697
	  tmp = gfc_conv_descriptor_data_get (decl);
4698
	  tmp = build2 (NE_EXPR, boolean_type_node, tmp,
4699
			build_int_cst (TREE_TYPE (tmp), 0));
4700
	  tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
4701
			nelems, gfc_index_zero_node);
4702
	  tmp = gfc_evaluate_now (tmp, &fnblock);
4703
	  tmp = build2 (MINUS_EXPR, gfc_array_index_type,
4704
			   tmp, gfc_index_one_node);
4705
	}
4706
      else
4707
	{
4708
	  /*  Otherwise use the TYPE_DOMAIN information.  */
4709
	  tmp =  array_type_nelts (TREE_TYPE (decl));
4710
	  tmp = fold_convert (gfc_array_index_type, tmp);
4711
	}
4712
4713
      nelems = gfc_evaluate_now (tmp, &fnblock);
4714
      index = gfc_create_var (gfc_array_index_type, "S");
4715
4716
      /* Build the body of the loop.  */
4717
      gfc_init_block (&loopbody);
4718
4719
      vref = gfc_build_array_ref (var, index);
4720
4721
      if (purpose == COPY_ALLOC_COMP)
4722
        {
4723
	  dvar = build_fold_indirect_ref (gfc_conv_array_data (dest));
4724
	  dref = gfc_build_array_ref (dvar, index);
4725
	  tmp = structure_alloc_comps (der_type, vref, dref, 0, purpose);
4726
	}
4727
      else
4728
        tmp = structure_alloc_comps (der_type, vref, NULL_TREE, 0, purpose);
4729
4730
      gfc_add_expr_to_block (&loopbody, tmp);
4731
4732
      /* Build the loop and return. */
4733
      gfc_init_loopinfo (&loop);
4734
      loop.dimen = 1;
4735
      loop.from[0] = gfc_index_zero_node;
4736
      loop.loopvar[0] = index;
4737
      loop.to[0] = nelems;
4738
      gfc_trans_scalarizing_loops (&loop, &loopbody);
4739
      gfc_add_block_to_block (&fnblock, &loop.pre);
4740
      return gfc_finish_block (&fnblock);
4741
    }
4742
4743
  /* Otherwise, deallocate the components or recursively call self to
4744
     deallocate the components of components. */
4745
  for (c = der_type->components; c; c = c->next)
4746
    {
4747
      cdecl = c->backend_decl;
4748
      ctype = TREE_TYPE (cdecl);
4749
4750
      switch (purpose)
4751
	{
4752
	case DEALLOCATE_ALLOC_COMP:
4753
	  /* Do not deallocate the components of ultimate pointer
4754
	     components.  */
4755
	  if (c->ts.type == BT_DERIVED
4756
		&& c->ts.derived->attr.alloc_comp
4757
		&& !c->pointer)
4758
	    {
4759
	      comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
4760
	      rank = c->as ? c->as->rank : 0;
4761
	      tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
4762
					   rank, purpose);
4763
	      gfc_add_expr_to_block (&fnblock, tmp);
4764
	    }
4765
4766
	  if (c->allocatable)
4767
	    {
4768
	      comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
4769
	      tmp = gfc_trans_dealloc_allocated (comp);
4770
	      gfc_add_expr_to_block (&fnblock, tmp);
4771
	    }
4772
	  break;
4773
4774
	case NULLIFY_ALLOC_COMP:
4775
	  if (c->pointer)
4776
	    continue;
4777
	  else if (c->allocatable)
4778
	    {
4779
	      comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
4780
	      gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
4781
	    }
4782
          else if (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp)
4783
	    {
4784
	      comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
4785
	      rank = c->as ? c->as->rank : 0;
4786
	      tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
4787
					   rank, purpose);
4788
	      gfc_add_expr_to_block (&fnblock, tmp);
4789
	    }
4790
	  break;
4791
4792
	case COPY_ALLOC_COMP:
4793
	  if (c->pointer)
4794
	    continue;
4795
4796
	  comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
4797
	  dcmp = build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
4798
	  dcmp = fold_convert (TREE_TYPE (comp), dcmp);
4799
4800
	  if (c->allocatable)
4801
	    {
4802
	      tree size;
4803
	      tree args;
4804
	      tree null_cond;
4805
	      tree null_data;
4806
	      stmtblock_t block;
4807
4808
	      /* If the source is null, set the destination to null. */
4809
	      gfc_init_block (&block);
4810
	      gfc_conv_descriptor_data_set (&block, dcmp,
4811
					    null_pointer_node);
4812
	      null_data = gfc_finish_block (&block);
4813
4814
	      gfc_init_block (&block);
4815
	      nelems = get_full_array_size (&block, comp, c->as->rank);
4816
	      size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
4817
				  TYPE_SIZE_UNIT (gfc_get_element_type (ctype)));
4818
4819
	      /* Allocate memory to the destination.  */
4820
	      tmp = gfc_chainon_list (NULL_TREE, size);
4821
	      if (gfc_index_integer_kind == 4)
4822
		tmp = build_function_call_expr (gfor_fndecl_internal_malloc, tmp);
4823
	      else if (gfc_index_integer_kind == 8)
4824
		tmp = build_function_call_expr (gfor_fndecl_internal_malloc64, tmp);
4825
	      else
4826
		gcc_unreachable ();
4827
	      tmp = fold (convert (TREE_TYPE (gfc_conv_descriptor_data_get (comp)),
4828
		          tmp));
4829
	      gfc_conv_descriptor_data_set (&block, dcmp, tmp);
4830
4831
	      /* We know the temporary and the value will be the same length,
4832
		 so can use memcpy.  */
4833
	      tmp = gfc_conv_descriptor_data_get (dcmp);
4834
	      args = gfc_chainon_list (NULL_TREE, tmp);
4835
	      tmp = gfc_conv_descriptor_data_get (comp);
4836
	      args = gfc_chainon_list (args, tmp);
4837
	      args = gfc_chainon_list (args, size);
4838
	      tmp = built_in_decls[BUILT_IN_MEMCPY];
4839
	      tmp = build_function_call_expr (tmp, args);
4840
	      gfc_add_expr_to_block (&block, tmp);
4841
	      tmp = gfc_finish_block (&block);
4842
4843
	      /* Null the destination if the source is null; otherwise do
4844
		 the allocate and copy.  */
4845
	      null_cond = gfc_conv_descriptor_data_get (comp);
4846
	      null_cond = convert (pvoid_type_node, null_cond);
4847
	      null_cond = build2 (NE_EXPR, boolean_type_node, null_cond,
4848
				  null_pointer_node);
4849
	      tmp = build3_v (COND_EXPR, null_cond, tmp, null_data);
4850
	      gfc_add_expr_to_block (&fnblock, tmp);
4851
	    }
4852
4853
          if (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp)
4854
	    {
4855
	      rank = c->as ? c->as->rank : 0;
4856
	      tmp = structure_alloc_comps (c->ts.derived, comp, dcmp,
4857
					   rank, purpose);
4858
	      gfc_add_expr_to_block (&fnblock, tmp);
4859
	    }
4860
	  break;
4861
4862
	default:
4863
	  gcc_unreachable ();
4864
	  break;
4865
	}
4866
    }
4867
4868
  return gfc_finish_block (&fnblock);
4869
}
4870
4871
/* Recursively traverse an object of derived type, generating code to
4872
   nullify allocatable components.  */
4873
4874
tree
4875
gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
4876
{
4877
  return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
4878
				NULLIFY_ALLOC_COMP);
4879
}
4880
4881
4882
/* Recursively traverse an object of derived type, generating code to
4883
   deallocate allocatable components.  */
4884
4885
tree
4886
gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
4887
{
4888
  return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
4889
				DEALLOCATE_ALLOC_COMP);
4890
}
4891
4892
4893
/* Recursively traverse an object of derived type, generating code to
4894
   copy its allocatable components.  */
4895
4896
tree
4897
gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
4898
{
4899
  return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
4900
}
4901
4902
4607
/* NULLIFY an allocatable/pointer array on function entry, free it on exit.  */
4903
/* NULLIFY an allocatable/pointer array on function entry, free it on exit.  */
4608
4904
4609
tree
4905
tree
Lines 4614-4629 Link Here
4614
  tree descriptor;
4910
  tree descriptor;
4615
  stmtblock_t fnblock;
4911
  stmtblock_t fnblock;
4616
  locus loc;
4912
  locus loc;
4913
  int rank;
4617
4914
4618
  /* Make sure the frontend gets these right.  */
4915
  /* Make sure the frontend gets these right.  */
4619
  if (!(sym->attr.pointer || sym->attr.allocatable))
4916
  if (!(sym->attr.pointer || sym->attr.allocatable
4620
    fatal_error
4917
	|| (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)))
4621
      ("Possible frontend bug: Deferred array size without pointer or allocatable attribute.");
4918
    fatal_error ("Possible frontend bug: Deferred array size without pointer"
4919
		 "allocatable attribute.");
4622
4920
4623
  gfc_init_block (&fnblock);
4921
  gfc_init_block (&fnblock);
4624
4922
4625
  gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
4923
  gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
4626
                || TREE_CODE (sym->backend_decl) == PARM_DECL);
4924
		|| TREE_CODE (sym->backend_decl) == PARM_DECL);
4627
4925
4628
  if (sym->ts.type == BT_CHARACTER
4926
  if (sym->ts.type == BT_CHARACTER
4629
      && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4927
      && !INTEGER_CST_P (sym->ts.cl->backend_decl))
Lines 4653-4674 Link Here
4653
4951
4654
  /* Get the descriptor type.  */
4952
  /* Get the descriptor type.  */
4655
  type = TREE_TYPE (sym->backend_decl);
4953
  type = TREE_TYPE (sym->backend_decl);
4656
  if (!GFC_DESCRIPTOR_TYPE_P (type))
4954
    
4955
  if (sym->ts.type == BT_DERIVED
4956
	&& sym->ts.derived->attr.alloc_comp
4957
	&& !(sym->attr.pointer || sym->attr.allocatable))
4657
    {
4958
    {
4959
      rank = sym->as ? sym->as->rank : 0;
4960
      tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank);
4961
      gfc_add_expr_to_block (&fnblock, tmp);
4962
    }
4963
  else if (!GFC_DESCRIPTOR_TYPE_P (type))
4964
    {
4658
      /* If the backend_decl is not a descriptor, we must have a pointer
4965
      /* If the backend_decl is not a descriptor, we must have a pointer
4659
	 to one.  */
4966
	 to one.  */
4660
      descriptor = build_fold_indirect_ref (sym->backend_decl);
4967
      descriptor = build_fold_indirect_ref (sym->backend_decl);
4661
      type = TREE_TYPE (descriptor);
4968
      type = TREE_TYPE (descriptor);
4662
      gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
4663
    }
4969
    }
4664
4970
  
4665
  /* NULLIFY the data pointer.  */
4971
  /* NULLIFY the data pointer.  */
4666
  gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
4972
  if (GFC_DESCRIPTOR_TYPE_P (type))
4973
    gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
4667
4974
4668
  gfc_add_expr_to_block (&fnblock, body);
4975
  gfc_add_expr_to_block (&fnblock, body);
4669
4976
4670
  gfc_set_backend_locus (&loc);
4977
  gfc_set_backend_locus (&loc);
4671
  /* Allocatable arrays need to be freed when they go out of scope.  */
4978
4979
  /* Allocatable arrays need to be freed when they go out of scope.
4980
     The allocatable components of pointers must not be touched.  */
4981
  if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp
4982
      && !(sym->attr.function || sym->attr.result)
4983
      && !sym->attr.pointer)
4984
    {
4985
      int rank;
4986
      rank = sym->as ? sym->as->rank : 0;
4987
      tmp = gfc_deallocate_alloc_comp (sym->ts.derived, descriptor, rank);
4988
      gfc_add_expr_to_block (&fnblock, tmp);
4989
    }
4990
4672
  if (sym->attr.allocatable)
4991
  if (sym->attr.allocatable)
4673
    {
4992
    {
4674
      tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
4993
      tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
(-)gcc/fortran/trans-expr.c (-18 / +192 lines)
Lines 42-48 Link Here
42
#include "trans-stmt.h"
42
#include "trans-stmt.h"
43
#include "dependency.h"
43
#include "dependency.h"
44
44
45
static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
45
static tree gfc_trans_structure_assign (gfc_se * outer_se, tree dest, gfc_expr * expr);
46
static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
46
static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
47
						 gfc_expr *);
47
						 gfc_expr *);
48
48
Lines 1702-1708 Link Here
1702
1702
1703
  if (intent != INTENT_OUT)
1703
  if (intent != INTENT_OUT)
1704
    {
1704
    {
1705
      tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
1705
      tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
1706
      gfc_add_expr_to_block (&body, tmp);
1706
      gfc_add_expr_to_block (&body, tmp);
1707
      gcc_assert (rse.ss == gfc_ss_terminator);
1707
      gcc_assert (rse.ss == gfc_ss_terminator);
1708
      gfc_trans_scalarizing_loops (&loop, &body);
1708
      gfc_trans_scalarizing_loops (&loop, &body);
Lines 1787-1793 Link Here
1787
1787
1788
  gcc_assert (lse.ss == gfc_ss_terminator);
1788
  gcc_assert (lse.ss == gfc_ss_terminator);
1789
1789
1790
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
1790
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
1791
  gfc_add_expr_to_block (&body, tmp);
1791
  gfc_add_expr_to_block (&body, tmp);
1792
  
1792
  
1793
  /* Generate the copying loops.  */
1793
  /* Generate the copying loops.  */
Lines 1859-1864 Link Here
1859
  gfc_ss *argss;
1859
  gfc_ss *argss;
1860
  gfc_ss_info *info;
1860
  gfc_ss_info *info;
1861
  int byref;
1861
  int byref;
1862
  int parm_kind;
1862
  tree type;
1863
  tree type;
1863
  tree var;
1864
  tree var;
1864
  tree len;
1865
  tree len;
Lines 1872-1877 Link Here
1872
  gfc_expr *e;
1873
  gfc_expr *e;
1873
  gfc_symbol *fsym;
1874
  gfc_symbol *fsym;
1874
  stmtblock_t post;
1875
  stmtblock_t post;
1876
  enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
1875
1877
1876
  arglist = NULL_TREE;
1878
  arglist = NULL_TREE;
1877
  retargs = NULL_TREE;
1879
  retargs = NULL_TREE;
Lines 1914-1919 Link Here
1914
    {
1916
    {
1915
      e = arg->expr;
1917
      e = arg->expr;
1916
      fsym = formal ? formal->sym : NULL;
1918
      fsym = formal ? formal->sym : NULL;
1919
      parm_kind = MISSING;
1917
      if (e == NULL)
1920
      if (e == NULL)
1918
	{
1921
	{
1919
1922
Lines 1942-1947 Link Here
1942
	  /* An elemental function inside a scalarized loop.  */
1945
	  /* An elemental function inside a scalarized loop.  */
1943
          gfc_init_se (&parmse, se);
1946
          gfc_init_se (&parmse, se);
1944
          gfc_conv_expr_reference (&parmse, e);
1947
          gfc_conv_expr_reference (&parmse, e);
1948
	  parm_kind = ELEMENTAL;
1945
	}
1949
	}
1946
      else
1950
      else
1947
	{
1951
	{
Lines 1952-1963 Link Here
1952
	  if (argss == gfc_ss_terminator)
1956
	  if (argss == gfc_ss_terminator)
1953
            {
1957
            {
1954
	      gfc_conv_expr_reference (&parmse, e);
1958
	      gfc_conv_expr_reference (&parmse, e);
1959
	      parm_kind = SCALAR;
1955
              if (fsym && fsym->attr.pointer
1960
              if (fsym && fsym->attr.pointer
1956
		  && e->expr_type != EXPR_NULL)
1961
		  && e->expr_type != EXPR_NULL)
1957
                {
1962
                {
1958
                  /* Scalar pointer dummy args require an extra level of
1963
                  /* Scalar pointer dummy args require an extra level of
1959
		  indirection. The null pointer already contains
1964
		  indirection. The null pointer already contains
1960
		  this level of indirection.  */
1965
		  this level of indirection.  */
1966
		  parm_kind = SCALAR_POINTER;
1961
                  parmse.expr = build_fold_addr_expr (parmse.expr);
1967
                  parmse.expr = build_fold_addr_expr (parmse.expr);
1962
                }
1968
                }
1963
            }
1969
            }
Lines 2014-2019 Link Here
2014
      gfc_add_block_to_block (&se->pre, &parmse.pre);
2020
      gfc_add_block_to_block (&se->pre, &parmse.pre);
2015
      gfc_add_block_to_block (&post, &parmse.post);
2021
      gfc_add_block_to_block (&post, &parmse.post);
2016
2022
2023
      /* Allocated allocatable components of derived types must be
2024
	 deallocated for INTENT(OUT) dummy arguments and non-variable
2025
         scalars.  Non-variable arrays are dealt with in trans-array.c
2026
         (gfc_conv_array_parameter).  */
2027
      if (e && e->ts.type == BT_DERIVED
2028
	    && e->ts.derived->attr.alloc_comp
2029
	    && ((formal && formal->sym->attr.intent == INTENT_OUT)
2030
		   ||
2031
		(e->expr_type != EXPR_VARIABLE && !e->rank)))
2032
        {
2033
	  int parm_rank;
2034
	  tmp = build_fold_indirect_ref (parmse.expr);
2035
	  parm_rank = e->rank;
2036
	  switch (parm_kind)
2037
	    {
2038
	    case (ELEMENTAL):
2039
	    case (SCALAR):
2040
	      parm_rank = 0;
2041
	      break;
2042
2043
	    case (SCALAR_POINTER):
2044
              tmp = build_fold_indirect_ref (tmp);
2045
	      break;
2046
	    case (ARRAY):
2047
              tmp = parmse.expr;
2048
	      break;
2049
	    }
2050
2051
          tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
2052
	  if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
2053
	    tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym),
2054
			    tmp, build_empty_stmt ());
2055
2056
	  if (e->expr_type != EXPR_VARIABLE)
2057
	    /* Don't deallocate non-variables until they have been used.  */
2058
	    gfc_add_expr_to_block (&se->post, tmp);
2059
	  else 
2060
	    {
2061
	      gcc_assert (formal && formal->sym->attr.intent == INTENT_OUT);
2062
	      gfc_add_expr_to_block (&se->pre, tmp);
2063
	    }
2064
        }
2065
2017
      /* Character strings are passed as two parameters, a length and a
2066
      /* Character strings are passed as two parameters, a length and a
2018
         pointer.  */
2067
         pointer.  */
2019
      if (parmse.string_length != NULL_TREE)
2068
      if (parmse.string_length != NULL_TREE)
Lines 2590-2596 Link Here
2590
2639
2591
  gfc_conv_expr (&rse, expr);
2640
  gfc_conv_expr (&rse, expr);
2592
2641
2593
  tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
2642
  tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
2594
  gfc_add_expr_to_block (&body, tmp);
2643
  gfc_add_expr_to_block (&body, tmp);
2595
2644
2596
  gcc_assert (rse.ss == gfc_ss_terminator);
2645
  gcc_assert (rse.ss == gfc_ss_terminator);
Lines 2614-2627 Link Here
2614
/* Assign a single component of a derived type constructor.  */
2663
/* Assign a single component of a derived type constructor.  */
2615
2664
2616
static tree
2665
static tree
2617
gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2666
gfc_trans_subcomponent_assign (gfc_se * outer_se, tree dest,
2667
			       gfc_component * cm, gfc_expr * expr)
2618
{
2668
{
2619
  gfc_se se;
2669
  gfc_se se;
2670
  gfc_se lse;
2620
  gfc_ss *rss;
2671
  gfc_ss *rss;
2621
  stmtblock_t block;
2672
  stmtblock_t block;
2622
  tree tmp;
2673
  tree tmp;
2674
  tree offset;
2675
  int n;
2623
2676
2624
  gfc_start_block (&block);
2677
  gfc_start_block (&block);
2678
2679
#if 0
2680
  if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
2681
    gfc_todo_error ("derived types with allocatable components as "
2682
		    "arguments of derived type constructors");
2683
#endif
2625
  if (cm->pointer)
2684
  if (cm->pointer)
2626
    {
2685
    {
2627
      gfc_init_se (&se, NULL);
2686
      gfc_init_se (&se, NULL);
Lines 2654-2673 Link Here
2654
    }
2713
    }
2655
  else if (cm->dimension)
2714
  else if (cm->dimension)
2656
    {
2715
    {
2657
      tmp = gfc_trans_subarray_assign (dest, cm, expr);
2716
      if (cm->allocatable && expr->expr_type == EXPR_NULL)
2658
      gfc_add_expr_to_block (&block, tmp);
2717
	gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
2718
      else if (cm->allocatable)
2719
	{
2720
	  tree tmp2;
2721
2722
	  gfc_init_se (&se, NULL);
2723
	  gfc_init_se (&lse, NULL);
2724
2725
	  se.want_pointer = 0;
2726
	  gfc_conv_expr_descriptor (&se, expr, gfc_walk_expr (expr));
2727
	  if (cm->ts.type == BT_CHARACTER)
2728
	    lse.string_length = cm->ts.cl->backend_decl;
2729
2730
	  lse.expr = dest;
2731
2732
	  /* Clean up temporaries at the right time.  */
2733
	  if (expr->expr_type == EXPR_FUNCTION)
2734
	    {
2735
	      stmtblock_t tmp_block;
2736
2737
	      /* Prevent the freeing of the memory after the array assignment to
2738
		 the derived type component....  */
2739
	      gfc_init_block (&tmp_block);
2740
	      gfc_add_block_to_block (&tmp_block, &se.post);
2741
	      gfc_conv_descriptor_data_set (&se.post, se.expr, null_pointer_node);
2742
	      gfc_add_block_to_block (&se.post, &tmp_block);
2743
2744
	      /* ...and do it when the derived type is completed.  */
2745
	      tmp = gfc_conv_descriptor_data_get (lse.expr);
2746
	      tmp = convert (pvoid_type_node, tmp);
2747
	      tmp = gfc_chainon_list (NULL_TREE, tmp);
2748
	      tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
2749
	      gfc_add_expr_to_block (&outer_se->post, tmp);
2750
	    }
2751
2752
	  tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
2753
	  gfc_add_expr_to_block (&block, tmp);
2754
2755
	  /* Shift the lbound and ubound of temporaries to being unity, rather
2756
	     than zero, based.  Calculate the offset for all cases.  */
2757
	  offset = gfc_conv_descriptor_offset (dest);
2758
	  gfc_add_modify_expr (&block, offset, gfc_index_zero_node);
2759
	  tmp2 =gfc_create_var (gfc_array_index_type, NULL);
2760
	  for (n = 0; n < expr->rank; n++)
2761
	    {
2762
	      if (expr->expr_type != EXPR_VARIABLE
2763
		    && expr->expr_type != EXPR_CONSTANT)
2764
		{
2765
		  tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
2766
		  gfc_add_modify_expr (&block, tmp,
2767
				       fold_build2 (PLUS_EXPR, gfc_array_index_type,
2768
						    tmp, gfc_index_one_node));
2769
		  tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
2770
		  gfc_add_modify_expr (&block, tmp, gfc_index_one_node);
2771
		}
2772
	      tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2773
				 gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]),
2774
				 gfc_conv_descriptor_stride (dest, gfc_rank_cst[n]));
2775
	      gfc_add_modify_expr (&block, tmp2, tmp);
2776
	      tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
2777
	      gfc_add_modify_expr (&block, offset, tmp);
2778
	    }  
2779
	}
2780
      else
2781
	{
2782
	  tmp = gfc_trans_subarray_assign (dest, cm, expr);
2783
	  gfc_add_expr_to_block (&block, tmp);
2784
	}
2659
    }
2785
    }
2660
  else if (expr->ts.type == BT_DERIVED)
2786
  else if (expr->ts.type == BT_DERIVED)
2661
    {
2787
    {
2662
      /* Nested derived type.  */
2788
      /* Nested derived type.  */
2663
      tmp = gfc_trans_structure_assign (dest, expr);
2789
      tmp = gfc_trans_structure_assign (outer_se, dest, expr);
2664
      gfc_add_expr_to_block (&block, tmp);
2790
      gfc_add_expr_to_block (&block, tmp);
2665
    }
2791
    }
2666
  else
2792
  else
2667
    {
2793
    {
2668
      /* Scalar component.  */
2794
      /* Scalar component.  */
2669
      gfc_se lse;
2670
2671
      gfc_init_se (&se, NULL);
2795
      gfc_init_se (&se, NULL);
2672
      gfc_init_se (&lse, NULL);
2796
      gfc_init_se (&lse, NULL);
2673
2797
Lines 2675-2681 Link Here
2675
      if (cm->ts.type == BT_CHARACTER)
2799
      if (cm->ts.type == BT_CHARACTER)
2676
	lse.string_length = cm->ts.cl->backend_decl;
2800
	lse.string_length = cm->ts.cl->backend_decl;
2677
      lse.expr = dest;
2801
      lse.expr = dest;
2678
      tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type);
2802
      tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
2679
      gfc_add_expr_to_block (&block, tmp);
2803
      gfc_add_expr_to_block (&block, tmp);
2680
    }
2804
    }
2681
  return gfc_finish_block (&block);
2805
  return gfc_finish_block (&block);
Lines 2684-2690 Link Here
2684
/* Assign a derived type constructor to a variable.  */
2808
/* Assign a derived type constructor to a variable.  */
2685
2809
2686
static tree
2810
static tree
2687
gfc_trans_structure_assign (tree dest, gfc_expr * expr)
2811
gfc_trans_structure_assign (gfc_se * outer_se, tree dest, gfc_expr * expr)
2688
{
2812
{
2689
  gfc_constructor *c;
2813
  gfc_constructor *c;
2690
  gfc_component *cm;
2814
  gfc_component *cm;
Lines 2702-2708 Link Here
2702
2826
2703
      field = cm->backend_decl;
2827
      field = cm->backend_decl;
2704
      tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
2828
      tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
2705
      tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
2829
      tmp = gfc_trans_subcomponent_assign (outer_se, tmp, cm, c->expr);
2706
      gfc_add_expr_to_block (&block, tmp);
2830
      gfc_add_expr_to_block (&block, tmp);
2707
    }
2831
    }
2708
  return gfc_finish_block (&block);
2832
  return gfc_finish_block (&block);
Lines 2729-2735 Link Here
2729
    {
2853
    {
2730
      /* Create a temporary variable and fill it in.  */
2854
      /* Create a temporary variable and fill it in.  */
2731
      se->expr = gfc_create_var (type, expr->ts.derived->name);
2855
      se->expr = gfc_create_var (type, expr->ts.derived->name);
2732
      tmp = gfc_trans_structure_assign (se->expr, expr);
2856
      tmp = gfc_trans_structure_assign (se, se->expr, expr);
2733
      gfc_add_expr_to_block (&se->pre, tmp);
2857
      gfc_add_expr_to_block (&se->pre, tmp);
2734
      return;
2858
      return;
2735
    }
2859
    }
Lines 3036-3048 Link Here
3036
   strings.  */
3160
   strings.  */
3037
3161
3038
tree
3162
tree
3039
gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
3163
gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
3164
			 bool l_is_temp, bool r_is_var)
3040
{
3165
{
3041
  stmtblock_t block;
3166
  stmtblock_t block;
3167
  tree tmp;
3168
  tree cond;
3042
3169
3043
  gfc_init_block (&block);
3170
  gfc_init_block (&block);
3044
3171
3045
  if (type == BT_CHARACTER)
3172
  if (ts.type == BT_CHARACTER)
3046
    {
3173
    {
3047
      gcc_assert (lse->string_length != NULL_TREE
3174
      gcc_assert (lse->string_length != NULL_TREE
3048
	      && rse->string_length != NULL_TREE);
3175
	      && rse->string_length != NULL_TREE);
Lines 3056-3061 Link Here
3056
      gfc_trans_string_copy (&block, lse->string_length, lse->expr,
3183
      gfc_trans_string_copy (&block, lse->string_length, lse->expr,
3057
			     rse->string_length, rse->expr);
3184
			     rse->string_length, rse->expr);
3058
    }
3185
    }
3186
  else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
3187
    {
3188
      cond = NULL_TREE;
3189
3190
      /* Are the rhs and the lhs the same?  */
3191
      if (r_is_var)
3192
	{
3193
	  cond = fold_build2 (EQ_EXPR, boolean_type_node,
3194
			      build_fold_addr_expr (lse->expr),
3195
			      build_fold_addr_expr (rse->expr));
3196
	  cond = gfc_evaluate_now (cond, &lse->pre);
3197
	}
3198
3199
      /* Deallocate the lhs allocated components as long as it is not
3200
	 the same as the rhs.  */
3201
      if (!l_is_temp)
3202
	{
3203
	  tmp = gfc_deallocate_alloc_comp (ts.derived, lse->expr, 0);
3204
	  if (r_is_var)
3205
	    tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
3206
	  gfc_add_expr_to_block (&lse->pre, tmp);
3207
	}
3208
	
3209
      gfc_add_block_to_block (&block, &lse->pre);
3210
      gfc_add_block_to_block (&block, &rse->pre);
3211
3212
      gfc_add_modify_expr (&block, lse->expr,
3213
			   fold_convert (TREE_TYPE (lse->expr), rse->expr));
3214
3215
      /* Do a deep copy if the rhs is a variable, as long as it is not the
3216
	 same as the lhs.  Otherwise, nullify the data fields so that the
3217
	 lhs retains the allocated resources.  */
3218
      if (r_is_var)
3219
	{
3220
	  tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
3221
	  tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
3222
	  gfc_add_expr_to_block (&block, tmp);
3223
	}
3224
      else
3225
	{
3226
	  tmp = gfc_nullify_alloc_comp (ts.derived, rse->expr, 0);
3227
	  gfc_add_expr_to_block (&block, tmp);
3228
	}
3229
    }
3059
  else
3230
  else
3060
    {
3231
    {
3061
      gfc_add_block_to_block (&block, &lse->pre);
3232
      gfc_add_block_to_block (&block, &lse->pre);
Lines 3250-3256 Link Here
3250
  else
3421
  else
3251
    gfc_conv_expr (&lse, expr1);
3422
    gfc_conv_expr (&lse, expr1);
3252
3423
3253
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
3424
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
3425
				 loop.temp_ss != NULL,
3426
				 expr2->expr_type == EXPR_VARIABLE);
3254
  gfc_add_expr_to_block (&body, tmp);
3427
  gfc_add_expr_to_block (&body, tmp);
3255
3428
3256
  if (lss == gfc_ss_terminator)
3429
  if (lss == gfc_ss_terminator)
Lines 3283-3291 Link Here
3283
	  gcc_assert (lse.ss == gfc_ss_terminator
3456
	  gcc_assert (lse.ss == gfc_ss_terminator
3284
		      && rse.ss == gfc_ss_terminator);
3457
		      && rse.ss == gfc_ss_terminator);
3285
3458
3286
	  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
3459
	  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false);
3287
	  gfc_add_expr_to_block (&body, tmp);
3460
	  gfc_add_expr_to_block (&body, tmp);
3288
	}
3461
	}
3462
3289
      /* Generate the copying loops.  */
3463
      /* Generate the copying loops.  */
3290
      gfc_trans_scalarizing_loops (&loop, &body);
3464
      gfc_trans_scalarizing_loops (&loop, &body);
3291
3465
(-)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 (-8 / +38 lines)
Lines 963-979 Link Here
963
963
964
  /* Check array components.  */
964
  /* Check array components.  */
965
  if (!c->dimension)
965
  if (!c->dimension)
966
    return SUCCESS;
966
    {
967
      if (c->allocatable)
968
	{
969
	  gfc_error ("Allocatable component at %C must be an array");
970
	  return FAILURE;
971
	}
972
      else
973
	return SUCCESS;
974
    }
967
975
968
  if (c->pointer)
976
  if (c->pointer)
969
    {
977
    {
970
      if (c->as->type != AS_DEFERRED)
978
      if (c->as->type != AS_DEFERRED)
971
	{
979
	{
972
	  gfc_error ("Pointer array component of structure at %C "
980
	  gfc_error ("Pointer array component of structure at %C must have a "
973
		     "must have a deferred shape");
981
		     "deferred shape");
974
	  return FAILURE;
982
	  return FAILURE;
975
	}
983
	}
976
    }
984
    }
985
  else if (c->allocatable)
986
    {
987
      if (c->as->type != AS_DEFERRED)
988
	{
989
	  gfc_error ("Allocatable component of structure at %C must have a "
990
		     "deferred shape");
991
	  return FAILURE;
992
	}
993
    }
977
  else
994
  else
978
    {
995
    {
979
      if (c->as->type != AS_EXPLICIT)
996
      if (c->as->type != AS_EXPLICIT)
Lines 2142-2152 Link Here
2142
	  && d != DECL_DIMENSION && d != DECL_POINTER
2159
	  && d != DECL_DIMENSION && d != DECL_POINTER
2143
	  && d != DECL_COLON && d != DECL_NONE)
2160
	  && d != DECL_COLON && d != DECL_NONE)
2144
	{
2161
	{
2145
2162
	  if (d == DECL_ALLOCATABLE)
2146
	  gfc_error ("Attribute at %L is not allowed in a TYPE definition",
2163
	    {
2147
		     &seen_at[d]);
2164
	      if (gfc_notify_std (GFC_STD_F2003, 
2148
	  m = MATCH_ERROR;
2165
				   "In the selected standard, the ALLOCATABLE "
2149
	  goto cleanup;
2166
				   "attribute at %C is not allowed in a TYPE "
2167
				   "definition") == FAILURE)         
2168
		{
2169
		  m = MATCH_ERROR;
2170
		  goto cleanup;
2171
		}
2172
            }
2173
          else
2174
	    {
2175
	      gfc_error ("Attribute at %L is not allowed in a TYPE definition",
2176
			  &seen_at[d]);
2177
	      m = MATCH_ERROR;
2178
	      goto cleanup;
2179
	    }
2150
	}
2180
	}
2151
2181
2152
      if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
2182
      if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
(-)gcc/fortran/trans-array.h (+7 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_nullify_alloc_comp (gfc_symbol *, tree, int);
48
49
tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int);
50
51
tree gfc_copy_alloc_comp (gfc_symbol *, tree, tree, int);
52
46
/* Add initialization for deferred arrays.  */
53
/* Add initialization for deferred arrays.  */
47
tree gfc_trans_deferred_array (gfc_symbol *, tree);
54
tree gfc_trans_deferred_array (gfc_symbol *, tree);
48
/* Generate an initializer for a static pointer or allocatable array.  */
55
/* Generate an initializer for a static pointer or allocatable array.  */
(-)gcc/fortran/gfortran.texi (-3 / +7 lines)
Lines 1346-1352 Link Here
1346
@itemize
1346
@itemize
1347
@item 
1347
@item 
1348
Intrinsics @code{command_argument_count}, @code{get_command},
1348
Intrinsics @code{command_argument_count}, @code{get_command},
1349
@code{get_command_argument}, and @code{get_environment_variable}.
1349
@code{get_command_argument}, @code{get_environment_variable}, and
1350
@code{move_alloc}.
1350
1351
1351
@item 
1352
@item 
1352
@cindex Array constructors
1353
@cindex Array constructors
Lines 1373-1386 Link Here
1373
1374
1374
@item
1375
@item
1375
@cindex TR 15581
1376
@cindex TR 15581
1376
The following parts of TR 15581:
1377
TR 15581:
1377
@itemize
1378
@itemize
1378
@item
1379
@item
1379
@cindex @code{ALLOCATABLE} dummy arguments
1380
@cindex @code{ALLOCATABLE} dummy arguments
1380
The @code{ALLOCATABLE} attribute for dummy arguments.
1381
@code{ALLOCATABLE} dummy arguments.
1381
@item
1382
@item
1382
@cindex @code{ALLOCATABLE} function results
1383
@cindex @code{ALLOCATABLE} function results
1383
@code{ALLOCATABLE} function results
1384
@code{ALLOCATABLE} function results
1385
@item
1386
@cindex @code{ALLOCATABLE} components of derived types
1387
@code{ALLOCATABLE} components of derived types
1384
@end itemize
1388
@end itemize
1385
1389
1386
@end itemize
1390
@end itemize
(-)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 / +35 lines)
Lines 1796-1802 Link Here
1796
      gfc_conv_expr (&lse, expr);
1796
      gfc_conv_expr (&lse, expr);
1797
1797
1798
      /* Use the scalar assignment.  */
1798
      /* Use the scalar assignment.  */
1799
      tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
1799
      tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
1800
1800
1801
      /* Form the mask expression according to the mask tree list.  */
1801
      /* Form the mask expression according to the mask tree list.  */
1802
      if (wheremask)
1802
      if (wheremask)
Lines 1891-1897 Link Here
1891
    }
1891
    }
1892
1892
1893
  /* Use the scalar assignment.  */
1893
  /* Use the scalar assignment.  */
1894
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts.type);
1894
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts, false, false);
1895
1895
1896
  /* Form the mask expression according to the mask tree list.  */
1896
  /* Form the mask expression according to the mask tree list.  */
1897
  if (wheremask)
1897
  if (wheremask)
Lines 2972-2978 Link Here
2972
    maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr);
2972
    maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr);
2973
2973
2974
  /* Use the scalar assignment as is.  */
2974
  /* Use the scalar assignment as is.  */
2975
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2975
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
2976
				 loop.temp_ss != NULL, false);
2976
  tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
2977
  tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
2977
2978
2978
  gfc_add_expr_to_block (&body, tmp);
2979
  gfc_add_expr_to_block (&body, tmp);
Lines 3025-3031 Link Here
3025
				    maskexpr);
3026
				    maskexpr);
3026
3027
3027
          /* Use the scalar assignment as is.  */
3028
          /* Use the scalar assignment as is.  */
3028
          tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
3029
          tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false);
3029
          tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
3030
          tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
3030
          gfc_add_expr_to_block (&body, tmp);
3031
          gfc_add_expr_to_block (&body, tmp);
3031
3032
Lines 3400-3407 Link Here
3400
        gfc_conv_expr (&edse, edst);
3401
        gfc_conv_expr (&edse, edst);
3401
    }
3402
    }
3402
3403
3403
  tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts.type);
3404
  tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, false);
3404
  estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts.type)
3405
  estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts, false, false)
3405
		 : build_empty_stmt ();
3406
		 : build_empty_stmt ();
3406
  tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
3407
  tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
3407
  gfc_add_expr_to_block (&body, tmp);
3408
  gfc_add_expr_to_block (&body, tmp);
Lines 3585-3590 Link Here
3585
				 parm, tmp, build_empty_stmt ());
3586
				 parm, tmp, build_empty_stmt ());
3586
	      gfc_add_expr_to_block (&se.pre, tmp);
3587
	      gfc_add_expr_to_block (&se.pre, tmp);
3587
	    }
3588
	    }
3589
3590
	  if (expr->ts.type == BT_DERIVED && expr->ts.derived->attr.alloc_comp)
3591
	    {
3592
	      tmp = build_fold_indirect_ref (se.expr);
3593
	      tmp = gfc_nullify_alloc_comp (expr->ts.derived, tmp, 0);
3594
	      gfc_add_expr_to_block (&se.pre, tmp);
3595
	    }
3596
3588
	}
3597
	}
3589
3598
3590
      tmp = gfc_finish_block (&se.pre);
3599
      tmp = gfc_finish_block (&se.pre);
Lines 3669-3674 Link Here
3669
      se.descriptor_only = 1;
3678
      se.descriptor_only = 1;
3670
      gfc_conv_expr (&se, expr);
3679
      gfc_conv_expr (&se, expr);
3671
3680
3681
      if (expr->ts.type == BT_DERIVED
3682
	    && expr->ts.derived->attr.alloc_comp)
3683
        {
3684
	  gfc_ref *ref;
3685
	  gfc_ref *last = NULL;
3686
	  for (ref = expr->ref; ref; ref = ref->next)
3687
	    if (ref->type == REF_COMPONENT)
3688
	      last = ref;
3689
3690
	  /* Do not deallocate the components of a derived type
3691
	     ultimate pointer component.  */
3692
	  if (!(last && last->u.c.component->pointer)
3693
		   && !(!last && expr->symtree->n.sym->attr.pointer))
3694
	    {
3695
	      tmp = gfc_deallocate_alloc_comp (expr->ts.derived, se.expr,
3696
						expr->rank);
3697
	      gfc_add_expr_to_block (&se.pre, tmp);
3698
	    }
3699
	}
3700
3672
      if (expr->rank)
3701
      if (expr->rank)
3673
	tmp = gfc_array_deallocate (se.expr, pstat);
3702
	tmp = gfc_array_deallocate (se.expr, pstat);
3674
      else
3703
      else
(-)gcc/fortran/module.c (-1 / +10 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 ("CRAY_POINTEE", AB_CRAY_POINTEE),
1469
    minit ("ALLOC_COMP", AB_ALLOC_COMP),
1468
    minit (NULL, -1)
1470
    minit (NULL, -1)
1469
};
1471
};
1470
1472
Lines 1556-1561 Link Here
1556
      if (attr->cray_pointee)
1558
      if (attr->cray_pointee)
1557
	MIO_NAME(ab_attribute) (AB_CRAY_POINTEE, attr_bits);
1559
	MIO_NAME(ab_attribute) (AB_CRAY_POINTEE, attr_bits);
1558
1560
1561
      if (attr->alloc_comp)
1562
	MIO_NAME(ab_attribute) (AB_ALLOC_COMP, attr_bits);
1563
1559
      mio_rparen ();
1564
      mio_rparen ();
1560
1565
1561
    }
1566
    }
Lines 1644-1649 Link Here
1644
	    case AB_CRAY_POINTEE:
1649
	    case AB_CRAY_POINTEE:
1645
	      attr->cray_pointee = 1;
1650
	      attr->cray_pointee = 1;
1646
	      break;
1651
	      break;
1652
	    case AB_ALLOC_COMP:
1653
	      attr->alloc_comp = 1;
1654
	      break;
1647
	    }
1655
	    }
1648
	}
1656
	}
1649
    }
1657
    }
Lines 1951-1956 Link Here
1951
1959
1952
  mio_integer (&c->dimension);
1960
  mio_integer (&c->dimension);
1953
  mio_integer (&c->pointer);
1961
  mio_integer (&c->pointer);
1962
  mio_integer (&c->allocatable);
1954
1963
1955
  mio_expr (&c->initializer);
1964
  mio_expr (&c->initializer);
1956
  mio_rparen ();
1965
  mio_rparen ();
(-)gcc/fortran/trans-types.c (-1 / +1 lines)
Lines 1547-1553 Link Here
1547
         required.  */
1547
         required.  */
1548
      if (c->dimension)
1548
      if (c->dimension)
1549
	{
1549
	{
1550
	  if (c->pointer)
1550
	  if (c->pointer || c->allocatable)
1551
	    {
1551
	    {
1552
	      /* Pointers to arrays aren't actually pointer types.  The
1552
	      /* Pointers to arrays aren't actually pointer types.  The
1553
	         descriptors are separate, but the data is common.  */
1553
	         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 (-10 / +15 lines)
Lines 912-924 Link Here
912
912
913
913
914
/* Do the checks of the actual argument list that are specific to elemental
914
/* Do the checks of the actual argument list that are specific to elemental
915
   procedures.  If called with c == NULL, we have a function, otherwise if
915
   procedures.  */
916
   expr == NULL, we have a subroutine.  */
917
static try
916
static try
918
resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
917
resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
919
{
918
{
920
  gfc_actual_arglist *arg0;
919
  gfc_actual_arglist * arg0;
921
  gfc_actual_arglist *arg;
920
  gfc_actual_arglist * arg;
922
  gfc_symbol *esym = NULL;
921
  gfc_symbol *esym = NULL;
923
  gfc_intrinsic_sym *isym = NULL;
922
  gfc_intrinsic_sym *isym = NULL;
924
  gfc_expr *e = NULL;
923
  gfc_expr *e = NULL;
Lines 929-935 Link Here
929
  int i;
928
  int i;
930
  int rank = 0;
929
  int rank = 0;
931
930
932
  /* Is this an elemental procedure?  */
933
  if (expr && expr->value.function.actual != NULL)
931
  if (expr && expr->value.function.actual != NULL)
934
    {
932
    {
935
      if (expr->value.function.esym != NULL
933
      if (expr->value.function.esym != NULL
Lines 966-972 Link Here
966
		&& arg->expr->symtree->n.sym->attr.optional)
964
		&& arg->expr->symtree->n.sym->attr.optional)
967
	    set_by_optional = true;
965
	    set_by_optional = true;
968
966
969
	  /* Function specific; set the result rank and shape.  */
967
	  /* Function specific.  */
970
	  if (expr)
968
	  if (expr)
971
	    {
969
	    {
972
	      expr->rank = rank;
970
	      expr->rank = rank;
Lines 3303-3309 Link Here
3303
3301
3304
/* Given the expression node e for an allocatable/pointer of derived type to be
3302
/* Given the expression node e for an allocatable/pointer of derived type to be
3305
   allocated, get the expression node to be initialized afterwards (needed for
3303
   allocated, get the expression node to be initialized afterwards (needed for
3306
   derived types with default initializers).  */
3304
   derived types with default initializers, and derived types with allocatable
3305
   components that need nullification.)  */
3307
3306
3308
static gfc_expr *
3307
static gfc_expr *
3309
expr_to_initialize (gfc_expr * e)
3308
expr_to_initialize (gfc_expr * e)
Lines 3412-3419 Link Here
3412
        init_st->loc = code->loc;
3411
        init_st->loc = code->loc;
3413
        init_st->op = EXEC_ASSIGN;
3412
        init_st->op = EXEC_ASSIGN;
3414
        init_st->expr = expr_to_initialize (e);
3413
        init_st->expr = expr_to_initialize (e);
3415
        init_st->expr2 = init_e;
3414
	init_st->expr2 = init_e;
3416
3417
        init_st->next = code->next;
3415
        init_st->next = code->next;
3418
        code->next = init_st;
3416
        code->next = init_st;
3419
    }
3417
    }
Lines 4022-4027 Link Here
4022
	  return;
4020
	  return;
4023
	}
4021
	}
4024
4022
4023
      if (ts->derived->attr.alloc_comp)
4024
	{
4025
	  gfc_error ("Data transfer element at %L cannot have "
4026
		     "ALLOCATABLE components", &code->loc);
4027
	  return;
4028
	}
4029
4025
      if (derived_inaccessible (ts->derived))
4030
      if (derived_inaccessible (ts->derived))
4026
	{
4031
	{
4027
	  gfc_error ("Data transfer element at %L cannot have "
4032
	  gfc_error ("Data transfer element at %L cannot have "
Lines 5403-5409 Link Here
5403
	    }
5408
	    }
5404
	}
5409
	}
5405
5410
5406
      if (c->pointer || c->as == NULL)
5411
      if (c->pointer || c->allocatable ||  c->as == NULL)
5407
	continue;
5412
	continue;
5408
5413
5409
      for (i = 0; i < c->as->rank; i++)
5414
      for (i = 0; i < c->as->rank; i++)
(-)gcc/fortran/trans-decl.c (-3 / +27 lines)
Lines 945-950 Link Here
945
	GFC_DECL_PACKED_ARRAY (decl) = 1;
945
	GFC_DECL_PACKED_ARRAY (decl) = 1;
946
    }
946
    }
947
947
948
  if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
949
    gfc_defer_symbol_init (sym);
950
948
  gfc_finish_var_decl (decl, sym);
951
  gfc_finish_var_decl (decl, sym);
949
952
950
  if (sym->ts.type == BT_CHARACTER)
953
  if (sym->ts.type == BT_CHARACTER)
Lines 2587-2599 Link Here
2587
	      break;
2590
	      break;
2588
2591
2589
	    case AS_DEFERRED:
2592
	    case AS_DEFERRED:
2590
	      fnbody = gfc_trans_deferred_array (sym, fnbody);
2593
	      if (!(sym->ts.type == BT_DERIVED
2594
		      && sym->ts.derived->attr.alloc_comp))
2595
		fnbody = gfc_trans_deferred_array (sym, fnbody);
2591
	      break;
2596
	      break;
2592
2597
2593
	    default:
2598
	    default:
2594
	      gcc_unreachable ();
2599
	      gcc_unreachable ();
2595
	    }
2600
	    }
2601
	  if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
2602
	    fnbody = gfc_trans_deferred_array (sym, fnbody);
2596
	}
2603
	}
2604
      else if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
2605
	fnbody = gfc_trans_deferred_array (sym, fnbody);
2597
      else if (sym->ts.type == BT_CHARACTER)
2606
      else if (sym->ts.type == BT_CHARACTER)
2598
	{
2607
	{
2599
	  gfc_get_backend_locus (&loc);
2608
	  gfc_get_backend_locus (&loc);
Lines 2829-2838 Link Here
2829
  tree old_context;
2838
  tree old_context;
2830
  tree decl;
2839
  tree decl;
2831
  tree tmp;
2840
  tree tmp;
2841
  tree tmp2;
2832
  stmtblock_t block;
2842
  stmtblock_t block;
2833
  stmtblock_t body;
2843
  stmtblock_t body;
2834
  tree result;
2844
  tree result;
2835
  gfc_symbol *sym;
2845
  gfc_symbol *sym;
2846
  int rank;
2836
2847
2837
  sym = ns->proc_name;
2848
  sym = ns->proc_name;
2838
2849
Lines 2992-2998 Link Here
2992
  tmp = gfc_finish_block (&body);
3003
  tmp = gfc_finish_block (&body);
2993
  /* Add code to create and cleanup arrays.  */
3004
  /* Add code to create and cleanup arrays.  */
2994
  tmp = gfc_trans_deferred_vars (sym, tmp);
3005
  tmp = gfc_trans_deferred_vars (sym, tmp);
2995
  gfc_add_expr_to_block (&block, tmp);
2996
3006
2997
  if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
3007
  if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
2998
    {
3008
    {
Lines 3007-3013 Link Here
3007
      else
3017
      else
3008
	result = sym->result->backend_decl;
3018
	result = sym->result->backend_decl;
3009
3019
3010
      if (result == NULL_TREE)
3020
      if (result != NULL_TREE && sym->attr.function
3021
	    && sym->ts.type == BT_DERIVED
3022
	    && sym->ts.derived->attr.alloc_comp)
3023
	{
3024
	  rank = sym->as ? sym->as->rank : 0;
3025
	  tmp2 = gfc_nullify_alloc_comp (sym->ts.derived, result, rank);
3026
	  gfc_add_expr_to_block (&block, tmp2);
3027
	}
3028
3029
     gfc_add_expr_to_block (&block, tmp);
3030
3031
     if (result == NULL_TREE)
3011
	warning (0, "Function return value not set");
3032
	warning (0, "Function return value not set");
3012
      else
3033
      else
3013
	{
3034
	{
Lines 3018-3024 Link Here
3018
	  gfc_add_expr_to_block (&block, tmp);
3039
	  gfc_add_expr_to_block (&block, tmp);
3019
	}
3040
	}
3020
    }
3041
    }
3042
  else
3043
    gfc_add_expr_to_block (&block, tmp);
3021
3044
3045
3022
  /* Add all the decls we created during processing.  */
3046
  /* Add all the decls we created during processing.  */
3023
  decl = saved_function_decls;
3047
  decl = saved_function_decls;
3024
  while (decl)
3048
  while (decl)
(-)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-1820 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;
1817
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
}
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)
1820
{
1881
{
(-)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 112-117 Link Here
112
* @code{MINEXPONENT}:   MINEXPONENT, Minimum exponent of a real kind
112
* @code{MINEXPONENT}:   MINEXPONENT, Minimum exponent of a real kind
113
* @code{MOD}:           MOD,       Remainder function
113
* @code{MOD}:           MOD,       Remainder function
114
* @code{MODULO}:        MODULO,    Modulo function
114
* @code{MODULO}:        MODULO,    Modulo function
115
* @code{MOVE_ALLOC}:    MOVE_ALLOC, Move allocation from one object to another
115
* @code{NEAREST}:       NEAREST,   Nearest representable number
116
* @code{NEAREST}:       NEAREST,   Nearest representable number
116
* @code{NINT}:          NINT,      Nearest whole number
117
* @code{NINT}:          NINT,      Nearest whole number
117
* @code{PRECISION}:     PRECISION, Decimal precision of a real kind
118
* @code{PRECISION}:     PRECISION, Decimal precision of a real kind
Lines 3869-3874 Link Here
3869
3870
3870
3871
3871
3872
3873
@node MOVE_ALLOC
3874
@section @code{MOVE_ALLOC} --- Move allocation from one object to another
3875
@findex @code{MOVE_ALLOC} intrinsic
3876
@cindex MOVE_ALLOC
3877
3878
@table @asis
3879
@item @emph{Description}:
3880
@code{MOVE_ALLOC(SRC, DEST)} moves the allocation from @var{SRC} to
3881
@var{DEST}.  @var{SRC} will become deallocated in the process.
3882
3883
@item @emph{Option}:
3884
f2003, gnu
3885
3886
@item @emph{Class}:
3887
Subroutine
3888
3889
@item @emph{Syntax}:
3890
@code{CALL MOVE_ALLOC(SRC, DEST)}
3891
3892
@item @emph{Arguments}:
3893
@multitable @columnfractions .15 .80
3894
@item @var{SRC} @tab @code{ALLOCATABLE}, @code{INTENT(INOUT)}, may be of any type and kind.
3895
@item @var{DEST} @tab @code{ALLOCATABLE}, @code{INTENT(OUT)}, shall be of the same type, kind and rank as @var{SRC}
3896
@end multitable
3897
3898
@item @emph{Return value}:
3899
None
3900
3901
@item @emph{Example}:
3902
@smallexample
3903
program test_move_alloc
3904
    integer, allocatable :: a(:), b(:)
3905
3906
    allocate(a(3))
3907
    a = [ 1, 2, 3 ]
3908
    call move_alloc(a, b)
3909
    print *, allocated(a), allocated(b)
3910
    print *, b
3911
end program test_move_alloc
3912
@end smallexample
3913
@end table
3914
3915
3916
3872
@node NEAREST
3917
@node NEAREST
3873
@section @code{NEAREST} --- Nearest representable number
3918
@section @code{NEAREST} --- Nearest representable number
3874
@findex @code{NEAREST} intrinsic
3919
@findex @code{NEAREST} intrinsic
(-)libgfortran/Makefile.in (-2 / +6 lines)
Lines 166-173 Link Here
166
	cshift0.lo ctime.lo date_and_time.lo env.lo erf.lo eoshift0.lo \
166
	cshift0.lo ctime.lo date_and_time.lo env.lo erf.lo eoshift0.lo \
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 move_alloc.lo \
170
	pack_generic.lo perror.lo signal.lo size.lo sleep.lo \
170
	mvbits.lo pack_generic.lo perror.lo signal.lo size.lo sleep.lo \
171
	spread_generic.lo string_intrinsics.lo system.lo rand.lo \
171
	spread_generic.lo string_intrinsics.lo system.lo rand.lo \
172
	random.lo rename.lo reshape_generic.lo reshape_packed.lo \
172
	random.lo rename.lo reshape_generic.lo reshape_packed.lo \
173
	selected_int_kind.lo selected_real_kind.lo stat.lo symlnk.lo \
173
	selected_int_kind.lo selected_real_kind.lo stat.lo symlnk.lo \
Lines 417-422 Link Here
417
intrinsics/ishftc.c \
417
intrinsics/ishftc.c \
418
intrinsics/link.c \
418
intrinsics/link.c \
419
intrinsics/malloc.c \
419
intrinsics/malloc.c \
420
intrinsics/move_alloc.c \
420
intrinsics/mvbits.c \
421
intrinsics/mvbits.c \
421
intrinsics/pack_generic.c \
422
intrinsics/pack_generic.c \
422
intrinsics/perror.c \
423
intrinsics/perror.c \
Lines 2301-2306 Link Here
2301
malloc.lo: intrinsics/malloc.c
2302
malloc.lo: intrinsics/malloc.c
2302
	$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o malloc.lo `test -f 'intrinsics/malloc.c' || echo '$(srcdir)/'`intrinsics/malloc.c
2303
	$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o malloc.lo `test -f 'intrinsics/malloc.c' || echo '$(srcdir)/'`intrinsics/malloc.c
2303
2304
2305
move_alloc.lo: intrinsics/move_alloc.c
2306
	$(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
2307
2304
mvbits.lo: intrinsics/mvbits.c
2308
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
2309
	$(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
2310
(-)libgfortran/Makefile.am (+1 lines)
Lines 73-78 Link Here
73
intrinsics/ishftc.c \
73
intrinsics/ishftc.c \
74
intrinsics/link.c \
74
intrinsics/link.c \
75
intrinsics/malloc.c \
75
intrinsics/malloc.c \
76
intrinsics/move_alloc.c \
76
intrinsics/mvbits.c \
77
intrinsics/mvbits.c \
77
intrinsics/pack_generic.c \
78
intrinsics/pack_generic.c \
78
intrinsics/perror.c \
79
intrinsics/perror.c \

Return to bug 20541