8sa1-gcc/gcc/fortran/trans.c

/* Code translation -- generate GCC trees from gfc_code.
   Copyright (C) 2002, 2003, 2004, 2005 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 2, 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 COPYING.  If not, write to the Free
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.  */

#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tree.h"
#include "tree-gimple.h"
#include "ggc.h"
#include "toplev.h"
#include "defaults.h"
#include "real.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;


/* 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)
{
  return create_tmp_var_raw (type, prefix);
}


/* 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 an 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_expr (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_expr (stmtblock_t * pblock, tree lhs, tree rhs)
{
  tree tmp;

#ifdef ENABLE_CHECKING
  /* 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 (TREE_TYPE (rhs) == TREE_TYPE (lhs)
	      || 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 ();

  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)))
    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
    {
      if (DECL_P (t))
        TREE_ADDRESSABLE (t) = 1;
      t = build1 (ADDR_EXPR, natural_type, t);
    }

  if (type && natural_type != type)
    t = convert (type, t);

  return t;
}


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

tree
gfc_build_indirect_ref (tree t)
{
  tree type = TREE_TYPE (t);
  gcc_assert (POINTER_TYPE_P (type));
  type = TREE_TYPE (type);

  if (TREE_CODE (t) == ADDR_EXPR)
    return TREE_OPERAND (t, 0);
  else
    return build1 (INDIRECT_REF, type, t);
}


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

tree
gfc_build_array_ref (tree base, tree offset)
{
  tree type = TREE_TYPE (base);
  gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
  type = TREE_TYPE (type);

  if (DECL_P (base))
    TREE_ADDRESSABLE (base) = 1;

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


/* Given a function declaration FNDECL and an argument list ARGLIST,
   build a CALL_EXPR.  */

tree
gfc_build_function_call (tree fndecl, tree arglist)
{
  tree fn;
  tree call;

  fn = gfc_build_addr_expr (NULL, fndecl);
  call = build3 (CALL_EXPR, TREE_TYPE (TREE_TYPE (fndecl)), 
		 fn, arglist, NULL);
  TREE_SIDE_EFFECTS (call) = 1;

  return call;
}


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

void
gfc_trans_runtime_check (tree cond, tree msg, stmtblock_t * pblock)
{
  stmtblock_t block;
  tree body;
  tree tmp;
  tree args;

  cond = fold (cond);

  if (integer_zerop (cond))
    return;

  /* The code to generate the error.  */
  gfc_start_block (&block);

  gcc_assert (TREE_CODE (msg) == STRING_CST);

  TREE_USED (msg) = 1;

  tmp = gfc_build_addr_expr (pchar_type_node, msg);
  args = gfc_chainon_list (NULL_TREE, tmp);

  tmp = gfc_build_addr_expr (pchar_type_node, gfc_strconst_current_filename);
  args = gfc_chainon_list (args, tmp);

  tmp = build_int_cst (NULL_TREE, input_line);
  args = gfc_chainon_list (args, tmp);

  tmp = gfc_build_function_call (gfor_fndecl_runtime_error, args);
  gfc_add_expr_to_block (&block, tmp);

  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.  */
      tmp = gfc_chainon_list (NULL_TREE, cond);
      tmp = gfc_chainon_list (tmp, integer_zero_node);
      cond = gfc_build_function_call (built_in_decls[BUILT_IN_EXPECT], tmp);

      tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt ());
      gfc_add_expr_to_block (pblock, tmp);
    }
}


/* Add a statement to a block.  */

void
gfc_add_expr_to_block (stmtblock_t * block, tree expr)
{
  gcc_assert (block);

  if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
    return;

  if (TREE_CODE (expr) != STATEMENT_LIST)
    expr = fold (expr);

  if (block->head)
    {
      if (TREE_CODE (block->head) != STATEMENT_LIST)
	{
	  tree tmp;

	  tmp = block->head;
	  block->head = NULL_TREE;
	  append_to_statement_list (tmp, &block->head);
	}
      append_to_statement_list (expr, &block->head);
    }
  else
    /* Don't bother creating a list if we only have a single statement.  */
    block->head = expr;
}


/* Add a block the end of a block.  */

void
gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
{
  gcc_assert (append);
  gcc_assert (!append->has_scope);

  gfc_add_expr_to_block (block, append->head);
  append->head = NULL_TREE;
}


/* Get the current locus.  The structure may not be complete, and should
   only be used with gfc_set_backend_locus.  */

void
gfc_get_backend_locus (locus * loc)
{
  loc->lb = gfc_getmem (sizeof (gfc_linebuf));    
#ifdef USE_MAPPED_LOCATION
  loc->lb->location = input_location;
#else
  loc->lb->linenum = input_line;
#endif
  loc->lb->file = gfc_current_backend_file;
}


/* Set the current locus.  */

void
gfc_set_backend_locus (locus * loc)
{
  gfc_current_backend_file = loc->lb->file;
#ifdef USE_MAPPED_LOCATION
  input_location = loc->lb->location;
#else
  input_line = loc->lb->linenum;
  input_filename = loc->lb->file->filename;
#endif
}


/* Translate an executable statement.  */

