//! @file format.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 FORMAT.

#include <vif.h>

static void format_elem (char *lex, int_4 *elems)
{
  if (lex == NO_TEXT || strlen (lex) == 0) {
    return;
  }
  NEW_RECORD (rstr); NEW_RECORD (wstr);
  int_4 width, digits, expwid;
  if (LEQUAL ("a", lex)) {
    if (sscanf (&lex[1], "%d", &width) != 1) {
      _srecordf (rstr, "%%s");
      _srecordf (wstr, "%%s");
    } else if (width < 1) {
      SYNTAX (1901, lex);
      _srecordf (rstr, "%%s");
      _srecordf (wstr, "%%s");
    } else {
      _srecordf (rstr, "%%%ds", width);
      _srecordf (wstr, "%%-%ds", width);
    }
    code (nprocs, FMT, "FMT_CHAR");
    (*elems)++;
  } else if (LEQUAL ("i", lex)) {
    if (sscanf (&lex[1], "%d", &width) != 1) {
      EXPECT (1902, "width");
      _srecordf (rstr, "%%d");
      _srecordf (wstr, "%%d");
    } else if (width < 1) {
      SYNTAX (1903, lex);
      _srecordf (rstr, "%%d");
      _srecordf (wstr, "%%d");
    } else {
      _srecordf (rstr, "%%%dd", width);
      _srecordf (wstr, "%%%dd", width);
    }
    code (nprocs, FMT, "FMT_INT");
    (*elems)++;
  } else if (LEQUAL ("l", lex)) {
    if (sscanf (&lex[1], "%d", &width) != 1) {
      EXPECT (1904, "width");
      _srecordf (rstr, "%%s");
      _srecordf (wstr, "%%s");
    } else if (width < 1) {
      SYNTAX (1905, lex);
      _srecordf (rstr, "%%s");
      _srecordf (wstr, "%%s");
    } else {
      _srecordf (rstr, "%%%ds", width);
      _srecordf (wstr, "%%-%ds", width);
    }
    code (nprocs, FMT, "FMT_INT");
    (*elems)++;
  } else if (LEQUAL ("d", lex) || LEQUAL ("e", lex) || LEQUAL ("g", lex) || LEQUAL ("n", lex)) {
    width = digits = expwid = 0;
    if (sscanf (&lex[1], "%d.%d.%d", &width, &digits, &expwid) == 3) {
      ;
    } else if (sscanf (&lex[1], "%d.%d", &width, &digits) == 2) {
      ;
    } else {
      EXPECT (1906, "width, decimals, [width]");
    }
    if (width < 0 || digits < 0) {
      SYNTAX (1907, lex);
    }
// Reading a REAL - specify width only!
    _srecordf (rstr, "%%%de", width);
// Writing a REAL - specify all. 
    if (tolower (lex[0]) == 'n') {
      if (islower (lex[0])) {
        _srecordf (wstr, "%%%d.%d.%dn", width, digits, expwid);
      } else {
        _srecordf (wstr, "%%%d.%d.%dN", width, digits, expwid);
      }
    } else {
      if (islower (lex[0])) {
        _srecordf (wstr, "%%%d.%d.%de", width, digits, expwid);
      } else {
        _srecordf (wstr, "%%%d.%d.%dE", width, digits, expwid);
      }
    }
    code (nprocs, FMT, "FMT_REAL");
    (*elems)++;
  } else if (LEQUAL ("f", lex)) {
    sscanf (&lex[1], "%d.%d", &width, &digits);
    if (sscanf (&lex[1], "%d.%d", &width, &digits) != 2) {
      EXPECT (1908, "width, decimals");
      _srecordf (rstr, "%%f");
      _srecordf (wstr, "%%f");
    } else if (width < 1 || digits < 0) {
      SYNTAX (1909, lex);
      _srecordf (rstr, "%%f");
      _srecordf (wstr, "%%f");
    } else {
      _srecordf (rstr, "%%%df", width);
      _srecordf (wstr, "%%%d.%df", width, digits);
    }
    code (nprocs, FMT, "FMT_REAL");
    (*elems)++;
  } else {
    SYNTAX (1910, lex);
    rstr[0] = wstr[0] = '\0';
    (*elems)++;
  }
  NEW_RECORD (fstr);
  code (nprocs, FMT, ", ");
  _srecordf (fstr, "\"%s\"", rstr);
  code (nprocs, FMT, fstr);
  code (nprocs, FMT, ", ");
  _srecordf (fstr, "\"%s\"", wstr);
  code (nprocs, FMT, fstr);
  code (nprocs, FMT, ",\n");
}

