//! @file table.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
//!
//! Symbol table routines.

#include <vif.h>

int_4 ord (char ch)
{
  return (ch - 'a');
}

char *edit_name (char *name)
{
// Strip leading and trailing underscores.
  static RECORD idf, idf2;
  char *buf = idf;
  strcpy (buf, name);
  int_4 len = strlen (buf);
  while (len > 1 && buf[len - 1] == '_') {
    buf[len - 1] = '\0';
    len = strlen (buf);
  }
  while (len > 1 && buf[0] == '_') {
    buf++;
    len = strlen (buf);
  }
  RECCPY (idf2, buf);
  return idf2;
}

char *edit_f (char *name)
{
// Function name
  static RECORD buf;
  _srecordf (buf, "_%s", edit_name (name));
  return buf;
}

char *edit_i (char *name)
{
// Intrinsic name
  static RECORD buf;
  _srecordf (buf, "__%s", edit_name (name));
  return buf;
}

char *edit_v (char *name)
{
// Variable
  static RECORD buf;
  _srecordf (buf, "%s_", edit_name (name));
  return buf;
}

char *edit_vn (char *name, int_4 num)
{
// Variable-Nest
  static RECORD buf;
  _srecordf (buf, "%s_%d_", edit_v (name), num);
  return buf;
}

char *edit_tmp (int_4 num)
{
  static RECORD buf;
  _srecordf (buf, "$%d_", num);
  return buf;
}

char *edit_fmt (int_4 num)
{
  static RECORD buf;
  if (num >= 100000) { // Anonymous text formats
    _srecordf (buf, "$f_%d_", num);
    return buf;
  }
  LBL *L = NO_LABEL;
  for (int_4 k = 0; k < nlabels; k++) {
    if (num == labels[k].num) {
      L = &labels[k];
      break;
    }
  }
  if (L == NO_LABEL) {
    _srecordf (buf, "%d", num);
    ERROR (3101, "undefined label", buf);
    return NO_TEXT;
  } else if (!L->format) {
    _srecordf (buf, "%d", num);
    ERROR (3102, "not a format label", buf);
    return NO_TEXT;
  } else {
    L->jumped++;
    _srecordf (buf, "$f_%d_", num);
    return buf;
  }
}

char *edit_unit (int_4 num)
{
  static RECORD buf;
  _srecordf (buf, "$u_%d_", num);
  return buf;
}

char *encode (char *buf, char *name)
{
  bufcpy (buf, name, RECLN);
  int_4 len = (int_4) strlen (buf);
  if (buf[0] == '_' || buf[len - 1] == '_') {
    return buf;
  }
  bufcpy (buf, edit_v (name), RECLN);
  return buf;
}

char *c_name (char *name)
{
  NEW_RECORD (safe);
  (void) encode (safe, name);
  return f_stralloc (safe);
}

logical_4 same_name (char *name, char * id)
{
if (name == NO_TEXT || id == NO_TEXT) return FALSE;
  NEW_RECORD (u);
  NEW_RECORD (v);
  (void) encode (u, name);
  (void) encode (v, id);
  return EQUAL (u, v);
}

LBL *find_label (char *lab)
{
  int_4 k, num;
  sscanf (lab, "%d", &num);
  for (k = 0; k < nlabels; k++) {
    LBL *L = &labels[k];
    if (num == L->num) {
      return L;
    }
  }
  return NO_LABEL;
}

void impl_type (char *name, MODE * mode)
{
  int_4 k = ord (tolower (name[0]));
  (*mode) = implic[k].mode;
}

int_4 add_block (char *name)
{
  int_4 k;
  for (k = 0; k < ncommons; k++) {
    if (same_name (name, commons[k])) {
      return k;
    }
  }
  if (ncommons >= MAX_COMMONS) {
    FATAL (3103, "too many common blocks", NO_TEXT);
  }
  k = ncommons++;
  commons[k] = c_name (name);
  return k;
}

IDENT *find_local (char *name, MODE * mode)
{
  int_4 k;
  if (!IS_VAR (name)) {
    ERROR (3104, "not a variable name", curlex);
    return NO_IDENT;
  }
// Search backwards, do not change.
  for (k = nlocals - 1; k >= 0; k--) {
    IDENT *idf = &locals[k];
    if (idf->nest >= 0 && (EQUAL (name, C_NAME (idf)) || EQUAL (name, F_NAME (idf)))) {
      if (macro_nest > 0 ? TRUE : idf->nest == 0) {
        if (mode != NO_MODE) {
          (*mode) = idf->mode;
        }
        idf->used = TRUE;
        return idf;
      }
    }
  }
  return NO_IDENT;
}

