//! @file coerce.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
//!
//! Type conversions for assignments and function statements.

#include <vif.h>

logical_4 coerce (EXPR * lhs, EXPR * rhs)
{
// Sensible defaults.
  RECCPY (lhs->str, rhs->str);
// Oftentimes, no action is required.
  if (lhs->mode.type == rhs->mode.type && lhs->mode.len == rhs->mode.len) {
    return TRUE;
  }
// Warn for possible precision loss.
  if (lhs->mode.type == REAL && rhs->mode.type == REAL) {
    if (lhs->mode.len < rhs->mode.len) {
      PRECISION_LOSS (601, qtype (&(rhs->mode)), qtype (&(lhs->mode)));
    }
  }
  if (lhs->mode.type == COMPLEX && rhs->mode.type == COMPLEX) {
    if (lhs->mode.len < rhs->mode.len) {
      PRECISION_LOSS (602, qtype (&(rhs->mode)), qtype (&(lhs->mode)));
    }
  }
  if (lhs->mode.type == COMPLEX && rhs->mode.type == REAL) {
    if (lhs->mode.len < 2 * rhs->mode.len) {
      PRECISION_LOSS (603, qtype (&(rhs->mode)), qtype (&(lhs->mode)));
    }
  }
  if (lhs->mode.type == REAL && rhs->mode.type == COMPLEX) {
    if (2 * lhs->mode.len < rhs->mode.len) {
      PRECISION_LOSS (604, qtype (&(rhs->mode)), qtype (&(lhs->mode)));
    }
  }
// Insert coercions.
  if (lhs->mode.type == REAL && lhs->mode.len == 32) {
    if (rhs->mode.type == REAL) {
      switch (rhs->mode.len) {
        case 4: _srecordf (lhs->str, "flttox (%s)", rhs->str); break;
        case 8: _srecordf (lhs->str, "dbltox (%s)", rhs->str); break;
        case 16: _srecordf (lhs->str, "quadtox (%s)", rhs->str); break;
      }
      return TRUE;
    } else if (rhs->mode.type == INTEGER) {
      switch (rhs->mode.len) {
        case 2: _srecordf (lhs->str, "inttox (%s)", rhs->str); break;
        case 4: _srecordf (lhs->str, "inttox (%s)", rhs->str); break;
        case 8: _srecordf (lhs->str, "quadtox (%s)", rhs->str); break;
      }
      return TRUE;
    } else {
      return FALSE;
    }
  } else if (lhs->mode.type == COMPLEX && lhs->mode.len == 64) {
    if (rhs->mode.type == COMPLEX) {
      switch (rhs->mode.len) {
        case 8: _srecordf (lhs->str, "cxflt (%s)", rhs->str); break;
        case 16: _srecordf (lhs->str, "cxdbl (%s)", rhs->str); break;
        case 32: _srecordf (lhs->str, "cxquad (%s)", rhs->str); break;
      }
      return TRUE;
    } else if (rhs->mode.type == REAL) {
      switch (rhs->mode.len) {
        case 4: _srecordf (lhs->str, "cxdbl (CMPLX (%s, 0.0))", rhs->str); break;
        case 8: _srecordf (lhs->str, "cxdbl (CMPLX (%s, 0.0))", rhs->str); break;
        case 16: _srecordf (lhs->str, "cxquad (CMPLXQ (%s, 0.0q))", rhs->str); break;
        case 32: _srecordf (lhs->str, "cxreal32 (%s)", rhs->str); break;
      }
      return TRUE;
    } else if (rhs->mode.type == INTEGER) {
      switch (rhs->mode.len) {
        case 2: _srecordf (lhs->str, "%s = cxdbl (CMPLX (%s, 0.0))", rhs->str); break;
        case 4: _srecordf (lhs->str, "%s = cxdbl (CMPLX (%s, 0.0))", rhs->str); break;
        case 8: _srecordf (lhs->str, "%s = cxquad (CMPLXQ (%s, 0.0q))", rhs->str); break;
      }
      return TRUE;
    } else {
      return FALSE;
    }
  } else if (rhs->mode.type == REAL && rhs->mode.len == 32) {
    if (lhs->mode.type == COMPLEX) {
      switch (lhs->mode.len) {
        case 8: _srecordf (lhs->str, "xtoflt (%s)", rhs->str); break;
        case 16: _srecordf (lhs->str, "xtodbl (%s)", rhs->str); break;
        case 32: _srecordf (lhs->str, "xtoquad (%s)", rhs->str); break;
      }
      return TRUE;
    } else if (lhs->mode.type == REAL) {
      switch (lhs->mode.len) {
        case 4: _srecordf (lhs->str, "xtoflt (%s)", rhs->str); break;
        case 8: _srecordf (lhs->str, "xtodbl (%s)", rhs->str); break;
        case 16: _srecordf (lhs->str, "xtoquad (%s)", rhs->str); break;
      }
      return TRUE;
    } else if (lhs->mode.type == INTEGER) {
      switch (lhs->mode.len) {
        case 2: _srecordf (lhs->str, "(int_2) _xint8 (%s)", rhs->str); break;
        case 4: _srecordf (lhs->str, "(int_4) _xint8 (%s)", rhs->str); break;
        case 8: _srecordf (lhs->str, "_xint8 (%s)", rhs->str); break;
      }
      return TRUE;
    } else {
      return FALSE;
    }
  } else if (rhs->mode.type == COMPLEX && rhs->mode.len == 64) {
    if (lhs->mode.type == COMPLEX) {
      switch (lhs->mode.len) {
        case 8: _srecordf (lhs->str, "CMPLX (xtodbl (cxreal (%s)), xtodbl (cximag (%s)))", rhs->str, rhs->str); break;
        case 16: _srecordf (lhs->str, "CMPLX (xtodbl (cxreal (%s)), xtodbl (cximag (%s)))", rhs->str, rhs->str); break;
        case 32: _srecordf (lhs->str, "CMPLXQ (xtoquad (cxreal (%s)), xtoquad (cximag (%s)))", rhs->str, rhs->str); break;
      }
      return TRUE;
    } else if (lhs->mode.type == REAL) {
      switch (lhs->mode.len) {
        case 4: _srecordf (lhs->str, "xtoflt (cxreal (%s))", rhs->str); break;
        case 8: _srecordf (lhs->str, "xtodbl (cxreal (%s))", rhs->str); break;
        case 16: _srecordf (lhs->str, "xtoquad (cxreal (%s))", rhs->str); break;
      }
      return TRUE;
    } else if (lhs->mode.type == INTEGER) {
      switch (lhs->mode.len) {
        case 2: _srecordf (lhs->str, "(int_2) _xint8 (cxreal (%s))", rhs->str); break;
        case 4: _srecordf (lhs->str, "(int_4) _xint8 (cxreal (%s))", rhs->str); break;
        case 8: _srecordf (lhs->str, "_xint8 (cxreal (%s))", rhs->str); break;
      }
      return TRUE;
    } else {
      return FALSE;
    }
  } else if (rhs->mode.type == COMPLEX && rhs->mode.len == 32) {
    if (lhs->mode.type == COMPLEX) {
      switch (lhs->mode.len) {
        case 64: _srecordf (lhs->str, "CMPLXX (xtoquad (crealq (%s)), xtoquad (cimagq (%s)))", rhs->str, rhs->str); break;
      }
      return TRUE;
    } else if (lhs->mode.type == REAL) {
      switch (lhs->mode.len) {
        case 4: _srecordf (lhs->str, "(real_4) (crealq (%s))", rhs->str); break;
        case 8: _srecordf (lhs->str, "(real_8) (crealq (%s))", rhs->str); break;
        case 16: _srecordf (lhs->str, "crealq (%s)", rhs->str); break;
      }
      return TRUE;
    } else if (lhs->mode.type == INTEGER) {
      switch (lhs->mode.len) {
        case 2: _srecordf (lhs->str, "(int_2) (crealq (%s))", rhs->str); break;
        case 4: _srecordf (lhs->str, "(int_4) (crealq (%s))", rhs->str); break;
        case 8: _srecordf (lhs->str, "(int_8) (crealq (%s))", rhs->str); break;
      }
      return TRUE;
    } else {
      return FALSE;
    }
  } else if (rhs->mode.type == COMPLEX && rhs->mode.len == 16) {
    if (lhs->mode.type == COMPLEX) {
      switch (lhs->mode.len) {
        case 64: _srecordf (lhs->str, "CMPLXX (_xtodbl (creal (%s)), _xtodbl (cimag (%s)))", rhs->str, rhs->str); break;
      }
      return TRUE;
    } else if (lhs->mode.type == REAL) {
      switch (lhs->mode.len) {
        case 4: _srecordf (lhs->str, "(real_4) (creal (%s))", rhs->str); break;
        case 8: _srecordf (lhs->str, "(real_8) (creal (%s))", rhs->str); break;
        case 16: _srecordf (lhs->str, "creal (%s)", rhs->str); break;
      }
      return TRUE;
    } else if (lhs->mode.type == INTEGER) {
      switch (lhs->mode.len) {
        case 2: _srecordf (lhs->str, "(int_2) (creal (%s))", rhs->str); break;
        case 4: _srecordf (lhs->str, "(int_4) (creal (%s))", rhs->str); break;
        case 8: _srecordf (lhs->str, "(int_8) (creal (%s))", rhs->str); break;
      }
      return TRUE;
    } else {
      return FALSE;
    }
  } else if (rhs->mode.type == COMPLEX && rhs->mode.len == 8) {
    if (lhs->mode.type == COMPLEX) {
      switch (lhs->mode.len) {
        case 64: _srecordf (lhs->str, "CMPLXX (_xtoflt (crealf (%s)), _xtoflt (cimagf (%s)))", rhs->str, rhs->str); break;
      }
      return TRUE;
    } else if (lhs->mode.type == REAL) {
      switch (lhs->mode.len) {
        case 4: _srecordf (lhs->str, "(real_4) (crealf (%s))", rhs->str); break;
        case 8: _srecordf (lhs->str, "(real_8) (crealf (%s))", rhs->str); break;
        case 16: _srecordf (lhs->str, "(real_16) (crealf (%s))", rhs->str); break;
      }
      return TRUE;
    } else if (lhs->mode.type == INTEGER) {
      switch (lhs->mode.len) {
        case 2: _srecordf (lhs->str, "(int_2) (crealf (%s))", rhs->str); break;
        case 4: _srecordf (lhs->str, "(int_4) (crealf (%s))", rhs->str); break;
        case 8: _srecordf (lhs->str, "(int_8) (crealf (%s))", rhs->str); break;
      }
      return TRUE;
    } else {
      return FALSE;
    }
  } else if (lhs->mode.type == INTEGER && lhs->mode.len == 4 && rhs->mode.type == CHARACTER) {
    _srecordf (lhs->str, "_str_to_int4 (%s)", rhs->str);
    return TRUE;
  } else if (lhs->mode.type == REAL && lhs->mode.len == 8 && rhs->mode.type == CHARACTER) {
    _srecordf (lhs->str, "_str_to_real8 (%s)", rhs->str);
    return TRUE;
  } 
  return TRUE; // Assume no action required.
}
