//! @file factor.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 expression factors.

#include <vif.h>

static void implicit_name (EXPR *loc, IDENT *idf, MODE *mode, RECORD name)
{
  UNSCAN;
  idf = impl_decl (name, mode);
  if (idf != NO_IDENT && idf->mode.type == NOTYPE && idf->external == FALSE) {
    ERROR (1701, "variable has no type", F_NAME (idf));
  }
  _srecordf (loc->str, "%s", C_NAME (idf));
  loc->variant = EXPR_VAR;
  loc->idf = idf;
  loc->mode = idf->mode;
}

void factor_variable (EXPR *loc, IDENT *idf, MODE *mode, RECORD name)
{
  if (idf == NO_IDENT) {
    idf = impl_decl (name, mode);
  }
  if (idf == NO_IDENT) {
    BUG ("cannot store identifier");
  }
  if (idf->mode.type == NOTYPE && idf->external == FALSE) {
    ERROR (1702, "variable has no type", F_NAME (idf));
  }
  if (idf->arg || idf->alias != NO_IDENT) {
    if (IS_ROW (idf->mode) || idf->mode.type == CHARACTER) {
      _srecordf (loc->str, "%s", C_NAME (idf), RECLN);
    } else {
      _srecordf (loc->str, "(*%s)", C_NAME (idf), RECLN);
    }
  } else {
    if (NOT_LOCAL (idf)) {
      (void) idf_full_c_name (loc->str, idf);
    } else if (idf->nest > 0) {
      NEW_RECORD (res);
      _srecordf (res, "%s", edit_vn (C_NAME (idf), idf->nest));
      bufcat (loc->str, res, RECLN);
    } else {
      bufcat (loc->str, C_NAME (idf), RECLN);
    }
  }
  loc->variant = EXPR_VAR;
  loc->idf = idf;
  loc->mode = idf->mode;
}

void factor_integer_number (EXPR *loc, char *str)
{
// We let length depend on the denotation.
  int_8 val = strtoll (str, NO_REF_TEXT, 10);
  loc->variant = EXPR_CONST;
  if (val >= SHRT_MIN && val <= SHRT_MAX) {
    _srecordf (loc->str, "%s", str);
    loc->mode = (MODE) {.type = INTEGER, .len = 2, .dim = 0};
  } else if (val >= INT_MIN && val <= INT_MAX) {
    _srecordf (loc->str, "%s", str);
    loc->mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
  } else if (val >= LLONG_MIN && val <= LLONG_MAX) {
    _srecordf (loc->str, "%s", str);
    loc->mode = (MODE) {.type = INTEGER, .len = 8, .dim = 0};
  } else {
    FATAL (1703, INTERNAL_CONSISTENCY, NO_TEXT);
  }
}

static void factor_real_number (EXPR *loc)
{
  char *expo;
  NEW_RECORD (edit);
  RECCPY (edit, curlex);
  if ((expo = strchr (edit, 'e')) != NO_TEXT || (expo = strchr (edit, 'E')) != NO_TEXT) {
    loc->mode = (MODE) {.type = REAL, .len = 4, .dim = 0};
    _srecordf (loc->str, "%s", pretty_float (edit));
  } else if ((expo = strchr (edit, 'd')) != NO_TEXT || (expo = strchr (edit, 'D')) != NO_TEXT) {
    *expo = 'e';
    loc->mode = (MODE) {.type = REAL, .len = 8, .dim = 0};
    _srecordf (loc->str, "%s", pretty_float (edit));
  } else if ((expo = strchr (edit, 'q')) != NO_TEXT || (expo = strchr (edit, 'Q')) != NO_TEXT) {
    *expo = 'e';
    loc->mode = (MODE) {.type = REAL, .len = 16, .dim = 0};
    _srecordf (loc->str, "%sq", pretty_float (edit));
  } else if ((expo = strchr (edit, 'x')) != NO_TEXT || (expo = strchr (edit, 'X')) != NO_TEXT) {
    *expo = 'e';
    loc->mode = (MODE) {.type = REAL, .len = 32, .dim = 0};
    _srecordf (loc->str, "_dc_%d", code_real_32_const (pretty_float (edit)));
  } else {
// No exponent.
    loc->mode = (MODE) {.type = REAL, .len = 4, .dim = 0};
    _srecordf (loc->str, "%s", pretty_float (edit));
  }
  loc->variant = EXPR_CONST;
}