IDENT *void_decl (char *name, MODE * mode)
{
  if (!IS_VAR (name)) {
    ERROR (3105, "not a variable name", curlex);
    return NO_IDENT;
  }
// Apparently a normal local variable.
  IDENT *idf = find_local (name, mode);
  if (idf == NO_IDENT) {
    if (nlocals >= MAX_IDENTS) {
      FATAL (3106, "too many identifiers", NO_TEXT);
      return NO_IDENT;
    }
    idf = &locals[nlocals++];
    memset (idf, 0, sizeof (IDENT));
    idf->line = curlin;
    C_NAME (idf) = c_name (name);
    F_NAME (idf) = f_stralloc (name);
    idf->external = FALSE;
    idf->mode.type = NOTYPE;
    idf->mode.len = 0;
    if (mode != NO_MODE) {
      *mode = idf->mode;
    }
  }
  return idf;
}

IDENT *add_local (char *name, int_4 type, int_4 len, int_4 uniq, int_4 apatch, int_4 arg, int_4 blck, int_4 src)
{
  MODE mode;
  if (!IS_VAR (name)) {
    ERROR (3107, "not a variable name", curlex);
    return NO_IDENT;
  }
  IDENT *idf = find_local (name, &mode);
  if (type == CHARACTER) {
    MODE m = {.type = type, .len = len};
    norm_mode (&m);
    len = m.len;
    if (idf == NO_IDENT) {
      if (len == 0 && arg == FALSE) {
        ERROR (3108, "variable length character must be argument", name);
      }
    } else {
      if (len == 0 && idf->arg == FALSE) {
        ERROR (3109, "variable length character must be argument", name);
      }
    }
  }
  if (idf != NO_IDENT) {
    if (uniq) {
      if (idf->mode.type == NOTYPE) {
        if (type != NOTYPE) {
          // Do not overwrite 'dim', respect previous dimension statement.
          idf->mode.type = type;
          idf->mode.len = len;
        } else {
          idf->patch2 = apatch;
        }
      } else if (idf->parm != NO_TEXT) {
        if (accept_mode (idf->mode.type, idf->mode.len, type, len)) {
          idf->mode = PLAIN_MODE (type, len);
        } else {
          MODE err = PLAIN_MODE (type, len);
          MODE_ERROR (3110, qtype (&err), qtype (&(idf->mode)));
        }
      } else if (NOT_LOCAL (idf)) {
        idf->mode = PLAIN_MODE (type, len);
      } else if (idf->external) {
        idf->mode = PLAIN_MODE (type, len);
      } else if (idf->mode.type == type && idf->mode.len == len) {
        /* Let it pass */
      } else {
        ERROR (3111, "multiple definition", name);
      }
    }
    return idf;
  }
  if (nlocals >= MAX_IDENTS) {
    FATAL (3112, "too many identifiers", NO_TEXT);
    return NO_IDENT;
  }
  idf = &locals[nlocals++];
  memset (idf, 0, sizeof (IDENT));
  idf->line = curlin;
  C_NAME (idf) = c_name (name);
  F_NAME (idf) = f_stralloc (name);
  idf->arg = arg;
  idf->common = blck;
  idf->external = FALSE;
  idf->mode = PLAIN_MODE (type, len);
  idf->patch1 = apatch;
  idf->source = src;
  return idf;
}

IDENT *add_nest (char *name, int_4 nest, MODE *mode)
{
  if (!IS_VAR (name)) {
    ERROR (3113, "not a variable name", curlex);
    return NO_IDENT;
  }
  if (nlocals >= MAX_IDENTS) {
    FATAL (3114, "too many identifiers", NO_TEXT);
    return NO_IDENT;
  }
// Already declared? Take this mode.
  IDENT *pre = find_local (name, mode);
//
  IDENT *idf = &locals[nlocals++];
  memset (idf, 0, sizeof (IDENT));
  idf->line = curlin;
  C_NAME (idf) = c_name (name);
  F_NAME (idf) = f_stralloc (name);
  idf->arg = NOARG;
  idf->external = FALSE;
  idf->common = 0;
  idf->patch1 = NOPATCH;
  idf->source = TEMP;
  idf->nest = nest;
  if (pre == NO_IDENT) {
    impl_type (name, &idf->mode);
    *mode = idf->mode;
  } else {
    *mode = pre->mode;
    idf->mode = *mode;
  }
  return idf;
}
