Attachment #11910 for bug #20541

View | Details | Return to bug 20541 | Differences between
Collapse All | Expand All

Lines 374-379 Link Here

(-)gcc/fortran/interface.c (+3 lines)
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

Lines 2318-2323 Link Here

(-)gcc/fortran/intrinsic.c (+5 lines)
2318	length, BT_INTEGER, di, OPTIONAL, st, BT_INTEGER, di, OPTIONAL,	2318	length, BT_INTEGER, di, OPTIONAL, st, BT_INTEGER, di, OPTIONAL,
2319	trim_name, BT_LOGICAL, dl, OPTIONAL);	2319	trim_name, BT_LOGICAL, dl, OPTIONAL);
2320		2320
		2321	add_sym_2s ("move_alloc", 0, 0, BT_UNKNOWN, 0, GFC_STD_F2003,
		2322	gfc_check_move_alloc, NULL, NULL,
		2323	f, BT_UNKNOWN, 0, REQUIRED,
		2324	t, BT_UNKNOWN, 0, REQUIRED);
		2325
2321	add_sym_5s ("mvbits", 1, 1, BT_UNKNOWN, 0, GFC_STD_F95,	2326	add_sym_5s ("mvbits", 1, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2322	gfc_check_mvbits, gfc_simplify_mvbits, gfc_resolve_mvbits,	2327	gfc_check_mvbits, gfc_simplify_mvbits, gfc_resolve_mvbits,
2323	f, BT_INTEGER, di, REQUIRED, fp, BT_INTEGER, di, REQUIRED,	2328	f, BT_INTEGER, di, REQUIRED, fp, BT_INTEGER, di, REQUIRED,




#include "trans-stmt.h"
#include "dependency.h"

static tree gfc_trans_structure_assign (gfc_se * outer_se, tree dest, gfc_expr * expr);
static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
						 gfc_expr *);



  if (intent != INTENT_OUT)
    {
      tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
      gfc_add_expr_to_block (&body, tmp);
      gcc_assert (rse.ss == gfc_ss_terminator);
      gfc_trans_scalarizing_loops (&loop, &body);


  gcc_assert (lse.ss == gfc_ss_terminator);

  tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
  gfc_add_expr_to_block (&body, tmp);
  
  /* Generate the copying loops.  */

  gfc_ss *argss;
  gfc_ss_info *info;
  int byref;
  int parm_kind;
  tree type;
  tree var;
  tree len;

  gfc_expr *e;
  gfc_symbol *fsym;
  stmtblock_t post;
  enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};

  arglist = NULL_TREE;
  retargs = NULL_TREE;

    {
      e = arg->expr;
      fsym = formal ? formal->sym : NULL;
      parm_kind = MISSING;
      if (e == NULL)
	{


	  /* An elemental function inside a scalarized loop.  */
          gfc_init_se (&parmse, se);
          gfc_conv_expr_reference (&parmse, e);
	  parm_kind = ELEMENTAL;
	}
      else
	{

	  if (argss == gfc_ss_terminator)
            {
	      gfc_conv_expr_reference (&parmse, e);
	      parm_kind = SCALAR;
              if (fsym && fsym->attr.pointer
		  && e->expr_type != EXPR_NULL)
                {
                  /* Scalar pointer dummy args require an extra level of
		  indirection. The null pointer already contains
		  this level of indirection.  */
		  parm_kind = SCALAR_POINTER;
                  parmse.expr = build_fold_addr_expr (parmse.expr);
                }
            }

      gfc_add_block_to_block (&se->pre, &parmse.pre);
      gfc_add_block_to_block (&post, &parmse.post);

      /* Allocated allocatable components of derived types must be
	 deallocated for INTENT(OUT) dummy arguments and non-variable
         scalars.  Non-variable arrays are dealt with in trans-array.c
         (gfc_conv_array_parameter).  */
      if (e && e->ts.type == BT_DERIVED
	    && e->ts.derived->attr.alloc_comp
	    && ((formal && formal->sym->attr.intent == INTENT_OUT)
		   ||
		(e->expr_type != EXPR_VARIABLE && !e->rank)))
        {
	  int parm_rank;
	  tmp = build_fold_indirect_ref (parmse.expr);
	  parm_rank = e->rank;
	  switch (parm_kind)
	    {
	    case (ELEMENTAL):
	    case (SCALAR):
	      parm_rank = 0;
	      break;

	    case (SCALAR_POINTER):
              tmp = build_fold_indirect_ref (tmp);
	      break;
	    case (ARRAY):
              tmp = parmse.expr;
	      break;
	    }

          tmp = deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
	  if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
	    tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym),
			    tmp, build_empty_stmt ());

	  if (e->expr_type == EXPR_FUNCTION)
	    /* Don't deallocate function results until they have been used.  */
	    gfc_add_expr_to_block (&se->post, tmp);
	  else
	    gfc_add_expr_to_block (&se->pre, tmp);
        }

      /* Character strings are passed as two parameters, a length and a
         pointer.  */
      if (parmse.string_length != NULL_TREE)


  gfc_conv_expr (&rse, expr);

  tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
  gfc_add_expr_to_block (&body, tmp);

  gcc_assert (rse.ss == gfc_ss_terminator);

/* Assign a single component of a derived type constructor.  */

static tree
gfc_trans_subcomponent_assign (gfc_se * outer_se, tree dest,
			       gfc_component * cm, gfc_expr * expr)
{
  gfc_se se;
  gfc_se lse;
  gfc_ss *rss;
  stmtblock_t block;
  tree tmp;
  tree offset;
  int n;

  gfc_start_block (&block);

#if 0
  if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
    gfc_todo_error ("derived types with allocatable components as "
		    "arguments of derived type constructors");
#endif
  if (cm->pointer)
    {
      gfc_init_se (&se, NULL);

    }
  else if (cm->dimension)
    {
      if (cm->allocatable && expr->expr_type == EXPR_NULL)
	gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
      else if (cm->allocatable)
	{
	  tree tmp2;

	  gfc_init_se (&se, NULL);
	  gfc_init_se (&lse, NULL);

	  se.want_pointer = 0;
	  gfc_conv_expr_descriptor (&se, expr, gfc_walk_expr (expr));
	  if (cm->ts.type == BT_CHARACTER)
	    lse.string_length = cm->ts.cl->backend_decl;

	  lse.expr = dest;

	  /* Clean up temporaries at the right time.  */
	  if (expr->expr_type == EXPR_FUNCTION)
	    {
	      stmtblock_t tmp_block;

	      /* Prevent the freeing of the memory after the array assignment to
		 the derived type component....  */
	      gfc_init_block (&tmp_block);
	      gfc_add_block_to_block (&tmp_block, &se.post);
	      gfc_conv_descriptor_data_set (&se.post, se.expr, null_pointer_node);
	      gfc_add_block_to_block (&se.post, &tmp_block);

	      /* ...and do it when the derived type is completed.  */
	      tmp = gfc_conv_descriptor_data_get (lse.expr);
	      tmp = convert (pvoid_type_node, tmp);
	      tmp = gfc_chainon_list (NULL_TREE, tmp);
	      tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
	      gfc_add_expr_to_block (&outer_se->post, tmp);
	    }

	  tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
	  gfc_add_expr_to_block (&block, tmp);

	  /* Shift the lbound and ubound of temporaries to being unity, rather
	     than zero, based.  Calculate the offset for all cases.  */
	  offset = gfc_conv_descriptor_offset (dest);
	  gfc_add_modify_expr (&block, offset, gfc_index_zero_node);
	  tmp2 =gfc_create_var (gfc_array_index_type, NULL);
	  for (n = 0; n < expr->rank; n++)
	    {
	      if (expr->expr_type != EXPR_VARIABLE
		    && expr->expr_type != EXPR_CONSTANT)
		{
		  tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
		  gfc_add_modify_expr (&block, tmp,
				       fold_build2 (PLUS_EXPR, gfc_array_index_type,
						    tmp, gfc_index_one_node));
		  tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
		  gfc_add_modify_expr (&block, tmp, gfc_index_one_node);
		}
	      tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
				 gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]),
				 gfc_conv_descriptor_stride (dest, gfc_rank_cst[n]));
	      gfc_add_modify_expr (&block, tmp2, tmp);
	      tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
	      gfc_add_modify_expr (&block, offset, tmp);
	    }  
	}
      else
	{
	  tmp = gfc_trans_subarray_assign (dest, cm, expr);
	  gfc_add_expr_to_block (&block, tmp);
	}
    }
  else if (expr->ts.type == BT_DERIVED)
    {
      /* Nested derived type.  */
      tmp = gfc_trans_structure_assign (outer_se, dest, expr);
      gfc_add_expr_to_block (&block, tmp);
    }
  else
    {
      /* Scalar component.  */
      gfc_se lse;

      gfc_init_se (&se, NULL);
      gfc_init_se (&lse, NULL);


      if (cm->ts.type == BT_CHARACTER)
	lse.string_length = cm->ts.cl->backend_decl;
      lse.expr = dest;
      tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
      gfc_add_expr_to_block (&block, tmp);
    }
  return gfc_finish_block (&block);

/* Assign a derived type constructor to a variable.  */

static tree
gfc_trans_structure_assign (gfc_se * outer_se, tree dest, gfc_expr * expr)
{
  gfc_constructor *c;
  gfc_component *cm;


      field = cm->backend_decl;
      tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
      tmp = gfc_trans_subcomponent_assign (outer_se, tmp, cm, c->expr);
      gfc_add_expr_to_block (&block, tmp);
    }
  return gfc_finish_block (&block);

    {
      /* Create a temporary variable and fill it in.  */
      se->expr = gfc_create_var (type, expr->ts.derived->name);
      tmp = gfc_trans_structure_assign (se, se->expr, expr);
      gfc_add_expr_to_block (&se->pre, tmp);
      return;
    }

   strings.  */

