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/trans-array.c (-16 / +301 lines)
Lines 3313-3318 Link Here
3313
  tmp = gfc_conv_descriptor_offset (se->expr);
3313
  tmp = gfc_conv_descriptor_offset (se->expr);
3314
  gfc_add_modify_expr (&se->pre, tmp, offset);
3314
  gfc_add_modify_expr (&se->pre, tmp, offset);
3315
3315
3316
  if (expr->ts.type == BT_DERIVED && expr->ts.derived->attr.alloc_comp)
3317
    {
3318
      tmp = nullify_alloc_comp (expr->ts.derived, se->expr, ref->u.ar.as->rank);
3319
      gfc_add_expr_to_block (&se->pre, tmp);
3320
    }
3321
3316
  return true;
3322
  return true;
3317
}
3323
}
3318
3324
Lines 3453-3458 Link Here
3453
        }
3459
        }
3454
      break;
3460
      break;
3455
3461
3462
    case EXPR_NULL:
3463
      return gfc_build_null_descriptor (type);
3464
3456
    default:
3465
    default:
3457
      gcc_unreachable ();
3466
      gcc_unreachable ();
3458
    }
3467
    }
Lines 4529-4534 Link Here
4529
  se->want_pointer = 1;
4538
  se->want_pointer = 1;
4530
  gfc_conv_expr_descriptor (se, expr, ss);
4539
  gfc_conv_expr_descriptor (se, expr, ss);
4531
4540
4541
  /* Deallocate the allocatable components of structures that are
4542
     not variable.  */
4543
  if (expr->ts.type == BT_DERIVED
4544
	&& expr->ts.derived->attr.alloc_comp
4545
	&& expr->expr_type != EXPR_VARIABLE)
4546
    {
4547
      tmp = build_fold_indirect_ref (se->expr);
4548
      tmp = deallocate_alloc_comp (expr->ts.derived, tmp, expr->rank);
4549
      gfc_add_expr_to_block (&se->post, tmp);
4550
    }
4551
4532
  if (g77)
4552
  if (g77)
4533
    {
4553
    {
4534
      desc = se->expr;
4554
      desc = se->expr;
Lines 4577-4600 Link Here
4577
gfc_trans_dealloc_allocated (tree descriptor)
4597
gfc_trans_dealloc_allocated (tree descriptor)
4578
{ 
4598
{ 
4579
  tree tmp;
4599
  tree tmp;
4580
  tree deallocate;
4600
  tree ptr;
4601
  tree var;
4581
  stmtblock_t block;
4602
  stmtblock_t block;
4582
4603
4583
  gfc_start_block (&block);
4604
  gfc_start_block (&block);
4584
  deallocate = gfc_array_deallocate (descriptor, null_pointer_node);
4585
4605
4586
  tmp = gfc_conv_descriptor_data_get (descriptor);
4606
  tmp = gfc_conv_descriptor_data_addr (descriptor);
4587
  tmp = build2 (NE_EXPR, boolean_type_node, tmp,
4607
  var = gfc_evaluate_now (tmp, &block);
4588
                build_int_cst (TREE_TYPE (tmp), 0));
4608
  tmp = gfc_create_var (gfc_array_index_type, NULL);
4589
  tmp = build3_v (COND_EXPR, tmp, deallocate, build_empty_stmt ());
4609
  ptr = build_fold_addr_expr (tmp);
4610
4611
  /* Call array_deallocate with an int* present in the second argument.
4612
     Although it is ignored here, it's presence ensures that arrays that
4613
     are already deallocated are ignored.  */
4614
  tmp = gfc_chainon_list (NULL_TREE, var);
4615
  tmp = gfc_chainon_list (tmp, ptr);
4616
  tmp = build_function_call_expr (gfor_fndecl_deallocate, tmp);
4590
  gfc_add_expr_to_block (&block, tmp);
4617
  gfc_add_expr_to_block (&block, tmp);
4618
  return gfc_finish_block (&block);
4619
}
4591
4620
4592
  tmp = gfc_finish_block (&block);
4593
4621
4594
  return tmp;
4622
/* This helper function calculates the size in words of a full array.  */
4623
4624
static tree
4625
get_full_array_size (stmtblock_t *block, tree decl, int rank)
4626
{
4627
   tree idx;
4628
   tree nelems;
4629
   tree tmp;
4630
   idx = gfc_rank_cst[rank - 1];
4631
   nelems = gfc_conv_descriptor_ubound (decl, idx);
4632
   tmp = gfc_conv_descriptor_lbound (decl, idx);
4633
   tmp = build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
4634
   tmp = build2 (PLUS_EXPR, gfc_array_index_type,
4635
		 tmp, gfc_index_one_node);
4636
   nelems = gfc_conv_descriptor_stride (decl, idx);
4637
   tmp = build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
4638
   return gfc_evaluate_now (tmp, block);
4595
}
4639
}
4596
4640
4597
4641
4642
/* Recursively traverse an object of derived type, generating code to deallocate,
4643
   nullify or copy allocatable components.  This is the work horse function for
4644
   the functions named in this enum.  */
4645
enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP};
4646
4647
static tree
4648
structure_alloc_comps (gfc_symbol * der_type, tree decl,
4649
		       tree dest, int rank, int purpose)
4650
{
4651
  gfc_component *c;
4652
  gfc_loopinfo loop;
4653
  stmtblock_t fnblock;
4654
  stmtblock_t loopbody;
4655
  tree tmp;
4656
  tree comp;
4657
  tree dcmp;
4658
  tree nelems;
4659
  tree index;
4660
  tree var;
4661
  tree cdecl;
4662
  tree ctype;
4663
4664
  gfc_init_block (&fnblock);
4665
4666
  /* If this an array of derived types with allocatable components
4667
     build a loop and recursively call this function.  */
4668
  if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE
4669
	|| GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
4670
    {
4671
      tmp = gfc_conv_array_data (decl);
4672
      var = build_fold_indirect_ref (tmp);
4673
	
4674
      /* Get the number of elements - 1 and set the counter.  */
4675
      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
4676
	{
4677
	  /* Use the descriptor for an allocatable array.  Since this
4678
	     is a full array reference, we only need the descriptor
4679
	     information from dimension = rank.  */
4680
	  nelems = get_full_array_size (&fnblock, decl, rank);
4681
4682
	  /* Set the result to -1 if already deallocated, so that the
4683
	     loop does not run.  */
4684
	  tmp = gfc_conv_descriptor_data_get (decl);
4685
	  tmp = build2 (NE_EXPR, boolean_type_node, tmp,
4686
			build_int_cst (TREE_TYPE (tmp), 0));
4687
	  tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
4688
			nelems, gfc_index_zero_node);
4689
	  tmp = build2 (MINUS_EXPR, gfc_array_index_type,
4690
			   tmp, gfc_index_one_node);
4691
	}
4692
      else
4693
	{
4694
	  /*  Otherwise use the TYPE_DOMAIN information.  */
4695
	  tmp =  array_type_nelts (TREE_TYPE (decl));
4696
	  tmp = fold_convert (gfc_array_index_type, tmp);
4697
	}
4698
4699
      nelems = gfc_evaluate_now (tmp, &fnblock);
4700
      index = gfc_create_var (gfc_array_index_type, "S");
4701
4702
      /* Build the body of the loop.  */
4703
      gfc_init_block (&loopbody);
4704
      tmp = gfc_build_array_ref (var, index);
4705
4706
      if (purpose == COPY_ALLOC_COMP)
4707
        tmp = structure_alloc_comps (der_type, tmp,
4708
				     gfc_build_array_ref (dest, index),
4709
				     0, purpose);
4710
      else
4711
        tmp = structure_alloc_comps (der_type, tmp, NULL_TREE, 0, purpose);
4712
4713
      gfc_add_expr_to_block (&loopbody, tmp);
4714
4715
      /* Build the loop and return. */
4716
      gfc_init_loopinfo (&loop);
4717
      loop.dimen = 1;
4718
      loop.from[0] = gfc_index_zero_node;
4719
      loop.loopvar[0] = index;
4720
      loop.to[0] = nelems;
4721
      gfc_trans_scalarizing_loops (&loop, &loopbody);
4722
      gfc_add_block_to_block (&fnblock, &loop.pre);
4723
      return gfc_finish_block (&fnblock);
4724
    }
4725
4726
  /* Otherwise, deallocate the components or recursively call self to
4727
     dealocate the components of components. */
4728
  for (c = der_type->components; c; c = c->next)
4729
    {
4730
      cdecl = c->backend_decl;
4731
      ctype = TREE_TYPE (cdecl);
4732
4733
      switch (purpose)
4734
	{
4735
	case DEALLOCATE_ALLOC_COMP:
4736
	  if (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp)
4737
	    {
4738
	      comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
4739
	      rank = c->as ? c->as->rank : 0;
4740
	      tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
4741
					   rank, purpose);
4742
	      gfc_add_expr_to_block (&fnblock, tmp);
4743
	    }
4744
4745
	  if (c->allocatable)
4746
	    {
4747
	      comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
4748
	      tmp = gfc_trans_dealloc_allocated (comp);
4749
	      gfc_add_expr_to_block (&fnblock, tmp);
4750
	    }
4751
	  break;
4752
4753
	case NULLIFY_ALLOC_COMP:
4754
	  if (c->pointer)
4755
	    continue;
4756
	  else if (c->allocatable)
4757
	    {
4758
	      comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
4759
	      gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
4760
	    }
4761
          else if (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp)
4762
	    {
4763
	      comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
4764
	      rank = c->as ? c->as->rank : 0;
4765
	      tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
4766
					   rank, purpose);
4767
	      gfc_add_expr_to_block (&fnblock, tmp);
4768
	    }
4769
	  break;
4770
4771
	case COPY_ALLOC_COMP:
4772
	  if (c->pointer)
4773
	    continue;
4774
4775
	  comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
4776
	  dcmp = build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
4777
4778
	  if (c->allocatable)
4779
	    {
4780
	      tree size;
4781
	      tree args;
4782
	      nelems = get_full_array_size (&fnblock, comp, c->as->rank);
4783
	      size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
4784
				  TYPE_SIZE_UNIT (gfc_get_element_type (ctype)));
4785
4786
	      /* Allocate memory to the destination.  */
4787
	      tmp = gfc_chainon_list (NULL_TREE, size);
4788
	      if (gfc_index_integer_kind == 4)
4789
		tmp = build_function_call_expr (gfor_fndecl_internal_malloc, tmp);
4790
	      else if (gfc_index_integer_kind == 8)
4791
		tmp = build_function_call_expr (gfor_fndecl_internal_malloc64, tmp);
4792
	      else
4793
		gcc_unreachable ();
4794
4795
	      tmp = fold (convert (TREE_TYPE (gfc_conv_descriptor_data_get (comp)),
4796
		          tmp));
4797
	      gfc_conv_descriptor_data_set (&fnblock, dcmp, tmp);
4798
4799
	      /* We know the temporary and the value will be the same length,
4800
		 so can use memcpy.  */
4801
	      tmp = gfc_conv_descriptor_data_get (dcmp);
4802
	      args = gfc_chainon_list (NULL_TREE, tmp);
4803
	      tmp = gfc_conv_descriptor_data_get (comp);
4804
	      args = gfc_chainon_list (args, tmp);
4805
	      args = gfc_chainon_list (args, size);
4806
	      tmp = built_in_decls[BUILT_IN_MEMCPY];
4807
	      tmp = build_function_call_expr (tmp, args);
4808
	      gfc_add_expr_to_block (&fnblock, tmp);
4809
	    }
