Subversion Repositories openrisc_me

/* Code translation -- generate GCC trees from gfc_code.

   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010

   Free Software Foundation, Inc.

   Contributed by Paul Brook

This file is part of GCC.

GCC is free software; you can redistribute it and/or modify it under

the terms of the GNU General Public License as published by the Free

Software Foundation; either version 3, or (at your option) any later

version.

GCC is distributed in the hope that it will be useful, but WITHOUT ANY

WARRANTY; without even the implied warranty of MERCHANTABILITY or

FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License

for more details.

You should have received a copy of the GNU General Public License

along with GCC; see the file COPYING3.  If not see

<http://www.gnu.org/licenses/>.  */

#include "config.h"

#include "system.h"

#include "coretypes.h"

#include "tree.h"

#include "gimple.h"

#include "tree-iterator.h"

#include "ggc.h"

#include "toplev.h"

#include "defaults.h"

#include "real.h"

#include "flags.h"

#include "gfortran.h"

#include "trans.h"

#include "trans-stmt.h"

#include "trans-array.h"

#include "trans-types.h"

#include "trans-const.h"

/* Naming convention for backend interface code:

   gfc_trans_*  translate gfc_code into STMT trees.

   gfc_conv_*   expression conversion

   gfc_get_*    get a backend tree representation of a decl or type  */

static gfc_file *gfc_current_backend_file;

const char gfc_msg_fault[] = N_("Array reference out of bounds");

const char gfc_msg_wrong_return[] = N_("Incorrect function return value");

/* Advance along TREE_CHAIN n times.  */

tree

gfc_advance_chain (tree t, int n)

{

  for (; n > 0; n--)

    {

      gcc_assert (t != NULL_TREE);

      t = TREE_CHAIN (t);

    }

  return t;

}

/* Wrap a node in a TREE_LIST node and add it to the end of a list.  */

tree

gfc_chainon_list (tree list, tree add)

{

  tree l;

  l = tree_cons (NULL_TREE, add, NULL_TREE);

  return chainon (list, l);

}

/* Strip off a legitimate source ending from the input

   string NAME of length LEN.  */

static inline void

remove_suffix (char *name, int len)

{

  int i;

  for (i = 2; i < 8 && len > i; i++)

    {

      if (name[len - i] == '.')

        {

          name[len - i] = '\0';

          break;

        }

    }

}

/* Creates a variable declaration with a given TYPE.  */

tree

gfc_create_var_np (tree type, const char *prefix)

{

  tree t;

  t = create_tmp_var_raw (type, prefix);

  /* No warnings for anonymous variables.  */

  if (prefix == NULL)

    TREE_NO_WARNING (t) = 1;

  return t;

}

/* Like above, but also adds it to the current scope.  */

tree

gfc_create_var (tree type, const char *prefix)

{

  tree tmp;

  tmp = gfc_create_var_np (type, prefix);

  pushdecl (tmp);

  return tmp;

}

/* If the expression is not constant, evaluate it now.  We assign the

   result of the expression to an artificially created variable VAR, and

   return a pointer to the VAR_DECL node for this variable.  */

tree

gfc_evaluate_now (tree expr, stmtblock_t * pblock)

{

  tree var;

  if (CONSTANT_CLASS_P (expr))

    return expr;

  var = gfc_create_var (TREE_TYPE (expr), NULL);

  gfc_add_modify (pblock, var, expr);

  return var;

}

/* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.

   A MODIFY_EXPR is an assignment:

   LHS <- RHS.  */

void

gfc_add_modify (stmtblock_t * pblock, tree lhs, tree rhs)

{

  tree tmp;

#ifdef ENABLE_CHECKING

  tree t1, t2;

  t1 = TREE_TYPE (rhs);

  t2 = TREE_TYPE (lhs);

  /* Make sure that the types of the rhs and the lhs are the same

     for scalar assignments.  We should probably have something

     similar for aggregates, but right now removing that check just

     breaks everything.  */

  gcc_assert (t1 == t2

              || AGGREGATE_TYPE_P (TREE_TYPE (lhs)));

#endif

  tmp = fold_build2 (MODIFY_EXPR, void_type_node, lhs, rhs);

  gfc_add_expr_to_block (pblock, tmp);

}

