trans-expr.c

gcc-fortran,linux使用fortran的编译软件。很好用的。

static void
gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
				     gfc_constructor * c)
{
  for (; c; c = c->next)
    {
      gfc_apply_interface_mapping_to_expr (mapping, c->expr);
      if (c->iterator)
	{
	  gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
	  gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
	  gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
	}
    }
}


/* Like gfc_apply_interface_mapping_to_expr, but applied to
   reference REF.  */

static void
gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
				    gfc_ref * ref)
{
  int n;

  for (; ref; ref = ref->next)
    switch (ref->type)
      {
      case REF_ARRAY:
	for (n = 0; n < ref->u.ar.dimen; n++)
	  {
	    gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
	    gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
	    gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
	  }
	gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
	break;

      case REF_COMPONENT:
	break;

      case REF_SUBSTRING:
	gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
	gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
	break;
      }
}


/* EXPR is a copy of an expression that appeared in the interface
   associated with MAPPING.  Walk it recursively looking for references to
   dummy arguments that MAPPING maps to actual arguments.  Replace each such
   reference with a reference to the associated actual argument.  */

static void
gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
				     gfc_expr * expr)
{
  gfc_interface_sym_mapping *sym;
  gfc_actual_arglist *actual;

  if (!expr)
    return;

  /* Copying an expression does not copy its length, so do that here.  */
  if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
    {
      expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl);
      gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length);
    }

  /* Apply the mapping to any references.  */
  gfc_apply_interface_mapping_to_ref (mapping, expr->ref);

  /* ...and to the expression's symbol, if it has one.  */
  if (expr->symtree)
    for (sym = mapping->syms; sym; sym = sym->next)
      if (sym->old == expr->symtree->n.sym)
	expr->symtree = sym->new;

  /* ...and to subexpressions in expr->value.  */
  switch (expr->expr_type)
    {
    case EXPR_VARIABLE:
    case EXPR_CONSTANT:
    case EXPR_NULL:
    case EXPR_SUBSTRING:
      break;

    case EXPR_OP:
      gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
      gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
      break;

    case EXPR_FUNCTION:
      for (sym = mapping->syms; sym; sym = sym->next)
	if (sym->old == expr->value.function.esym)
	  expr->value.function.esym = sym->new->n.sym;

      for (actual = expr->value.function.actual; actual; actual = actual->next)
	gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
      break;

    case EXPR_ARRAY:
    case EXPR_STRUCTURE:
      gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
      break;
    }
}


/* Evaluate interface expression EXPR using MAPPING.  Store the result
   in SE.  */

void
gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
			     gfc_se * se, gfc_expr * expr)
{
  expr = gfc_copy_expr (expr);
  gfc_apply_interface_mapping_to_expr (mapping, expr);
  gfc_conv_expr (se, expr);
  se->expr = gfc_evaluate_now (se->expr, &se->pre);
  gfc_free_expr (expr);
}

/* Returns a reference to a temporary array into which a component of
   an actual argument derived type array is copied and then returned
   after the function call.
   TODO Get rid of this kludge, when array descriptors are capable of
   handling aliased arrays.  */

