//! @file code.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
//!
//! Routines to emit C object code.

#include <vif.h>

#undef LIST_IMPLICIT

#define MAX_UNIQ_STR 5000
static char *uniq_str[MAX_UNIQ_STR];
static int_4 uniq_index[MAX_UNIQ_STR];
static int_4 n_uniq_str = 0;
int_4 n_dc = 0;

char *idf_full_c_name (RECORD ldf, IDENT *idf)
{
  RECCLR (ldf);
  if (NOT_LOCAL (idf)) {
    bufcpy (ldf, commons[idf->common], RECLN);
    if (idf->common == EXTERN) {
      bufcat (ldf, "->", RECLN);
    } else {
      bufcat (ldf, ".", RECLN);
    }
  }
  bufcat (ldf, C_NAME (idf), RECLN);
  return ldf;
}

int_4 code_uniq_str (char *nstr)
{
  int_4 k;
  for (k = 0; k < n_uniq_str; k++) {
    if (strcmp (nstr, uniq_str[k]) == 0) {
      return uniq_index[k];
    }
  }
  if (k == MAX_UNIQ_STR) {
    OVERFLOW (501, "code_uniq_str");
  }
  NEW_RECORD (idf); NEW_RECORD (str);
  int_4 rc = n_dc;
  uniq_index[n_uniq_str] = rc;
  _srecordf (idf, "_dc_%d", n_dc++);
  _srecordf (str, "#define %s %s", idf, nstr);
  code (0, STRINGS, str);
  code (0, STRINGS, "\n");
  uniq_str[n_uniq_str++] = f_stralloc (nstr);
  return rc;
}

char *get_uniq_str (char *dc, char *buf)
{
  for (int_4 k = 0; k < n_uniq_str; k++) {
    NEW_RECORD (idf);
    _srecordf (idf, "_dc_%d", uniq_index[k]);
    if (strcmp (idf, dc) == 0) {
      int_4 j;
      for (j = 1; j < strlen (uniq_str[k]) - 1; j++) {
        buf[j - 1] = uniq_str[k][j];
      }
      buf[j] = '\0';
      return buf;
    }
  }
  return NO_TEXT;
}

int_4 code_real_32_const (char *num)
{
  NEW_RECORD (str);
  int_4 rc = n_dc;
  _srecordf (str, "real_32 _dc_%d = { // %s\n", n_dc++, curlex);
  code (0, CONSTANTS, str);
  real_32 x = atox (num);
  for (int_4 k = 0; k <= FLT256_LEN; k++) {
    if (k < FLT256_LEN) {
      _srecordf (str, "0x%04x,", (x.value)[k]);
    } else {
      _srecordf (str, "0x%04x", (x.value)[k]);
    }
    code (0, CONSTANTS, str);
    if ((k + 1) % 4 == 0) {
      code (0, CONSTANTS, "\n");
    }
  }
  code (0, CONSTANTS, "};");
  code (0, CONSTANTS, "\n");
  code (0, CONSTANTS, "\n");
  return rc;
}

int_4 code (int_4 proc, int_4 phase, char *str)
{
  if (n_c_src >= MAX_C_SRC) {
    MAX_C_SRC += INCREMENT;
    object = (C_SRC *) f_realloc (object, MAX_C_SRC * sizeof (C_SRC));
  }
// Add to list.
  C_SRC *lin = &object[n_c_src];
  int_4 patch = n_c_src;
  lin->text = f_stralloc (str);
  lin->phase = phase;
  lin->proc = proc;
  n_c_src++;
  return patch;
}