/* Create a new scope/binding level and initialize a block.  Care must be

   taken when translating expressions as any temporaries will be placed in

   the innermost scope.  */

void

gfc_start_block (stmtblock_t * block)

{

  /* Start a new binding level.  */

  pushlevel (0);

  block->has_scope = 1;

  /* The block is empty.  */

  block->head = NULL_TREE;

}

/* Initialize a block without creating a new scope.  */

void

gfc_init_block (stmtblock_t * block)

{

  block->head = NULL_TREE;

  block->has_scope = 0;

}

/* Sometimes we create a scope but it turns out that we don't actually

   need it.  This function merges the scope of BLOCK with its parent.

   Only variable decls will be merged, you still need to add the code.  */

void

gfc_merge_block_scope (stmtblock_t * block)

{

  tree decl;

  tree next;

  gcc_assert (block->has_scope);

  block->has_scope = 0;

  /* Remember the decls in this scope.  */

  decl = getdecls ();

  poplevel (0, 0, 0);

  /* Add them to the parent scope.  */

  while (decl != NULL_TREE)

    {

      next = TREE_CHAIN (decl);

      TREE_CHAIN (decl) = NULL_TREE;

      pushdecl (decl);

      decl = next;

    }

}

/* Finish a scope containing a block of statements.  */

tree

gfc_finish_block (stmtblock_t * stmtblock)

{

  tree decl;

  tree expr;

  tree block;

  expr = stmtblock->head;

  if (!expr)

    expr = build_empty_stmt (input_location);

  stmtblock->head = NULL_TREE;

  if (stmtblock->has_scope)

    {

      decl = getdecls ();

      if (decl)

        {

          block = poplevel (1, 0, 0);

          expr = build3_v (BIND_EXPR, decl, expr, block);

        }

      else

        poplevel (0, 0, 0);

    }

  return expr;

}

/* Build an ADDR_EXPR and cast the result to TYPE.  If TYPE is NULL, the

   natural type is used.  */

tree

gfc_build_addr_expr (tree type, tree t)

{

  tree base_type = TREE_TYPE (t);

  tree natural_type;

  if (type && POINTER_TYPE_P (type)

      && TREE_CODE (base_type) == ARRAY_TYPE

      && TYPE_MAIN_VARIANT (TREE_TYPE (type))

         == TYPE_MAIN_VARIANT (TREE_TYPE (base_type)))

    {

      tree min_val = size_zero_node;

      tree type_domain = TYPE_DOMAIN (base_type);

      if (type_domain && TYPE_MIN_VALUE (type_domain))

        min_val = TYPE_MIN_VALUE (type_domain);

      t = fold (build4 (ARRAY_REF, TREE_TYPE (type),

                        t, min_val, NULL_TREE, NULL_TREE));

      natural_type = type;

    }

  else

    natural_type = build_pointer_type (base_type);

  if (TREE_CODE (t) == INDIRECT_REF)

    {

      if (!type)

        type = natural_type;

      t = TREE_OPERAND (t, 0);

      natural_type = TREE_TYPE (t);

    }

  else

    {

      tree base = get_base_address (t);

      if (base && DECL_P (base))

        TREE_ADDRESSABLE (base) = 1;

      t = fold_build1 (ADDR_EXPR, natural_type, t);

    }

  if (type && natural_type != type)

    t = convert (type, t);

  return t;

}

/* Build an ARRAY_REF with its natural type.  */

tree

gfc_build_array_ref (tree base, tree offset, tree decl)

