path: root/ortho/gcc/ortho-lang.c

#include <stddef.h>
#include <math.h>
#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tm.h"
#include "tree.h"
#include "tm_p.h"
#include "defaults.h"
#include "ggc.h"
#include "diagnostic.h"
#include "langhooks.h"
#include "langhooks-def.h"
#include "toplev.h"
#include "opts.h"
#include "options.h"
#include "real.h"
#include "tree-iterator.h"
#include "function.h"
#include "cgraph.h"
#include "target.h"
#include "convert.h"
#include "tree-pass.h"
#include "tree-dump.h"

// temp for debugging 
#include "stdio.h"

/* TODO:
 * remove stmt_list_stack, save in if/case/loop block
 * Re-add -v (if necessary)
 */

static tree type_for_size (unsigned int precision, int unsignedp);

const int tree_identifier_size = sizeof (struct tree_identifier);

struct GTY(()) binding_level
{
  /*  The BIND_EXPR node for this binding.  */
  tree bind;

  /*  The BLOCK node for this binding.  */
  tree block;

  /*  If true, stack must be saved (alloca is used).  */
  int save_stack;

  /*  Parent binding level.  */
  struct binding_level *prev;

  /*  Decls in this binding.  */
  tree first_decl;
  tree last_decl;

  /*  Blocks in this binding.  */
  tree first_block;
  tree last_block;
};

/*  The current binding level.  */
static GTY(()) struct binding_level *cur_binding_level = NULL;

/*  Chain of unused binding levels.  */
static GTY(()) struct binding_level *old_binding_levels = NULL;

/*  Chain of statements currently generated.  */
static GTY(()) tree cur_stmts = NULL_TREE;

static void
push_binding (void)
{
  struct binding_level *res;

  if (old_binding_levels == NULL)
    res = ggc_alloc_binding_level ();
  else
    {
      res = old_binding_levels;
      old_binding_levels = res->prev;
    }

  /* Init.  */
  res->first_decl = NULL_TREE;
  res->last_decl = NULL_TREE;

  res->first_block = NULL_TREE;
  res->last_block = NULL_TREE;

  res->save_stack = 0;

  res->bind = make_node (BIND_EXPR);
  res->block = make_node (BLOCK);
  BIND_EXPR_BLOCK (res->bind) = res->block;
  TREE_SIDE_EFFECTS (res->bind) = true;
  TREE_TYPE (res->bind) = void_type_node;
  TREE_USED (res->block) = true;

  if (cur_binding_level != NULL)
    {
      /* Append the block created.  */
      if (cur_binding_level->first_block == NULL)
	cur_binding_level->first_block = res->block;
      else
	BLOCK_CHAIN (cur_binding_level->last_block) = res->block;
      cur_binding_level->last_block = res->block;

      BLOCK_SUPERCONTEXT (res->block) = cur_binding_level->block;
    }

  res->prev = cur_binding_level;
  cur_binding_level = res;
}

static void
push_decl (tree decl)
{
  DECL_CONTEXT (decl) = current_function_decl;

  if (cur_binding_level->first_decl == NULL)
    cur_binding_level->first_decl = decl;
  else
    TREE_CHAIN (cur_binding_level->last_decl) = decl;
  cur_binding_level->last_decl = decl;
}

static tree
pop_binding (void)
{
  tree res;
  struct binding_level *cur;

  cur = cur_binding_level;
  res = cur->bind;

  if (cur->save_stack)
    {
      tree tmp_var;
      tree save;
      tree save_call;
      tree restore;
      tree t;

      /* Create an artificial var to save the stack pointer.  */
      tmp_var = build_decl (input_location, VAR_DECL, NULL, ptr_type_node);
      DECL_ARTIFICIAL (tmp_var) = true;
      DECL_IGNORED_P (tmp_var) = true;
      TREE_USED (tmp_var) = true;
      push_decl (tmp_var);

      /* Create the save stmt.  */
      save_call = build_call_expr
	(builtin_decl_implicit (BUILT_IN_STACK_SAVE), 0);
      save = build2 (MODIFY_EXPR, ptr_type_node, tmp_var, save_call);
      TREE_SIDE_EFFECTS (save) = true;

      /* Create the restore stmt.  */
      restore = build_call_expr
	(builtin_decl_implicit (BUILT_IN_STACK_RESTORE), 1, tmp_var);

      /* Build a try-finally block.
	 The statement list is the block of current statements.  */
      t = build2 (TRY_FINALLY_EXPR, void_type_node, cur_stmts, NULL_TREE);
      TREE_SIDE_EFFECTS (t) = true;

      /* The finally block is the restore stmt.  */
      append_to_statement_list (restore, &TREE_OPERAND (t, 1));

      /* The body of the BIND_BLOCK is the save stmt, followed by the
	 try block.  */
      BIND_EXPR_BODY (res) = NULL_TREE;
      append_to_statement_list (save, &BIND_EXPR_BODY (res));
      append_to_statement_list (t, &BIND_EXPR_BODY (res));
    }
  else
    {
      /* The body of the BIND_BLOCK is the statement block.  */
      BIND_EXPR_BODY (res) = cur_stmts;
    }
  BIND_EXPR_VARS (res) = cur->first_decl;

  BLOCK_SUBBLOCKS (cur->block) = cur->first_block;
  BLOCK_VARS (cur->block) = cur->first_decl;

  cur_binding_level = cur->prev;
  cur->prev = old_binding_levels;
  old_binding_levels = cur;

  return res;
}

/* This is a stack of current statement_lists  */
//static GTY(()) VEC_tree_gc * stmt_list_stack;

// naive conversion to new vec API following the wiki at
// http://gcc.gnu.org/wiki/cxx-conversion/cxx-vec
// see also push_stmts, pop_stmts
static vec <tree> stmt_list_stack = vec<tree>();

static void
push_stmts (tree stmts)
{
//  VEC_safe_push (tree, gc, stmt_list_stack, cur_stmts);
  stmt_list_stack.safe_push(cur_stmts);
  cur_stmts = stmts;
}
 
static void
pop_stmts (void)
{
//  cur_stmts = VEC_pop (tree, stmt_list_stack);
cur_stmts = stmt_list_stack.pop();
}

static void
append_stmt (tree stmt)
{
  if (!EXPR_HAS_LOCATION (stmt))
    SET_EXPR_LOCATION (stmt, input_location);
  TREE_SIDE_EFFECTS (stmt) = true;
  append_to_statement_list (stmt, &cur_stmts);
}

static GTY(()) tree top;

static GTY(()) tree stack_alloc_function_ptr;
extern "C" void ortho_fe_init (void);

static bool
global_bindings_p (void)
{
  return cur_binding_level->prev == NULL;
}

static tree
pushdecl (tree t)
{
  //gcc_unreachable ();
  // gcc4.8.2 we get here from build_common_builtin_nodes () call in ortho_init
  return t;
}

static tree
builtin_function (const char *name,
		  tree type,
		  int function_code,
		  enum built_in_class decl_class,
		  const char *library_name,
		  tree attrs ATTRIBUTE_UNUSED);

REAL_VALUE_TYPE fp_const_p5; /* 0.5 */
REAL_VALUE_TYPE fp_const_m_p5; /* -0.5 */
REAL_VALUE_TYPE fp_const_zero; /* 0.0 */

