//! @file expression.c
//! @author J. Marcel van der Veer
//
//! @section Copyright
//
// This file is part of VIF - vintage FORTRAN compiler.
// Copyright 2020-2025 J. Marcel van der Veer <algol68g@xs4all.nl>.
//
//! @section License
//
// This program is free software; you can redistribute it and/or modify it 
// under the terms of the GNU General Public License as published by the 
// Free Software Foundation; either version 3 of the License, or 
// (at your option) any later version.
//
// This program 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 this program. If not, see <http://www.gnu.org/licenses/>.

//! @section Synopsis
//!
//! Compile Fortran expressions.

#include <vif.h>

int_4 lhs_factor;

#define OP_ERROR(num, s) {\
          NEW_RECORD (_str_);\
          _srecordf (_str_, "%s %s %s",\
            qtype (&lhs->mode), op, qtype (&rhs->mode));\
          ERROR ((num), (s), _str_);\
          return;\
        }

logical_4 valid_expr (EXPR *reg)
{
  if (strlen (reg->str) == 0) {
    return FALSE;
  }
  if (reg->mode.type == ETYPE) {
    return FALSE;
  }
  return TRUE;
}

char *const_1 (MODE * m)
{
  if (m->type == INTEGER) {
    return "1";
  } else if (m->type == REAL) {
    if (m->len == 8) {
      return "1.0";
    } else if (m->len == 16) {
      return "1.0q";
    }
  } else if (m->type == COMPLEX) {
    if (m->len == 16) {
      return "1.0";
    } else if (m->len == 32) {
      return "1.0q";
    }
  }
  return "1";
}

