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

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

(-)gcc/fortran/interface.c (+3 lines)
 Lines 374-379   gfc_compare_derived_types (gfc_symbol * 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   add_subroutines (void) 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 (-25 / +351 lines)
 Lines 3227-3235   gfc_array_allocate (gfc_se * se, gfc_exp Link Here 
3227
  tree size;
3227
  tree size;
3228
  gfc_expr **lower;
3228
  gfc_expr **lower;
3229
  gfc_expr **upper;
3229
  gfc_expr **upper;
3230
  gfc_ref *ref;
3230
  gfc_ref *ref, *prev_ref = NULL;
3231
  int allocatable_array;
3231
  bool allocatable_array;
3232
  int must_be_pointer;
3233
3232
3234
  ref = expr->ref;
3233
  ref = expr->ref;
3235
3234
 Lines 3238-3258   gfc_array_allocate (gfc_se * se, gfc_exp Link Here 
3238
     We test this by checking for ref->next.
3237
     We test this by checking for ref->next.
3239
     An implementation of TR 15581 would need to change this.  */
3238
     An implementation of TR 15581 would need to change this.  */
3240
3239
3240
  #if 0
3241
  if (ref)
3241
  if (ref)
3242
    must_be_pointer = ref->next != NULL;
3242
    must_be_pointer = ref->next != NULL;
3243
  else
3243
  else
3244
    must_be_pointer = 0;
3244
    must_be_pointer = 0;
3245
3246
  if (must_be_pointer)
3247
    allocatable_array = 0;
3248
  else
3249
    allocatable_array = expr->symtree->n.sym->attr.allocatable;
3250
  #endif
3245
  
3251
  
3246
  /* Find the last reference in the chain.  */
3252
  /* Find the last reference in the chain.  */
3247
  while (ref && ref->next != NULL)
3253
  while (ref && ref->next != NULL)
3248
    {
3254
    {
3249
      gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3255
      gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3256
      prev_ref = ref;
3250
      ref = ref->next;
3257
      ref = ref->next;
3251
    }
3258
    }
3252
3259
3253
  if (ref == NULL || ref->type != REF_ARRAY)
3260
  if (ref == NULL || ref->type != REF_ARRAY)
3254
    return false;
3261
    return false;
3255
3262
3263
  if (!prev_ref)
3264
    allocatable_array = expr->symtree->n.sym->attr.allocatable;
3265
  else
3266
    allocatable_array = prev_ref->u.c.component->allocatable;
3267
3256
  /* Figure out the size of the array.  */
3268
  /* Figure out the size of the array.  */
3257
  switch (ref->u.ar.type)
3269
  switch (ref->u.ar.type)
3258
    {
3270
    {
 Lines 3285-3295   gfc_array_allocate (gfc_se * se, gfc_exp Link Here 
3285
  tmp = gfc_conv_descriptor_data_addr (se->expr);
3297
  tmp = gfc_conv_descriptor_data_addr (se->expr);
3286
  pointer = gfc_evaluate_now (tmp, &se->pre);
3298
  pointer = gfc_evaluate_now (tmp, &se->pre);
3287
3299
3288
  if (must_be_pointer)
3289
    allocatable_array = 0;
3290
  else
3291
    allocatable_array = expr->symtree->n.sym->attr.allocatable;
3292
3293
  if (TYPE_PRECISION (gfc_array_index_type) == 32)
3300
  if (TYPE_PRECISION (gfc_array_index_type) == 32)
3294
    {
3301
    {
3295
      if (allocatable_array)
3302
      if (allocatable_array)
 Lines 3316-3321   gfc_array_allocate (gfc_se * se, gfc_exp Link Here 
3316
  tmp = gfc_conv_descriptor_offset (se->expr);
3323
  tmp = gfc_conv_descriptor_offset (se->expr);
3317
  gfc_add_modify_expr (&se->pre, tmp, offset);
3324
  gfc_add_modify_expr (&se->pre, tmp, offset);
3318
3325
3326
  if (expr->ts.type == BT_DERIVED && expr->ts.derived->attr.alloc_comp)
3327
    {
3328
      tmp = gfc_nullify_alloc_comp (expr->ts.derived, se->expr,
3329
				    ref->u.ar.as->rank);
3330
      gfc_add_expr_to_block (&se->pre, tmp);
3331
    }
3332
3319
  return true;
3333
  return true;
3320
}
3334
}
3321
3335
 Lines 3456-3461   gfc_conv_array_initializer (tree type, g Link Here 
3456
        }
3470
        }
3457
      break;
3471
      break;
3458
3472
3473
    case EXPR_NULL:
3474
      return gfc_build_null_descriptor (type);
3475
3459
    default:
3476
    default:
3460
      gcc_unreachable ();
3477
      gcc_unreachable ();
3461
    }
3478
    }
 Lines 4538-4543   gfc_conv_array_parameter (gfc_se * se, g Link Here 
4538
  se->want_pointer = 1;
4555
  se->want_pointer = 1;
4539
  gfc_conv_expr_descriptor (se, expr, ss);
4556
  gfc_conv_expr_descriptor (se, expr, ss);
4540
4557
4558
  /* Deallocate the allocatable components of structures that are
4559
     not variable.  */
4560
  if (expr->ts.type == BT_DERIVED
4561
	&& expr->ts.derived->attr.alloc_comp
4562
	&& expr->expr_type != EXPR_VARIABLE)
4563
    {
4564
      tmp = build_fold_indirect_ref (se->expr);
4565
      tmp = gfc_deallocate_alloc_comp (expr->ts.derived, tmp, expr->rank);
4566
      gfc_add_expr_to_block (&se->post, tmp);
4567
    }
4568
4541
  if (g77)
4569
  if (g77)
4542
    {
4570
    {
4543
      desc = se->expr;
4571
      desc = se->expr;
 Lines 4586-4606   tree Link Here 
4586
gfc_trans_dealloc_allocated (tree descriptor)
4614
gfc_trans_dealloc_allocated (tree descriptor)
4587
{ 
4615
{ 
4588
  tree tmp;
4616
  tree tmp;
4589
  tree deallocate;
4617
  tree ptr;
4618
  tree var;
4590
  stmtblock_t block;
4619
  stmtblock_t block;
4591
4620
4592
  gfc_start_block (&block);
4621
  gfc_start_block (&block);
4593
  deallocate = gfc_array_deallocate (descriptor, null_pointer_node);
4594
4622
4595
  tmp = gfc_conv_descriptor_data_get (descriptor);
4623
  tmp = gfc_conv_descriptor_data_addr (descriptor);
4596
  tmp = build2 (NE_EXPR, boolean_type_node, tmp,
4624
  var = gfc_evaluate_now (tmp, &block);
4597
                build_int_cst (TREE_TYPE (tmp), 0));
4625
  tmp = gfc_create_var (gfc_array_index_type, NULL);
4598
  tmp = build3_v (COND_EXPR, tmp, deallocate, build_empty_stmt ());
4626
  ptr = build_fold_addr_expr (tmp);
4627
4628
  /* Call array_deallocate with an int* present in the second argument.
4629
     Although it is ignored here, it's presence ensures that arrays that
4630
     are already deallocated are ignored.  */
4631
  tmp = gfc_chainon_list (NULL_TREE, var);
4632
  tmp = gfc_chainon_list (tmp, ptr);
4633
  tmp = build_function_call_expr (gfor_fndecl_deallocate, tmp);
4599
  gfc_add_expr_to_block (&block, tmp);
4634
  gfc_add_expr_to_block (&block, tmp);
4635
  return gfc_finish_block (&block);
4636
}
4600
4637
4601
  tmp = gfc_finish_block (&block);
4602
4638
4603
  return tmp;
4639
/* This helper function calculates the size in words of a full array.  */
4640
4641
static tree
4642
get_full_array_size (stmtblock_t *block, tree decl, int rank)
4643
{
4644
  tree idx;
4645
  tree nelems;
4646
  tree tmp;
4647
  idx = gfc_rank_cst[rank - 1];
4648
  nelems = gfc_conv_descriptor_ubound (decl, idx);
4649
  tmp = gfc_conv_descriptor_lbound (decl, idx);
4650
  tmp = build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
4651
  tmp = build2 (PLUS_EXPR, gfc_array_index_type,
4652
		tmp, gfc_index_one_node);
4653
  tmp = gfc_evaluate_now (tmp, block);
4654
4655
  nelems = gfc_conv_descriptor_stride (decl, idx);
4656
  tmp = build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
4657
  return gfc_evaluate_now (tmp, block);
4658
}
4659
4660
4661
/* Recursively traverse an object of derived type, generating code to deallocate,
4662
   nullify or copy allocatable components.  This is the work horse function for
4663
   the functions named in this enum.  */
4664
enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP};
4665
4666
static tree
4667
structure_alloc_comps (gfc_symbol * der_type, tree decl,
4668
		       tree dest, int rank, int purpose)
4669
{
4670
  gfc_component *c;
4671
  gfc_loopinfo loop;
4672
  stmtblock_t fnblock;
4673
  stmtblock_t loopbody;
4674
  tree tmp;
4675
  tree comp;
4676
  tree dcmp;
4677
  tree nelems;
4678
  tree index;
4679
  tree var, dvar;
4680
  tree cdecl;
4681
  tree ctype;
4682
  tree vref, dref;
4683
4684
  gfc_init_block (&fnblock);
4685
4686
  /* If this an array of derived types with allocatable components
4687
     build a loop and recursively call this function.  */
4688
  if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE
4689
	|| GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
4690
    {
4691
      tmp = gfc_conv_array_data (decl);
4692
      var = build_fold_indirect_ref (tmp);
4693
	
4694
      /* Get the number of elements - 1 and set the counter.  */
4695
      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
4696
	{
4697
	  /* Use the descriptor for an allocatable array.  Since this
4698
	     is a full array reference, we only need the descriptor
4699
	     information from dimension = rank.  */
4700
	  nelems = get_full_array_size (&fnblock, decl, rank);
4701
4702
	  /* Set the result to -1 if already deallocated, so that the
4703
	     loop does not run.  */
4704
	  tmp = gfc_conv_descriptor_data_get (decl);
4705
	  tmp = build2 (NE_EXPR, boolean_type_node, tmp,
4706
			build_int_cst (TREE_TYPE (tmp), 0));
4707
	  tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
4708
			nelems, gfc_index_zero_node);
4709
	  tmp = gfc_evaluate_now (tmp, &fnblock);
4710
	  tmp = build2 (MINUS_EXPR, gfc_array_index_type,
4711
			   tmp, gfc_index_one_node);
4712
	}
4713
      else
4714
	{
4715
	  /*  Otherwise use the TYPE_DOMAIN information.  */
4716
	  tmp =  array_type_nelts (TREE_TYPE (decl));
4717
	  tmp = fold_convert (gfc_array_index_type, tmp);
4718
	}
4719
4720
      nelems = gfc_evaluate_now (tmp, &fnblock);
4721
      index = gfc_create_var (gfc_array_index_type, "S");
4722
4723
      /* Build the body of the loop.  */
4724
      gfc_init_block (&loopbody);
4725
4726
      vref = gfc_build_array_ref (var, index);
4727
4728
      if (purpose == COPY_ALLOC_COMP)
4729
        {
4730
	  dvar = build_fold_indirect_ref (gfc_conv_array_data (dest));
4731
	  dref = gfc_build_array_ref (dvar, index);
4732
	  tmp = structure_alloc_comps (der_type, vref, dref, 0, purpose);
4733
	}
4734
      else
4735
        tmp = structure_alloc_comps (der_type, vref, NULL_TREE, 0, purpose);
4736
4737
      gfc_add_expr_to_block (&loopbody, tmp);
4738
4739
      /* Build the loop and return. */
4740
      gfc_init_loopinfo (&loop);
4741
      loop.dimen = 1;
4742
      loop.from[0] = gfc_index_zero_node;
4743
      loop.loopvar[0] = index;
4744
      loop.to[0] = nelems;
4745
      gfc_trans_scalarizing_loops (&loop, &loopbody);
4746
      gfc_add_block_to_block (&fnblock, &loop.pre);
4747
      return gfc_finish_block (&fnblock);
4748
    }
4749
4750
  /* Otherwise, deallocate the components or recursively call self to
4751
     deallocate the components of components. */
4752
  for (c = der_type->components; c; c = c->next)
4753
    {
4754
      cdecl = c->backend_decl;
4755
      ctype = TREE_TYPE (cdecl);
4756
4757
      switch (purpose)
4758
	{
4759
	case DEALLOCATE_ALLOC_COMP:
4760
	  /* Do not deallocate the components of ultimate pointer
4761
	     components.  */
4762
	  if (c->ts.type == BT_DERIVED
4763
		&& c->ts.derived->attr.alloc_comp
4764
		&& !c->pointer)
4765
	    {
4766
	      comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
4767
	      rank = c->as ? c->as->rank : 0;
4768
	      tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
4769
					   rank, purpose);
4770
	      gfc_add_expr_to_block (&fnblock, tmp);
4771
	    }
4772
4773
	  if (c->allocatable)
4774
	    {
4775
	      comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
4776
	      tmp = gfc_trans_dealloc_allocated (comp);
4777
	      gfc_add_expr_to_block (&fnblock, tmp);
4778
	    }
4779
	  break;
4780
4781
	case NULLIFY_ALLOC_COMP:
4782
	  if (c->pointer)
4783
	    continue;
4784
	  else if (c->allocatable)
4785
	    {
4786
	      comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
4787
	      gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
4788
	    }
4789
          else if (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp)
4790
	    {
4791
	      comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
4792
	      rank = c->as ? c->as->rank : 0;
4793
	      tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
4794
					   rank, purpose);
4795
	      gfc_add_expr_to_block (&fnblock, tmp);
4796
	    }
4797
	  break;
4798
4799
	case COPY_ALLOC_COMP:
4800
	  if (c->pointer)
4801
	    continue;
4802
4803
	  comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
4804
	  dcmp = build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
4805
	  dcmp = fold_convert (TREE_TYPE (comp), dcmp);
4806
4807
	  if (c->allocatable)
4808
	    {
4809
	      tree size;
4810
	      tree args;
4811
	      tree null_cond;
4812
	      tree null_data;
4813
	      stmtblock_t block;
4814
4815
	      /* If the source is null, set the destination to null. */
4816
	      gfc_init_block (&block);
4817
	      gfc_conv_descriptor_data_set (&block, dcmp,
4818
					    null_pointer_node);
4819
	      null_data = gfc_finish_block (&block);
4820
4821
	      gfc_init_block (&block);
4822
	      nelems = get_full_array_size (&block, comp, c->as->rank);
4823
	      size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
4824
				  TYPE_SIZE_UNIT (gfc_get_element_type (ctype)));
4825
4826
	      /* Allocate memory to the destination.  */
4827
	      tmp = gfc_chainon_list (NULL_TREE, size);
4828
	      if (gfc_index_integer_kind == 4)
4829
		tmp = build_function_call_expr (gfor_fndecl_internal_malloc, tmp);
4830
	      else if (gfc_index_integer_kind == 8)
4831
		tmp = build_function_call_expr (gfor_fndecl_internal_malloc64, tmp);
4832
	      else
4833
		gcc_unreachable ();
4834
	      tmp = fold (convert (TREE_TYPE (gfc_conv_descriptor_data_get (comp)),
4835
		          tmp));
4836
	      gfc_conv_descriptor_data_set (&block, dcmp, tmp);
4837
4838
	      /* We know the temporary and the value will be the same length,
4839
		 so can use memcpy.  */
4840
	      tmp = gfc_conv_descriptor_data_get (dcmp);
4841
	      args = gfc_chainon_list (NULL_TREE, tmp);
4842
	      tmp = gfc_conv_descriptor_data_get (comp);
4843
	      args = gfc_chainon_list (args, tmp);
4844
	      args = gfc_chainon_list (args, size);
4845
	      tmp = built_in_decls[BUILT_IN_MEMCPY];
4846
	      tmp = build_function_call_expr (tmp, args);
4847
	      gfc_add_expr_to_block (&block, tmp);
4848
	      tmp = gfc_finish_block (&block);
4849
4850
	      /* Null the destination if the source is null; otherwise do
4851
		 the allocate and copy.  */
4852
	      null_cond = gfc_conv_descriptor_data_get (comp);
4853
	      null_cond = convert (pvoid_type_node, null_cond);
4854
	      null_cond = build2 (NE_EXPR, boolean_type_node, null_cond,
4855
				  null_pointer_node);
4856
	      tmp = build3_v (COND_EXPR, null_cond, tmp, null_data);
4857
	      gfc_add_expr_to_block (&fnblock, tmp);
4858
	    }
4859
4860
          if (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp)
4861
	    {
4862
	      rank = c->as ? c->as->rank : 0;
4863
	      tmp = structure_alloc_comps (c->ts.derived, comp, dcmp,
4864
					   rank, purpose);
4865
	      gfc_add_expr_to_block (&fnblock, tmp);
4866
	    }
4867
	  break;
4868
4869
	default:
4870
	  gcc_unreachable ();
4871
	  break;
4872
	}
4873
    }
4874
4875
  return gfc_finish_block (&fnblock);
4876
}
4877
4878
/* Recursively traverse an object of derived type, generating code to
4879
   nullify allocatable components.  */
4880
4881
tree
4882
gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
4883
{
4884
  return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
4885
				NULLIFY_ALLOC_COMP);
4886
}
4887
4888
4889
/* Recursively traverse an object of derived type, generating code to
4890
   deallocate allocatable components.  */
4891
4892
tree
4893
gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
4894
{
4895
  return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
4896
				DEALLOCATE_ALLOC_COMP);
4897
}
4898
4899
4900
/* Recursively traverse an object of derived type, generating code to
4901
   copy its allocatable components.  */
4902
4903
tree
4904
gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
4905
{
4906
  return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
4604
}
4907
}
4605
4908
4606
4909
 Lines 4614-4629   gfc_trans_deferred_array (gfc_symbol * s Link Here 
4614
  tree descriptor;
4917
  tree descriptor;
4615
  stmtblock_t fnblock;
4918
  stmtblock_t fnblock;
4616
  locus loc;
4919
  locus loc;
4920
  int rank;
4617
4921
4618
  /* Make sure the frontend gets these right.  */
4922
  /* Make sure the frontend gets these right.  */
4619
  if (!(sym->attr.pointer || sym->attr.allocatable))
4923
  if (!(sym->attr.pointer || sym->attr.allocatable
4620
    fatal_error
4924
	|| (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)))
4621
      ("Possible frontend bug: Deferred array size without pointer or allocatable attribute.");
4925
    fatal_error ("Possible frontend bug: Deferred array size without pointer"
4926
		 "allocatable attribute.");
4622
4927
4623
  gfc_init_block (&fnblock);
4928
  gfc_init_block (&fnblock);
4624
4929
4625
  gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
4930
  gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
4626
                || TREE_CODE (sym->backend_decl) == PARM_DECL);
