//! @file fold.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
//!
//! Constant folder.

#include <vif.h>
#include <rts-real32.h>

// A trivial calculator to compiler generated constant expressions.

// INTEGER
// Exponentiation is already optimised by the code generator.

static int_4 calc_int_add (char **, int_4 *);

static int_4 calc_int_fact (char **s, int_4 *val)
{
  while (isspace (*s[0])) {
    (*s)++;
  }
  if (isdigit ((*s)[0])) {
    *val = strtol (*s, s, 10);
    return TRUE;
  } else if ((*s)[0] == '-') {
    int_4 rc;
    (*s)++;
    rc = calc_int_fact (s, val);
    *val = -*val;
    return rc;
  } else if ((*s)[0] == '(') {
    int_4 rc, sub;
    (*s)++;
    rc = calc_int_add (s, &sub);
    (*s)++; // Assume ')'
    *val = sub;
    return rc;
  }
  return FALSE;
}

static int_4 calc_int_mul (char **s, int_4 *val)
{
  int_4 lval, rval;
  if (!calc_int_fact (s, &lval)) {
    return FALSE;
  }
  while (isspace (*s[0])) {
    (*s)++;
  }
  while ((*s)[0] != '\0' && ((*s)[0] == '*' || (*s)[0] == '/' || (*s[0]) == '%')) {
    char op = (*s)++[0];
    if (!calc_int_fact (s, &rval)) {
      return FALSE;
    }
    if (op == '*') {
      lval *= rval;
    } else if (op == '/') {
      lval /= rval;
    } else {
      lval %= rval;
    }
    while ((*s)[0] == ' ') {
      (*s)++;
    }
  }
  *val = lval;
  return TRUE;
}

static int_4 calc_int_add (char **s, int_4 *val)
{
  int_4 lval, rval;
  if (!calc_int_mul (s, &lval)) {
    return FALSE;
  }
  while ((*s)[0] == ' ') {
    (*s)++;
  }
  while ((*s)[0] != '\0' && ((*s)[0] == '+' || (*s)[0] == '-')) {
    char op = (*s)++[0];
    if (!calc_int_mul (s, &rval)) {
      return FALSE;
    }
    if (op == '+') {
      lval += rval;
    } else {
      lval -= rval;
    }
    while (isspace (*s[0])) {
      (*s)++;
    }
  }
  *val = lval;
  return TRUE;
}

int_4 calc_int_4 (char *p, int_4 *val)
{
  char *q = p;
  int_4 rc = calc_int_add (&q, val) && (q[0] == '\0');
  return rc;
}

void fold_int_4 (char *buf, char *p)
{
  NEW_RECORD (q);
  int_4 val;
  bufcpy (q, p, RECLN);
  if (calc_int_4 (q, &val)) {
    _srecordf (buf, "%d", val);
  } else {
    bufcpy (buf, p, RECLN);
  }
}

// REAL
// Exponentiation is already optimised by the code generator.

static int_4 calc_real_add (char **, real_32 *);

static int_4 calc_real_fact (char **s, real_32 *val)
{
  while (isspace (*s[0])) {
    (*s)++;
  }
  if (isdigit ((*s)[0])) {
    *val = strtox (*s, s);
    if ((*s)[0] == 'q') {
      (*s)++;
    }
    return TRUE;
  } else if ((*s)[0] == '-') {
    int_4 rc;
    (*s)++;
    rc = calc_real_fact (s, val);
    *val = xneg (*val);
    return rc;
  } else if ((*s)[0] == '(') {
    int_4 rc;
    real_32 sub;
    (*s)++;
    rc = calc_real_add (s, &sub);
    (*s)++; // Assume ')'
    *val = sub;
    return rc;
  }
  return FALSE;
}

static int_4 calc_real_mul (char **s, real_32 *val)
{
  real_32 lval, rval;
  if (!calc_real_fact (s, &lval)) {
    return FALSE;
  }
  while (isspace (*s[0])) {
    (*s)++;
  }
  while ((*s)[0] != '\0' && ((*s)[0] == '*' || (*s)[0] == '/')) {
    char op = (*s)++[0];
    if (!calc_real_fact (s, &rval)) {
      return FALSE;
    }
    if (op == '*') {
      lval = xmul (lval, rval);
    } else if (op == '/') {
      if (xis0 (&rval)) {
        ERROR (1801, "division by zero", NO_TEXT);
        return FALSE;
      } else {
        lval = xdiv (lval, rval);
      }
    }
    while ((*s)[0] == ' ') {
      (*s)++;
    }
  }
  *val = lval;
  return TRUE;
}

static int_4 calc_real_add (char **s, real_32 *val)
{
  real_32 lval, rval;
  if (!calc_real_mul (s, &lval)) {
    return FALSE;
  }
  while ((*s)[0] == ' ') {
    (*s)++;
  }
  while ((*s)[0] != '\0' && ((*s)[0] == '+' || (*s)[0] == '-')) {
    char op = (*s)++[0];
    if (!calc_real_mul (s, &rval)) {
      return FALSE;
    }
    if (op == '+') {
      lval = xadd (lval, rval, 0);
    } else {
      lval = xadd (lval, rval, 1);
    }
    while (isspace (*s[0])) {
      (*s)++;
    }
  }
  *val = lval;
  return TRUE;
}