4810
4811
          if (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp)
4812
	    {
4813
	      rank = c->as ? c->as->rank : 0;
4814
	      tmp = structure_alloc_comps (c->ts.derived, comp, dcmp,
4815
					   rank, purpose);
4816
	      gfc_add_expr_to_block (&fnblock, tmp);
4817
	    }
4818
	  break;
4819
4820
	default:
4821
	  gcc_unreachable ();
4822
	  break;
4823
	}
4824
    }
4825
4826
  return gfc_finish_block (&fnblock);
4827
}
4828
4829
/* Recursively traverse an object of derived type, generating code to
4830
   nullify allocatable components.  */
4831
4832
tree
4833
nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
4834
{
4835
  return structure_alloc_comps (der_type, decl, NULL_TREE, 
4836
				rank, NULLIFY_ALLOC_COMP);
4837
}
4838
4839
4840
/* Recursively traverse an object of derived type, generating code to
4841
   deallocate allocatable components.  */
4842
4843
tree
4844
deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
4845
{
4846
  return structure_alloc_comps (der_type, decl, NULL_TREE,
4847
				rank, DEALLOCATE_ALLOC_COMP);
4848
}
4849
4850
4851
/* Recursively traverse an object of derived type, generating code to
4852
   copy its allocatable components.  */
4853
4854
tree
4855
copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
4856
{
4857
  return structure_alloc_comps (der_type, decl, dest,
4858
				rank, COPY_ALLOC_COMP);
4859
}
4860
4861
4598
/* NULLIFY an allocatable/pointer array on function entry, free it on exit.  */
4862
/* NULLIFY an allocatable/pointer array on function entry, free it on exit.  */
4599
4863
4600
tree
4864
tree
Lines 4605-4620 Link Here
4605
  tree descriptor;
4869
  tree descriptor;
4606
  stmtblock_t fnblock;
4870
  stmtblock_t fnblock;
4607
  locus loc;
4871
  locus loc;
4872
  int rank;
4608
4873
4609
  /* Make sure the frontend gets these right.  */
4874
  /* Make sure the frontend gets these right.  */
4610
  if (!(sym->attr.pointer || sym->attr.allocatable))
4875
  if (!(sym->attr.pointer || sym->attr.allocatable
4611
    fatal_error
4876
	|| (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)))
4612
      ("Possible frontend bug: Deferred array size without pointer or allocatable attribute.");
4877
    fatal_error ("Possible frontend bug: Deferred array size without pointer"
4878
		 "allocatable attribute.");
4613
4879
4614
  gfc_init_block (&fnblock);
4880
  gfc_init_block (&fnblock);
4615
4881
4616
  gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
4882
  gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
4617
                || TREE_CODE (sym->backend_decl) == PARM_DECL);
4883
		|| TREE_CODE (sym->backend_decl) == PARM_DECL);