static void
gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr, int g77)
{
  gfc_se lse;
  gfc_se rse;
  gfc_ss *lss;
  gfc_ss *rss;
  gfc_loopinfo loop;
  gfc_loopinfo loop2;
  gfc_ss_info *info;
  tree offset;
  tree tmp_index;
  tree tmp;
  tree base_type;
  stmtblock_t body;
  int n;

  gcc_assert (expr->expr_type == EXPR_VARIABLE);

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

  /* Walk the argument expression.  */
  rss = gfc_walk_expr (expr);

  gcc_assert (rss != gfc_ss_terminator);
 
  /* Initialize the scalarizer.  */
  gfc_init_loopinfo (&loop);
  gfc_add_ss_to_loop (&loop, rss);

  /* Calculate the bounds of the scalarization.  */
  gfc_conv_ss_startstride (&loop);

  /* Build an ss for the temporary.  */
  base_type = gfc_typenode_for_spec (&expr->ts);
  if (GFC_ARRAY_TYPE_P (base_type)
		|| GFC_DESCRIPTOR_TYPE_P (base_type))
    base_type = gfc_get_element_type (base_type);

  loop.temp_ss = gfc_get_ss ();;
  loop.temp_ss->type = GFC_SS_TEMP;
  loop.temp_ss->data.temp.type = base_type;

  if (expr->ts.type == BT_CHARACTER)
    loop.temp_ss->string_length = expr->ts.cl->backend_decl;

  loop.temp_ss->data.temp.dimen = loop.dimen;
  loop.temp_ss->next = gfc_ss_terminator;

  /* Associate the SS with the loop.  */
  gfc_add_ss_to_loop (&loop, loop.temp_ss);

  /* Setup the scalarizing loops.  */
  gfc_conv_loop_setup (&loop);

  /* Pass the temporary descriptor back to the caller.  */
  info = &loop.temp_ss->data.info;
  parmse->expr = info->descriptor;

  /* Setup the gfc_se structures.  */
  gfc_copy_loopinfo_to_se (&lse, &loop);
  gfc_copy_loopinfo_to_se (&rse, &loop);

  rse.ss = rss;
  lse.ss = loop.temp_ss;
  gfc_mark_ss_chain_used (rss, 1);
  gfc_mark_ss_chain_used (loop.temp_ss, 1);

  /* Start the scalarized loop body.  */
  gfc_start_scalarized_body (&loop, &body);

  /* Translate the expression.  */
  gfc_conv_expr (&rse, expr);

  gfc_conv_tmp_array_ref (&lse);
  gfc_advance_se_ss_chain (&lse);

  tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
  gfc_add_expr_to_block (&body, tmp);

  gcc_assert (rse.ss == gfc_ss_terminator);

  gfc_trans_scalarizing_loops (&loop, &body);

  /* Add the post block after the second loop, so that any
     freeing of allocated memory is done at the right time.  */
  gfc_add_block_to_block (&parmse->pre, &loop.pre);

  /**********Copy the temporary back again.*********/

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

  /* Walk the argument expression.  */
  lss = gfc_walk_expr (expr);
  rse.ss = loop.temp_ss;
  lse.ss = lss;

  /* Initialize the scalarizer.  */
  gfc_init_loopinfo (&loop2);
  gfc_add_ss_to_loop (&loop2, lss);

  /* Calculate the bounds of the scalarization.  */
  gfc_conv_ss_startstride (&loop2);

  /* Setup the scalarizing loops.  */
  gfc_conv_loop_setup (&loop2);

  gfc_copy_loopinfo_to_se (&lse, &loop2);
  gfc_copy_loopinfo_to_se (&rse, &loop2);

  gfc_mark_ss_chain_used (lss, 1);
  gfc_mark_ss_chain_used (loop.temp_ss, 1);

  /* Declare the variable to hold the temporary offset and start the
     scalarized loop body.  */
  offset = gfc_create_var (gfc_array_index_type, NULL);
  gfc_start_scalarized_body (&loop2, &body);

  /* Build the offsets for the temporary from the loop variables.  The
     temporary array has lbounds of zero and strides of one in all
     dimensions, so this is very simple.  The offset is only computed
     outside the innermost loop, so the overall transfer could be
     optimised further.  */
  info = &rse.ss->data.info;

  tmp_index = gfc_index_zero_node;
  for (n = info->dimen - 1; n > 0; n--)
    {
      tree tmp_str;
      tmp = rse.loop->loopvar[n];
      tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
			 tmp, rse.loop->from[n]);
      tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
			 tmp, tmp_index);

      tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
			     rse.loop->to[n-1], rse.loop->from[n-1]);
      tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
			     tmp_str, gfc_index_one_node);

      tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
			       tmp, tmp_str);
    }

  tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
  			   tmp_index, rse.loop->from[0]);
  gfc_add_modify_expr (&rse.loop->code[0], offset, tmp_index);

  tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
			   rse.loop->loopvar[0], offset);

  /* Now use the offset for the reference.  */
  tmp = build_fold_indirect_ref (info->data);
  rse.expr = gfc_build_array_ref (tmp, tmp_index);

  if (expr->ts.type == BT_CHARACTER)
    rse.string_length = expr->ts.cl->backend_decl;

  gfc_conv_expr (&lse, expr);

  gcc_assert (lse.ss == gfc_ss_terminator);

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

  /* Wrap the whole thing up by adding the second loop to the post-block
     and following it by the post-block of the fist loop.  In this way,
     if the temporary needs freeing, it is done after use!  */
  gfc_add_block_to_block (&parmse->post, &loop2.pre);
  gfc_add_block_to_block (&parmse->post, &loop2.post);

  gfc_add_block_to_block (&parmse->post, &loop.post);

  gfc_cleanup_loop (&loop);
  gfc_cleanup_loop (&loop2);

  /* Pass the string length to the argument expression.  */
  if (expr->ts.type == BT_CHARACTER)
    parmse->string_length = expr->ts.cl->backend_decl;

  /* We want either the address for the data or the address of the descriptor,
     depending on the mode of passing array arguments.  */
  if (g77)
    parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
  else
    parmse->expr = build_fold_addr_expr (parmse->expr);

  return;
}