static void format_scale (int_4 N)
{
  code (nprocs, FMT, "FMT_TEXT, ");
  code (nprocs, FMT, "\"\"");
  code (nprocs, FMT, ", ");
  if (N == 0) {
    code (nprocs, FMT, "\"0\"");
  } else if (N == 1) {
    code (nprocs, FMT, "\"1\"");
  } else if (N == 2) {
    code (nprocs, FMT, "\"2\"");
  } else if (N == 3) {
    code (nprocs, FMT, "\"3\"");
  } else {
    code (nprocs, FMT, "\"1\"");
  }
}

static void format_x (int_4 N)
{
  NEW_RECORD (idf); NEW_RECORD (str);
  str[0] = '\0';
  bufcat (str, "\"", RECLN);
  for (int_4 k = 0; k < N && k < RECLN; k ++) {
    bufcat (str, " ", RECLN);
  }
  bufcat (str, "\"", RECLN);
  _srecordf (idf, "_dc_%d", code_uniq_str (str));
  code (nprocs, FMT, "FMT_TEXT, ");
  code (nprocs, FMT, idf);
  code (nprocs, FMT, ", ");
  code (nprocs, FMT, idf);
  code (nprocs, FMT, ",\n");
}

static void format_nl (int_4 N)
{
  NEW_RECORD (str);
  _srecordf (str, "\"\\n\"");
  for (int_4 k = 0; k < N; k ++) {
    code (nprocs, FMT, "FMT_TEXT, ");
    code (nprocs, FMT, str);
    code (nprocs, FMT, ", ");
    code (nprocs, FMT, str);
    code (nprocs, FMT, ",\n");
  }
}

static void format_term (int_4 N)
{
  NEW_RECORD (str);
  _srecordf (str, "FMT_TERM");
  code (nprocs, FMT, "FMT_TEXT, ");
  code (nprocs, FMT, str);
  code (nprocs, FMT, ", ");
  code (nprocs, FMT, str);
  code (nprocs, FMT, ",\n");
}

static void format_text (int_4 N, char *lex)
{
  NEW_RECORD (idf);
  _srecordf (idf, "_dc_%d", code_uniq_str (lex));
  for (int_4 k = 0; k < N; k ++) {
    code (nprocs, FMT, "FMT_TEXT, ");
    code (nprocs, FMT, idf);
    code (nprocs, FMT, ", ");
    code (nprocs, FMT, idf);
    code (nprocs, FMT, ",\n");
  }
}

void format_list (int_4 *nest, int_4 *elems)
{
#define LETTER(ch) (tolower (curlex[0]) == ch)
  int_4 rc; 
  int_4 crd = curlin, col = curcol;
  while (WITHIN && (rc = scan_fmt ()) != END_OF_LINE) {
    if ((*nest) == 0 && (*elems) == 0 && !TOKEN ("(")) {
      SYNTAX (1911, "symbol outside parentheses");
    } else if (TOKEN (",")) {
      ;
    } else {
      int_4 k, N;
      if (rc != INT_NUMBER) {
        N = 1;
      } else {
        sscanf (curlex, "%d", &N);
        crd = curlin;
        col = curcol;
        rc = scan_fmt ();
      }
      if (LETTER ('p')) {
        format_scale (N);
        code (nprocs, FMT, ",\n");
        (*elems)++;
        curlin = crd;
        curcol = col + 1; // continue after 'P'
      } else if (TOKEN ("x")) {
        format_x (N);
        (*elems)++;
      } else if (TOKEN (":")) {
        format_term (N);
        (*elems)++;
      } else if (TOKEN ("/")) {
        format_nl (N);
        (*elems)++;
      } else if (LEQUAL ("\"", curlex)) {
        format_text (N, curlex);
        (*elems)++;
      } else {
        for (k = 0; k < N; k ++) {
          if (TOKEN ("(")) {
            (*nest) ++;
            format_list (nest, elems);
            if (k < N - 1) {
              curlin = crd;
              curcol = col;
              rc = scan_fmt ();
            }
          } else if (TOKEN (")")) {
            (*nest) --;
            return;
          } else {
            format_elem (curlex, elems);
          }
        }
      }
    }
    crd = curlin; col = curcol;
  }
#undef LETTER
}