void cpp_direct (int_4 proc, int_4 lin, int_4 phase)
{
  if (!gcc_ftn_lines) {
    return;
  }
  if (source[lin].cpp == FALSE) {
    NEW_RECORD (str);
    char *q = source[lin].text;
    if (q != NO_TEXT) {
      for (int_4 k = 0; q[k] != '\0' && k < 5; k++) {
        q++;
      }
      while (q[0] != '\0' && q[0] == ' ') {
        q++;
      }
      NEW_RECORD (edit);
      int_4 n = 0, m = 0;
      while (q[n] != '\0') {
        if (q[n] == '"') {
          edit[m++] = '\\';
        } else if (q[n] == '%') {
          edit[m++] = '%';
        }
        edit[m++] = q[n++];
      }
      edit[m] = '\0';
      NEW_RECORD (loc);
      _srecordf (loc, "** %-10s ** isn %d %s", modnam, source[lin].isn, edit);
      _srecordf (str, "# line %d \"%s\"", source[lin].num, loc);
      code (proc, phase, str);
      if (trace) {
        _srecordf (str, "~fprintf (stderr, \"%s\\n\");", loc);
        code (proc, phase, str);
        code (proc, phase, "\n");
      }
    }
    source[lin].cpp = TRUE;
  }
}

static int_4 idf_code (IDENT *idf, int_4 save, int_4 src)
{
// Must we declare this identifier?
  if (idf == NO_IDENT) {
    return FALSE; // Oops!
  }
  if (idf->mode.save != save || idf->source != src) {
    return FALSE; // Wrong category
  }
  if (idf->parm != NO_TEXT) {
    return FALSE; // Parameter to subprogram
  }
  if (idf->external || idf->intrinsic) {
    return FALSE; // Otherwise declared
  }
  if (idf->nest != 0) {
    return FALSE; // Macro parameter, declared inline
  }
  return TRUE;
}

void code_one_type (IDENT * table, int_4 M, int_4 type, int_4 len, int_4 blck, int_4 proc, int_4 save, int_4 src, int_4 phase)
{
  int_4 k, N;
  for (k = 0, N = 0; k < M; k++) {
    IDENT *idf = &table[k];
    if (idf_code (idf, save, src)) {
      if (idf->const_ref) {
        ;
      } else if (idf->alias != NO_IDENT && idf->mode.type == type && idf->mode.len == len) {
        N++;
      } else if (!idf->arg && idf->mode.type == type && idf->mode.len == len && idf->common == blck) {
        N++;
      }
    }
  }
  if (N > 0) {
    NEW_RECORD (str);
    MODE mode = (MODE) {.type = type,.len = len,.dim = 0 };
    if (table == locals && (save == STATIC && src == SOURCE)) {
      _srecordf (str, "static %s ", wtype (&mode, NOARG, NOFUN));
    } else {
      _srecordf (str, "%s ", wtype (&mode, NOARG, NOFUN));
    }
    code (proc, phase, str);
    for (k = 0; k < M; k++) {
      IDENT *idf = &table[k];
      if (idf_code (idf, save, src)) {
        if (idf->const_ref) {
          ;
        } else if (idf->alias != NO_IDENT && idf->mode.type == type && idf->mode.len == len) {
          code (proc, phase, ptr_to_array (idf, NOCONST, NOCAST, ACTUAL));
          if (--N > 0) {
            code (proc, phase, ", ");
          }
        } else if (!idf->arg && idf->mode.type == type && idf->mode.len == len && idf->common == blck) {
          str[0] = '\0';
          if (IS_ROW (idf->mode)) {
            NEW_RECORD (buf);
            compute_row_size (buf, idf);
            if (EQUAL (buf, "VARY")) {
              ERROR (502, "only argument rows can vary", NO_TEXT);
            }
            _srecordf (str, "%s[%s]", C_NAME (idf), buf);
            code (proc, phase, str);
          } else {
            code (proc, phase, C_NAME (idf));
          }
          if (--N > 0) {
            code (proc, phase, ", ");
          }
        }
      }
    }
    code (proc, phase, ";\n");
  }
}