tree
gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
			 bool l_is_temp, bool r_is_var)
{
  stmtblock_t block;
  tree tmp;
  tree cond;

  gfc_init_block (&block);

  if (ts.type == BT_CHARACTER)
    {
      gcc_assert (lse->string_length != NULL_TREE
	      && rse->string_length != NULL_TREE);

      gfc_trans_string_copy (&block, lse->string_length, lse->expr,
			     rse->string_length, rse->expr);
    }
  else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
    {
      cond = NULL_TREE;

      /* Are the rhs and the lhs the same?  */
      if (r_is_var)
	{
	  cond = fold_build2 (EQ_EXPR, boolean_type_node,
			      build_fold_addr_expr (lse->expr),
			      build_fold_addr_expr (rse->expr));
	  cond = gfc_evaluate_now (cond, &lse->pre);
	}

      /* Deallocate the lhs allocated components as long as it is not
	 the same as the rhs.  */
      if (!l_is_temp)
	{
	  tmp = deallocate_alloc_comp (ts.derived, lse->expr, 0);
	  if (r_is_var)
	    tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
	  gfc_add_expr_to_block (&lse->pre, tmp);
	}
	
      gfc_add_block_to_block (&block, &lse->pre);
      gfc_add_block_to_block (&block, &rse->pre);

      gfc_add_modify_expr (&block, lse->expr,
			   fold_convert (TREE_TYPE (lse->expr), rse->expr));

      /* Do a deep copy if the rhs is a variable, as long as it is not the
	 same as the lhs.  Otherwise, nullify the data fields so that the
	 lhs retains the allocated resources.  */
      if (r_is_var)
	{
	  tmp = copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
	  tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
	  gfc_add_expr_to_block (&block, tmp);
	}
      else
	{
	  tmp = nullify_alloc_comp (ts.derived, rse->expr, 0);
	  gfc_add_expr_to_block (&block, tmp);
	}
    }
  else
    {
      gfc_add_block_to_block (&block, &lse->pre);

  else
    gfc_conv_expr (&lse, expr1);

  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
				 loop.temp_ss != NULL,
				 expr2->expr_type == EXPR_VARIABLE);
  gfc_add_expr_to_block (&body, tmp);

  if (lss == gfc_ss_terminator)

	  gcc_assert (lse.ss == gfc_ss_terminator
		      && rse.ss == gfc_ss_terminator);

	  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false);
	  gfc_add_expr_to_block (&body, tmp);
	}

      /* Generate the copying loops.  */
      gfc_trans_scalarizing_loops (&loop, &body);


Lines 3316-3321 Link Here

(-)gcc/fortran/trans-array.c (-18 / +337 lines)
3316	tmp = gfc_conv_descriptor_offset (se->expr);	3316	tmp = gfc_conv_descriptor_offset (se->expr);
3317	gfc_add_modify_expr (&se->pre, tmp, offset);	3317	gfc_add_modify_expr (&se->pre, tmp, offset);
3318		3318
		3319	if (expr->ts.type == BT_DERIVED && expr->ts.derived->attr.alloc_comp)
		3320	{
		3321	tmp = nullify_alloc_comp (expr->ts.derived, se->expr, ref->u.ar.as->rank);
		3322	gfc_add_expr_to_block (&se->pre, tmp);
		3323	}
		3324
3319	return true;	3325	return true;
3320	}	3326	}
3321		3327
Lines 3456-3461 Link Here
3456	}	3462	}
3457	break;	3463	break;
3458		3464
		3465	case EXPR_NULL:
		3466	return gfc_build_null_descriptor (type);
		3467
3459	default:	3468	default:
3460	gcc_unreachable ();	3469	gcc_unreachable ();
3461	}	3470	}
Lines 4524-4530 Link Here
4524	}	4533	}
4525	if (sym->attr.allocatable)	4534	if (sym->attr.allocatable)
4526	{	4535	{
4527	se->expr = gfc_conv_array_data (tmp);	4536	if (sym->attr.dummy)
		4537	se->expr = tmp;
		4538	else
		4539	se->expr = gfc_conv_array_data (tmp);
4528	return;	4540	return;
4529	}	4541	}
4530	}	4542	}
Lines 4532-4537 Link Here
4532	se->want_pointer = 1;	4544	se->want_pointer = 1;
4533	gfc_conv_expr_descriptor (se, expr, ss);	4545	gfc_conv_expr_descriptor (se, expr, ss);
4534		4546
		4547	/* Deallocate the allocatable components of structures that are
		4548	not variable. */
		4549	if (expr->ts.type == BT_DERIVED
		4550	&& expr->ts.derived->attr.alloc_comp
		4551	&& expr->expr_type != EXPR_VARIABLE)
		4552	{
		4553	tmp = build_fold_indirect_ref (se->expr);
		4554	tmp = deallocate_alloc_comp (expr->ts.derived, tmp, expr->rank);
		4555	gfc_add_expr_to_block (&se->post, tmp);
		4556	}
		4557
