//! @file equivalence.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 EQUIVALENCE.

// This code compiles pairwise equivalence statements of the form
//
//   EQUIVALENCE (A, B), ...
//
// Multiple equivalence was allowed by vintage Fortran, 
// but hardly used (if at all) in practice. 
// Anyway, VIF compiles
//
//   EQUIVALENCE (A, B, C, D)
//
// as (Aho, Sethi, Ullman)
//
//   EQUIVALENCE (B, A), (C, A), (D, A)
//
// Not all EQUIVALENCE statements may work in VIF as VIF neither emulates the 
// FORTRAN memory model, nor combines equivalence statements. This hardly has 
// consequences for compiling existing vintage code. Programmers apparently 
// only need(ed) basic equivalence facilities. 

#include <vif.h>

static void eq_compute_row_size (IDENT *idf, int_4 *val)
{
// Compute size of row in bytes.
  NEW_RECORD (buf);
  compute_row_size (buf, idf);
  if (EQUAL (buf, "VARY")) {
    ERROR (1401, "varying row in equivalence", NO_TEXT);
  }
  if (!is_int4 (buf, val)) {
    (*val) = 0;
  }
}

static void eq_var_any (EXPR lhs, EXPR rhs, int_4 *N)
{
// Link a variable to either variable or row.
  IDENT *lid = lhs.idf, *rid = rhs.idf; NEW_RECORD (str);
// Redirect if possible.
  if (lid->equiv != NO_IDENT) {
    if (rid->equiv == NO_IDENT) {
      eq_var_any (rhs, lhs, N);
    } else {
     _srecordf (str, "(%s, %s)", F_NAME (lid), F_NAME (rid));
     ERROR (1402, "cannot alias", str);
    }
    return;
  }
// Peephole optimization.
  NEW_RECORD (target);
  NEW_RECORD (buf);
  if (IS_SCALAR (rid->mode)) {
    _srecordf (target, "&(%s)", rhs.str);
  } else {
    if (!is_int4 (rhs.elem, &rhs.value)) {
      SYNTAX (1403, "rhs must have a constant index");
      return;
    }
    if (rhs.value == 0) {
      _srecordf (target, "%s", idf_full_c_name (buf, rid));
    } else {
      _srecordf (target, "&(%s)", rhs.str);
    }
  }
// Make alias.
  if (rid->common != LOCAL) {
    cpp_direct (nprocs, prelin, REFDECL);
    _srecordf (str, "static %s %s = %s %s;\n", wtype (&lhs.mode, NOARG, NOFUN), ptr_to_array (lhs.idf, CONST, NOCAST, ACTUAL), ptr_to_array (lhs.idf, NOCONST, CAST, ACTUAL), target);
    code (nprocs, REFDECL, str);
    lid->const_ref = TRUE;
  } else if (lhs.mode.save == STATIC) {
    if (rhs.mode.save == STATIC) {
      cpp_direct (nprocs, prelin, REFDECL);
      _srecordf (str, "static %s %s = %s %s;\n", wtype (&lhs.mode, NOARG, NOFUN), ptr_to_array (lhs.idf, CONST, NOCAST, ACTUAL), ptr_to_array (lhs.idf, NOCONST, CAST, ACTUAL), target);
      code (nprocs, REFDECL, str);
      lid->const_ref = TRUE;
    } else {
      cpp_direct (nprocs, prelin, EQUIV);
      _srecordf (str, "%s = %s %s;\n", lhs.str, ptr_to_array (lhs.idf, NOCONST, CAST, ACTUAL), target);
      code (nprocs, EQUIV, str);
      N++;
    }
  } else {
    cpp_direct (nprocs, prelin, BODY);
    _srecordf (str, "%s = %s %s;\n", lhs.str, ptr_to_array (lhs.idf, NOCONST, CAST, ACTUAL), target);
    code (nprocs, BODY, str);
  }
}