static bool
ortho_init (void)
{
  tree n;

  input_location = BUILTINS_LOCATION;

  /* Create a global binding.  */
  push_binding ();

  build_common_tree_nodes (0, 0);

  n = build_decl (input_location,
                  TYPE_DECL, get_identifier ("int"), integer_type_node);
  push_decl (n);
  n = build_decl (input_location,
                  TYPE_DECL, get_identifier ("char"), char_type_node);
  push_decl (n);

  /* Create alloca builtin.  */
  {
    tree args_type = tree_cons (NULL_TREE, size_type_node, void_list_node);
    tree func_type = build_function_type (ptr_type_node, args_type);
       
    set_builtin_decl
      (BUILT_IN_ALLOCA,
       builtin_function
       ("__builtin_alloca", func_type,
	BUILT_IN_ALLOCA, BUILT_IN_NORMAL, NULL, NULL_TREE), true);
    
    stack_alloc_function_ptr = build1
      (ADDR_EXPR, 
       build_pointer_type (func_type),
       builtin_decl_implicit (BUILT_IN_ALLOCA));
  }

  {
    tree ptr_ftype = build_function_type (ptr_type_node, NULL_TREE);

    set_builtin_decl
      (BUILT_IN_STACK_SAVE,
       builtin_function
       ("__builtin_stack_save", ptr_ftype,
	BUILT_IN_STACK_SAVE, BUILT_IN_NORMAL, NULL, NULL_TREE), true);
  }

  {
    tree ftype_ptr;

    ftype_ptr = build_function_type
      (void_type_node,
       tree_cons (NULL_TREE, ptr_type_node, NULL_TREE));

    set_builtin_decl
      (BUILT_IN_STACK_RESTORE,
       builtin_function
       ("__builtin_stack_restore", ftype_ptr,
	BUILT_IN_STACK_RESTORE, BUILT_IN_NORMAL, NULL, NULL_TREE), true);
  }
  {
    REAL_VALUE_TYPE v;
    
    REAL_VALUE_FROM_INT (v, 1, 0, DFmode);
    real_ldexp (&fp_const_p5, &v, -1);
    
    REAL_VALUE_FROM_INT (v, -1, -1, DFmode);
    real_ldexp (&fp_const_m_p5, &v, -1);
    
    REAL_VALUE_FROM_INT (fp_const_zero, 0, 0, DFmode);
  }

  ortho_fe_init ();

  build_common_builtin_nodes ();
  // FIXME: this MAY remove the need for creating the builtins above...
  // Evaluate tree.c / build_common_builtin_nodes (); for each in turn.

  return true;
}

static void
ortho_finish (void)
{
}

static unsigned int
ortho_option_lang_mask (void)
{
  return CL_vhdl;
}

static bool
ortho_post_options (const char **pfilename)
{
  if (*pfilename == NULL || strcmp (*pfilename, "-") == 0)
    *pfilename = "*stdin*";

  /* Default hook.  */
  lhd_post_options (pfilename);

  // This stops compile failures writing debug information when both -g and -O2 
  // (or -O1, -O3 or -Os) options are present.
  // Should really make it conditional on specific options
  // FIXME : re-evaluate if this is still necessary with newer gccrevisions
  dwarf_strict = 1;

  /* Run the back-end.  */
  return false;
}

extern "C" bool lang_handle_option (const char *opt, const char *arg);

static bool
ortho_handle_option (size_t code, const char *arg, int value, int kind,
                     location_t loc,
                     const struct cl_option_handlers *handlers)
{
  const char *opt;

  opt = cl_options[code].opt_text;

  switch (code)
    {
    case OPT__elab:
    case OPT_l:
    case OPT_c:
    case OPT__anaelab:
      /* Only a few options have a real arguments.  */
      return lang_handle_option (opt, arg);
    default:
      /* The other options must have a joint argument.  */
      if (arg != NULL)
	{
	  size_t len1;
	  size_t len2;
	  char *nopt;
	  
	  len1 = strlen (opt);
	  len2 = strlen (arg);
	  nopt = (char *) alloca (len1 + len2 + 1);
	  memcpy (nopt, opt, len1);
	  memcpy (nopt + len1, arg, len2);
	  nopt[len1 + len2] = 0;
	  opt = nopt;
	}
      return lang_handle_option (opt, NULL);
    }
}

extern "C" int lang_parse_file (const char *filename);

static void
ortho_parse_file (void)
{
  const char *filename;

  if (num_in_fnames == 0)
    filename = NULL;
  else
    filename = in_fnames[0];

  linemap_add (line_table, LC_ENTER, 0, filename ? filename :"*no-file*", 1);
  input_location = linemap_line_start (line_table, 1, 252);

  if (!lang_parse_file (filename))
    errorcount++;
  linemap_add (line_table, LC_LEAVE, 0, NULL, 1);
}

/*  Called by the back-end or by the front-end when the address of EXP
    must be taken.
    This function should found the base object (if any), and mark it as
    addressable (via TREE_ADDRESSABLE).  It may emit a warning if this
    object cannot be addressable (front-end restriction).
    Returns TRUE in case of success, FALSE in case of failure.
    Note that the status is never checked by the back-end.  */
static bool
ortho_mark_addressable (tree exp)
{
  tree n;

  n = exp;

  while (1)
    switch (TREE_CODE (n))
      {
      case VAR_DECL:
      case CONST_DECL:
      case PARM_DECL:
      case RESULT_DECL:
	TREE_ADDRESSABLE (n) = true;
	return true;

      case COMPONENT_REF:
      case ARRAY_REF:
      case ARRAY_RANGE_REF:
	n = TREE_OPERAND (n, 0);
	break;

      case FUNCTION_DECL:
      case CONSTRUCTOR:
	TREE_ADDRESSABLE (n) = true;
	return true;

      case INDIRECT_REF:
	return true;

      default:
	gcc_unreachable ();
      }
}

static tree
ortho_truthvalue_conversion (tree expr)
{
  tree expr_type;
  tree t;
  tree f;

  expr_type = TREE_TYPE (expr);
  if (TREE_CODE (expr_type) != BOOLEAN_TYPE)
    {
      t = integer_one_node;
      f = integer_zero_node;
    }
  else
    {
      f = TYPE_MIN_VALUE (expr_type);
      t = TYPE_MAX_VALUE (expr_type);
    }


  switch (TREE_CODE (expr))
    {
    case EQ_EXPR:
    case NE_EXPR:
    case LE_EXPR:
    case GE_EXPR:
    case LT_EXPR:
    case GT_EXPR:
    case TRUTH_ANDIF_EXPR:
    case TRUTH_ORIF_EXPR:
    case TRUTH_AND_EXPR:
    case TRUTH_OR_EXPR:
    case ERROR_MARK:
      return expr;

    case INTEGER_CST:
      /* Not 0 is true.  */
      return integer_zerop (expr) ? f : t;

    case REAL_CST:
      return real_zerop (expr) ? f : t;

    default:
      gcc_unreachable ();
    }
}

/* The following function has been copied and modified from c-convert.c.  */

/* Change of width--truncation and extension of integers or reals--
   is represented with NOP_EXPR.  Proper functioning of many things
   assumes that no other conversions can be NOP_EXPRs.

   Conversion between integer and pointer is represented with CONVERT_EXPR.
   Converting integer to real uses FLOAT_EXPR
   and real to integer uses FIX_TRUNC_EXPR.

   Here is a list of all the functions that assume that widening and
   narrowing is always done with a NOP_EXPR:
     In convert.c, convert_to_integer.
     In c-typeck.c, build_binary_op (boolean ops), and
	c_common_truthvalue_conversion.
     In expr.c: expand_expr, for operands of a MULT_EXPR.
     In fold-const.c: fold.
     In tree.c: get_narrower and get_unwidened.  */

/* Subroutines of `convert'.  */



/* Create an expression whose value is that of EXPR,
   converted to type TYPE.  The TREE_TYPE of the value
   is always TYPE.  This function implements all reasonable
   conversions; callers should filter out those that are
   not permitted by the language being compiled.  */