4535	if (g77)	4558	if (g77)
4536	{	4559	{
4537	desc = se->expr;	4560	desc = se->expr;
Lines 4580-4603 Link Here
4580	gfc_trans_dealloc_allocated (tree descriptor)	4603	gfc_trans_dealloc_allocated (tree descriptor)
4581	{	4604	{
4582	tree tmp;	4605	tree tmp;
4583	tree deallocate;	4606	tree ptr;
		4607	tree var;
4584	stmtblock_t block;	4608	stmtblock_t block;
4585		4609
4586	gfc_start_block (&block);	4610	gfc_start_block (&block);
4587	deallocate = gfc_array_deallocate (descriptor, null_pointer_node);
4588		4611
4589	tmp = gfc_conv_descriptor_data_get (descriptor);	4612	tmp = gfc_conv_descriptor_data_addr (descriptor);
4590	tmp = build2 (NE_EXPR, boolean_type_node, tmp,	4613	var = gfc_evaluate_now (tmp, &block);
4591	build_int_cst (TREE_TYPE (tmp), 0));	4614	tmp = gfc_create_var (gfc_array_index_type, NULL);
4592	tmp = build3_v (COND_EXPR, tmp, deallocate, build_empty_stmt ());	4615	ptr = build_fold_addr_expr (tmp);
		4616
		4617	/* Call array_deallocate with an int* present in the second argument.
		4618	Although it is ignored here, it's presence ensures that arrays that
		4619	are already deallocated are ignored. */
		4620	tmp = gfc_chainon_list (NULL_TREE, var);
		4621	tmp = gfc_chainon_list (tmp, ptr);
		4622	tmp = build_function_call_expr (gfor_fndecl_deallocate, tmp);
4593	gfc_add_expr_to_block (&block, tmp);	4623	gfc_add_expr_to_block (&block, tmp);
		4624	return gfc_finish_block (&block);
		4625	}
4594		4626
4595	tmp = gfc_finish_block (&block);
4596		4627
4597	return tmp;	4628	/* This helper function calculates the size in words of a full array. */
		4629
		4630	static tree
		4631	get_full_array_size (stmtblock_t *block, tree decl, int rank)
		4632	{
		4633	tree idx;
		4634	tree nelems;
		4635	tree tmp;
		4636	idx = gfc_rank_cst[rank - 1];
		4637	nelems = gfc_conv_descriptor_ubound (decl, idx);
		4638	tmp = gfc_conv_descriptor_lbound (decl, idx);
		4639	tmp = build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
		4640	tmp = build2 (PLUS_EXPR, gfc_array_index_type,
		4641	tmp, gfc_index_one_node);
		4642	tmp = gfc_evaluate_now (tmp, block);
		4643
		4644	nelems = gfc_conv_descriptor_stride (decl, idx);
		4645	tmp = build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
		4646	return gfc_evaluate_now (tmp, block);
4598	}	4647	}
4599		4648
4600		4649
		4650	/* Recursively traverse an object of derived type, generating code to deallocate,
		4651	nullify or copy allocatable components. This is the work horse function for
		4652	the functions named in this enum. */
		4653	enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP};
		4654
		4655	static tree
		4656	structure_alloc_comps (gfc_symbol * der_type, tree decl,
		4657	tree dest, int rank, int purpose)
		4658	{
		4659	gfc_component *c;
		4660	gfc_loopinfo loop;
		4661	stmtblock_t fnblock;
		4662	stmtblock_t loopbody;
		4663	tree tmp;
		4664	tree comp;
		4665	tree dcmp;
		4666	tree nelems;
		4667	tree index;
		4668	tree var;
		4669	tree cdecl;
		4670	tree ctype;
		4671
		4672	gfc_init_block (&fnblock);
		4673
		4674	/* If this an array of derived types with allocatable components
		4675	build a loop and recursively call this function. */
		4676	if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE
		4677	\|\| GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
		4678	{
		4679	tmp = gfc_conv_array_data (decl);
		4680	var = build_fold_indirect_ref (tmp);
		4681
		4682	/* Get the number of elements - 1 and set the counter. */
		4683	if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
		4684	{
		4685	/* Use the descriptor for an allocatable array. Since this
		4686	is a full array reference, we only need the descriptor
		4687	information from dimension = rank. */
		4688	nelems = get_full_array_size (&fnblock, decl, rank);
		4689
		4690	/* Set the result to -1 if already deallocated, so that the
		4691	loop does not run. */
		4692	tmp = gfc_conv_descriptor_data_get (decl);
		4693	tmp = build2 (NE_EXPR, boolean_type_node, tmp,
		4694	build_int_cst (TREE_TYPE (tmp), 0));
		4695	tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
		4696	nelems, gfc_index_zero_node);
		4697	tmp = gfc_evaluate_now (tmp, &fnblock);
		4698	tmp = build2 (MINUS_EXPR, gfc_array_index_type,
		4699	tmp, gfc_index_one_node);
		4700	}
		4701	else
		4702	{
		4703	/* Otherwise use the TYPE_DOMAIN information. */
		4704	tmp = array_type_nelts (TREE_TYPE (decl));
		4705	tmp = fold_convert (gfc_array_index_type, tmp);
		4706	}
		4707
		4708	nelems = gfc_evaluate_now (tmp, &fnblock);
		4709	index = gfc_create_var (gfc_array_index_type, "S");
		4710
		4711	/* Build the body of the loop. */
		4712	gfc_init_block (&loopbody);
		4713
4714	tmp = gfc_build_array_ref (var, index);
4715
4716	if (purpose == COPY_ALLOC_COMP)
4717	tmp = structure_alloc_comps (der_type, tmp,
4718	gfc_build_array_ref (dest, index),
4719	0, purpose);
4720	else
4721	tmp = structure_alloc_comps (der_type, tmp, NULL_TREE, 0, purpose);
4722
4723	gfc_add_expr_to_block (&loopbody, tmp);
4724
4725	/* Build the loop and return. */
4726	gfc_init_loopinfo (&loop);
4727	loop.dimen = 1;
4728	loop.from[0] = gfc_index_zero_node;
4729	loop.loopvar[0] = index;
4730	loop.to[0] = nelems;
4731	gfc_trans_scalarizing_loops (&loop, &loopbody);
4732	gfc_add_block_to_block (&fnblock, &loop.pre);
4733	return gfc_finish_block (&fnblock);
4734	}
4735
4736	/* Otherwise, deallocate the components or recursively call self to
4737	deallocate the components of components. */
4738	for (c = der_type->components; c; c = c->next)
4739	{
4740	cdecl = c->backend_decl;
4741	ctype = TREE_TYPE (cdecl);
4742
4743	switch (purpose)
4744	{
4745	case DEALLOCATE_ALLOC_COMP:
4746	/* Do not deallocate the components of ultimate pointer
4747	components. */
4748	if (c->ts.type == BT_DERIVED
4749	&& c->ts.derived->attr.alloc_comp
4750	&& !c->pointer)
4751	{
4752	comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
4753	rank = c->as ? c->as->rank : 0;
4754	tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
4755	rank, purpose);
4756	gfc_add_expr_to_block (&fnblock, tmp);
4757	}
4758
4759	if (c->allocatable)
4760	{
4761	comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
4762	tmp = gfc_trans_dealloc_allocated (comp);
4763	gfc_add_expr_to_block (&fnblock, tmp);
4764	}
4765	break;
4766
4767	case NULLIFY_ALLOC_COMP:
4768	if (c->pointer)
4769	continue;
4770	else if (c->allocatable)
4771	{
4772	comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
4773	gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
4774	}
4775	else if (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp)
4776	{
4777	comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
4778	rank = c->as ? c->as->rank : 0;
4779	tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
4780	rank, purpose);
4781	gfc_add_expr_to_block (&fnblock, tmp);
4782	}
4783	break;
4784
4785	case COPY_ALLOC_COMP:
4786	if (c->pointer)
4787	continue;
4788
4789	comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
4790	dcmp = build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
4791	dcmp = fold_convert (TREE_TYPE (comp), dcmp);
4792
4793	if (c->allocatable)
4794	{
4795	tree size;
4796	tree args;
4797	tree null_cond;
4798	tree null_data;
4799	stmtblock_t block;
4800
4801	/* If the source is null, set the destination to null. */
4802	gfc_init_block (&block);
4803	gfc_conv_descriptor_data_set (&block, dcmp,
4804	null_pointer_node);
4805	null_data = gfc_finish_block (&block);
4806
4807	gfc_init_block (&block);
4808	nelems = get_full_array_size (&block, comp, c->as->rank);
4809	size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
4810	TYPE_SIZE_UNIT (gfc_get_element_type (ctype)));
4811
4812	/* Allocate memory to the destination. */
4813	tmp = gfc_chainon_list (NULL_TREE, size);
4814	if (gfc_index_integer_kind == 4)
4815	tmp = build_function_call_expr (gfor_fndecl_internal_malloc, tmp);
4816	else if (gfc_index_integer_kind == 8)
4817	tmp = build_function_call_expr (gfor_fndecl_internal_malloc64, tmp);
4818	else
4819	gcc_unreachable ();
4820	tmp = fold (convert (TREE_TYPE (gfc_conv_descriptor_data_get (comp)),
4821	tmp));
4822	gfc_conv_descriptor_data_set (&block, dcmp, tmp);
4823
4824	/* We know the temporary and the value will be the same length,
4825	so can use memcpy. */
4826	tmp = gfc_conv_descriptor_data_get (dcmp);
4827	args = gfc_chainon_list (NULL_TREE, tmp);
4828	tmp = gfc_conv_descriptor_data_get (comp);
4829	args = gfc_chainon_list (args, tmp);
4830	args = gfc_chainon_list (args, size);
4831	tmp = built_in_decls[BUILT_IN_MEMCPY];
4832	tmp = build_function_call_expr (tmp, args);
4833	gfc_add_expr_to_block (&block, tmp);
4834	tmp = gfc_finish_block (&block);
4835
4836	/* Null the destination if the source is null; otherwise do
4837	the allocate and copy. */
4838	null_cond = gfc_conv_descriptor_data_get (comp);
4839	null_cond = convert (pvoid_type_node, null_cond);
4840	null_cond = build2 (NE_EXPR, boolean_type_node, null_cond,
4841	null_pointer_node);
4842	tmp = build3_v (COND_EXPR, null_cond, tmp, null_data);
4843	gfc_add_expr_to_block (&fnblock, tmp);
4844	}
4845
4846	if (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp)
4847	{
4848	rank = c->as ? c->as->rank : 0;
4849	tmp = structure_alloc_comps (c->ts.derived, comp, dcmp,
4850	rank, purpose);
4851	gfc_add_expr_to_block (&fnblock, tmp);
4852	}
4853	break;
4854
4855	default:
4856	gcc_unreachable ();
4857	break;
4858	}
4859	}
4860
4861	return gfc_finish_block (&fnblock);
4862	}
4863
4864	/* Recursively traverse an object of derived type, generating code to
4865	nullify allocatable components. */
4866
4867	tree
4868	nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
4869	{
4870	return structure_alloc_comps (der_type, decl, NULL_TREE,
4871	rank, NULLIFY_ALLOC_COMP);
4872	}
4873
4874
4875	/* Recursively traverse an object of derived type, generating code to
4876	deallocate allocatable components. */
4877
4878	tree
4879	deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
4880	{
4881	return structure_alloc_comps (der_type, decl, NULL_TREE,
4882	rank, DEALLOCATE_ALLOC_COMP);
4883	}
4884
4885
4886	/* Recursively traverse an object of derived type, generating code to
4887	copy its allocatable components. */
4888
4889	tree
4890	copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
4891	{
4892	return structure_alloc_comps (der_type, decl, dest,
4893	rank, COPY_ALLOC_COMP);
4894	}
4895
4896
4601	/* NULLIFY an allocatable/pointer array on function entry, free it on exit. */	4897	/* NULLIFY an allocatable/pointer array on function entry, free it on exit. */
4602		4898
4603	tree	4899	tree
Lines 4608-4623 Link Here
4608	tree descriptor;	4904	tree descriptor;
4609	stmtblock_t fnblock;	4905	stmtblock_t fnblock;
4610	locus loc;	4906	locus loc;
		4907	int rank;
4611		4908
4612	/* Make sure the frontend gets these right. */	4909	/* Make sure the frontend gets these right. */
4613	if (!(sym->attr.pointer \|\| sym->attr.allocatable))	4910	if (!(sym->attr.pointer \|\| sym->attr.allocatable
4614	fatal_error	4911	\|\| (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)))
4615	("Possible frontend bug: Deferred array size without pointer or allocatable attribute.");	4912	fatal_error ("Possible frontend bug: Deferred array size without pointer"
		4913	"allocatable attribute.");
4616		4914
4617	gfc_init_block (&fnblock);	4915	gfc_init_block (&fnblock);
4618		4916
4619	gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL	4917	gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
4620	\|\| TREE_CODE (sym->backend_decl) == PARM_DECL);	4918	\|\| TREE_CODE (sym->backend_decl) == PARM_DECL);
4621		4919
4622	if (sym->ts.type == BT_CHARACTER	4920	if (sym->ts.type == BT_CHARACTER
4623	&& !INTEGER_CST_P (sym->ts.cl->backend_decl))	4921	&& !INTEGER_CST_P (sym->ts.cl->backend_decl))
Lines 4647-4668 Link Here
4647		4945
4648	/* Get the descriptor type. */	4946	/* Get the descriptor type. */
4649	type = TREE_TYPE (sym->backend_decl);	4947	type = TREE_TYPE (sym->backend_decl);
4650	if (!GFC_DESCRIPTOR_TYPE_P (type))	4948
		4949	if (sym->ts.type == BT_DERIVED
		4950	&& sym->ts.derived->attr.alloc_comp
		4951	&& !(sym->attr.pointer \|\| sym->attr.allocatable))
4651	{	4952	{
		4953	rank = sym->as ? sym->as->rank : 0;
		4954	tmp = nullify_alloc_comp (sym->ts.derived, descriptor, rank);
		4955	gfc_add_expr_to_block (&fnblock, tmp);
		4956	}
		4957	else if (!GFC_DESCRIPTOR_TYPE_P (type))
		4958	{
4652	/* If the backend_decl is not a descriptor, we must have a pointer	4959	/* If the backend_decl is not a descriptor, we must have a pointer
4653	to one. */	4960	to one. */
4654	descriptor = build_fold_indirect_ref (sym->backend_decl);	4961	descriptor = build_fold_indirect_ref (sym->backend_decl);
4655	type = TREE_TYPE (descriptor);	4962	type = TREE_TYPE (descriptor);
4656	gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
4657	}	4963	}
4658		4964
4659	/* NULLIFY the data pointer. */	4965	/* NULLIFY the data pointer. */
4660	gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);	4966	if (GFC_DESCRIPTOR_TYPE_P (type))
		4967	gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