static void eq_row_row (EXPR lhs, EXPR rhs, int_4 *N)
{
// Link a row to a row.
  IDENT *lid = lhs.idf, *rid = rhs.idf; NEW_RECORD (str);
  NEW_RECORD (index); NEW_RECORD (buf);
// Peephole optimization.
  if (lhs.value == rhs.value) {
    _srecordf (index, "%s", idf_full_c_name (buf, rid));
  } else {
    _srecordf (index, "&(%s[%d])", idf_full_c_name (buf, rid), rhs.value - lhs.value);
  }
// Make alias.
  if (rid->common != LOCAL) {
    cpp_direct (nprocs, prelin, DECL);
    _srecordf (str, "static %s %s = %s %s;\n", wtype (&lhs.mode, NOARG, NOFUN), ptr_to_array (lid, CONST, NOCAST, ACTUAL), ptr_to_array (lid, NOCONST, CAST, ACTUAL), index);
    code (nprocs, DECL, str);
    lid->const_ref = TRUE;
  } else {
    _srecordf (str, "%s = %s %s;\n", C_NAME (lid), ptr_to_array (lid, NOCONST, CAST, ACTUAL), index);
    if (lhs.mode.save == STATIC) {
      cpp_direct (nprocs, prelin, EQUIV);
      code (nprocs, EQUIV, str);
      N++;
    } else {
      cpp_direct (nprocs, prelin, BODY);
      code (nprocs, BODY, str);
    }
  }
}

static void eq_link (EXPR lhs, EXPR rhs, int_4 *N)
{
  IDENT *lid = lhs.idf, *rid = rhs.idf;
// Oops!
  if (lid == NO_IDENT || rid == NO_IDENT) {
    SYNTAX (1404, "equivalence statement");
    return;
  }
// ROW -> ROW is mostly OK.
  if (IS_ROW (lid->mode) && IS_ROW (rid->mode)) {
    if (!is_int4 (lhs.elem, &lhs.value)) {
      SYNTAX (1405, "lhs must have a constant index");
      return;
    }
    if (!is_int4 (rhs.elem, &rhs.value)) {
      SYNTAX (1406, "rhs must have a constant index");
      return;
    }
    int_4 lsz, rsz;
    eq_compute_row_size (lid, &lsz);
    eq_compute_row_size (rid, &rsz);
// We want the alias to fit in the target.
    if (rhs.idf->common == LOCAL && (rhs.value <= lhs.value) && (rsz <= lsz - lhs.value)) {
      rid->alias = lid;
      lid->equiv = rid;
      eq_row_row (rhs, lhs, N);
    } else if (lhs.idf->common == LOCAL && (rhs.value >= lhs.value) && (lsz <= rsz - rhs.value)) {
      lid->alias = rid;
      rid->equiv = lid;
      eq_row_row (lhs, rhs, N);
    } else {
// Alias sticks out to the right.
      ERROR (1407, "equivalence", "cannot equivalence");
    }
    return;
  }
// ROW -> VAR is VAR -> ROW.
  if (IS_ROW (lid->mode) && IS_SCALAR (rid->mode)) {
    eq_link (rhs, lhs, N);
    return;
  }
// Shuffle to avoid multiple equivalencing if possible.
  if (lid->equiv != NO_IDENT) {
    if (rid->equiv == NO_IDENT) {
      eq_link (rhs, lhs, N);
      return;
    } else {
      NEW_RECORD (str);
      _srecordf (str, "(%s, %s)", F_NAME (lid), F_NAME (rid));
      ERROR (1408, "cannot alias", str);
    }
  }
// VAR -> VAR is OK.
  if (IS_SCALAR (lid->mode) && IS_SCALAR (rid->mode)) {
    lid->alias = rid;
    rid->equiv = lid;
    eq_var_any (lhs, rhs, N);
  }
// VAR -> ROW is OK.
  if (IS_SCALAR (lid->mode) && IS_ROW (rid->mode)) {
    lid->alias = rid;
    rid->equiv = lid;
    eq_var_any (lhs, rhs, N);
  }
}

