/*Pascal expressions.

  Copyright (C) 1992-2004 Free Software Foundation, Inc.

  Authors: Jukka Virtanen <jtv@hut.fi>
           Peter Gerwinski <peter@gerwinski.de>
           Frank Heckenbach <frank@pascal.gnu.de>
           Waldek Hebisch <hebisch@math.uni.wroc.pl>

  Parts of this file were originally derived from GCC's `c-common.c'.

  This file is part of GNU Pascal.

  GNU Pascal 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 Pascal 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 Pascal; see the file COPYING. If not, write to the
  Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  02111-1307, USA. */

#include "gpc.h"

int operators_defined = 0;

static void set_string_length PARAMS ((tree, int, int));
static void warn_operands PARAMS ((enum tree_code, tree, int));
static int is_pascal_loop_check PARAMS ((tree));
static const char *get_op_name PARAMS ((enum tree_code));
static void binary_op_error PARAMS ((enum tree_code));
static tree get_type_name PARAMS ((tree));
static inline tree get_op_id PARAMS ((const char *, const char *, const char *));
static int compatible_types_p PARAMS ((tree, tree));
static int compatible_relop_p PARAMS ((tree, tree));
static tree c_size_in_bytes PARAMS ((tree));
static tree pointer_int_sum PARAMS ((enum tree_code, tree, tree));
static tree pointer_diff PARAMS ((tree, tree));
static tree strip_needless_lists PARAMS ((tree));

/* Set the type of a strings, starting at index 1.
   The empty string gets range 1 .. 1, because 1 .. 0 would be invalid.
   Note: TREE_STRING_LENGTH includes a trailing #0 (to output
   C-compatible strings and to avoid changing the files that output
   assembler code), but the domain doesn't (so the NULL doesn't appear
   in Pascal string usage). */
static void
set_string_length (value, wide_flag, length)
     tree value;
     int wide_flag, length;
{
  tree domain;
  assert (length >= 0);
  if (length == 0)
    domain = build_index_2_type (integer_one_node, integer_one_node);
  else
    domain = build_index_2_type (integer_one_node, build_int_2 (length, 0));
  TREE_TYPE (value) = build_simple_array_type (p_build_type_variant (
    wide_flag ? wchar_type_node : char_type_node, 1, 0), domain);
  /* In addition, the string (array) constant is `packed' */
  PASCAL_TYPE_PACKED (TREE_TYPE (value)) = 1;
  TREE_CONSTANT (value) = 1;
  TREE_READONLY (value) = 1;
  TREE_STATIC (value) = 1;
}

tree
build_string_constant (s, length, literal)
     const char *s;
     int length, literal;
{
  tree t;
  char *buf = alloca (length + 1);
  memcpy (buf, s, length);
  buf[length] = 0;
  t = build_string (length + 1, buf);
  PASCAL_TREE_FRESH_CST (t) = literal;
  set_string_length (t, 0, length);
  return t;
}

tree
build_caret_string_constant (c)
     int c;
{
  char tmp = TOUPPER (c) ^ 0x40;
  chk_dialect ("char constants with `^' are", B_D_PASCAL);
  /* It is a single char, but the parser expects it as a string constant. */
  return build_string_constant (&tmp, 1, 1);
}

/* Given a list of STRING_CST nodes, concatenate them into one STRING_CST.
   mode means:
   0: explicit concatenation
   1: implicit
   2: implicit for `asm' (insert "\n\t" between the strings) */
tree
combine_strings (strings, mode)
     tree strings;
     int mode;
{
  tree value, l, t;
  int length = 1, wide_length = 0, wide_flag = 0, nchars;
  int wchar_bytes = TYPE_PRECISION (wchar_type_node) / BITS_PER_UNIT;
  char *p, *q;

  if (!TREE_CHAIN (strings))
    {
      if (TREE_STRING_LENGTH (TREE_VALUE (strings)) == 1)
        chk_dialect ("the empty string is", NOT_CLASSIC_PASCAL);
      return TREE_VALUE (strings);
    }

  if (mode)
    chk_dialect ("string concatenation without `Concat' or `+' is", B_D_PASCAL);
  else
    chk_dialect ("string concatenation with `+' is", NOT_CLASSIC_PASCAL);

  /* Don't include the #0 at the end of each substring,
     except for the last one.
     Count wide strings and ordinary strings separately. */
  for (l = strings; l; l = TREE_CHAIN (l))
    {
      t = TREE_VALUE (l);
      if (TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))) == wchar_type_node)
        {
          wide_length += TREE_STRING_LENGTH (t) - wchar_bytes;
          wide_flag = 1;
          if (mode == 2 && TREE_CHAIN (l)) wide_length += 2 * wchar_bytes;
        }
      else
        {
          length += TREE_STRING_LENGTH (t) - 1;
          if (mode == 2 && TREE_CHAIN (l)) length += 2;
        }
    }

  /* If anything is wide, the non-wides will be converted,
     which makes them take more space. */
  if (wide_flag)
    length = length * wchar_bytes + wide_length;

#ifdef EGCS97
  p = xmalloc (length);
#else
  p = savealloc (length);
#endif

  /* Copy the individual strings into the new combined string.
     If the combined string is wide, convert the chars to ints
     for any individual strings that are not wide. */
  q = p;
  for (l = strings; l; l = TREE_CHAIN (l))
    {
      int len;
      t = TREE_VALUE (l);
      len = TREE_STRING_LENGTH (t) - ((TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))) == wchar_type_node) ? wchar_bytes : 1);
      if ((TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))) == wchar_type_node) == wide_flag)
        {
          memcpy (q, TREE_STRING_POINTER (t), len);
          q += len;
        }
      else
        {
          int i;
          for (i = 0; i < len; i++)
            {
              if (TYPE_PRECISION (wchar_type_node) == HOST_BITS_PER_SHORT)
                ((short *) q)[i] = TREE_STRING_POINTER (t)[i];
              else
                ((int *) q)[i] = TREE_STRING_POINTER (t)[i];
            }
          q += len * wchar_bytes;
        }
      if (mode == 2 && TREE_CHAIN (l))
        {
          if (!wide_flag)
            {
              *q++ = '\n';
              *q++ = '\t';
            }
          else if (TYPE_PRECISION (wchar_type_node) == HOST_BITS_PER_SHORT)
            {
              ((short *) q)[0] = '\n';
              ((short *) q)[1] = '\t';
              q += 2 * sizeof (short);
            }
          else
            {
              ((int *) q)[0] = '\n';
              ((int *) q)[1] = '\t';
              q += 2 * sizeof (int);
            }
        }
    }
  if (wide_flag)
    for (nchars = 0; nchars < wchar_bytes; nchars++)
      *q++ = 0;
  else
    *q = 0;
  value = make_node (STRING_CST);
  TREE_STRING_POINTER (value) = p;
  TREE_STRING_LENGTH (value) = length;
  PASCAL_TREE_FRESH_CST (value) = !!mode;
  set_string_length (value, wide_flag, wide_flag ? length / wchar_bytes : length - 1);
  return value;
}

/* Print a warning if a constant expression had overflow in folding.
   Invoke this function on every expression that the language
   requires to be a constant expression. */
void
constant_expression_warning (value)
     tree value;
{
  if ((TREE_CODE (value) == INTEGER_CST || TREE_CODE (value) == REAL_CST
       || TREE_CODE (value) == COMPLEX_CST)
      && TREE_CONSTANT_OVERFLOW (value) && pedantic)
    error ("overflow in constant expression");
}

tree
range_check_2 (min, max, expr)
     tree min, max, expr;
{
  CHK_EM (expr);
  if (!ORDINAL_TYPE (TREE_CODE (TREE_TYPE (expr))))
    return expr;
  STRIP_TYPE_NOPS (expr);
  expr = fold (expr);
  if (TREE_CODE (expr) == INTEGER_CST
      && (int_cst_lt_always (expr, min) || int_cst_lt_always (max, expr)))
    {
      error ("constant out of range");
      return error_mark_node;
    }
  if (int_cst_lt_always (max, TYPE_MIN_VALUE (TREE_TYPE (expr)))
      || int_cst_lt_always (TYPE_MAX_VALUE (TREE_TYPE (expr)), min))
    {
      error ("ranges of value and target are disjoint");
      return error_mark_node;
    }
  return expr;
}

tree
range_check (type, expr)
     tree type, expr;
{
  if (!ORDINAL_TYPE (TREE_CODE (type)))
    return expr;
  return range_check_2 (TYPE_MIN_VALUE (type), TYPE_MAX_VALUE (type), expr);
}

tree
convert_and_check (type, expr)
     tree type, expr;
{
  if (contains_discriminant (expr, NULL_TREE))
    return build1 (CONVERT_EXPR, type, expr);
  /* Don't complain about `High (WordBool)' etc. */
  if (TREE_CODE (TREE_TYPE (expr)) == BOOLEAN_TYPE
      && int_cst_lt_always (TYPE_MAX_VALUE (type), TYPE_MAX_VALUE (TREE_TYPE (expr))))
    expr = build_binary_op (NE_EXPR, expr, boolean_false_node, 0);
  return convert (type, range_check (type, expr));
}

static const char *
get_op_name (code)
     enum tree_code code;
{
  switch (code)
  {
    case PLUS_EXPR:        return "+";
    case MINUS_EXPR:       return "-";
    case MULT_EXPR:        return "*";
    case MAX_EXPR:         return "Max";
    case MIN_EXPR:         return "Min";
    case LE_EXPR:          return "<=";
    case GE_EXPR:          return ">=";
    case LT_EXPR:          return "<";
    case GT_EXPR:          return ">";
    case EQ_EXPR:          return "=";
    case NE_EXPR:          return "<>";
    case TRUNC_MOD_EXPR:
    case FLOOR_MOD_EXPR:   return "mod";
    case TRUNC_DIV_EXPR:
    case FLOOR_DIV_EXPR:   return "div";
    case RDIV_EXPR:        return "/";
    case POW_EXPR:         return "pow";
    case POWER_EXPR:       return "**";
    case TRUTH_NOT_EXPR:   return "not";
    case BIT_AND_EXPR:
    case TRUTH_AND_EXPR:   return "and";
    case TRUTH_ANDIF_EXPR: return "and_then";
    case BIT_IOR_EXPR:
    case TRUTH_OR_EXPR:    return "or";
    case TRUTH_ORIF_EXPR:  return "or_else";
    case BIT_XOR_EXPR:
    case TRUTH_XOR_EXPR:   return "xor";
    case IN_EXPR:          return "in";
    case SYMDIFF_EXPR:     return "><";
    case LSHIFT_EXPR:      return "shl";
    case RSHIFT_EXPR:      return "shr";
    case LROTATE_EXPR:     return "RotateLeft";
    case RROTATE_EXPR:     return "RotateRight";
    default:               assert (0);
  }
}

/* Print an error message for invalid operands to arith operation CODE.
   NOP_EXPR is used as a special case (see truthvalue_conversion). */
static void
binary_op_error (code)
     enum tree_code code;
{
  if (code == NOP_EXPR)
    error ("invalid type conversion");
  else
    error ("invalid operands to binary `%s'", get_op_name (code));
}

static tree
get_type_name (t)
     tree t;
{
  if (TYPE_NAME (t))
    t = TYPE_NAME (t);
  else if (TREE_CODE (t) == REFERENCE_TYPE && TYPE_NAME (TREE_TYPE (t)))
    t = TYPE_NAME (TREE_TYPE (t));
  if (t && TREE_CODE (t) == TYPE_DECL)
    t = DECL_NAME (t);
  return (t && TREE_CODE (t) == IDENTIFIER_NODE) ? t : NULL_TREE;
}

static inline tree
get_op_id (op_id, n1, n2)
     const char *op_id, *n1, *n2;
{
  return get_identifier (ACONCAT ((op_id, "_", (*n1 >= 'A' && *n1 <= 'Z') ? "" : "OP", n1,
                                          "_", (*n2 >= 'A' && *n2 <= 'Z') ? "" : "OP", n2, NULL)));
}

/* Return an identifier_node (if new is set; NULL_TREE in case of error) or a
   FUNCTION_DECL (if new is not set; NULL_TREE if not found) for a user-defined
   operator. Both args may be expression, type or type_decl nodes. */
tree
get_operator (op_id, op_name, arg1, arg2, new)
     const char *op_id, *op_name;
     tree arg1, arg2;
     int new;
{
  tree found = NULL_TREE, t1, t2, a1, a2, next1, next2;

  /* If no user operators have been (or are being) defined, don't waste time looking for any. */
  if (new)
    operators_defined = 1;
  if (!operators_defined)
    return NULL_TREE;

  arg1 = string_may_be_char (arg1, 0);
  arg2 = string_may_be_char (arg2, 0);
  STRIP_TYPE_NOPS (arg1);
  STRIP_TYPE_NOPS (arg2);

  /* For "fresh" constants try the most basic and the longest type.
     For Char constants try Char and String. */
  if (TREE_CODE_CLASS (TREE_CODE (arg1)) == 'c' && PASCAL_TREE_FRESH_CST (arg1))
    {
      if (TREE_CODE (arg1) == INTEGER_CST && TREE_CODE (TREE_TYPE (arg1)) == INTEGER_TYPE)
        {
          found = get_operator (op_id, op_name, pascal_integer_type_node, arg2, new);
          arg1 = long_long_integer_type_node;
        }
      if (TREE_CODE (arg1) == INTEGER_CST && TREE_CODE (TREE_TYPE (arg1)) == CHAR_TYPE)
        {
          found = get_operator (op_id, op_name, char_type_node, arg2, new);
          arg1 = string_schema_proto_type;
        }
      if (TREE_CODE (arg1) == REAL_CST)
        {
          found = get_operator (op_id, op_name, double_type_node, arg2, new);
          arg1 = long_double_type_node;
        }
      if (found)
        return found;
    }
  if (TREE_CODE_CLASS (TREE_CODE (arg2)) == 'c' && PASCAL_TREE_FRESH_CST (arg2))
    {
      if (TREE_CODE (arg2) == INTEGER_CST && TREE_CODE (TREE_TYPE (arg2)) == INTEGER_TYPE)
        {
          found = get_operator (op_id, op_name, arg1, pascal_integer_type_node, new);
          arg2 = long_long_integer_type_node;
        }
      if (TREE_CODE (arg2) == INTEGER_CST && TREE_CODE (TREE_TYPE (arg2)) == CHAR_TYPE)
        {
          found = get_operator (op_id, op_name, arg1, char_type_node, new);
          arg2 = string_schema_proto_type;
        }
      if (TREE_CODE (arg2) == REAL_CST)
        {
          found = get_operator (op_id, op_name, arg1, double_type_node, new);
          arg2 = long_double_type_node;
        }
      if (found)
        return found;
    }

  if (!TYPE_P (arg1))
    arg1 = TREE_TYPE (arg1);
  if (!TYPE_P (arg2))
    arg2 = TREE_TYPE (arg2);
  if (!arg1 || EM (arg1) || !arg2 || EM (arg2))
    return NULL_TREE;

  /* Look through all variants, but try the given type first to get
     the expected name when defining a new operator. */
  for (a1 = arg1, next1 = TYPE_MAIN_VARIANT (arg1); a1;
       a1 = next1, next1 = a1 ? TYPE_NEXT_VARIANT (a1) : NULL_TREE)
    if ((t1 = get_type_name (a1)))
      for (a2 = arg2, next2 = TYPE_MAIN_VARIANT (arg2); a2;
           a2 = next2, next2 = a2 ? TYPE_NEXT_VARIANT (a2) : NULL_TREE)
        if ((t2 = get_type_name (a2)))
          {
            const char *n1 = IDENTIFIER_POINTER (t1), *n2 = IDENTIFIER_POINTER (t2);
            tree result = get_op_id (op_id, n1, n2);
            tree t = new ? result : lookup_name (result);
            if (t)
              {
                assert (new || TREE_CODE (t) == FUNCTION_DECL);
                if (!IDENTIFIER_SPELLING (result)
                    && op_name
                    && IDENTIFIER_SPELLING (t1)
                    && IDENTIFIER_SPELLING (t2))
                  {
                    char *s = ACONCAT ((op_name, " (", IDENTIFIER_SPELLING (t1),
                                                 ", ", IDENTIFIER_SPELLING (t2),
                                                 ")", NULL));
                    set_identifier_spelling (result, s, NULL, 0);
                  }
                return t;
              }
          }
  return NULL_TREE;
}

/* A user-defined operator expression is converted to a function call. */
tree
build_operator_call (op, exp1, exp2, pxsc)
     tree op, exp1, exp2;
     int pxsc;
{
  tree fun = get_operator (IDENTIFIER_POINTER (op), NULL, exp1, exp2, 0);
  if (pxsc)
    chk_dialect ("overloaded and rounding operators are", PASCAL_SC);
  CHK_EM (exp1);
  CHK_EM (exp2);
  if (PASCAL_TYPE_RESTRICTED (TREE_TYPE (exp1)) || PASCAL_TYPE_RESTRICTED (TREE_TYPE (exp2)))
    error ("invalid binary operation with restricted value");
  if (fun)
    return build_routine_call (fun, tree_cons (NULL_TREE, exp1, build_tree_list (NULL_TREE, exp2)));
  if (pxsc)
    error ("PXSC operators are not built-in but must be overloaded");
  else
    {
      tree t = lookup_name (op);
      if (t && TREE_CODE (t) == OPERATOR_DECL)
        error ("invalid use of operator `%s'", IDENTIFIER_NAME (op));
      else
        error ("syntax error before `%s'", IDENTIFIER_NAME (op));
    }
  return error_mark_node;
}

static void
warn_operands (outer, exp_inner, rhs)
     enum tree_code outer;
     tree exp_inner;
     int rhs;
{
#define REL_OP(code) \
  (code == EQ_EXPR || code == LT_EXPR || code == GT_EXPR \
   || code == NE_EXPR || code == LE_EXPR || code == GE_EXPR || code == IN_EXPR)
#define OR_OP(code) \
  (code == BIT_IOR_EXPR || code == TRUTH_OR_EXPR || code == TRUTH_ORIF_EXPR \
   || code == BIT_XOR_EXPR || code == TRUTH_XOR_EXPR)
#define AND_OP(code) \
  (code == BIT_AND_EXPR || code == TRUTH_AND_EXPR || code == TRUTH_ANDIF_EXPR)
  if (co->warn_parentheses && IS_EXPR_CODE_CLASS (TREE_CODE_CLASS (TREE_CODE (exp_inner))))
    {
      enum tree_code inner = EXP_ORIGINAL_CODE (exp_inner);
      if ((AND_OP (inner) && OR_OP (outer))
          || ((OR_OP (inner) || AND_OP (inner) || (!rhs && inner == TRUTH_NOT_EXPR))
              && REL_OP (outer)))
        warning ("suggest parentheses around `%s' in operand of `%s'",
                 get_op_name (inner), get_op_name (outer));
    }
}

