//! @file data.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 DATA.

#include <vif.h>

//
// DATA STATEMENT
//

void const_list (MODE * mode, int_4 *items)
{
  while (WITHIN) {
    int_4 rc = scan (EXPECT_NONE);
    if (!WITHIN) {
      ;
    } else {
      int_8 repeat = 1;
      if (curret == INT_NUMBER) {
        repeat = strtoll (curlex, NO_REF_TEXT, 10);
        rc = scan (EXPECT_NONE);
        if (TOKEN ("*")) {
          rc = scan (EXPECT_NONE);
        } else {
          repeat = 1;
          UNSCAN;
        }
      }
      EXPR reg;
      factor (&reg);
      if (reg.variant != EXPR_CONST) {
        EXPECT (801, "constant");
      } else if (!accept_mode (reg.mode.type, reg.mode.len, mode->type, mode->len)) {
        MODE_ERROR (802, qtype (&(reg.mode)), qtype (mode));
      }
      for (int_4 k = 0; k < repeat; k++) {
        if (reg.mode.type == CHARACTER && mode->type == INTEGER && mode->len == 4) {
          NEW_RECORD (str); NEW_RECORD (buf);
          _srecordf (str, "%d", _str_to_int4 (get_uniq_str (reg.str, buf)));
          code (nprocs, DATA, str);
        } else if (reg.mode.type == CHARACTER && mode->type == REAL && mode->len == 8) {
          NEW_RECORD (str); NEW_RECORD (buf);
          _srecordf (str, "%g", _str_to_real8 (get_uniq_str (reg.str, buf)));
          code (nprocs, DATA, str);
        } else {
          code (nprocs, DATA, reg.str);
        }
        if (k < repeat - 1) {
          code (nprocs, DATA, ",\n");
        }
      }
      (*items) += (int_4) repeat;
      rc = scan (EXPECT_NONE);
      if (TOKEN ("/")) {
        return;
      } else if (TOKEN (",")) {
        code (nprocs, DATA, ",\n");
      }
    }
    (void) rc;
  }
}