tree
convert (tree type, tree expr)
{
  tree e = expr;
  enum tree_code code = TREE_CODE (type);
  const char *invalid_conv_diag;

  if (type == error_mark_node
      || expr == error_mark_node
      || TREE_TYPE (expr) == error_mark_node)
    return error_mark_node;

  if ((invalid_conv_diag
       = targetm.invalid_conversion (TREE_TYPE (expr), type)))
    {
      error (invalid_conv_diag);
      return error_mark_node;
    }

  if (type == TREE_TYPE (expr))
    return expr;

  if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (expr)))
    return fold_build1 (NOP_EXPR, type, expr);
  if (TREE_CODE (TREE_TYPE (expr)) == ERROR_MARK)
    return error_mark_node;
  if (TREE_CODE (TREE_TYPE (expr)) == VOID_TYPE || code == VOID_TYPE)
    {
      gcc_unreachable ();
    }
  if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
    return fold (convert_to_integer (type, e));
  if (code == BOOLEAN_TYPE)
    {
      tree t = ortho_truthvalue_conversion (expr);
      if (TREE_CODE (t) == ERROR_MARK)
	return t;

      /* If it returns a NOP_EXPR, we must fold it here to avoid
	 infinite recursion between fold () and convert ().  */
      if (TREE_CODE (t) == NOP_EXPR)
	return fold_build1 (NOP_EXPR, type, TREE_OPERAND (t, 0));
      else
	return fold_build1 (NOP_EXPR, type, t);
    }
  if (code == POINTER_TYPE || code == REFERENCE_TYPE)
    return fold (convert_to_pointer (type, e));
  if (code == REAL_TYPE)
    return fold (convert_to_real (type, e));

  gcc_unreachable ();
}

/* Return a definition for a builtin function named NAME and whose data type
   is TYPE.  TYPE should be a function type with argument types.
   FUNCTION_CODE tells later passes how to compile calls to this function.
   See tree.h for its possible values.

   If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
   the name to be called if we can't opencode the function.  If
   ATTRS is nonzero, use that for the function's attribute list.  */
static tree
builtin_function (const char *name,
		  tree type,
		  int function_code,
		  enum built_in_class decl_class,
		  const char *library_name,
		  tree attrs ATTRIBUTE_UNUSED)
{
  tree decl = build_decl (input_location,
                          FUNCTION_DECL, get_identifier (name), type);
  DECL_EXTERNAL (decl) = 1;
  TREE_PUBLIC (decl) = 1;
  if (library_name)
    SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
  make_decl_rtl (decl);
  DECL_BUILT_IN_CLASS (decl) = decl_class;
  DECL_FUNCTION_CODE (decl) = (built_in_function) function_code;
  DECL_SOURCE_LOCATION (decl) = input_location;
  return decl;
}

#ifndef MAX_BITS_PER_WORD
#define MAX_BITS_PER_WORD BITS_PER_WORD
#endif

/*  This variable keeps a table for types for each precision so that we only
    allocate each of them once. Signed and unsigned types are kept separate. 
 */
static GTY(()) tree signed_and_unsigned_types[MAX_BITS_PER_WORD + 1][2];

/*  Return an integer type with the number of bits of precision given by
    PRECISION.  UNSIGNEDP is nonzero if the type is unsigned; otherwise
    it is a signed type.  */
static tree
type_for_size (unsigned int precision, int unsignedp)
{
  tree t;

  if (precision <= MAX_BITS_PER_WORD
      && signed_and_unsigned_types[precision][unsignedp] != NULL_TREE)
    return signed_and_unsigned_types[precision][unsignedp];

  if (unsignedp)
    t = make_unsigned_type (precision);
  else
    t = make_signed_type (precision);

  if (precision <= MAX_BITS_PER_WORD)
    signed_and_unsigned_types[precision][unsignedp] = t;
  else
    // Handle larger requests by returning a NULL tree and letting
    // the back end default to another approach.
    // the exact test is unknown : distinguishing between 32 and 64 bits
    // may be enough for all likely platforms
    if (MAX_BITS_PER_WORD >= 64)
      t = NULL_TREE;

  return t;
}

/*  Return a data type that has machine mode MODE.  UNSIGNEDP selects
    an unsigned type; otherwise a signed type is returned.  */
static tree
type_for_mode (enum machine_mode mode, int unsignedp)
{
  return type_for_size (GET_MODE_BITSIZE (mode), unsignedp);
}

#undef LANG_HOOKS_NAME
#define LANG_HOOKS_NAME "vhdl"
#undef LANG_HOOKS_IDENTIFIER_SIZE
#define LANG_HOOKS_IDENTIFIER_SIZE sizeof (struct tree_identifier)
#undef LANG_HOOKS_INIT
#define LANG_HOOKS_INIT ortho_init
#undef LANG_HOOKS_FINISH
#define LANG_HOOKS_FINISH ortho_finish
#undef LANG_HOOKS_OPTION_LANG_MASK
#define LANG_HOOKS_OPTION_LANG_MASK ortho_option_lang_mask
#undef LANG_HOOKS_HANDLE_OPTION
#define LANG_HOOKS_HANDLE_OPTION ortho_handle_option
#undef LANG_HOOKS_POST_OPTIONS
#define LANG_HOOKS_POST_OPTIONS ortho_post_options
#undef LANG_HOOKS_HONOR_READONLY
#define LANG_HOOKS_HONOR_READONLY true
#undef LANG_HOOKS_MARK_ADDRESSABLE
#define LANG_HOOKS_MARK_ADDRESSABLE ortho_mark_addressable
#undef LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION
#define LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION ortho_expand_function

#undef LANG_HOOKS_TYPE_FOR_MODE
#define LANG_HOOKS_TYPE_FOR_MODE type_for_mode
#undef LANG_HOOKS_TYPE_FOR_SIZE
#define LANG_HOOKS_TYPE_FOR_SIZE type_for_size
#undef LANG_HOOKS_SIGNED_TYPE
#define LANG_HOOKS_SIGNED_TYPE signed_type
#undef LANG_HOOKS_UNSIGNED_TYPE
#define LANG_HOOKS_UNSIGNED_TYPE unsigned_type
#undef LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE
#define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE signed_or_unsigned_type
#undef LANG_HOOKS_PARSE_FILE
#define LANG_HOOKS_PARSE_FILE ortho_parse_file

#define pushlevel lhd_do_nothing_i
#define poplevel lhd_do_nothing_iii_return_null_tree
#define set_block lhd_do_nothing_t
#undef LANG_HOOKS_GETDECLS
#define LANG_HOOKS_GETDECLS lhd_return_null_tree_v

struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;

union GTY((desc ("0"),
	   chain_next ("CODE_CONTAINS_STRUCT (TREE_CODE (&%h.generic), TS_COMMON) ? ((union lang_tree_node *) TREE_CHAIN (&%h.generic)) : NULL")))
  lang_tree_node
{
  union tree_node GTY((tag ("0"),
		       desc ("tree_node_structure (&%h)"))) generic;
};

/* GHDL does not use the lang_decl and lang_type.

   FIXME: the variable_size annotation here is needed because these types are
   variable-sized in some other front-ends.  Due to gengtype deficiency, the
   GTY options of such types have to agree across all front-ends.  */

struct GTY((variable_size)) lang_type { char dummy; };
struct GTY((variable_size)) lang_decl { char dummy; };

struct GTY(()) language_function
{
  char dummy;
};