/* @@ Kludge to solve problems with Boolean shortcut operators. (fjf226*.pas)
      The problem is that expressions may cause assignments to temporary
      variables to be *expanded* before the expressions are used. The
      work-around implemented here is to also expand the operands of the
      short-cut operators and wrap up the RHS one in a conditional statement.
      So we actually contribute to the problem that we then work-around.
      Statement-expressions might be a better solution.
      As a side benefit, we can output line number information for each
      operand in the parser, so the evaluation of such shortcut operations
      can be traced in the debugger. */
tree
start_boolean_binary_op (code, exp1)
     enum tree_code code;
     tree exp1;
{
  if (TREE_CODE (TREE_TYPE (exp1)) == BOOLEAN_TYPE
      && current_function_decl
      && (code == TRUTH_ANDIF_EXPR || code == TRUTH_ORIF_EXPR || co->short_circuit))
    {
      tree tempvar = make_new_variable ("fjf226", boolean_type_node);
      expand_expr_stmt (build_modify_expr (tempvar, NOP_EXPR, exp1));
      expand_start_cond ((code == TRUTH_AND_EXPR || code == TRUTH_ANDIF_EXPR)
        ? tempvar : build_unary_op (TRUTH_NOT_EXPR, tempvar, 0), 0);
      return tempvar;
    }
  else
    return NULL_TREE;
}

tree
finish_boolean_binary_op (code, exp1, exp2, tempvar)
     enum tree_code code;
     tree exp1, exp2, tempvar;
{
  if (tempvar)
    {
      if (TREE_CODE (TREE_TYPE (exp2)) == BOOLEAN_TYPE)
        expand_expr_stmt (build_modify_expr (tempvar, NOP_EXPR, exp2));
      else if (!EM (exp2))
        error ("incompatible types in Boolean operation");
      expand_end_cond ();
      warn_operands (code, exp1, 0);
      warn_operands (code, exp2, 1);
      return set_exp_original_code (non_lvalue (tempvar), code);
    }
  else
    return parser_build_binary_op (code, exp1, exp2);
}

tree
set_exp_original_code (t, code)
     tree t;
     enum tree_code code;
{
  tree result = t;
  if (!HAS_EXP_ORIGINAL_CODE_FIELD (result))
    {
      /* @@ Don't put NON_LVALUE_EXPRs around STRING_CST and CONSTRUCTOR nodes
            (result of `+'). Many places in the compiler don't seem to expect
            it. There warnings in warn_operands don't apply for strings and
            sets, anyway, except for user-defined operators. */
      if (TREE_CODE (result) == STRING_CST || TREE_CODE (result) == CONSTRUCTOR || lvalue_p (result))
        return result;
      result = build1 (NON_LVALUE_EXPR, TREE_TYPE (t), t);
      TREE_CONSTANT (result) = TREE_CONSTANT (t);
      TREE_OVERFLOW (result) = TREE_OVERFLOW (t);
    }
  SET_EXP_ORIGINAL_CODE (result, code);
  return result;
}

/* This is the entry point used by the parser for binary operators in the input.
   In addition to constructing the expression, we check for operands that were
   combined with other binary operators in a way that is likely to confuse the
   user. If parentheses are used, EXP_ORIGINAL_CODE is cleared to prevent these
   warnings. */
tree
parser_build_binary_op (code, arg1, arg2)
     enum tree_code code;
     tree arg1, arg2;
{
  tree result = build_pascal_binary_op (code, arg1, arg2);
  if (TREE_CODE_CLASS (TREE_CODE (result)) == 'c' && TREE_OVERFLOW (result))
    {
      TREE_OVERFLOW (result) = 0;
      error ("constant overflow in expression");
    }
  warn_operands (code, arg1, 0);
  warn_operands (code, arg2, 1);
  return set_exp_original_code (result, code);
}

/* Convert the operations for sets to their corresponding bitwise
   boolean operators. Other than sets, do some checks and call
   build_binary_op with the supplied args (no conversion).

   @@@ Here is a great chance to optimize constant sets (later).

   If the arguments are constructors, this is a good place
   to convert them to sets since we know how big the other
   set is we are operating with. */
tree
build_pascal_binary_op (code, exp1, exp2)
     enum tree_code code;
     tree exp1, exp2;
{
  enum tree_code t1 = TREE_CODE (exp1), t2 = TREE_CODE (exp2);
  const char *op_name;
  tree result;

  CHK_EM (TREE_TYPE (exp1));
  CHK_EM (TREE_TYPE (exp2));

  if (PASCAL_TYPE_RESTRICTED (TREE_TYPE (exp1)) || PASCAL_TYPE_RESTRICTED (TREE_TYPE (exp2)))
    error ("invalid operation with a restricted value");

  /* Check for string constants being chars. */
  if (t1 == STRING_CST && TREE_STRING_LENGTH (exp1) == 2)
    {
      exp1 = string_may_be_char (exp1, 0);
      t1 = TREE_CODE (exp1);
    }
  if (t2 == STRING_CST && TREE_STRING_LENGTH (exp2) == 2)
    {
      exp2 = string_may_be_char (exp2, 0);
      t2 = TREE_CODE (exp2);
    }

  /* Look if this is a user-defined operator which must be converted to a function call. */
  switch (code)
  {
    case PLUS_EXPR:        op_name = "BPlus";    break;
    case MINUS_EXPR:       op_name = "BMinus";   break;
    case MULT_EXPR:        op_name = "BMult";    break;
    case RDIV_EXPR:        op_name = "RDiv";     break;
    case TRUNC_DIV_EXPR:   op_name = "Div";      break;
    case TRUNC_MOD_EXPR:
    case FLOOR_MOD_EXPR:   op_name = "Mod";      break;
    case POWER_EXPR:       op_name = "RPower";   break;
    case POW_EXPR:         op_name = "Pow";      break;
    case LSHIFT_EXPR:      op_name = "Shl";      break;
    case RSHIFT_EXPR:      op_name = "Shr";      break;
    case IN_EXPR:          op_name = "In";       break;
    case LT_EXPR:          op_name = "LT";       break;
    case EQ_EXPR:          op_name = "EQ";       break;
    case GT_EXPR:          op_name = "GT";       break;
    case NE_EXPR:          op_name = "NE";       break;
    case GE_EXPR:          op_name = "GE";       break;
    case LE_EXPR:          op_name = "LE";       break;
    case TRUTH_AND_EXPR:   op_name = "And";      break;
    case TRUTH_ANDIF_EXPR: op_name = "And_then"; break;
    case TRUTH_OR_EXPR:    op_name = "Or";       break;
    case TRUTH_ORIF_EXPR:  op_name = "Or_else";  break;
    case TRUTH_XOR_EXPR:   op_name = "Xor";      break;
    case SYMDIFF_EXPR:     op_name = "SymDiff";  break;
    default:               op_name = NULL;  /* `Min', `Max', ... */
  }
  if (op_name)
    {
      tree func = get_operator (op_name, NULL, exp1, exp2, 0);
      if (func)
        return build_routine_call (func, tree_cons (NULL_TREE, exp1, build_tree_list (NULL_TREE, exp2)));
    }

  /* Call functions. */
  if (TREE_CODE (exp1) == FUNCTION_DECL)
    exp1 = probably_call_function (exp1);
  if (TREE_CODE (exp2) == FUNCTION_DECL)
    exp2 = probably_call_function (exp2);

  /* @@ This was in the parser before, but for overloaded operators both
        the type checking and the joining of `pow' and `**' is too early
        there (maur7.pas). It's probably not the best place here, but
        operator overloading will have to be rewritten, anyway, etc. ... */
  if (code == POWER_EXPR)
    {
      chk_dialect_name ("**", E_O_PASCAL);
      if (TREE_CODE (TREE_TYPE (exp2)) == INTEGER_TYPE)
        exp2 = convert (TREE_TYPE (real_zero_node), exp2);
      if (TREE_CODE (TREE_TYPE (exp2)) != REAL_TYPE)
        {
          error ("`**' exponent is not of real or integer type");
          return error_mark_node;
        }
    }
  else if (code == POW_EXPR)
    {
      if (TREE_CODE (TREE_TYPE (exp2)) != INTEGER_TYPE)
        {
          error ("`pow' exponent is not of integer type");
          return error_mark_node;
        }
    }
  else if (code == TRUTH_OR_EXPR)
    {
      if (TREE_CODE (TREE_TYPE (exp1)) == INTEGER_TYPE)
        {
          code = BIT_IOR_EXPR;
          chk_dialect ("bitwise `or' is", B_D_M_PASCAL);
        }
      else if (co->short_circuit)
        code = TRUTH_ORIF_EXPR;
    }
  else if (code == TRUTH_AND_EXPR)
    {
      if (TREE_CODE (TREE_TYPE (exp1)) == INTEGER_TYPE)
        {
          code = BIT_AND_EXPR;
          chk_dialect ("bitwise `and' is", B_D_M_PASCAL);
        }
      else if (co->short_circuit)
        code = TRUTH_ANDIF_EXPR;
    }
  else if (code == TRUTH_XOR_EXPR && TREE_CODE (TREE_TYPE (exp1)) == INTEGER_TYPE)
    {
      code = BIT_XOR_EXPR;
      chk_dialect ("bitwise `xor' is", B_D_M_PASCAL);
    }

  /* INTEGER_CSTs are of type `LongestCard', usually.
     Convert them to something smaller here.
     @@@@ Overloaded operators must be re-implemented! We must keep
     a list of operators, try to apply them using usual parameter
     conversions, trigger an error if it is ambiguous, use the
     default operator if there is no overloaded one. The same
     mechanism will work for overloaded functions. */
  if (TREE_CODE (TREE_TYPE (exp1)) == INTEGER_TYPE
      && TREE_CODE (TREE_TYPE (exp2)) == INTEGER_TYPE
      && code != RDIV_EXPR
      && code != RSHIFT_EXPR
      && code != LSHIFT_EXPR
      && code != TRUNC_MOD_EXPR
      && code != FLOOR_MOD_EXPR
      && code != EQ_EXPR
      && code != NE_EXPR
      && code != LE_EXPR
      && code != GE_EXPR
      && code != LT_EXPR
      && code != GT_EXPR)
    {
      tree common_integer_type = select_integer_type (exp1, exp2, code);
      exp1 = convert (common_integer_type, exp1);
      exp2 = convert (common_integer_type, exp2);
    }

  /* @@ Hmm? A left shift may require the last bit of LongestCard -- but
        then again, it might require a sign. At least use an unsigned
        type when we know the left operand is unsigned. In the general
        case (left operand is variable), it may depend on the actual value
        which type (if any) fits. -- Frank */
  if (TREE_CODE (TREE_TYPE (exp1)) == INTEGER_TYPE
      && TREE_CODE (TREE_TYPE (exp2)) == INTEGER_TYPE
      && code == LSHIFT_EXPR)
    {
      tree t = (TREE_UNSIGNED (exp1)
                || (TREE_CODE (exp1) == INTEGER_CST && !INT_CST_LT (exp1, integer_zero_node)))
               ? long_long_unsigned_type_node
               : long_long_integer_type_node;
      exp1 = convert (t, exp1);
    }

  /* Convert set constructors to sets. */
  if (t1 == CONSTRUCTOR && TREE_CODE (TREE_TYPE (exp1)) == SET_TYPE)
    exp1 = construct_set (exp1, NULL_TREE, 1);
  if (t2 == CONSTRUCTOR && TREE_CODE (TREE_TYPE (exp2)) == SET_TYPE)
    exp2 = construct_set (exp2, NULL_TREE, 1);

  CHK_EM (TREE_TYPE (exp1));
  CHK_EM (TREE_TYPE (exp2));
  t1 = TREE_CODE (TREE_TYPE (exp1));
  t2 = TREE_CODE (TREE_TYPE (exp2));

  if (code == POWER_EXPR || code == POW_EXPR)
    return build_predef_call ((code == POW_EXPR) ? p_pow : LEX_POWER,
             tree_cons (NULL_TREE, exp1, build_tree_list (NULL_TREE, exp2)));

  /* All string and char types are compatible in Extended Pascal. */
  if (is_string_compatible_type (exp1, 1)
      && is_string_compatible_type (exp2, 1)
      && (t1 != CHAR_TYPE || t2 != CHAR_TYPE || code == PLUS_EXPR))
    {
      int rts_code = 0;
      switch (code)
      {
        case EQ_EXPR: rts_code = '=';    break;
        case NE_EXPR: rts_code = LEX_NE; break;
        case LT_EXPR: rts_code = '<';    break;
        case LE_EXPR: rts_code = LEX_LE; break;
        case GT_EXPR: rts_code = '>';    break;
        case GE_EXPR: rts_code = LEX_GE; break;
        default:  /* NOTHING */;
      }
      if (rts_code)
        {
          if (t1 != t2 || !tree_int_cst_equal (PASCAL_STRING_LENGTH (exp1), PASCAL_STRING_LENGTH (exp2)))
            chk_dialect ("comparison of different string and char types is", NOT_CLASSIC_PASCAL);
          return build_predef_call (rts_code, tree_cons (NULL_TREE, exp1, build_tree_list (NULL_TREE, exp2)));
        }

      /* All string catenations are handled here. */
      if (code == PLUS_EXPR)
        {
          STRIP_TYPE_NOPS (exp1);
          STRIP_TYPE_NOPS (exp2);
          if ((TREE_CODE (exp1) == STRING_CST || TREE_CODE (exp1) == INTEGER_CST)
              && (TREE_CODE (exp2) == STRING_CST || TREE_CODE (exp2) == INTEGER_CST))
            {
              /* Concatenation of string constants.
                 Treat it in a special way to preserve constantness.
                 But first transform char constants to string constants
                 (not necessary anymore for those generated by the lexer
                 since it always generates string constants, but for
                 those actually declared as Pascal Char constants). */
              if (TREE_CODE (exp1) == INTEGER_CST)
                {
                  char buffer = TREE_INT_CST_LOW (exp1);
                  exp1 = build_string_constant (&buffer, 1, PASCAL_TREE_FRESH_CST (exp1));
                }
              if (TREE_CODE (exp2) == INTEGER_CST)
                {
                  char buffer = TREE_INT_CST_LOW (exp2);
                  exp2 = build_string_constant (&buffer, 1, PASCAL_TREE_FRESH_CST (exp2));
                }
              return combine_strings (chainon (build_tree_list (NULL_TREE, exp1), build_tree_list (NULL_TREE, exp2)), 0);
            }
          else
            {
              /* Length of the combined strings */
              tree len1 = PASCAL_STRING_LENGTH (exp1);
              tree len2 = PASCAL_STRING_LENGTH (exp2);
              tree length = build_binary_op (PLUS_EXPR, len1, len2, 0);

              /* Create a new string object */
              tree nstr = make_new_variable ("concat", build_pascal_string_schema (length));
              tree sval = PASCAL_STRING_VALUE (nstr);
              tree str_addr = build_unary_op (ADDR_EXPR, sval, 0);

              /* Assign the first string to the new object */
              if (t1 == CHAR_TYPE)
                expand_expr_stmt (
                  build_modify_expr (build_array_ref (sval, integer_one_node), NOP_EXPR, exp1));
              else
                expand_expr_stmt (build_memcpy (
                  str_addr, build1 (ADDR_EXPR, cstring_type_node, PASCAL_STRING_VALUE (exp1)), len1));

              /* Catenate the second string to the first */
              if (t2 == CHAR_TYPE)
                expand_expr_stmt (build_modify_expr (
                  build_array_ref (sval, build_binary_op (PLUS_EXPR, len1, integer_one_node, 0)), NOP_EXPR, exp2));
              else
                expand_expr_stmt (build_memcpy (
                  build (PLUS_EXPR, cstring_type_node, str_addr, len1, 0),
                  build1 (ADDR_EXPR, cstring_type_node, PASCAL_STRING_VALUE (exp2)), len2));

              /* Save the combined length of strings */
              expand_expr_stmt (build_modify_expr (PASCAL_STRING_LENGTH (nstr), NOP_EXPR, length));
              return non_lvalue (nstr);
            }
        }
    }

  if (code == IN_EXPR)
    {
      if (!ORDINAL_TYPE (TREE_CODE (TREE_TYPE (exp1))))
        {
          error ("left operand to `in' must be of ordinal type");
          return error_mark_node;
        }

      if (TREE_CODE (TREE_TYPE (exp2)) != SET_TYPE)
        {
          error ("right operand to `in' must be a set");
          return error_mark_node;
        }

      if (TREE_TYPE (exp2) == empty_set_type_node)
        {
          warning ("`... in []' (empty set) is always `False'.");
          if (TREE_SIDE_EFFECTS (exp1))
            warning (" Operand with side-effects is not evaluated.");
          return boolean_false_node;
        }

      if (!comptypes (TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (exp2))),
                      TYPE_MAIN_VARIANT (TREE_TYPE (exp1))))
        {
          error ("incompatible operands to `in'");
          return error_mark_node;
        }

      if (TREE_CODE (exp2) == CONSTRUCTOR)
        {
          /* Optimize `foo in [a, b .. c]' to become
             `(foo = a) or ((foo >= b) and (foo <= c))'
             (where foo is evaluated only once). */
          tree elem, result = NULL_TREE, exp = save_expr (exp1);
          for (elem = CONSTRUCTOR_ELTS (exp2); elem; elem = TREE_CHAIN (elem))
            {
              tree min_c = TREE_PURPOSE (elem);
              tree max_c = TREE_VALUE (elem);
              tree condition;

              STRIP_NOPS (min_c);
              STRIP_NOPS (max_c);

              /* !max_c: old-style set constructor, should not happen */
              assert (max_c);

              if (!comptypes (TYPE_MAIN_VARIANT (TREE_TYPE (exp1)), TYPE_MAIN_VARIANT (TREE_TYPE (min_c)))
                  || !comptypes (TYPE_MAIN_VARIANT (TREE_TYPE (exp1)), TYPE_MAIN_VARIANT (TREE_TYPE (max_c))))
                binary_op_error (code);

              if (max_c == min_c)
                /* This is a single element, not a range. */
                condition = build_pascal_binary_op (EQ_EXPR, exp, min_c);
              else
                {
                  /* This is a range. Avoid warning in the case
                     `<unsigned value> in [0 .. <whatever>]'. */
                  if (integer_zerop (min_c) && TREE_UNSIGNED (TREE_TYPE (exp)))
                    condition = build_pascal_binary_op (LE_EXPR, exp, max_c);
                  else
                    condition = build_pascal_binary_op (TRUTH_ANDIF_EXPR,
                                  build_pascal_binary_op (GE_EXPR, exp, min_c),
                                  build_pascal_binary_op (LE_EXPR, exp, max_c));
                }
              if (result)
                result = build_pascal_binary_op (TRUTH_ORIF_EXPR, result, condition);
              else
                result = condition;
            }
          assert (result);
          return result;
        }
      else
        /* No optimization possible. Create an RTS call. */
        return build_predef_call (p_in, tree_cons (NULL_TREE, exp1, build_tree_list (NULL_TREE, exp2)));
    }

  if (t1 == SET_TYPE && t2 == SET_TYPE)
    {
      int r_num = 0, negate = 0, empty1, empty2;
      tree result, temp;

      if (!comptypes (TYPE_MAIN_VARIANT (TREE_TYPE (exp1)), TYPE_MAIN_VARIANT (TREE_TYPE (exp2))))
        error ("operation on incompatible sets");
      if (code == LT_EXPR || code == GT_EXPR)
        chk_dialect ("`>' and `<' applied to sets are", GNU_PASCAL);
      if (code == SYMDIFF_EXPR)
        chk_dialect ("symmetric set difference is", E_O_PASCAL);

      if (TREE_CODE (exp1) == CONSTRUCTOR && TREE_CODE (exp2) == CONSTRUCTOR && code == PLUS_EXPR)
        return build_set_constructor (chainon (
          copy_list (CONSTRUCTOR_ELTS (exp1)), copy_list (CONSTRUCTOR_ELTS (exp2))));

      result = NULL_TREE;

      empty1 = TREE_TYPE (exp1) == empty_set_type_node;
      empty2 = TREE_TYPE (exp2) == empty_set_type_node;

      if (empty1)
        switch (code)
        {
          case PLUS_EXPR:
          case SYMDIFF_EXPR:
            warning ("Set operation has no effect.");
            return exp2;
          case MINUS_EXPR:
          case MULT_EXPR:
            warning ("Set operation always yields the empty set.");
            result = build_set_constructor (NULL_TREE);
            break;
          case GT_EXPR:
            warning ("`>' comparison of the empty set is always false.");
            result = boolean_false_node;
            break;
          case LE_EXPR:
            warning ("`<=' comparison of the empty set is always true.");
            result = boolean_true_node;
            break;
          case EQ_EXPR:
          case GE_EXPR:
            if (empty2)
              return boolean_true_node;
            r_num = p_Set_IsEmpty;
            exp1 = exp2;
            break;
          case NE_EXPR:
          case LT_EXPR:
            if (empty2)
              return boolean_false_node;
            r_num = p_Set_IsEmpty;
            exp1 = exp2;
            negate = 1;
            break;
          default: /* NOTHING */;
        }
      if (!result && !r_num && empty2)
        switch (code)
        {
          case PLUS_EXPR:
          case MINUS_EXPR:
          case SYMDIFF_EXPR:
            warning ("Set operation has no effect.");
            return exp1;
          case MULT_EXPR:
            warning ("Set operation always yields the empty set.");
            result = build_set_constructor (NULL_TREE);
            break;
          case LT_EXPR:
            warning ("`<' comparison against the empty set is always false.");
            result = boolean_false_node;
            break;
          case GE_EXPR:
            warning ("`>=' comparison against the empty set is always true.");
            result = boolean_true_node;
            break;
          case EQ_EXPR:
          case LE_EXPR:
            r_num = p_Set_IsEmpty;
            break;
          case NE_EXPR:
          case GT_EXPR:
            r_num = p_Set_IsEmpty;
            negate = 1;
            break;
          default: /* NOTHING */;
        }
      if (result)
        {
          if (TREE_SIDE_EFFECTS (empty1 ? exp2 : exp1))
            warning (" Operand with side-effects is not evaluated.");
          return result;
        }
      if (!r_num)
        switch (code)
        {
          case PLUS_EXPR:
            r_num = p_Set_Union;
            break;
          case MINUS_EXPR:
            r_num = p_Set_Diff;
            break;
          case MULT_EXPR:
            r_num = p_Set_Intersection;
            break;
          case SYMDIFF_EXPR:
            r_num = p_Set_SymDiff;
            break;
          case EQ_EXPR:
            r_num = p_Set_Equal;
            break;
          case NE_EXPR:
            r_num = p_Set_Equal;
            negate = 1;
            break;
          case LT_EXPR:
            r_num = p_Set_Less;
            break;
          case GT_EXPR:
            r_num = p_Set_Less;
            temp = exp1;
            exp1 = exp2;
            exp2 = temp;
            break;
          case LE_EXPR:
            r_num = p_Set_LE;
            break;
          case GE_EXPR:
            r_num = p_Set_LE;
            temp = exp1;
            exp1 = exp2;
            exp2 = temp;
            break;
          default:
            /* No other set operations are defined. */
            binary_op_error (code);
            return error_mark_node;
        }
      if (r_num == p_Set_IsEmpty)
        result = build_predef_call (r_num, build_tree_list (NULL_TREE, exp1));
      else
        result = build_predef_call (r_num, tree_cons (NULL_TREE, exp1, build_tree_list (NULL_TREE, exp2)));
      if (negate)
        result = build_pascal_unary_op (TRUTH_NOT_EXPR, result);
      return result;
    }

  if (!co->pointer_arithmetic
      && (t1 == POINTER_TYPE || t2 == POINTER_TYPE)
      && code != EQ_EXPR
      && code != NE_EXPR)
    {
      error ("only `=' and `<>' operators are allowed for pointers");
      ptrarith_inform ();
    }

  /* @@@@ Do some type-checking (fjf547*.pas). This is by far not enough. */
  switch (code)
  {
    case PLUS_EXPR:
      if ((!IS_NUMERIC (t1) || !IS_NUMERIC (t2))
          && (t1 != POINTER_TYPE || t2 != INTEGER_TYPE))
        binary_op_error (code);
      break;
    case MINUS_EXPR:
      if ((!IS_NUMERIC (t1) || !IS_NUMERIC (t2))
          && (t1 != POINTER_TYPE || (t2 != POINTER_TYPE && t2 != INTEGER_TYPE)))
        binary_op_error (code);
      break;
    case MULT_EXPR:
    case RDIV_EXPR:
    case TRUNC_DIV_EXPR:
    case TRUNC_MOD_EXPR:
    case FLOOR_MOD_EXPR:
    case POWER_EXPR:
    case LSHIFT_EXPR:
    case RSHIFT_EXPR:
      if (!IS_NUMERIC (t1) || !IS_NUMERIC (t2))
        binary_op_error (code);
      break;
    default: /* NOTHING */;
  }

  switch (code)
  {
    case RDIV_EXPR:
    case TRUNC_DIV_EXPR:
    case FLOOR_DIV_EXPR:
      if (integer_zerop (exp2))
        error_or_warning (pedantic || !(co->pascal_dialect & C_E_O_PASCAL), "division by zero");
      break;
    case FLOOR_MOD_EXPR:
      {
        tree temp;
        tree tu1 = unsigned_type (TREE_TYPE (exp1)), e1u;
        tree tu2 = unsigned_type (TREE_TYPE (exp2)), e2u;
        int side_effects1 = TREE_SIDE_EFFECTS (exp1);
        if (integer_zerop (exp2))
          error_or_warning (pedantic || !(co->pascal_dialect & C_E_O_PASCAL), "zero modulus");
        exp1 = save_expr (exp1);
        exp2 = save_expr (exp2);
        e1u = convert (tu1, exp1);
        e2u = convert (tu2, exp2);
        temp = build_binary_op (code, e1u, e2u, 0);
        /* @@@@ This is kind of a kludge for the case when signed
           and unsigned types are used together to avoid wrap-around
           (fjf434c.pas). It might be better to select a longer result
           type (unless both are the longest types already)-:. */
        if (!TREE_UNSIGNED (TREE_TYPE (exp1)))
          {
            /* (-exp1) mod exp2 */
            tree temp2 = save_expr (build_binary_op (code,
                           convert (tu1, build_unary_op (NEGATE_EXPR, exp1, 0)), e2u, 0));
            /* exp1 >= 0 ? exp1 mod exp2 : temp2 == 0 ? 0 : exp2 - temp2 */
            temp = build (COND_EXPR, tu2,
                     build_pascal_binary_op (GE_EXPR, exp1, integer_zero_node),
                     convert (tu2, temp),
                     build (COND_EXPR, tu2,
                       build_pascal_binary_op (EQ_EXPR, temp2, integer_zero_node),
                         convert (tu2, integer_zero_node),
                         convert (tu2, build_binary_op (MINUS_EXPR, e2u, temp2, 0))));
          }
        if (int_cst_lt_always (integer_zero_node, exp2))
          TREE_SIDE_EFFECTS (temp) = side_effects1;
        else
          temp = build (COND_EXPR, TREE_TYPE (temp),
                        build_pascal_binary_op (LE_EXPR, exp2, integer_zero_node),
                        build (COMPOUND_EXPR, TREE_TYPE (temp),
                          build_predef_call (p_ModRangeError, NULL_TREE),
                          integer_zero_node),
                        temp);
        return temp;
      }
    case TRUNC_MOD_EXPR:
      if (integer_zerop (exp2))
        error ("zero modulus");
      /* @@@@ This is kind of a kludge for the case when signed
         and unsigned types are used together to avoid wrap-around.
         (fjf434a.pas) It might be better to select a longer result
         type (unless both are the longest types already)-:. */
      if (!TREE_UNSIGNED (TREE_TYPE (exp2)))
        exp2 = convert (unsigned_type (TREE_TYPE (exp2)), build_unary_op (ABS_EXPR, exp2, 0));
      if (!TREE_UNSIGNED (TREE_TYPE (exp1)))
        {
          tree tu1 = unsigned_type (TREE_TYPE (exp1));
          tree ts1 = signed_type (TREE_TYPE (exp1));
          int side_effects = TREE_SIDE_EFFECTS (exp1) || TREE_SIDE_EFFECTS (exp2);
          exp1 = save_expr (exp1);
          exp2 = save_expr (exp2);
          result = build (COND_EXPR, ts1,
                     build_pascal_binary_op (GE_EXPR, exp1, integer_zero_node),
                     convert (ts1, build_binary_op (code, convert (tu1, exp1), exp2, 0)),
                     build_unary_op (NEGATE_EXPR,
                       convert (ts1,
                         build_binary_op (code,
                           convert (tu1, build_unary_op (NEGATE_EXPR, exp1, 0)),
                           exp2, 0)), 0));
          result = build (COMPOUND_EXPR, TREE_TYPE (result), exp2, result);
          TREE_SIDE_EFFECTS (result) = side_effects;
          return result;
        }
      break;
    default: /* NOTHING */;
  }

  /* Handle comparisons between signed and unsigned integers
     which the backend gets wrong (i.e., the C way) */
  switch (code)
  {
    case EQ_EXPR:
    case NE_EXPR:
    case LE_EXPR:
    case GE_EXPR:
    case LT_EXPR:
    case GT_EXPR:
      if (t1 == INTEGER_TYPE && t2 == INTEGER_TYPE
          && TREE_UNSIGNED (TREE_TYPE (exp1)) != TREE_UNSIGNED (TREE_TYPE (exp2)))
        {
          tree signed_exp;
          int lz;  /* 1: signed_exp < 0 means always True; 0: ... means always False */

          /* If one operand is constant and fits into the other's range, just convert it */
          tree tmp = fold (exp1);
          if (TREE_CODE (tmp) == INTEGER_CST)
            {
              tree tmp1 = convert (TREE_TYPE (exp2), tmp);
              tree tmp2 = fold (convert (TREE_TYPE (exp1), tmp1));
              if (!TREE_OVERFLOW (tmp2) && tree_int_cst_equal (tmp2, exp1))
                {
                  exp1 = tmp1;
                  break;
                }
            }
          tmp = fold (exp2);
          if (TREE_CODE (tmp) == INTEGER_CST)
            {
              tree tmp1 = convert (TREE_TYPE (exp1), tmp);
              tree tmp2 = fold (convert (TREE_TYPE (exp2), tmp1));
              if (!TREE_OVERFLOW (tmp2) && tree_int_cst_equal (tmp2, exp2))
                {
                  exp2 = tmp1;
                  break;
                }
            }
          if (TREE_UNSIGNED (TREE_TYPE (exp2)))
            {
              signed_exp = exp1 = save_expr (exp1);
              lz = code == NE_EXPR || code == LT_EXPR || code == LE_EXPR;
            }
          else
            {
              signed_exp = exp2 = save_expr (exp2);
              lz = code == NE_EXPR || code == GT_EXPR || code == GE_EXPR;
            }
          result = build_binary_op ((lz ? TRUTH_ORIF_EXPR : TRUTH_ANDIF_EXPR),
                     build_binary_op (code, exp1, exp2, 0),
                     build_binary_op ((lz ? LT_EXPR : GE_EXPR), signed_exp,
                       convert (TREE_TYPE (signed_exp), integer_zero_node), 0), 0);
          return result;
        }
      break;
    default: /* NOTHING */;
  }
  result = build_binary_op (code, exp1, exp2, 0);
  if (TREE_CODE_CLASS (TREE_CODE (result)) == 'c' && TREE_OVERFLOW (result))
    error ("arithmetical overflow");
  return result;
}