int_4 calc_real (char *p, real_32 *val)
{
  char *q = p;
  int_4 rc = calc_real_add (&q, val) && (q[0] == '\0');
  return rc;
}

// COMPLEX

static int_4 calc_complex_add (char **, complex_64 *);

int skip (char **q, char *p)
{
  size_t N = strlen (p);
  if (strncmp (*q, p, N) == 0) {
    (*q) += N;
    return TRUE;
  } else {
    return FALSE;
  }
}

static int_4 calc_complex_fact (char **s, complex_64 *val)
{
  while (isspace (*s[0])) {
    (*s)++;
  }
  (void) skip (s, "CMPLXQ");
  (void) skip (s, "CMPLXF");
  (void) skip (s, "CMPLX");
  while (isspace (*s[0])) {
    (*s)++;
  }
  if (isdigit ((*s)[0])) {
    real_32 z;
    z = strtox (*s, s);
    if ((*s)[0] == 'q') {
      (*s)++;
    }
    *val = (complex_64) {z, X_0};
    return TRUE;
  } else if ((*s)[0] == '-') {
    int_4 rc;
    (*s)++;
    rc = calc_complex_fact (s, val);
    *val = cxneg (*val);
    return rc;
  } else if ((*s)[0] == '(') {
    int_4 rc;
    complex_64 sub;
    (*s)++;
    char *t = *s;
    if (isdigit ((*s)[0]) || (*s)[0] == '+' || (*s)[0] == '-') {
      real_32 re, im;
      re = strtox (*s, s);
      if ((*s)[0] == 'q') {
        (*s)++;
      }
      if ((*s)[0] == ',') {
        (*s)++;
        im = strtox (*s, s);
        if ((*s)[0] == 'q') {
          (*s)++;
        }
        sub = (complex_64) {re, im};
        rc = TRUE;
      } else {
        *s = t;
        rc = calc_complex_add (s, &sub);
      }
    } else {
      rc = calc_complex_add (s, &sub);
    }
    (*s)++; // Assume ')'
    *val = sub;
    return rc;
  }
  return FALSE;
}

static int_4 calc_complex_mul (char **s, complex_64 *val)
{
  complex_64 lval, rval;
  if (!calc_complex_fact (s, &lval)) {
    return FALSE;
  }
  while (isspace (*s[0])) {
    (*s)++;
  }
  while ((*s)[0] != '\0' && ((*s)[0] == '*' || (*s)[0] == '/')) {
    char op = (*s)++[0];
    if (!calc_complex_fact (s, &rval)) {
      return FALSE;
    }
    if (op == '*') {
      lval = cxmul (lval, rval);
    } else if (op == '/') {
      lval = cxdiv (lval, rval);
    }
    while ((*s)[0] == ' ') {
      (*s)++;
    }
  }
  *val = lval;
  return TRUE;
}

static int_4 calc_complex_add (char **s, complex_64 *val)
{
  complex_64 lval, rval;
  if (!calc_complex_mul (s, &lval)) {
    return FALSE;
  }
  while ((*s)[0] == ' ') {
    (*s)++;
  }
  while ((*s)[0] != '\0' && ((*s)[0] == '+' || (*s)[0] == '-')) {
    char op = (*s)++[0];
    if (!calc_complex_mul (s, &rval)) {
      return FALSE;
    }
    if (op == '+') {
      lval = cxsum (lval, rval);
    } else {
      lval = cxsub (lval, rval);
    }
    while (isspace (*s[0])) {
      (*s)++;
    }
  }
  *val = lval;
  return TRUE;
}

int_4 calc_complex (char *p, complex_64 *val)
{
  char *q = p;
  int_4 rc = calc_complex_add (&q, val) && (q[0] == '\0');
  return rc;
}

// Drivers.

char *pretty_float (char *num)
{
// Cut zero exponent and end-zeroes in floats.
  NEW_RECORD (expo);
  char *e = strchr (num, 'e');
  if (e != NO_TEXT) {
    _srecordf (expo, "%s", &e[1]);
    *e = '\0';
  }
  NEW_RECORD (frac);
  char *f = strchr (num, '.');
  if (f != NO_TEXT) {
    _srecordf (frac, "%s", &f[1]);
    *f = '\0';
  }
// Simplify exponent.
  if (e != NO_TEXT) {
    int expd;
    sscanf (expo, "%d", &expd);
    if (expd != 0) {
      _srecordf (expo, "%d", expd);
    }
  }
// Simplify fraction.
  while (strlen (frac) > 0 && frac[strlen (frac) - 1] == '0') {
    frac[strlen (frac) - 1] = '\0';
  }
// Compose pretty float,
  if (strlen (frac) > 0) {
    strcat (num, ".");
    strcat (num, frac);
  } else {
    strcat (num, ".0");
  }
  if (strlen (expo) > 0) {
    strcat (num, "e");
    strcat (num, expo);
  }
  return num;
}