4618
4884
4619
  if (sym->ts.type == BT_CHARACTER
4885
  if (sym->ts.type == BT_CHARACTER
4620
      && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4886
      && !INTEGER_CST_P (sym->ts.cl->backend_decl))
Lines 4644-4665 Link Here
4644
4910
4645
  /* Get the descriptor type.  */
4911
  /* Get the descriptor type.  */
4646
  type = TREE_TYPE (sym->backend_decl);
4912
  type = TREE_TYPE (sym->backend_decl);
4647
  if (!GFC_DESCRIPTOR_TYPE_P (type))
4913
    
4914
  if (sym->ts.type == BT_DERIVED
4915
	&& sym->ts.derived->attr.alloc_comp
4916
	&& !(sym->attr.pointer || sym->attr.allocatable))
4648
    {
4917
    {
4918
      rank = sym->as ? sym->as->rank : 0;
4919
      tmp = nullify_alloc_comp (sym->ts.derived, descriptor, rank);
4920
      gfc_add_expr_to_block (&fnblock, tmp);
4921
    }
4922
  else if (!GFC_DESCRIPTOR_TYPE_P (type))
4923
    {
4649
      /* If the backend_decl is not a descriptor, we must have a pointer
4924
      /* If the backend_decl is not a descriptor, we must have a pointer
4650
	 to one.  */
4925
	 to one.  */
4651
      descriptor = build_fold_indirect_ref (sym->backend_decl);
4926
      descriptor = build_fold_indirect_ref (sym->backend_decl);
4652
      type = TREE_TYPE (descriptor);
4927
      type = TREE_TYPE (descriptor);
4653
      gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
4654
    }
4928
    }
4655
4929
  
4656
  /* NULLIFY the data pointer.  */
4930
  /* NULLIFY the data pointer.  */
4657
  gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
4931
  if (GFC_DESCRIPTOR_TYPE_P (type))
4932
    gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
4658
4933
4659
  gfc_add_expr_to_block (&fnblock, body);
4934
  gfc_add_expr_to_block (&fnblock, body);
4660
4935
4661
  gfc_set_backend_locus (&loc);
4936
  gfc_set_backend_locus (&loc);
4937
4662
  /* Allocatable arrays need to be freed when they go out of scope.  */
4938
  /* Allocatable arrays need to be freed when they go out of scope.  */
4939
  if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp
4940
      && !(sym->attr.function || sym->attr.result))
4941
    {
4942
      int rank;
4943
      rank = sym->as ? sym->as->rank : 0;
4944
      tmp = deallocate_alloc_comp (sym->ts.derived, descriptor, rank);
4945
      gfc_add_expr_to_block (&fnblock, tmp);
4946
    }
4947
4663
  if (sym->attr.allocatable)
4948
  if (sym->attr.allocatable)
4664
    {
4949
    {
4665
      tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
4950
      tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
(-)gcc/fortran/trans-expr.c (-81 / +199 lines)
Lines 41-47 Link Here
41
#include "trans-stmt.h"
41
#include "trans-stmt.h"
42
#include "dependency.h"
42
#include "dependency.h"
43
43
44
static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
44
static tree gfc_trans_structure_assign (gfc_se * outer_se, tree dest, gfc_expr * expr);
45
static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
45
static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
46
						 gfc_expr *);
46
						 gfc_expr *);
47
47
Lines 1591-1598 Link Here
1591
   handling aliased arrays.  */
1591
   handling aliased arrays.  */
1592
1592
1593
static void
1593
static void
1594
gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
1594
gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr, int g77)
1595
		      int g77, sym_intent intent)
1596
{
1595
{
1597
  gfc_se lse;
1596
  gfc_se lse;
1598
  gfc_se rse;
1597
  gfc_se rse;
Lines 1636-1673 Link Here
1636
  loop.temp_ss->data.temp.type = base_type;
1635
  loop.temp_ss->data.temp.type = base_type;
1637
1636
1638
  if (expr->ts.type == BT_CHARACTER)
1637
  if (expr->ts.type == BT_CHARACTER)
1639
    {
1638
    loop.temp_ss->string_length = expr->ts.cl->backend_decl;
1640
      gfc_ref *char_ref = expr->ref;
1641
1639
1642
      for (; expr->ts.cl == NULL && char_ref; char_ref = char_ref->next)
1643
	if (char_ref->type == REF_SUBSTRING)
1644
	  {
1645
	    gfc_se tmp_se;
1646
1647
	    expr->ts.cl = gfc_get_charlen ();
1648
	    expr->ts.cl->next = char_ref->u.ss.length->next;
1649
	    char_ref->u.ss.length->next = expr->ts.cl;
1650
1651
	    gfc_init_se (&tmp_se, NULL);
1652
	    gfc_conv_expr_type (&tmp_se, char_ref->u.ss.end,
1653
				gfc_array_index_type);
1654
	    tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1655
			       tmp_se.expr, gfc_index_one_node);
1656
	    tmp = gfc_evaluate_now (tmp, &parmse->pre);
1657
	    gfc_init_se (&tmp_se, NULL);
1658
	    gfc_conv_expr_type (&tmp_se, char_ref->u.ss.start,
1659
				gfc_array_index_type);
1660
	    tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1661
			       tmp, tmp_se.expr);
1662
	    expr->ts.cl->backend_decl = tmp;
1663
1664
	    break;
1665
	  }
1666
      loop.temp_ss->data.temp.type
1667
		= gfc_typenode_for_spec (&expr->ts);
1668
      loop.temp_ss->string_length = expr->ts.cl->backend_decl;
1669
    }
1670
1671
  loop.temp_ss->data.temp.dimen = loop.dimen;
1640
  loop.temp_ss->data.temp.dimen = loop.dimen;
1672
  loop.temp_ss->next = gfc_ss_terminator;
1641
  loop.temp_ss->next = gfc_ss_terminator;
1673
1642
Lines 1699-1711 Link Here
1699
  gfc_conv_tmp_array_ref (&lse);
1668
  gfc_conv_tmp_array_ref (&lse);
1700
  gfc_advance_se_ss_chain (&lse);
1669
  gfc_advance_se_ss_chain (&lse);
1701
1670
1702
  if (intent != INTENT_OUT)
1671
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
1703
    {
1672
  gfc_add_expr_to_block (&body, tmp);
1704
      tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
1673
  gcc_assert (rse.ss == gfc_ss_terminator);
1705
      gfc_add_expr_to_block (&body, tmp);
1674
  gfc_trans_scalarizing_loops (&loop, &body);
1706
      gcc_assert (rse.ss == gfc_ss_terminator);
1707
      gfc_trans_scalarizing_loops (&loop, &body);
1708
    }
1709
1675
1710
  /* Add the post block after the second loop, so that any
1676
  /* Add the post block after the second loop, so that any
1711
     freeing of allocated memory is done at the right time.  */
1677
     freeing of allocated memory is done at the right time.  */
Lines 1786-1805 Link Here
1786
1752
1787
  gcc_assert (lse.ss == gfc_ss_terminator);
1753
  gcc_assert (lse.ss == gfc_ss_terminator);
1788
1754
1789
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
1755
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
1790
  gfc_add_expr_to_block (&body, tmp);
1756
  gfc_add_expr_to_block (&body, tmp);
1791
  
1757
  
1792
  /* Generate the copying loops.  */
1758
  /* Generate the copying loops.  */
1793
  gfc_trans_scalarizing_loops (&loop2, &body);
1759
  gfc_trans_scalarizing_loops (&loop2, &body);
1794
1760
1795
  /* Wrap the whole thing up by adding the second loop to the post-block
1761
  /* Wrap the whole thing up by adding the second loop to the post-block
1796
     and following it by the post-block of the first loop.  In this way,
1762
     and following it by the post-block of the fist loop.  In this way,
1797
     if the temporary needs freeing, it is done after use!  */
1763
     if the temporary needs freeing, it is done after use!  */
1798
  if (intent != INTENT_IN)
1764
  gfc_add_block_to_block (&parmse->post, &loop2.pre);
1799
    {
1765
  gfc_add_block_to_block (&parmse->post, &loop2.post);
1800
      gfc_add_block_to_block (&parmse->post, &loop2.pre);
1801
      gfc_add_block_to_block (&parmse->post, &loop2.post);
1802
    }