4931
		|| TREE_CODE (sym->backend_decl) == PARM_DECL);
4627
4932
4628
  if (sym->ts.type == BT_CHARACTER
4933
  if (sym->ts.type == BT_CHARACTER
4629
      && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4934
      && !INTEGER_CST_P (sym->ts.cl->backend_decl))
 Lines 4653-4674   gfc_trans_deferred_array (gfc_symbol * s Link Here 
4653
4958
4654
  /* Get the descriptor type.  */
4959
  /* Get the descriptor type.  */
4655
  type = TREE_TYPE (sym->backend_decl);
4960
  type = TREE_TYPE (sym->backend_decl);
4656
  if (!GFC_DESCRIPTOR_TYPE_P (type))
4961
    
4962
  if (sym->ts.type == BT_DERIVED
4963
	&& sym->ts.derived->attr.alloc_comp
4964
	&& !(sym->attr.pointer || sym->attr.allocatable))
4965
    {
4966
      rank = sym->as ? sym->as->rank : 0;
4967
      tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank);
4968
      gfc_add_expr_to_block (&fnblock, tmp);
4969
    }
4970
  else if (!GFC_DESCRIPTOR_TYPE_P (type))
4657
    {
4971
    {
4658
      /* If the backend_decl is not a descriptor, we must have a pointer
4972
      /* If the backend_decl is not a descriptor, we must have a pointer
4659
	 to one.  */
4973
	 to one.  */
4660
      descriptor = build_fold_indirect_ref (sym->backend_decl);
4974
      descriptor = build_fold_indirect_ref (sym->backend_decl);
4661
      type = TREE_TYPE (descriptor);
4975
      type = TREE_TYPE (descriptor);
4662
      gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
4663
    }
4976
    }
4664
4977
  
4665
  /* NULLIFY the data pointer.  */
4978
  /* NULLIFY the data pointer.  */
4666
  gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
4979
  if (GFC_DESCRIPTOR_TYPE_P (type))
4980
    gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
4667
4981
4668
  gfc_add_expr_to_block (&fnblock, body);
4982
  gfc_add_expr_to_block (&fnblock, body);
4669
4983
4670
  gfc_set_backend_locus (&loc);
4984
  gfc_set_backend_locus (&loc);
4671
  /* Allocatable arrays need to be freed when they go out of scope.  */
4985
4986
  /* Allocatable arrays need to be freed when they go out of scope.
4987
     The allocatable components of pointers must not be touched.  */
4988
  if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp
4989
      && !(sym->attr.function || sym->attr.result)
4990
      && !sym->attr.pointer)
