trans-expr.c

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

	      int f;
	      f = (formal != NULL)
		  && !formal->sym->attr.pointer
		  && formal->sym->as->type != AS_ASSUMED_SHAPE;
	      f = f || !sym->attr.always_explicit;
	      if (arg->expr->expr_type == EXPR_VARIABLE
		    && is_aliased_array (arg->expr))
		/* The actual argument is a component reference to an
		   array of derived types.  In this case, the argument
		   is converted to a temporary, which is passed and then
		   written back after the procedure call.  */
		gfc_conv_aliased_arg (&parmse, arg->expr, f);
	      else
	        gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
	    } 
	}

      if (formal && need_interface_mapping)
	gfc_add_interface_mapping (&mapping, formal->sym, &parmse);

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

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

      arglist = gfc_chainon_list (arglist, parmse.expr);
    }
  gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);

  ts = sym->ts;
  if (ts.type == BT_CHARACTER)
    {
      if (sym->ts.cl->length == NULL)
	{
	  /* Assumed character length results are not allowed by 5.1.1.5 of the
	     standard and are trapped in resolve.c; except in the case of SPREAD
	     (and other intrinsics?).  In this case, we take the character length
	     of the first argument for the result.  */
	  cl.backend_decl = TREE_VALUE (stringargs);
	}
      else
	{
	  /* Calculate the length of the returned string.  */
	  gfc_init_se (&parmse, NULL);
	  if (need_interface_mapping)
	    gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
	  else
	    gfc_conv_expr (&parmse, sym->ts.cl->length);
	  gfc_add_block_to_block (&se->pre, &parmse.pre);
	  gfc_add_block_to_block (&se->post, &parmse.post);
	  cl.backend_decl = fold_convert (gfc_charlen_type_node, parmse.expr);
	}

      /* Set up a charlen structure for it.  */
      cl.next = NULL;
      cl.length = NULL;
      ts.cl = &cl;

      len = cl.backend_decl;
    }

  byref = gfc_return_by_reference (sym);
  if (byref)
    {
      if (se->direct_byref)
	retargs = gfc_chainon_list (retargs, se->expr);
      else if (sym->result->attr.dimension)
	{
	  gcc_assert (se->loop && info);

	  /* Set the type of the array.  */
	  tmp = gfc_typenode_for_spec (&ts);
	  info->dimen = se->loop->dimen;

	  /* Evaluate the bounds of the result, if known.  */
	  gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);

	  /* Allocate a temporary to store the result.  In case the function
             returns a pointer, the temporary will be a shallow copy and
             mustn't be deallocated.  */
          gfc_trans_allocate_temp_array (&se->pre, &se->post, se->loop, info,
                                         tmp, false, !sym->attr.pointer);

	  /* Zero the first stride to indicate a temporary.  */
	  tmp = gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
	  gfc_add_modify_expr (&se->pre, tmp,
			       convert (TREE_TYPE (tmp), integer_zero_node));

	  /* Pass the temporary as the first argument.  */
	  tmp = info->descriptor;
	  tmp = gfc_build_addr_expr (NULL, tmp);
	  retargs = gfc_chainon_list (retargs, tmp);
	}
      else if (ts.type == BT_CHARACTER)
	{
	  /* Pass the string length.  */
	  type = gfc_get_character_type (ts.kind, ts.cl);
	  type = build_pointer_type (type);

	  /* Return an address to a char[0:len-1]* temporary for
	     character pointers.  */
	  if (sym->attr.pointer || sym->attr.allocatable)
	    {
	      /* Build char[0:len-1] * pstr.  */
	      tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
				 build_int_cst (gfc_charlen_type_node, 1));
	      tmp = build_range_type (gfc_array_index_type,
				      gfc_index_zero_node, tmp);
	      tmp = build_array_type (gfc_character1_type_node, tmp);
	      var = gfc_create_var (build_pointer_type (tmp), "pstr");

	      /* Provide an address expression for the function arguments.  */
	      var = gfc_build_addr_expr (NULL, var);
	    }
	  else
	    var = gfc_conv_string_tmp (se, type, len);

	  retargs = gfc_chainon_list (retargs, var);
	}
      else
	{
	  gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);

	  type = gfc_get_complex_type (ts.kind);
	  var = gfc_build_addr_expr (NULL, gfc_create_var (type, "cmplx"));
	  retargs = gfc_chainon_list (retargs, var);
	}

      /* Add the string length to the argument list.  */
      if (ts.type == BT_CHARACTER)
	retargs = gfc_chainon_list (retargs, len);
    }
  gfc_free_interface_mapping (&mapping);

  /* Add the return arguments.  */
  arglist = chainon (retargs, arglist);

  /* Add the hidden string length parameters to the arguments.  */
  arglist = chainon (arglist, stringargs);

  /* Generate the actual call.  */
  gfc_conv_function_val (se, sym);
  /* If there are alternate return labels, function type should be
     integer.  Can't modify the type in place though, since it can be shared
     with other functions.  */
  if (has_alternate_specifier
      && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
    {
      gcc_assert (! sym->attr.dummy);
      TREE_TYPE (sym->backend_decl)
        = build_function_type (integer_type_node,
                               TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
      se->expr = gfc_build_addr_expr (NULL, sym->backend_decl);
    }

  fntype = TREE_TYPE (TREE_TYPE (se->expr));
  se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr,
		     arglist, NULL_TREE);

  /* If we have a pointer function, but we don't want a pointer, e.g.
     something like
        x = f()
     where f is pointer valued, we have to dereference the result.  */
  if (!se->want_pointer && !byref && sym->attr.pointer)
    se->expr = gfc_build_indirect_ref (se->expr);

  /* f2c calling conventions require a scalar default real function to
     return a double precision result.  Convert this back to default
     real.  We only care about the cases that can happen in Fortran 77.
  */
  if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
      && sym->ts.kind == gfc_default_real_kind
      && !sym->attr.always_explicit)
    se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);

  /* A pure function may still have side-effects - it may modify its
     parameters.  */
  TREE_SIDE_EFFECTS (se->expr) = 1;
