Merge tree-ssa-20020619-branch into mainline.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@81764 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 662 insertions, 0 deletions

diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
new file mode 100644
index 00000000000..aed764d0a36
--- /dev/null
+++ b/gcc/fortran/trans.c
@@ -0,0 +1,662 @@
+/* Code translation -- generate GCC trees from gfc_code.
+   Copyright (C) 2002, 2003 Free Software Foundation, Inc.
+   Contributed by Paul Brook
+
+This file is part of GNU G95.
+
+GNU G95 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.
+
+GNU G95 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 GNU G95; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "tree.h"
+#include "tree-simple.h"
+#include <stdio.h>
+#include "ggc.h"
+#include "toplev.h"
+#include "defaults.h"
+#include "real.h"
+#include <gmp.h>
+#include <assert.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--)
+    {
+      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 (TREE_CODE_CLASS (TREE_CODE (expr)) == 'c')
+    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;
+
+  tmp = fold (build_v (MODIFY_EXPR, 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 expessions 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;
+
+  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 = rationalize_compound_expr (stmtblock->head);
+  stmtblock->head = NULL_TREE;
+
+  if (stmtblock->has_scope)
+    {
+      decl = getdecls ();
+
+      if (decl)
+	{
+	  block = poplevel (1, 0, 0);
+	  expr = build_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);
+  if (!POINTER_TYPE_P (type))
+    abort ();
+  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);
+  if (TREE_CODE (type) != ARRAY_TYPE)
+    abort ();
+  type = TREE_TYPE (type);
+
+  if (DECL_P (base))
+    TREE_ADDRESSABLE (base) = 1;
+
+  return build (ARRAY_REF, type, base, offset);
+}
+
+
+/* Given a funcion 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 = build (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);
+
+  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_2 (input_line, 0);
+  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 likley.  */
+      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 = build_v (COND_EXPR, cond, body, build_empty_stmt ());
+      gfc_add_expr_to_block (pblock, tmp);
+    }
+}
+
+
+/* Add a statement to a bock.  */
+
+void
+gfc_add_expr_to_block (stmtblock_t * block, tree expr)
+{
+  assert (block);
+
+  if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
+    return;
+
+  expr = fold (expr);
+  if (block->head)
+    block->head = build_v (COMPOUND_EXPR, block->head, expr);
+  else
+    block->head = expr;
+}
+
+
+/* Add a block the end of a block.  */
+
+void
+gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
+{
+  assert (append);
+  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_current_locus.  */
+
+void
+gfc_get_backend_locus (locus * loc)
+{
+  loc->line = input_line - 1;
+  loc->file = gfc_current_backend_file;
+}
+
+
+/* Set the current locus.  */
+
+void
+gfc_set_backend_locus (locus * loc)
+{
+  input_line = loc->line + 1;
+  gfc_current_backend_file = loc->file;
+  input_filename = loc->file->filename;
+}
+
+
+/* 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 SIMPLE trees until we reach
+     the end of this gfc_code branch.  */
+  for (; code; code = code->next)
+    {
+      gfc_set_backend_locus (&code->loc);
+
+      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_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_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");
+	}
+
+      if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
+	{
+	  annotate_with_locus (res, input_location);
+	  /* Add the new statemment 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)
+{
+  gfc_symbol *main_program = NULL;
+  symbol_attribute attr;
+
+  /* Main program subroutine.  */
+  if (!ns->proc_name)
+    {
+      /* 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;
+      main_program->attr = attr;
+      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_build_function_decl (n->proc_name);
+    }
+
+  for (n = ns->contained; n; n = n->sibling)
+    {
+      if (!n->proc_name)
+        continue;
+
+      gfc_generate_function_code (n);
+    }
+}
+