/* Is true if the last array reference is followed by a component reference.  */

static bool
is_aliased_array (gfc_expr * e)
{
  gfc_ref * ref;
  bool seen_array;

  seen_array = false;	
  for (ref = e->ref; ref; ref = ref->next)
    {
      if (ref->type == REF_ARRAY)
	seen_array = true;

      if (ref->next == NULL && ref->type == REF_COMPONENT)
	return seen_array;
    }
  return false;
}

/* Generate code for a procedure call.  Note can return se->post != NULL.
   If se->direct_byref is set then se->expr contains the return parameter.
   Return nonzero, if the call has alternate specifiers.  */

int
gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
			gfc_actual_arglist * arg)
{
  gfc_interface_mapping mapping;
  tree arglist;
  tree retargs;
  tree tmp;
  tree fntype;
  gfc_se parmse;
  gfc_ss *argss;
  gfc_ss_info *info;
  int byref;
  tree type;
  tree var;
  tree len;
  tree stringargs;
  gfc_formal_arglist *formal;
  int has_alternate_specifier = 0;
  bool need_interface_mapping;
  gfc_typespec ts;
  gfc_charlen cl;

  arglist = NULL_TREE;
  retargs = NULL_TREE;
  stringargs = NULL_TREE;
  var = NULL_TREE;
  len = NULL_TREE;

  if (se->ss != NULL)
    {
      if (!sym->attr.elemental)
	{
	  gcc_assert (se->ss->type == GFC_SS_FUNCTION);
          if (se->ss->useflags)
            {
              gcc_assert (gfc_return_by_reference (sym)
                      && sym->result->attr.dimension);
              gcc_assert (se->loop != NULL);

              /* Access the previously obtained result.  */
              gfc_conv_tmp_array_ref (se);
              gfc_advance_se_ss_chain (se);
              return 0;
            }
	}
      info = &se->ss->data.info;
    }
  else
    info = NULL;

  gfc_init_interface_mapping (&mapping);
  need_interface_mapping = ((sym->ts.type == BT_CHARACTER
				  && sym->ts.cl->length
				  && sym->ts.cl->length->expr_type
						!= EXPR_CONSTANT)
			      || sym->attr.dimension);
  formal = sym->formal;
  /* Evaluate the arguments.  */
  for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
    {
      if (arg->expr == NULL)
	{

	  if (se->ignore_optional)
	    {
	      /* Some intrinsics have already been resolved to the correct
	         parameters.  */
	      continue;
	    }
	  else if (arg->label)
	    {
              has_alternate_specifier = 1;
              continue;
	    }
	  else
	    {
	      /* Pass a NULL pointer for an absent arg.  */
	      gfc_init_se (&parmse, NULL);
	      parmse.expr = null_pointer_node;
              if (arg->missing_arg_type == BT_CHARACTER)
		parmse.string_length = convert (gfc_charlen_type_node,
						integer_zero_node);
	    }
	}
      else if (se->ss && se->ss->useflags)
	{
	  /* An elemental function inside a scalarized loop.  */
          gfc_init_se (&parmse, se);
          gfc_conv_expr_reference (&parmse, arg->expr);
	}
      else
	{
	  /* A scalar or transformational function.  */
	  gfc_init_se (&parmse, NULL);
	  argss = gfc_walk_expr (arg->expr);

	  if (argss == gfc_ss_terminator)
            {
	      gfc_conv_expr_reference (&parmse, arg->expr);
              if (formal && formal->sym->attr.pointer
		  && arg->expr->expr_type != EXPR_NULL)
                {
                  /* Scalar pointer dummy args require an extra level of
		  indirection. The null pointer already contains
		  this level of indirection.  */
                  parmse.expr = gfc_build_addr_expr (NULL, parmse.expr);
                }
            }
	  else
	    {
	      /* If the procedure requires an explicit interface, the
		 actual argument is passed according to the
		 corresponding formal argument.  If the corresponding
		 formal argument is a POINTER or assumed shape, we do
		 not use g77's calling convention, and pass the
		 address of the array descriptor instead. Otherwise we
		 use g77's calling convention.  */