Attachment #11910 for bug #20541

(-)gcc/fortran/interface.c (+3 lines)

Lines 374-379	Link Here

374

      if (dt1->dimension != dt2->dimension)

374

      if (dt1->dimension != dt2->dimension)

375

	return 0;

375

	return 0;

376

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 2318-2323	Link Here

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

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);


(-)gcc/fortran/trans-array.c (-18 / +337 lines)

Lines 3316-3321	Link Here

3316

  tmp = gfc_conv_descriptor_offset (se->expr);

3316

  tmp = gfc_conv_descriptor_offset (se->expr);

3317

  gfc_add_modify_expr (&se->pre, tmp, offset);

3317

  gfc_add_modify_expr (&se->pre, tmp, offset);

3318

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);

(-)gcc/fortran/symbol.c (+2 lines)

Lines 1523-1528	Link Here

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

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)

(-)gcc/fortran/intrinsic.h (+1 lines)

Lines 149-154	Link Here

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 *);

(-)gcc/fortran/trans-array.h (+7 lines)

Lines 43-48	Link Here

tree gfc_trans_g77_array (gfc_symbol *, tree);

tree gfc_trans_g77_array (gfc_symbol *, tree);

/* Generate code to deallocate an array, if it is allocated.  */

/* Generate code to deallocate an array, if it is allocated.  */

tree gfc_trans_dealloc_allocated (tree);

tree gfc_trans_dealloc_allocated (tree);

tree nullify_alloc_comp (gfc_symbol *, tree, int);

tree deallocate_alloc_comp (gfc_symbol *, tree, int);

tree copy_alloc_comp (gfc_symbol *, tree, tree, int);

/* Add initialization for deferred arrays.  */

/* Add initialization for deferred arrays.  */

tree gfc_trans_deferred_array (gfc_symbol *, tree);

tree gfc_trans_deferred_array (gfc_symbol *, tree);

/* Generate an initializer for a static pointer or allocatable array.  */

/* Generate an initializer for a static pointer or allocatable array.  */

(-)gcc/fortran/gfortran.h (-1 / +5 lines)

Lines 522-527	Link Here

522

  /* Special attributes for Cray pointers, pointees.  */

522

  /* Special attributes for Cray pointers, pointees.  */

523

  unsigned cray_pointer:1, cray_pointee:1;

523

  unsigned cray_pointer:1, cray_pointee:1;

524

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;
}


(-)gcc/fortran/module.c (-1 / +10 lines)

Lines 1435-1441	Link Here

1435

  AB_DATA, AB_IN_NAMELIST, AB_IN_COMMON,

1435

  AB_DATA, AB_IN_NAMELIST, AB_IN_COMMON,

1436

  AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, AB_ELEMENTAL, AB_PURE,

1436

  AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, AB_ELEMENTAL, AB_PURE,

1437

  AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT, AB_CRAY_POINTER,

1437

  AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT, AB_CRAY_POINTER,

1438

  AB_CRAY_POINTEE, AB_THREADPRIVATE

1438

  AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP

1439

1440

ab_attribute;

1440

ab_attribute;

1441

Lines 1465-1470	Link Here

1465

    minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),

1465

    minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),

1466

    minit ("CRAY_POINTER", AB_CRAY_POINTER),

1466

    minit ("CRAY_POINTER", AB_CRAY_POINTER),

1467

    minit ("CRAY_POINTEE", AB_CRAY_POINTEE),

1467

    minit ("CRAY_POINTEE", AB_CRAY_POINTEE),

1468

    minit ("CRAY_POINTEE", AB_CRAY_POINTEE),

1469

    minit ("ALLOC_COMP", AB_ALLOC_COMP),

1468

    minit (NULL, -1)

1470

    minit (NULL, -1)

1469

};

1471

};

1470

1472

Lines 1556-1561	Link Here

1556

      if (attr->cray_pointee)

1558

      if (attr->cray_pointee)

1557

	MIO_NAME(ab_attribute) (AB_CRAY_POINTEE, attr_bits);

1559

	MIO_NAME(ab_attribute) (AB_CRAY_POINTEE, attr_bits);

1558

1560

1561

      if (attr->alloc_comp)

1562

	MIO_NAME(ab_attribute) (AB_ALLOC_COMP, attr_bits);

1563

1559

      mio_rparen ();

1564

      mio_rparen ();

1560

1565

1561

1566

Lines 1644-1649	Link Here

1644

	    case AB_CRAY_POINTEE:

1649

	    case AB_CRAY_POINTEE:

1645

	      attr->cray_pointee = 1;

1650

	      attr->cray_pointee = 1;

1646

	      break;

1651

	      break;

1652

	    case AB_ALLOC_COMP:

1653

	      attr->alloc_comp = 1;

1654

	      break;

1647

1655

1648

1656

1649

1657

Lines 1951-1956	Link Here

1951

1959

1952

  mio_integer (&c->dimension);

1960

  mio_integer (&c->dimension);

1953

  mio_integer (&c->pointer);

1961

  mio_integer (&c->pointer);

1962

  mio_integer (&c->allocatable);

1954

1963

1955

  mio_expr (&c->initializer);

1964

  mio_expr (&c->initializer);

1956

  mio_rparen ();

1965

  mio_rparen ();

(-)gcc/fortran/trans-types.c (-1 / +1 lines)

Lines 1532-1538	Link Here

1532

         required.  */

1532

         required.  */

1533

      if (c->dimension)

1533

      if (c->dimension)

1534

1535

	  if (c->pointer)

1535

	  if (c->pointer || c->allocatable)

1536

1537

	      /* Pointers to arrays aren't actually pointer types.  The

1537

	      /* Pointers to arrays aren't actually pointer types.  The

1538

	         descriptors are separate, but the data is common.  */

1538

	         descriptors are separate, but the data is common.  */

(-)gcc/fortran/trans.h (-1 / +1 lines)

Lines 307-313	Link Here

307

/* gfc_trans_* shouldn't call push/poplevel, use gfc_push/pop_scope */

307

/* gfc_trans_* shouldn't call push/poplevel, use gfc_push/pop_scope */

308

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

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++)

(-)gcc/fortran/trans-decl.c (-3 / +27 lines)

Lines 945-950	Link Here

945

	GFC_DECL_PACKED_ARRAY (decl) = 1;

945

	GFC_DECL_PACKED_ARRAY (decl) = 1;

946

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 ();
}


(-)gcc/fortran/check.c (-1 / +62 lines)

Lines 461-473	Link Here

461

try

461

try

462

gfc_check_allocated (gfc_expr * array)

462

gfc_check_allocated (gfc_expr * array)

463

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