4661		4968
4662	gfc_add_expr_to_block (&fnblock, body);	4969	gfc_add_expr_to_block (&fnblock, body);
4663		4970
4664	gfc_set_backend_locus (&loc);	4971	gfc_set_backend_locus (&loc);
4665	/* Allocatable arrays need to be freed when they go out of scope. */	4972
		4973	/* Allocatable arrays need to be freed when they go out of scope.
		4974	The allocatable components of pointers must not be touched. */
		4975	if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp
		4976	&& !(sym->attr.function \|\| sym->attr.result)
		4977	&& !sym->attr.pointer)
		4978	{
		4979	int rank;
		4980	rank = sym->as ? sym->as->rank : 0;
		4981	tmp = deallocate_alloc_comp (sym->ts.derived, descriptor, rank);
		4982	gfc_add_expr_to_block (&fnblock, tmp);
		4983	}
		4984
4666	if (sym->attr.allocatable)	4985	if (sym->attr.allocatable)
4667	{	4986	{
4668	tmp = gfc_trans_dealloc_allocated (sym->backend_decl);	4987	tmp = gfc_trans_dealloc_allocated (sym->backend_decl);

Lines 1523-1528 Link Here

(-)gcc/fortran/symbol.c (+2 lines)
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





  /* Check array components.  */
  if (!c->dimension)
    {
      if (c->allocatable)
	{
	  gfc_error ("Allocatable component at %C must be an array");
	  return FAILURE;
	}
      else
	return SUCCESS;
    }

  if (c->pointer)
    {
      if (c->as->type != AS_DEFERRED)
	{
	  gfc_error ("Pointer array component of structure at %C must have a "
		     "deferred shape");
	  return FAILURE;
	}
    }
  else if (c->allocatable)
    {
      if (c->as->type != AS_DEFERRED)
	{
	  gfc_error ("Allocatable component of structure at %C must have a "
		     "deferred shape");
	  return FAILURE;
	}
    }
  else
    {
      if (c->as->type != AS_EXPLICIT)

	  && d != DECL_DIMENSION && d != DECL_POINTER
	  && d != DECL_COLON && d != DECL_NONE)
	{
	  if (d == DECL_ALLOCATABLE)
	    {
	      if (gfc_notify_std (GFC_STD_F2003, 
				   "In the selected standard, the ALLOCATABLE "
				   "attribute at %C is not allowed in a TYPE "
				   "definition") == FAILURE)         
		{
		  m = MATCH_ERROR;
		  goto cleanup;
		}
            }
          else
	    {
	      gfc_error ("Attribute at %L is not allowed in a TYPE definition",
			  &seen_at[d]);
	      m = MATCH_ERROR;
	      goto cleanup;
	    }
	}

      if ((d == DECL_PRIVATE || d == DECL_PUBLIC)

Lines 149-154 Link Here

(-)gcc/fortran/intrinsic.h (+1 lines)
149	try gfc_check_fstat_sub (gfc_expr , gfc_expr , gfc_expr *);	149	try gfc_check_fstat_sub (gfc_expr , gfc_expr , gfc_expr *);
150	try gfc_check_gerror (gfc_expr *);	150	try gfc_check_gerror (gfc_expr *);
151	try gfc_check_getlog (gfc_expr *);	151	try gfc_check_getlog (gfc_expr *);
		152	try gfc_check_move_alloc (gfc_expr , gfc_expr );
152	try gfc_check_mvbits (gfc_expr , gfc_expr , gfc_expr , gfc_expr ,	153	try gfc_check_mvbits (gfc_expr , gfc_expr , gfc_expr , gfc_expr ,
153	gfc_expr *);	154	gfc_expr *);
154	try gfc_check_random_number (gfc_expr *);	155	try gfc_check_random_number (gfc_expr *);

Lines 43-48 Link Here

(-)gcc/fortran/trans-array.h (+7 lines)
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. */

Lines 522-527 Link Here

(-)gcc/fortran/gfortran.h (-1 / +5 lines)
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 *);




      gfc_conv_expr (&lse, expr);

      /* Use the scalar assignment.  */
      tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);

      /* Form the mask expression according to the mask tree list.  */
      if (wheremask)

    }

  /* Use the scalar assignment.  */
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts, false, false);

  /* Form the mask expression according to the mask tree list.  */
  if (wheremask)

    maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr);

  /* Use the scalar assignment as is.  */
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
				 loop.temp_ss != NULL, false);
  tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());

  gfc_add_expr_to_block (&body, tmp);

				    maskexpr);

          /* Use the scalar assignment as is.  */
          tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false);
          tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
          gfc_add_expr_to_block (&body, tmp);


        gfc_conv_expr (&edse, edst);
    }

  tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, false);
  estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts, false, false)
		 : build_empty_stmt ();
  tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
  gfc_add_expr_to_block (&body, tmp);

      se.descriptor_only = 1;
      gfc_conv_expr (&se, expr);

      if (expr->ts.type == BT_DERIVED
	    && expr->ts.derived->attr.alloc_comp)
        {
	  gfc_ref *ref;
	  gfc_ref *last = NULL;
	  for (ref = expr->ref; ref; ref = ref->next)
	    if (ref->type == REF_COMPONENT)
	      last = ref;

	  /* Do not deallocate the components of a derived type
	     ultimate pointer component.  */
	  if (!(last && last->u.c.component->pointer)
		   && !(!last && expr->symtree->n.sym->attr.pointer))
	    {
	      tmp = deallocate_alloc_comp (expr->ts.derived, se.expr,
					   expr->rank);
	      gfc_add_expr_to_block (&se.pre, tmp);
	    }
	}

      if (expr->rank)
	tmp = gfc_array_deallocate (se.expr, pstat);
      else




          break;
        }
}


/* Given the expression node e for an allocatable/pointer of derived type to be
   allocated, get the expression node to be initialized afterwards (needed for
   derived types with default initializers, and derived types with allocatable
   components that need nullification.)  */

gfc_expr *
gfc_expr_to_initialize (gfc_expr * e)
{
  gfc_expr *result;
  gfc_ref *ref;
  int i;

  result = gfc_copy_expr (e);

  /* Change the last array reference from AR_ELEMENT to AR_FULL.  */
  for (ref = result->ref; ref; ref = ref->next)
    if (ref->type == REF_ARRAY && ref->next == NULL)
      {
        ref->u.ar.type = AR_FULL;

        for (i = 0; i < ref->u.ar.dimen; i++)
          ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;

        result->rank = ref->u.ar.dimen; 
        break;
      }

  return result;
}


Lines 1435-1441 Link Here

(-)gcc/fortran/module.c (-1 / +10 lines)
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 ();

Lines 1532-1538 Link Here

(-)gcc/fortran/trans-types.c (-1 / +1 lines)
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. */

Lines 307-313 Link Here

(-)gcc/fortran/trans.h (-1 / +1 lines)
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 *);






/* Do the checks of the actual argument list that are specific to elemental
   procedures.  */
   expr == NULL, we have a subroutine.  */
static try
resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
{
  gfc_actual_arglist * arg0;
  gfc_actual_arglist * arg;
  gfc_symbol *esym = NULL;
  gfc_intrinsic_sym *isym = NULL;
  gfc_expr *e = NULL;

  int i;
  int rank = 0;

  /* Is this an elemental procedure?  */
  if (expr && expr->value.function.actual != NULL)
    {
      if (expr->value.function.esym != NULL

		&& arg->expr->symtree->n.sym->attr.optional)
	    set_by_optional = true;

	  /* Function specific.  */
	  if (expr)
	    {
	      expr->rank = rank;

      else if (isym)
	formal_optional = true;

      if (arg->expr !=NULL
	    && arg->expr->expr_type == EXPR_VARIABLE
	    && arg->expr->symtree->n.sym->attr.optional
	    && formal_optional

}


/* Given the expression node e for an allocatable/pointer of derived type to be
   allocated, get the expression node to be initialized afterwards (needed for
   derived types with default initializers).  */

static gfc_expr *
expr_to_initialize (gfc_expr * e)
{
  gfc_expr *result;
  gfc_ref *ref;
  int i;

  result = gfc_copy_expr (e);

  /* Change the last array reference from AR_ELEMENT to AR_FULL.  */
  for (ref = result->ref; ref; ref = ref->next)
    if (ref->type == REF_ARRAY && ref->next == NULL)
      {
        ref->u.ar.type = AR_FULL;

        for (i = 0; i < ref->u.ar.dimen; i++)
          ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;

        result->rank = ref->u.ar.dimen; 
        break;
      }

  return result;
}


/* Resolve the expression in an ALLOCATE statement, doing the additional
   checks to see whether the expression is OK or not.  The expression must
   have a trailing array reference that gives the size of the array.  */

        init_st = gfc_get_code ();
        init_st->loc = code->loc;
        init_st->op = EXEC_ASSIGN;
        init_st->expr = gfc_expr_to_initialize (e);
	init_st->expr2 = init_e;

        init_st->next = code->next;
        code->next = init_st;
    }

	  return FAILURE;
	}

      if (c->pointer || c->allocatable ||  c->as == NULL)
	continue;

      for (i = 0; i < c->as->rank; i++)

Lines 945-950 Link Here

(-)gcc/fortran/trans-decl.c (-3 / +27 lines)
945	GFC_DECL_PACKED_ARRAY (decl) = 1;	945	GFC_DECL_PACKED_ARRAY (decl) = 1;
946	}	946	}
947		947
		948	if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
		949	gfc_defer_symbol_init (sym);
		950