1803
1766
1804
  gfc_add_block_to_block (&parmse->post, &loop.post);
1767
  gfc_add_block_to_block (&parmse->post, &loop.post);
1805
1768
Lines 1834-1841 Link Here
1834
      if (ref->type == REF_ARRAY)
1797
      if (ref->type == REF_ARRAY)
1835
	seen_array = true;
1798
	seen_array = true;
1836
1799
1837
      if (ref->next == NULL
1800
      if (ref->next == NULL && ref->type != REF_ARRAY)
1838
	    && ref->type != REF_ARRAY)
1839
	return seen_array;
1801
	return seen_array;
1840
    }
1802
    }
1841
  return false;
1803
  return false;
Lines 1858-1867 Link Here
1858
  gfc_ss *argss;
1820
  gfc_ss *argss;
1859
  gfc_ss_info *info;
1821
  gfc_ss_info *info;
1860
  int byref;
1822
  int byref;
1823
  int parm_kind;
1861
  tree type;
1824
  tree type;
1862
  tree var;
1825
  tree var;
1863
  tree len;
1826
  tree len;
1864
  tree stringargs;
1827
  tree stringargs;
1865
  gfc_formal_arglist *formal;
1828
  gfc_formal_arglist *formal;
1866
  int has_alternate_specifier = 0;
1829
  int has_alternate_specifier = 0;
1867
  bool need_interface_mapping;
1830
  bool need_interface_mapping;
Lines 1877-1882 Link Here
1877
  stringargs = NULL_TREE;
1840
  stringargs = NULL_TREE;
1878
  var = NULL_TREE;
1841
  var = NULL_TREE;
1879
  len = NULL_TREE;
1842
  len = NULL_TREE;
1843
  enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
1880
1844
1881
  if (se->ss != NULL)
1845
  if (se->ss != NULL)