void data_elem (char *data, char *datk, char *datn, MODE * mode, int_4 *items)
{
#define CIRCULAR\
  {\
    _srecordf (str, "if (%s >= %s) {\n", datk, datn);\
    code (nprocs, BODY, str);\
    _srecordf (str, "%s = 0;\n", datk);\
    code (nprocs, BODY, str);\
    code (nprocs, BODY, "}\n");\
  }
//
  EXPR reg;
  factor (&reg);
  if ((reg.idf != NO_IDENT) && reg.idf->mode.save == AUTOMATIC) {
    ERROR (803, "variable is automatic", F_NAME (reg.idf));
  }
  if (reg.variant == EXPR_VAR && IS_SCALAR (reg.mode)) {
    NEW_RECORD (str);
    *mode = reg.idf->mode;
    CIRCULAR;
    if (mode->type == CHARACTER) {
      if (mode->len == 0) {
        _srecordf (str, "strcpy (%s, %s[%s++]);\n", reg.str, data, datk);
      } else {
        _srecordf (str, "bufcpy (%s, %s[%s++], %d);\n", reg.str, data, datk, mode->len);
      }
    } else {
      _srecordf (str, "%s = %s[%s++];\n", reg.str, data, datk);
    }
    code (nprocs, BODY, str);
    (*items)++;
  } else if (reg.variant == EXPR_SLICE) {
    NEW_RECORD (str);
    *mode = reg.idf->mode;
    CIRCULAR;
    if (mode->type == CHARACTER) {
      if (mode->len == 0) {
        _srecordf (str, "strcpy (%s, %s[%s++]);\n", reg.str, data, datk);
      } else {
        _srecordf (str, "bufcpy (%s, %s[%s++], %d);\n", reg.str, data, datk, mode->len);
      }
    } else {
      _srecordf (str, "%s = %s[%s++];\n", reg.str, data, datk);
    }
    code (nprocs, BODY, str);
    (*items)++;
  } else if (reg.variant == EXPR_VAR && IS_ROW (reg.mode)) {
    NEW_RECORD (str); NEW_RECORD (tmpa); NEW_RECORD (tmpk);
    IDENT *ptr;
    *mode = reg.idf->mode;
    mode->dim = 0;
    _srecordf (tmpa, "_arr_%d", nloctmps++);
    ptr = add_local (tmpa, mode->type, mode->len, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
    ptr->alias = reg.idf;
    _srecordf (tmpk, "_k_%d", nloctmps++);
    add_local (tmpk, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
    _srecordf (str, "for (%s = (%s *) %s, %s = 0; %s < ", tmpa, wtype (mode, NOARG, NOFUN), reg.str, tmpk, tmpk);
    code (nprocs, BODY, str);
    code_row_len (reg.idf);
    _srecordf (str, "; %s++, %s++) {\n", tmpa, tmpk);
    code (nprocs, BODY, str);
    CIRCULAR;
    if (mode->type == CHARACTER) {
      if (mode->len == 0) {
        _srecordf (str, "strcpy (*(%s), %s[%s++]);\n", tmpa, data, datk);
      } else {
        _srecordf (str, "bufcpy (*(%s), %s[%s++], %d);\n", tmpa, data, datk, mode->len);
      }
    } else {
      _srecordf (str, "%s[%s] = %s[%s++];\n", reg.str, tmpk, data, datk);
    }
    code (nprocs, BODY, str);
    code (nprocs, BODY, "}\n");
    (*mode) = reg.idf->mode;
    (*items)++;
  } else {
    ERROR (804, "cannot initialise", reg.str);
  }
#undef CIRCULAR
}

void data_list (char *data, char *datk, char *datn, MODE * mode, int_4 lpatch, int_4 *nest, int_4 *items)
{
  while (WITHIN) {
    int_4 rc = scan (EXPECT_NONE);
    if (!WITHIN) {
      ;
    } else if (TOKEN ("/")) {
      return;
    } else if (TOKEN (",")) {
      if (*nest == 0) {
        code (nprocs, DATA, "\n");
      }
    } else if (TOKEN ("(")) {
      SAVE_POS (1);
// Quick lookahead.
      int_4 loop = impl_do ();
// Restore.
      RESTORE_POS (1);
      UNSCAN;
      rc = scan ("(");
// Decide.
      if (loop) {
        (*nest)++;
        int_4 where = code (nprocs, BODY, NO_TEXT);
        data_list (data, datk, datn, mode, where, nest, items);
      } else {
        data_elem (data, datk, datn, mode, items);
      }
    } else if (TOKEN (")")) {
// Expression closed by ')'
      (*nest)--;
      return;
    } else if (rc == WORD) {
      if (*nest == 0) {
        data_elem (data, datk, datn, mode, items);
      } else {
// Implied do-loop?
        SAVE_POS (2);
        rc = scan (EXPECT_NONE);
        if (!TOKEN ("=")) {
// Not an implied do-loop.
          RESTORE_POS (2);
          UNSCAN;
          rc = scan (EXPECT_NONE);
          data_elem (data, datk, datn, mode, items);
        } else {
// Implied do-loop!
          NEW_RECORD (lid); NEW_RECORD (loop);
          EXPR from, to, by;
          MODE nmode;
          IDENT *idf = impl_decl (prelex, &nmode);
          if (idf->arg || idf->alias != NO_IDENT) {
            _srecordf (lid, "*%s", C_NAME (idf));
          } else {
            (void) idf_full_c_name (lid, idf);
          }
          rc = scan (EXPECT_NONE);
          macro_depth = 0;
          express (&from, idf->mode.type, idf->mode.len);
          rc = scan (",");
          rc = scan (EXPECT_NONE);
          macro_depth = 0;
          express (&to, idf->mode.type, idf->mode.len);
          rc = scan (EXPECT_NONE);
          if (TOKEN (",")) {
            rc = scan (EXPECT_NONE);
            macro_depth = 0;
            express (&by, idf->mode.type, idf->mode.len);
            _srecordf (loop, "for (%s = %s; %s <= %s; %s += %s) {\n", lid, from.str, lid, to.str, lid, by.str);
            rc = scan (EXPECT_NONE);
          } else {
            _srecordf (loop, "for (%s = %s; %s <= %s; %s++) {\n", lid, from.str, lid, to.str, lid);
          }
          patch (lpatch, loop);
          if (TOKEN (")")) {
// Implied DO loop closed by ')'.
            (*nest)--;
            code (nprocs, BODY, "}; // implied DO \n");
          } else {
            EXPECT (805, ")");
          }
          return;
        }
      }
    } else {
      data_elem (data, datk, datn, mode, items);
    }
  }
}

void do_data (int_4 *nest)
{
  int_4 rc, go_on = TRUE;
  NEW_RECORD (str);
  _srecordf (str, "if (__calls[%d].calls == 0) {\n", nprocs - 1);
  code (nprocs, BODY, str);
  while (go_on) {
    int_4 items = 0, dpatch;
    NEW_RECORD (data); NEW_RECORD (datk); NEW_RECORD (datn);
    MODE mode;
    _srecordf (data, "_data_l_%d", nglobtmps);
    _srecordf (datk, "_data_k_%d", nglobtmps);
    _srecordf (datn, "_data_n_%d", nglobtmps++);
    add_local (datk, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
    _srecordf (str, "%s = 0;\n", datk);
    code (nprocs, BODY, str);
    data_list (data, datk, datn, &mode, ERR, nest, &items);
    if (!TOKEN ("/")) {
      EXPECT (806, "/");
    }
    mode.dim = 0;
    code (nprocs, DATA, "\n");
    cpp_direct (nprocs, curlin, DATA);
    _srecordf (str, "#define %s ", datn);
    code (nprocs, DATA, str);
    dpatch = code (nprocs, DATA, NO_TEXT);
    code (nprocs, DATA, "\n");
    _srecordf (str, "static %s %s[%s] = {\n", wtype (&mode, NOARG, NOFUN), data, datn);
    code (nprocs, DATA, str);
    items = 0;
    const_list (&mode, &items);
    _srecordf (str, "%d", items);
    patch (dpatch, str);
    code (nprocs, DATA, "\n");
    code (nprocs, DATA, "};\n");
    if (!TOKEN ("/")) {
      EXPECT (807, "/");
    }
    rc = scan (EXPECT_NONE);
    go_on = TOKEN (",");
  }
  code (nprocs, BODY, "}\n");
  if (WITHIN) {
    SYNTAX (808, curlex);
  }
  (void) rc;
}

void decl_data (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) {
      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) {
      int_4 nest = 0;
      do_data (&nest);
      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;
    }
  }
}