{

  tree type = TREE_TYPE (base);

  tree tmp;

  gcc_assert (TREE_CODE (type) == ARRAY_TYPE);

  type = TREE_TYPE (type);

  if (DECL_P (base))

    TREE_ADDRESSABLE (base) = 1;

  /* Strip NON_LVALUE_EXPR nodes.  */

  STRIP_TYPE_NOPS (offset);

  /* If the array reference is to a pointer, whose target contains a

     subreference, use the span that is stored with the backend decl

     and reference the element with pointer arithmetic.  */

  if (decl && (TREE_CODE (decl) == FIELD_DECL

                 || TREE_CODE (decl) == VAR_DECL

                 || TREE_CODE (decl) == PARM_DECL)

        && GFC_DECL_SUBREF_ARRAY_P (decl)

        && !integer_zerop (GFC_DECL_SPAN(decl)))

    {

      offset = fold_build2 (MULT_EXPR, gfc_array_index_type,

                            offset, GFC_DECL_SPAN(decl));

      tmp = gfc_build_addr_expr (pvoid_type_node, base);

      tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node,

                         tmp, fold_convert (sizetype, offset));

      tmp = fold_convert (build_pointer_type (type), tmp);

      if (!TYPE_STRING_FLAG (type))

        tmp = build_fold_indirect_ref_loc (input_location, tmp);

      return tmp;

    }

  else

    /* Otherwise use a straightforward array reference.  */

    return build4 (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);

}

/* Generate a call to print a runtime error possibly including multiple

   arguments and a locus.  */

tree

gfc_trans_runtime_error (bool error, locus* where, const char* msgid, ...)

{

  va_list ap;

  va_start (ap, msgid);

  return gfc_trans_runtime_error_vararg (error, where, msgid, ap);

}

tree

gfc_trans_runtime_error_vararg (bool error, locus* where, const char* msgid,

                                va_list ap)

{

  stmtblock_t block;

  tree tmp;

  tree arg, arg2;

  tree *argarray;

  tree fntype;

  char *message;

  const char *p;

  int line, nargs, i;

  /* Compute the number of extra arguments from the format string.  */

  for (p = msgid, nargs = 0; *p; p++)

    if (*p == '%')

      {

        p++;

        if (*p != '%')

          nargs++;

      }

  /* The code to generate the error.  */

  gfc_start_block (&block);

  if (where)

    {

      line = LOCATION_LINE (where->lb->location);

      asprintf (&message, "At line %d of file %s",  line,

                where->lb->file->filename);

    }

  else

    asprintf (&message, "In file '%s', around line %d",

              gfc_source_file, input_line + 1);

  arg = gfc_build_addr_expr (pchar_type_node,

                             gfc_build_localized_cstring_const (message));

  gfc_free(message);

  asprintf (&message, "%s", _(msgid));

  arg2 = gfc_build_addr_expr (pchar_type_node,

                              gfc_build_localized_cstring_const (message));

  gfc_free(message);

  /* Build the argument array.  */

  argarray = (tree *) alloca (sizeof (tree) * (nargs + 2));

  argarray[0] = arg;

  argarray[1] = arg2;

  for (i = 0; i < nargs; i++)

    argarray[2 + i] = va_arg (ap, tree);

  va_end (ap);

  /* Build the function call to runtime_(warning,error)_at; because of the

     variable number of arguments, we can't use build_call_expr_loc dinput_location,

     irectly.  */

  if (error)

    fntype = TREE_TYPE (gfor_fndecl_runtime_error_at);

  else

    fntype = TREE_TYPE (gfor_fndecl_runtime_warning_at);

  tmp = fold_builtin_call_array (input_location, TREE_TYPE (fntype),

                                 fold_build1 (ADDR_EXPR,

                                              build_pointer_type (fntype),

                                              error

                                              ? gfor_fndecl_runtime_error_at

                                              : gfor_fndecl_runtime_warning_at),

                                 nargs + 2, argarray);

  gfc_add_expr_to_block (&block, tmp);

  return gfc_finish_block (&block);

}

/* Generate a runtime error if COND is true.  */

void

gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,

                         locus * where, const char * msgid, ...)