char *format_str_list (char *fmt, int_4 *nest, int_4 *elems)
{
#define LETTER(ch) (tolower (fmt[0]) == ch)
  if (fmt[0] == '(') {
    fmt++;
  } else {
    EXPECT (1912, "("); 
  }
  while (fmt[0] != ')' && fmt[0] != '\0') {
    if (fmt[0] == ',') {
      fmt++;
    }
    while (isspace (fmt[0])) {
      fmt++;
    }
    int_4 N;
    if (!isdigit (fmt[0])) {
      N = 1;
    } else {
      char *end;
      N = strtol (fmt, &end, 10);
      fmt = end;
    }
    if (LETTER ('p')) {
      format_scale (N);
      code (nprocs, FMT, ",\n");
      (*elems)++;
      fmt++;
    } else if (LETTER ('x')) {
      format_x (N);
      (*elems)++;
      fmt++;
    } else if (fmt[0] == ':') {
      format_term (N);
      (*elems)++;
      fmt++;
    } else if (fmt[0] == '/') {
      format_nl (N);
      (*elems)++;
      fmt++;
    } else if (LETTER ('h')) {
      fmt++;
      NEW_RECORD (str);
      int_4 k = 0;
      str[k++] = '"';
      for (int_4 M = 0; M < N && fmt[0] != '\0'; M++) {
        str[k++] = (fmt++)[0];
      }
      str[k++] = '"';
      format_text (1, str);
      (*elems)++;
    } else if (fmt[0] == '\"') {
      fmt++;
      NEW_RECORD (str);
      int_4 k = 0;
      str[k++] = '"';
      int_4 go_on = TRUE;
      while (go_on) {
        if (fmt[0] == '\0') {
          go_on = FALSE;
        } else if (fmt[0] == '"') {
          if ((++fmt)[0] == '"') {
            str[k++] = '"';
            fmt++;
          } else {
            go_on = FALSE;
          }
        } else {
          str[k++] = (fmt++)[0];
        }
      }
      str[k++] = '"';
      format_text (N, str);
      (*elems)++;
    } else if (fmt[0] == '\'') {
      fmt++;
      NEW_RECORD (str);
      int_4 k = 0;
      str[k++] = '"';
      int_4 go_on = TRUE;
      while (go_on) {
        if (fmt[0] == '\0') {
          go_on = FALSE;
        } else if (fmt[0] == '\'') {
          if ((++fmt)[0] == '\'') {
            str[k++] = '\'';
            fmt++;
          } else {
            go_on = FALSE;
          }
        } else {
          str[k++] = (fmt++)[0];
        }
      }
      str[k++] = '"';
      format_text (N, str);
      (*elems)++;
    } else {
      for (int_4 k = 0; k < N; k++) {
        char *sav = fmt, *rtn = NO_TEXT;
        if (fmt[0] == '(') {
          (*nest)++;
          rtn = format_str_list (fmt, nest, elems);
        } else if (fmt[0] == ')') {
          break;
        } else if (strchr ("adefgiln", tolower (fmt[0])) == NO_TEXT) {
          SYNTAX (1913, fmt++);
        } else {
          NEW_RECORD (lex);
          char *p = lex;
          do {
            (p++)[0] = (fmt++)[0];
            while (isdigit (fmt[0])) {
              (p++)[0] = (fmt++)[0];
            }
          } while (fmt[0] == '.');
          format_elem (lex, elems);
        }
        if (k < N - 1) {
          fmt = sav;
        } else if (rtn != NO_TEXT) {
          fmt = rtn;
        }
      }
    }
  }
  if (fmt[0] != ')') {
    EXPECT (1914, ")"); 
    return fmt;
  } else if (*nest > 0) {
    (*nest)--;
  }
  return &fmt[1];
#undef LETTER
}

void format (LBL *statlbl)
{
  int_4 nest = 0, elems = 0;
  NEW_RECORD (str);
  if (statlbl == NO_LABEL) {
    SYNTAX (1915, "format without label");
  }
  code (nprocs, FMT, "\n");
  _srecordf (str, "static FORMAT %s[] = {\n", edit_fmt (statlbl->num));
  code (nprocs, FMT, str);
  format_list (&nest, &elems);
  code (nprocs, FMT, "NULL, NULL, NULL\n");
  code (nprocs, FMT, "};\n");
  if (nest != 0) {
    SYNTAX (1916, "unbalanced parentheses");
  }
  if (elems == 0) {
    SYNTAX (1917, "empty format");
  }
  skip_card (FALSE);
}

int_4 format_str (char *fmt)
{
  int_4 nest = 0, elems = 0;
  int_4 lab = CUR_LIN.isn + 100000;
  NEW_RECORD (str);
  if (fmt[0] == '"') {
    fmt++;
  }
  if (fmt[strlen (fmt) - 1] == '"') {
    fmt[strlen (fmt) - 1] = '\0';
  }
  code (nprocs, FMT, "\n");
  _srecordf (str, "static FORMAT %s[] = {\n", edit_fmt (lab));
  code (nprocs, FMT, str);
  (void) format_str_list (fmt, &nest, &elems);
  code (nprocs, FMT, "NULL, NULL, NULL\n");
  code (nprocs, FMT, "};\n");
  if (nest != 0) {
    SYNTAX (1918, "unbalanced parentheses");
  }
  if (elems == 0) {
    SYNTAX (1919, "empty format");
  }
  return lab;
}