void equivalence (void)
{
// EQUIVALENCE by aliasing already allocated variables or arrays.
// We already know that parentheses are balanced.
  int_4 rc, set = 0, N = 0;
  int_4 epatch = code (nprocs, EQUIV, NO_TEXT);
  while ((rc = scan (EXPECT_NONE)) != END_OF_LINE) {
    if (TOKEN (",")) {
      continue;
    } else if (TOKEN ("(")) {
      continue;
    } else if (rc != WORD) {
      EXPECT (1409, "identifier");
    } else {
      set++;
      IDENT *lid, *rid;
      EXPR lhs, rhs;
      MODE lmode, rmode;
      rid = impl_decl (curlex, &lmode);
      if (rid->alias != NO_IDENT) {
        ERROR (1410, "cannot alias", curlex);
      }
      factor (&rhs);
      rc = scan (EXPECT_NONE);
      if (!TOKEN (",")) {
        EXPECT (1411, ",");
      }
// Loop resolving multiple equivalence.
      while (TOKEN (",")) {
        rc = scan (EXPECT_NONE);
        if (rc != WORD) {
          EXPECT (1412, "variable");
        }
        lid = impl_decl (curlex, &rmode);
        factor (&lhs);
        rc = scan (EXPECT_NONE);
// Mistakes.
        if (lid == NO_IDENT || rid == NO_IDENT) {
          break;
        }
        if (lid->mode.save != rid->mode.save) {
          ERROR (1413, "aliasing static and automatic", NO_TEXT);
          break;
        }
        if (lid->common != LOCAL && rid->common != LOCAL) {
          ERROR (1414, "lhs and rhs are in common block", NO_TEXT);
          break;
        }
// If a row is denoted as variable, address of first element is implied.
// Padding "[0]" simplifies code generation.
        if (lhs.variant == EXPR_VAR && IS_ROW (lid->mode)) {
          bufcat (lhs.str, "[0]", RECLN);
          _srecordf (lhs.elem, "0");
          lhs.value = 0;
        }
        if (rhs.variant == EXPR_VAR && IS_ROW (rid->mode)) {
          bufcat (rhs.str, "[0]", RECLN);
          _srecordf (rhs.elem, "0");
          rhs.value = 0;
        }
// Warning!
        if (lid->mode.type != rid->mode.type || lid->mode.len != rid->mode.len) {
          NEW_RECORD (str);
          _srecordf (str, "equivalence (%s, %s)", qtype (&(rhs.mode)), qtype (&(lhs.mode)));
          WARNING (1415, "mixed types", str);
        } 
// Equivalence in correct order.
        if (lid->common == LOCAL) {
          eq_link (lhs, rhs, &N);
        } else if (rid->common == LOCAL) {
          eq_link (rhs, lhs, &N);
        } else {
          eq_link (lhs, rhs, &N);
        } 
      }
    }
  }
  if (set == 0) {
    SYNTAX (1416, "equivalence statement");
  }
  if (N > 0) {
    NEW_RECORD (str);
    cpp_direct (nprocs, prelin, EQUIV);
    _srecordf (str, "if (__calls[%d].calls == 0) {\n", nprocs - 1);
    patch (epatch, str);
    code (nprocs, EQUIV, "}\n");
  }
}

void decl_equiv (void)
{
  int_4 go_on = TRUE;
  while (go_on) {
    SAVE_POS (1);
    int_4 rc = scan (EXPECT_NONE);
    if (rc == DECLAR) {
      skip_card (FALSE);
    } else if (TOKEN ("implicit") && IS_NOT_ASSIGNMENT) {
      skip_card (FALSE);
    } else if (TOKEN ("save") && IS_NOT_ASSIGNMENT) {
      skip_card (FALSE);
    } else if (TOKEN ("automatic") && IS_NOT_ASSIGNMENT) {
      skip_card (FALSE);
    } else if (TOKEN ("parameter") && IS_NOT_ASSIGNMENT) {
      skip_card (FALSE);
    } else if (TOKEN ("common") && IS_NOT_ASSIGNMENT) {
      skip_card (FALSE);
    } else if (TOKEN ("dimension") && IS_NOT_ASSIGNMENT) {
      skip_card (FALSE);
    } else if (TOKEN ("equivalence") && IS_NOT_ASSIGNMENT) {
      equivalence ();
      skip_card (FALSE);
    } else if (TOKEN ("external") && IS_NOT_ASSIGNMENT) {
      skip_card (FALSE);
    } else if (TOKEN ("intrinsic") && IS_NOT_ASSIGNMENT) {
      skip_card (FALSE);
    } else if (TOKEN ("data") && IS_NOT_ASSIGNMENT) {
      skip_card (FALSE);
    } else if (rc == WORD && IS_MACRO_DECLARATION) {
      skip_card (FALSE);
    } else if (strlen (curlex) > 0) {
// Backspace and done.
      RESTORE_POS (1);
      go_on = FALSE;
    }
  }
}