void code_idfs (IDENT * table, int_4 M, int_4 blck, int_4 proc, int_4 phase)
{
  for (int_4 n = STATIC; n <= AUTOMATIC; n++) {
    for (int_4 m = SOURCE; m <= TEMP; m++) {
      code_one_type (table, M, INTEGER, 2, blck, proc, n, m, phase);
      code_one_type (table, M, INTEGER, 4, blck, proc, n, m, phase);
      code_one_type (table, M, INTEGER, 8, blck, proc, n, m, phase);
      code_one_type (table, M, LOGICAL, 4, blck, proc, n, m, phase);
      code_one_type (table, M, REAL, 4, blck, proc, n, m, phase);
      code_one_type (table, M, REAL, 8, blck, proc, n, m, phase);
      code_one_type (table, M, REAL, 16, blck, proc, n, m, phase);
      code_one_type (table, M, REAL, 32, blck, proc, n, m, phase);
      code_one_type (table, M, COMPLEX, 8, blck, proc, n, m, phase);
      code_one_type (table, M, COMPLEX, 16, blck, proc, n, m, phase);
      code_one_type (table, M, COMPLEX, 32, blck, proc, n, m, phase);
      code_one_type (table, M, COMPLEX, 64, blck, proc, n, m, phase);
      for (int_4 k = 0, len = 2; k < MAX_STRLENS; k++, len *= 2) {
        if (strlens[k]) {
          code_one_type (table, M, CHARACTER, len - 1, blck, proc, n, m, phase);
        }
      }
    }
  }
}

void code_common (void)
{
  int_4 k;
  for (k = EXTERN + 1; k < ncommons; k++) {
    NEW_RECORD (name);
    code (0, COMMON, "\n");
    _srecordf (name, "// common /%s/\n", commons[k]);
    code (0, COMMON, name);
    _srecordf (name, "static struct {\n");
    code (0, COMMON, name);
    code_idfs (globals, nglobals, k, 0, COMMON);
    _srecordf (name, "} %s;\n", commons[k]);
    code (0, COMMON, name);
  }
}

void code_exts (IDENT * table, int_4 M, int_4 eblck, int_4 proc, int_4 phase)
{
  int_4 k;
  (void) eblck;
  for (k = 0; k < M; k++) {
    IDENT *idf = &table[k];
    if (idf->external && idf->arg == NOARG) {
      if (!find_module (C_NAME (idf))) { // Avoid prototype error.
        NEW_RECORD (str);
        MODE *mode = &(idf->mode);
        if (idf->used) {
          _srecordf (str, "extern %s %s ();\n", wtype (mode, NOARG, NOFUN), edit_f (C_NAME (idf)));
        } else {
          _srecordf (str, "// extern %s %s ();\n", wtype (mode, NOARG, NOFUN), edit_f (C_NAME (idf)));
        }
        code (proc, phase, str);
      }
    }
  }
}

void code_row_len (IDENT * idf)
{
  int_4 k, tlen = 1, npack = 0;
  NEW_RECORD (pack); NEW_RECORD (str);
  pack[0] = '\0';
  for (k = 0; k < idf->mode.dim; k++) {
    int_4 len;
    if (EQUAL (idf->len[k], "VARY")) {
      ERROR (503, "array has varying size", NO_TEXT);
    } else if (is_int4 (idf->len[k], &len)) {
      tlen *= len;
    } else {
      if (npack > 0) {
        bufcat (pack, " * ", RECLN);
      }
      bufcat (pack, "(", RECLN);
      bufcat (pack, idf->len[k], RECLN);
      bufcat (pack, ")", RECLN);
      npack++;
    }
  }
  if (tlen == 1 && npack > 0) {
    _srecordf (str, "%s", pack);
  } else if (npack == 0) {
    _srecordf (str, "%d", tlen);
  } else {
    _srecordf (str, "%d * %s", tlen, pack);
  }
  code (nprocs, BODY, str);
}