1882
    {
1846
    {
Lines 1913-1918 Link Here
1913
    {
1877
    {
1914
      e = arg->expr;
1878
      e = arg->expr;
1915
      fsym = formal ? formal->sym : NULL;
1879
      fsym = formal ? formal->sym : NULL;
1880
      parm_kind = MISSING;
1916
      if (e == NULL)
1881
      if (e == NULL)
1917
	{
1882
	{
1918
1883
Lines 1941-1946 Link Here
1941
	  /* An elemental function inside a scalarized loop.  */
1906
	  /* An elemental function inside a scalarized loop.  */
1942
          gfc_init_se (&parmse, se);
1907
          gfc_init_se (&parmse, se);
1943
          gfc_conv_expr_reference (&parmse, e);
1908
          gfc_conv_expr_reference (&parmse, e);
1909
	  parm_kind = ELEMENTAL;
1944
	}
1910
	}
1945
      else
1911
      else
1946
	{
1912
	{
Lines 1951-1962 Link Here
1951
	  if (argss == gfc_ss_terminator)
1917
	  if (argss == gfc_ss_terminator)
1952
            {
1918
            {
1953
	      gfc_conv_expr_reference (&parmse, e);
1919
	      gfc_conv_expr_reference (&parmse, e);
1920
	      parm_kind = SCALAR;
1954
              if (fsym && fsym->attr.pointer
1921
              if (fsym && fsym->attr.pointer
1955
		  && e->expr_type != EXPR_NULL)
1922
		  && e->expr_type != EXPR_NULL)
1956
                {
1923
                {
1957
                  /* Scalar pointer dummy args require an extra level of
1924
                  /* Scalar pointer dummy args require an extra level of
1958
		  indirection. The null pointer already contains
1925
		  indirection. The null pointer already contains
1959
		  this level of indirection.  */
1926
		  this level of indirection.  */
1927
		  parm_kind = SCALAR_POINTER;
1960
                  parmse.expr = build_fold_addr_expr (parmse.expr);
1928
                  parmse.expr = build_fold_addr_expr (parmse.expr);
1961
                }
1929
                }
1962
            }
1930
            }
Lines 1973-1989 Link Here
1973
		  && !(fsym->attr.pointer || fsym->attr.allocatable)
1941
		  && !(fsym->attr.pointer || fsym->attr.allocatable)
1974
		  && fsym->as->type != AS_ASSUMED_SHAPE;
1942
		  && fsym->as->type != AS_ASSUMED_SHAPE;
1975
	      f = f || !sym->attr.always_explicit;
1943
	      f = f || !sym->attr.always_explicit;
1976
1977
	      if (e->expr_type == EXPR_VARIABLE
1944
	      if (e->expr_type == EXPR_VARIABLE
1978
		    && is_aliased_array (e))
1945
		    && is_aliased_array (e))
1979
		/* The actual argument is a component reference to an
1946
		/* The actual argument is a component reference to an
1980
		   array of derived types.  In this case, the argument
1947
		   array of derived types.  In this case, the argument
1981
		   is converted to a temporary, which is passed and then
1948
		   is converted to a temporary, which is passed and then
1982
		   written back after the procedure call.  */
1949
		   written back after the procedure call.  */
1983
		gfc_conv_aliased_arg (&parmse, e, f, fsym->attr.intent);
1950
		gfc_conv_aliased_arg (&parmse, e, f);
1984
	      else
1951
	      else
1985
	        gfc_conv_array_parameter (&parmse, e, argss, f);
1952
	        gfc_conv_array_parameter (&parmse, e, argss, f);
1986
1953
1954
	      parm_kind = ARRAY;
1955
1987
              /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is 
1956
              /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is 
1988
                 allocated on entry, it must be deallocated.  */
1957
                 allocated on entry, it must be deallocated.  */
1989
              if (fsym && fsym->attr.allocatable
1958
              if (fsym && fsym->attr.allocatable
Lines 2012-2017 Link Here
2012
      gfc_add_block_to_block (&se->pre, &parmse.pre);
1981
      gfc_add_block_to_block (&se->pre, &parmse.pre);
2013
      gfc_add_block_to_block (&post, &parmse.post);
1982
      gfc_add_block_to_block (&post, &parmse.post);
2014
1983
1984
      /* Allocated allocatable components of derived types must be
1985
	 deallocated for INTENT(OUT) dummy arguments and non-variable
1986
         scalars.  Non-variable arrays are dealt with in trans-array.c
1987
         (gfc_conv_array_parameter).  */
1988
      if (e && e->ts.type == BT_DERIVED
1989
	    && e->ts.derived->attr.alloc_comp
1990
	    && ((formal && formal->sym->attr.intent == INTENT_OUT)
1991
		   ||
1992
		(e->expr_type != EXPR_VARIABLE && !e->rank)))
1993
        {
1994
	  int parm_rank;
1995
	  tmp = build_fold_indirect_ref (parmse.expr);
1996
	  parm_rank = e->rank;
1997
	  switch (parm_kind)
1998
	    {
1999
	    case (ELEMENTAL):
2000
	    case (SCALAR):
2001
	      parm_rank = 0;
2002
	      break;
2003
2004
	    case (SCALAR_POINTER):
2005
              tmp = build_fold_indirect_ref (tmp);
2006
	      break;
2007
	    case (ARRAY):
2008
              tmp = parmse.expr;
2009
	      break;
2010
	    }
2011
2012
          tmp = deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
2013
	  if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
2014
	    tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym),
2015
			    tmp, build_empty_stmt ());
2016
2017
	  if (e->expr_type == EXPR_FUNCTION)
2018
	    /* Don't deallocate function results until they have been used.  */
2019
	    gfc_add_expr_to_block (&se->post, tmp);
2020
	  else
2021
	    gfc_add_expr_to_block (&se->pre, tmp);
2022
        }
2023
2015
      /* Character strings are passed as two parameters, a length and a
2024
      /* Character strings are passed as two parameters, a length and a
2016
         pointer.  */
2025
         pointer.  */
2017
      if (parmse.string_length != NULL_TREE)
2026
      if (parmse.string_length != NULL_TREE)
Lines 2532-2538 Link Here
2532
2541
2533
  gfc_conv_expr (&rse, expr);
2542
  gfc_conv_expr (&rse, expr);
2534
2543
2535
  tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
2544
  tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, false, false);
2536
  gfc_add_expr_to_block (&body, tmp);
2545
  gfc_add_expr_to_block (&body, tmp);
2537
2546
2538
  gcc_assert (rse.ss == gfc_ss_terminator);
2547
  gcc_assert (rse.ss == gfc_ss_terminator);
Lines 2556-2567 Link Here
2556
/* Assign a single component of a derived type constructor.  */
2565
/* Assign a single component of a derived type constructor.  */
2557
2566
2558
static tree
2567
static tree
2559
gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2568
gfc_trans_subcomponent_assign (gfc_se * outer_se, tree dest,
2569
			       gfc_component * cm, gfc_expr * expr)
2560
{
2570
{
2561
  gfc_se se;
2571
  gfc_se se;
2572
  gfc_se lse;
2562
  gfc_ss *rss;
2573
  gfc_ss *rss;
2563
  stmtblock_t block;
2574
  stmtblock_t block;
2564
  tree tmp;
2575
  tree tmp;
2576
  tree offset;
2577
  int n;
2565
2578
2566
  gfc_start_block (&block);
2579
  gfc_start_block (&block);
2567
  if (cm->pointer)
2580
  if (cm->pointer)
Lines 2596-2615 Link Here
2596
    }
2609
    }
2597
  else if (cm->dimension)
2610
  else if (cm->dimension)
2598
    {
2611
    {
2599
      tmp = gfc_trans_subarray_assign (dest, cm, expr);
2612
      if (cm->allocatable && expr->expr_type == EXPR_NULL)
2600
      gfc_add_expr_to_block (&block, tmp);
2613
	gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
2614
      else if (cm->allocatable)
2615
	{
2616
          gfc_init_se (&se, NULL);
2617
	  gfc_init_se (&lse, NULL);
2618
2619
	  se.want_pointer = 0;
2620
	  gfc_conv_expr_descriptor (&se, expr, gfc_walk_expr (expr));
2621
	  if (cm->ts.type == BT_CHARACTER)
2622
	    lse.string_length = cm->ts.cl->backend_decl;
2623
	  lse.expr = dest;
2624
	  if (expr->expr_type == EXPR_FUNCTION)
2625
	    {
2626
	      /* Null the data pointer so that the memory does not get freed.  The
2627
	         this has to go to the head of the se.post block.
2628
		 FIXME: The data needs to be freed in the next scope up or, better
2629
		 still, the copy should not be done in the assignment.
2630
		 NOTE: outer_se is provided expressly to fix this. We need to add
2631
		 a pointer to outer_se->pre, to assign the data field to it in this
2632
		 scope and to free the data in outer_se->post.  */
2633
	      stmtblock_t tmp_block;
2634
	      gfc_init_block (&tmp_block);
2635
	      gfc_add_block_to_block (&tmp_block, &se.post);
2636
	      gfc_conv_descriptor_data_set (&se.post, se.expr, null_pointer_node);
2637
	      gfc_add_block_to_block (&se.post, &tmp_block);
2638
	    }
2639
2640
	  tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, false, false);
2641
	  gfc_add_expr_to_block (&block, tmp);
2642
2643
	  /* Shift the lbound and ubound of temporaries to being unity, rather
2644
	     than zero, based.  Calculate the offset for all cases.  */
2645
	  offset = gfc_conv_descriptor_offset (dest);
2646
	  gfc_add_modify_expr (&block, offset, gfc_index_zero_node);
2647
	  for (n = 0; n < expr->rank; n++)
2648
	    {
2649
	      if (expr->expr_type != EXPR_VARIABLE
2650
		    && expr->expr_type != EXPR_CONSTANT)
2651
		{
2652
		  tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
2653
		  gfc_add_modify_expr (&block, tmp,
2654
				       fold_build2 (PLUS_EXPR, gfc_array_index_type,
2655
						    tmp, gfc_index_one_node));
2656
		  tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
2657
		  gfc_add_modify_expr (&block, tmp, gfc_index_one_node);
2658
		}
2659
	      tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2660
				 gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]),
2661
				 gfc_conv_descriptor_stride (dest, gfc_rank_cst[n]));
2662
	      tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
2663
	      gfc_add_modify_expr (&block, offset, tmp);
2664
	    }  
2665
	}
2666
      else
2667
	{
2668
	  tmp = gfc_trans_subarray_assign (dest, cm, expr);
2669
	  gfc_add_expr_to_block (&block, tmp);
2670
	}
2601
    }
2671
    }
2602
  else if (expr->ts.type == BT_DERIVED)
2672
  else if (expr->ts.type == BT_DERIVED)
2603
    {
2673
    {
2604
      /* Nested derived type.  */
2674
      /* Nested derived type.  */
2605
      tmp = gfc_trans_structure_assign (dest, expr);
2675
      tmp = gfc_trans_structure_assign (outer_se, dest, expr);
2606
      gfc_add_expr_to_block (&block, tmp);
2676
      gfc_add_expr_to_block (&block, tmp);
2607
    }
2677
    }
2608
  else
2678
  else
2609
    {
2679
    {
2610
      /* Scalar component.  */
2680
      /* Scalar component.  */
2611
      gfc_se lse;
2612
2613
      gfc_init_se (&se, NULL);
2681
      gfc_init_se (&se, NULL);
2614
      gfc_init_se (&lse, NULL);
2682
      gfc_init_se (&lse, NULL);
2615
2683
Lines 2617-2623 Link Here
2617
      if (cm->ts.type == BT_CHARACTER)
2685
      if (cm->ts.type == BT_CHARACTER)
2618
	lse.string_length = cm->ts.cl->backend_decl;
2686
	lse.string_length = cm->ts.cl->backend_decl;
2619
      lse.expr = dest;
2687
      lse.expr = dest;
2620
      tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type);
2688
      tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, false, false);
2621
      gfc_add_expr_to_block (&block, tmp);
2689
      gfc_add_expr_to_block (&block, tmp);
2622
    }
2690
    }
2623
  return gfc_finish_block (&block);
2691
  return gfc_finish_block (&block);
Lines 2626-2632 Link Here
2626
/* Assign a derived type constructor to a variable.  */
2694
/* Assign a derived type constructor to a variable.  */
2627
2695
2628
static tree
2696
static tree
2629
gfc_trans_structure_assign (tree dest, gfc_expr * expr)
2697
gfc_trans_structure_assign (gfc_se * outer_se, tree dest, gfc_expr * expr)
2630
{
2698
{
2631
  gfc_constructor *c;
2699
  gfc_constructor *c;
2632
  gfc_component *cm;
2700
  gfc_component *cm;
Lines 2644-2650 Link Here
2644
2712
2645
      field = cm->backend_decl;
2713
      field = cm->backend_decl;
2646
      tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
2714
      tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
2647
      tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
2715
      tmp = gfc_trans_subcomponent_assign (outer_se, tmp, cm, c->expr);
2648
      gfc_add_expr_to_block (&block, tmp);
2716
      gfc_add_expr_to_block (&block, tmp);
2649
    }
2717
    }
2650
  return gfc_finish_block (&block);
2718
  return gfc_finish_block (&block);