948	gfc_finish_var_decl (decl, sym);	951	gfc_finish_var_decl (decl, sym);
949		952
950	if (sym->ts.type == BT_CHARACTER)	953	if (sym->ts.type == BT_CHARACTER)
Lines 2587-2599 Link Here
2587	break;	2590	break;
2588		2591
2589	case AS_DEFERRED:	2592	case AS_DEFERRED:
2590	fnbody = gfc_trans_deferred_array (sym, fnbody);	2593	if (!(sym->ts.type == BT_DERIVED
		2594	&& sym->ts.derived->attr.alloc_comp))
		2595	fnbody = gfc_trans_deferred_array (sym, fnbody);
2591	break;	2596	break;
2592		2597
2593	default:	2598	default:
2594	gcc_unreachable ();	2599	gcc_unreachable ();
2595	}	2600	}
		2601	if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
		2602	fnbody = gfc_trans_deferred_array (sym, fnbody);
2596	}	2603	}
		2604	else if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
		2605	fnbody = gfc_trans_deferred_array (sym, fnbody);
2597	else if (sym->ts.type == BT_CHARACTER)	2606	else if (sym->ts.type == BT_CHARACTER)
2598	{	2607	{
2599	gfc_get_backend_locus (&loc);	2608	gfc_get_backend_locus (&loc);
Lines 2829-2838 Link Here
2829	tree old_context;	2838	tree old_context;
2830	tree decl;	2839	tree decl;
2831	tree tmp;	2840	tree tmp;
		2841	tree tmp2;
2832	stmtblock_t block;	2842	stmtblock_t block;
2833	stmtblock_t body;	2843	stmtblock_t body;
2834	tree result;	2844	tree result;
2835	gfc_symbol *sym;	2845	gfc_symbol *sym;
		2846	int rank;
2836		2847
2837	sym = ns->proc_name;	2848	sym = ns->proc_name;
2838		2849
Lines 2992-2998 Link Here
2992	tmp = gfc_finish_block (&body);	3003	tmp = gfc_finish_block (&body);
2993	/* Add code to create and cleanup arrays. */	3004	/* Add code to create and cleanup arrays. */
2994	tmp = gfc_trans_deferred_vars (sym, tmp);	3005	tmp = gfc_trans_deferred_vars (sym, tmp);
2995	gfc_add_expr_to_block (&block, tmp);
2996		3006
2997	if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)	3007	if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
2998	{	3008	{
Lines 3007-3013 Link Here
3007	else	3017	else
3008	result = sym->result->backend_decl;	3018	result = sym->result->backend_decl;
3009		3019
3010	if (result == NULL_TREE)	3020	if (result != NULL_TREE && sym->attr.function
		3021	&& sym->ts.type == BT_DERIVED
		3022	&& sym->ts.derived->attr.alloc_comp)
		3023	{
		3024	rank = sym->as ? sym->as->rank : 0;
		3025	tmp2 = nullify_alloc_comp (sym->ts.derived, result, rank);
		3026	gfc_add_expr_to_block (&block, tmp2);
		3027	}
		3028
		3029	gfc_add_expr_to_block (&block, tmp);
		3030
		3031	if (result == NULL_TREE)
3011	warning (0, "Function return value not set");	3032	warning (0, "Function return value not set");
3012	else	3033	else
3013	{	3034	{
Lines 3018-3024 Link Here
3018	gfc_add_expr_to_block (&block, tmp);	3039	gfc_add_expr_to_block (&block, tmp);
3019	}	3040	}
3020	}	3041	}
		3042	else
		3043	gfc_add_expr_to_block (&block, tmp);
3021		3044
		3045
3022	/* Add all the decls we created during processing. */	3046	/* Add all the decls we created during processing. */
3023	decl = saved_function_decls;	3047	decl = saved_function_decls;
3024	while (decl)	3048	while (decl)




  gfc_statement st;
  gfc_component *c;
  gfc_state_data s;
  gfc_symbol *sym;

  error_flag = 0;


	  }
      }

  /* Look for allocatable components.  */
  sym = gfc_current_block ();
  for (c = sym->components; c; c = c->next)
    {
      if (c->allocatable || (c->ts.type == BT_DERIVED
		    	     && c->ts.derived->attr.alloc_comp))
	{
	  sym->attr.alloc_comp = 1;
	  break;
	}
     }

  pop_state ();
}


Lines 461-473 Link Here

(-)gcc/fortran/check.c (-1 / +62 lines)
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,
Lines 1753-1759 Link Here
1753	return SUCCESS;	1756	return SUCCESS;
1754	}	1757	}
1755		1758
		1759	try
		1760	gfc_check_move_alloc (gfc_expr * from, gfc_expr * to)
		1761	{
		1762	symbol_attribute attr;
1756		1763
		1764	if (variable_check (from, 0) == FAILURE)
		1765	return FAILURE;
		1766
		1767	if (array_check (from, 0) == FAILURE)
		1768	return FAILURE;
		1769
		1770	attr = gfc_variable_attr (from, NULL);
		1771	if (!attr.allocatable)
		1772	{
		1773	gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
		1774	gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
		1775	&from->where);
		1776	return FAILURE;
		1777	}
		1778
		1779	if (variable_check (to, 0) == FAILURE)
		1780	return FAILURE;
		1781
		1782	if (array_check (to, 0) == FAILURE)
		1783	return FAILURE;
		1784
		1785	attr = gfc_variable_attr (to, NULL);
		1786	if (!attr.allocatable)
		1787	{
		1788	gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
		1789	gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
		1790	&to->where);
		1791	return FAILURE;
		1792	}
		1793
		1794	if (same_type_check (from, 0, to, 1) == FAILURE)
		1795	return FAILURE;
		1796
		1797	if (to->rank != from->rank)
		1798	{
		1799	gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
		1800	"have the same rank %d/%d", gfc_current_intrinsic_arg[0],
		1801	gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
		1802	&to->where, from->rank, to->rank);
		1803	return FAILURE;
		1804	}
		1805
		1806	if (to->ts.kind != from->ts.kind)
		1807	{
		1808	gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
		1809	"be of the same kind %d/%d", gfc_current_intrinsic_arg[0],
		1810	gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
		1811	&to->where, from->ts.kind, to->ts.kind);
		1812	return FAILURE;
		1813	}
		1814
		1815	return SUCCESS;
		1816	}
		1817
1757	try	1818	try
1758	gfc_check_nearest (gfc_expr * x, gfc_expr * s)	1819	gfc_check_nearest (gfc_expr * x, gfc_expr * s)
1759	{	1820	{




symbol_attribute
gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
{
  int dimension, pointer, allocatable, target;
  symbol_attribute attr;
  gfc_ref *ref;



  dimension = attr.dimension;
  pointer = attr.pointer;
  allocatable = attr.allocatable;

  target = attr.target;
  if (pointer)

	    break;

	  case AR_SECTION:
	    allocatable = pointer = 0;
	    dimension = 1;
	    break;

	  case AR_ELEMENT:
	    allocatable = pointer = 0;
	    break;

	  case AR_UNKNOWN:

	  *ts = ref->u.c.component->ts;

	pointer = ref->u.c.component->pointer;
	allocatable = ref->u.c.component->allocatable;
	if (pointer)
	  target = 1;

	break;

      case REF_SUBSTRING:
	allocatable = pointer = 0;
	break;
      }

  attr.dimension = dimension;
  attr.pointer = pointer;
  attr.allocatable = allocatable;
  attr.target = target;

  return attr;




{
  pack_s_internal (ret, array, mask, vector, array_length);
}

extern void move_alloc (gfc_array_char *, gfc_array_char *);
export_proto(move_alloc);

void
move_alloc (gfc_array_char * from, gfc_array_char * to)
{
  int i;

  internal_free (to->data);

  for (i = 0; i < GFC_DESCRIPTOR_RANK (from); i++)
    {
      to->dim[i].lbound = from->dim[i].lbound;
      to->dim[i].ubound = from->dim[i].ubound;
      to->dim[i].stride = from->dim[i].stride;
      from->dim[i].stride = 0;
      from->dim[i].ubound = from->dim[i].lbound;
    }

  to->offset = from->offset;
  to->dtype = from->dtype;
  to->data = from->data;
  from->data = NULL;
}

extern void move_alloc_c (gfc_array_char *, GFC_INTEGER_4,
			  gfc_array_char *, GFC_INTEGER_4);
export_proto(move_alloc_c);

void
move_alloc_c (gfc_array_char * from, GFC_INTEGER_4 from_length __attribute__((unused)),
	      gfc_array_char * to, GFC_INTEGER_4 to_length __attribute__((unused)))
{
  move_alloc (from, to);
}



Return to bug 20541

Lines 2535-2537 Link Here

(-)gcc/fortran/expr.c (+32 lines)
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

Lines 1500-1505 Link Here

(-)gcc/fortran/parse.c (+13 lines)
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

Lines 42-48 Link Here

(-)gcc/fortran/trans-expr.c (-18 / +189 lines)
42	#include "trans-stmt.h"	42	#include "trans-stmt.h"
43	#include "dependency.h"	43	#include "dependency.h"
44		44
45	static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);	45	static tree gfc_trans_structure_assign (gfc_se * outer_se, tree dest, gfc_expr * expr);
46	static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,	46	static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
47	gfc_expr *);	47	gfc_expr *);
48		48
Lines 1702-1708 Link Here
1702		1702
1703	if (intent != INTENT_OUT)	1703	if (intent != INTENT_OUT)
1704	{	1704	{
1705	tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);	1705	tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
1706	gfc_add_expr_to_block (&body, tmp);	1706	gfc_add_expr_to_block (&body, tmp);
1707	gcc_assert (rse.ss == gfc_ss_terminator);	1707	gcc_assert (rse.ss == gfc_ss_terminator);
1708	gfc_trans_scalarizing_loops (&loop, &body);	1708	gfc_trans_scalarizing_loops (&loop, &body);
Lines 1787-1793 Link Here
1787		1787
1788	gcc_assert (lse.ss == gfc_ss_terminator);	1788	gcc_assert (lse.ss == gfc_ss_terminator);
1789		1789
1790	tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);	1790	tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
1791	gfc_add_expr_to_block (&body, tmp);	1791	gfc_add_expr_to_block (&body, tmp);
1792		1792
1793	/* Generate the copying loops. */	1793	/* Generate the copying loops. */
Lines 1859-1864 Link Here
1859	gfc_ss *argss;	1859	gfc_ss *argss;
1860	gfc_ss_info *info;	1860	gfc_ss_info *info;
1861	int byref;	1861	int byref;
		1862	int parm_kind;