tree
gfc_trans_code (gfc_code * code)
{
  stmtblock_t block;
  tree res;

  if (!code)
    return build_empty_stmt ();

  gfc_start_block (&block);

  /* Translate statements one by one to GIMPLE trees until we reach
     the end of this gfc_code branch.  */
  for (; code; code = code->next)
    {
      if (code->here != 0)
	{
	  res = gfc_trans_label_here (code);
	  gfc_add_expr_to_block (&block, res);
	}

      switch (code->op)
	{
	case EXEC_NOP:
	  res = NULL_TREE;
	  break;

	case EXEC_ASSIGN:
	  res = gfc_trans_assign (code);
	  break;

        case EXEC_LABEL_ASSIGN:
          res = gfc_trans_label_assign (code);
          break;

	case EXEC_POINTER_ASSIGN:
	  res = gfc_trans_pointer_assign (code);
	  break;

	case EXEC_CONTINUE:
	  res = NULL_TREE;
	  break;

	case EXEC_CYCLE:
	  res = gfc_trans_cycle (code);
	  break;

	case EXEC_EXIT:
	  res = gfc_trans_exit (code);
	  break;

	case EXEC_GOTO:
	  res = gfc_trans_goto (code);
	  break;

	case EXEC_ENTRY:
	  res = gfc_trans_entry (code);
	  break;

	case EXEC_PAUSE:
	  res = gfc_trans_pause (code);
	  break;

	case EXEC_STOP:
	  res = gfc_trans_stop (code);
	  break;

	case EXEC_CALL:
	  res = gfc_trans_call (code);
	  break;

	case EXEC_RETURN:
	  res = gfc_trans_return (code);
	  break;

	case EXEC_IF:
	  res = gfc_trans_if (code);
	  break;

	case EXEC_ARITHMETIC_IF:
	  res = gfc_trans_arithmetic_if (code);
	  break;

	case EXEC_DO:
	  res = gfc_trans_do (code);
	  break;

	case EXEC_DO_WHILE:
	  res = gfc_trans_do_while (code);
	  break;

	case EXEC_SELECT:
	  res = gfc_trans_select (code);
	  break;

	case EXEC_FLUSH:
	  res = gfc_trans_flush (code);
	  break;

	case EXEC_FORALL:
	  res = gfc_trans_forall (code);
	  break;

	case EXEC_WHERE:
	  res = gfc_trans_where (code);
	  break;

	case EXEC_ALLOCATE:
	  res = gfc_trans_allocate (code);
	  break;

	case EXEC_DEALLOCATE:
	  res = gfc_trans_deallocate (code);
	  break;

	case EXEC_OPEN:
	  res = gfc_trans_open (code);
	  break;

	case EXEC_CLOSE:
	  res = gfc_trans_close (code);
	  break;

	case EXEC_READ:
	  res = gfc_trans_read (code);
	  break;

	case EXEC_WRITE:
	  res = gfc_trans_write (code);
	  break;

	case EXEC_IOLENGTH:
	  res = gfc_trans_iolength (code);
	  break;

	case EXEC_BACKSPACE:
	  res = gfc_trans_backspace (code);
	  break;

	case EXEC_ENDFILE:
	  res = gfc_trans_endfile (code);
	  break;

	case EXEC_INQUIRE:
	  res = gfc_trans_inquire (code);
	  break;

	case EXEC_REWIND:
	  res = gfc_trans_rewind (code);
	  break;

	case EXEC_TRANSFER:
	  res = gfc_trans_transfer (code);
	  break;

	case EXEC_DT_END:
	  res = gfc_trans_dt_end (code);
	  break;

	default:
	  internal_error ("gfc_trans_code(): Bad statement code");
	}

      gfc_set_backend_locus (&code->loc);

      if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
	{
	  if (TREE_CODE (res) == STATEMENT_LIST)
	    annotate_all_with_locus (&res, input_location);
	  else
	    SET_EXPR_LOCATION (res, input_location);
	    
	  /* Add the new statement to the block.  */
	  gfc_add_expr_to_block (&block, res);
	}
    }

  /* Return the finished block.  */
  return gfc_finish_block (&block);
}


/* This function is called after a complete program unit has been parsed
   and resolved.  */

void
gfc_generate_code (gfc_namespace * ns)
{
  if (ns->is_block_data)
    {
      gfc_generate_block_data (ns);
      return;
    }

  /* Main program subroutine.  */
  if (!ns->proc_name)
    {
      gfc_symbol *main_program;
      symbol_attribute attr;

      /* Lots of things get upset if a subroutine doesn't have a symbol, so we
         make one now.  Hopefully we've set all the required fields.  */
      gfc_get_symbol ("MAIN__", ns, &main_program);
      gfc_clear_attr (&attr);
      attr.flavor = FL_PROCEDURE;
      attr.proc = PROC_UNKNOWN;
      attr.subroutine = 1;
      attr.access = ACCESS_PUBLIC;
      attr.is_main_program = 1;
      main_program->attr = attr;

      /* Set the location to the first line of code.  */
      if (ns->code)
	main_program->declared_at = ns->code->loc;
      ns->proc_name = main_program;
      gfc_commit_symbols ();
    }

  gfc_generate_function_code (ns);
}


/* This function is called after a complete module has been parsed
   and resolved.  */

void
gfc_generate_module_code (gfc_namespace * ns)
{
  gfc_namespace *n;

  gfc_generate_module_vars (ns);

  /* We need to generate all module function prototypes first, to allow
     sibling calls.  */
  for (n = ns->contained; n; n = n->sibling)
    {
      if (!n->proc_name)
        continue;

      gfc_create_function_decl (n);
    }

  for (n = ns->contained; n; n = n->sibling)
    {
      if (!n->proc_name)
        continue;

      gfc_generate_function_code (n);
    }
}