tree
build_pascal_unary_op (code, xarg)
     enum tree_code code;
     tree xarg;
{
  int fresh = TREE_CODE_CLASS (TREE_CODE (xarg)) == 'c' && PASCAL_TREE_FRESH_CST (xarg)
              && last_parenthesized_expression != xarg;
  int noconvert = 0;

  CHK_EM (xarg);

  if (PASCAL_TYPE_RESTRICTED (TREE_TYPE (xarg)))
    error ("invalid unary operation with restricted value");

  if (TREE_CODE (xarg) == FUNCTION_DECL)
    xarg = probably_call_function (xarg);

  if (code == TRUTH_NOT_EXPR && TREE_CODE (TREE_TYPE (xarg)) == INTEGER_TYPE)
    {
      chk_dialect ("bitwise `not' is", B_D_M_PASCAL);
      code = BIT_NOT_EXPR;
      noconvert = 1;
    }

  if (code == NEGATE_EXPR
      && TREE_CODE (TREE_TYPE (xarg)) == INTEGER_TYPE
      && (TREE_UNSIGNED (TREE_TYPE (xarg))
          || (TREE_CODE (xarg) == INTEGER_CST && !int_cst_lt_always (xarg, integer_zero_node))))
    {
      if (TREE_CODE (xarg) == INTEGER_CST)
        {
          /* Convert unsigned constants to signed ones here and do some trivial range checking. */
          if (TREE_UNSIGNED (TREE_TYPE (xarg))
              && INT_CST_LT_UNSIGNED (build_int_2 (0, (HOST_WIDE_INT) -1 << (HOST_BITS_PER_WIDE_INT - 1)), xarg))
            {
              error ("value does not fit in longest integer type");
              return integer_zero_node;
            }
          else
            {
              xarg = build_unary_op (code, convert (long_long_integer_type_node, xarg), 0);

              /* -16#8000000000000000 is no overflow, although
                  16#8000000000000000 does not fit in a signed integer type. */
              TREE_OVERFLOW (xarg) = 0;
            }
        }
      else if (!noconvert)
        xarg = build_unary_op (code, convert (select_signed_integer_type (TREE_TYPE (xarg)), xarg), noconvert);
    }
  else
    xarg = build_unary_op (code, xarg, noconvert);

  CHK_EM (xarg);
  if (TREE_CODE_CLASS (TREE_CODE (xarg)) == 'c')
    PASCAL_TREE_FRESH_CST (xarg) = fresh;
  return xarg;
}

/* Dereference a pointer. This may result in a function call. */
tree
build_pascal_pointer_reference (pointer)
     tree pointer;
{
  tree result, fun_type;
  CHK_EM (pointer);
  if (TREE_CODE (pointer) == TYPE_DECL)
    {
      error ("trying to dereference a type rather than an expression");
      return error_mark_node;
    }

  prediscriminate_schema (pointer);

  if (PASCAL_TYPE_RESTRICTED (TREE_TYPE (pointer)))
    error ("dereferencing a restricted pointer is not allowed");

  if (PASCAL_TYPE_FILE (TREE_TYPE (pointer)))
    result = build_buffer_ref (pointer, p_LazyTryGet);
  else if (MAYBE_CALL_FUNCTION (pointer)
           && (fun_type = (TREE_CODE (pointer) == FUNCTION_DECL
                           ? TREE_TYPE (pointer)
                           : TREE_TYPE (TREE_TYPE (pointer))),
               TYPE_ARG_TYPES (fun_type)
               && TREE_CODE (TREE_VALUE (TYPE_ARG_TYPES (fun_type))) == VOID_TYPE))
    {
      int function_calls = allow_function_calls (1);
      result = maybe_call_function (pointer, 1);
      allow_function_calls (function_calls);
      if (TREE_CODE (pointer) == FUNCTION_DECL)  /* direct function call */
        result = build_pascal_pointer_reference (result);
    }
  else
    {
      tree type = TREE_TYPE (pointer);
      if (TREE_CODE (pointer) == FUNCTION_DECL || CALL_METHOD (pointer))
        type = TREE_TYPE (type);
      if (TREE_CODE (pointer) != ADDR_EXPR
          && TREE_CODE (type) == POINTER_TYPE
          && TREE_CODE (TREE_TYPE (type)) == VOID_TYPE
          && !(co->pascal_dialect & B_D_PASCAL))
        {
          error ("dereferencing untyped pointer");
          return error_mark_node;
        }
      result = build_indirect_ref (pointer, "`^'");
    }
  DEREFERENCE_SCHEMA (result);
  return result;
}

tree
undo_schema_dereference (val)
     tree val;
{
  while (TREE_CODE (val) == COMPONENT_REF
         && TREE_CODE (TREE_OPERAND (val, 1)) == FIELD_DECL
         && DECL_NAME (TREE_OPERAND (val, 1)) == schema_id)
    val = TREE_OPERAND (val, 0);
  return val;
}

/* Return an expression for the address of FACTOR.
   In most cases, this is an ADDR_EXPR, but it may also be a cast of a
   reference to a pointer. */