static void factor_complex_number (EXPR *loc, EXPR lhs)
{
  (void) scan (EXPECT_NONE);
  EXPR rhs;
  memset (&rhs, 0, sizeof (rhs));
  express (&rhs, NOTYPE, 0);
  int_4 len = mix_len (&lhs, &rhs);
  if (len == 32) {
    _srecordf (loc->str, "CMPLXX (%s, %s)", lhs.str, rhs.str);
    loc->mode = (MODE) {.type = COMPLEX, .len = 64, .dim = 0};
  } else if (len == 16) {
    _srecordf (loc->str, "CMPLXQ (%s, %s)", lhs.str, rhs.str);
    loc->mode = (MODE) {.type = COMPLEX, .len = 32, .dim = 0};
  } else if (len == 8) {
    _srecordf (loc->str, "CMPLX (%s, %s)", lhs.str, rhs.str);
    loc->mode = (MODE) {.type = COMPLEX, .len = 16, .dim = 0};
  } else {
    _srecordf (loc->str, "CMPLXF (%s, %s)", lhs.str, rhs.str);
    loc->mode = (MODE) {.type = COMPLEX, .len = 8, .dim = 0};
  }
  if (lhs.variant == EXPR_CONST && rhs.variant == EXPR_CONST) {
    loc->variant = EXPR_CONST;
  }
  (void) scan (EXPECT_NONE);
}