{

  va_list ap;

  stmtblock_t block;

  tree body;

  tree tmp;

  tree tmpvar = NULL;

  if (integer_zerop (cond))

    return;

  if (once)

    {

       tmpvar = gfc_create_var (boolean_type_node, "print_warning");

       TREE_STATIC (tmpvar) = 1;

       DECL_INITIAL (tmpvar) = boolean_true_node;

       gfc_add_expr_to_block (pblock, tmpvar);

    }

  gfc_start_block (&block);

  /* The code to generate the error.  */

  va_start (ap, msgid);

  gfc_add_expr_to_block (&block,

                         gfc_trans_runtime_error_vararg (error, where,

                                                         msgid, ap));

  if (once)

    gfc_add_modify (&block, tmpvar, boolean_false_node);

  body = gfc_finish_block (&block);

  if (integer_onep (cond))

    {

      gfc_add_expr_to_block (pblock, body);

    }

  else

    {

      /* Tell the compiler that this isn't likely.  */

      if (once)

        cond = fold_build2 (TRUTH_AND_EXPR, long_integer_type_node, tmpvar,

                            cond);

      else

        cond = fold_convert (long_integer_type_node, cond);

      tmp = build_int_cst (long_integer_type_node, 0);

      cond = build_call_expr_loc (input_location,

                              built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);

      cond = fold_convert (boolean_type_node, cond);

      tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt (input_location));

      gfc_add_expr_to_block (pblock, tmp);

    }

}

/* Call malloc to allocate size bytes of memory, with special conditions:

      + if size <= 0, return a malloced area of size 1,

      + if malloc returns NULL, issue a runtime error.  */

tree

gfc_call_malloc (stmtblock_t * block, tree type, tree size)

{

  tree tmp, msg, malloc_result, null_result, res;

  stmtblock_t block2;

  size = gfc_evaluate_now (size, block);

  if (TREE_TYPE (size) != TREE_TYPE (size_type_node))

    size = fold_convert (size_type_node, size);

  /* Create a variable to hold the result.  */

  res = gfc_create_var (prvoid_type_node, NULL);

  /* Call malloc.  */

  gfc_start_block (&block2);

  size = fold_build2 (MAX_EXPR, size_type_node, size,

                      build_int_cst (size_type_node, 1));

  gfc_add_modify (&block2, res,

                  fold_convert (prvoid_type_node,

                                build_call_expr_loc (input_location,

                                   built_in_decls[BUILT_IN_MALLOC], 1, size)));

  /* Optionally check whether malloc was successful.  */

  if (gfc_option.rtcheck & GFC_RTCHECK_MEM)

    {

      null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,

                                 build_int_cst (pvoid_type_node, 0));

      msg = gfc_build_addr_expr (pchar_type_node,

              gfc_build_localized_cstring_const ("Memory allocation failed"));

      tmp = fold_build3 (COND_EXPR, void_type_node, null_result,

              build_call_expr_loc (input_location,

                                   gfor_fndecl_os_error, 1, msg),

                                   build_empty_stmt (input_location));

      gfc_add_expr_to_block (&block2, tmp);

    }

  malloc_result = gfc_finish_block (&block2);

  gfc_add_expr_to_block (block, malloc_result);

  if (type != NULL)

    res = fold_convert (type, res);

  return res;

}

/* Allocate memory, using an optional status argument.

   This function follows the following pseudo-code:

    void *

    allocate (size_t size, integer_type* stat)

    {

      void *newmem;

      if (stat)

        *stat = 0;

      // The only time this can happen is the size wraps around.

      if (size < 0)

      {

        if (stat)

        {

          *stat = LIBERROR_ALLOCATION;

          newmem = NULL;

        }

        else

          runtime_error ("Attempt to allocate negative amount of memory. "

                         "Possible integer overflow");

      }

      else

      {

        newmem = malloc (MAX (size, 1));

        if (newmem == NULL)

        {

          if (stat)

            *stat = LIBERROR_ALLOCATION;

          else

            runtime_error ("Out of memory");

        }

      }

      return newmem;

    }  */

tree

gfc_allocate_with_status (stmtblock_t * block, tree size, tree status)