Lines 2671-2677 Link Here
2671
    {
2739
    {
2672
      /* Create a temporary variable and fill it in.  */
2740
      /* Create a temporary variable and fill it in.  */
2673
      se->expr = gfc_create_var (type, expr->ts.derived->name);
2741
      se->expr = gfc_create_var (type, expr->ts.derived->name);
2674
      tmp = gfc_trans_structure_assign (se->expr, expr);
2742
      tmp = gfc_trans_structure_assign (se, se->expr, expr);
2675
      gfc_add_expr_to_block (&se->pre, tmp);
2743
      gfc_add_expr_to_block (&se->pre, tmp);
2676
      return;
2744
      return;
2677
    }
2745
    }
Lines 2978-3003 Link Here
2978
   strings.  */
3046
   strings.  */
2979
3047
2980
tree
3048
tree
2981
gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
3049
gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
3050
			 bool l_is_temp, bool r_is_var)
2982
{
3051
{
2983
  stmtblock_t block;
3052
  stmtblock_t block;
3053
  tree tmp;
3054
  tree cond;
2984
3055
2985
  gfc_init_block (&block);
3056
  gfc_init_block (&block);
2986
3057
2987
  if (type == BT_CHARACTER)
3058
  if (ts.type == BT_CHARACTER)
2988
    {
3059
    {
2989
      gcc_assert (lse->string_length != NULL_TREE
3060
      gcc_assert (lse->string_length != NULL_TREE
2990
	      && rse->string_length != NULL_TREE);
3061
	      && rse->string_length != NULL_TREE);
2991
3062
2992
      gfc_conv_string_parameter (lse);
3063
      gfc_conv_string_parameter (lse);
2993
      gfc_conv_string_parameter (rse);
3064
      gfc_conv_string_parameter (rse);
2994
3065
2995
      gfc_add_block_to_block (&block, &lse->pre);
3066
      gfc_add_block_to_block (&block, &lse->pre);
2996
      gfc_add_block_to_block (&block, &rse->pre);
3067
      gfc_add_block_to_block (&block, &rse->pre);
2997
3068
2998
      gfc_trans_string_copy (&block, lse->string_length, lse->expr,
3069
      gfc_trans_string_copy (&block, lse->string_length, lse->expr,
2999
			     rse->string_length, rse->expr);
3070
			     rse->string_length, rse->expr);
3000
    }
3071
    }
3072
  else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
3073
    {
3074
      cond = NULL_TREE;
3075
3076
      /* Are the rhs and the lhs the same?  */
3077
      if (r_is_var)
3078
	{
3079
	  cond = fold_build2 (EQ_EXPR, boolean_type_node,
3080
			      build_fold_addr_expr (lse->expr),
3081
			      build_fold_addr_expr (rse->expr));
3082
	  cond = gfc_evaluate_now (cond, &lse->pre);
3083
	}
3084
3085
      /* Deallocate the lhs allocated components as long as it is not
3086
	 the same as the rhs.  */
3087
      if (!l_is_temp)
3088
	{
3089
	  tmp = deallocate_alloc_comp (ts.derived, lse->expr, 0);
3090
	  if (r_is_var)
3091
	    tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
3092
	  gfc_add_expr_to_block (&lse->pre, tmp);
3093
	}
3094
	
3095
      gfc_add_block_to_block (&block, &lse->pre);
3096
      gfc_add_block_to_block (&block, &rse->pre);
3097
3098
      gfc_add_modify_expr (&block, lse->expr,
3099
			   fold_convert (TREE_TYPE (lse->expr), rse->expr));
3100
3101
      /* Do a deep copy if the rhs is a variable, as long as it is not the
3102
	 same as the lhs.  Otherwise, nullify the data fields so that the
3103
	 lhs retains the allocated resources.  */
3104
      if (r_is_var)
3105
	{
3106
	  tmp = copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
3107
	  tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
3108
	  gfc_add_expr_to_block (&block, tmp);
3109
	}
3110
      else
3111
	{
3112
	  tmp = nullify_alloc_comp (ts.derived, rse->expr, 0);
3113
	  gfc_add_expr_to_block (&block, tmp);
3114
	}
3115
    }
3001
  else
3116
  else
3002
    {
3117
    {
3003
      gfc_add_block_to_block (&block, &lse->pre);
3118
      gfc_add_block_to_block (&block, &lse->pre);
Lines 3192-3198 Link Here
3192
  else
3307
  else
3193
    gfc_conv_expr (&lse, expr1);
3308
    gfc_conv_expr (&lse, expr1);
3194
3309
3195
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
3310
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
3311
				 loop.temp_ss != NULL,
3312
				 expr2->expr_type != EXPR_FUNCTION);
3196
  gfc_add_expr_to_block (&body, tmp);
3313
  gfc_add_expr_to_block (&body, tmp);
3197
3314
3198
  if (lss == gfc_ss_terminator)
3315
  if (lss == gfc_ss_terminator)
Lines 3225-3233 Link Here
3225
	  gcc_assert (lse.ss == gfc_ss_terminator
3342
	  gcc_assert (lse.ss == gfc_ss_terminator
3226
		      && rse.ss == gfc_ss_terminator);
3343
		      && rse.ss == gfc_ss_terminator);
3227
3344
3228
	  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
3345
	  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false);
3229
	  gfc_add_expr_to_block (&body, tmp);
3346
	  gfc_add_expr_to_block (&body, tmp);
3230
	}
3347
	}
3348
3231
      /* Generate the copying loops.  */
3349
      /* Generate the copying loops.  */
3232
      gfc_trans_scalarizing_loops (&loop, &body);
3350
      gfc_trans_scalarizing_loops (&loop, &body);
3233
3351
(-)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/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 2128-2138 Link Here
2128
	  && d != DECL_DIMENSION && d != DECL_POINTER
2145
	  && d != DECL_DIMENSION && d != DECL_POINTER
2129
	  && d != DECL_COLON && d != DECL_NONE)
2146
	  && d != DECL_COLON && d != DECL_NONE)
2130
	{
2147
	{
2131
2148
	  if (d == DECL_ALLOCATABLE)
2132
	  gfc_error ("Attribute at %L is not allowed in a TYPE definition",
2149
	    {
2133
		     &seen_at[d]);
2150
	      if (gfc_notify_std (GFC_STD_F2003, 
2134
	  m = MATCH_ERROR;
2151
				   "In the selected standard, the ALLOCATABLE "
2135
	  goto cleanup;
2152
				   "attribute at %C is not allowed in a TYPE "
2153
				   "definition") == FAILURE)         
2154
		{
2155
		  m = MATCH_ERROR;
2156
		  goto cleanup;
2157
		}
2158
            }
2159
          else
2160
	    {
2161
	      gfc_error ("Attribute at %L is not allowed in a TYPE definition",
2162
			  &seen_at[d]);
2163
	      m = MATCH_ERROR;
2164
	      goto cleanup;
2165
	    }
2136
	}
2166
	}
2137
2167
2138
      if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
2168
      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 nullify_alloc_comp (gfc_symbol *, tree, int);
48
49
tree deallocate_alloc_comp (gfc_symbol *, tree, int);
50
51
tree 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.h (-1 / +5 lines)
Lines 522-527 Link Here
522
  /* Special attributes for Cray pointers, pointees.  */
522
  /* Special attributes for Cray pointers, pointees.  */
523
  unsigned cray_pointer:1, cray_pointee:1;
523
  unsigned cray_pointer:1, cray_pointee:1;
524
524
525
  /* The symbol is a derived type with allocatable components, possibly nested.
526
   */
527
  unsigned alloc_comp:1;