4991
    {
4992
      int rank;
4993
      rank = sym->as ? sym->as->rank : 0;
4994
      tmp = gfc_deallocate_alloc_comp (sym->ts.derived, descriptor, rank);
4995
      gfc_add_expr_to_block (&fnblock, tmp);
4996
    }
4997
4672
  if (sym->attr.allocatable)
4998
  if (sym->attr.allocatable)
4673
    {
4999
    {
4674
      tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
5000
      tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
(-)gcc/fortran/trans-expr.c (-18 / +192 lines)
 Lines 42-48   Software Foundation, 51 Franklin Street, 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   gfc_conv_aliased_arg (gfc_se * parmse, g 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   gfc_conv_aliased_arg (gfc_se * parmse, g 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   gfc_conv_function_call (gfc_se * se, gfc 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   gfc_conv_function_call (gfc_se * se, gfc 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   gfc_conv_function_call (gfc_se * se, gfc 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   gfc_conv_function_call (gfc_se * se, gfc 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   gfc_conv_function_call (gfc_se * se, gfc 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 2024-2029   gfc_conv_function_call (gfc_se * se, gfc Link Here 
2024
	  gfc_add_expr_to_block (&se->pre, tmp);
2030
	  gfc_add_expr_to_block (&se->pre, tmp);
2025
	}
2031
	}
2026
2032
2033
      /* Allocated allocatable components of derived types must be
2034
	 deallocated for INTENT(OUT) dummy arguments and non-variable
2035
         scalars.  Non-variable arrays are dealt with in trans-array.c
2036
         (gfc_conv_array_parameter).  */
2037
      if (e && e->ts.type == BT_DERIVED
2038
	    && e->ts.derived->attr.alloc_comp
2039
	    && ((formal && formal->sym->attr.intent == INTENT_OUT)
2040
		   ||
2041
		(e->expr_type != EXPR_VARIABLE && !e->rank)))
2042
        {
2043
	  int parm_rank;
2044
	  tmp = build_fold_indirect_ref (parmse.expr);
2045
	  parm_rank = e->rank;
2046
	  switch (parm_kind)
2047
	    {
2048
	    case (ELEMENTAL):
2049
	    case (SCALAR):
2050
	      parm_rank = 0;
2051
	      break;
2052
2053
	    case (SCALAR_POINTER):
2054
              tmp = build_fold_indirect_ref (tmp);
2055
	      break;
2056
	    case (ARRAY):
2057
              tmp = parmse.expr;
2058
	      break;
2059
	    }
2060
2061
          tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
2062
	  if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
2063
	    tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym),
2064
			    tmp, build_empty_stmt ());
2065
2066
	  if (e->expr_type != EXPR_VARIABLE)
2067
	    /* Don't deallocate non-variables until they have been used.  */
2068
	    gfc_add_expr_to_block (&se->post, tmp);
2069
	  else 
2070
	    {
2071
	      gcc_assert (formal && formal->sym->attr.intent == INTENT_OUT);
2072
	      gfc_add_expr_to_block (&se->pre, tmp);
2073
	    }
2074
        }
2075
2027
      /* Character strings are passed as two parameters, a length and a
2076
      /* Character strings are passed as two parameters, a length and a
2028
         pointer.  */
2077
         pointer.  */
2029
      if (parmse.string_length != NULL_TREE)
2078
      if (parmse.string_length != NULL_TREE)
 Lines 2600-2606   gfc_trans_subarray_assign (tree dest, gf Link Here 
2600
2649
2601
  gfc_conv_expr (&rse, expr);
2650
  gfc_conv_expr (&rse, expr);
2602
2651
2603
  tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
2652
  tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
2604
  gfc_add_expr_to_block (&body, tmp);
2653
  gfc_add_expr_to_block (&body, tmp);
2605
2654
2606
  gcc_assert (rse.ss == gfc_ss_terminator);
2655
  gcc_assert (rse.ss == gfc_ss_terminator);
 Lines 2624-2637   gfc_trans_subarray_assign (tree dest, gf Link Here 
2624
/* Assign a single component of a derived type constructor.  */
2673
/* Assign a single component of a derived type constructor.  */
2625
2674
2626
static tree
2675
static tree
2627
gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2676
gfc_trans_subcomponent_assign (gfc_se * outer_se, tree dest,
2677
			       gfc_component * cm, gfc_expr * expr)
2628
{
2678
{
2629
  gfc_se se;
2679
  gfc_se se;
2680
  gfc_se lse;
2630
  gfc_ss *rss;
2681
  gfc_ss *rss;
2631
  stmtblock_t block;
2682
  stmtblock_t block;
2632
  tree tmp;
2683
  tree tmp;
2684
  tree offset;
2685
  int n;
2633
2686
2634
  gfc_start_block (&block);
2687
  gfc_start_block (&block);
2688
2689
#if 0
2690
  if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
2691
    gfc_todo_error ("derived types with allocatable components as "
2692
		    "arguments of derived type constructors");
2693
#endif
2635
  if (cm->pointer)
2694
  if (cm->pointer)
2636
    {
2695
    {
2637
      gfc_init_se (&se, NULL);
2696
      gfc_init_se (&se, NULL);
 Lines 2664-2671   gfc_trans_subcomponent_assign (tree dest Link Here 
2664
    }
2723
    }
2665
  else if (cm->dimension)
2724
  else if (cm->dimension)
2666
    {
2725
    {
2667
      tmp = gfc_trans_subarray_assign (dest, cm, expr);
2726
      if (cm->allocatable && expr->expr_type == EXPR_NULL)
2668
      gfc_add_expr_to_block (&block, tmp);
2727
 	gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
2728
      else if (cm->allocatable)
2729
       {
2730
         tree tmp2;
2731
 
2732
         gfc_init_se (&se, NULL);
2733
         gfc_init_se (&lse, NULL);
2734
 
2735
         se.want_pointer = 0;
2736
         gfc_conv_expr_descriptor (&se, expr, gfc_walk_expr (expr));
2737
         if (cm->ts.type == BT_CHARACTER)
2738
           lse.string_length = cm->ts.cl->backend_decl;
2739
 
2740
         lse.expr = dest;
2741
 
2742
         /* Clean up temporaries at the right time.  */
2743
         if (expr->expr_type == EXPR_FUNCTION)
2744
           {
2745
             stmtblock_t tmp_block;
2746
 
2747
             /* Prevent the freeing of the memory after the array assignment to
2748
                the derived type component....  */
2749
             gfc_init_block (&tmp_block);
2750
             gfc_add_block_to_block (&tmp_block, &se.post);
2751
             gfc_conv_descriptor_data_set (&se.post, se.expr, null_pointer_node);
2752
             gfc_add_block_to_block (&se.post, &tmp_block);
2753
 
2754
             /* ...and do it when the derived type is completed.  */
2755
             tmp = gfc_conv_descriptor_data_get (lse.expr);
2756
             tmp = convert (pvoid_type_node, tmp);
2757
             tmp = gfc_chainon_list (NULL_TREE, tmp);
2758
             tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
2759
             gfc_add_expr_to_block (&outer_se->post, tmp);
2760
           }
2761
 
2762
         tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
2763
         gfc_add_expr_to_block (&block, tmp);
2764
 
2765
         /* Shift the lbound and ubound of temporaries to being unity, rather
2766
            than zero, based.  Calculate the offset for all cases.  */
2767
         offset = gfc_conv_descriptor_offset (dest);
2768
         gfc_add_modify_expr (&block, offset, gfc_index_zero_node);
2769
         tmp2 =gfc_create_var (gfc_array_index_type, NULL);
2770
         for (n = 0; n < expr->rank; n++)
2771
           {
2772
             if (expr->expr_type != EXPR_VARIABLE
2773
                   && expr->expr_type != EXPR_CONSTANT)
2774
               {
2775
                 tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
2776
                 gfc_add_modify_expr (&block, tmp,
2777
                                      fold_build2 (PLUS_EXPR, gfc_array_index_type,
2778
                                                   tmp, gfc_index_one_node));
2779
                 tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
2780
                 gfc_add_modify_expr (&block, tmp, gfc_index_one_node);
2781
               }
2782
             tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2783
                                gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]),
2784
                                gfc_conv_descriptor_stride (dest, gfc_rank_cst[n]));
2785
             gfc_add_modify_expr (&block, tmp2, tmp);
2786
             tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
2787
             gfc_add_modify_expr (&block, offset, tmp);
2788
           }  
2789
       }
2790
      else
2791
        {
2792
	  tmp = gfc_trans_subarray_assign (dest, cm, expr);
2793
	  gfc_add_expr_to_block (&block, tmp);
2794
        }
2669
    }
2795
    }
2670
  else if (expr->ts.type == BT_DERIVED)
2796
  else if (expr->ts.type == BT_DERIVED)
2671
    {
2797
    {
 Lines 2679-2693   gfc_trans_subcomponent_assign (tree dest Link Here 
2679
      else
2805
      else
2680
	{
2806
	{
2681
	  /* Nested constructors.  */
2807
	  /* Nested constructors.  */
2682
	  tmp = gfc_trans_structure_assign (dest, expr);
2808
	  tmp = gfc_trans_structure_assign (outer_se, dest, expr);
2683
	  gfc_add_expr_to_block (&block, tmp);
2809
	  gfc_add_expr_to_block (&block, tmp);
2684
	}
2810
	}
2685
    }
2811
    }
2686
  else
2812
  else
2687
    {
2813
    {
2688
      /* Scalar component.  */
2814
      /* Scalar component.  */
2689
      gfc_se lse;
2690
2691
      gfc_init_se (&se, NULL);
2815
      gfc_init_se (&se, NULL);
2692
      gfc_init_se (&lse, NULL);
2816
      gfc_init_se (&lse, NULL);
2693
2817
 Lines 2695-2701   gfc_trans_subcomponent_assign (tree dest Link Here 
2695
      if (cm->ts.type == BT_CHARACTER)
2819
      if (cm->ts.type == BT_CHARACTER)
2696
	lse.string_length = cm->ts.cl->backend_decl;
2820
	lse.string_length = cm->ts.cl->backend_decl;
2697
      lse.expr = dest;
2821
      lse.expr = dest;
2698
      tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type);
2822
      tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
2699
      gfc_add_expr_to_block (&block, tmp);
2823
      gfc_add_expr_to_block (&block, tmp);
2700
    }
2824
    }
2701
  return gfc_finish_block (&block);
2825
  return gfc_finish_block (&block);
 Lines 2704-2710   gfc_trans_subcomponent_assign (tree dest Link Here 
2704
/* Assign a derived type constructor to a variable.  */
2828
/* Assign a derived type constructor to a variable.  */
2705
2829
2706
static tree
2830
static tree
2707
gfc_trans_structure_assign (tree dest, gfc_expr * expr)
2831
gfc_trans_structure_assign (gfc_se * outer_se, tree dest, gfc_expr * expr)
2708
{
2832
{
2709
  gfc_constructor *c;
2833
  gfc_constructor *c;
2710
  gfc_component *cm;
2834
  gfc_component *cm;
 Lines 2722-2728   gfc_trans_structure_assign (tree dest, g Link Here 
2722
2846
2723
      field = cm->backend_decl;
2847
      field = cm->backend_decl;
2724
      tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
2848
      tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
2725
      tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
2849
      tmp = gfc_trans_subcomponent_assign (outer_se, tmp, cm, c->expr);
2726
      gfc_add_expr_to_block (&block, tmp);
2850
      gfc_add_expr_to_block (&block, tmp);
2727
    }
2851
    }
2728
  return gfc_finish_block (&block);
2852
  return gfc_finish_block (&block);
 Lines 2749-2755   gfc_conv_structure (gfc_se * se, gfc_exp Link Here 
2749
    {
2873
    {
2750
      /* Create a temporary variable and fill it in.  */
2874
      /* Create a temporary variable and fill it in.  */
2751
      se->expr = gfc_create_var (type, expr->ts.derived->name);
2875
      se->expr = gfc_create_var (type, expr->ts.derived->name);
2752
      tmp = gfc_trans_structure_assign (se->expr, expr);
2876
      tmp = gfc_trans_structure_assign (se, se->expr, expr);
2753
      gfc_add_expr_to_block (&se->pre, tmp);
2877
      gfc_add_expr_to_block (&se->pre, tmp);
2754
      return;
2878
      return;
2755
    }
2879
    }
 Lines 3056-3068   gfc_conv_string_parameter (gfc_se * se) Link Here 
3056
   strings.  */
3180
   strings.  */
3057
3181
3058
tree
3182
tree
3059
gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
3183
gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
3184
			 bool l_is_temp, bool r_is_var)
3060
{
3185
{
3061
  stmtblock_t block;
3186
  stmtblock_t block;
3187
  tree tmp;
3188
  tree cond;
3062
3189
3063
  gfc_init_block (&block);
3190
  gfc_init_block (&block);
3064
3191
3065
  if (type == BT_CHARACTER)
3192
  if (ts.type == BT_CHARACTER)
3066
    {
3193
    {
3067
      gcc_assert (lse->string_length != NULL_TREE
3194
      gcc_assert (lse->string_length != NULL_TREE
3068
	      && rse->string_length != NULL_TREE);
3195
	      && rse->string_length != NULL_TREE);
 Lines 3076-3081   gfc_trans_scalar_assign (gfc_se * lse, g Link Here 
3076
      gfc_trans_string_copy (&block, lse->string_length, lse->expr,
3203
      gfc_trans_string_copy (&block, lse->string_length, lse->expr,
3077
			     rse->string_length, rse->expr);
3204
			     rse->string_length, rse->expr);
3078
    }
3205
    }
3206
  else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
3207
    {
3208
      cond = NULL_TREE;
3209
3210
      /* Are the rhs and the lhs the same?  */
3211
      if (r_is_var)
3212
	{
3213
	  cond = fold_build2 (EQ_EXPR, boolean_type_node,
3214
			      build_fold_addr_expr (lse->expr),
3215
			      build_fold_addr_expr (rse->expr));
3216
	  cond = gfc_evaluate_now (cond, &lse->pre);
3217
	}
3218
3219
      /* Deallocate the lhs allocated components as long as it is not
3220
	 the same as the rhs.  */
3221
      if (!l_is_temp)
3222
	{
3223
	  tmp = gfc_deallocate_alloc_comp (ts.derived, lse->expr, 0);
3224
	  if (r_is_var)
3225
	    tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
3226
	  gfc_add_expr_to_block (&lse->pre, tmp);
3227
	}
3228
	
3229
      gfc_add_block_to_block (&block, &lse->pre);
3230
      gfc_add_block_to_block (&block, &rse->pre);
3231
3232
      gfc_add_modify_expr (&block, lse->expr,
3233
			   fold_convert (TREE_TYPE (lse->expr), rse->expr));
3234
3235
      /* Do a deep copy if the rhs is a variable, as long as it is not the
3236
	 same as the lhs.  Otherwise, nullify the data fields so that the
3237
	 lhs retains the allocated resources.  */
3238
      if (r_is_var)
3239
	{
3240
	  tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
3241
	  tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
3242
	  gfc_add_expr_to_block (&block, tmp);
3243
	}
3244
      else
3245
	{
3246
	  tmp = gfc_nullify_alloc_comp (ts.derived, rse->expr, 0);
3247
	  gfc_add_expr_to_block (&block, tmp);
3248
	}
3249
    }
3079
  else
3250
  else
3080
    {
3251
    {
3081
      gfc_add_block_to_block (&block, &lse->pre);
3252
      gfc_add_block_to_block (&block, &lse->pre);
 Lines 3270-3276   gfc_trans_assignment (gfc_expr * expr1, Link Here 
3270
  else
3441
  else
3271
    gfc_conv_expr (&lse, expr1);
3442
    gfc_conv_expr (&lse, expr1);
3272
3443
3273
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
3444
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
3445
				 loop.temp_ss != NULL,
3446
				 expr2->expr_type == EXPR_VARIABLE);
3274
  gfc_add_expr_to_block (&body, tmp);
3447
  gfc_add_expr_to_block (&body, tmp);
3275
3448
3276
  if (lss == gfc_ss_terminator)
3449
  if (lss == gfc_ss_terminator)
 Lines 3303-3311   gfc_trans_assignment (gfc_expr * expr1, Link Here 
3303
	  gcc_assert (lse.ss == gfc_ss_terminator
3476
	  gcc_assert (lse.ss == gfc_ss_terminator
3304
		      && rse.ss == gfc_ss_terminator);
3477
		      && rse.ss == gfc_ss_terminator);
3305
3478
3306
	  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
3479
	  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false);
3307
	  gfc_add_expr_to_block (&body, tmp);
3480
	  gfc_add_expr_to_block (&body, tmp);
3308
	}
3481
	}
3482
3309
      /* Generate the copying loops.  */
3483
      /* Generate the copying loops.  */
3310
      gfc_trans_scalarizing_loops (&loop, &body);
3484
      gfc_trans_scalarizing_loops (&loop, &body);
3311
3485
(-)gcc/fortran/symbol.c (+2 lines)
 Lines 1598-1603   gfc_set_component_attr (gfc_component * Link Here 
1598
1598
1599
  c->dimension = attr->dimension;
1599
  c->dimension = attr->dimension;
1600
  c->pointer = attr->pointer;
1600
  c->pointer = attr->pointer;
1601
  c->allocatable = attr->allocatable;
1601
}
1602
}
1602
1603
1603
1604
 Lines 1611-1616   gfc_get_component_attr (symbol_attribute Link Here 
1611
  gfc_clear_attr (attr);
1612
  gfc_clear_attr (attr);
1612
  attr->dimension = c->dimension;
1613
  attr->dimension = c->dimension;
1613
  attr->pointer = c->pointer;
1614
  attr->pointer = c->pointer;
1615
  attr->allocatable = c->allocatable;
1614
}
1616
}
1615
1617
1616
1618
(-)gcc/fortran/intrinsic.h (+1 lines)
 Lines 153-158   try gfc_check_free (gfc_expr *); 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 957-970   build_struct (const char *name, gfc_char Link Here 
957
957
958
  /* Check array components.  */
958
  /* Check array components.  */
959
  if (!c->dimension)
959
  if (!c->dimension)
960
    return SUCCESS;
960
    {
961
      if (c->allocatable)
962
	{
963
	  gfc_error ("Allocatable component at %C must be an array");
964
	  return FAILURE;
965
	}
966
      else
967
	return SUCCESS;
968
    }
961
969
962
  if (c->pointer)
970
  if (c->pointer)
963
    {
971
    {
964
      if (c->as->type != AS_DEFERRED)
972
      if (c->as->type != AS_DEFERRED)
965
	{
973
	{
966
	  gfc_error ("Pointer array component of structure at %C "
974
	  gfc_error ("Pointer array component of structure at %C must have a "
967
		     "must have a deferred shape");
975
		     "deferred shape");
976
	  return FAILURE;
977
	}
978
    }
979
  else if (c->allocatable)
980
    {
981
      if (c->as->type != AS_DEFERRED)
982
	{
983
	  gfc_error ("Allocatable component of structure at %C must have a "
984
		     "deferred shape");
968
	  return FAILURE;
985
	  return FAILURE;
969
	}
986
	}
970
    }
987
    }
 Lines 2136-2146   match_attr_spec (void) Link Here 
2136
	  && d != DECL_DIMENSION && d != DECL_POINTER
2153
	  && d != DECL_DIMENSION && d != DECL_POINTER
2137
	  && d != DECL_COLON && d != DECL_NONE)
2154
	  && d != DECL_COLON && d != DECL_NONE)
2138
	{
2155
	{
2139
2156
	  if (d == DECL_ALLOCATABLE)
2140
	  gfc_error ("Attribute at %L is not allowed in a TYPE definition",
2157
	    {
2141
		     &seen_at[d]);
2158
	      if (gfc_notify_std (GFC_STD_F2003, 
2142
	  m = MATCH_ERROR;
2159
				   "In the selected standard, the ALLOCATABLE "
2143
	  goto cleanup;
2160
				   "attribute at %C is not allowed in a TYPE "
2161
				   "definition") == FAILURE)         
2162
		{
2163
		  m = MATCH_ERROR;
2164
		  goto cleanup;
2165
		}
2166
            }
2167
          else
2168
	    {
2169
	      gfc_error ("Attribute at %L is not allowed in a TYPE definition",
2170
			  &seen_at[d]);
2171
	      m = MATCH_ERROR;
2172
	      goto cleanup;
2173
	    }
2144
	}
2174
	}
2145
2175
2146
      if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
2176
      if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
(-)gcc/fortran/trans-array.h (+7 lines)
 Lines 43-48   tree gfc_trans_dummy_array_bias (gfc_sym 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   available. 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   Support for the declaration of enumerati 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
@item
1390
@item
(-)gcc/fortran/gfortran.h (-1 / +5 lines)
 Lines 532-537   typedef struct 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   typedef struct gfc_component 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 1955-1960   void gfc_resolve_omp_do_blocks (gfc_code Link Here 
1955
void gfc_free_actual_arglist (gfc_actual_arglist *);
1958
void gfc_free_actual_arglist (gfc_actual_arglist *);
1956
gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *);
1959
gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *);
1957
const char *gfc_extract_int (gfc_expr *, int *);
1960
const char *gfc_extract_int (gfc_expr *, int *);
1961
gfc_expr *gfc_expr_to_initialize (gfc_expr *);
1958
1962
1959
gfc_expr *gfc_build_conversion (gfc_expr *);
1963
gfc_expr *gfc_build_conversion (gfc_expr *);
1960
void gfc_free_ref_list (gfc_ref *);
1964
void gfc_free_ref_list (gfc_ref *);
(-)gcc/fortran/trans-stmt.c (-6 / +35 lines)
 Lines 1796-1802   generate_loop_for_temp_to_lhs (gfc_expr 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   generate_loop_for_rhs_to_temp (gfc_expr 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   gfc_trans_where_assign (gfc_expr *expr1, 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   gfc_trans_where_assign (gfc_expr *expr1, 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   gfc_trans_where_3 (gfc_code * cblock, gf 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   gfc_trans_allocate (gfc_code * code) 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   gfc_trans_deallocate (gfc_code * code) 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   typedef enum 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   static const mstring attr_bits[] = 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   mio_symbol_attribute (symbol_attribute * 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   mio_symbol_attribute (symbol_attribute * 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   mio_component (gfc_component * c) 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 1480-1486   gfc_get_derived_type (gfc_symbol * deriv Link Here 
1480
         required.  */
1480
         required.  */
1481
      if (c->dimension)
1481
      if (c->dimension)
1482
	{
1482
	{
1483
	  if (c->pointer)
1483
	  if (c->pointer || c->allocatable)
1484
	    {
1484
	    {
1485
	      /* Pointers to arrays aren't actually pointer types.  The
1485
	      /* Pointers to arrays aren't actually pointer types.  The
1486
	         descriptors are separate, but the data is common.  */
1486
	         descriptors are separate, but the data is common.  */
(-)gcc/fortran/trans.h (-1 / +1 lines)
 Lines 307-313   int gfc_conv_function_call (gfc_se *, gf 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 919-931   resolve_actual_arglist (gfc_actual_argli Link Here 
919
919
920
920
921
/* Do the checks of the actual argument list that are specific to elemental
921
/* Do the checks of the actual argument list that are specific to elemental
922
   procedures.  If called with c == NULL, we have a function, otherwise if
922
   procedures.  */
923
   expr == NULL, we have a subroutine.  */
924
static try
923
static try
925
resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
924
resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
926
{
925
{
927
  gfc_actual_arglist *arg0;
926
  gfc_actual_arglist * arg0;
928
  gfc_actual_arglist *arg;
927
  gfc_actual_arglist * arg;
929
  gfc_symbol *esym = NULL;
928
  gfc_symbol *esym = NULL;
930
  gfc_intrinsic_sym *isym = NULL;
929
  gfc_intrinsic_sym *isym = NULL;
931
  gfc_expr *e = NULL;
930
  gfc_expr *e = NULL;
 Lines 936-942   resolve_elemental_actual (gfc_expr *expr Link Here 
936
  int i;
935
  int i;
937
  int rank = 0;
936
  int rank = 0;
938
937
939
  /* Is this an elemental procedure?  */
940
  if (expr && expr->value.function.actual != NULL)
938
  if (expr && expr->value.function.actual != NULL)
941
    {
939
    {
942
      if (expr->value.function.esym != NULL
940
      if (expr->value.function.esym != NULL
 Lines 973-979   resolve_elemental_actual (gfc_expr *expr Link Here 
973
		&& arg->expr->symtree->n.sym->attr.optional)
971
		&& arg->expr->symtree->n.sym->attr.optional)
974
	    set_by_optional = true;
972
	    set_by_optional = true;
975
973
976
	  /* Function specific; set the result rank and shape.  */
974
	  /* Function specific.  */
977
	  if (expr)
975
	  if (expr)
978
	    {
976
	    {
979
	      expr->rank = rank;
977
	      expr->rank = rank;
 Lines 3310-3316   resolve_deallocate_expr (gfc_expr * e) Link Here 
3310
3308
3311
/* Given the expression node e for an allocatable/pointer of derived type to be
3309
/* Given the expression node e for an allocatable/pointer of derived type to be
3312
   allocated, get the expression node to be initialized afterwards (needed for
3310
   allocated, get the expression node to be initialized afterwards (needed for
3313
   derived types with default initializers).  */
3311
   derived types with default initializers, and derived types with allocatable
3312
   components that need nullification.)  */
3314
3313
3315
static gfc_expr *
3314
static gfc_expr *
3316
expr_to_initialize (gfc_expr * e)
3315
expr_to_initialize (gfc_expr * e)
 Lines 3419-3426   resolve_allocate_expr (gfc_expr * e, gfc Link Here 
3419
        init_st->loc = code->loc;
3418
        init_st->loc = code->loc;
3420
        init_st->op = EXEC_ASSIGN;
3419
        init_st->op = EXEC_ASSIGN;
3421
        init_st->expr = expr_to_initialize (e);
3420
        init_st->expr = expr_to_initialize (e);
3422
        init_st->expr2 = init_e;
3421
	init_st->expr2 = init_e;
3423
3424
        init_st->next = code->next;
3422
        init_st->next = code->next;
3425
        code->next = init_st;
3423
        code->next = init_st;
3426
    }
3424
    }
 Lines 4029-4034   resolve_transfer (gfc_code * code) Link Here 
4029
	  return;
4027
	  return;
4030
	}
4028
	}
4031
4029
4030
      if (ts->derived->attr.alloc_comp)
4031
	{
4032
	  gfc_error ("Data transfer element at %L cannot have "
4033
		     "ALLOCATABLE components", &code->loc);
4034
	  return;
4035
	}
4036
4032
      if (derived_inaccessible (ts->derived))
4037
      if (derived_inaccessible (ts->derived))
4033
	{
4038
	{
4034
	  gfc_error ("Data transfer element at %L cannot have "
4039
	  gfc_error ("Data transfer element at %L cannot have "
 Lines 5409-5415   resolve_fl_derived (gfc_symbol *sym) Link Here 
5409
	    }
5414
	    }
5410
	}
5415
	}
5411
5416
5412
      if (c->pointer || c->as == NULL)
5417
      if (c->pointer || c->allocatable ||  c->as == NULL)
5413
	continue;
5418
	continue;
5414
5419
5415
      for (i = 0; i < c->as->rank; i++)
5420
      for (i = 0; i < c->as->rank; i++)
(-)gcc/fortran/trans-decl.c (-3 / +27 lines)
 Lines 957-962   gfc_get_symbol_decl (gfc_symbol * sym) Link Here 
957
	GFC_DECL_PACKED_ARRAY (decl) = 1;
957
	GFC_DECL_PACKED_ARRAY (decl) = 1;
958
    }
958
    }
959
959
960
  if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
961
    gfc_defer_symbol_init (sym);
962
960
  gfc_finish_var_decl (decl, sym);
963
  gfc_finish_var_decl (decl, sym);
961
964
962
  if (sym->ts.type == BT_CHARACTER)
965
  if (sym->ts.type == BT_CHARACTER)
 Lines 2601-2613   gfc_trans_deferred_vars (gfc_symbol * pr Link Here 
2601
	      break;
2604
	      break;
2602
2605
2603
	    case AS_DEFERRED:
2606
	    case AS_DEFERRED:
2604
	      fnbody = gfc_trans_deferred_array (sym, fnbody);
2607
	      if (!(sym->ts.type == BT_DERIVED
2608
		      && sym->ts.derived->attr.alloc_comp))
2609
		fnbody = gfc_trans_deferred_array (sym, fnbody);
2605
	      break;
2610
	      break;
2606
2611
2607
	    default:
2612
	    default:
2608
	      gcc_unreachable ();
2613
	      gcc_unreachable ();
2609
	    }
2614
	    }
2615
	  if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
2616
	    fnbody = gfc_trans_deferred_array (sym, fnbody);
2610
	}
2617
	}
2618
      else if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
2619
	fnbody = gfc_trans_deferred_array (sym, fnbody);
2611
      else if (sym->ts.type == BT_CHARACTER)
2620
      else if (sym->ts.type == BT_CHARACTER)
2612
	{
2621
	{
2613
	  gfc_get_backend_locus (&loc);
2622
	  gfc_get_backend_locus (&loc);
 Lines 2957-2966   gfc_generate_function_code (gfc_namespac Link Here 
2957
  tree old_context;
2966
  tree old_context;
2958
  tree decl;
2967
  tree decl;
2959
  tree tmp;
2968
  tree tmp;
2969
  tree tmp2;
2960
  stmtblock_t block;
2970
  stmtblock_t block;
2961
  stmtblock_t body;
2971
  stmtblock_t body;
2962
  tree result;
2972
  tree result;
2963
  gfc_symbol *sym;
2973
  gfc_symbol *sym;
2974
  int rank;
2964
2975
2965
  sym = ns->proc_name;
2976
  sym = ns->proc_name;
2966
2977
 Lines 3120-3126   gfc_generate_function_code (gfc_namespac Link Here 
3120
  tmp = gfc_finish_block (&body);
3131
  tmp = gfc_finish_block (&body);
3121
  /* Add code to create and cleanup arrays.  */
3132
  /* Add code to create and cleanup arrays.  */
3122
  tmp = gfc_trans_deferred_vars (sym, tmp);
3133
  tmp = gfc_trans_deferred_vars (sym, tmp);
3123
  gfc_add_expr_to_block (&block, tmp);
3124
3134
3125
  if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
3135
  if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
3126
    {
3136
    {
 Lines 3135-3141   gfc_generate_function_code (gfc_namespac Link Here 
3135
      else
3145
      else
3136
	result = sym->result->backend_decl;
3146
	result = sym->result->backend_decl;
3137
3147
3138
      if (result == NULL_TREE)
3148
      if (result != NULL_TREE && sym->attr.function
3149
	    && sym->ts.type == BT_DERIVED
3150
	    && sym->ts.derived->attr.alloc_comp)
3151
	{
3152
	  rank = sym->as ? sym->as->rank : 0;
3153
	  tmp2 = gfc_nullify_alloc_comp (sym->ts.derived, result, rank);
3154
	  gfc_add_expr_to_block (&block, tmp2);
3155
	}
3156
3157
     gfc_add_expr_to_block (&block, tmp);
3158
3159
     if (result == NULL_TREE)
3139
	warning (0, "Function return value not set");
3160
	warning (0, "Function return value not set");
3140
      else
3161
      else
3141
	{
3162
	{
 Lines 3146-3151   gfc_generate_function_code (gfc_namespac Link Here 
3146
	  gfc_add_expr_to_block (&block, tmp);
3167
	  gfc_add_expr_to_block (&block, tmp);
3147
	}
3168
	}
3148
    }
3169
    }
3170
  else
3171
    gfc_add_expr_to_block (&block, tmp);
3172
3149
3173
3150
  /* Add all the decls we created during processing.  */
3174
  /* Add all the decls we created during processing.  */
3151
  decl = saved_function_decls;
3175
  decl = saved_function_decls;
(-)gcc/fortran/parse.c (+14 lines)
 Lines 1499-1504   parse_derived (void) 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   parse_derived (void) 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   gfc_check_all_any (gfc_expr * mask, gfc_ Link Here 
477
try
477
try
478
gfc_check_allocated (gfc_expr * array)
478
gfc_check_allocated (gfc_expr * array)
479
{
479
{
480
  symbol_attribute attr;
481
480
  if (variable_check (array, 0) == FAILURE)
482
  if (variable_check (array, 0) == FAILURE)
481
    return FAILURE;
483
    return FAILURE;
482
484
483
  if (array_check (array, 0) == FAILURE)
485
  if (array_check (array, 0) == FAILURE)
484
    return FAILURE;
486
    return FAILURE;
485
487
486
  if (!array->symtree->n.sym->attr.allocatable)
488
  attr = gfc_variable_attr (array, NULL);
489
  if (!attr.allocatable)
487
    {
490
    {
488
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
491
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
489
		 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
492
		 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
 Lines 1814-1819   gfc_check_merge (gfc_expr * tsource, gfc Link Here 
1814
  return SUCCESS;
1817
  return SUCCESS;
1815
}
1818
}
1816
1819
1820
try
1821
gfc_check_move_alloc (gfc_expr * from, gfc_expr * to)
1822
{
1823
  symbol_attribute attr;
1824
1825
  if (variable_check (from, 0) == FAILURE)
1826
    return FAILURE;
1827
1828
  if (array_check (from, 0) == FAILURE)
1829
    return FAILURE;
1830
1831
  attr = gfc_variable_attr (from, NULL);
1832
  if (!attr.allocatable)
1833
    {
1834
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
1835
		 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
1836
		 &from->where);
1837
      return FAILURE;
1838
    }
1839
1840
  if (variable_check (to, 0) == FAILURE)
1841
    return FAILURE;
1842
1843
  if (array_check (to, 0) == FAILURE)
1844
    return FAILURE;
1845
1846
  attr = gfc_variable_attr (to, NULL);
1847
  if (!attr.allocatable)
1848
    {
1849
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
1850
		 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
1851
		 &to->where);
1852
      return FAILURE;
1853
    }
1854
1855
  if (same_type_check (from, 0, to, 1) == FAILURE)
1856
    return FAILURE;
1857
1858
  if (to->rank != from->rank)
1859
    {
1860
      gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
1861
		 "have the same rank %d/%d", gfc_current_intrinsic_arg[0],
1862
		 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
1863
		 &to->where,  from->rank, to->rank);
1864
      return FAILURE;
1865
    }
1866
1867
  if (to->ts.kind != from->ts.kind)
1868
    {
1869
      gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
1870
		 "be of the same kind %d/%d", gfc_current_intrinsic_arg[0],
1871
		 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
1872
		 &to->where, from->ts.kind, to->ts.kind);
1873
      return FAILURE;
1874
    }
1875
1876
  return SUCCESS;
1877
}
1817
1878
1818
try
1879
try
1819
gfc_check_nearest (gfc_expr * x, gfc_expr * s)
1880
gfc_check_nearest (gfc_expr * x, gfc_expr * s)
(-)gcc/fortran/primary.c (-4 / +7 lines)
 Lines 1711-1717   check_substring: 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   gfc_variable_attr (gfc_expr * expr, gfc_ 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   gfc_variable_attr (gfc_expr * expr, gfc_ 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   gfc_variable_attr (gfc_expr * expr, gfc_ 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   and editing. All contributions and corr 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   end program test_mod 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 (-10 / +19 lines)
 Lines 167-178   am__objects_30 = associated.lo abort.lo Link Here 
167
	eoshift2.lo etime.lo exit.lo fget.lo flush.lo fnum.lo ftell.lo \
167
	eoshift2.lo etime.lo exit.lo fget.lo flush.lo fnum.lo ftell.lo \
168
	gerror.lo getcwd.lo getlog.lo getXid.lo hyper.lo hostnm.lo \
168
	gerror.lo getcwd.lo getlog.lo getXid.lo hyper.lo hostnm.lo \
169
	kill.lo ierrno.lo ishftc.lo link.lo malloc.lo mvbits.lo \
169
	kill.lo ierrno.lo ishftc.lo link.lo malloc.lo mvbits.lo \
170
	pack_generic.lo perror.lo signal.lo size.lo sleep.lo \
170
	move_alloc.lo pack_generic.lo perror.lo signal.lo size.lo \
171
	spread_generic.lo string_intrinsics.lo system.lo rand.lo \
171
	sleep.lo spread_generic.lo string_intrinsics.lo system.lo \
172
	random.lo rename.lo reshape_generic.lo reshape_packed.lo \
172
	rand.lo random.lo rename.lo reshape_generic.lo \
173
	selected_int_kind.lo selected_real_kind.lo stat.lo symlnk.lo \
173
	reshape_packed.lo selected_int_kind.lo selected_real_kind.lo \
174
	system_clock.lo time.lo transpose_generic.lo tty.lo umask.lo \
174
	stat.lo symlnk.lo system_clock.lo time.lo transpose_generic.lo \
175
	unlink.lo unpack_generic.lo in_pack_generic.lo \
175
	tty.lo umask.lo unlink.lo unpack_generic.lo in_pack_generic.lo \
176
	in_unpack_generic.lo
176
	in_unpack_generic.lo
177
am__objects_31 =
177
am__objects_31 =
178
am__objects_32 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \
178
am__objects_32 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \
 Lines 264-269   AUTOHEADER = @AUTOHEADER@ Link Here 
264
AUTOMAKE = @AUTOMAKE@
264
AUTOMAKE = @AUTOMAKE@
265
AWK = @AWK@
265
AWK = @AWK@
266
CC = @CC@
266
CC = @CC@
267
CFLAGS = @CFLAGS@
267
CPP = @CPP@
268
CPP = @CPP@
268
CPPFLAGS = @CPPFLAGS@
269
CPPFLAGS = @CPPFLAGS@
269
CYGPATH_W = @CYGPATH_W@
270
CYGPATH_W = @CYGPATH_W@
 Lines 276-281   EXEEXT = @EXEEXT@ Link Here 
276
FC = @FC@
277
FC = @FC@
277
FCFLAGS = @FCFLAGS@
278
FCFLAGS = @FCFLAGS@
278
FPU_HOST_HEADER = @FPU_HOST_HEADER@
279
FPU_HOST_HEADER = @FPU_HOST_HEADER@
280
GREP = @GREP@
279
INSTALL_DATA = @INSTALL_DATA@
281
INSTALL_DATA = @INSTALL_DATA@
280
INSTALL_PROGRAM = @INSTALL_PROGRAM@
282
INSTALL_PROGRAM = @INSTALL_PROGRAM@
281
INSTALL_SCRIPT = @INSTALL_SCRIPT@
283
INSTALL_SCRIPT = @INSTALL_SCRIPT@
 Lines 303-314   SET_MAKE = @SET_MAKE@ Link Here 
303
SHELL = @SHELL@
305
SHELL = @SHELL@
304
STRIP = @STRIP@
306
STRIP = @STRIP@
305
VERSION = @VERSION@
307
VERSION = @VERSION@
306
ac_ct_AR = @ac_ct_AR@
307
ac_ct_AS = @ac_ct_AS@
308
ac_ct_CC = @ac_ct_CC@
308
ac_ct_CC = @ac_ct_CC@
309
ac_ct_FC = @ac_ct_FC@
309
ac_ct_FC = @ac_ct_FC@
310
ac_ct_RANLIB = @ac_ct_RANLIB@
311
ac_ct_STRIP = @ac_ct_STRIP@
312
am__leading_dot = @am__leading_dot@
310
am__leading_dot = @am__leading_dot@
313
am__tar = @am__tar@
311
am__tar = @am__tar@
314
am__untar = @am__untar@
312
am__untar = @am__untar@
 Lines 321-326   build_os = @build_os@ Link Here 
321
build_subdir = @build_subdir@
319
build_subdir = @build_subdir@
322
build_vendor = @build_vendor@
320
build_vendor = @build_vendor@
323
datadir = @datadir@
321
datadir = @datadir@
322
datarootdir = @datarootdir@
323
docdir = @docdir@
324
dvidir = @dvidir@
324
enable_shared = @enable_shared@
325
enable_shared = @enable_shared@
325
enable_static = @enable_static@
326
enable_static = @enable_static@
326
exec_prefix = @exec_prefix@
327
exec_prefix = @exec_prefix@
 Lines 331-348   host_cpu = @host_cpu@ Link Here 
331
host_os = @host_os@
332
host_os = @host_os@
332
host_subdir = @host_subdir@
333
host_subdir = @host_subdir@
333
host_vendor = @host_vendor@
334
host_vendor = @host_vendor@
335
htmldir = @htmldir@
334
includedir = @includedir@
336
includedir = @includedir@
335
infodir = @infodir@
337
infodir = @infodir@
336
install_sh = @install_sh@
338
install_sh = @install_sh@
337
libdir = @libdir@
339
libdir = @libdir@
338
libexecdir = @libexecdir@
340
libexecdir = @libexecdir@
341
localedir = @localedir@
339
localstatedir = @localstatedir@
342
localstatedir = @localstatedir@
340
mandir = @mandir@
343
mandir = @mandir@
341
mkdir_p = @mkdir_p@
344
mkdir_p = @mkdir_p@
342
multi_basedir = @multi_basedir@
345
multi_basedir = @multi_basedir@
343
oldincludedir = @oldincludedir@
346
oldincludedir = @oldincludedir@
347
pdfdir = @pdfdir@
344
prefix = @prefix@
348
prefix = @prefix@
345
program_transform_name = @program_transform_name@
349
program_transform_name = @program_transform_name@
350
psdir = @psdir@
346
sbindir = @sbindir@
351
sbindir = @sbindir@
347
sharedstatedir = @sharedstatedir@
352
sharedstatedir = @sharedstatedir@
348
sysconfdir = @sysconfdir@
353
sysconfdir = @sysconfdir@
 Lines 418-423   intrinsics/ishftc.c \ Link Here 
418
intrinsics/link.c \
423
intrinsics/link.c \
419
intrinsics/malloc.c \
424
intrinsics/malloc.c \
420
intrinsics/mvbits.c \
425
intrinsics/mvbits.c \
426
intrinsics/move_alloc.c \
421
intrinsics/pack_generic.c \
427
intrinsics/pack_generic.c \
422
intrinsics/perror.c \
428
intrinsics/perror.c \
423
intrinsics/signal.c \
429
intrinsics/signal.c \
 Lines 2304-2309   malloc.lo: intrinsics/malloc.c Link Here 
2304
mvbits.lo: intrinsics/mvbits.c
2310
mvbits.lo: intrinsics/mvbits.c
2305
	$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o mvbits.lo `test -f 'intrinsics/mvbits.c' || echo '$(srcdir)/'`intrinsics/mvbits.c
2311
	$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o mvbits.lo `test -f 'intrinsics/mvbits.c' || echo '$(srcdir)/'`intrinsics/mvbits.c
2306
2312
2313
move_alloc.lo: intrinsics/move_alloc.c
2314
	$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o move_alloc.lo `test -f 'intrinsics/move_alloc.c' || echo '$(srcdir)/'`intrinsics/move_alloc.c
2315
2307
pack_generic.lo: intrinsics/pack_generic.c
2316
pack_generic.lo: intrinsics/pack_generic.c
2308
	$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o pack_generic.lo `test -f 'intrinsics/pack_generic.c' || echo '$(srcdir)/'`intrinsics/pack_generic.c
2317
	$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o pack_generic.lo `test -f 'intrinsics/pack_generic.c' || echo '$(srcdir)/'`intrinsics/pack_generic.c
2309
2318
(-)libgfortran/intrinsics/move_alloc.c (+67 lines)
Line 0    Link Here 
1
/* Generic implementation of the MOVE_ALLOC intrinsic
2
   Copyright (C) 2006 Free Software Foundation, Inc.
3
   Contributed by Paul Thomas
4
5
This file is part of the GNU Fortran 95 runtime library (libgfortran).
6
7
Libgfortran is free software; you can redistribute it and/or
8
modify it under the terms of the GNU General Public
9
License as published by the Free Software Foundation; either
10
version 2 of the License, or (at your option) any later version.
11
12
In addition to the permissions in the GNU General Public License, the
13
Free Software Foundation gives you unlimited permission to link the
14
compiled version of this file into combinations with other programs,
15
and to distribute those combinations without any restriction coming
16
from the use of this file.  (The General Public License restrictions
17
do apply in other respects; for example, they cover modification of
18
the file, and distribution when not linked into a combine
19
executable.)
20
21
Ligbfortran is distributed in the hope that it will be useful,
22
but WITHOUT ANY WARRANTY; without even the implied warranty of
23
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
24
GNU General Public License for more details.
25
26
You should have received a copy of the GNU General Public
27
License along with libgfortran; see the file COPYING.  If not,
28
write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
29
Boston, MA 02110-1301, USA.  */
30
31
#include "libgfortran.h"
32
33
extern void move_alloc (gfc_array_char *, gfc_array_char *);
34
export_proto(move_alloc);
35
36
void
37
move_alloc (gfc_array_char * from, gfc_array_char * to)
38
{
39
  int i;
40
41
  internal_free (to->data);
42
43
  for (i = 0; i < GFC_DESCRIPTOR_RANK (from); i++)
44
    {
45
      to->dim[i].lbound = from->dim[i].lbound;
46
      to->dim[i].ubound = from->dim[i].ubound;
47
      to->dim[i].stride = from->dim[i].stride;
48
      from->dim[i].stride = 0;
49
      from->dim[i].ubound = from->dim[i].lbound;
50
    }
51
52
  to->offset = from->offset;
53
  to->dtype = from->dtype;
54
  to->data = from->data;
55
  from->data = NULL;
56
}
57
58
extern void move_alloc_c (gfc_array_char *, GFC_INTEGER_4,
59
			  gfc_array_char *, GFC_INTEGER_4);
60
export_proto(move_alloc_c);
61
62
void
63
move_alloc_c (gfc_array_char * from, GFC_INTEGER_4 from_length __attribute__((unused)),
64
	      gfc_array_char * to, GFC_INTEGER_4 to_length __attribute__((unused)))
65
{
66
  move_alloc (from, to);
67
}
(-)libgfortran/Makefile.am (+1 lines)
 Lines 74-79   intrinsics/ishftc.c \ Link Here 
74
intrinsics/link.c \
74
intrinsics/link.c \
75
intrinsics/malloc.c \
75
intrinsics/malloc.c \
76
intrinsics/mvbits.c \
76
intrinsics/mvbits.c \
77
intrinsics/move_alloc.c \
77
intrinsics/pack_generic.c \
78
intrinsics/pack_generic.c \
78
intrinsics/perror.c \
79
intrinsics/perror.c \
79
intrinsics/signal.c \
80
intrinsics/signal.c \

Return to bug 20541