1862	tree type;	1863	tree type;
1863	tree var;	1864	tree var;
1864	tree len;	1865	tree len;
Lines 1872-1877 Link Here
1872	gfc_expr *e;	1873	gfc_expr *e;
1873	gfc_symbol *fsym;	1874	gfc_symbol *fsym;
1874	stmtblock_t post;	1875	stmtblock_t post;
		1876	enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
1875		1877
1876	arglist = NULL_TREE;	1878	arglist = NULL_TREE;
1877	retargs = NULL_TREE;	1879	retargs = NULL_TREE;
Lines 1914-1919 Link Here
1914	{	1916	{
1915	e = arg->expr;	1917	e = arg->expr;
1916	fsym = formal ? formal->sym : NULL;	1918	fsym = formal ? formal->sym : NULL;
		1919	parm_kind = MISSING;
1917	if (e == NULL)	1920	if (e == NULL)
1918	{	1921	{
1919		1922
Lines 1942-1947 Link Here
1942	/* An elemental function inside a scalarized loop. */	1945	/* An elemental function inside a scalarized loop. */
1943	gfc_init_se (&parmse, se);	1946	gfc_init_se (&parmse, se);
1944	gfc_conv_expr_reference (&parmse, e);	1947	gfc_conv_expr_reference (&parmse, e);
		1948	parm_kind = ELEMENTAL;
1945	}	1949	}
1946	else	1950	else
1947	{	1951	{
Lines 1952-1963 Link Here
1952	if (argss == gfc_ss_terminator)	1956	if (argss == gfc_ss_terminator)
1953	{	1957	{
1954	gfc_conv_expr_reference (&parmse, e);	1958	gfc_conv_expr_reference (&parmse, e);
		1959	parm_kind = SCALAR;
1955	if (fsym && fsym->attr.pointer	1960	if (fsym && fsym->attr.pointer
1956	&& e->expr_type != EXPR_NULL)	1961	&& e->expr_type != EXPR_NULL)
1957	{	1962	{
1958	/* Scalar pointer dummy args require an extra level of	1963	/* Scalar pointer dummy args require an extra level of
1959	indirection. The null pointer already contains	1964	indirection. The null pointer already contains
1960	this level of indirection. */	1965	this level of indirection. */
		1966	parm_kind = SCALAR_POINTER;
1961	parmse.expr = build_fold_addr_expr (parmse.expr);	1967	parmse.expr = build_fold_addr_expr (parmse.expr);
1962	}	1968	}
1963	}	1969	}
Lines 2014-2019 Link Here
2014	gfc_add_block_to_block (&se->pre, &parmse.pre);	2020	gfc_add_block_to_block (&se->pre, &parmse.pre);
2015	gfc_add_block_to_block (&post, &parmse.post);	2021	gfc_add_block_to_block (&post, &parmse.post);
2016		2022
		2023	/* Allocated allocatable components of derived types must be
		2024	deallocated for INTENT(OUT) dummy arguments and non-variable
		2025	scalars. Non-variable arrays are dealt with in trans-array.c
		2026	(gfc_conv_array_parameter). */
		2027	if (e && e->ts.type == BT_DERIVED
		2028	&& e->ts.derived->attr.alloc_comp
		2029	&& ((formal && formal->sym->attr.intent == INTENT_OUT)
		2030	\|\|
		2031	(e->expr_type != EXPR_VARIABLE && !e->rank)))
		2032	{
		2033	int parm_rank;
		2034	tmp = build_fold_indirect_ref (parmse.expr);
		2035	parm_rank = e->rank;
		2036	switch (parm_kind)
		2037	{
		2038	case (ELEMENTAL):
		2039	case (SCALAR):
		2040	parm_rank = 0;
		2041	break;
		2042
		2043	case (SCALAR_POINTER):
		2044	tmp = build_fold_indirect_ref (tmp);
		2045	break;
		2046	case (ARRAY):
		2047	tmp = parmse.expr;
		2048	break;
		2049	}
		2050
		2051	tmp = deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
		2052	if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
		2053	tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym),
		2054	tmp, build_empty_stmt ());
		2055
		2056	if (e->expr_type == EXPR_FUNCTION)
		2057	/* Don't deallocate function results until they have been used. */
		2058	gfc_add_expr_to_block (&se->post, tmp);
		2059	else
		2060	gfc_add_expr_to_block (&se->pre, tmp);
		2061	}
		2062
2017	/* Character strings are passed as two parameters, a length and a	2063	/* Character strings are passed as two parameters, a length and a
2018	pointer. */	2064	pointer. */
2019	if (parmse.string_length != NULL_TREE)	2065	if (parmse.string_length != NULL_TREE)
Lines 2590-2596 Link Here
2590		2636
2591	gfc_conv_expr (&rse, expr);	2637	gfc_conv_expr (&rse, expr);
2592		2638
2593	tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);	2639	tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
2594	gfc_add_expr_to_block (&body, tmp);	2640	gfc_add_expr_to_block (&body, tmp);
2595		2641
2596	gcc_assert (rse.ss == gfc_ss_terminator);	2642	gcc_assert (rse.ss == gfc_ss_terminator);
Lines 2614-2627 Link Here
2614	/* Assign a single component of a derived type constructor. */	2660	/* Assign a single component of a derived type constructor. */
2615		2661
2616	static tree	2662	static tree
2617	gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)	2663	gfc_trans_subcomponent_assign (gfc_se * outer_se, tree dest,
		2664	gfc_component * cm, gfc_expr * expr)
2618	{	2665	{
2619	gfc_se se;	2666	gfc_se se;
		2667	gfc_se lse;
2620	gfc_ss *rss;	2668	gfc_ss *rss;
2621	stmtblock_t block;	2669	stmtblock_t block;
2622	tree tmp;	2670	tree tmp;
		2671	tree offset;
		2672	int n;
2623		2673
2624	gfc_start_block (&block);	2674	gfc_start_block (&block);
		2675
		2676	#if 0
		2677	if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
		2678	gfc_todo_error ("derived types with allocatable components as "
		2679	"arguments of derived type constructors");
		2680	#endif
2625	if (cm->pointer)	2681	if (cm->pointer)
2626	{	2682	{
2627	gfc_init_se (&se, NULL);	2683	gfc_init_se (&se, NULL);
Lines 2654-2673 Link Here
2654	}	2710	}
2655	else if (cm->dimension)	2711	else if (cm->dimension)
2656	{	2712	{
2657	tmp = gfc_trans_subarray_assign (dest, cm, expr);	2713	if (cm->allocatable && expr->expr_type == EXPR_NULL)
2658	gfc_add_expr_to_block (&block, tmp);	2714	gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
		2715	else if (cm->allocatable)
		2716	{
		2717	tree tmp2;
		2718
		2719	gfc_init_se (&se, NULL);
		2720	gfc_init_se (&lse, NULL);
		2721
		2722	se.want_pointer = 0;
		2723	gfc_conv_expr_descriptor (&se, expr, gfc_walk_expr (expr));
		2724	if (cm->ts.type == BT_CHARACTER)
		2725	lse.string_length = cm->ts.cl->backend_decl;
		2726
		2727	lse.expr = dest;
		2728
		2729	/* Clean up temporaries at the right time. */
		2730	if (expr->expr_type == EXPR_FUNCTION)
		2731	{
		2732	stmtblock_t tmp_block;
		2733
		2734	/* Prevent the freeing of the memory after the array assignment to
		2735	the derived type component.... */
		2736	gfc_init_block (&tmp_block);
		2737	gfc_add_block_to_block (&tmp_block, &se.post);
		2738	gfc_conv_descriptor_data_set (&se.post, se.expr, null_pointer_node);
		2739	gfc_add_block_to_block (&se.post, &tmp_block);
		2740
		2741	/* ...and do it when the derived type is completed. */
		2742	tmp = gfc_conv_descriptor_data_get (lse.expr);
		2743	tmp = convert (pvoid_type_node, tmp);
		2744	tmp = gfc_chainon_list (NULL_TREE, tmp);
		2745	tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
		2746	gfc_add_expr_to_block (&outer_se->post, tmp);
		2747	}
		2748
		2749	tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
		2750	gfc_add_expr_to_block (&block, tmp);
		2751
		2752	/* Shift the lbound and ubound of temporaries to being unity, rather
		2753	than zero, based. Calculate the offset for all cases. */
		2754	offset = gfc_conv_descriptor_offset (dest);
		2755	gfc_add_modify_expr (&block, offset, gfc_index_zero_node);
		2756	tmp2 =gfc_create_var (gfc_array_index_type, NULL);
		2757	for (n = 0; n < expr->rank; n++)
		2758	{
		2759	if (expr->expr_type != EXPR_VARIABLE
		2760	&& expr->expr_type != EXPR_CONSTANT)
		2761	{
		2762	tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
		2763	gfc_add_modify_expr (&block, tmp,
		2764	fold_build2 (PLUS_EXPR, gfc_array_index_type,
		2765	tmp, gfc_index_one_node));
		2766	tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
		2767	gfc_add_modify_expr (&block, tmp, gfc_index_one_node);
		2768	}
		2769	tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
		2770	gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]),
		2771	gfc_conv_descriptor_stride (dest, gfc_rank_cst[n]));
		2772	gfc_add_modify_expr (&block, tmp2, tmp);
		2773	tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
		2774	gfc_add_modify_expr (&block, offset, tmp);
		2775	}
		2776	}
		2777	else
		2778	{
2779	tmp = gfc_trans_subarray_assign (dest, cm, expr);
2780	gfc_add_expr_to_block (&block, tmp);
2781	}
2659	}	2782	}
2660	else if (expr->ts.type == BT_DERIVED)	2783	else if (expr->ts.type == BT_DERIVED)
2661	{	2784	{
2662	/* Nested derived type. */	2785	/* Nested derived type. */
2663	tmp = gfc_trans_structure_assign (dest, expr);	2786	tmp = gfc_trans_structure_assign (outer_se, dest, expr);
2664	gfc_add_expr_to_block (&block, tmp);	2787	gfc_add_expr_to_block (&block, tmp);
2665	}	2788	}
2666	else	2789	else
2667	{	2790	{
2668	/* Scalar component. */	2791	/* Scalar component. */
2669	gfc_se lse;
2670
2671	gfc_init_se (&se, NULL);	2792	gfc_init_se (&se, NULL);
2672	gfc_init_se (&lse, NULL);	2793	gfc_init_se (&lse, NULL);
2673		2794
Lines 2675-2681 Link Here
2675	if (cm->ts.type == BT_CHARACTER)	2796	if (cm->ts.type == BT_CHARACTER)
2676	lse.string_length = cm->ts.cl->backend_decl;	2797	lse.string_length = cm->ts.cl->backend_decl;
2677	lse.expr = dest;	2798	lse.expr = dest;
2678	tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type);	2799	tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
2679	gfc_add_expr_to_block (&block, tmp);	2800	gfc_add_expr_to_block (&block, tmp);
2680	}	2801	}
2681	return gfc_finish_block (&block);	2802	return gfc_finish_block (&block);
Lines 2684-2690 Link Here
2684	/* Assign a derived type constructor to a variable. */	2805	/* Assign a derived type constructor to a variable. */
2685		2806
2686	static tree	2807	static tree
2687	gfc_trans_structure_assign (tree dest, gfc_expr * expr)	2808	gfc_trans_structure_assign (gfc_se * outer_se, tree dest, gfc_expr * expr)
2688	{	2809	{
2689	gfc_constructor *c;	2810	gfc_constructor *c;
2690	gfc_component *cm;	2811	gfc_component *cm;
Lines 2702-2708 Link Here
2702		2823
2703	field = cm->backend_decl;	2824	field = cm->backend_decl;
2704	tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);	2825	tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
2705	tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);	2826	tmp = gfc_trans_subcomponent_assign (outer_se, tmp, cm, c->expr);
2706	gfc_add_expr_to_block (&block, tmp);	2827	gfc_add_expr_to_block (&block, tmp);
2707	}	2828	}
2708	return gfc_finish_block (&block);	2829	return gfc_finish_block (&block);
Lines 2729-2735 Link Here
2729	{	2850	{
2730	/* Create a temporary variable and fill it in. */	2851	/* Create a temporary variable and fill it in. */
2731	se->expr = gfc_create_var (type, expr->ts.derived->name);	2852	se->expr = gfc_create_var (type, expr->ts.derived->name);
2732	tmp = gfc_trans_structure_assign (se->expr, expr);	2853	tmp = gfc_trans_structure_assign (se, se->expr, expr);
2733	gfc_add_expr_to_block (&se->pre, tmp);	2854	gfc_add_expr_to_block (&se->pre, tmp);
2734	return;	2855	return;
2735	}	2856	}
Lines 3036-3048 Link Here
3036	strings. */	3157	strings. */
3037		3158
3038	tree	3159	tree
3039	gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)	3160	gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
		3161	bool l_is_temp, bool r_is_var)