extern "C" {


struct GTY(()) chain_constr_type
{
  tree first;
  tree last;
};

static void
chain_init (struct chain_constr_type *constr)
{
  constr->first = NULL_TREE;
  constr->last = NULL_TREE;
}

static void
chain_append (struct chain_constr_type *constr, tree el)
{
  if (constr->first == NULL_TREE)
    {
      gcc_assert (constr->last == NULL_TREE);
      constr->first = el;
    }
  else
    TREE_CHAIN (constr->last) = el;
  constr->last = el;
}

struct GTY(()) list_constr_type
{
  tree first;
  tree last;
};

static void
list_init (struct list_constr_type *constr)
{
  constr->first = NULL_TREE;
  constr->last = NULL_TREE;
}

static void
ortho_list_append (struct list_constr_type *constr, tree el)
{
  tree res;

  res = tree_cons (NULL_TREE, el, NULL_TREE);
  if (constr->first == NULL_TREE)
    constr->first = res;
  else
    TREE_CHAIN (constr->last) = res;
  constr->last = res;
}

enum ON_op_kind {
  /*  Not an operation; invalid.  */
  ON_Nil,

  /*  Dyadic operations.  */
  ON_Add_Ov,
  ON_Sub_Ov,
  ON_Mul_Ov,
  ON_Div_Ov,
  ON_Rem_Ov,
  ON_Mod_Ov,

  /*  Binary operations.  */
  ON_And,
  ON_Or, 
  ON_Xor,
  ON_And_Then,
  ON_Or_Else,

  /*  Monadic operations.  */
  ON_Not,
  ON_Neg_Ov,
  ON_Abs_Ov,

  /*  Comparaisons  */
  ON_Eq,
  ON_Neq,
  ON_Le,
  ON_Lt,
  ON_Ge,
  ON_Gt,

  ON_LAST
};


static enum tree_code ON_op_to_TREE_CODE[ON_LAST] = {
  ERROR_MARK,

  PLUS_EXPR,
  MINUS_EXPR,
  MULT_EXPR,
  ERROR_MARK,
  TRUNC_MOD_EXPR,
  FLOOR_MOD_EXPR,

  TRUTH_AND_EXPR,
  TRUTH_OR_EXPR,
  TRUTH_XOR_EXPR,
  TRUTH_ANDIF_EXPR,
  TRUTH_ORIF_EXPR,

  TRUTH_NOT_EXPR,
  NEGATE_EXPR,
  ABS_EXPR,

  EQ_EXPR,
  NE_EXPR,
  LE_EXPR,
  LT_EXPR,
  GE_EXPR,
  GT_EXPR,
};

tree
new_dyadic_op (enum ON_op_kind kind, tree left, tree right)
{
  tree left_type;
  enum tree_code code;

  left_type = TREE_TYPE (left);
  gcc_assert (left_type == TREE_TYPE (right));

  switch (kind)
    {
    case ON_Div_Ov:
      if (TREE_CODE (left_type) == REAL_TYPE)
	code = RDIV_EXPR;
      else
	code = TRUNC_DIV_EXPR;
      break;
    default:
      code = ON_op_to_TREE_CODE[kind];
      break;
    }
  return build2 (code, left_type, left, right);
}

tree
new_monadic_op (enum ON_op_kind kind, tree operand)
{
  return build1 (ON_op_to_TREE_CODE[kind], TREE_TYPE (operand), operand);
}

tree
new_compare_op (enum ON_op_kind kind, tree left, tree right, tree ntype)
{
  gcc_assert (TREE_CODE (ntype) == BOOLEAN_TYPE);
  gcc_assert (TREE_TYPE (left) == TREE_TYPE (right));
  return build2 (ON_op_to_TREE_CODE[kind], ntype, left, right);
}

tree
new_convert_ov (tree val, tree rtype)
{
  tree val_type;
  enum tree_code val_code;
  enum tree_code rtype_code;
  enum tree_code code;

  val_type = TREE_TYPE (val);
  if (val_type == rtype)
    return val;

  /*  FIXME: check conversions.  */
  val_code = TREE_CODE (val_type);
  rtype_code = TREE_CODE (rtype);
  if (val_code == POINTER_TYPE && rtype_code == POINTER_TYPE)
    code = NOP_EXPR;
  else if (val_code == INTEGER_TYPE && rtype_code == INTEGER_TYPE)
    code = CONVERT_EXPR;
  else if (val_code == REAL_TYPE && rtype_code == INTEGER_TYPE)
    {
      /*  REAL to INTEGER
          Gcc only handles FIX_TRUNC_EXPR, but we need rounding.  */
      tree m_p5;
      tree p5;
      tree zero;
      tree saved;
      tree comp;
      tree adj;
      tree res;

      m_p5 = build_real (val_type, fp_const_m_p5);
      p5 = build_real (val_type, fp_const_p5);
      zero = build_real (val_type, fp_const_zero);
      saved = save_expr (val);
      comp = build2 (GE_EXPR, integer_type_node, saved, zero);
      /*  FIXME: instead of res = res + (comp ? .5 : -.5)
	  do: res = res (comp ? + : -) .5  */
      adj = build3 (COND_EXPR, val_type, comp, p5, m_p5);
      res = build2 (PLUS_EXPR, val_type, saved, adj);
      res = build1 (FIX_TRUNC_EXPR, rtype, res);
      return res;
    }
  else if (val_code == INTEGER_TYPE && rtype_code == ENUMERAL_TYPE)
    code = CONVERT_EXPR;
  else if (val_code == ENUMERAL_TYPE && rtype_code == INTEGER_TYPE)
    code = CONVERT_EXPR;
  else if (val_code == INTEGER_TYPE && rtype_code == REAL_TYPE)
    code = FLOAT_EXPR;
  else if (val_code == BOOLEAN_TYPE && rtype_code == BOOLEAN_TYPE)
    code = NOP_EXPR;
  else if (val_code == BOOLEAN_TYPE && rtype_code == INTEGER_TYPE)
    code = CONVERT_EXPR;
  else if (val_code == INTEGER_TYPE && rtype_code == BOOLEAN_TYPE)
    code = NOP_EXPR;
  else if (val_code == REAL_TYPE && rtype_code == REAL_TYPE)
    code = NOP_EXPR;
  else
    gcc_unreachable ();

  return build1 (code, rtype, val);
}

tree
new_alloca (tree rtype, tree size)
{
  tree res;

  /* Must save stack except when at function level.  */
  if (cur_binding_level->prev != NULL
      && cur_binding_level->prev->prev != NULL)
    cur_binding_level->save_stack = 1;

  res = build_call_nary (ptr_type_node, stack_alloc_function_ptr,
                         1, fold_convert (size_type_node, size));
  return fold_convert (rtype, res);
}

tree
new_signed_literal (tree ltype, long long value)
{
  tree res;
  HOST_WIDE_INT lo;
  HOST_WIDE_INT hi;

  lo = value;
  hi = (value >> 1) >> (8 * sizeof (HOST_WIDE_INT) - 1);
  res = build_int_cst_wide (ltype, lo, hi);
  return res;
}

tree
new_unsigned_literal (tree ltype, unsigned long long value)
{
  tree res;
  unsigned HOST_WIDE_INT lo;
  unsigned HOST_WIDE_INT hi;

  lo = value;
  hi = (value >> 1) >> (8 * sizeof (HOST_WIDE_INT) - 1);
  res = build_int_cst_wide (ltype, lo, hi);
  return res;
}

tree
new_null_access (tree ltype)
{
  tree res;

  res = build_int_cst_wide (ltype, 0, 0);
  return res;
}

tree
new_float_literal (tree ltype, double value)
{
  signed long long s;
  double frac;
  int ex;
  REAL_VALUE_TYPE r_sign;
  REAL_VALUE_TYPE r_exp;
  REAL_VALUE_TYPE r;
  tree res;
  HOST_WIDE_INT lo;
  HOST_WIDE_INT hi;

  frac = frexp (value, &ex);
  
  s = ldexp (frac, 60);
  lo = s;
  hi = (s >> 1) >> (8 * sizeof (HOST_WIDE_INT) - 1);
  res = build_int_cst_wide (long_integer_type_node, lo, hi);
  REAL_VALUE_FROM_INT (r_sign, lo, hi, DFmode);
  real_2expN (&r_exp, ex - 60, DFmode);
  real_arithmetic (&r, MULT_EXPR, &r_sign, &r_exp);
  res = build_real (ltype, r);
  return res;
}

struct GTY(()) o_element_list
{
  tree res;
  struct chain_constr_type chain;
};

void
new_uncomplete_record_type (tree *res)
{
  *res = make_node (RECORD_TYPE);
}

void
start_record_type (struct o_element_list *elements)
{
  elements->res = make_node (RECORD_TYPE);
  chain_init (&elements->chain);
}

void
start_uncomplete_record_type (tree res, struct o_element_list *elements)
{
  elements->res = res;
  chain_init (&elements->chain);
}

static void
new_record_union_field (struct o_element_list *list,
			tree *el,
			tree ident,
			tree etype)
{
  tree res;

  res = build_decl (input_location,
                    FIELD_DECL, ident, etype);
  DECL_CONTEXT (res) = list->res;
  chain_append (&list->chain, res);
  *el = res;
}

void
new_record_field (struct o_element_list *list,
		  tree *el,
		  tree ident,
		  tree etype)
{
  return new_record_union_field (list, el, ident, etype);
}

void
finish_record_type (struct o_element_list *elements, tree *res)
{
  TYPE_FIELDS (elements->res) = elements->chain.first;
  layout_type (elements->res);
  *res = elements->res;

  if (TYPE_NAME (elements->res) != NULL_TREE)
    {
      /*  The type was completed.  */
      rest_of_type_compilation (elements->res, 1);
    }
}

void
start_union_type (struct o_element_list *elements)
{
  elements->res =  make_node (UNION_TYPE);
  chain_init (&elements->chain);
}

void
new_union_field (struct o_element_list *elements,
		 tree *el,
		 tree ident,
		 tree etype)
{
  return new_record_union_field (elements, el, ident, etype);
}

void
finish_union_type (struct o_element_list *elements, tree *res)
{
  TYPE_FIELDS (elements->res) = elements->chain.first;
  layout_type (elements->res);
  *res = elements->res;
}

tree
new_unsigned_type (int size)
{
  return make_unsigned_type (size);
}

tree
new_signed_type (int size)
{
  return make_signed_type (size);
}

tree
new_float_type (void)
{
  tree res;

  res = make_node (REAL_TYPE);
  TYPE_PRECISION (res) = DOUBLE_TYPE_SIZE;
  layout_type (res);
  return res;
}

tree
new_access_type (tree dtype)
{
  tree res;

  if (dtype == NULL_TREE)
    {
      res = make_node (POINTER_TYPE);
      TREE_TYPE (res) = NULL_TREE;
      /* Seems necessary.  */
      SET_TYPE_MODE (res, Pmode);
      layout_type (res);
      return res;
    }
  else
    return build_pointer_type (dtype);
}

void
finish_access_type (tree atype, tree dtype)
{
  gcc_assert (TREE_CODE (atype) == POINTER_TYPE
	      && TREE_TYPE (atype) == NULL_TREE);

  TREE_TYPE (atype) = dtype;
}

tree
new_array_type (tree el_type, tree index_type)
{
  return build_array_type (el_type, index_type);
}


tree
new_constrained_array_type (tree atype, tree length)
{
  tree range_type;
  tree index_type;
  tree len;
  tree one;
  tree res;

  index_type = TYPE_DOMAIN (atype);
  if (integer_zerop (length))
    {
      /*  Handle null array, by creating a one-length array...  */
      len = size_zero_node;
    }
  else
    {
      one = build_int_cstu (index_type, 1);
      len = build2 (MINUS_EXPR, index_type, length, one);
      len = fold (len);
    }

  range_type = build_range_type (index_type, size_zero_node, len);
  res = build_array_type (TREE_TYPE (atype), range_type);

  /* Constrained arrays are *always* a subtype of its array type.
     Just copy alias set.  */
  TYPE_ALIAS_SET (res) = get_alias_set (atype);
  return res;
}

void
new_boolean_type (tree *res,
		  tree false_id, tree *false_e,
		  tree true_id, tree *true_e)
{
  *res = make_node (BOOLEAN_TYPE);
  TYPE_PRECISION (*res) = 1;
  fixup_unsigned_type (*res);
  *false_e = TYPE_MIN_VALUE (*res);
  *true_e = TYPE_MAX_VALUE (*res);
}

struct o_enum_list
{
  tree res;
  struct chain_constr_type chain;
  int num;
  int size;
};

void
start_enum_type (struct o_enum_list *list, int size)
{
  list->res = make_node (ENUMERAL_TYPE);
  // as of gcc4.8, TYPE_PRECISION of 0 is rigorously enforced!
  TYPE_PRECISION(list->res) = size;	
  chain_init (&list->chain);
  list->num = 0;
  list->size = size;
}

void
new_enum_literal (struct o_enum_list *list, tree ident, tree *res)
{
  *res = build_int_cstu (list->res, (HOST_WIDE_INT)(list->num));
  chain_append (&list->chain, tree_cons (ident, *res, NULL_TREE));
  list->num++;
}

void
finish_enum_type (struct o_enum_list *list, tree *res)
{
  *res = list->res;
  TYPE_VALUES (*res) = list->chain.first;
  TYPE_UNSIGNED (*res) = 1;
  TYPE_PRECISION (*res) = list->size;
  set_min_and_max_values_for_integral_type (*res, list->size, 1);
  layout_type (*res);
}

struct GTY(()) o_record_aggr_list
{
  /* Type of the record.  */
  tree atype;
  /* Type of the next field to be added.  */
  tree field;
  /* Vector of elements.  */
  // VEC(constructor_elt,gc) *elts;
  vec<constructor_elt,va_gc> *elts;
};

void
start_record_aggr (struct o_record_aggr_list *list, tree atype)
{
  list->atype = atype;
  list->field = TYPE_FIELDS (atype);
  //list->elts = VEC_alloc (constructor_elt, gc, fields_length (atype));
  vec_alloc(list->elts, fields_length (atype));
}

void
new_record_aggr_el (struct o_record_aggr_list *list, tree value)
{
  CONSTRUCTOR_APPEND_ELT (list->elts, list->field, value);
  list->field = TREE_CHAIN (list->field);
}

void
finish_record_aggr (struct o_record_aggr_list *list, tree *res)
{
  *res = build_constructor (list->atype, list->elts);
}
 

struct GTY(()) o_array_aggr_list
{
  tree atype;
  /* Vector of elements.  */
  //VEC(constructor_elt,gc) *elts;
  vec<constructor_elt,va_gc> *elts;
};

void
start_array_aggr (struct o_array_aggr_list *list, tree atype)
{
  tree nelts;
  unsigned HOST_WIDE_INT n;

  list->atype = atype;
  list->elts = NULL;

  nelts = array_type_nelts (atype);
  gcc_assert (nelts != NULL_TREE && host_integerp (nelts, 1));

  n = tree_low_cst (nelts, 1) + 1;
  //list->elts = VEC_alloc (constructor_elt, gc, n);
  vec_alloc(list->elts, n);
}

void
new_array_aggr_el (struct o_array_aggr_list *list, tree value)
{
  CONSTRUCTOR_APPEND_ELT (list->elts, NULL_TREE, value);
}
 
void
finish_array_aggr (struct o_array_aggr_list *list, tree *res)
{
  *res = build_constructor (list->atype, list->elts);
}


tree
new_union_aggr (tree atype, tree field, tree value)
{
  tree res;

  res = build_constructor_single (atype, field, value);
  TREE_CONSTANT (res) = 1;
  return res;
}

tree
new_indexed_element (tree arr, tree index)
{
  ortho_mark_addressable (arr);
  return build4 (ARRAY_REF, TREE_TYPE (TREE_TYPE (arr)),
		 arr, index, NULL_TREE, NULL_TREE);
}

tree
new_slice (tree arr, tree res_type, tree index)
{
#if 0
  tree res;
  tree el_ptr_type;
  tree el_type;
  tree res_ptr_type;
#endif

  /*  *((RES_TYPE *)(&ARR[INDEX]))
      convert ARR to a pointer, add index, and reconvert to array ?  */
  gcc_assert (TREE_CODE (res_type) == ARRAY_TYPE);

  ortho_mark_addressable (arr);
  return build4 (ARRAY_RANGE_REF, res_type, arr, index, NULL_TREE, NULL_TREE);
#if 0
  el_type = TREE_TYPE (TREE_TYPE (arr));
  el_ptr_type = build_pointer_type (el_type);

  res = build4 (ARRAY_REF, el_type, arr, index, NULL_TREE, NULL_TREE);
  res = build1 (ADDR_EXPR, el_ptr_type, res);
  res_ptr_type = build_pointer_type (res_type);
  res = build1 (NOP_EXPR, res_ptr_type, res);
  res = build1 (INDIRECT_REF, res_type, res);
  return res;
#endif
}

tree
new_selected_element (tree rec, tree el)
{
  tree res;

  gcc_assert (TREE_CODE (TREE_TYPE (rec)) == RECORD_TYPE);

  res = build3 (COMPONENT_REF, TREE_TYPE (el), rec, el, NULL_TREE);
  return res;
}

tree
new_access_element (tree acc)
{
  tree acc_type;

  acc_type = TREE_TYPE (acc);
  gcc_assert (TREE_CODE (acc_type) == POINTER_TYPE);

  return build1 (INDIRECT_REF, TREE_TYPE (acc_type), acc);
}

tree
new_offsetof (tree field, tree rtype)
{
  tree off;
  tree bit_off;
  HOST_WIDE_INT pos;
  tree res;

  off = DECL_FIELD_OFFSET (field);

  /*  The offset must be a constant.  */
  gcc_assert (host_integerp (off, 1));

  bit_off = DECL_FIELD_BIT_OFFSET (field);

  /*  The offset must be a constant.  */
  gcc_assert (host_integerp (bit_off, 1));

  pos = TREE_INT_CST_LOW (off)
        + (TREE_INT_CST_LOW (bit_off) / BITS_PER_UNIT);
  res = build_int_cstu (rtype, pos);
  return res;
}

tree
new_sizeof (tree atype, tree rtype)
{
 tree size;

 size = TYPE_SIZE_UNIT (atype);

 return fold (build1 (NOP_EXPR, rtype, size));
}

/* Convert the array expression EXP to a pointer.  */
static tree array_to_pointer_conversion (tree exp);

static tree
ortho_build_addr (tree lvalue, tree atype)
{
  tree res;

  if (TREE_CODE (lvalue) == INDIRECT_REF)
    {
      /* ADDR_REF(INDIRECT_REF(x)) -> x.  */
      res = TREE_OPERAND (lvalue, 0);
    }
  else
    {
      /* &base[off] -> base+off.  */
      if (TREE_CODE (lvalue) == ARRAY_REF
	  || TREE_CODE (lvalue) == ARRAY_RANGE_REF)
	{
	  tree base = TREE_OPERAND (lvalue, 0);
	  tree idx = TREE_OPERAND (lvalue, 1);
	  tree offset;
	  tree base_type;

	  ortho_mark_addressable (base);

	  idx = fold_convert (sizetype, idx);
	  offset = fold_build2 (MULT_EXPR, sizetype, idx,
				array_ref_element_size (lvalue)); 

	  base = array_to_pointer_conversion (base);
	  base_type = TREE_TYPE (base);

	  res = build2 (POINTER_PLUS_EXPR, base_type, base, offset);
	}
      else
	{
	  ortho_mark_addressable (lvalue);

	  if (TREE_TYPE (lvalue) != TREE_TYPE (atype))
	    {
	      tree ptr;
	      ptr = build_pointer_type (TREE_TYPE (lvalue));
	      res = build1 (ADDR_EXPR, ptr, lvalue);
	    }
	  else
	    res = build1 (ADDR_EXPR, atype, lvalue);
	}
      res = fold (res);
    }

  if (TREE_TYPE (res) != atype)
    res = fold_build1 (NOP_EXPR, atype, res);

  return res;
}

/* Convert the array expression EXP to a pointer.  */
static tree
array_to_pointer_conversion (tree exp)
{
  tree type = TREE_TYPE (exp);
  tree adr;
  tree restype = TREE_TYPE (type);
  tree ptrtype;

  gcc_assert (TREE_CODE (type) == ARRAY_TYPE);

  /* Create a pointer to elements.  */
  ptrtype = build_pointer_type (restype);

  switch (TREE_CODE (exp))
    {
    case INDIRECT_REF:
      return convert (ptrtype, TREE_OPERAND (exp, 0));

    case VAR_DECL:
      /* Convert array to pointer to elements.  */
      adr = build1 (ADDR_EXPR, ptrtype, exp);
      ortho_mark_addressable (exp);
      TREE_SIDE_EFFECTS (adr) = 0;   /* Default would be, same as EXP.  */
      return adr;

    default:
      /* Get address.  */
      return ortho_build_addr (exp, ptrtype);
    }
}

tree
new_unchecked_address (tree lvalue, tree atype)
{
  return ortho_build_addr (lvalue, atype);
}

tree
new_address (tree lvalue, tree atype)
{
  return ortho_build_addr (lvalue, atype);
}

tree
new_global_address (tree lvalue, tree atype)
{
  return ortho_build_addr (lvalue, atype);
}

tree
new_global_unchecked_address (tree lvalue, tree atype)
{
  return ortho_build_addr (lvalue, atype);
}

/*  Return a pointer to function FUNC. */
static tree
build_function_ptr (tree func)
{
  return build1 (ADDR_EXPR,
		 build_pointer_type (TREE_TYPE (func)), func);
}

tree
new_subprogram_address (tree subprg, tree atype)
{
  return fold (build1 (NOP_EXPR, atype, build_function_ptr (subprg)));
}

tree
new_value (tree lvalue)
{
  return lvalue;
}

void
new_debug_line_decl (int line)
{
  input_location = linemap_line_start (line_table, line, 252);
}

void
new_type_decl (tree ident, tree atype)
{
  tree decl;

  TYPE_NAME (atype) = ident;
  decl = build_decl (input_location, TYPE_DECL, ident, atype);
  TYPE_STUB_DECL (atype) = decl;
  push_decl (decl);
  /*
      if Get_TYPE_SIZE (Ttype) /= NULL_TREE then
         --  Do not generate debug info for uncompleted types.
         Rest_Of_Type_Compilation (Ttype, C_True);
      end if;
  */
}

enum o_storage { o_storage_external,
		 o_storage_public,
		 o_storage_private,
		 o_storage_local };

static void
set_storage (tree Node, enum o_storage storage)
{
  switch (storage)
    {
    case o_storage_external:
      DECL_EXTERNAL (Node) = 1;
      TREE_PUBLIC (Node) = 1;
      TREE_STATIC (Node) = 0;
      break;
    case o_storage_public:
      DECL_EXTERNAL (Node) = 0;
      TREE_PUBLIC (Node) = 1;
      TREE_STATIC (Node) = 1;
      break;
    case o_storage_private:
      DECL_EXTERNAL (Node) = 0;
      TREE_PUBLIC (Node) = 0;
      TREE_STATIC (Node) = 1;
      break;
    case o_storage_local:
      DECL_EXTERNAL (Node) = 0;
      TREE_PUBLIC (Node) = 0;
      TREE_STATIC (Node) = 0;
      break;
    }
}

void
new_const_decl (tree *res, tree ident, enum o_storage storage, tree atype)
{
  tree cst;

  cst = build_decl (input_location, VAR_DECL, ident, atype);
  set_storage (cst, storage);
  TREE_READONLY (cst) = 1;
  push_decl (cst);
  switch (storage)
    {
    case o_storage_local:
      gcc_unreachable ();
    case o_storage_external:
      /*  We are at top level if Current_Function_Decl is null.  */
      rest_of_decl_compilation
	(cst, current_function_decl == NULL_TREE, 0);
      break;
    case o_storage_public:
    case o_storage_private:
      break;
    }
  *res = cst;
}

void
start_const_value (tree *cst)
{
}

void
finish_const_value (tree *cst, tree val)
{
  DECL_INITIAL (*cst) = val;
  TREE_CONSTANT (val) = 1;
  TREE_STATIC (*cst) = 1;
  rest_of_decl_compilation
        (*cst, current_function_decl == NULL_TREE, 0);
}

void
new_var_decl (tree *res, tree ident, enum o_storage storage, tree atype)
{
  tree var;

  var = build_decl (input_location, VAR_DECL, ident, atype);
  if (current_function_decl != NULL_TREE)
    {    
      /*  Local variable. */
      TREE_STATIC (var) = 0;
      DECL_EXTERNAL (var) = 0;
      TREE_PUBLIC (var) = 0;
    }
  else
    set_storage (var, storage);

  push_decl (var);

  if (current_function_decl == NULL_TREE)
    rest_of_decl_compilation (var, 1, 0);

  *res = var;
}

struct GTY(()) o_inter_list
{
  tree ident;
  enum o_storage storage;

  /*  Return type.  */
  tree rtype;

  /*  List of parameter types.  */
  struct list_constr_type param_list;

  /*  Chain of parameters declarations.  */
  struct chain_constr_type param_chain;
};

void
start_function_decl (struct o_inter_list *interfaces,
		     tree ident,
		     enum o_storage storage,
		     tree rtype)
{
  interfaces->ident = ident;
  interfaces->storage = storage;
  interfaces->rtype = rtype;
  chain_init (&interfaces->param_chain);
  list_init (&interfaces->param_list);
}

void
start_procedure_decl (struct o_inter_list *interfaces,
		      tree ident,
		      enum o_storage storage)
{
  start_function_decl (interfaces, ident, storage, void_type_node);
}

void
new_interface_decl (struct o_inter_list *interfaces,
		    tree *res,
		    tree ident,
		    tree atype)
{
  tree r;

  r = build_decl (input_location, PARM_DECL, ident, atype);
  /* DECL_CONTEXT (Res, Xxx); */

  /*  Do type conversion: convert boolean and enums to int  */
  switch (TREE_CODE (atype))
    {
    case ENUMERAL_TYPE:
    case BOOLEAN_TYPE:
      DECL_ARG_TYPE (r) = integer_type_node;
    default:
      DECL_ARG_TYPE (r) = atype;
    }

  layout_decl (r, 0);

  chain_append (&interfaces->param_chain, r);
  ortho_list_append (&interfaces->param_list, atype);
  *res = r;
}

void
finish_subprogram_decl (struct o_inter_list *interfaces, tree *res)
{
  tree decl;
  tree result;
  tree parm;
  int is_global;

  /* Append a void type in the parameter types chain, so that the function
     is known not be have variables arguments.  */
  ortho_list_append (&interfaces->param_list, void_type_node);

  decl = build_decl (input_location, FUNCTION_DECL, interfaces->ident,
		     build_function_type (interfaces->rtype,
					  interfaces->param_list.first));
  DECL_SOURCE_LOCATION (decl) = input_location;

  is_global = current_function_decl == NULL_TREE
    || interfaces->storage == o_storage_external;
  if (is_global)
    set_storage (decl, interfaces->storage);
  else
    {
      /*  A nested subprogram.  */
      DECL_EXTERNAL (decl) = 0;
      TREE_PUBLIC (decl) = 0;
    }
  /*  The function exist in static storage. */
  TREE_STATIC (decl) = 1;
  DECL_INITIAL (decl) = error_mark_node;
  TREE_ADDRESSABLE (decl) = 1;

  /*  Declare the result.
      FIXME: should be moved in start_function_body. */
  result = build_decl (input_location,
                       RESULT_DECL, NULL_TREE, interfaces->rtype);
  DECL_RESULT (decl) = result;
  DECL_CONTEXT (result) = decl;

  DECL_ARGUMENTS (decl) = interfaces->param_chain.first;
  /* Set DECL_CONTEXT of parameters.  */
  for (parm = interfaces->param_chain.first;
       parm != NULL_TREE;
       parm = TREE_CHAIN (parm))
    DECL_CONTEXT (parm) = decl;

  push_decl (decl);

  /* External functions are never nested.
     Remove their context, which is set by push_decl.  */
  if (interfaces->storage == o_storage_external)
    DECL_CONTEXT (decl) = NULL_TREE;

  if (is_global)
    rest_of_decl_compilation (decl, 1, 0);

  *res = decl;
}

void
start_subprogram_body (tree func)
{
  gcc_assert (current_function_decl == DECL_CONTEXT (func));
  current_function_decl = func;

  /* The function is not anymore external.  */
  DECL_EXTERNAL (func) = 0;

  push_stmts (alloc_stmt_list ());
  push_binding ();
}

void
finish_subprogram_body (void)
{
  tree bind;
  tree func;
  tree parent;

  bind = pop_binding ();
  pop_stmts ();

  func = current_function_decl;
  DECL_INITIAL (func) = BIND_EXPR_BLOCK (bind);
  DECL_SAVED_TREE (func) = bind;

  /* Initialize the RTL code for the function.  */
  allocate_struct_function (func, false);

  /* Store the end of the function.  */
  cfun->function_end_locus = input_location;
  

  parent = DECL_CONTEXT (func);

  if (parent != NULL)
    cgraph_get_create_node (func);
  else
    cgraph_finalize_function (func, false);

  current_function_decl = parent;
  set_cfun (NULL);
}


void
new_debug_line_stmt (int line)
{
  input_location = linemap_line_start (line_table, line, 252);
}

void
start_declare_stmt (void)
{
  push_stmts (alloc_stmt_list ());
  push_binding ();
}

void
finish_declare_stmt (void)
{
  tree bind;

  bind = pop_binding ();
  pop_stmts ();
  append_stmt (bind);
}


struct GTY(()) o_assoc_list
{
  tree subprg;
//  VEC(tree,gc) *vec;
  vec<tree, va_gc> *vecptr;
};

void
start_association (struct o_assoc_list *assocs, tree subprg)
{
  assocs->subprg = subprg;
  assocs->vecptr = NULL;
}

void
new_association (struct o_assoc_list *assocs, tree val)
{
//  VEC_safe_push (tree, gc, assocs->vec, val);
  vec_safe_push(assocs->vecptr, val);
}

tree
new_function_call (struct o_assoc_list *assocs)
{
  return build_call_vec (TREE_TYPE (TREE_TYPE (assocs->subprg)),
                         build_function_ptr (assocs->subprg),
                         assocs->vecptr);
}

void
new_procedure_call (struct o_assoc_list *assocs)
{
  tree res;

  res = build_call_vec (TREE_TYPE (TREE_TYPE (assocs->subprg)),
                        build_function_ptr (assocs->subprg),
                        assocs->vecptr);
  TREE_SIDE_EFFECTS (res) = 1;
  append_stmt (res);
}

void
new_assign_stmt (tree target, tree value)
{
  tree n;

  n = build2 (MODIFY_EXPR, TREE_TYPE (target), target, value);
  TREE_SIDE_EFFECTS (n) = 1;
  append_stmt (n);
}

void
new_func_return_stmt (tree value)
{
  tree assign;
  tree stmt;
  tree res;

  res = DECL_RESULT (current_function_decl);
  assign = build2 (MODIFY_EXPR, TREE_TYPE (value), res, value);
  TREE_SIDE_EFFECTS (assign) = 1;
  stmt = build1 (RETURN_EXPR, void_type_node, assign);
  TREE_SIDE_EFFECTS (stmt) = 1;
  append_stmt (stmt);
}

void
new_proc_return_stmt (void)
{
  tree stmt;

  stmt = build1 (RETURN_EXPR, void_type_node, NULL_TREE);
  TREE_SIDE_EFFECTS (stmt) = 1;
  append_stmt (stmt);
}


struct GTY(()) o_if_block
{
  tree stmt;
};

void
start_if_stmt (struct o_if_block *block, tree cond)
{
  tree stmt;
  tree stmts;

  stmts = alloc_stmt_list ();
  stmt = build3 (COND_EXPR, void_type_node, cond, stmts, NULL_TREE);
  block->stmt = stmt;
  append_stmt (stmt);
  push_stmts (stmts);
}

void
new_elsif_stmt (struct o_if_block *block, tree cond)
{
  tree stmts;
  tree stmt;

  pop_stmts ();
  stmts = alloc_stmt_list ();
  stmt = build3 (COND_EXPR, void_type_node, cond, stmts, NULL_TREE);
  COND_EXPR_ELSE (block->stmt) = stmt;
  block->stmt = stmt;
  push_stmts (stmts);
}

void
new_else_stmt (struct o_if_block *block)
{
  tree stmts;

  pop_stmts ();
  stmts = alloc_stmt_list ();
  COND_EXPR_ELSE (block->stmt) = stmts;
  push_stmts (stmts);
}

void
finish_if_stmt (struct o_if_block *block)
{
  pop_stmts ();
}


struct GTY(()) o_snode
{
  tree beg_label;
  tree end_label;
};

/* Create an artificial label.  */
static tree
build_label (void)
{
  tree res;

  res = build_decl (input_location, LABEL_DECL, NULL_TREE, void_type_node);
  DECL_CONTEXT (res) = current_function_decl;
  DECL_ARTIFICIAL (res) = 1;
  return res;
}

void
start_loop_stmt (struct o_snode *label)
{
  tree stmt;

  label->beg_label = build_label ();

  stmt = build1 (LABEL_EXPR, void_type_node, label->beg_label);
  append_stmt (stmt);

  label->end_label = build_label ();
}

void
finish_loop_stmt (struct o_snode *label)
{
  tree stmt;

  stmt = build1 (GOTO_EXPR, void_type_node, label->beg_label);
  TREE_USED (label->beg_label) = 1;
  append_stmt (stmt);
  /*  Emit the end label only if there is a goto to it.
      (Return may be used to exit from the loop).  */
  if (TREE_USED (label->end_label))
    {
      stmt = build1 (LABEL_EXPR, void_type_node, label->end_label);
      append_stmt (stmt);
    }
}

void
new_exit_stmt (struct o_snode *l)
{
  tree stmt;

  stmt = build1 (GOTO_EXPR, void_type_node, l->end_label);
  append_stmt (stmt);
  TREE_USED (l->end_label) = 1;
}

void
new_next_stmt (struct o_snode *l)
{
  tree stmt;

  stmt = build1 (GOTO_EXPR, void_type_node, l->beg_label);
  TREE_USED (l->beg_label) = 1;
  append_stmt (stmt);
}

struct GTY(()) o_case_block
{
  tree end_label;
  int add_break;
};

static GTY(()) tree t_condtype = NULL_TREE;
static vec <tree> t_condtype_stack = vec<tree>();

void
start_case_stmt (struct o_case_block *block, tree value)
{
  tree stmt;
  tree stmts;

// following https://bitbucket.org/goshawk/gdc/issue/344/compilation-with-latest-trunk-fails
// gimplify_switch_expr now checks type of index expr is (some discrete type) but at least not void
// Saved in static variable t_condtype for start_choice to use
//
// Static variable is inadequate : nested Case statements won't work, so we either:
// need to stack t_condtypes, or add a parameter to start_choice, which affects 
// translation.adb and the interface to ALL backends, mcode etc. I think this is less ugly.
  t_condtype_stack.safe_push(t_condtype);
  t_condtype = TREE_TYPE(value);

  block->end_label = build_label ();
  block->add_break = 0;
  stmts = alloc_stmt_list ();
  stmt = build3 (SWITCH_EXPR, t_condtype, value, stmts, NULL_TREE);
  append_stmt (stmt);
  push_stmts (stmts);
}

void
start_choice (struct o_case_block *block)
{
  tree stmt;
  if (block->add_break)
    {
// following https://bitbucket.org/goshawk/gdc/issue/344/compilation-with-latest-trunk-fails
// gimplify_switch_expr now checks type of index expr is (saved) t_condtype
      stmt = build1 (GOTO_EXPR, t_condtype, block->end_label);
      append_stmt (stmt);

      block->add_break = 0;
    }
}

void
new_expr_choice (struct o_case_block *block, tree expr)
{
  tree stmt;

  stmt = build_case_label
    (expr, NULL_TREE, create_artificial_label (input_location));
  append_stmt (stmt);
}

void
new_range_choice (struct o_case_block *block, tree low, tree high)
{
  tree stmt;

  stmt = build_case_label
    (low, high, create_artificial_label (input_location));
  append_stmt (stmt);
}

void
new_default_choice (struct o_case_block *block)
{
  tree stmt;

  stmt = build_case_label
    (NULL_TREE, NULL_TREE, create_artificial_label (input_location));
  append_stmt (stmt);
}

void
finish_choice (struct o_case_block *block)
{
  block->add_break = 1;
}

void
finish_case_stmt (struct o_case_block *block)
{
  tree stmt;

  pop_stmts ();
  stmt = build1 (LABEL_EXPR, void_type_node, block->end_label);
  append_stmt (stmt);
// see start_case_stmt : restore t_condtype to handle outer case statement
  t_condtype = t_condtype_stack.pop();
}

bool
compare_identifier_string (tree id, const char *str, size_t len)
{
  if (IDENTIFIER_LENGTH (id) != len)
    return false;
  if (!memcmp (IDENTIFIER_POINTER (id), str, len))
    return true;
  else
    return false;
}

void
get_identifier_string (tree id, const char **str, int *len)
{
  *len = IDENTIFIER_LENGTH (id);
  *str = IDENTIFIER_POINTER (id);
}

// C linkage wrappers for two (now C++) functions so that 
// Ada code can call them without name mangling
tree get_identifier_with_length_c (const char *c, size_t s)
{
  return get_identifier_with_length(c, s);
}

int toplev_main_c (int argc, char **argv)
{
  return toplev_main(argc, argv);
}

void
debug_tree_c ( tree expr)
{
  warning(OPT_Wall,"Debug tree");
  debug_tree(expr);
}

} // end extern "C"

#include "debug.h"
#include "gt-vhdl-ortho-lang.h"
#include "gtype-vhdl.h"