tree
build_pascal_address_expression (factor, untyped)
     tree factor;
     int untyped;
{
  tree result;

  /* Undo a function call without parameters. Note: The first operand
     of the CALL_EXPR is already the address of the function. */
  if (TREE_CODE (factor) == CALL_EXPR && !TREE_OPERAND (factor, 1))
    {
      result = TREE_OPERAND (factor, 0);
      if (TREE_CODE (result) == ADDR_EXPR)
        /* build_routine_call does not do it, intentionally */
        mark_addressable (TREE_OPERAND (result, 0));
      return result;
    }

  /* build_unary_op accepts CONSTRUCTORs (for parameters), but the backend
     would later crash. Maybe it should be checked elsewhere, but it
     seems to work here. -- Frank */
  if (TREE_CODE (factor) == CONSTRUCTOR)
    {
      error ("reference expected, value given");
      return error_mark_node;
    }

  factor = undo_schema_dereference (factor);

  /* If `foo' is a procedure reference, `@foo' is a type cast to a procedure pointer. */
  if (PASCAL_PROCEDURAL_TYPE (TREE_TYPE (factor)))
    result = convert (build_pointer_type (TREE_TYPE (TREE_TYPE (factor))), factor);
  else
    {
      tree t;

      if (TREE_CODE (factor) == STRING_CST)
        {
          tree length = build_int_2 (TREE_STRING_LENGTH (factor) - 1, 0);
          factor = build_constructor (build_pascal_string_schema (length),
                     tree_cons (NULL_TREE, length,
                     tree_cons (NULL_TREE, length,
                     build_tree_list (NULL_TREE, factor))));
          /* Make this a valid lvalue for taking addresses. */
          TREE_CONSTANT (factor) = 1;
          TREE_STATIC (factor) = 1;
        }

      t = factor;
      while (TREE_CODE (t) == NOP_EXPR
             || TREE_CODE (t) == CONVERT_EXPR
             || TREE_CODE (t) == NON_LVALUE_EXPR
             || TREE_CODE (t) == COMPONENT_REF
             || TREE_CODE (t) == ARRAY_REF)
        t = TREE_OPERAND (t, 0);
      if (TREE_CODE (t) == VAR_DECL)
        PASCAL_VALUE_ASSIGNED (t) = 1;

      if (TREE_CODE_CLASS (TREE_CODE (t)) == 'c')
        {
          error ("trying to take the address of a constant");
          return error_mark_node;
        }

      /* Don't call build_pascal_unary_op() which would call the function. */
      result = build_unary_op (ADDR_EXPR, factor, 0);

      /* Mark constant addresses as such (for initialization). */
      if ((TREE_CODE (factor) == VAR_DECL || TREE_CODE (factor) == FUNCTION_DECL)
          && (!DECL_CONTEXT (factor)
              || (TREE_CODE (factor) == FUNCTION_DECL && DECL_NO_STATIC_CHAIN (factor))))
        TREE_CONSTANT (result) = 1;
    }

  if (untyped)
    result = convert (ptr_type_node, result);

  return result;
}

/* Special case where `@foo' can be an lvalue: If `foo' is a procedure
   reference, `@foo' is a type cast to a procedure pointer. */
tree
build_pascal_lvalue_address_expression (expr)
     tree expr;
{
  chk_dialect ("the address operator is", B_D_M_PASCAL);
  if (PASCAL_PROCEDURAL_TYPE (TREE_TYPE (expr)))
    return convert (build_pointer_type (TREE_TYPE (TREE_TYPE (expr))), expr);
  error ("using address expression as lvalue");
  return error_mark_node;
}

static int
is_pascal_loop_check (op)
     tree op;
{
  while (TREE_CODE (op) == NOP_EXPR
         || TREE_CODE (op) == CONVERT_EXPR
         || TREE_CODE (op) == NON_LVALUE_EXPR)
    op = TREE_OPERAND (op, 0);
  return TREE_CODE (op) == VAR_DECL && PASCAL_LOOP_BOUND (op);
}

/* Subroutine of build_binary_op, used for comparison operations.
   See if the operands have both been converted from subword integer types
   and, if so, perhaps change them both back to their original type.
   This function is also responsible for converting the two operands
   to the proper common type for comparison.

   The arguments of this function are all pointers to local variables
   of build_binary_op: OP0_PTR is &OP0, OP1_PTR is &OP1,
   RESTYPE_PTR is &RESULT_TYPE and RESCODE_PTR is &RESULTCODE.

   If this function returns nonzero, it means that the comparison has
   a constant value. What this function returns is an expression for
   that value. */
tree
shorten_compare (op0_ptr, op1_ptr, restype_ptr, rescode_ptr)
     tree *op0_ptr, *op1_ptr, *restype_ptr;
     enum tree_code *rescode_ptr;
{
  tree type, op0 = *op0_ptr, op1 = *op1_ptr, primop0, primop1;
  int unsignedp0, unsignedp1, real1, real2;
  enum tree_code code = *rescode_ptr;

  /* Throw away any conversions to wider types already present in the operands. */

  primop0 = get_narrower (op0, &unsignedp0);
  primop1 = get_narrower (op1, &unsignedp1);

  /* @@@@ This is probably wrong (or not optimal) in general, but it fixes
          couper1.pas; the whole stuff is just too confusing (seems to
          be still more C than Pascal) to make any sense of. :-( -- Frank */
  if (TYPE_PRECISION (TREE_TYPE (primop0)) % BITS_PER_UNIT != 0)
    {
      primop0 = op0;
      unsignedp0 = TREE_UNSIGNED (op0);
    }
  if (TYPE_PRECISION (TREE_TYPE (primop1)) % BITS_PER_UNIT != 0)
    {
      primop1 = op1;
      unsignedp1 = TREE_UNSIGNED (op1);
    }

  /* Handle the case that OP0 does not *contain* a conversion
     but it *requires* conversion to FINAL_TYPE. */

  if (op0 == primop0 && TREE_TYPE (op0) != *restype_ptr)
    unsignedp0 = TREE_UNSIGNED (TREE_TYPE (op0));
  if (op1 == primop1 && TREE_TYPE (op1) != *restype_ptr)
    unsignedp1 = TREE_UNSIGNED (TREE_TYPE (op1));

  /* If one of the operands must be floated, we cannot optimize. */
  real1 = TREE_CODE (TREE_TYPE (primop0)) == REAL_TYPE;
  real2 = TREE_CODE (TREE_TYPE (primop1)) == REAL_TYPE;

  /* If first arg is constant, swap the args (changing operation
     so value is preserved), for canonicalization. Don't do this if
     the second arg is 0. */

  if (TREE_CONSTANT (primop0) && !integer_zerop (primop1) && !real_zerop (primop1))
    {
      tree tem = primop0;
      int temi = unsignedp0;
      primop0 = primop1;
      primop1 = tem;
      tem = op0;
      op0 = op1;
      op1 = tem;
      *op0_ptr = op0;
      *op1_ptr = op1;
      unsignedp0 = unsignedp1;
      unsignedp1 = temi;
      temi = real1;
      real1 = real2;
      real2 = temi;

      switch (code)
      {
        case LT_EXPR:
          code = GT_EXPR;
          break;
        case GT_EXPR:
          code = LT_EXPR;
          break;
        case LE_EXPR:
          code = GE_EXPR;
          break;
        case GE_EXPR:
          code = LE_EXPR;
          break;
        default:
          break;
      }
      *rescode_ptr = code;
    }

  /* If comparing an integer against a constant more bits wide,
     maybe we can deduce a value of 1 or 0 independent of the data.
     Or else truncate the constant now
     rather than extend the variable at run time.

     This is only interesting if the constant is the wider arg.
     Also, it is not safe if the constant is unsigned and the
     variable arg is signed, since in this case the variable
     would be sign-extended and then regarded as unsigned.
     Our technique fails in this case because the lowest/highest
     possible unsigned results don't follow naturally from the
     lowest/highest possible values of the variable operand.
     For just EQ_EXPR and NE_EXPR there is another technique that
     could be used: see if the constant can be faithfully represented
     in the other operand's type, by truncating it and reextending it
     and see if that preserves the constant's value. */

  if (!real1 && !real2
      && TREE_CODE (primop1) == INTEGER_CST
      && TYPE_PRECISION (TREE_TYPE (primop0)) < TYPE_PRECISION (*restype_ptr))
    {
      int min_gt, max_gt, min_lt, max_lt;
      tree maxval, minval;
      /* 1 if comparison is nominally unsigned. */
      int unsignedp = TREE_UNSIGNED (*restype_ptr);
      tree val;

      type = signed_or_unsigned_type (unsignedp0, TREE_TYPE (primop0));

      maxval = TYPE_MAX_VALUE (type);
      minval = TYPE_MIN_VALUE (type);

      if (unsignedp && !unsignedp0)
        *restype_ptr = signed_type (*restype_ptr);

      if (TREE_TYPE (primop1) != *restype_ptr)
        primop1 = convert (*restype_ptr, primop1);
      if (type != *restype_ptr)
        {
          minval = convert (*restype_ptr, minval);
          maxval = convert (*restype_ptr, maxval);
        }

      if (unsignedp && unsignedp0)
        {
          min_gt = INT_CST_LT_UNSIGNED (primop1, minval);
          max_gt = INT_CST_LT_UNSIGNED (primop1, maxval);
          min_lt = INT_CST_LT_UNSIGNED (minval, primop1);
          max_lt = INT_CST_LT_UNSIGNED (maxval, primop1);
        }
      else
        {
          min_gt = INT_CST_LT (primop1, minval);
          max_gt = INT_CST_LT (primop1, maxval);
          min_lt = INT_CST_LT (minval, primop1);
          max_lt = INT_CST_LT (maxval, primop1);
        }

      val = NULL_TREE;
      /* This used to be a switch, but Genix compiler can't handle that. */
      if (code == NE_EXPR)
        {
          if (max_lt || min_gt)
            val = boolean_true_node;
        }
      else if (code == EQ_EXPR)
        {
          if (max_lt || min_gt)
            val = boolean_false_node;
        }
      else if (code == LT_EXPR)
        {
          if (max_lt)
            val = boolean_true_node;
          if (!min_lt)
            val = boolean_false_node;
        }
      else if (code == GT_EXPR)
        {
          if (min_gt)
            val = boolean_true_node;
          if (!max_gt)
            val = boolean_false_node;
        }
      else if (code == LE_EXPR)
        {
          if (!max_gt)
            val = boolean_true_node;
          if (min_gt)
            val = boolean_false_node;
        }
      else if (code == GE_EXPR)
        {
          if (!min_lt)
            val = boolean_true_node;
          if (max_lt)
            val = boolean_false_node;
        }

      /* If primop0 was sign-extended and unsigned comparison specd,
         we did a signed comparison above using the signed type bounds.
         But the comparison we output must be unsigned.

         Also, for inequalities, VAL is no good; but if the signed
         comparison had *any* fixed result, it follows that the
         unsigned comparison just tests the sign in reverse
         (positive values are LE, negative ones GE).
         So we can generate an unsigned comparison
         against an extreme value of the signed type. */

      if (unsignedp && !unsignedp0)
        {
          if (val)
            switch (code)
            {
              case LT_EXPR:
              case GE_EXPR:
                primop1 = TYPE_MIN_VALUE (type);
                val = NULL_TREE;
                break;

              case LE_EXPR:
              case GT_EXPR:
                primop1 = TYPE_MAX_VALUE (type);
                val = NULL_TREE;
                break;

              default:
                break;
            }
          type = unsigned_type (type);
        }

      /* Don't complain of the limited range comparisons when checking `for' loop bounds. */
      if (!is_pascal_loop_check (op0) && !max_gt && !unsignedp0 && TREE_CODE (primop0) != INTEGER_CST)
        {
          if (val == boolean_false_node)
            warning ("Comparison always yields `False' due to limited range of data type.");
          if (val == boolean_true_node)
            warning ("Comparison always yields `True' due to limited range of data type.");
        }

      if (!is_pascal_loop_check (op0) && !min_lt && unsignedp0 && TREE_CODE (primop0) != INTEGER_CST)
        {
          if (val == boolean_false_node)
            warning ("Comparison always yields `False' due to limited range of data type.");
          if (val == boolean_true_node)
            warning ("Comparison always yields `True' due to limited range of data type.");
        }

      if (val)
        {
          if (TREE_SIDE_EFFECTS (primop0))
            warning (" Operand with side-effects is not evaluated.");
          return val;
        }

      /* Value is not predetermined, but do the comparison
         in the type of the operand that is not constant.
         TYPE is already properly set. */
    }
  else if (real1 && real2
           && (TYPE_PRECISION (TREE_TYPE (primop0)) == TYPE_PRECISION (TREE_TYPE (primop1))))
    type = TREE_TYPE (primop0);

  /* If args' natural types are both narrower than nominal type
     and both extend in the same manner, compare them
     in the type of the wider arg.
     Otherwise must actually extend both to the nominal
     common type lest different ways of extending alter the result.
     (eg, (short) -1 == (unsigned short) -1  should be 0.) */

  else if (unsignedp0 == unsignedp1 && real1 == real2
           && TYPE_PRECISION (TREE_TYPE (primop0)) < TYPE_PRECISION (*restype_ptr)
           && TYPE_PRECISION (TREE_TYPE (primop1)) < TYPE_PRECISION (*restype_ptr))
    {
      type = common_type (TREE_TYPE (primop0), TREE_TYPE (primop1));
      type = signed_or_unsigned_type (unsignedp0 || TREE_UNSIGNED (*restype_ptr), type);
      /* Make sure shorter operand is extended the right way
         to match the longer operand. */
      primop0 = convert (signed_or_unsigned_type (unsignedp0, TREE_TYPE (primop0)), primop0);
      primop1 = convert (signed_or_unsigned_type (unsignedp1, TREE_TYPE (primop1)), primop1);
    }
  else
    {
      /* Here we must do the comparison on the nominal type
         using the args exactly as we received them. */
      type = *restype_ptr;
      primop0 = op0;
      primop1 = op1;

      if (!real1 && !real2 && integer_zerop (primop1)
          && TREE_UNSIGNED (*restype_ptr))
        {
          tree value = 0;
          switch (code)
          {
            case GE_EXPR:
              /* All unsigned values are >= 0, so we warn if extra warnings
                 are requested. However, if OP0 is a constant that is >= 0,
                 the signedness of the comparison isn't an issue, so suppress
                 the warning. */
              if (!is_pascal_loop_check (op0) && TREE_CODE (primop0) != INTEGER_CST)
                warning ("Comparison `unsigned value >= 0' always yields `True'.");
              value = boolean_true_node;
              break;

            case LT_EXPR:
              if (!is_pascal_loop_check (op0) && TREE_CODE (primop0) != INTEGER_CST)
                warning ("Comparison `unsigned value < 0' always yields `False'.");
              value = boolean_false_node;
              break;

            default:
              break;
          }

          if (value)
            {
              if (TREE_SIDE_EFFECTS (primop0))
                warning (" Operand with side-effects is not evaluated.");
              return value;
            }
        }
    }
  *op0_ptr = convert (type, primop0);
  *op1_ptr = convert (type, primop1);
  *restype_ptr = boolean_type_node;
  return 0;
}

/* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
   or validate its data type for an `if' or `while' statement or ?..: exp.
   This preparation consists of taking the ordinary
   representation of an expression expr and producing a valid tree
   boolean expression describing whether expr is nonzero. We could
   simply always do build_binary_op (NE_EXPR, expr, boolean_false_node, 1),
   but we optimize comparisons, &&, ||, and !.
   The resulting type should always be `boolean_type_node'. */