{

  stmtblock_t alloc_block;

  tree res, tmp, error, msg, cond;

  tree status_type = status ? TREE_TYPE (TREE_TYPE (status)) : NULL_TREE;

  /* Evaluate size only once, and make sure it has the right type.  */

  size = gfc_evaluate_now (size, block);

  if (TREE_TYPE (size) != TREE_TYPE (size_type_node))

    size = fold_convert (size_type_node, size);

  /* Create a variable to hold the result.  */

  res = gfc_create_var (prvoid_type_node, NULL);

  /* Set the optional status variable to zero.  */

  if (status != NULL_TREE && !integer_zerop (status))

    {

      tmp = fold_build2 (MODIFY_EXPR, status_type,

                         fold_build1 (INDIRECT_REF, status_type, status),

                         build_int_cst (status_type, 0));

      tmp = fold_build3 (COND_EXPR, void_type_node,

                         fold_build2 (NE_EXPR, boolean_type_node, status,

                                      build_int_cst (TREE_TYPE (status), 0)),

                         tmp, build_empty_stmt (input_location));

      gfc_add_expr_to_block (block, tmp);

    }

  /* Generate the block of code handling (size < 0).  */

  msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const

                        ("Attempt to allocate negative amount of memory. "

                         "Possible integer overflow"));

  error = build_call_expr_loc (input_location,

                           gfor_fndecl_runtime_error, 1, msg);

  if (status != NULL_TREE && !integer_zerop (status))

    {

      /* Set the status variable if it's present.  */

      stmtblock_t set_status_block;

      gfc_start_block (&set_status_block);

      gfc_add_modify (&set_status_block,

                      fold_build1 (INDIRECT_REF, status_type, status),

                           build_int_cst (status_type, LIBERROR_ALLOCATION));

      gfc_add_modify (&set_status_block, res,

                           build_int_cst (prvoid_type_node, 0));

      tmp = fold_build2 (EQ_EXPR, boolean_type_node, status,

                         build_int_cst (TREE_TYPE (status), 0));

      error = fold_build3 (COND_EXPR, void_type_node, tmp, error,

                           gfc_finish_block (&set_status_block));

    }

  /* The allocation itself.  */

  gfc_start_block (&alloc_block);

  gfc_add_modify (&alloc_block, res,

                  fold_convert (prvoid_type_node,

                                build_call_expr_loc (input_location,

                                   built_in_decls[BUILT_IN_MALLOC], 1,

                                        fold_build2 (MAX_EXPR, size_type_node,

                                                     size,

                                                     build_int_cst (size_type_node, 1)))));

  msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const

                                                ("Out of memory"));

  tmp = build_call_expr_loc (input_location,

                         gfor_fndecl_os_error, 1, msg);

  if (status != NULL_TREE && !integer_zerop (status))

    {

      /* Set the status variable if it's present.  */

      tree tmp2;

      cond = fold_build2 (EQ_EXPR, boolean_type_node, status,

                          build_int_cst (TREE_TYPE (status), 0));

      tmp2 = fold_build2 (MODIFY_EXPR, status_type,

                          fold_build1 (INDIRECT_REF, status_type, status),

                          build_int_cst (status_type, LIBERROR_ALLOCATION));

      tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,

                         tmp2);

    }

  tmp = fold_build3 (COND_EXPR, void_type_node,

                     fold_build2 (EQ_EXPR, boolean_type_node, res,

                                  build_int_cst (prvoid_type_node, 0)),

                     tmp, build_empty_stmt (input_location));

  gfc_add_expr_to_block (&alloc_block, tmp);

  cond = fold_build2 (LT_EXPR, boolean_type_node, size,

                      build_int_cst (TREE_TYPE (size), 0));

  tmp = fold_build3 (COND_EXPR, void_type_node, cond, error,

                     gfc_finish_block (&alloc_block));

  gfc_add_expr_to_block (block, tmp);

  return res;

}

/* Generate code for an ALLOCATE statement when the argument is an

   allocatable array.  If the array is currently allocated, it is an

   error to allocate it again.

   This function follows the following pseudo-code:

    void *

    allocate_array (void *mem, size_t size, integer_type *stat)

    {

      if (mem == NULL)

        return allocate (size, stat);

      else

      {

        if (stat)

        {

          free (mem);

          mem = allocate (size, stat);

          *stat = LIBERROR_ALLOCATION;

          return mem;

        }

        else

          runtime_error ("Attempting to allocate already allocated array");

      }

    }

    expr must be set to the original expression being allocated for its locus

    and variable name in case a runtime error has to be printed.  */

tree

gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size,

                                tree status, gfc_expr* expr)

{

  stmtblock_t alloc_block;

  tree res, tmp, null_mem, alloc, error;

  tree type = TREE_TYPE (mem);