3040	{	3162	{
3041	stmtblock_t block;	3163	stmtblock_t block;
		3164	tree tmp;
		3165	tree cond;
3042		3166
3043	gfc_init_block (&block);	3167	gfc_init_block (&block);
3044		3168
3045	if (type == BT_CHARACTER)	3169	if (ts.type == BT_CHARACTER)
3046	{	3170	{
3047	gcc_assert (lse->string_length != NULL_TREE	3171	gcc_assert (lse->string_length != NULL_TREE
3048	&& rse->string_length != NULL_TREE);	3172	&& rse->string_length != NULL_TREE);
Lines 3056-3061 Link Here
3056	gfc_trans_string_copy (&block, lse->string_length, lse->expr,	3180	gfc_trans_string_copy (&block, lse->string_length, lse->expr,
3057	rse->string_length, rse->expr);	3181	rse->string_length, rse->expr);
3058	}	3182	}
		3183	else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
		3184	{
		3185	cond = NULL_TREE;
		3186
		3187	/* Are the rhs and the lhs the same? */
		3188	if (r_is_var)
		3189	{
		3190	cond = fold_build2 (EQ_EXPR, boolean_type_node,
		3191	build_fold_addr_expr (lse->expr),
		3192	build_fold_addr_expr (rse->expr));
		3193	cond = gfc_evaluate_now (cond, &lse->pre);
		3194	}
		3195
		3196	/* Deallocate the lhs allocated components as long as it is not
		3197	the same as the rhs. */
		3198	if (!l_is_temp)
		3199	{
		3200	tmp = deallocate_alloc_comp (ts.derived, lse->expr, 0);
		3201	if (r_is_var)
		3202	tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
		3203	gfc_add_expr_to_block (&lse->pre, tmp);
		3204	}
		3205
		3206	gfc_add_block_to_block (&block, &lse->pre);
		3207	gfc_add_block_to_block (&block, &rse->pre);
		3208
		3209	gfc_add_modify_expr (&block, lse->expr,
		3210	fold_convert (TREE_TYPE (lse->expr), rse->expr));
		3211
		3212	/* Do a deep copy if the rhs is a variable, as long as it is not the
		3213	same as the lhs. Otherwise, nullify the data fields so that the
		3214	lhs retains the allocated resources. */
		3215	if (r_is_var)
		3216	{
		3217	tmp = copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
		3218	tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
		3219	gfc_add_expr_to_block (&block, tmp);
		3220	}
		3221	else
		3222	{
		3223	tmp = nullify_alloc_comp (ts.derived, rse->expr, 0);
		3224	gfc_add_expr_to_block (&block, tmp);
		3225	}
		3226	}
3059	else	3227	else
3060	{	3228	{
3061	gfc_add_block_to_block (&block, &lse->pre);	3229	gfc_add_block_to_block (&block, &lse->pre);
Lines 3250-3256 Link Here
3250	else	3418	else
3251	gfc_conv_expr (&lse, expr1);	3419	gfc_conv_expr (&lse, expr1);
3252		3420
3253	tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);	3421	tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
		3422	loop.temp_ss != NULL,
		3423	expr2->expr_type == EXPR_VARIABLE);
3254	gfc_add_expr_to_block (&body, tmp);	3424	gfc_add_expr_to_block (&body, tmp);
3255		3425
3256	if (lss == gfc_ss_terminator)	3426	if (lss == gfc_ss_terminator)
Lines 3283-3291 Link Here
3283	gcc_assert (lse.ss == gfc_ss_terminator	3453	gcc_assert (lse.ss == gfc_ss_terminator
3284	&& rse.ss == gfc_ss_terminator);	3454	&& rse.ss == gfc_ss_terminator);
3285		3455
3286	tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);	3456	tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false);
3287	gfc_add_expr_to_block (&body, tmp);	3457	gfc_add_expr_to_block (&body, tmp);
3288	}	3458	}
		3459
3289	/* Generate the copying loops. */	3460	/* Generate the copying loops. */
3290	gfc_trans_scalarizing_loops (&loop, &body);	3461	gfc_trans_scalarizing_loops (&loop, &body);
3291		3462

Lines 963-979 Link Here

(-)gcc/fortran/decl.c (-8 / +38 lines)
963		963
964	/* Check array components. */	964	/* Check array components. */
965	if (!c->dimension)	965	if (!c->dimension)
966	return SUCCESS;	966	{
		967	if (c->allocatable)
		968	{
		969	gfc_error ("Allocatable component at %C must be an array");
		970	return FAILURE;
		971	}
		972	else
		973	return SUCCESS;
		974	}
967		975
968	if (c->pointer)	976	if (c->pointer)
969	{	977	{
970	if (c->as->type != AS_DEFERRED)	978	if (c->as->type != AS_DEFERRED)
971	{	979	{
972	gfc_error ("Pointer array component of structure at %C "	980	gfc_error ("Pointer array component of structure at %C must have a "
973	"must have a deferred shape");	981	"deferred shape");
974	return FAILURE;	982	return FAILURE;
975	}	983	}
976	}	984	}
		985	else if (c->allocatable)
		986	{
		987	if (c->as->type != AS_DEFERRED)
		988	{
		989	gfc_error ("Allocatable component of structure at %C must have a "
		990	"deferred shape");
		991	return FAILURE;
		992	}
		993	}
977	else	994	else
978	{	995	{
979	if (c->as->type != AS_EXPLICIT)	996	if (c->as->type != AS_EXPLICIT)
Lines 2142-2152 Link Here
2142	&& d != DECL_DIMENSION && d != DECL_POINTER	2159	&& d != DECL_DIMENSION && d != DECL_POINTER
2143	&& d != DECL_COLON && d != DECL_NONE)	2160	&& d != DECL_COLON && d != DECL_NONE)
2144	{	2161	{
2145		2162	if (d == DECL_ALLOCATABLE)
2146	gfc_error ("Attribute at %L is not allowed in a TYPE definition",	2163	{
2147	&seen_at[d]);	2164	if (gfc_notify_std (GFC_STD_F2003,
2148	m = MATCH_ERROR;	2165	"In the selected standard, the ALLOCATABLE "
2149	goto cleanup;	2166	"attribute at %C is not allowed in a TYPE "
		2167	"definition") == FAILURE)
		2168	{
		2169	m = MATCH_ERROR;
		2170	goto cleanup;
		2171	}
		2172	}
		2173	else
		2174	{
		2175	gfc_error ("Attribute at %L is not allowed in a TYPE definition",
		2176	&seen_at[d]);
		2177	m = MATCH_ERROR;
		2178	goto cleanup;
		2179	}
2150	}	2180	}
2151		2181
2152	if ((d == DECL_PRIVATE \|\| d == DECL_PUBLIC)	2182	if ((d == DECL_PRIVATE \|\| d == DECL_PUBLIC)

Lines 1795-1801 Link Here

(-)gcc/fortran/trans-stmt.c (-6 / +27 lines)
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 2971-2977 Link Here
2971	maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr);	2971	maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr);
2972		2972
2973	/* Use the scalar assignment as is. */	2973	/* Use the scalar assignment as is. */
2974	tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);	2974	tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
		2975	loop.temp_ss != NULL, false);