tree
truthvalue_conversion (expr)
     tree expr;
{
  CHK_EM (expr);
  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 TRUTH_XOR_EXPR:
    case TRUTH_NOT_EXPR:
      assert (TREE_TYPE (expr) == boolean_type_node);
      return expr;

    case INTEGER_CST:
      return integer_zerop (expr) ? boolean_false_node : boolean_true_node;

    case REAL_CST:
      return real_zerop (expr) ? boolean_false_node : boolean_true_node;

    case ADDR_EXPR:
      /* If we are taking the address of a external decl, it might be zero
         if it is weak, so we cannot optimize. */
      if (DECL_P (TREE_OPERAND (expr, 0)) && DECL_EXTERNAL (TREE_OPERAND (expr, 0)))
        break;
      return boolean_true_node;

    case COMPLEX_EXPR:
      return build_binary_op (TRUTH_ORIF_EXPR,
                              truthvalue_conversion (TREE_OPERAND (expr, 0)),
                              truthvalue_conversion (TREE_OPERAND (expr, 1)),
                              0);

    case NEGATE_EXPR:
    case ABS_EXPR:
    case FLOAT_EXPR:
    case FFS_EXPR:
      /* These don't change whether an object is non-zero or zero. */
      return truthvalue_conversion (TREE_OPERAND (expr, 0));

    case LROTATE_EXPR:
    case RROTATE_EXPR:
      /* These don't change whether an object (left operand) is zero or non-zero. */
      if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
        warning ("right operand to rotate operation has side-effects and is not evaluated");
      return truthvalue_conversion (TREE_OPERAND (expr, 0));

    case COND_EXPR:
      /* Distribute the conversion into the arms of a COND_EXPR. */
      return fold (build (COND_EXPR, boolean_type_node, TREE_OPERAND (expr, 0),
                          truthvalue_conversion (TREE_OPERAND (expr, 1)),
                          truthvalue_conversion (TREE_OPERAND (expr, 2))));

    case CONVERT_EXPR:
      /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
         since that affects how `default_conversion' will behave. */
      if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
          || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
        break;
      /* FALLTHROUGH */
    case NOP_EXPR:
      /* If this is widening the argument, we can ignore it. */
      if (TYPE_PRECISION (TREE_TYPE (expr)) >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
        return truthvalue_conversion (TREE_OPERAND (expr, 0));
      break;

    case MINUS_EXPR:
      /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize this case. */
      if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
          && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
        break;
      /* FALLTHROUGH */
    case BIT_XOR_EXPR:
      /* This and MINUS_EXPR can be changed into a comparison of the two objects. */
      if (TREE_TYPE (TREE_OPERAND (expr, 0)) == TREE_TYPE (TREE_OPERAND (expr, 1)))
        return build_binary_op (NE_EXPR, TREE_OPERAND (expr, 0), TREE_OPERAND (expr, 1), 1);
      return build_binary_op (NE_EXPR, TREE_OPERAND (expr, 0),
               fold (build1 (NOP_EXPR, TREE_TYPE (TREE_OPERAND (expr, 0)), TREE_OPERAND (expr, 1))), 1);

    case BIT_AND_EXPR:
      if (integer_onep (TREE_OPERAND (expr, 1)) && TREE_TYPE (expr) != boolean_type_node)
        /* Using convert here would cause infinite recursion. */
        return build1 (NOP_EXPR, boolean_type_node, expr);
      break;

    default:
      break;
  }

  if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
    return (build_binary_op
            (TRUTH_ORIF_EXPR,
             truthvalue_conversion (build_unary_op (REALPART_EXPR, expr, 0)),
             truthvalue_conversion (build_unary_op (IMAGPART_EXPR, expr, 0)),
             0));

  return build_binary_op (NE_EXPR, expr, integer_zero_node, 1);
}

/* Check if selected types are compatible in various contexts.
   Strings should not come here.
   @@@ Should perhaps rewrite the type checking functions
       instead of patching them like this, sigh. */
static int
compatible_types_p (type0, type1)
     tree type0, type1;
{
  return TREE_CODE (type0) == TREE_CODE (type1)
         && (TREE_CODE (type0) != ENUMERAL_TYPE || base_type (type0) == base_type (type1));
}

static int
compatible_relop_p (type0, type1)
     tree type0, type1;
{
  enum tree_code code0 = TREE_CODE (type0), code1 = TREE_CODE (type1);
  return compatible_types_p (type0, type1)
         || (code0 == REAL_TYPE && code1 == INTEGER_TYPE)
         || (code0 == INTEGER_TYPE && code1 == REAL_TYPE)
         || (code0 == COMPLEX_TYPE && (code1 == REAL_TYPE || code1 == INTEGER_TYPE))
         || ((code0 == REAL_TYPE || code0 == INTEGER_TYPE) && code1 == COMPLEX_TYPE);
}

/* Build a binary-operation expression without default conversions.
   CODE is the kind of expression to build.
   This function differs from `build' in several ways:
   the data type of the result is computed and recorded in it,
   warnings are generated if arg data types are invalid,
   special handling for addition and subtraction of pointers is known,
   and some optimization is done (operations on narrow ints
   are done in the narrower type when that gives the same result).
   Constant folding is also done before the result is returned. */
tree
build_binary_op (code, orig_op0, orig_op1, convert_p)
     enum tree_code code;
     tree orig_op0, orig_op1;
     int convert_p;
{
  enum tree_code code0, code1;
  tree type0, type1, op0, op1;

  /* Expression code to give to the expression when it is built.
     Normally this is CODE, which is what the caller asked for,
     but in some special cases we change it. */
  enum tree_code resultcode = code;

  /* Data type in which the computation is to be performed.
     In the simplest cases this is the common type of the arguments. */
  tree result_type = NULL;

  /* Nonzero means operands have already been type-converted
     in whatever way is necessary.
     Zero means they need to be converted to RESULT_TYPE. */
  int converted = 0;

  /* Nonzero means create the expression with this type, rather than
     RESULT_TYPE. */
  tree build_type = 0;

  /* Nonzero means after finally constructing the expression
     convert it to this type. */
  tree final_type = 0;

  /* Nonzero if this is an operation like MIN or MAX which can
     safely be computed in short if both args are promoted shorts.
     Also implies COMMON.
     -1 indicates a bitwise operation; this makes a difference
     in the exact conditions for when it is safe to do the operation
     in a narrower mode. */
  int shorten = 0;

  /* Nonzero if this is a comparison operation;
     if both args are promoted shorts, compare the original shorts.
     Also implies COMMON. */
  int short_compare = 0;

  /* Nonzero if this is a right-shift operation, which can be computed on the
     original short and then promoted if the operand is a promoted short. */
  int short_shift = 0;

  /* Nonzero means set RESULT_TYPE to the common type of the args. */
  int common = 0;

  if (convert_p)
    {
      op0 = default_conversion (orig_op0);
      op1 = default_conversion (orig_op1);
    }
  else
    {
      op0 = orig_op0;
      op1 = orig_op1;
    }

  type0 = TREE_TYPE (op0);
  type1 = TREE_TYPE (op1);

  /* If an error was already reported for one of the arguments,
     avoid reporting another error. */
  CHK_EM (type0);
  CHK_EM (type1);

  /* The expression codes of the data types of the arguments tell us
     whether the arguments are integers, floating, pointers, etc. */
  code0 = TREE_CODE (type0);
  code1 = TREE_CODE (type1);

  /* Strip NON_LVALUE_EXPRs, etc., since we aren't using as an lvalue. */
  STRIP_TYPE_NOPS (op0);
  STRIP_TYPE_NOPS (op1);

  switch (code)
  {
    case PLUS_EXPR:
      /* Handle the pointer + int case. */
      if (code0 == POINTER_TYPE && code1 == INTEGER_TYPE)
        return pointer_int_sum (PLUS_EXPR, op0, op1);
      else if (code1 == POINTER_TYPE && code0 == INTEGER_TYPE)
        return pointer_int_sum (PLUS_EXPR, op1, op0);
      else
        common = 1;
      break;

    case MINUS_EXPR:
      /* Subtraction of two similar pointers.
         We must subtract them as integers, then divide by object size. */
      if (code0 == POINTER_TYPE && code1 == POINTER_TYPE && comp_target_types (type0, type1))
        return pointer_diff (op0, op1);
      /* Handle pointer minus int. Just like pointer plus int. */
      else if (code0 == POINTER_TYPE && code1 == INTEGER_TYPE)
        return pointer_int_sum (MINUS_EXPR, op0, op1);
      else
        common = 1;
      break;

    case MULT_EXPR:
      common = 1;
      break;

    case RDIV_EXPR:
      if (INT_REAL (code0) && INT_REAL (code1))
        {
          if ((code0 == REAL_TYPE && TYPE_PRECISION (type0) > TYPE_PRECISION (double_type_node))
              || (code1 == REAL_TYPE && TYPE_PRECISION (type1) > TYPE_PRECISION (double_type_node)))
            result_type = long_double_type_node;
          else
            result_type = double_type_node;
          /* This is wrong, e.g., if exactly one operand is LongReal (fjf237.pas)
          converted = code0 != INTEGER_TYPE && code1 != INTEGER_TYPE; */
        }
      else if (IS_NUMERIC (code0) && IS_NUMERIC (code1))
        {
          result_type = complex_type_node;
          /* This is wrong if one operand is real and the other one is complex (maur4.pas)
          converted = 1; */
        }
      break;

    case TRUNC_DIV_EXPR:
    case CEIL_DIV_EXPR:
    case FLOOR_DIV_EXPR:
    case ROUND_DIV_EXPR:
    case EXACT_DIV_EXPR:
      if (code0 == INTEGER_TYPE && code1 == INTEGER_TYPE)
        {
          /* Although it would be tempting to shorten always here, that
             loses on some targets, since the modulo instruction is
             undefined if the quotient can't be represented in the
             computation mode. We shorten only if unsigned or if
             dividing by something we know != -1. */
          shorten = TREE_UNSIGNED (TREE_TYPE (orig_op0))
                    || (TREE_CODE (op1) == INTEGER_CST && !integer_all_onesp (op1));
          common = 1;
        }
      break;

    case BIT_AND_EXPR:
    case BIT_ANDTC_EXPR:
    case BIT_IOR_EXPR:
    case BIT_XOR_EXPR:
      if (code0 == INTEGER_TYPE && code1 == INTEGER_TYPE)
        shorten = -1;
      /* If one operand is a constant, and the other is a short type
         that has been converted to an int,
         really do the work in the short type and then convert the
         result to int. If we are lucky, the constant will be 0 or 1
         in the short type, making the entire operation go away. */
      if (TREE_CODE (op0) == INTEGER_CST
          && TREE_CODE (op1) == NOP_EXPR
          && TYPE_PRECISION (type1) > TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (op1, 0)))
          && TREE_UNSIGNED (TREE_TYPE (TREE_OPERAND (op1, 0))))
        {
          final_type = result_type;
          op1 = TREE_OPERAND (op1, 0);
          result_type = TREE_TYPE (op1);
        }
      if (TREE_CODE (op1) == INTEGER_CST
          && TREE_CODE (op0) == NOP_EXPR
          && TYPE_PRECISION (type0) > TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (op0, 0)))
          && TREE_UNSIGNED (TREE_TYPE (TREE_OPERAND (op0, 0))))
        {
          final_type = result_type;
          op0 = TREE_OPERAND (op0, 0);
          result_type = TREE_TYPE (op0);
        }
      if (code0 == SET_TYPE && code1 == SET_TYPE)
        {
          /* @@@@@ Check for set compatibility */
          converted = 1;
          result_type = TREE_TYPE (op0);
        }
      break;

    case TRUNC_MOD_EXPR:
    case FLOOR_MOD_EXPR:
      if (code0 == INTEGER_TYPE && code1 == INTEGER_TYPE)
        {
          /* Although it would be tempting to shorten always here, that loses
             on some targets, since the modulo instruction is undefined if the
             quotient can't be represented in the computation mode. We shorten
             only if unsigned or if dividing by something we know != -1. */
          shorten = TREE_UNSIGNED (TREE_TYPE (orig_op0))
                    || (TREE_CODE (op1) == INTEGER_CST && !integer_all_onesp (op1));
          common = 1;
        }
      break;

    case TRUTH_ANDIF_EXPR:
    case TRUTH_ORIF_EXPR:
    case TRUTH_AND_EXPR:
    case TRUTH_OR_EXPR:
    case TRUTH_XOR_EXPR:
      build_type = boolean_type_node;
      if (code0 == BOOLEAN_TYPE && code1 == BOOLEAN_TYPE)
        {
          result_type = boolean_type_node;
          op0 = truthvalue_conversion (op0);
          op1 = truthvalue_conversion (op1);
          converted = 1;
        }
      break;

    /* Shift operations: result has same type as first operand;
       always convert second operand to int.
       Also set SHORT_SHIFT if shifting rightward. */

    case RSHIFT_EXPR:
      if (code0 == INTEGER_TYPE && code1 == INTEGER_TYPE)
        {
          if (TREE_CODE (op1) == INTEGER_CST)
            {
              if (tree_int_cst_sgn (op1) < 0)
                warning ("right shift count is negative");
              else
                {
                  if (TREE_INT_CST_LOW (op1) | TREE_INT_CST_HIGH (op1))
                    short_shift = 1;
                  if (TREE_INT_CST_HIGH (op1) != 0
                      || ((unsigned HOST_WIDE_INT) TREE_INT_CST_LOW (op1) >= TYPE_PRECISION (type0)))
                    warning ("right shift count >= width of type");
                }
            }
          /* Use the type of the value to be shifted for the result. */
          result_type = type0;
          if (TYPE_MAIN_VARIANT (TREE_TYPE (op1)) != pascal_integer_type_node)
            op1 = convert (pascal_integer_type_node, op1);
          /* Avoid converting op1 to result_type later. */
          converted = 1;
        }
      break;

    case LSHIFT_EXPR:
      if (code0 == INTEGER_TYPE && code1 == INTEGER_TYPE)
        {
          result_type = TREE_UNSIGNED (op0) ? long_long_unsigned_type_node : long_long_integer_type_node;
          op0 = convert (result_type, op0);
          if (TREE_CODE (op1) == INTEGER_CST)
            {
              if (tree_int_cst_sgn (op1) < 0)
                warning ("left shift count is negative");
              else if (TREE_INT_CST_HIGH (op1) != 0
                       || ((unsigned HOST_WIDE_INT) TREE_INT_CST_LOW (op1) >= TYPE_PRECISION (result_type)))
                warning ("left shift count >= width of type");
            }
          if (TYPE_MAIN_VARIANT (TREE_TYPE (op1)) != pascal_integer_type_node)
            op1 = convert (pascal_integer_type_node, op1);
          /* Avoid converting op1 to result_type later. */
          converted = 1;
        }
      break;

    case RROTATE_EXPR:
    case LROTATE_EXPR:
      if (code0 == INTEGER_TYPE && code1 == INTEGER_TYPE)
        {
          if (TREE_CODE (op1) == INTEGER_CST)
            {
              if (tree_int_cst_sgn (op1) < 0)
                warning ("shift count is negative");
              else if (TREE_INT_CST_HIGH (op1) != 0
                       || ((unsigned HOST_WIDE_INT) TREE_INT_CST_LOW (op1) >= TYPE_PRECISION (type0)))
                warning ("shift count >= width of type");
            }
          /* Use the type of the value to be shifted.
             This is what most traditional C compilers do. */
          result_type = type0;
          /* Convert the shift-count to an integer, regardless of size of
             value being shifted. */
          if (TYPE_MAIN_VARIANT (TREE_TYPE (op1)) != pascal_integer_type_node)
            op1 = convert (pascal_integer_type_node, op1);
          /* Avoid converting op1 to result_type later. */
          converted = 1;
        }
      break;

    case EQ_EXPR:
    case NE_EXPR:
      if (co->warn_float_equal && (code0 == REAL_TYPE || code1 == REAL_TYPE))
        warning ("comparing real numbers with `=' or `<>' is unsafe");
      /* Result of comparison is always Boolean, but don't convert the args to Boolean. */
      build_type = boolean_type_node;
      if (ORDINAL_REAL_OR_COMPLEX_TYPE (code0) && compatible_relop_p (type0, type1))
        short_compare = 1;
      else if (code0 == ARRAY_TYPE && code1 == ARRAY_TYPE && comptypes (type0, type1))
        {
          if (!is_string_type (op0, 1) || !is_string_type (op1, 1))
            error ("comparison between arrays that are not of string type");
          else
            result_type = boolean_type_node;
          converted = 1;
        }
      else if (code0 == SET_TYPE && code1 == SET_TYPE)
        {
          result_type = boolean_type_node;
          converted = 1;
        }
      else if (code0 == POINTER_TYPE && code1 == POINTER_TYPE)
        {
          tree tt0 = TREE_TYPE (type0);
          tree tt1 = TREE_TYPE (type1);
          if (comp_target_types (type0, type1))
            result_type = common_type (type0, type1);
          else if (TYPE_MAIN_VARIANT (tt0) != void_type_node
                   && TYPE_MAIN_VARIANT (tt1) != void_type_node
                   && !comp_object_or_schema_pointer_types (tt0, tt1)
                   && !comp_object_or_schema_pointer_types (tt1, tt0))
            error ("comparison of incompatible pointer types");
          if (!result_type)
            result_type = ptr_type_node;
        }
      else if (code1 == REFERENCE_TYPE && TREE_CODE (TREE_TYPE (type1)) == FUNCTION_TYPE
               && code0 == POINTER_TYPE && integer_zerop (op0))
        result_type = type1;
      else if (code0 == REFERENCE_TYPE && TREE_CODE (TREE_TYPE (type0)) == FUNCTION_TYPE
               && ((code1 == POINTER_TYPE && integer_zerop (op1))
                   || (code1 == REFERENCE_TYPE && TREE_CODE (TREE_TYPE (type1)) == FUNCTION_TYPE
                       && strictly_comp_types (TREE_TYPE (type0), TREE_TYPE (type1)))))
        result_type = type0;
      break;

    case MAX_EXPR:
    case MIN_EXPR:
      if (ORDINAL_OR_REAL_TYPE (code0) && compatible_types_p (type0, type1))
        shorten = 1;
      else if (code0 == POINTER_TYPE && code1 == POINTER_TYPE)
        {
          if (comp_target_types (type0, type1))
            {
              result_type = common_type (type0, type1);
              if (TREE_CODE (TREE_TYPE (type0)) == FUNCTION_TYPE)
                warning ("ordered comparisons of pointers to functions");
            }
          else if (!comp_object_or_schema_pointer_types (TREE_TYPE (type0), TREE_TYPE (type1))
                   && !comp_object_or_schema_pointer_types (TREE_TYPE (type1), TREE_TYPE (type0)))
            {
              result_type = ptr_type_node;
              pedwarn ("comparison of distinct pointer types lacks a cast");
            }
        }
      break;

    case LE_EXPR:
    case GE_EXPR:
    case LT_EXPR:
    case GT_EXPR:
      build_type = boolean_type_node;
      if (ORDINAL_OR_REAL_TYPE (code0) && compatible_relop_p (type0, type1))
        {
          result_type = boolean_type_node;
          short_compare = 1;
        }
      else if (code0 == POINTER_TYPE && code1 == POINTER_TYPE)
        {
          if (comp_target_types (type0, type1))
            {
              result_type = common_type (type0, type1);
              if (COMPLETE_OR_VOID_TYPE_P (TREE_TYPE (type0))
                  != COMPLETE_OR_VOID_TYPE_P (TREE_TYPE (type1)))
                pedwarn ("comparison of complete and incomplete pointers");
              else if (pedantic && TREE_CODE (TREE_TYPE (type0)) == FUNCTION_TYPE)
                warning ("ordered comparision of pointers to functions");
            }
          else
            {
              result_type = ptr_type_node;
              pedwarn ("comparison of distinct pointer types lacks a cast");
            }
        }
      else if (code0 == ARRAY_TYPE && code1 == ARRAY_TYPE)
        {
          if (!is_string_type (op0, 1) || !is_string_type (op1, 1))
            error ("comparison between arrays that are not of string type");
          else
            result_type = boolean_type_node;
          converted = 1;
        }
      else if (code0 == SET_TYPE && code1 == SET_TYPE)
        {
          result_type = boolean_type_node;
          converted = 1;
        }
      break;

    case IN_EXPR:
      if (code0 == SET_TYPE
          && (type0 == empty_set_type_node
              || code1 == TREE_CODE (TREE_TYPE (type0))
              || (code1 == INTEGER_TYPE /* Maybe the set is of subrange type */
                  && TREE_TYPE (type1)
                  && TREE_TYPE (type1) == TREE_TYPE (type0)))) /* subrange of same type? */
        {
          /* expand_expr expects the left operand to be of integer type */
          if (type1 != pascal_integer_type_node)
            op1 = convert (pascal_integer_type_node, op1);
          result_type = boolean_type_node;
          converted = 1;
        }
      break;

    case CARD_EXPR:
      if (code0 == SET_TYPE)
        converted = 1; /* Don't convert anything */
      break;

    default:
      break;
  }

  if ((ORDINAL_REAL_OR_COMPLEX_TYPE (code0) && ORDINAL_REAL_OR_COMPLEX_TYPE (code1))
      || (code0 == SET_TYPE && code1 == SET_TYPE))
    {
      int none_complex = code0 != COMPLEX_TYPE && code1 != COMPLEX_TYPE;

      if (shorten || common || short_compare)
        result_type = common_type (type0, type1);

      /* For certain operations (which identify themselves by shorten != 0)
         if both args were extended from the same smaller type,
         do the arithmetic in that type and then extend.

         shorten !=0 and !=1 indicates a bitwise operation.
         For them, this optimization is safe only if
         both args are zero-extended or both are sign-extended.
         Otherwise, we might change the result.
         Eg, (short) -1 | (unsigned short) -1 is (int) -1
         but calculated in (unsigned short) it would be (unsigned short) -1. */

      if (shorten && none_complex)
        {
          int unsigned0, unsigned1;
          tree arg0 = get_narrower (op0, &unsigned0);
          tree arg1 = get_narrower (op1, &unsigned1);
          /* UNS is 1 if the operation to be done is an unsigned one. */
          int uns = TREE_UNSIGNED (result_type);
          tree type;

          final_type = result_type;

          /* Handle the case that OP0 (or OP1) does not *contain* a conversion
             but it *requires* conversion to FINAL_TYPE. */

          if ((TYPE_PRECISION (TREE_TYPE (op0)) == TYPE_PRECISION (TREE_TYPE (arg0)))
              && TREE_TYPE (op0) != final_type)
            unsigned0 = TREE_UNSIGNED (TREE_TYPE (op0));
          if ((TYPE_PRECISION (TREE_TYPE (op1)) == TYPE_PRECISION (TREE_TYPE (arg1)))
              && TREE_TYPE (op1) != final_type)
            unsigned1 = TREE_UNSIGNED (TREE_TYPE (op1));

          /* Now UNSIGNED0 is 1 if ARG0 zero-extends to FINAL_TYPE. */

          /* For bitwise operations, signedness of nominal type
             does not matter. Consider only how operands were extended. */
          if (shorten == -1)
            uns = unsigned0;

          /* Note that in all three cases below we refrain from optimizing
             an unsigned operation on sign-extended args.
             That would not be valid. */

          /* Both args variable: if both extended in same way
             from same width, do it in that width.
             Do it unsigned if args were zero-extended. */
          if ((TYPE_PRECISION (TREE_TYPE (arg0)) < TYPE_PRECISION (result_type))
              && (TYPE_PRECISION (TREE_TYPE (arg1)) == TYPE_PRECISION (TREE_TYPE (arg0)))
              && unsigned0 == unsigned1
              && (unsigned0 || !uns))
            result_type = signed_or_unsigned_type (unsigned0,
              common_type (TREE_TYPE (arg0), TREE_TYPE (arg1)));
          else if (TREE_CODE (arg0) == INTEGER_CST
                   && (unsigned1 || !uns)
                   && (TYPE_PRECISION (TREE_TYPE (arg1)) < TYPE_PRECISION (result_type))
                   && (type = signed_or_unsigned_type (unsigned1, TREE_TYPE (arg1)),
                       int_fits_type_p (arg0, type)))
            result_type = type;
          else if (TREE_CODE (arg1) == INTEGER_CST
                   && (unsigned0 || !uns)
                   && (TYPE_PRECISION (TREE_TYPE (arg0)) < TYPE_PRECISION (result_type))
                   && (type = signed_or_unsigned_type (unsigned0, TREE_TYPE (arg0)),
                       int_fits_type_p (arg1, type)))
            result_type = type;
        }

      /* Shifts can be shortened if shifting right. */

      if (short_shift)
        {
          int unsigned_arg;
          tree arg0 = get_narrower (op0, &unsigned_arg);

          final_type = result_type;

          if (arg0 == op0 && final_type == TREE_TYPE (op0))
            unsigned_arg = TREE_UNSIGNED (TREE_TYPE (op0));

          if (TYPE_PRECISION (TREE_TYPE (arg0)) < TYPE_PRECISION (result_type)
              /* We can shorten only if the shift count is less than the
                 number of bits in the smaller type size. */
              && !TREE_INT_CST_HIGH (op1)
              && TYPE_PRECISION (TREE_TYPE (arg0)) > TREE_INT_CST_LOW (op1)
              /* If arg is sign-extended and then unsigned-shifted,
                 we can simulate this with a signed shift in arg's type
                 only if the extended result is at least twice as wide
                 as the arg. Otherwise, the shift could use up all the
                 ones made by sign-extension and bring in zeros.
                 We can't optimize that case at all, but in most machines
                 it never happens because available widths are 2**N. */
              && (!TREE_UNSIGNED (final_type)
                  || unsigned_arg
                  || 2 * TYPE_PRECISION (TREE_TYPE (arg0)) <= TYPE_PRECISION (result_type)))
            {
              /* Do an unsigned shift if the operand was zero-extended. */
              result_type = signed_or_unsigned_type (unsigned_arg, TREE_TYPE (arg0));
              /* Convert value-to-be-shifted to that type. */
              if (TREE_TYPE (op0) != result_type)
                op0 = convert (result_type, op0);
              converted = 1;
            }
        }

      /* Comparison operations are shortened too but differently.
         They identify themselves by setting short_compare = 1. */

      if (short_compare)
        {
          /* Don't write &op0, etc., because that would prevent op0
             from being kept in a register.
             Instead, make copies of the our local variables and
             pass the copies by reference, then copy them back afterward. */
          int unsignedp0, unsignedp1;
          tree primop0, primop1;
          tree xop0 = op0, xop1 = op1, xresult_type = result_type;
          enum tree_code xresultcode = resultcode;
          tree val = shorten_compare (&xop0, &xop1, &xresult_type, &xresultcode);
          if (val)
            return build_type ? convert (build_type, val) : val;
          op0 = xop0, op1 = xop1;
          converted = 1;
          resultcode = xresultcode;

          primop0 = get_narrower (op0, &unsignedp0);
          primop1 = get_narrower (op1, &unsignedp1);

          /* Warn if two unsigned values are being compared in a size
             larger than their original size, and one (and only one) is the
             result of a `not' operator. This comparison will always fail.

             Also warn if one operand is a constant, and the constant
             does not have all bits set that are set in the `not' operand
             when it is extended. */

          if ((TREE_CODE (primop0) == BIT_NOT_EXPR) != (TREE_CODE (primop1) == BIT_NOT_EXPR))
            {
              if (TREE_CODE (primop0) == BIT_NOT_EXPR)
                primop0 = get_narrower (TREE_OPERAND (primop0, 0), &unsignedp0);
              else
                primop1 = get_narrower (TREE_OPERAND (primop1, 0), &unsignedp1);

              if (TREE_CODE (primop0) == INTEGER_CST || TREE_CODE (primop1) == INTEGER_CST)
                {
                  tree primop;
                  long constant, mask;
                  int unsignedp, bits;

                  if (TREE_CODE (primop0) == INTEGER_CST)
                    {
                      primop = primop1;
                      unsignedp = unsignedp1;
                      constant = TREE_INT_CST_LOW (primop0);
                    }
                  else
                    {
                      primop = primop0;
                      unsignedp = unsignedp0;
                      constant = TREE_INT_CST_LOW (primop1);
                    }

                  bits = TYPE_PRECISION (TREE_TYPE (primop));
                  if (bits < TYPE_PRECISION (result_type) && bits < HOST_BITS_PER_LONG && unsignedp)
                    {
                      mask = (~0L) << bits;
                      if ((mask & constant) != mask)
                        warning ("comparison of promoted `not' unsigned with constant");
                    }
                }
              else if (unsignedp0 && unsignedp1
                       && (TYPE_PRECISION (TREE_TYPE (primop0)) < TYPE_PRECISION (result_type))
                       && (TYPE_PRECISION (TREE_TYPE (primop1)) < TYPE_PRECISION (result_type)))
                warning ("comparison of promoted `not' unsigned with unsigned");
            }
        }
    }

  /* At this point, RESULT_TYPE must be nonzero to avoid an error message.
     If CONVERTED is zero, both args will be converted to type RESULT_TYPE.
     Then the expression will be built.
     It will be given type FINAL_TYPE if that is nonzero;
     otherwise, it will be given type RESULT_TYPE. */

  if (!result_type)
    {
      binary_op_error (code);
      return error_mark_node;
    }

  if (!converted)
    {
      if (TREE_TYPE (op0) != result_type)
        op0 = convert (result_type, op0);
      if (TREE_TYPE (op1) != result_type)
        op1 = convert (result_type, op1);
    }

  if (!build_type)
    build_type = result_type;

  {
    tree result = build (resultcode, build_type, op0, op1);
    tree folded = fold (result);
    if (folded == result)
      TREE_CONSTANT (folded) = TREE_CONSTANT (op0) && TREE_CONSTANT (op1);
    if (final_type)
      return convert (final_type, folded);
    return folded;
  }
}

