//! @file slice.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 array slices.

#include <vif.h>

void code_index (RECORD index, IDENT * idf, int_4 dim)
{
  NEW_RECORD (str);
  EXPR reg;
  express (&reg, INTEGER, 4);
  if (EQUAL (idf->lwb[dim], "0")) {
    if (dim == 0) {
      _srecordf (str, "%s", reg.str);
    } else {
      _srecordf (str, "(%s)", reg.str);
    }
  } else {
    NEW_RECORD (buf);
    _srecordf (str, "%s - %s", reg.str, idf->lwb[dim]);
    fold_int_4 (buf, str);
    if (dim == 0) {
      _srecordf (str, "%s", buf);
    } else {
      _srecordf (str, "(%s)", buf);
    }
  }
  (void) scan (EXPECT_NONE);
  if (TOKEN (":")) {
    SYNTAX (2901, "range not allowed");
  } else if (TOKEN (",")) {
    NEW_RECORD (deep);
    (void) scan (EXPECT_NONE);
    code_index (deep, idf, dim + 1);
    if (strcmp (idf->len[dim], "VARY") == 0) {
      ERROR (2902, "dimension cannot vary", NO_TEXT);
    }
    NEW_RECORD (prod); NEW_RECORD (fact);
    _srecordf (prod, "(%s) * (%s)", idf->len[dim], deep);
    fold_int_4 (fact, prod);
    if (strcmp (fact, "0") == 0) {
      _srecordf (index, "%s", str);
    } else {
      _srecordf (index, "%s + %s", str, fact);
    }
  } else if (TOKEN (")")) {
    bufcpy (index, str, RECLN);
    return;
  }
}

void code_store_index (EXPR *loc, RECORD index, IDENT * idf, int_4 dim)
{
  RECCLR (index);
  code_index (index, idf, 0);
// Sanity check.
  int_4 value;
  if (is_int4 (index, &value) && value < 0) {
    ERROR (2903, "index out of range", F_NAME (idf));
  }
// FORTRAN code, like m[(i + W1 * (j * W2 * k)]
  fold_int_4 (loc->elem, index);
}

void factor_slice_char (EXPR *loc, IDENT *idf)
{
  NEW_RECORD (ldf);
  NEW_RECORD (index);
// Code identifier name.
  (void) idf_full_c_name (ldf, idf);
// 
  if (IS_ROW (idf->mode)) { 
// Assume idf(i1, .., iN) possibly followed by (lwb : upb)
    (void) scan (EXPECT_NONE);
    code_store_index (loc, index, idf, 0);
    _srecordf (ldf, "%s[%s]", ldf, index);
    (void) scan (EXPECT_NONE); // Skip ")"
    if (!TOKEN ("(")) {
// idf(i1, ..., iN), no substring.
      UNSCAN;
      bufcpy (loc->str, ldf, RECLN);
      loc->variant = EXPR_SLICE;
      loc->idf = idf;
      loc->mode = idf->mode;
      return;
    }
  }
// The trimmer (lwb : upb)
  EXPR ini, fin;
  int_4 denot = (IS_SCALAR (idf->mode));
  (void) scan (EXPECT_NONE);
  if (TOKEN (":")) {
    _srecordf (ini.str, "1");
    ini.mode.type = INTEGER;
    ini.mode.len = 4;
    ini.variant = EXPR_CONST;
  } else {
    express (&ini, INTEGER, 4);
    denot &= (ini.variant == EXPR_CONST);
    (void) scan (EXPECT_NONE);
  }
  CHECKPOINT (2904, ":");
// ldf(lwb : upb)
  (void) scan (EXPECT_NONE);
  if (TOKEN (")")) {
    UNSCAN;
    _srecordf (fin.str, "%d", idf->mode.len);
    fin.mode.type = INTEGER;
    fin.mode.len = 4;
    fin.variant = EXPR_CONST;
  } else {
    express (&fin, INTEGER, 4);
    denot &= (fin.variant == EXPR_CONST);
  }
  if (lhs_factor) { // A permanent stub ...
    bufcat (ini.str, " - 1", RECLN);
    (void) fold_expr (&ini, INTEGER);
    _srecordf (loc->str, "(char *) &(%s[%s])", ldf, ini.str);
    loc->variant = EXPR_SUBSTR;
    loc->idf = idf;
    loc->mode = idf->mode;
  } else {
// Optimize substring with all constant parameters.
    denot &= (idf->parm != NO_TEXT);
    if (denot) {
      NEW_RECORD (cdf); NEW_RECORD (sub); NEW_RECORD (tmp);
      get_uniq_str (idf->parm, cdf);
      _srecordf (sub, "\"%s\"", _bufsub (tmp, cdf, atoi (ini.str), atoi (fin.str)));
      _srecordf (cdf, "_dc_%d", code_uniq_str (sub));
      _srecordf (loc->str, "%s", cdf);
      loc->mode = (MODE) {.type = CHARACTER, .len = strlen (sub) - 2, .dim = 0};
      loc->variant = EXPR_CONST;
    } else {
// General form of substring.
      NEW_RECORD (tmp);
      _srecordf (tmp, "%s", edit_tmp (nloctmps++));
      if (idf->mode.len > 0) {
        add_local (tmp, idf->mode.type, idf->mode.len, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
      } else { // Should not copy into zero-length string.
        add_local (tmp, idf->mode.type, MAX_STRLEN, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
      }
// _bufsub returns buffer address, so no gcc statement expression needed.
      _srecordf (loc->str, "_bufsub ((char *) %s, (char *) %s, %s, %s)", tmp, ldf, ini.str, fin.str);
      loc->variant = EXPR_SUBSTR;
      loc->idf = idf;
      loc->mode = idf->mode;
    }
  }
  (void) scan (")");
}

void factor_slice (EXPR *loc, IDENT *idf)
{
  NEW_RECORD (index);
  (void) idf_full_c_name (loc->str, idf);
  (void) scan (EXPECT_NONE);
  code_store_index (loc, index, idf, 0);
  bufcat (loc->str, "[", RECLN);
  bufcat (loc->str, loc->elem, RECLN);
  bufcat (loc->str, "]", RECLN);
  loc->variant = EXPR_SLICE;
  loc->idf = idf;
  loc->mode = idf->mode;
}