525
}
528
}
526
symbol_attribute;
529
symbol_attribute;
527
530
Lines 639-645 Link Here
639
  const char *name;
642
  const char *name;
640
  gfc_typespec ts;
643
  gfc_typespec ts;
641
644
642
  int pointer, dimension;
645
  int pointer, allocatable, dimension;
643
  gfc_array_spec *as;
646
  gfc_array_spec *as;
644
647
645
  tree backend_decl;
648
  tree backend_decl;
Lines 1958-1963 Link Here
1958
void gfc_free_actual_arglist (gfc_actual_arglist *);
1961
void gfc_free_actual_arglist (gfc_actual_arglist *);
1959
gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *);
1962
gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *);
1960
const char *gfc_extract_int (gfc_expr *, int *);
1963
const char *gfc_extract_int (gfc_expr *, int *);
1964
gfc_expr *gfc_expr_to_initialize (gfc_expr *);
1961
1965
1962
gfc_expr *gfc_build_conversion (gfc_expr *);
1966
gfc_expr *gfc_build_conversion (gfc_expr *);
1963
void gfc_free_ref_list (gfc_ref *);
1967
void gfc_free_ref_list (gfc_ref *);
(-)gcc/fortran/trans-stmt.c (-6 / +13 lines)
Lines 1795-1801 Link Here
1795
      gfc_conv_expr (&lse, expr);
1795
      gfc_conv_expr (&lse, expr);
1796
1796
1797
      /* Use the scalar assignment.  */
1797
      /* Use the scalar assignment.  */
1798
      tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
1798
      tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
1799
1799
1800
      /* Form the mask expression according to the mask tree list.  */
1800
      /* Form the mask expression according to the mask tree list.  */
1801
      if (wheremask)
1801
      if (wheremask)
Lines 1890-1896 Link Here
1890
    }
1890
    }
1891
1891
1892
  /* Use the scalar assignment.  */
1892
  /* Use the scalar assignment.  */
1893
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts.type);
1893
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts, false, false);
1894
1894
1895
  /* Form the mask expression according to the mask tree list.  */
1895
  /* Form the mask expression according to the mask tree list.  */
1896
  if (wheremask)
1896
  if (wheremask)
Lines 2967-2973 Link Here
2967
    maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr);
2967
    maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr);
2968
2968
2969
  /* Use the scalar assignment as is.  */
2969
  /* Use the scalar assignment as is.  */
2970
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2970
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
2971
				 loop.temp_ss != NULL, false);
2971
  tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
2972
  tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
2972
2973
2973
  gfc_add_expr_to_block (&body, tmp);
2974
  gfc_add_expr_to_block (&body, tmp);
Lines 3020-3026 Link Here
3020
				    maskexpr);
3021
				    maskexpr);
3021
3022
3022
          /* Use the scalar assignment as is.  */
3023
          /* Use the scalar assignment as is.  */
3023
          tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
3024
          tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false);
3024
          tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
3025
          tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
3025
          gfc_add_expr_to_block (&body, tmp);
3026
          gfc_add_expr_to_block (&body, tmp);
3026
3027
Lines 3395-3402 Link Here
3395
        gfc_conv_expr (&edse, edst);
3396
        gfc_conv_expr (&edse, edst);
3396
    }
3397
    }
3397
3398
3398
  tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts.type);
3399
  tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, false);
3399
  estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts.type)
3400
  estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts, false, false)
3400
		 : build_empty_stmt ();
3401
		 : build_empty_stmt ();
3401
  tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
3402
  tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
3402
  gfc_add_expr_to_block (&body, tmp);
3403
  gfc_add_expr_to_block (&body, tmp);
Lines 3664-3669 Link Here
3664
      se.descriptor_only = 1;
3665
      se.descriptor_only = 1;
3665
      gfc_conv_expr (&se, expr);
3666
      gfc_conv_expr (&se, expr);
3666
3667
3668
      if (expr->ts.type == BT_DERIVED && expr->ts.derived->attr.alloc_comp)
3669
        {
3670
	  tmp = deallocate_alloc_comp (expr->ts.derived, se.expr, expr->rank);
3671
	  gfc_add_expr_to_block (&se.pre, tmp);
3672
	}
3673
3667
      if (expr->rank)
3674
      if (expr->rank)
3668
	tmp = gfc_array_deallocate (se.expr, pstat);
3675
	tmp = gfc_array_deallocate (se.expr, pstat);
3669
      else
3676
      else
(-)gcc/fortran/expr.c (+32 lines)
Lines 2535-2537 Link Here
2535
          break;
2535
          break;
2536
        }
2536
        }
2537
}
2537
}
2538
2539
2540
/* Given the expression node e for an allocatable/pointer of derived type to be
2541
   allocated, get the expression node to be initialized afterwards (needed for
2542
   derived types with default initializers, and derived types with allocatable
2543
   components that need nullification.)  */
2544
2545
gfc_expr *
2546
gfc_expr_to_initialize (gfc_expr * e)
2547
{
2548
  gfc_expr *result;
2549
  gfc_ref *ref;
2550
  int i;
2551
2552
  result = gfc_copy_expr (e);
2553
2554
  /* Change the last array reference from AR_ELEMENT to AR_FULL.  */
2555
  for (ref = result->ref; ref; ref = ref->next)
2556
    if (ref->type == REF_ARRAY && ref->next == NULL)
2557
      {
2558
        ref->u.ar.type = AR_FULL;
2559
2560
        for (i = 0; i < ref->u.ar.dimen; i++)
2561
          ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
2562
2563
        result->rank = ref->u.ar.dimen; 
2564
        break;
2565
      }
2566
2567
  return result;
2568
}
2569
(-)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 1532-1538 Link Here
1532
         required.  */
1532
         required.  */
1533
      if (c->dimension)
1533
      if (c->dimension)
1534
	{
1534
	{
1535
	  if (c->pointer)
1535
	  if (c->pointer || c->allocatable)
1536
	    {
1536
	    {
1537
	      /* Pointers to arrays aren't actually pointer types.  The
1537
	      /* Pointers to arrays aren't actually pointer types.  The
1538
	         descriptors are separate, but the data is common.  */
1538
	         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 (-34 / +3 lines)
Lines 3214-3249 Link Here
3214
}
3214
}
3215
3215
3216
3216
3217
/* Given the expression node e for an allocatable/pointer of derived type to be
3218
   allocated, get the expression node to be initialized afterwards (needed for
3219
   derived types with default initializers).  */
3220
3221
static gfc_expr *
3222
expr_to_initialize (gfc_expr * e)
3223
{
3224
  gfc_expr *result;
3225
  gfc_ref *ref;
3226
  int i;
3227
3228
  result = gfc_copy_expr (e);
3229
3230
  /* Change the last array reference from AR_ELEMENT to AR_FULL.  */
3231
  for (ref = result->ref; ref; ref = ref->next)
3232
    if (ref->type == REF_ARRAY && ref->next == NULL)
3233
      {
3234
        ref->u.ar.type = AR_FULL;
3235
3236
        for (i = 0; i < ref->u.ar.dimen; i++)
3237
          ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
3238
3239
        result->rank = ref->u.ar.dimen; 
3240
        break;
3241
      }
3242
3243
  return result;
3244
}
3245
3246
3247
/* Resolve the expression in an ALLOCATE statement, doing the additional
3217
/* Resolve the expression in an ALLOCATE statement, doing the additional
3248
   checks to see whether the expression is OK or not.  The expression must
3218
   checks to see whether the expression is OK or not.  The expression must
3249
   have a trailing array reference that gives the size of the array.  */
3219
   have a trailing array reference that gives the size of the array.  */
Lines 3324-3332 Link Here
3324
        init_st = gfc_get_code ();
3294
        init_st = gfc_get_code ();
3325
        init_st->loc = code->loc;
3295
        init_st->loc = code->loc;
3326
        init_st->op = EXEC_ASSIGN;
3296
        init_st->op = EXEC_ASSIGN;
3327
        init_st->expr = expr_to_initialize (e);
3297
        init_st->expr = gfc_expr_to_initialize (e);
3328
        init_st->expr2 = init_e;
3298
	init_st->expr2 = init_e;
3329
3330
        init_st->next = code->next;
3299
        init_st->next = code->next;
3331
        code->next = init_st;
3300
        code->next = init_st;
3332
    }
3301
    }