#if 0
  if (!sym->attr.pure)
    TREE_SIDE_EFFECTS (se->expr) = 1;
#endif

  if (byref)
    {
      /* Add the function call to the pre chain.  There is no expression.  */
      gfc_add_expr_to_block (&se->pre, se->expr);
      se->expr = NULL_TREE;

      if (!se->direct_byref)
	{
	  if (sym->attr.dimension)
	    {
	      if (flag_bounds_check)
		{
		  /* Check the data pointer hasn't been modified.  This would
		     happen in a function returning a pointer.  */
		  tmp = gfc_conv_descriptor_data_get (info->descriptor);
		  tmp = build2 (NE_EXPR, boolean_type_node, tmp, info->data);
		  gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
		}
	      se->expr = info->descriptor;
	      /* Bundle in the string length.  */
	      se->string_length = len;
	    }
	  else if (sym->ts.type == BT_CHARACTER)
	    {
	      /* Dereference for character pointer results.  */
	      if (sym->attr.pointer || sym->attr.allocatable)
		se->expr = gfc_build_indirect_ref (var);
	      else
	        se->expr = var;

	      se->string_length = len;
	    }
	  else
	    {
	      gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
	      se->expr = gfc_build_indirect_ref (var);
	    }
	}
    }

  return has_alternate_specifier;
}


/* Generate code to copy a string.  */

static void
gfc_trans_string_copy (stmtblock_t * block, tree dlen, tree dest,
		       tree slen, tree src)
{
  tree tmp;
  tree dsc;
  tree ssc;

  /* Deal with single character specially.  */
  dsc = gfc_to_single_character (dlen, dest);
  ssc = gfc_to_single_character (slen, src);
  if (dsc != NULL_TREE && ssc != NULL_TREE)
    {
      gfc_add_modify_expr (block, dsc, ssc);
      return;
    }

  tmp = NULL_TREE;
  tmp = gfc_chainon_list (tmp, dlen);
  tmp = gfc_chainon_list (tmp, dest);
  tmp = gfc_chainon_list (tmp, slen);
  tmp = gfc_chainon_list (tmp, src);
  tmp = gfc_build_function_call (gfor_fndecl_copy_string, tmp);
  gfc_add_expr_to_block (block, tmp);
}


/* Translate a statement function.
   The value of a statement function reference is obtained by evaluating the
   expression using the values of the actual arguments for the values of the
   corresponding dummy arguments.  */