2975	tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());	2976	tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
2976		2977
2977	gfc_add_expr_to_block (&body, tmp);	2978	gfc_add_expr_to_block (&body, tmp);
Lines 3024-3030 Link Here
3024	maskexpr);	3025	maskexpr);
3025		3026
3026	/* Use the scalar assignment as is. */	3027	/* Use the scalar assignment as is. */
3027	tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);	3028	tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false);
3028	tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());	3029	tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
3029	gfc_add_expr_to_block (&body, tmp);	3030	gfc_add_expr_to_block (&body, tmp);
3030		3031
Lines 3399-3406 Link Here
3399	gfc_conv_expr (&edse, edst);	3400	gfc_conv_expr (&edse, edst);
3400	}	3401	}
3401		3402
3402	tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts.type);	3403	tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, false);
3403	estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts.type)	3404	estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts, false, false)
3404	: build_empty_stmt ();	3405	: build_empty_stmt ();
3405	tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);	3406	tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
3406	gfc_add_expr_to_block (&body, tmp);	3407	gfc_add_expr_to_block (&body, tmp);
Lines 3668-3673 Link Here
3668	se.descriptor_only = 1;	3669	se.descriptor_only = 1;
3669	gfc_conv_expr (&se, expr);	3670	gfc_conv_expr (&se, expr);
3670		3671
		3672	if (expr->ts.type == BT_DERIVED
		3673	&& expr->ts.derived->attr.alloc_comp)
		3674	{
		3675	gfc_ref *ref;
		3676	gfc_ref *last = NULL;
		3677	for (ref = expr->ref; ref; ref = ref->next)
		3678	if (ref->type == REF_COMPONENT)
		3679	last = ref;
		3680
		3681	/* Do not deallocate the components of a derived type
		3682	ultimate pointer component. */
		3683	if (!(last && last->u.c.component->pointer)
		3684	&& !(!last && expr->symtree->n.sym->attr.pointer))
		3685	{
		3686	tmp = deallocate_alloc_comp (expr->ts.derived, se.expr,
		3687	expr->rank);
		3688	gfc_add_expr_to_block (&se.pre, tmp);
		3689	}
		3690	}
		3691
3671	if (expr->rank)	3692	if (expr->rank)
3672	tmp = gfc_array_deallocate (se.expr, pstat);	3693	tmp = gfc_array_deallocate (se.expr, pstat);
3673	else	3694	else

Lines 911-923 Link Here

(-)gcc/fortran/resolve.c (-41 / +8 lines)
911		911
912		912
913	/* Do the checks of the actual argument list that are specific to elemental	913	/* Do the checks of the actual argument list that are specific to elemental
914	procedures. If called with c == NULL, we have a function, otherwise if	914	procedures. */
915	expr == NULL, we have a subroutine. */
916	static try	915	static try
917	resolve_elemental_actual (gfc_expr expr, gfc_code c)	916	resolve_elemental_actual (gfc_expr expr, gfc_code c)
918	{	917	{
919	gfc_actual_arglist *arg0;	918	gfc_actual_arglist * arg0;
920	gfc_actual_arglist *arg;	919	gfc_actual_arglist * arg;
921	gfc_symbol *esym = NULL;	920	gfc_symbol *esym = NULL;
922	gfc_intrinsic_sym *isym = NULL;	921	gfc_intrinsic_sym *isym = NULL;
923	gfc_expr *e = NULL;	922	gfc_expr *e = NULL;
Lines 928-934 Link Here
928	int i;	927	int i;
929	int rank = 0;	928	int rank = 0;
930		929
931	/* Is this an elemental procedure? */
932	if (expr && expr->value.function.actual != NULL)	930	if (expr && expr->value.function.actual != NULL)
933	{	931	{
934	if (expr->value.function.esym != NULL	932	if (expr->value.function.esym != NULL
Lines 965-971 Link Here
965	&& arg->expr->symtree->n.sym->attr.optional)	963	&& arg->expr->symtree->n.sym->attr.optional)
966	set_by_optional = true;	964	set_by_optional = true;
967		965
968	/* Function specific; set the result rank and shape. */	966	/* Function specific. */
969	if (expr)	967	if (expr)
970	{	968	{
971	expr->rank = rank;	969	expr->rank = rank;
Lines 1007-1013 Link Here
1007	else if (isym)	1005	else if (isym)
1008	formal_optional = true;	1006	formal_optional = true;
1009		1007
1010	if (arg->expr != NULL	1008	if (arg->expr !=NULL
1011	&& arg->expr->expr_type == EXPR_VARIABLE	1009	&& arg->expr->expr_type == EXPR_VARIABLE
1012	&& arg->expr->symtree->n.sym->attr.optional	1010	&& arg->expr->symtree->n.sym->attr.optional
1013	&& formal_optional	1011	&& formal_optional
Lines 3299-3334 Link Here
3299	}	3297	}
3300		3298
3301		3299
3302	/* Given the expression node e for an allocatable/pointer of derived type to be
3303	allocated, get the expression node to be initialized afterwards (needed for
3304	derived types with default initializers). */
3305
3306	static gfc_expr *
3307	expr_to_initialize (gfc_expr * e)
3308	{
3309	gfc_expr *result;
3310	gfc_ref *ref;
3311	int i;
3312
3313	result = gfc_copy_expr (e);
3314
3315	/* Change the last array reference from AR_ELEMENT to AR_FULL. */
3316	for (ref = result->ref; ref; ref = ref->next)
3317	if (ref->type == REF_ARRAY && ref->next == NULL)
3318	{
3319	ref->u.ar.type = AR_FULL;
3320
3321	for (i = 0; i < ref->u.ar.dimen; i++)
3322	ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
3323
3324	result->rank = ref->u.ar.dimen;
3325	break;
3326	}
3327
3328	return result;
3329	}
3330
3331
3332	/* Resolve the expression in an ALLOCATE statement, doing the additional	3300	/* Resolve the expression in an ALLOCATE statement, doing the additional
3333	checks to see whether the expression is OK or not. The expression must	3301	checks to see whether the expression is OK or not. The expression must
3334	have a trailing array reference that gives the size of the array. */	3302	have a trailing array reference that gives the size of the array. */
Lines 3409-3417 Link Here
3409	init_st = gfc_get_code ();	3377	init_st = gfc_get_code ();
3410	init_st->loc = code->loc;	3378	init_st->loc = code->loc;
3411	init_st->op = EXEC_ASSIGN;	3379	init_st->op = EXEC_ASSIGN;
3412	init_st->expr = expr_to_initialize (e);	3380	init_st->expr = gfc_expr_to_initialize (e);
3413	init_st->expr2 = init_e;	3381	init_st->expr2 = init_e;
3414
3415	init_st->next = code->next;	3382	init_st->next = code->next;
3416	code->next = init_st;	3383	code->next = init_st;
3417	}	3384	}
Lines 5390-5396 Link Here
5390	return FAILURE;	5357	return FAILURE;
5391	}	5358	}
5392		5359
5393	if (c->pointer \|\| c->as == NULL)	5360	if (c->pointer \|\| c->allocatable \|\| c->as == NULL)
5394	continue;	5361	continue;
5395		5362
5396	for (i = 0; i < c->as->rank; i++)	5363	for (i = 0; i < c->as->rank; i++)

Lines 1711-1717 Link Here

(-)gcc/fortran/primary.c (-4 / +7 lines)
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;

Lines 469-471 Link Here

(-)libgfortran/intrinsics/pack_generic.c (+38 lines)
469	{	469	{
470	pack_s_internal (ret, array, mask, vector, array_length);	470	pack_s_internal (ret, array, mask, vector, array_length);
471	}	471	}
		472
		473	extern void move_alloc (gfc_array_char , gfc_array_char );
		474	export_proto(move_alloc);
		475
		476	void
		477	move_alloc (gfc_array_char * from, gfc_array_char * to)
		478	{
		479	int i;
		480
		481	internal_free (to->data);
		482
		483	for (i = 0; i < GFC_DESCRIPTOR_RANK (from); i++)
		484	{
		485	to->dim[i].lbound = from->dim[i].lbound;
		486	to->dim[i].ubound = from->dim[i].ubound;
		487	to->dim[i].stride = from->dim[i].stride;
		488	from->dim[i].stride = 0;
		489	from->dim[i].ubound = from->dim[i].lbound;
		490	}
		491
		492	to->offset = from->offset;
		493	to->dtype = from->dtype;
		494	to->data = from->data;
		495	from->data = NULL;
		496	}
		497
		498	extern void move_alloc_c (gfc_array_char *, GFC_INTEGER_4,
		499	gfc_array_char *, GFC_INTEGER_4);
		500	export_proto(move_alloc_c);
		501
		502	void
		503	move_alloc_c (gfc_array_char * from, GFC_INTEGER_4 from_length __attribute__((unused)),
		504	gfc_array_char * to, GFC_INTEGER_4 to_length __attribute__((unused)))
		505	{
		506	move_alloc (from, to);
		507	}
		508
		509