/* Compute the size to increment a pointer by. */
static tree
c_size_in_bytes (type)
     tree type;
{
  enum tree_code code = TREE_CODE (type);
  tree t;
  if (code == FUNCTION_TYPE || code == VOID_TYPE || EM (type))
    return size_int (1);
  if (!TYPE_SIZE (type))
    {
      error ("arithmetic on pointer to an incomplete type");
      return size_int (1);
    }
  /* Convert in case a char is more than one unit. */
#ifdef EGCS
  t = size_binop (CEIL_DIV_EXPR, TYPE_SIZE_UNIT (type),
                  size_int (TYPE_PRECISION (byte_integer_type_node) / BITS_PER_UNIT));
#else
  t = size_binop (CEIL_DIV_EXPR, TYPE_SIZE (type), size_int (BITS_PER_UNIT));
#endif
  force_fit_type (t, 0);
  return t;
}

/* Return a tree for the sum or difference (RESULTCODE says which)
   of pointer PTROP and integer INTOP. */
static tree
pointer_int_sum (resultcode, ptrop, intop)
     enum tree_code resultcode;
     tree ptrop, intop;
{
  tree size_exp, result, folded;

  /* The result is a pointer of the same type that is being added. */
  tree result_type = TREE_TYPE (ptrop);

  if (TREE_CODE (TREE_TYPE (result_type)) == VOID_TYPE)
    {
      warning ("untyped pointer used in arithmetic");
      size_exp = integer_one_node;
    }
  else if (TREE_CODE (TREE_TYPE (result_type)) == FUNCTION_TYPE)
    {
      warning ("pointer to a function used in arithmetic");
      size_exp = integer_one_node;
    }
  else
    size_exp = c_size_in_bytes (TREE_TYPE (result_type));

  /* If what we are about to multiply by the size of the elements
     contains a constant term, apply distributive law
     and multiply that constant term separately.
     This helps produce common subexpressions. */
  if ((TREE_CODE (intop) == PLUS_EXPR || TREE_CODE (intop) == MINUS_EXPR)
      && !TREE_CONSTANT (intop)
      && TREE_CONSTANT (TREE_OPERAND (intop, 1))
      && TREE_CONSTANT (size_exp)
      /* If the constant comes from pointer subtraction,
         skip this optimization--it would cause an error. */
      && TREE_CODE (TREE_TYPE (TREE_OPERAND (intop, 0))) == INTEGER_TYPE
      /* If the constant is unsigned, and smaller than the pointer size,
         then we must skip this optimization. This is because it could cause
         an overflow error if the constant is negative but INTOP is not. */
      && (!TREE_UNSIGNED (TREE_TYPE (intop))
          || (TYPE_PRECISION (TREE_TYPE (intop)) == TYPE_PRECISION (TREE_TYPE (ptrop)))))
    {
      enum tree_code subcode = resultcode;
      tree int_type = TREE_TYPE (intop);
      if (TREE_CODE (intop) == MINUS_EXPR)
        subcode = (subcode == PLUS_EXPR ? MINUS_EXPR : PLUS_EXPR);
      /* Convert both subexpression types to the type of intop,
         because weird cases involving pointer arithmetic
         can result in a sum or difference with different type args. */
      ptrop = build_binary_op (subcode, ptrop, convert (int_type, TREE_OPERAND (intop, 1)), 1);
      intop = convert (int_type, TREE_OPERAND (intop, 0));
    }

  /* Convert the integer argument to a type the same size as sizetype
     so the multiply won't overflow spuriously. */
  if (TYPE_PRECISION (TREE_TYPE (intop)) != TYPE_PRECISION (sizetype)
      || TREE_UNSIGNED (TREE_TYPE (intop)) != TREE_UNSIGNED (sizetype))
    intop = convert (type_for_size (TYPE_PRECISION (sizetype), TREE_UNSIGNED (sizetype)), intop);

  /* Replace the integer argument with a suitable product by the object size.
     Do this multiplication as signed, then convert to the appropriate
     pointer type (actually unsigned integral). */
  intop = convert (result_type,
                   build_binary_op (MULT_EXPR, intop, convert (TREE_TYPE (intop), size_exp), 1));

  /* Create the sum or difference. */
  result = build (resultcode, result_type, ptrop, intop);

  folded = fold (result);
  if (folded == result)
    TREE_CONSTANT (folded) = TREE_CONSTANT (ptrop) & TREE_CONSTANT (intop);
  return folded;
}

/* Return a tree for the difference of pointers OP0 and OP1.
   The resulting tree has type int. */
static tree
pointer_diff (op0, op1)
     tree op0, op1;
{
  tree result, folded;
  tree restype = ptrdiff_type_node;
  tree target_type = TREE_TYPE (TREE_TYPE (op0));

  if (TREE_CODE (target_type) == VOID_TYPE)
    warning ("untyped pointer used in pointer difference");
  if (TREE_CODE (target_type) == FUNCTION_TYPE)
    warning ("pointer to a function used in pointer difference");

  /* First do the subtraction as integers; then drop through to
     build the divide operator. Do not do default conversions
     on the minus operator in case restype is a short type. */
  op0 = build_binary_op (MINUS_EXPR, convert (restype, op0), convert (restype, op1), 0);
  /* This generates an error if op1 is pointer to incomplete type. */
  if (!TYPE_SIZE (TREE_TYPE (TREE_TYPE (op1)))
      && TREE_CODE (TREE_TYPE (TREE_TYPE (op1))) != VOID_TYPE)
    error ("arithmetic on pointer to an incomplete type");

  /* This generates an error if op0 is pointer to incomplete type. */
  op1 = c_size_in_bytes (target_type);

  /* Divide by the size, in easiest possible way. */
  result = build (EXACT_DIV_EXPR, restype, op0, convert (restype, op1));

  folded = fold (result);
  if (folded == result)
    TREE_CONSTANT (folded) = TREE_CONSTANT (op0) & TREE_CONSTANT (op1);
  return folded;
}

/* Construct and perhaps optimize a tree representation
   for a unary operation. CODE, a tree_code, specifies the operation
   and XARG is the operand. NOCONVERT nonzero suppresses
   the default promotions (such as from short to int), except for
   ADDR_EXPR where it means not to warn about packed fields, 2 means
   not even to require an lvalue. */
tree
build_unary_op (code, xarg, noconvert)
     enum tree_code code;
     tree xarg;
     int noconvert;
{
  /* No default_conversion here. It causes trouble for ADDR_EXPR. */
  tree arg = xarg, addr, argtype = 0;
  enum tree_code typecode = TREE_CODE (TREE_TYPE (arg));
  const char *errstring = NULL;

  CHK_EM (TREE_TYPE (arg));

  switch (code)
  {
    case CONVERT_EXPR:
      /* This is used for unary plus, because a CONVERT_EXPR
         is enough to prevent anybody from looking inside for
         associativity, but won't generate any code. */
      if (!IS_NUMERIC (typecode))
        errstring = "wrong type of argument to unary `+'";
      else if (!noconvert)
        arg = default_conversion (arg);
      break;

    case NEGATE_EXPR:
      if (!IS_NUMERIC (typecode))
        errstring = "wrong type of argument to unary `-'";
      else
        {
          if (!noconvert)
            arg = default_conversion (arg);

          /* If this is an unsigned integer subrange make sure
             the negated arg can be represented in the result type. */
          if (typecode == INTEGER_TYPE && TREE_TYPE (TREE_TYPE (arg)))
            argtype = type_for_size (TYPE_PRECISION (TREE_TYPE (arg)), 0);
        }
      break;

    case BIT_NOT_EXPR:
      if (typecode != INTEGER_TYPE)
        errstring = "wrong type of argument to bitwise `not'";
      else if (!noconvert)
        arg = default_conversion (arg);
      break;

    case ABS_EXPR:
      if (!IS_NUMERIC (typecode))
        errstring = "wrong type of argument to `Abs'";
      else if (!noconvert)
        arg = default_conversion (arg);
      break;

    case CONJ_EXPR:
      /* Conjugating a real value is a no-op, but allow it anyway. */
      if (!IS_NUMERIC (typecode))
        errstring = "wrong type of argument to conjugation";
      else if (!noconvert)
        arg = default_conversion (arg);
      break;

    case TRUTH_NOT_EXPR:
      if (typecode != BOOLEAN_TYPE)
        errstring = "wrong type of argument to Boolean `not'";
      else
        return invert_truthvalue (truthvalue_conversion (arg));

    case NOP_EXPR:
      break;

    case REALPART_EXPR:
      if (TREE_CODE (arg) == COMPLEX_CST)
        return TREE_REALPART (arg);
      else if (TREE_CODE (TREE_TYPE (arg)) == COMPLEX_TYPE)
        return fold (build1 (REALPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg));
      else
        return arg;

    case IMAGPART_EXPR:
      if (TREE_CODE (arg) == COMPLEX_CST)
        return TREE_IMAGPART (arg);
      else if (TREE_CODE (TREE_TYPE (arg)) == COMPLEX_TYPE)
        return fold (build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg));
      else
        return convert (TREE_TYPE (arg), integer_zero_node);

    case ADDR_EXPR:
      /* Note that this operation never does default_conversion
         regardless of NOCONVERT which has a different meaning here. */

      /* Let &* cancel out to simplify resulting code. */
      if (TREE_CODE (arg) == INDIRECT_REF)
        {
          /* Don't let this be an lvalue. */
          if (lvalue_p (TREE_OPERAND (arg, 0)))
            return non_lvalue (TREE_OPERAND (arg, 0));
          return TREE_OPERAND (arg, 0);
        }

      /* For &x[y], return x+y */
      if (TREE_CODE (arg) == ARRAY_REF)
        {
          tree index, array = TREE_OPERAND (arg, 0);

          if (!mark_addressable2 (array, !!noconvert))
            return error_mark_node;

          if (!noconvert && PASCAL_TYPE_PACKED (TREE_TYPE (TREE_OPERAND (arg, 0))))
            chk_dialect ("this use of packed array components is", B_D_M_PASCAL);

          /* Kenner's get_inner_reference() code affected also this
             -- Interesting. So what? -- Frank */

          /* Pascal arrays are not pointers. */
          index = default_conversion (TREE_OPERAND (arg, 1));
          if (TREE_CODE (TREE_TYPE (index)) != INTEGER_TYPE
              && ORDINAL_TYPE (TREE_CODE (TREE_TYPE (index))))
            index = convert (pascal_integer_type_node, index);

          return build_binary_op (PLUS_EXPR, convert_array_to_pointer (array),
            fold (build (MINUS_EXPR, TREE_TYPE (index), index,
                         TYPE_MIN_VALUE (TYPE_DOMAIN (TREE_TYPE (array))))), 0);
        }

      if (TREE_CODE (arg) == COND_EXPR)
        {
          tree op1 = build_unary_op (ADDR_EXPR, TREE_OPERAND (arg, 1), noconvert);
          tree op2 = build_unary_op (ADDR_EXPR, TREE_OPERAND (arg, 2), noconvert);
          CHK_EM (op1);
          CHK_EM (op2);
          return build (COND_EXPR, TREE_TYPE (op1), TREE_OPERAND (arg, 0), op1, op2);
        }

      if (TREE_CODE (arg) == COMPOUND_EXPR)
        {
          tree real_result = build_unary_op (ADDR_EXPR, TREE_OPERAND (arg, 1), noconvert);
          return build (COMPOUND_EXPR, TREE_TYPE (real_result), TREE_OPERAND (arg, 0), real_result);
        }

      /* Addresses of constructors are needed for parameters. */
      if (TREE_CODE (arg) == CONSTRUCTOR)
        {
          if (!TREE_CONSTANT (arg))
            {
              /* Create a temporary variable for non-constant constructors. */
              tree temp = make_new_variable ("structured_value", TREE_TYPE (arg));
              expand_expr_stmt (build_modify_expr (temp, NOP_EXPR, arg));
              arg = temp;
            }
        }
      else if (TREE_CODE (arg) == NOP_EXPR || TREE_CODE (arg) == CONVERT_EXPR)
        /* Address of a cast is just a cast of the address of the operand of the cast. */
        return convert (build_pointer_type (TREE_TYPE (arg)),
                        build_unary_op (ADDR_EXPR, TREE_OPERAND (arg, 0), noconvert));
      else if (typecode != FUNCTION_TYPE && TREE_CODE (arg) != STRING_CST && noconvert < 2 && !lvalue_p (arg))
        {
          error ("reference expected, value given");
          return error_mark_node;
        }

      /* Ordinary case; arg is a COMPONENT_REF or a decl. */
      argtype = TREE_TYPE (arg);

      /* If the lvalue is const or volatile, merge that into the type
         to which the address will point. Note that you can't get a
         restricted pointer by taking the address of something, so we
         only have to deal with `const' and `volatile' here. */
      if ((DECL_P (arg) || TREE_CODE_CLASS (TREE_CODE (arg)) == 'r')
          && (TREE_READONLY (arg) || TREE_THIS_VOLATILE (arg)))
        argtype = c_build_type_variant (argtype, TREE_READONLY (arg), TREE_THIS_VOLATILE (arg));

      argtype = build_pointer_type (argtype);

      if (!mark_addressable2 (arg, !!noconvert))
        return error_mark_node;

      if (TREE_CODE (arg) == BIT_FIELD_REF && PASCAL_TYPE_PACKED (TREE_TYPE (TREE_OPERAND (arg, 0))))
        error ("invalid use of component of packed array `%s'",
               IDENTIFIER_NAME (DECL_NAME (TREE_OPERAND (arg, 0))));

      if (TREE_CODE (arg) == COMPONENT_REF)
        {
          tree field = TREE_OPERAND (arg, 1);
          if (!noconvert && PASCAL_TYPE_PACKED (TREE_TYPE (TREE_OPERAND (arg, 0))))
            chk_dialect ("this use of packed record fields is", B_D_PASCAL);

          if (!noconvert && DECL_PACKED_FIELD (field))
            {
              error ("invalid use of field `%s' of packed record `%s'",
                     IDENTIFIER_NAME (DECL_NAME (field)),
                     IDENTIFIER_NAME (DECL_NAME (TREE_OPERAND (arg, 0))));
              return error_mark_node;
            }

          addr = convert (argtype, build_unary_op (ADDR_EXPR, TREE_OPERAND (arg, 0), noconvert));
#ifndef EGCS97
          if (!integer_zerop (bit_position (field)))
            {
              tree offset = size_binop (EXACT_DIV_EXPR, bit_position (field), bitsize_int (BITS_PER_UNIT));
              /* int flag = TREE_CONSTANT (addr); */
              addr = fold (build (PLUS_EXPR, argtype, addr, convert (argtype, offset)));
              /* TREE_CONSTANT (addr) = flag; */
            }
#else
          addr = fold (build (PLUS_EXPR, argtype, addr, convert (argtype, byte_position (field))));
#endif
        }
      else
        addr = build1 (code, argtype, arg);

      /* Address of a static or external variable or file-scope function counts as a constant. */
      if (staticp (arg) && !(TREE_CODE (arg) == FUNCTION_DECL && DECL_CONTEXT (arg) && !DECL_NO_STATIC_CHAIN (arg)))
        TREE_CONSTANT (addr) = 1;
      return addr;

    default:
      assert (0);
      break;
  }

  if (!errstring)
    {
      if (!argtype)
        argtype = TREE_TYPE (arg);
      return fold (build1 (code, argtype, arg));
    }

  error (errstring);
  return error_mark_node;
}