static void
gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
{
  gfc_symbol *sym;
  gfc_symbol *fsym;
  gfc_formal_arglist *fargs;
  gfc_actual_arglist *args;
  gfc_se lse;
  gfc_se rse;
  gfc_saved_var *saved_vars;
  tree *temp_vars;
  tree type;
  tree tmp;
  int n;

  sym = expr->symtree->n.sym;
  args = expr->value.function.actual;
  gfc_init_se (&lse, NULL);
  gfc_init_se (&rse, NULL);

  n = 0;
  for (fargs = sym->formal; fargs; fargs = fargs->next)
    n++;
  saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
  temp_vars = (tree *)gfc_getmem (n * sizeof (tree));

  for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
    {
      /* Each dummy shall be specified, explicitly or implicitly, to be
         scalar.  */
      gcc_assert (fargs->sym->attr.dimension == 0);
      fsym = fargs->sym;

      /* Create a temporary to hold the value.  */
      type = gfc_typenode_for_spec (&fsym->ts);
      temp_vars[n] = gfc_create_var (type, fsym->name);

      if (fsym->ts.type == BT_CHARACTER)
        {
	  /* Copy string arguments.  */
          tree arglen;

          gcc_assert (fsym->ts.cl && fsym->ts.cl->length
                  && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);

          arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
          tmp = gfc_build_addr_expr (build_pointer_type (type),
				     temp_vars[n]);

          gfc_conv_expr (&rse, args->expr);
          gfc_conv_string_parameter (&rse);
          gfc_add_block_to_block (&se->pre, &lse.pre);
          gfc_add_block_to_block (&se->pre, &rse.pre);

	  gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
				 rse.expr);
          gfc_add_block_to_block (&se->pre, &lse.post);
          gfc_add_block_to_block (&se->pre, &rse.post);
        }
      else
        {
          /* For everything else, just evaluate the expression.  */
          gfc_conv_expr (&lse, args->expr);

          gfc_add_block_to_block (&se->pre, &lse.pre);
          gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
          gfc_add_block_to_block (&se->pre, &lse.post);
        }

      args = args->next;
    }

  /* Use the temporary variables in place of the real ones.  */
  for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
    gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);

  gfc_conv_expr (se, sym->value);

  if (sym->ts.type == BT_CHARACTER)
    {
      gfc_conv_const_charlen (sym->ts.cl);

      /* Force the expression to the correct length.  */
      if (!INTEGER_CST_P (se->string_length)
	  || tree_int_cst_lt (se->string_length,
			      sym->ts.cl->backend_decl))
	{
	  type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
	  tmp = gfc_create_var (type, sym->name);
	  tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
	  gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
				 se->string_length, se->expr);
	  se->expr = tmp;
	}
      se->string_length = sym->ts.cl->backend_decl;
    }

  /* Restore the original variables.  */
  for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
    gfc_restore_sym (fargs->sym, &saved_vars[n]);
  gfc_free (saved_vars);
}


/* Translate a function expression.  */

static void
gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
{
  gfc_symbol *sym;

  if (expr->value.function.isym)
    {
      gfc_conv_intrinsic_function (se, expr);
      return;
    }

  /* We distinguish statement functions from general functions to improve
     runtime performance.  */
  if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
    {
      gfc_conv_statement_function (se, expr);
      return;
    }

  /* expr.value.function.esym is the resolved (specific) function symbol for
     most functions.  However this isn't set for dummy procedures.  */
  sym = expr->value.function.esym;
  if (!sym)
    sym = expr->symtree->n.sym;
  gfc_conv_function_call (se, sym, expr->value.function.actual);
}


static void
gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
{
  gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
  gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);

  gfc_conv_tmp_array_ref (se);
  gfc_advance_se_ss_chain (se);
}


/* Build a static initializer.  EXPR is the expression for the initial value.
   The other parameters describe the variable of the component being 
   initialized. EXPR may be null.  */

tree
gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
		      bool array, bool pointer)
{
  gfc_se se;

  if (!(expr || pointer))
    return NULL_TREE;

  if (array)
    {
      /* Arrays need special handling.  */
      if (pointer)
	return gfc_build_null_descriptor (type);
      else
	return gfc_conv_array_initializer (type, expr);
    }
  else if (pointer)
    return fold_convert (type, null_pointer_node);
  else
    {
      switch (ts->type)
	{
	case BT_DERIVED:
	  gfc_init_se (&se, NULL);
	  gfc_conv_structure (&se, expr, 1);
	  return se.expr;

	case BT_CHARACTER:
	  return gfc_conv_string_init (ts->cl->backend_decl,expr);

	default:
	  gfc_init_se (&se, NULL);
	  gfc_conv_constant (&se, expr);
	  return se.expr;
	}
    }
}
  
static tree
gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
{
  gfc_se rse;
  gfc_se lse;
  gfc_ss *rss;
  gfc_ss *lss;
  stmtblock_t body;
  stmtblock_t block;
  gfc_loopinfo loop;
  int n;
  tree tmp;

  gfc_start_block (&b