int_4 optimise_exp (char *str, EXPR * lhs, EXPR * rhs)
{
  NEW_RECORD (tmp);
  if (lhs->mode.type == INTEGER && lhs->variant == EXPR_CONST && rhs->mode.type == INTEGER && rhs->variant == EXPR_CONST) {
    int_4 a, n;
    sscanf (lhs->str, "%d", &a);
    sscanf (rhs->str, "%d", &n);
    _srecordf (str, "%d", _up_int_4 (a, n));
    return TRUE;
  } 
  int_4 simple = lhs->variant != EXPR_OTHER;
  if (EQUAL (rhs->str, "2")) {
    if (simple) {
      _srecordf (str, "(%s * %s)", lhs->str, lhs->str);
    } else {
      _srecordf (tmp, "%s", edit_tmp (nloctmps++));
      add_local (tmp, lhs->mode.type, lhs->mode.len, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
      _srecordf (str, "(%s = %s, %s * %s)", tmp, lhs->str, tmp, tmp);
    }
    return TRUE;
  } else if (simple && EQUAL (rhs->str, "-2")) {
    _srecordf (str, "%s / (%s * %s)", const_1 (&lhs->mode), lhs->str, lhs->str);
    return TRUE;
  } else if (simple && EQUAL (rhs->str, "3")) {
    _srecordf (str, "(%s * %s * %s)", lhs->str, lhs->str, lhs->str);
    return TRUE;
  } else if (simple && EQUAL (rhs->str, "-3")) {
    _srecordf (str, "%s / (%s * %s * %s)", const_1 (&lhs->mode), lhs->str, lhs->str, lhs->str);
    return TRUE;
  } else if (simple && EQUAL (rhs->str, "4")) {
    _srecordf (tmp, "%s", edit_tmp (nloctmps++));
    add_local (tmp, lhs->mode.type, lhs->mode.len, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
    _srecordf (str, "(%s = %s * %s, %s * %s)", tmp, lhs->str, lhs->str, tmp, tmp);
    return TRUE;
  } else if (simple && EQUAL (rhs->str, "-4")) {
    _srecordf (tmp, "%s", edit_tmp (nloctmps++));
    add_local (tmp, lhs->mode.type, lhs->mode.len, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
    _srecordf (str, "(%s = %s * %s, %s / (%s * %s))", tmp, lhs->str, lhs->str, const_1 (&lhs->mode), tmp, tmp);
    return TRUE;
  } else if (simple && EQUAL (rhs->str, "5")) {
    _srecordf (tmp, "%s", edit_tmp (nloctmps++));
    add_local (tmp, lhs->mode.type, lhs->mode.len, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
    _srecordf (str, "(%s = %s * %s, %s * %s * %s)", tmp, lhs->str, lhs->str, lhs->str, tmp, tmp);
    return TRUE;
  } else if (simple && EQUAL (rhs->str, "-5")) {
    _srecordf (tmp, "%s", edit_tmp (nloctmps++));
    add_local (tmp, lhs->mode.type, lhs->mode.len, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
    _srecordf (str, "(%s = %s * %s, %s / (%s * %s * %s))", tmp, lhs->str, lhs->str, const_1 (&lhs->mode), lhs->str, tmp, tmp);
    return TRUE;
  } else if (simple && EQUAL (rhs->str, "6")) {
    _srecordf (tmp, "%s", edit_tmp (nloctmps++));
    add_local (tmp, lhs->mode.type, lhs->mode.len, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
    _srecordf (str, "(%s = %s * %s, %s * %s * %s)", tmp, lhs->str, lhs->str, tmp, tmp, tmp);
    return TRUE;
  } else if (simple && EQUAL (rhs->str, "-6")) {
    _srecordf (tmp, "%s", edit_tmp (nloctmps++));
    add_local (tmp, lhs->mode.type, lhs->mode.len, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
    _srecordf (str, "(%s = %s * %s, %s / (%s * %s * %s))", tmp, lhs->str, lhs->str, const_1 (&lhs->mode), tmp, tmp, tmp);
    return TRUE;
  } else {
    return FALSE;
  }
}

static void oper_char (EXPR * lhs, EXPR * rhs, char *op)
{
  if (lhs->mode.type != rhs->mode.type) {
    OP_ERROR (1501, "mixed mode expression");
  } else {
    char *routine = (use_strcasecmp ? "strcasecmp" : "strcmp");
    if (EQUAL (op, "+") || EQUAL (op, "//")) {
      int len;
      if (lhs->mode.len == 0 || rhs->mode.len == 0) {
        len = MAX_STRLEN;
      } else {
        len = lhs->mode.len + rhs->mode.len;
      }
      MODE m = {.type = CHARACTER, .len = (len > MAX_STRLEN ? MAX_STRLEN : len)};
      norm_mode (&m);
      NEW_RECORD (tmp);
      _srecordf (tmp, "%s", edit_tmp (nloctmps++));
      add_local (tmp, CHARACTER, m.len, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
      _srecordf (lhs->str, "concat (%s, %s, %s)", tmp, lhs->str, rhs->str);
      lhs->mode = (MODE) {.type = CHARACTER, .len = m.len, .dim = 0};
    } else if (EQUAL (op, ".eq.") || EQUAL (op, "==")) {
      _srecordf (lhs->str, "(%s (%s, %s) == 0)", routine, lhs->str, rhs->str);
      lhs->mode = (MODE) {.type = LOGICAL, .len = 4, .dim = 0};
    } else if (EQUAL (op, ".ne.") || EQUAL (op, "/=")) {
      _srecordf (lhs->str, "(%s (%s, %s) != 0)", routine, lhs->str, rhs->str);
      lhs->mode = (MODE) {.type = LOGICAL, .len = 4, .dim = 0};
    } else if (EQUAL (op, ".le.") || EQUAL (op, ".lle.") || EQUAL (op, "<=")) {
      _srecordf (lhs->str, "(%s (%s, %s) <= 0)", routine, lhs->str, rhs->str);
      lhs->mode = (MODE) {.type = LOGICAL, .len = 4, .dim = 0};
    } else if (EQUAL (op, ".ge.") || EQUAL (op, ".lge.") || EQUAL (op, ">=")) {
      _srecordf (lhs->str, "(%s (%s, %s) >= 0)", routine, lhs->str, rhs->str);
      lhs->mode = (MODE) {.type = LOGICAL, .len = 4, .dim = 0};
    } else if (EQUAL (op, ".lt.") || EQUAL (op, ".llt.") || EQUAL (op, "<")) {
      _srecordf (lhs->str, "(%s (%s, %s) < 0)", routine, lhs->str, rhs->str);
      lhs->mode = (MODE) {.type = LOGICAL, .len = 4, .dim = 0};
    } else if (EQUAL (op, ".gt.") || EQUAL (op, ".lgt.") || EQUAL (op, ">")) {
      _srecordf (lhs->str, "(%s (%s, %s) > 0)", routine, lhs->str, rhs->str);
      lhs->mode = (MODE) {.type = LOGICAL, .len = 4, .dim = 0};
    } else {
      OP_ERROR (1502, "undefined operator");
    }
  }
}

static void oper_real_32 (EXPR * lhs, EXPR * rhs, char *op)
{
  if (TYPE (lhs, REAL, 32)) {
    if (TYPE (rhs, REAL, 32)) {
      /* Ok */;
    } else if (rhs->mode.type == REAL || rhs->mode.type == INTEGER) {
      NEW_RECORD (tmp);
      _srecordf (tmp, "%s", edit_tmp (nloctmps++));
      add_local (tmp, REAL, 32, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
      _srecordf (rhs->str, "_quadtop (&%s, %s)", tmp, rhs->str);
      rhs->mode = (MODE) {.type = REAL, .len = 32, .dim = 0};
    }
  } else if (TYPE (rhs, REAL, 32)) {
    if (TYPE (lhs, REAL, 32)) {
      /* Ok */;
    } else if (lhs->mode.type == REAL || lhs->mode.type == INTEGER) {
      NEW_RECORD (tmp);
      _srecordf (tmp, "%s", edit_tmp (nloctmps++));
      add_local (tmp, REAL, 32, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
      _srecordf (lhs->str, "_quadtop (&%s, %s)", tmp, lhs->str);
      lhs->mode = (MODE) {.type = REAL, .len = 32, .dim = 0};
    }
  }
  if (lhs->mode.type != rhs->mode.type) {
    OP_ERROR (1503, "undefined operator");
  } else if (lhs->mode.len != rhs->mode.len) {
    OP_ERROR (1504, "undefined operator");
  } else if (EQUAL (op, "+")) {
    _srecordf (lhs->str, "xsum (%s, %s)", lhs->str, rhs->str);
  } else if (EQUAL (op, "-")) {
    _srecordf (lhs->str, "xsub (%s, %s)", lhs->str, rhs->str);
  } else if (EQUAL (op, "*")) {
    _srecordf (lhs->str, "xmul (%s, %s)", lhs->str, rhs->str);
  } else if (EQUAL (op, "/")) {
    _srecordf (lhs->str, "xdiv (%s, %s)", lhs->str, rhs->str);
  } else if (EQUAL (op, ".eq.") || EQUAL (op, "==")) {
    _srecordf (lhs->str, "xeq (%s, %s)", lhs->str, rhs->str);
    lhs->mode = (MODE) {.type = LOGICAL,.len = 4,.dim = 0};
  } else if (EQUAL (op, ".ne.") || EQUAL (op, "/=")) {
    _srecordf (lhs->str, "xneq (%s, %s)", lhs->str, rhs->str);
    lhs->mode = (MODE) {.type = LOGICAL,.len = 4,.dim = 0};
  } else if (EQUAL (op, ".le.") || EQUAL (op, "<=")) {
    _srecordf (lhs->str, "xle (%s, %s)", lhs->str, rhs->str);
    lhs->mode = (MODE) {.type = LOGICAL,.len = 4,.dim = 0};
  } else if (EQUAL (op, ".lt.") || EQUAL (op, "<")) {
    _srecordf (lhs->str, "xlt (%s, %s)", lhs->str, rhs->str);
    lhs->mode = (MODE) {.type = LOGICAL,.len = 4,.dim = 0};
  } else if (EQUAL (op, ".ge.") || EQUAL (op, ">=")) {
    _srecordf (lhs->str, "xge (%s, %s)", lhs->str, rhs->str);
    lhs->mode = (MODE) {.type = LOGICAL,.len = 4,.dim = 0};
  } else if (EQUAL (op, ".gt.") || EQUAL (op, ">")) {
    _srecordf (lhs->str, "xgt (%s, %s)", lhs->str, rhs->str);
    lhs->mode = (MODE) {.type = LOGICAL,.len = 4,.dim = 0};
  } else {
    OP_ERROR (1505, "undefined operator");
  }
}

static void oper_complex_64 (EXPR * lhs, EXPR * rhs, char *op)
{
  if (TYPE (lhs, COMPLEX, 64)) {
    if (TYPE (rhs, COMPLEX, 64)) {
      /* Ok */;
    } else if (TYPE (rhs, REAL, 32)) {
      NEW_RECORD (tmp);
      _srecordf (tmp, "%s", edit_tmp (nloctmps++));
      add_local (tmp, COMPLEX, 64, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
      _srecordf (rhs->str, "_coctotop (&%s, %s)", tmp, rhs->str);
      rhs->mode = (MODE) {.type = COMPLEX, .len = 64, .dim = 0};
    } else if (rhs->mode.type == INTEGER || rhs->mode.type == REAL) {
      NEW_RECORD (tmp);
      _srecordf (tmp, "%s", edit_tmp (nloctmps++));
      add_local (tmp, COMPLEX, 64, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
      _srecordf (rhs->str, "_cquadtop (&%s, %s)", tmp, rhs->str);
      rhs->mode = (MODE) {.type = COMPLEX, .len = 64, .dim = 0};
    }
  } else if (TYPE (rhs, COMPLEX, 64)) {
    if (TYPE (lhs, REAL, 32)) {
      NEW_RECORD (tmp);
      _srecordf (tmp, "%s", edit_tmp (nloctmps++));
      add_local (tmp, COMPLEX, 64, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
      _srecordf (lhs->str, "_coctotop (&%s, %s)", tmp, lhs->str);
      lhs->mode = (MODE) {.type = COMPLEX, .len = 64, .dim = 0};
    } else if (lhs->mode.type == INTEGER || lhs->mode.type == REAL) {
      NEW_RECORD (tmp);
      _srecordf (tmp, "%s", edit_tmp (nloctmps++));
      add_local (tmp, COMPLEX, 64, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
      _srecordf (lhs->str, "_cquadtop (&%s, %s)", tmp, lhs->str);
      lhs->mode = (MODE) {.type = COMPLEX, .len = 64, .dim = 0};
    }
  }
  if (lhs->mode.type != rhs->mode.type) {
    OP_ERROR (1506, "undefined operator");
  } else if (lhs->mode.len != rhs->mode.len) {
    OP_ERROR (1507, "undefined operator");
  } else if (EQUAL (op, "+")) {
    _srecordf (lhs->str, "cxsum (%s, %s)", lhs->str, rhs->str);
  } else if (EQUAL (op, "-")) {
    _srecordf (lhs->str, "cxsub (%s, %s)", lhs->str, rhs->str);
  } else if (EQUAL (op, "*")) {
    _srecordf (lhs->str, "cxmul (%s, %s)", lhs->str, rhs->str);
  } else if (EQUAL (op, "/")) {
    _srecordf (lhs->str, "cxdiv (%s, %s)", lhs->str, rhs->str);
  } else if (EQUAL (op, ".eq.")) {
    _srecordf (lhs->str, "cxeq (%s, %s)", lhs->str, rhs->str);
  } else if (EQUAL (op, ".ne.")) {
    _srecordf (lhs->str, "cxneq (%s, %s)", lhs->str, rhs->str);
  } else {
    OP_ERROR (1508, "undefined operator");
  }
}

int_4 mix_len (EXPR * lhs, EXPR * rhs)
{
  return _max (lhs->mode.len, rhs->mode.len);
}

void power (EXPR * lhs, EXPR * rhs, char *op)
{
  NEW_RECORD (str);
  if (rhs->mode.type != INTEGER) {
    if (TYPE (lhs, REAL, 4) && TYPE (rhs, REAL, 4)) {
      _srecordf (lhs->str, "powl (%s, %s)", lhs->str, rhs->str);
    } else if (TYPE (lhs, REAL, 4) && TYPE (rhs, REAL, 8)) {
      _srecordf (lhs->str, "powl (%s, (real_4) %s)", lhs->str, rhs->str);
    } else if (TYPE (lhs, REAL, 8) && TYPE (rhs, REAL, 8)) {
      _srecordf (lhs->str, "pow (%s, %s)", lhs->str, rhs->str);
    } else if (TYPE (lhs, REAL, 8) && TYPE (rhs, REAL, 4)) {
      _srecordf (lhs->str, "pow (%s, (real_8) %s)", lhs->str, rhs->str);
    } else if (TYPE (lhs, REAL, 16) && TYPE (rhs, REAL, 16)) {
      _srecordf (lhs->str, "powq (%s, %s)", lhs->str, rhs->str);
    } else if (TYPE (lhs, REAL, 32) && TYPE (rhs, REAL, 32)) {
      _srecordf (lhs->str, "xpow (%s, %s)", lhs->str, rhs->str);
    } else {
      OP_ERROR (1509, "undefined operator");
    }
  } else if (TYPE (lhs, COMPLEX, 64)) {
    _srecordf (lhs->str, "cxpwr (%s, %s)", lhs->str, rhs->str);
  } else if (TYPE (lhs, REAL, 32)) {
    _srecordf (lhs->str, "xpwr (%s, %s)", lhs->str, rhs->str);
  } else {
    if (optimise_exp (str, lhs, rhs)) {
      RECCPY (lhs->str, str);
      return;
    } else {
      NEW_RECORD (proc);
      if (lhs->mode.type == INTEGER) {
        if (lhs->mode.len == 4) {
          RECCPY (proc, "_up_int_4");
        } else if (lhs->mode.len == 8) {
          RECCPY (proc, "_up_int_8");
        }
      } else if (lhs->mode.type == REAL) {
        if (lhs->mode.len == 4) {
          RECCPY (proc, "_up_real_4");
        } else if (lhs->mode.len == 8) {
          RECCPY (proc, "_up_real_8");
        } else if (lhs->mode.len == 16) {
          RECCPY (proc, "_up_real_16");
        }
      } else if (lhs->mode.type == COMPLEX) {
        if (lhs->mode.len == 8) {
          RECCPY (proc, "_up_complex_8");
        } else if (lhs->mode.len == 16) {
          RECCPY (proc, "_up_complex");
        } else if (lhs->mode.len == 32) {
          RECCPY (proc, "_up_complex_32");
        }
      } else {
        OP_ERROR (1510, "not an arithmetic operand");
      }
      _srecordf (lhs->str, "%s (%s, %s)", proc, lhs->str, rhs->str);
      return;
    }
  }
}

void oper (EXPR * lhs, EXPR * rhs, char *op)
{
//
  if (lhs->mode.type == ETYPE || rhs->mode.type == ETYPE) {
    lhs->mode.type = ETYPE;
    return;
  }
//
  if (EQUAL (op, ".not.") || EQUAL (op, "!")) {
    _srecordf (lhs->str, "! (%s)", rhs->str);\
    lhs->mode = (MODE) {.type = LOGICAL, .len = 4, .dim = 0};\
    return;
  }
//
#define MIXED(p, f_op, q, r, c_op) {\
  if ((lhs->mode.type == (p) && rhs->mode.type == (q)) ||\
      (lhs->mode.type == (q) && rhs->mode.type == (p))) {\
    if (EQUAL (op, f_op)) {\
      _srecordf (lhs->str, "%s %s %s", lhs->str, c_op, rhs->str);\
      lhs->mode = (MODE) {.type = r, .len = mix_len (lhs, rhs), .dim = 0};\
      return;\
    }\
  }}
//
#define LOGIC(p, f_op, q, c_op) {\
  if ((lhs->mode.type == (p) && rhs->mode.type == (q)) ||\
      (lhs->mode.type == (q) && rhs->mode.type == (p))) {\
    if (EQUAL (op, f_op)) {\
      _srecordf (lhs->str, "%s %s %s", lhs->str, c_op, rhs->str);\
      lhs->mode = (MODE) {.type = LOGICAL, .len = 4, .dim = 0};\
      return;\
    }\
  }}
//
  if (lhs->mode.type == CHARACTER) {
    oper_char (lhs, rhs, op);
  } else if ((TYPE (lhs, COMPLEX, 64)) || (TYPE (rhs, COMPLEX, 64))) {
    oper_complex_64 (lhs, rhs, op);
  } else if ((TYPE (lhs, REAL, 32)) || (TYPE (rhs, REAL, 32))) {
    oper_real_32 (lhs, rhs, op);
  } else if (EQUAL (op, "**")) {
    power (lhs, rhs, op);
  } else {
    MIXED (INTEGER, "+", INTEGER, INTEGER, "+");
    MIXED (INTEGER, "+", REAL, REAL, "+");
    MIXED (INTEGER, "+", COMPLEX, COMPLEX, "+");
    MIXED (INTEGER, "-", INTEGER, INTEGER, "-");
    MIXED (INTEGER, "-", REAL, REAL, "-");
    MIXED (INTEGER, "-", COMPLEX, COMPLEX, "-");
    MIXED (INTEGER, "*", INTEGER, INTEGER, "*");
    MIXED (INTEGER, "*", REAL, REAL, "*");
    MIXED (INTEGER, "*", COMPLEX, COMPLEX, "*");
    MIXED (INTEGER, "/", INTEGER, INTEGER, "/");
    MIXED (INTEGER, ".mod.", INTEGER, INTEGER, "%");
    MIXED (INTEGER, "*%", INTEGER, INTEGER, "%");
    MIXED (INTEGER, "/", REAL, REAL, "/");
    MIXED (INTEGER, "/", COMPLEX, COMPLEX, "/");
    MIXED (INTEGER, ".eq.", INTEGER, LOGICAL, "==");
    MIXED (INTEGER, ".eq.", REAL, LOGICAL, "==");
    MIXED (INTEGER, ".eq.", COMPLEX, LOGICAL, "==");
    MIXED (INTEGER, ".ne.", INTEGER, LOGICAL, "!=");
    MIXED (INTEGER, ".ne.", REAL, LOGICAL, "!=");
    MIXED (INTEGER, ".ne.", COMPLEX, LOGICAL, "!=");
    MIXED (INTEGER, ".le.", INTEGER, LOGICAL, "<=");
    MIXED (INTEGER, ".le.", REAL, LOGICAL, "<=");
    MIXED (INTEGER, ".ge.", INTEGER, LOGICAL, ">=");
    MIXED (INTEGER, ".ge.", REAL, LOGICAL, ">=");
    MIXED (INTEGER, ".lt.", INTEGER, LOGICAL, "<");
    MIXED (INTEGER, ".lt.", REAL, LOGICAL, "<");
    MIXED (INTEGER, ".gt.", INTEGER, LOGICAL, ">");
    MIXED (INTEGER, ".gt.", REAL, LOGICAL, ">");
    MIXED (INTEGER, "==", INTEGER, LOGICAL, "==");
    MIXED (INTEGER, "==", REAL, LOGICAL, "==");
    MIXED (INTEGER, "==", COMPLEX, LOGICAL, "==");
    MIXED (INTEGER, "/=", INTEGER, LOGICAL, "!=");
    MIXED (INTEGER, "/=", REAL, LOGICAL, "!=");
    MIXED (INTEGER, "/=", COMPLEX, LOGICAL, "!=");
    MIXED (INTEGER, "<=", INTEGER, LOGICAL, "<=");
    MIXED (INTEGER, "<=", REAL, LOGICAL, "<=");
    MIXED (INTEGER, ">=", INTEGER, LOGICAL, ">=");
    MIXED (INTEGER, ">=", REAL, LOGICAL, ">=");
    MIXED (INTEGER, "<", INTEGER, LOGICAL, "<");
    MIXED (INTEGER, "<", REAL, LOGICAL, "<");
    MIXED (INTEGER, ">", INTEGER, LOGICAL, ">");
    MIXED (INTEGER, ">", REAL, LOGICAL, ">");
//
    MIXED (REAL, "+", REAL, REAL, "+");
    MIXED (REAL, "+", COMPLEX, COMPLEX, "+");
    MIXED (REAL, "-", REAL, REAL, "-");
    MIXED (REAL, "-", COMPLEX, COMPLEX, "-");
    MIXED (REAL, "*", REAL, REAL, "*");
    MIXED (REAL, "*", COMPLEX, COMPLEX, "*");
    MIXED (REAL, "/", REAL, REAL, "/");
    MIXED (REAL, "/", COMPLEX, COMPLEX, "/");
    MIXED (REAL, ".eq.", REAL, LOGICAL, "==");
    MIXED (REAL, ".eq.", COMPLEX, LOGICAL, "==");
    MIXED (REAL, ".ne.", REAL, LOGICAL, "!=");
    MIXED (REAL, ".ne.", COMPLEX, LOGICAL, "!=");
    MIXED (REAL, ".le.", REAL, LOGICAL, "<=");
    MIXED (REAL, ".ge.", REAL, LOGICAL, ">=");
    MIXED (REAL, ".lt.", REAL, LOGICAL, "<");
    MIXED (REAL, ".gt.", REAL, LOGICAL, ">");
    MIXED (REAL, "==", REAL, LOGICAL, "==");
    MIXED (REAL, "==", COMPLEX, LOGICAL, "==");
    MIXED (REAL, "/=", REAL, LOGICAL, "!=");
    MIXED (REAL, "/=", COMPLEX, LOGICAL, "!=");
    MIXED (REAL, "<=", REAL, LOGICAL, "<=");
    MIXED (REAL, ">=", REAL, LOGICAL, ">=");
    MIXED (REAL, "<", REAL, LOGICAL, "<");
    MIXED (REAL, ">", REAL, LOGICAL, ">");
//
    MIXED (COMPLEX, "+", COMPLEX, COMPLEX, "+");
    MIXED (COMPLEX, "-", COMPLEX, COMPLEX, "-");
    MIXED (COMPLEX, "*", COMPLEX, COMPLEX, "*");
    MIXED (COMPLEX, "/", COMPLEX, COMPLEX, "/");
    MIXED (COMPLEX, ".eq.", COMPLEX, LOGICAL, "==");
    MIXED (COMPLEX, ".ne.", COMPLEX, LOGICAL, "!=");
    MIXED (COMPLEX, "==", COMPLEX, LOGICAL, "==");
    MIXED (COMPLEX, "/=", COMPLEX, LOGICAL, "!=");
//
    LOGIC (LOGICAL, "==", LOGICAL, "==");
    LOGIC (LOGICAL, "/=", LOGICAL, "!=");
    LOGIC (LOGICAL, ".eq.", LOGICAL, "==");
    LOGIC (LOGICAL, ".neq.", LOGICAL, "!=");
    LOGIC (LOGICAL, ".and.", LOGICAL, "&&");
    LOGIC (LOGICAL, "&", LOGICAL, "&&");
    LOGIC (LOGICAL, ".or.", LOGICAL, "||");
    LOGIC (LOGICAL, "|", LOGICAL, "||");
    LOGIC (LOGICAL, ".xor.", LOGICAL, "^");
    LOGIC (LOGICAL, "^", LOGICAL, "^");
    LOGIC (LOGICAL, ".eqv.", LOGICAL, "==");
    LOGIC (LOGICAL, ".neqv.", LOGICAL, "^");
//
    OP_ERROR (1511, "undefined operator");
  }
#undef MIXED
#undef LOGIC
}

int_4 oper_prio (char *op, int_4 prio)
{
  if (TOKEN (")")) {
    return FALSE;
  } else if (TOKEN ("=")) {
    return FALSE;
  }
// According VAX FORTRAN.
  switch (prio) {
  case 1: {
      return TOKEN (".eqv.") || TOKEN (".neqv.") || TOKEN (".xor.") || TOKEN ("^");
    }
  case 2: {
      return TOKEN (".or.") || TOKEN ("|");
    }
  case 3: {
      return TOKEN (".and.") || TOKEN ("&");
    }
  case 4: {
      return TOKEN (".not.") || TOKEN ("!");
    }
  case 5: {
      return TOKEN (".eq.") || TOKEN (".ne.") || 
             TOKEN (".lt.") || TOKEN (".le.") || 
             TOKEN (".gt.") || TOKEN (".ge.") ||
             TOKEN ("==") || TOKEN ("/=") ||
             TOKEN ("<") || TOKEN ("<=") || 
             TOKEN (">") || TOKEN (">=");
    }
  case 6: {
      return TOKEN ("+") || TOKEN ("-") || TOKEN ("//");
    }
  case 7: {
      return TOKEN ("*") || TOKEN ("/") || TOKEN (".mod.") || TOKEN ("*%");
    }
  case 8: {
      return TOKEN ("**");
    }
  }
  return FALSE;
}

void exprio (EXPR * reg, int_4 prio, logical_4 no_dim_var)
{
  if (prio == MAX_PRIO) {
    if (TOKEN (".not.") || TOKEN ("!")) {
      _srecordf (reg->str, "TRUE");
      reg->mode = (MODE) {.type = LOGICAL,.len = 4,.dim = 0};
      reg->variant = EXPR_CONST;
      UNSCAN;
    } else {
      factor (reg);
      if (no_dim_var && reg->variant == EXPR_VAR) {
        IDENT *idf = impl_decl (reg->str, NO_MODE);
        if (idf != NO_IDENT && IS_ROW (idf->mode)) {
          ERROR (1512, "dimensioned variable cannot be an operand", curlex);
        }
      }
    }
  } else {
    int_4 rc;
    EXPR lhs;
    memset (&lhs, 0, sizeof (EXPR));
//
    exprio (&lhs, prio + 1, no_dim_var);
    rc = scan (EXPECT_NONE);
    while (oper_prio (curlex, prio)) {
      EXPR rhs;
      NEW_RECORD (op);
      memset (&rhs, 0, sizeof (EXPR));
      RECCPY (op, curlex);
      rc = scan (EXPECT_NONE);
      if (prio == MAX_PRIO - 1) {
        exprio (&rhs, prio, no_dim_var);
      } else {
        exprio (&rhs, prio + 1, no_dim_var);
      }
      oper (&lhs, &rhs, op);
      if (lhs.variant == EXPR_CONST && rhs.variant == EXPR_CONST) {
        ;
      } else {
        lhs.variant = EXPR_OTHER;
      }
      rc = scan (EXPECT_NONE);
    }
    memcpy (reg, &lhs, sizeof (EXPR));
    UNSCAN;
    (void) rc;
  }
}

#undef OP_ERROR

logical_4 express (EXPR * reg, int_4 expect, int_4 len)
{
  MODE expect_type = (MODE) {.type = expect, .len = len, .dim = 0 };
  memset (reg, 0, sizeof (EXPR));
  exprio (reg, 1, FALSE);
  if (!valid_expr (reg)) {
    return FALSE;
  }
  (void) fold_expr (reg, expect);
  if (reg->variant == EXPR_CONST && reg->mode.type == INTEGER && expect == INTEGER) {
// INTEGER length denotations overlap.
    factor_integer_number (reg, reg->str);
    if (reg->mode.len <= len) {
      reg->mode.len = len;
      return TRUE;
    } else {
      MODE_ERROR (1513, qtype (&(reg->mode)), qtype (&expect_type));
      return FALSE;
    } 
  } else if (accept_mode (reg->mode.type, reg->mode.len, expect, len)) {
    return TRUE;
  } else {
    MODE_ERROR (1514, qtype (&(reg->mode)), qtype (&expect_type));
    return FALSE;
  }
}