Lines 5305-5311 Link Here
5305
	  return FAILURE;
5274
	  return FAILURE;
5306
	}
5275
	}
5307
5276
5308
      if (c->pointer || c->as == NULL)
5277
      if (c->pointer || c->allocatable ||  c->as == NULL)
5309
	continue;
5278
	continue;
5310
5279
5311
      for (i = 0; i < c->as->rank; i++)
5280
      for (i = 0; i < c->as->rank; i++)
(-)gcc/fortran/trans-decl.c (-3 / +27 lines)
Lines 946-951 Link Here
946
	GFC_DECL_PACKED_ARRAY (decl) = 1;
946
	GFC_DECL_PACKED_ARRAY (decl) = 1;
947
    }
947
    }
948
948
949
  if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
950
    gfc_defer_symbol_init (sym);
951
949
  gfc_finish_var_decl (decl, sym);
952
  gfc_finish_var_decl (decl, sym);
950
953
951
  if (sym->ts.type == BT_CHARACTER)
954
  if (sym->ts.type == BT_CHARACTER)
Lines 2595-2607 Link Here
2595
	      break;
2598
	      break;
2596
2599
2597
	    case AS_DEFERRED:
2600
	    case AS_DEFERRED:
2598
	      fnbody = gfc_trans_deferred_array (sym, fnbody);
2601
	      if (!(sym->ts.type == BT_DERIVED
2602
		      && sym->ts.derived->attr.alloc_comp))
2603
		fnbody = gfc_trans_deferred_array (sym, fnbody);
2599
	      break;
2604
	      break;
2600
2605
2601
	    default:
2606
	    default:
2602
	      gcc_unreachable ();
2607
	      gcc_unreachable ();
2603
	    }
2608
	    }
2609
	  if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
2610
	    fnbody = gfc_trans_deferred_array (sym, fnbody);
2604
	}
2611
	}
2612
      else if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
2613
	fnbody = gfc_trans_deferred_array (sym, fnbody);
2605
      else if (sym->ts.type == BT_CHARACTER)
2614
      else if (sym->ts.type == BT_CHARACTER)
2606
	{
2615
	{
2607
	  gfc_get_backend_locus (&loc);
2616
	  gfc_get_backend_locus (&loc);
Lines 2837-2846 Link Here
2837
  tree old_context;
2846
  tree old_context;
2838
  tree decl;
2847
  tree decl;
2839
  tree tmp;
2848
  tree tmp;
2849
  tree tmp2;
2840
  stmtblock_t block;
2850
  stmtblock_t block;
2841
  stmtblock_t body;
2851
  stmtblock_t body;
2842
  tree result;
2852
  tree result;
2843
  gfc_symbol *sym;
2853
  gfc_symbol *sym;
2854
  int rank;
2844
2855
2845
  sym = ns->proc_name;
2856
  sym = ns->proc_name;
2846
2857
Lines 3000-3006 Link Here
3000
  tmp = gfc_finish_block (&body);
3011
  tmp = gfc_finish_block (&body);
3001
  /* Add code to create and cleanup arrays.  */
3012
  /* Add code to create and cleanup arrays.  */
3002
  tmp = gfc_trans_deferred_vars (sym, tmp);
3013
  tmp = gfc_trans_deferred_vars (sym, tmp);
3003
  gfc_add_expr_to_block (&block, tmp);
3004
3014
3005
  if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
3015
  if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
3006
    {
3016
    {
Lines 3015-3021 Link Here
3015
      else
3025
      else
3016
	result = sym->result->backend_decl;
3026
	result = sym->result->backend_decl;
3017
3027
3018
      if (result == NULL_TREE)
3028
      if (result != NULL_TREE && sym->attr.function
3029
	    && sym->ts.type == BT_DERIVED
3030
	    && sym->ts.derived->attr.alloc_comp)
3031
	{
3032
	  rank = sym->as ? sym->as->rank : 0;
3033
	  tmp2 = nullify_alloc_comp (sym->ts.derived, result, rank);
3034
	  gfc_add_expr_to_block (&block, tmp2);
3035
	}
3036
3037
     gfc_add_expr_to_block (&block, tmp);
3038
3039
     if (result == NULL_TREE)
3019
	warning (0, "Function return value not set");
3040
	warning (0, "Function return value not set");
3020
      else
3041
      else
3021
	{
3042
	{
Lines 3026-3032 Link Here
3026
	  gfc_add_expr_to_block (&block, tmp);
3047
	  gfc_add_expr_to_block (&block, tmp);
3027
	}
3048
	}
3028
    }
3049
    }
3050
  else
3051
    gfc_add_expr_to_block (&block, tmp);
3029
3052
3053
3030
  /* Add all the decls we created during processing.  */
3054
  /* Add all the decls we created during processing.  */
3031
  decl = saved_function_decls;
3055
  decl = saved_function_decls;
3032
  while (decl)
3056
  while (decl)
(-)gcc/fortran/parse.c (+13 lines)
Lines 1500-1505 Link Here
1500
  gfc_statement st;
1500
  gfc_statement st;
1501
  gfc_component *c;
1501
  gfc_component *c;
1502
  gfc_state_data s;
1502
  gfc_state_data s;
1503
  gfc_symbol *sym;
1503
1504
1504
  error_flag = 0;
1505
  error_flag = 0;
1505
1506
Lines 1610-1615 Link Here
1610
	  }
1611
	  }
1611
      }
1612
      }
1612
1613
1614
  /* Look for allocatable components.  */
1615
  sym = gfc_current_block ();
1616
  for (c = sym->components; c; c = c->next)
1617
    {
1618
      if (c->allocatable || (c->ts.type == BT_DERIVED
1619
		    	     && c->ts.derived->attr.alloc_comp))
1620
	{
1621
	  sym->attr.alloc_comp = 1;
1622
	  break;
1623
	}
1624
     }
1625
1613
  pop_state ();
1626
  pop_state ();
1614
}
1627
}
1615
1628
(-)gcc/fortran/check.c (-1 / +4 lines)
Lines 461-473 Link Here
461
try
461
try
462
gfc_check_allocated (gfc_expr * array)
462
gfc_check_allocated (gfc_expr * array)
463
{
463
{
464
  symbol_attribute attr;
465
464
  if (variable_check (array, 0) == FAILURE)
466
  if (variable_check (array, 0) == FAILURE)
465
    return FAILURE;
467
    return FAILURE;
466
468
467
  if (array_check (array, 0) == FAILURE)
469
  if (array_check (array, 0) == FAILURE)
468
    return FAILURE;
470
    return FAILURE;
469
471
470
  if (!array->symtree->n.sym->attr.allocatable)
472
  attr = gfc_variable_attr (array, NULL);
473
  if (!attr.allocatable)
471
    {
474
    {
472
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
475
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
473
		 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
476
		 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
(-)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;

Return to bug 20541