/* Build an expression representing a cast to type TYPE of expression EXPR. */
tree
build_type_cast (type, value)
     tree type, value;
{
  tree otype, ovalue;

  CHK_EM (type);
  CHK_EM (value);
  type = TYPE_MAIN_VARIANT (type);
  assert (TREE_CODE (type) != FUNCTION_TYPE);

  /* Dereference procedural variables before casting them.
     Use the address operator `@' to cast a reference to a pointer. */
  if (PASCAL_PROCEDURAL_TYPE (TREE_TYPE (value)))
    value = build_indirect_ref (value, "procedure/function reference");
  if (TREE_CODE (TREE_TYPE (value)) == FUNCTION_TYPE)
    value = probably_call_function (value);
  if (TREE_CODE (TREE_TYPE (value)) == FUNCTION_TYPE)  /* still */
    {
      error ("cannot cast a function");
      return error_mark_node;
    }

  value = string_may_be_char (value, 0);

  if (type == TREE_TYPE (value))
    {
      if (TREE_CODE_CLASS (TREE_CODE (value)) == 'c' && PASCAL_TREE_FRESH_CST (value))
        {
          value = copy_node (value);
          PASCAL_TREE_FRESH_CST (value) = 0;
        }
      return value;
    }

  /* If casting to void, avoid the error that would come
     from default_conversion in the case of a non-lvalue array. */
  if (TREE_CODE (type) == VOID_TYPE)
    return build1 (CONVERT_EXPR, type, value);

  otype = TREE_TYPE (value);

#if 0
  /* Optionally warn about potentially worrisome casts. */
  if (warn_cast_qual && TREE_CODE (type) == POINTER_TYPE && TREE_CODE (otype) == POINTER_TYPE)
    {
      if (TYPE_VOLATILE (TREE_TYPE (otype)) && !TYPE_VOLATILE (TREE_TYPE (type)))
        pedwarn ("cast discards `volatile' from pointer target type");
      if (TYPE_READONLY (TREE_TYPE (otype)) && !TYPE_READONLY (TREE_TYPE (type)))
        pedwarn ("cast discards `const' from pointer target type");
    }
#endif

  /* Warn about possible alignment problems. */
  if (warn_cast_align
      && TREE_CODE (type) == POINTER_TYPE
      && TREE_CODE (otype) == POINTER_TYPE
      && TREE_CODE (TREE_TYPE (otype)) != VOID_TYPE
      && TREE_CODE (TREE_TYPE (otype)) != FUNCTION_TYPE
      && TYPE_ALIGN (TREE_TYPE (type)) > TYPE_ALIGN (TREE_TYPE (otype)))
    warning ("cast increases required alignment of target type");

  if (TYPE_PRECISION (type) != TYPE_PRECISION (otype) && !TREE_CONSTANT (value))
    {
      if (TREE_CODE (type) == INTEGER_TYPE && TREE_CODE (otype) == POINTER_TYPE)
        warning ("cast from pointer to integer of different size");
      if (TREE_CODE (type) == POINTER_TYPE && TREE_CODE (otype) == INTEGER_TYPE
          && TREE_CODE (value) != PLUS_EXPR && TREE_CODE (value) != MINUS_EXPR)
        warning ("cast to pointer from integer of different size");
    }

  ovalue = value;
  if ((ORDINAL_TYPE (TREE_CODE (otype)) || TREE_CODE (otype) == POINTER_TYPE || TREE_CODE (otype) == REFERENCE_TYPE)
      && (ORDINAL_TYPE (TREE_CODE (type)) || TREE_CODE (type) == POINTER_TYPE || TREE_CODE (type) == REFERENCE_TYPE))
    {
      /* Value type cast. */
      STRIP_TYPE_NOPS (value);
      if (TREE_CODE (value) == INTEGER_CST && ORDINAL_TYPE (TREE_CODE (type)))
        {
          /* Do some trivial range checking, and pedwarn about range
             overflows in explicit casts between ordinal types. */
          if ((TYPE_MIN_VALUE (type) && int_cst_lt_always (value, TYPE_MIN_VALUE (type)))
              || (TYPE_MAX_VALUE (type) && int_cst_lt_always (TYPE_MAX_VALUE (type), value)))
            error ("constant out of range");
        }

      /* If the source and the target type differ both in size and
         in sign, do the conversion in two stages such that the size
         conversion is done on the unsigned type to avoid the value
         being 1-padded.
         Examples: Integer --> Cardinal --> LongCard
                   Byte --> Cardinal --> Integer */
      if (TREE_CODE (type) == INTEGER_TYPE
          && TREE_CODE (TREE_TYPE (value)) == INTEGER_TYPE
          && TREE_UNSIGNED (type) != TREE_UNSIGNED (TREE_TYPE (value))
          && TYPE_PRECISION (type) != TYPE_PRECISION (TREE_TYPE (value)))
        value = convert (signed_or_unsigned_type (1,
                  TREE_UNSIGNED (type) ? TREE_TYPE (value) : type), value);
      value = convert (type, value);
      /* Ignore any integer overflow caused by the cast. */
      if (TREE_CODE (value) == INTEGER_CST)
        {
          TREE_OVERFLOW (value) = TREE_OVERFLOW (ovalue);
          TREE_CONSTANT_OVERFLOW (value) = TREE_CONSTANT_OVERFLOW (ovalue);
        }
      /* cast to type of different size can't be a variable type-cast */
      if (!tree_int_cst_equal (TYPE_SIZE (otype), TYPE_SIZE (type)))
        value = non_lvalue (value);
    }
  else
    {
      /* Variable type cast. Convert a pointer internally. */
      if (TREE_CODE (otype) != VOID_TYPE
          && TREE_CODE (type) != VOID_TYPE
          && !tree_int_cst_equal (TYPE_SIZE (otype), TYPE_SIZE (type)))
        warning ("cast to type of different size");
      /* @@ GPC allows `@'...'' as an extension, but we don't want that here. */
      if (TREE_CODE (value) == STRING_CST)
        error ("reference expected, value given");
      value = build_indirect_ref (convert (build_pointer_type (type),
        build_pascal_unary_op (ADDR_EXPR, value)), "type cast");
    }
  return value;
}

/* Given an expression PTR for a pointer, return an expression for the value pointed to.
   ERRORSTRING is the name of the operator to appear in error messages. */
tree
build_indirect_ref (ptr, errorstring)
     tree ptr;
     const char *errorstring;
{
  tree pointer = default_conversion (ptr), type;
  CHK_EM (ptr);
  if ((TREE_CODE (pointer) == FUNCTION_DECL && TREE_CODE (TREE_TYPE (TREE_TYPE (pointer))) == POINTER_TYPE)
      || CALL_METHOD (pointer))
    pointer = probably_call_function (pointer);
  type = TREE_TYPE (pointer);
  if (TREE_CODE (type) == POINTER_TYPE)
    {
      tree t = TREE_TYPE (type), ref;
      if (!TYPE_SIZE (t) && TREE_CODE (t) != VOID_TYPE
          && !PASCAL_TYPE_UNDISCRIMINATED_SCHEMA (t))
        {
          error ("dereferencing pointer to incomplete type");
          return error_mark_node;
        }
      if (TREE_CODE (pointer) == ADDR_EXPR
          && !flag_volatile
          && (TREE_TYPE (TREE_OPERAND (pointer, 0)) == t))
        return TREE_OPERAND (pointer, 0);

      ref = build1 (INDIRECT_REF, t, pointer);
      TREE_READONLY (ref) = TYPE_READONLY (t);
      TREE_THIS_VOLATILE (ref) = TYPE_VOLATILE (t);
      TREE_SIDE_EFFECTS (ref) = TYPE_VOLATILE (t) || TREE_SIDE_EFFECTS (pointer) || flag_volatile;
      prediscriminate_schema (ref);
      return ref;
    }
  else if (!EM (pointer))
    {
      assert (errorstring);
      error ("invalid type of argument of %s", errorstring);
    }
  return error_mark_node;
}

/* Enables (state = 1) or disables (state = 0) procedure/function evaluation
   when the routines have no parameters.
   Reason:
   1) When parsing an LEX_ID it may be either a routine name or a variable name.
   2) When passing such an item to a routine, it may have to be evaluated or
      not depending of the corresponding FORMAL parameter type; if this is a
      procedural parameter, the routine should be passed, if not, the routine
      should be evaluated, and the result passed.
   3) Enabling is necessary when parsing constructs like `@foo.bar' where `foo'
      is a function which returns a record containing a field `bar'. In this
      case, `foo' must be called although it follows an address operator.
   The old value of the flag is returned. By passing it again, the previous
   state is restored. */
static int evaluate_function_calls = 1;
int
allow_function_calls (state)
     int state;
{
  int old = evaluate_function_calls;
  evaluate_function_calls = state;
  return old;
}

/* Return the result type of the function FUN which may be a
   function decl, a reference or a pointer to a function. */
tree
function_result_type (fun)
     tree fun;
{
  tree type = TREE_TYPE (fun);
  if (TREE_CODE (type) == POINTER_TYPE || TREE_CODE (type) == REFERENCE_TYPE)
    type = TREE_TYPE (type);
  assert (TREE_CODE (type) == FUNCTION_TYPE);
  return TREE_TYPE (type);
}

/* Maybe call the function, or pass it as a routine parameter, or assign
   its address to some lvalue. The problem is that the corresponding
   argument type is not known when the factor is parsed. Neither is it known
   if this is part of an expression ... */
tree
maybe_call_function (fun, flag)
     tree fun;
     int flag;  /* Not sure exactly what this parameter means, `flag' is
                   always a good name for a Boolean value. ;-) -- Frank */
{
  tree temp = fun;

  /* 1) This is a procedure statement without parameters.
     2) This is an assignment from a function with no parameters to some
        variable, or passing the result of such function to another routine.
        @@@@ It may also have args, for function pointer calls.
     3) This procedure or function is being passed to a procedural parameter
        list.
     4) This is the assignment of the ADDRESS of a function to some lvalue.
     5) This is the assignment of the function itself to a procedural variable.
     6) This is a procedure call without parameters through a procedural
        variable.

     The problem is:
     in 1, 2, and 6 above the procedure/function should be called;
     in 3, 4, and 5 it should *not* be called. */

  if (evaluate_function_calls)
    if ((TREE_CODE (fun) == FUNCTION_DECL
         && TYPE_ARG_TYPES (TREE_TYPE (fun))
         && TREE_CODE (TREE_VALUE (TYPE_ARG_TYPES (TREE_TYPE (fun)))) == VOID_TYPE)
        || (((TREE_CODE (fun) == PARM_DECL && PASCAL_PROCEDURAL_PARAMETER (fun))
             || PASCAL_PROCEDURAL_TYPE (TREE_TYPE (fun)))
            && TYPE_ARG_TYPES (TREE_TYPE (TREE_TYPE (fun)))
            && TREE_CODE (TREE_VALUE (TYPE_ARG_TYPES (TREE_TYPE (TREE_TYPE (fun))))) == VOID_TYPE)
        || flag)
      {
        if (PASCAL_PROCEDURAL_TYPE (TREE_TYPE (fun)) || TREE_CODE (TREE_TYPE (fun)) == POINTER_TYPE)
          fun = build_indirect_ref (fun, "indirect procedure call");
        temp = build_routine_call (fun, NULL_TREE);
      }

  return temp;
}

/* A problem with the function calls again ...
   If a forward declared/external function is used in an expression that
   is part of some function arguments it will not be called by the routine
   maybe_call_function().
   The function probably_call_function() is used when we know that the
   function is not a function parameter but rather should be evaluated. */
tree
probably_call_function (fun)
     tree fun;
{
  tree t;
  CHK_EM (fun);
  t = TREE_TYPE (fun);
  if (TREE_CODE (t) == REFERENCE_TYPE)
    t = TREE_TYPE (t);
  /* If this is a function without parameters, call it */
  if (TREE_CODE (t) == FUNCTION_TYPE
      && TREE_CODE (TREE_TYPE (t)) != VOID_TYPE
      && TYPE_ARG_TYPES (t)
      && TREE_CODE (TREE_VALUE (TYPE_ARG_TYPES (t))) == VOID_TYPE)
    fun = build_routine_call (fun, NULL_TREE);
  else if (CALL_METHOD (fun))
    fun = call_method (fun, NULL_TREE);
  return fun;
}

tree
build_iocheck ()
{
  tree t = build (CALL_EXPR, void_type_node, checkinoutres_routine_node, NULL_TREE, NULL_TREE);
  TREE_SIDE_EFFECTS (t) = 1;
  return build (COND_EXPR, pascal_integer_type_node, build_pascal_binary_op (NE_EXPR,
    inoutres_variable_node, integer_zero_node),
    build (COMPOUND_EXPR, pascal_integer_type_node, t, integer_zero_node), integer_zero_node);
}

/* Build a function call to function FUNCTION with parameters PARAMS.
   PARAMS is a list -- a chain of TREE_LIST nodes -- in which the
   TREE_VALUE of each node is a parameter-expression.
   FUNCTION's data type may be a function type or a pointer-to-function. */