void proc_listing (int_4 proc)
{
  int_4 k, n, l_i, l_f;
  NEW_RECORD (lin);
  code (nprocs, SYMBOLS, newpage (modnam, "symbol-table"));
#if defined (LIST_IMPLICIT)
// Implicit modes
  RECCPY (lin, "//  ");
  for (k = ord ('a'); k <= ord ('z'); k++) {
    NEW_RECORD (str);
    _srecordf (str, "'%c' %-12s", 'a' + k, qtype (&implic[k].mode));
    bufcat (lin, str, RECLN);
    if ((k + 1) % 6 == 0) {
      bufcat (lin, "\n", RECLN);
      code (nprocs, SYMBOLS, lin);
      RECCPY (lin, "//  ");
    }
  }
  code (nprocs, SYMBOLS, lin);
  code (nprocs, SYMBOLS, "\n");
#endif
// Local variables
  if (nlocals > 0) {
    for (k = 0; k < nlocals; k++) {
      IDENT *idf = &locals[k];
//      if (idf->source != SOURCE || idf->external || idf->intrinsic) {
//        continue;
//      }
      NEW_RECORD (str);
      if (idf->source == SOURCE) {
        _srecordf (lin, "// line %6d %4s %-12s %-8s", idf->line, (idf->mode.save == STATIC ? "save" : "auto"), qtype (&idf->mode), F_NAME (idf));
      } else {
        _srecordf (lin, "// line %6d %4s %-12s %-8s", idf->line, "****", qtype (&idf->mode), F_NAME (idf));
      }
      for (n = 0; n < idf->mode.dim; n++) {
        _srecordf (str, " (%s, %s)", idf->lwb[n], idf->upb[n]);
        bufcat (lin, str, RECLN);
      }
      if (idf->parm != NO_TEXT) {
        bufcat (lin, " parm", RECLN);
      } else if (idf->used) {
        bufcat (lin, " used", RECLN);
      } else {
        bufcat (lin, " idle", RECLN);
      }
      if (idf->alias != NO_IDENT) {
        _srecordf (str, " aliased to %s", C_NAME (idf->alias));
        bufcat (lin, str, RECLN);
      }
      if (idf->equiv != NO_IDENT) {
        _srecordf (str, " aliased by %s", C_NAME (idf->equiv));
        bufcat (lin, str, RECLN);
      }
      if (idf->parm != NO_TEXT) {
        _srecordf (str, " = %s", idf->parm);
        bufcat (lin, str, RECLN);
      }
      code (nprocs, SYMBOLS, lin);
    }
    code (nprocs, SYMBOLS, "\n");
  }
  if (nlabels > 0) {
    for (k = 1; k < nlabels; k++) {
      LBL *L = &labels[k];
      if (L->jumped > 0) {
        _srecordf (lin, "// label %5d %5d in line %5d, goto\n", L->index, L->num, L->line);
      } else if (L->nonexe) {
        _srecordf (lin, "// label %5d %5d in line %5d, non-executable\n", L->index, L->num, L->line);
      } else {
        _srecordf (lin, "// label %5d %5d in line %5d\n", L->index, L->index, L->line);
      }
      code (nprocs, SYMBOLS, lin);
    }
    code (nprocs, SYMBOLS, "\n");
  }
// Unclassified comments need a place.
  int_4 xproc = nprocs;
  int_4 lisn = curlin;
  if (source[lisn].isn != 0) {
// If there is next module, delay comments after 'END' to the next module.
// We assume they belong there.
    lisn--;
    while (lisn >= 0 && source[lisn].isn == 0) {
      source[lisn].proc = 0;
      lisn--;
    }
  }
// Now assign comments to a module.
  for (k = lisn; k >= 0; k--) {
    FTN_LINE *flin = &source[k];
    if (xproc > 1 && flin->proc > 0 && flin->proc < xproc) {
      xproc = flin->proc;
    }
    if (flin->text != NO_TEXT && IS_COMMENT (flin->text[0]) && flin->proc == 0) {
      flin->proc = xproc;
    }
  }
//  
  l_i = l_f = ERR;
  for (k = 1; k < nftnlines && l_i == ERR; k++) {
    FTN_LINE *flin = &source[k];
    if (flin->proc == proc) {
      l_i = k;
    }
  }
  for (k = nftnlines - 1; k >= 1 && l_f == ERR; k--) {
    FTN_LINE *flin = &source[k];
    if (flin->proc == proc) {
      l_f = k;
    }
  }
  code (nprocs, LIST, newpage (modnam, "source-code"));
  for (k = l_i; k <= l_f; k++) {
    FTN_LINE *flin = &source[k];
    if (!flin->jcl) { // JCL is listed elsewhere.
      NEW_RECORD (lrec);
      if (flin->isn > 0) {
        _srecordf (lrec, "// %6d %6d %s\n", flin->num, flin->isn, flin->text);
      } else {
        _srecordf (lrec, "// %6d        %s\n", flin->num, flin->text);
      }
      code (nprocs, LIST, lrec);
    }
  }
}