void factor (EXPR * reg)
{
  int_4 rc;
  MODE mode;
  EXPR loc;
  NEW_RECORD (name);
  bufcpy (name, curlex, RECLN);
  memset (&loc, 0, sizeof (EXPR));
  loc.variant = EXPR_OTHER;
  if (curret == WORD || curret == DECLAR) { 
    IDENT *idf = find_local (name, &mode);
    logical_4 pack = lookahead ("(");
    if (curret == DECLAR && pack) {
      // Some intrinsics share name with a declarer, like REAL (I).
      intrinsic_call (name, &loc);
      memcpy (reg, &loc, sizeof (EXPR));
      return;
    }
    if (idf != NO_IDENT && idf->intrinsic && !pack) {
      // Intrinsic function as parameter must be 'specific'.
      // Otherwise ambiguity results -> implementation dependent result.
      // implicit dcos
      // call zeroin (dcos, ...)
      if (!is_specific (name)) {
        EXPECT (1704, "generic intrinsic subprogram name");
      }
      reg->idf = idf;
      _srecordf (reg->str, "%s", edit_i (name));
      reg->variant = EXPR_VAR;
      return;
    }
    if (idf != NO_IDENT && idf->intrinsic && pack) {
      // intrinsic dcos
      // ... dcos (x) 
      rc = scan (EXPECT_NONE);
      if (TOKEN ("(")) {
        factor_function_call (&loc, name);
      }
      memcpy (reg, &loc, sizeof (EXPR));
      (void) rc;
      return;
    }
    if (! (idf != NO_IDENT && idf->external)) {
      // Not a call to a declared external name.
      logical_4 int_call = FALSE;
      if (idf != NO_IDENT && idf->intrinsic && pack) {
        int_call = intrinsic_call (name, &loc);
      } else if (idf == NO_IDENT) {
        int_call = intrinsic_call (name, &loc);
      }
      if (int_call) {
        memcpy (reg, &loc, sizeof (EXPR));
        return;
      } 
    }
    if (idf != NO_IDENT && idf->mode.dim == 0 && !idf->intrinsic && !idf->external && pack) {
      // Name is declared but not as intrinsic or external.
      // In VIF this gives a check on function return type.
      // real*8 cos
      // y = cos (1.0d0)
      INTRINS *fun;
      if (is_intrins (name, &fun)) {
        if (intrinsic_call (name, &loc)) {
          if (!accept_mode (loc.mode.type, loc.mode.len, idf->mode.type, idf->mode.len)) {
            MODE_ERROR (1705, qtype (&(loc.mode)), qtype (&(idf->mode)));
          }
          memcpy (reg, &loc, sizeof (EXPR));
          return;
        }
      }
    }
    if (idf == NO_IDENT || idf->external) {
      // Undefined locally can mean function call.
      // In VIF, 'external' always means you supply the routine.
      // external cos
      // call zeroin (cos, ...)
      rc = scan (EXPECT_NONE);
      if (TOKEN ("(")) {
        factor_function_call (&loc, name);
      } else {
        implicit_name (&loc, idf, &mode, name);
      }
      memcpy (reg, &loc, sizeof (EXPR));
      (void) rc;
      return;
    }
    // 
    if (pack) {
      rc = scan (EXPECT_NONE);
      idf = impl_decl (name, &mode);
      if (idf->mode.type == CHARACTER) {
        factor_slice_char (&loc, idf);
        if (idf->parm) {
          loc.mode = idf->mode;
          loc.variant = EXPR_CONST;
        }
      } else if (IS_SCALAR (idf->mode)) {
        if (strcmp (name, modnam) == 0) {
          recursion (&loc, modnam, idf);
        } else if (idf->source == MACRO) {
          macro (&loc, idf);
        } else {
          factor_function_call (&loc, name);
        }
      } else {
        // Row slice.
        factor_slice (&loc, idf);
      }
    } else {
      if (idf->parm) {
        bufcat (loc.str, idf->parm, RECLN);
        loc.mode = idf->mode;
        loc.variant = EXPR_CONST;
      } else {
        idf = impl_decl (name, &mode);
        factor_variable (&loc, idf, &mode, name);
      }
    }
    memcpy (reg, &loc, sizeof (EXPR));
    return;
  } else if (TOKEN ("+")) {
// + factor.
    EXPR fac;
    memset (&fac, 0, sizeof (EXPR));
    rc = scan (EXPECT_NONE);
    factor (&fac);
    if (fac.mode.type != INTEGER && fac.mode.type != REAL && fac.mode.type != COMPLEX) {
      EXPECT (1706, "arithmetical expression");
    }
    _srecordf (loc.str, "%s", fac.str);
    loc.mode = fac.mode;
    if (fac.variant == EXPR_CONST) {
      loc.variant = EXPR_CONST;
    } else {
      loc.variant = EXPR_OTHER;
    }
  } else if (TOKEN ("-")) {
// - factor.
    EXPR fac;
    memset (&fac, 0, sizeof (EXPR));
    rc = scan (EXPECT_NONE);
    factor (&fac);
    if (fac.mode.type != INTEGER && fac.mode.type != REAL && fac.mode.type != COMPLEX) {
      EXPECT (1707, "arithmetical expression");
    }
    if (fac.mode.type == COMPLEX && fac.mode.len == 64) {
      _srecordf (loc.str, "cxneg (%s)", fac.str);
    } else if (fac.mode.type == REAL && fac.mode.len == 32) {
      _srecordf (loc.str, "xneg (%s)", fac.str);
    } else {
      _srecordf (loc.str, "-%s", fac.str);
    }
    loc.mode = fac.mode;
    if (fac.variant == EXPR_CONST) {
      loc.variant = EXPR_CONST;
    } else {
      loc.variant = EXPR_OTHER;
    }
  } else if (TOKEN (".true.") || TOKEN (".t.")) {
// LOGICAL constant TRUE.
    _srecordf (loc.str, "TRUE");
    loc.mode = (MODE) {
    .type = LOGICAL, .len = 4, .dim = 0};
    loc.variant = EXPR_CONST;
  } else if (TOKEN (".false.") || TOKEN (".f.")) {
// LOGICAL constant FALSE.
    _srecordf (loc.str, "FALSE");
    loc.mode = (MODE) {
    .type = LOGICAL, .len = 4, .dim = 0};
    loc.variant = EXPR_CONST;
  } else if (curret == INT_NUMBER) {
// INTEGER constant.
    factor_integer_number (&loc, curlex);
    MAXIMISE (loc.mode.len, 4);
  } else if (curret == FLT_NUMBER) {
// REAL constnat.
    factor_real_number (&loc);
  } else if (curret == TEXT) {
// TEXT constant.
    NEW_RECORD (idf);
    _srecordf (idf, "_dc_%d", code_uniq_str (curlex));
    _srecordf (loc.str, "%s", idf);
    int len = strlen (curlex) - 2;
    if (len < 1) {
      len = 1;
    }
    loc.mode = (MODE) {.type = CHARACTER, .len = len, .dim = 0};
    norm_mode (&loc.mode);
    loc.variant = EXPR_CONST;
  } else if (TOKEN ("(")) {
    EXPR lhs;
    memset (&lhs, 0, sizeof (lhs));
    rc = scan (EXPECT_NONE);
    express (&lhs, NOTYPE, 0);
    rc = scan (EXPECT_NONE);
    if (TOKEN (",")) {
// COMPLEX number.
      factor_complex_number (&loc, lhs);
    } else {
// Parenthesized expression.
      if (lhs.variant == EXPR_CONST) {
        loc.variant = EXPR_CONST;
        _srecordf (loc.str, "%s", lhs.str);
      } else {
        loc.variant = EXPR_OTHER;
        _srecordf (loc.str, "(%s)", lhs.str);
      }
      loc.mode = lhs.mode;
    }
    CHECKPOINT (1708, ")");
  } else {
    ERROR (1709, "expected operand", NO_TEXT);
    loc.mode.type = ETYPE;
  }
  memcpy (reg, &loc, sizeof (EXPR));
  (void) rc;
}