tree
build_routine_call (function, params)
     tree function, params;
{
  tree fntype, fundecl = NULL_TREE, result, coerced_params, t, orig_type;
  int side_effects = 1;

  CHK_EM (function);
  for (t = params; t; t = TREE_CHAIN (t))
    CHK_EM (TREE_VALUE (t));

#if 0 /* @@ Should be reasonable, but fails with `const Foo = [...] - [...]' etc. */
  if (!current_function_decl)
    {
      error ("cannot call routine from a global declaration");
      return error_mark_node;
    }
#endif

  orig_type = TREE_TYPE (function);

  /* Strip NON_LVALUE_EXPRs, etc., since we aren't using as an lvalue. */
  STRIP_TYPE_NOPS (function);

  /* Convert anything with function type to a pointer-to-function. */
  if (TREE_CODE (function) == FUNCTION_DECL)
    {
      fundecl = function;
      side_effects = !TREE_READONLY (function);

      /* Differs from default_conversion by not setting TREE_ADDRESSABLE
         (because calling an inline function does not mean the function
         needs to be separately compiled). */
      fntype = p_build_type_variant (TREE_TYPE (function),
                                     TREE_READONLY (function),
                                     TREE_THIS_VOLATILE (function));
      function = build1 (ADDR_EXPR, build_pointer_type (fntype), function);
    }
  /* Not converted by default_conversion(). */
  else if (TREE_CODE (TREE_TYPE (function)) == FUNCTION_TYPE)
    function = build_unary_op (ADDR_EXPR, function, 0);
  else if (TREE_CODE (TREE_TYPE (function)) == POINTER_TYPE)
    error ("missing `^' in indirect function call");
  else
    function = default_conversion (function);

  fntype = TREE_TYPE (function);
  CHK_EM (fntype);

  if (!(TREE_CODE (fntype) == POINTER_TYPE && TREE_CODE (TREE_TYPE (fntype)) == FUNCTION_TYPE))
    {
      error ("called object is not a procedure or function");
      return error_mark_node;
    }

  /* fntype now gets the type of function pointed to. */
  fntype = TREE_TYPE (fntype);

  /* Convert the parameters to the types declared with the
     routine, or apply default promotions. */
  coerced_params = convert_arguments (TYPE_ARG_TYPES (fntype), params, fundecl);
  if (coerced_params)
    CHK_EM (coerced_params);

  result = build (CALL_EXPR, TREE_TYPE (fntype), function, coerced_params, NULL_TREE);
  TREE_SIDE_EFFECTS (result) = side_effects;

  if (PASCAL_TYPE_STRING (TREE_TYPE (fntype)))
    {
      /* Handle functions returning string schemata.
         Since we don't know what will happen to the string to be
         returned, we must provide a temporary variable and expand
         the assignment to it now. Otherwise, subsequent component
         references (to Capacity, length, and string) will cause the
         function to be called three times. */
      tree temp_string = make_new_variable ("string_result", TREE_TYPE (fntype));
      result = save_expr (build_modify_expr (temp_string, NOP_EXPR, result));
      result = build (COMPOUND_EXPR, TREE_TYPE (fntype), result, non_lvalue (temp_string));
      TREE_USED (result) = 1;
    }
  DEREFERENCE_SCHEMA (result);
  if (co->io_checking && PASCAL_TYPE_IOCRITICAL (orig_type))
    {
      if (TREE_CODE (TREE_TYPE (result)) == VOID_TYPE || EM (TREE_TYPE (result)))
        {
          result = build1 (CONVERT_EXPR, void_type_node, save_expr (build (COMPOUND_EXPR, pascal_integer_type_node, result, build_iocheck ())));
          PASCAL_TREE_IGNORABLE (result) = 1;
        }
      else
        {
          /* @@ Can we do it somehow without the temp var? We'd need something
                like a "left-valued comma", i.e. evaluate first a, then b, and
                return a. -- Frank */
          tree temp_var = make_new_variable ("save_across_io_check", TREE_TYPE (result));
          result = build (COMPOUND_EXPR, TREE_TYPE (temp_var), save_expr (build (COMPOUND_EXPR, pascal_integer_type_node,
                     build_modify_expr (temp_var, NOP_EXPR, result), build_iocheck ())), temp_var);
        }
    }
  PASCAL_TREE_IGNORABLE (result) |= PASCAL_TREE_IGNORABLE (orig_type) || co->ignore_function_results;
  if (TREE_CODE (TREE_TYPE (result)) == VOID_TYPE || EM (TREE_TYPE (result)))
    return result;
  return require_complete_type (result);
}

static tree
strip_needless_lists (list)
     tree list;
{
  while (1)
    {
      tree nl = TREE_VALUE (list);
      if (TREE_CHAIN (list) || TREE_PURPOSE (list) || !nl)
        return NULL_TREE;
      if (TREE_CODE (nl) != TREE_LIST)
        return list;
      if (!PASCAL_BP_INITIALIZER_LIST (nl))
        return NULL_TREE;
      PASCAL_BP_INITIALIZER_LIST (nl) = 0;
      list = nl;
    }
}

tree
build_iso_set_constructor (type, list, one_el)
     tree type, list;
     int one_el;
{
  tree nl = NULL_TREE;
  if (one_el)
    {
      if ((list = strip_needless_lists (list)))
        {
          TREE_PURPOSE (list) = TREE_VALUE (list);
          TREE_VALUE (list) = NULL_TREE;
        }
      else
        {
          error ("invalid set constructor");
          return error_mark_node;
        }
    }
  while (list)
    {
      tree low = TREE_PURPOSE (list);
      if (low && TREE_CODE (low) == IDENTIFIER_NODE)
        low = check_identifier (low);
      nl = tree_cons (low, TREE_VALUE (list), nl);
      list = TREE_CHAIN (list);
    }
  return construct_set (build_set_constructor (nreverse (nl)), type, 1);
}

tree
build_iso_constructor (tdecl, list)
     tree tdecl, list;
{
  tree type = TREE_TYPE (tdecl);
  assert (TREE_CODE (list) == TREE_LIST);
  if (TREE_CODE (tdecl) != TYPE_DECL)
    {
      /* Handle `arr[(((expr)))]' -- since we must track parentheses
         in BP initializers, we prefer parse as initializer to parse
         as index expression */
      if ((list = strip_needless_lists (list)))
        return build_pascal_array_ref (tdecl, list);
      error ("invalid subscript");
      return error_mark_node;
    }
  if (TREE_CODE (type) == SET_TYPE)
    return build_iso_set_constructor (type, list, 1);
  if (!STRUCTURED_TYPE (TREE_CODE (type)))
    error ("invalid type for structured value constructor");
  list = build_tree_list (NULL_TREE, list);
  if (check_pascal_initializer (type, list))
    {
      error ("invalid structured value constructor");
      return error_mark_node;
    }
  else
    return build_pascal_initializer (NULL_TREE, type, list);
}

tree
build_call_or_cast (function, args)
     tree function, args;
{
  if (TREE_CODE (function) == TYPE_DECL)
    {
      chk_dialect ("type casts are", B_D_M_PASCAL);
      if (list_length (args) != 1)
        {
          error ("type cast expects one expression argument");
          return error_mark_node;
        }
      else
        return build_type_cast (TREE_TYPE (function), TREE_VALUE (args));
    }
  else if (CALL_METHOD (function))
    return call_method (function, args);
  else
    return build_routine_call (function, args);
}

/* Build an assignment expression of lvalue LHS from value RHS.
   MODIFYCODE is the code for a binary operator that we use
   to combine the old value of LHS with RHS to get the new value.
   Or else MODIFYCODE is NOP_EXPR meaning do a simple assignment,
   or INIT_EXPR which is the same, but does not mark the variable
   as assigned nor warn about assignments to discriminants etc.
   (meant for automatic initializations). */
tree
build_modify_expr (lhs, modifycode, rhs)
     tree lhs, rhs;
     enum tree_code modifycode;
{
  tree result, newrhs;
  tree lhstype = TREE_TYPE (lhs);
  tree olhstype = lhstype;
  int is_init = (modifycode == INIT_EXPR);
  if (modifycode == INIT_EXPR)
    modifycode = NOP_EXPR;

  /* Types that aren't fully specified cannot be used in assignments. */
  lhs = require_complete_type (lhs);

  /* Avoid duplicate error messages from operands that had errors. */
  CHK_EM (lhs);
  CHK_EM (rhs);

  /* Strip NON_LVALUE_EXPRs since we aren't using as an lvalue.
     Do not use STRIP_NOPS here. We do not want an enumerator
     whose value is 0 to count as a null pointer constant. */
  if (TREE_CODE (rhs) == NON_LVALUE_EXPR)
    rhs = TREE_OPERAND (rhs, 0);

  newrhs = rhs;

  /* Object assignments. */
  if (PASCAL_TYPE_OBJECT (lhstype) && PASCAL_TYPE_OBJECT (TREE_TYPE (rhs)))
    {
      tree field = TYPE_FIELDS (lhstype), field2, lastfield, l = lhs;
      if (!comp_object_or_schema_pointer_types (lhstype, TREE_TYPE (rhs)))
        {
          error ("assignment between incompatible object types");
          return error_mark_node;
        }
      if (co->warn_object_assignment)
        warning ("assignment between objects");

      while (TREE_CODE (l) == NOP_EXPR
             || TREE_CODE (l) == CONVERT_EXPR
             || TREE_CODE (l) == NON_LVALUE_EXPR)
        l = TREE_OPERAND (l, 0);
      if (TREE_CODE (l) != VAR_DECL
          && TREE_CODE (l) != PARM_DECL
          && TREE_CODE (l) != COMPONENT_REF
          && TREE_CODE (l) != ARRAY_REF)
        warning ("left-hand side of object assignment is polymorphic");

      /* The following code assumes that the VMT pointer is the first field.
         This is always the case in GPC. If this ever changes, the code must
         be adapted. */
      assert (TYPE_LANG_VMT_FIELD (lhstype) == field);
#ifdef EGCS97
      assert (integer_zerop (DECL_FIELD_BIT_OFFSET (field))
              && integer_zerop (DECL_FIELD_OFFSET (field)));
#else
      assert (integer_zerop (bit_position (field)));
#endif
      field = TREE_CHAIN (field);
      field2 = TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (rhs)));
      if (!field)
        {
          if (!is_init)
            warning ("assignment of object with no fields has no effect");
          return error_mark_node;
        }
      lastfield = tree_last (field);
      return build_memcpy (
        build_unary_op (ADDR_EXPR, build (COMPONENT_REF, TREE_TYPE (field), lhs, field), 1),
        build_unary_op (ADDR_EXPR, build (COMPONENT_REF, TREE_TYPE (field2), rhs, field2), 2),
        size_binop (CEIL_DIV_EXPR,
          size_binop (MINUS_EXPR, size_binop (PLUS_EXPR, bit_position (lastfield), DECL_SIZE (lastfield)), bit_position (field)),
          bitsize_int (TYPE_PRECISION (byte_integer_type_node))));
    }

  if ((IS_EXPR_CODE_CLASS (TREE_CODE_CLASS (TREE_CODE (lhs))) || TREE_CODE (lhs) == VAR_DECL)
      && PASCAL_TREE_PACKED (lhs))
    {
      /* This is a construction to read a component of a packed array.
         Use it to construct an expression to write to that component.
         This depends on how build_pascal_array_ref() works. */
      tree newlhs, access = lhs;
      tree mask, shifted_mask, offset, temprhs, save_rhs_stmt, eraser, brush;
      tree low_lhs, high_lhs, low_assignment, high_assignment;

      /* Extract the mask and the offset from the expression. */
      if (TREE_CODE (access) == CONVERT_EXPR)
        access = TREE_OPERAND (access, 0);
      if (TREE_CODE (access) == COND_EXPR)
        access = TREE_OPERAND (access, 2);
      while (TREE_CODE (access) == NOP_EXPR)
        access = TREE_OPERAND (access, 0);
      /* Now ACCESS must be an RSHIFT_EXPR, but might have been folded to a
         NON_LVALUE_EXPR if it was a shift by 0 (emil1.pas); its arg0 must
         be a BIT_AND_EXPR in both cases. */
      if (TREE_CODE (access) == NON_LVALUE_EXPR)
        offset = integer_zero_node;
      else
        {
          assert (TREE_CODE (access) == RSHIFT_EXPR);
          offset = TREE_OPERAND (access, 1);
        }

      assert (TREE_CODE (TREE_OPERAND (access, 0)) == BIT_AND_EXPR);
      newlhs = TREE_OPERAND (TREE_OPERAND (access, 0), 0);
      if (TREE_CODE (newlhs) == NOP_EXPR)
        newlhs = TREE_OPERAND (newlhs, 0);
      shifted_mask = TREE_OPERAND (TREE_OPERAND (access, 0), 1);

      /* NEWLHS must be a BIT_IOR_EXPR. Prepare to access it in two halfs. */
      assert (TREE_CODE (newlhs) == BIT_IOR_EXPR);
      low_lhs = TREE_OPERAND (newlhs, 0);
      while (TREE_CODE (low_lhs) == NOP_EXPR)
        low_lhs = TREE_OPERAND (low_lhs, 0);
      high_lhs = TREE_OPERAND (newlhs, 1);
      while (TREE_CODE (high_lhs) == NOP_EXPR)
        high_lhs = TREE_OPERAND (high_lhs, 0);
      assert (TREE_CODE (high_lhs) == LSHIFT_EXPR);
      high_lhs = TREE_OPERAND (high_lhs, 0);
      while (TREE_CODE (high_lhs) == NOP_EXPR)
        high_lhs = TREE_OPERAND (high_lhs, 0);

      /* Dig out the non-shifted mask. */
      mask = shifted_mask;
      while (TREE_CODE (mask) == NOP_EXPR)
        mask = TREE_OPERAND (mask, 0);

      /* If the shift (by 0) was optimized away, mask is an INTEGER_CST already. Fine. */
      if (TREE_CODE (mask) != INTEGER_CST)
        {
          assert ((TREE_CODE (mask) == LSHIFT_EXPR || TREE_CODE (mask) == NON_LVALUE_EXPR)
                  && TREE_CODE (TREE_OPERAND (mask, 0)) == INTEGER_CST);
          mask = TREE_OPERAND (mask, 0);
        }

      /* NEWRHS can be an expression involving the LHS array field, so
         store it into a temporary variable before modifying the LHS. */
      temprhs = make_new_variable ("assign_packed", TREE_TYPE (newrhs));
      save_rhs_stmt = build_modify_expr (temprhs, NOP_EXPR, newrhs);
      newrhs = temprhs;

      /* Do the modification. */
      if (modifycode != NOP_EXPR)
        newrhs = build_binary_op (modifycode, lhs, newrhs, 1);

      /* Now form a new expression to store the lower part of NEWRHS in LOW_LHS.
         Clear the bits in the target. */
      eraser = build_unary_op (BIT_NOT_EXPR, shifted_mask, 0);
      eraser = build_modify_expr (low_lhs, BIT_AND_EXPR, eraser);
      /* Do the assignment. */
      brush = build_binary_op (BIT_AND_EXPR, newrhs, mask, 1);
      brush = build_binary_op (LSHIFT_EXPR, brush, offset, 0);
      brush = build_modify_expr (low_lhs, BIT_IOR_EXPR, brush);

      low_assignment = build (COMPOUND_EXPR, TREE_TYPE (brush), save_rhs_stmt,
                         build (COMPOUND_EXPR, TREE_TYPE (brush), eraser, brush));

      /* Now do the same for the higher part and HIGH_LHS.
         Prepare SHIFTED_MASK to access the higher half. */
      shifted_mask = build (RSHIFT_EXPR, TREE_TYPE (shifted_mask), shifted_mask,
                            TYPE_SIZE (TREE_TYPE (low_lhs)));
      /* Clear the bits in the target. */
      eraser = build_unary_op (BIT_NOT_EXPR, shifted_mask, 0);
      eraser = build_modify_expr (high_lhs, BIT_AND_EXPR, eraser);
      /* Do the assignment. */
      brush = build_binary_op (BIT_AND_EXPR, newrhs, mask, 1);
      brush = build_binary_op (LSHIFT_EXPR, brush, offset, 0);
      brush = build_binary_op (RSHIFT_EXPR, brush, TYPE_SIZE (TREE_TYPE (low_lhs)), 0);
      brush = build_modify_expr (high_lhs, BIT_IOR_EXPR, brush);
      /* Construct a COMPOUND_EXPR holding both. */
      high_assignment = build (COMPOUND_EXPR, TREE_TYPE (brush), eraser, brush);
      /* Return another COMPOUND_EXPR holding both halfs. */
      return build (COMPOUND_EXPR, TREE_TYPE (high_assignment), low_assignment, high_assignment);
    }
  if (TREE_CODE (lhs) == COMPOUND_EXPR)
    {
      /* COMPOUND_EXPRs are generated by some "magic" functions. */
      newrhs = build_modify_expr (TREE_OPERAND (lhs, 1), modifycode, rhs);
      CHK_EM (newrhs);
      return build (COMPOUND_EXPR, lhstype, TREE_OPERAND (lhs, 0), newrhs);
    }

  /* If a binary op has been requested, combine the old LHS value with the RHS
     producing the value we should actually store into the LHS. */
  if (modifycode != NOP_EXPR)
    {
      lhs = stabilize_reference (lhs);
      newrhs = build_binary_op (modifycode, lhs, rhs, 1);
    }

  if (TREE_CODE (lhs) == NOP_EXPR || TREE_CODE (lhs) == CONVERT_EXPR)
    {
      /* Handle a cast used as an "lvalue".
         We have already performed any binary operator using the value as cast.
         Now convert the result to the cast type of the lhs,
         and then true type of the lhs and store it there;
         then convert result back to the cast type to be the value of the assignment.
         Do not convert between types; just copy the data in memory. */
      tree inner_lhs = TREE_OPERAND (lhs, 0);

      if (!comptypes (TREE_TYPE (lhs), TREE_TYPE (newrhs)))
        error ("incompatible types in assignment");

      /* For most types, build_type_cast() already has checked that the sizes of the
         types match. For integer types, this must be re-checked here. */
      if (TREE_CODE (TYPE_SIZE (TREE_TYPE (inner_lhs))) == INTEGER_CST
          && TREE_CODE (TYPE_SIZE (lhstype)) == INTEGER_CST
          && (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (inner_lhs))) != TREE_INT_CST_LOW (TYPE_SIZE (lhstype))
              || TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (inner_lhs))) != TREE_INT_CST_LOW (TYPE_SIZE (lhstype))))
        {
          warning ("cast to type of different size");
          lhs = build_pascal_unary_op (ADDR_EXPR, inner_lhs);
          lhstype = build_pointer_type (TREE_TYPE (newrhs));
          lhs = convert (lhstype, lhs);
          lhs = build_indirect_ref (lhs, "assignment");
        }
      else
        {
          newrhs = build1 (NOP_EXPR, TREE_TYPE (inner_lhs), newrhs);
          lhs = inner_lhs;
        }
      return build_modify_expr (lhs, NOP_EXPR, newrhs);
    }

  /* Now we have handled acceptable kinds of LHS that are not truly lvalues.
     Reject anything strange now. */
  if (!lvalue_or_else (lhs, "assignment"))
    return error_mark_node;

  if (!is_init && !mark_lvalue (lhs, "assignment", 1))
    return error_mark_node;

  /* If storing into a structure or union member, it has probably been given type `int'.
     Compute the type that would go with the actual amount of storage the member occupies. */
  if (TREE_CODE (lhs) == COMPONENT_REF
      && (TREE_CODE (lhstype) == INTEGER_TYPE || TREE_CODE (lhstype) == REAL_TYPE))
    lhstype = TREE_TYPE (get_unwidened (lhs, 0));

  /* If storing in a field that is in actuality a short or narrower than one,
     we must store in the field in its actual type. */
  if (lhstype != TREE_TYPE (lhs))
    {
      lhs = copy_node (lhs);
      TREE_TYPE (lhs) = lhstype;
    }

  /* Convert new value to destination type. */
  newrhs = convert_for_assignment (lhstype, newrhs, "assignment", NULL_TREE, 0);
  CHK_EM (newrhs);

  result = build (MODIFY_EXPR, lhstype, lhs, newrhs);
  TREE_SIDE_EFFECTS (result) = 1;

  /* If we got the LHS in a different type for storing in,
     convert the result back to the nominal type of LHS
     so that the value we return always has the same type
     as the LHS argument. */
  if (olhstype == TREE_TYPE (result))
    return result;

  return convert_for_assignment (olhstype, result, "assignment", NULL_TREE, 0);
}