void pretty_number (char *num, int_4 prec, real_32 val)
{
  NEW_RECORD (stre); NEW_RECORD (strf); NEW_RECORD (fmt);
  _srecordf (fmt, "%%.%df", prec);
  _fprintf_real_32 (strf, fmt, val, 5, FLT256_DIG);
  real_32 valf = strtox (strf, NO_REF_TEXT);
  _srecordf (fmt, "%%.%de", prec);
  _fprintf_real_32 (stre, fmt, val, 5, FLT256_DIG);
  real_32 vale = strtox (stre, NO_REF_TEXT);
  if (xeq (vale, valf)) {
    _srecordf (num, "%s", pretty_float (strf));
  } else {
    _srecordf (num, "%s", pretty_float (stre));
  }
}

void pretty_real (char *num, int_4 prec, real_32 val)
{
  switch (prec) {
    case 4: {
      pretty_number (num, FLT_DIG + 1, val);
      return;
    }
    case 8: {
      pretty_number (num, DBL_DIG + 1, val);
      return;
    }
    case 16: {
      pretty_number (num, FLT128_DIG + 1, val);
      bufcat (num, "q", RECLN);
      return;
    }
    case 32: {
      pretty_number (num, FLT256_DIG, val);
      return;
    }
  }
}

void pretty_complex (char *num, int_4 prec, complex_64 cval)
{
  NEW_RECORD (RE);
  NEW_RECORD (IM);
  switch (prec) {
    case 8: {
      pretty_real (RE, 4, cxreal (cval));
      pretty_real (IM, 4, cximag (cval));
      _srecordf (num, "CMPLXF (%s, %s)", RE, IM);
      return;
    }
    case 16: {
      pretty_real (RE, 8, cxreal (cval));
      pretty_real (IM, 8, cximag (cval));
      _srecordf (num, "CMPLX (%s, %s)", RE, IM);
      return;
    }
    case 32: {
      pretty_real (RE, 16, cxreal (cval));
      pretty_real (IM, 16, cximag (cval));
      _srecordf (num, "CMPLXQ (%s, %s)", RE, IM);
      return;
    }
  }
}

logical_4 fold_intrinsic (INTRINS *F, EXPR *lhs, EXPR *rhs)
{
  if (lhs->variant != EXPR_CONST) {
    return FALSE;
  } else if (!valid_expr (lhs)) {
    return FALSE;
  } else if (rhs != NO_EXPR && rhs->variant != EXPR_CONST) {
    return FALSE;
  } else if (rhs != NO_EXPR && !valid_expr (rhs)) {
    return FALSE;
  } else if (F->f3 != NULL && rhs == NO_EXPR) {
    complex_64 lval;
    if (! (accept_mode (lhs->mode.type, lhs->mode.len, COMPLEX, 32) && calc_complex (lhs->str, &lval))) {
      return FALSE;
    }
    complex_64 cval = (F->f3) (lval);
    pretty_complex (lhs->str, F->alen, cval);
    return TRUE;
  } else {
    NEW_RECORD (num);
    num[0] = '\0';
    real_32 lval;
    if (! (accept_mode (lhs->mode.type, lhs->mode.len, REAL, 16) && calc_real (lhs->str, &lval))) {
      return FALSE;
    }
    if (F->f1 != NULL) {
// Single-argumenters.
      pretty_real (num, 32, (F->f1) (lval));
    }
    if (rhs != NO_EXPR) {
      real_32 rval;
      if (! (accept_mode (rhs->mode.type, rhs->mode.len, REAL, 16) && calc_real (rhs->str, &rval))) {
        return FALSE;
      }
      if (F->f2 != NULL) {
// Two-argumenters.
        pretty_real (num, 32, (F->f2) (lval, rval));
      }
    }
    if (strlen (num) > 0) {
      RECCPY (lhs->str, num);
      return TRUE;
    } else {
      return FALSE;
    }
  }
}

logical_4 fold_expr (EXPR *reg, int_4 expect) 
{
  if (reg->variant != EXPR_CONST) {
    return FALSE;
  } else if (!valid_expr (reg)) {
    return FALSE;
  } else {
    if ((reg->mode.type == INTEGER || (reg->mode.type == REAL && reg->mode.len <= 16))) {
      real_32 rval;
      if (calc_real (reg->str, &rval)) {
        if (reg->mode.type == INTEGER || expect == INTEGER) {
          reg->mode.type = INTEGER;
          reg->mode.len = 4;
          _srecordf (reg->str, "%d", _xint4 (rval));
        } else {
          NEW_RECORD (z);
          RECCLR (z);
          pretty_real (z, reg->mode.len, rval);
          RECCPY (reg->str, z);
        }
        return TRUE;
      } else {
        return FALSE;
      }
    } else if (reg->mode.type == COMPLEX && reg->mode.len <= 32) {
      complex_64 cval;
      if (calc_complex (reg->str, &cval)) {
        pretty_complex (reg->str, reg->mode.len, cval);
        return TRUE;
      } else {
        return FALSE;
      }
    } else {
      return FALSE;
    }
  }
}
