//! @file modules.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 BLOCK DATA, FUNCTION, PROGRAM and SUBROUTINE.

#include <vif.h>

#define ALLOW_ANON (nprocs >= 0)

int_4 aborted;
int_4 nmodules = 0;
char *modules[MAX_MODULES];

void common_errors (int_4 *nest)
{
  NEW_RECORD (str);
  _srecordf (str, "%s %s", prelex, curlex);
  if (TOKEN ("(")) {
    (*nest)++;
  } else if (TOKEN (")")) {
    (*nest)--;
  } else if (strlen (curlex) == 1 && strchr ("{}[];\\?~`@#$%", curlex[0]) != NO_TEXT) {
    SYNTAX (2601, "stray symbol");
  } else if (preret == WORD && curret == WORD) {
    if (!reserved (prelex)) {
      ADJACENT (2602, str);
    }
  } else if (IS_NUMBER (preret) && IS_NUMBER (curret)) {
    ADJACENT (2603, str);
  }
}

void skip_to_end (void)
{
  int_4 rc, go_on = TRUE;
  while (go_on && (rc = scan (EXPECT_NONE)) != END_OF_MODULE) {
    if (TOKEN ("end") && IS_NOT_ASSIGNMENT) {
      go_on = FALSE;
    } else {
      rc = scan (EXPECT_NONE);
      while (WITHIN) {
        rc = scan (EXPECT_NONE);
      }
    }
  }
  aborted = TRUE;
}

void prescan (void)
{
  SAVE_POS (1);
  int_4 rc, go_on = TRUE;
  while (go_on && (rc = scan (EXPECT_NONE)) != END_OF_MODULE) {
    LBL *statlbl = NO_LABEL;
    if (curlex[0] == '\0') {
      continue;
    }
    if (rc == LABEL) {
      sscanf (curlex, "%d", &CUR_LIN.label);
      if (nlabels >= MAX_LABELS) {
        ERROR (2604, "too many labels", NO_TEXT);
      }
      for (int_4 k = 1; k < nlabels; k++) {
        if (labels[k].num == CUR_LIN.label) {
          ERROR (2605, "duplicate label", curlex);
          break;
        }
      }
      statlbl = &labels[nlabels];
      statlbl->index = nlabels;
      statlbl->num = CUR_LIN.label;
      statlbl->line = curlin;
      statlbl->nonexe = FALSE;
      statlbl->data = FALSE;
      statlbl->format = FALSE;
      statlbl->jumped = FALSE;
      statlbl->renum = nlabels++;
      rc = scan (EXPECT_NONE);
    }
    if (TOKEN ("end") && IS_NOT_ASSIGNMENT) {
      go_on = FALSE;
    } else if (TOKEN ("data") && IS_NOT_ASSIGNMENT) {
      if (statlbl != NO_LABEL) {
        statlbl->nonexe = TRUE;
        statlbl->data = TRUE;
      }
      skip_card (FALSE);
    } else if (TOKEN ("format") && IS_NOT_ASSIGNMENT) {
      if (statlbl == NO_LABEL) {
        ERROR (2606, "format statement needs a label", NO_TEXT);
      } else {
        statlbl->nonexe = TRUE;
        statlbl->format = TRUE;
      }
      skip_card (FALSE);
    } else {
      int_4 nest = 0;
      rc = scan (EXPECT_NONE);
      while (WITHIN) {
        common_errors (&nest);
        rc = scan (EXPECT_NONE);
      }
      if (nest != 0) {
        SYNTAX (2607, "unbalanced parentheses");
      }
    }
  }
  RESTORE_POS (1);
}

void code_args (int_4 proc, int_4 phase)
{
  int_4 rc;
  code (proc, phase, procnam);
  code (proc, phase, " ");
  rc = scan (EXPECT_NONE);
  if (TOKEN ("(")) {
    rc = scan (EXPECT_NONE);
    if (TOKEN (")")) {
      code (proc, phase, "(void)");
    } else if (rc == WORD) {
      int_4 go_on;
      code (proc, phase, "(");
      do {
        int_4 apatch = code (proc, phase, NO_TEXT);
        if (rc == WORD) {
          add_local (curlex, NOTYPE, NOLEN, UNIQ, apatch, ARG, LOCAL, SOURCE);
        } else {
          EXPECT (2608, "variable");
        }
        rc = scan (EXPECT_NONE);
        if (TOKEN (",")) {
          go_on = TRUE;
          code (proc, phase, ", ");
          rc = scan (EXPECT_NONE);
        } else if (TOKEN (")")) {
          go_on = FALSE;
          code (proc, phase, ")");
        } else {
          go_on = FALSE;
          EXPECT (2609, ", or )");
        }
      } while (go_on);
    }
  } else {
    code (proc, phase, "(void)");
  }
  (void) rc;
  skip_card (FALSE);
}

void gen_code (void)
{
// Generate code for one module.
  code (nprocs, TITLE, newpage (modnam, "generated-code"));
  code (nprocs, PARAMETERS, newpage (modnam, "parameters"));
  code (nprocs, MESSAGES, newpage (modnam, "diagnostics"));
  merrors = 0;
  prescan ();
//
  SAVE_POS (1);
  if (merrors == 0) {
    get_impl ();
    RESTORE_POS (1);
    get_decls ();
    RESTORE_POS (1);
    decl_autosave ();
    RESTORE_POS (1);
    decl_equiv ();
    merge_commons ();
    RESTORE_POS (1);
    decl_data ();
  }
  if (merrors == 0) {
    idfs_unused ();
    RESTORE_POS (1);
    decl_macros ();
  } else {
    skip_to_end ();
    return;
  }
  if (merrors == 0) {
    gen_statements (NO_LABEL, 0);
    code_idfs (locals, nlocals, LOCAL, nprocs, DECL);
    code_exts (locals, nlocals, LOCAL, nprocs, DECL);
  } else {
    skip_to_end ();
    return;
  }
  if (merrors == 0) {
    patch_args ();
  }
}

void gen_program (void)
{
  int_4 rc;
// PROGRAM
  nprocs++;
  code (0, PROTOTYPE, "\n");
  code (0, PROTOTYPE, "prototype int_4 ");
  code (nprocs, PRE, "int_4 ");
  SAVE_POS (1);
  rc = scan (EXPECT_NONE);
  if (rc != WORD) {
    ERROR (2610, "missing name for ", "program");
    RECCPY (modnam, "program");
  } else {
    RECCPY (modnam, curlex);
  }
  _srecordf (procnam, "%s", edit_f (modnam));
  RECCPY (retnam, "");
  if (strlen (program) == 0) {
    RECCPY (program, procnam);
  } else {
    ERROR (2611, "redefinition", "program");
  }
  code_args (0, PROTOTYPE);
  code (0, PROTOTYPE, ";");
  RESTORE_POS (1);
  rc = scan (EXPECT_NONE);
  code_args (nprocs, PRE);
  code (nprocs, PRE, "\n");
  code (nprocs, PRE, "{\n");
  cpp_direct (nprocs, prelin, PRE);
  gen_code ();
  code (nprocs, POST, "}");
}

void gen_anon_program (void)
{
  if (! ALLOW_ANON) {
    EXPECT (2612, "valid subprogram");
    return; 
  }
  if (nprocs == 0) {
    curlin = 1; 
  }
    curcol = START_OF_LINE;
  nprocs++;
  RECCPY (modnam, "anonymous");
  _srecordf (procnam, "%s", edit_f (modnam));
  RECCPY (retnam, "");
  if (strlen (program) == 0) {
    RECCPY (program, procnam);
  } else {
    ERROR (2613, "redefinition", "program");
  }
  code (0, PROTOTYPE, "\n");
  code (0, PROTOTYPE, "prototype int_4 ");
  code (0, PROTOTYPE, procnam);
  code (0, PROTOTYPE, " (void);");
  code (nprocs, PRE, "int_4 ");
  code (nprocs, PRE, procnam);
  code (nprocs, PRE, " (void)");
  code (nprocs, PRE, "\n");
  code (nprocs, PRE, "{\n");
  cpp_direct (nprocs, prelin, PRE);
  gen_code ();
  code (nprocs, POST, "}");
}

void gen_subroutine (void)
{
// SUBROUTINE
  int_4 rc;
  nprocs++;
  code (0, PROTOTYPE, "\n");
  if (compile_only || optimise < 3) {
    code (0, PROTOTYPE, "prototype int_4 ");
    code (nprocs, PRE, "int_4 ");
  } else {
    code (0, PROTOTYPE, "prototype static inline int_4 ");
    code (nprocs, PRE, "static inline int_4 ");
  }
  SAVE_POS (1);
  rc = scan (EXPECT_NONE);
  if (rc != WORD) {
    ERROR (2614, "missing name for ", "subroutine");
    RECCPY (modnam, "routine");
  } else {
    RECCPY (modnam, curlex);
  }
  _srecordf (procnam, "%s", edit_f (modnam));
  RECCPY (retnam, "");
  code_args (0, PROTOTYPE);
  code (0, PROTOTYPE, ";");
  RESTORE_POS (1);
  rc = scan (EXPECT_NONE);
  code_args (nprocs, PRE);
  code (nprocs, PRE, "\n");
  code (nprocs, PRE, "{\n");
  cpp_direct (nprocs, prelin, PRE);
  gen_code ();
  code (nprocs, POST, "}");
}

void gen_block_data (void)
{
// BLOCK DATA
  NEW_RECORD (str);
  int_4 rc = scan (EXPECT_NONE);
  nprocs++;
  if (!TOKEN ("data")) {
    EXPECT (2615, "block data");
  }
  rc = scan (EXPECT_NONE);
  if (prelin == curlin) {
    RECCPY (modnam, curlex);
    rc = scan (EXPECT_NONE);
  } else {
    RECCPY (modnam, "block_data");
  }
  RECCPY (retnam, "");
  _srecordf (block, "%s", edit_f (modnam));
  if (compile_only || optimise < 3) {
    _srecordf (str, "int_4 %s (void)", block);
  } else {
    _srecordf (str, "static inline int_4 %s (void)", block);
  }
  code (0, PROTOTYPE, "\n");
  code (0, PROTOTYPE, "prototype ");
  code (0, PROTOTYPE, str);
  code (0, PROTOTYPE, ";");
  code (nprocs, PRE, str);
  code (nprocs, PRE, "{\n");
  cpp_direct (nprocs, prelin, PRE);
  gen_code ();
  code (nprocs, POST, "}");
  (void) rc;
}

void gen_function (void)
{
  int_4 rc;
// FUNCTION with implicit type.
  int_4 patchp, patchf;
  SAVE_POS (1);
  IDENT *ret;
  NEW_RECORD (str);
  nprocs++;
  func = TRUE;
  code (0, PROTOTYPE, "\n");
  code (0, PROTOTYPE, "prototype ");
  if (compile_only == FALSE || optimise >= 3) {
    code (0, PROTOTYPE, "static inline ");
  }
  patchp = code (0, PROTOTYPE, NO_TEXT);
  code (0, PROTOTYPE, " ");
  if (compile_only == FALSE || optimise >= 3) {
    code (nprocs, PRE, "static inline ");
  }
  patchf = code (nprocs, PRE, NO_TEXT);
  code (nprocs, PRE, " ");
  rc = scan (EXPECT_NONE);
  if (rc != WORD) {
    ERROR (2616, "missing name for ", "function");
    RECCPY (modnam, "function");
  } else {
    RECCPY (modnam, curlex);
  }
  _srecordf (procnam, "%s", edit_f (modnam));
  ret = add_local (modnam, NOTYPE, NOLEN, UNIQ, NOPATCH, NOARG, LOCAL, SOURCE);
  ret->mode.fun = TRUE;
  ret->mode.save = AUTOMATIC;
  _srecordf (retnam, "%s", C_NAME (ret));
  code_args (0, PROTOTYPE);
  code (0, PROTOTYPE, ";");
  RESTORE_POS (1);
  rc = scan (EXPECT_NONE);
  code_args (nprocs, PRE);
  code (nprocs, PRE, "\n");
  code (nprocs, PRE, "{\n");
  cpp_direct (nprocs, prelin, PRE);
  gen_code ();
  code (nprocs, POST, "}\n");
  _srecordf (str, "%s", wtype (&ret->mode, NOARG, FUN));
  patch (patchp, str);
  patch (patchf, str);
}

MODE gen_typed_function (void)
{
  int_4 rc;
// TYPE FUNCTION
  MODE mode;
  f2c_type (curlex, &mode, NOARG, NOFUN);
  rc = scan (EXPECT_NONE);
  if (!TOKEN ("function")) {
    mode.type = NOTYPE;
    mode.len = 0;
    return mode;
  } else {
    SAVE_POS (1);
    IDENT *ret;
    nprocs++;
    func = TRUE;
    code (0, PROTOTYPE, "\n");
    code (0, PROTOTYPE, "prototype ");
    if (compile_only == FALSE || optimise >= 3) {
      code (0, PROTOTYPE, "static inline ");
    }
    code (0, PROTOTYPE, f2c_type (prelex, NO_MODE, NOARG, FUN));
    code (0, PROTOTYPE, " ");
    if (compile_only == FALSE || optimise >= 3) {
      code (nprocs, PRE, "static inline ");
    }
    code (nprocs, PRE, f2c_type (prelex, NO_MODE, NOARG, FUN));
    code (nprocs, PRE, " ");
    rc = scan (EXPECT_NONE);
    if (rc != WORD) {
      ERROR (2617, "missing name for ", "function");
      RECCPY (modnam, "function");
    } else {
      RECCPY (modnam, curlex);
    }
    _srecordf (procnam, "%s", edit_f (modnam));
    ret = add_local (modnam, mode.type, mode.len, UNIQ, NOPATCH, NOARG, LOCAL, SOURCE);
    ret->mode.fun = TRUE;
    ret->mode.save = AUTOMATIC;
    _srecordf (retnam, "%s", C_NAME (ret));
    code_args (0, PROTOTYPE);
    code (0, PROTOTYPE, ";");
    RESTORE_POS (1);
    rc = scan (EXPECT_NONE);
    code_args (nprocs, PRE);
    code (nprocs, PRE, "\n");
    code (nprocs, PRE, "{\n");
    cpp_direct (nprocs, prelin, PRE);
    gen_code ();
    code (nprocs, POST, "}");
  }
  return mode;
}

void subprograms (void)
{
  int_4 rc;
  NEW_RECORD (type);
  NEW_RECORD (kind);
  NEW_RECORD (str);
  NEW_RECORD (endof);
  while (!abend) {
    SAVE_POS (1);
    rc = scan (EXPECT_NONE);
    if (rc == END_OF_MODULE) {
      break;
    }
    nlocals = 0;
    type[0] = '\0';
// Label '0' is the label for subprogram exit.
    labels[0].num = 0;
    labels[0].line = 0;
    labels[0].jumped = FALSE;
    nlabels = 1;
//
    lbl = NO_LABEL;
    nloctmps = 0;
    func = FALSE;
    if (rc == END_OF_LINE) {
      continue;
    }
    kind[0] = '\0';
    end_statements = 0;
    aborted = FALSE;
    if (rc == WORD) {
      if (TOKEN ("program")) {
        bufcpy (kind, "program", RECLN);
        gen_program ();
      } else if (TOKEN ("subroutine")) {
        bufcpy (kind, "subroutine", RECLN);
        gen_subroutine ();
        if (renum && merrors == 0) {
          RESTORE_POS (1);
          tidy_source (procnam);
        }
      } else if (TOKEN ("block")) {
        bufcpy (kind, "block data", RECLN);
        gen_block_data ();
        if (renum && merrors == 0) {
          RESTORE_POS (1);
          tidy_source (procnam);
        }
      } else if (TOKEN ("function")) {
        bufcpy (kind, "function", RECLN);
        gen_function ();
        if (renum && merrors == 0) {
          RESTORE_POS (1);
          tidy_source (procnam);
        }
      } else {
        if (ALLOW_ANON) {
          gen_anon_program ();
          bufcpy (kind, "program", RECLN);
          if (renum && merrors == 0) {
            RESTORE_POS (1);
            tidy_source (procnam);
          }
        }
      }
    } else if (rc == DECLAR) {
      bufcpy (kind, "function", RECLN);
      MODE ret = gen_typed_function ();
      if (ret.type == NOTYPE && ALLOW_ANON) {
        gen_anon_program ();
        bufcpy (kind, "program", RECLN);
      } else {
        _srecordf (type, qtype (&ret));
      }
      if (renum && merrors == 0) {
        RESTORE_POS (1);
        tidy_source (procnam);
      }
//  } else if (rc == LABEL) {
//    WARNING (2618, "ignored label", curlex);
    } else {
      if (ALLOW_ANON) {
        gen_anon_program ();
        bufcpy (kind, "program", RECLN);
        if (renum && merrors == 0) {
          RESTORE_POS (1);
          tidy_source (procnam);
        }
      } else {
        EXPECT (2619, "valid subprogram");
      }
      return;
    }
    if (!aborted && end_statements == 0) {
      EXPECT (2620, "end statement");
    }
    if (nprocs == 0) {
//    BUG ("no subprogram found");
      FATAL (2621, "no subprogram", "check program statement");
    }
// Prune 'sleeping' labels.
    for (int_4 k = 0; k < nlabels; k++) {
      LBL *L = &labels[k];
      if (!L->jumped) {
        patch (L->patch, NO_TEXT);
      }
    }
//
    if (nprocs == pnprocs) {
      FATAL (2622, "invalid fortran source", modnam);
    }
    NEW_RECORD (sub);
    _srecordf (endof, "** %-10s ** end of compilation %d", _bufsub (sub, modnam, 1, 10), nprocs);
    pnprocs = nprocs;
    code (nprocs, BANNER, newpage (modnam, modnam));
    if (strlen (type) > 0) {
      banner (nprocs, BANNER, _strupper (type));
      code (nprocs, BANNER, "\n");
      _srecordf (str, "  {\"%s\", 0}, // %s %s\n", modnam, type, kind);
      code (0, FREQ, str);
    } else {
      _srecordf (str, "  {\"%s\", 0}, // %s\n", modnam, kind);
      code (0, FREQ, str);
    }
    banner (nprocs, BANNER, _strupper (kind));
    code (nprocs, BANNER, "\n");
    banner (nprocs, BANNER, _strupper (modnam));
    code (nprocs, BANNER, "\n");
    if (!quiet_mode) {
      diagnostic (nprocs, endof);
    }
    proc_listing (nprocs);
  }
}

logical_4 find_module (char *name)
{
  for (int_4 k = 0; k < nmodules; k++) {
    if (same_name (name, modules[k])) {
      return TRUE;
    }
  }
  return FALSE;
}

void list_module (void)
{
  int_4 rc = scan (EXPECT_NONE);
  if (rc == WORD) {
    if (nmodules >= MAX_MODULES) {
      FATAL (2623, "too many modules", NO_TEXT);
    }
    modules[nmodules++] = f_stralloc (curlex);
  } else {
    ERROR (2624, "missing name", "module");
  }
}

void scan_modules (void)
{
  int_4 rc;
  while ((rc = scan (EXPECT_NONE)) != END_OF_MODULE && !abend) {
    if (rc == WORD) {
      if (TOKEN ("program")) {
        list_module ();
      } else if (TOKEN ("subroutine")) {
        list_module ();
      } else if (TOKEN ("function")) {
        list_module ();
      } else if (rc == DECLAR) {
        rc = scan (EXPECT_NONE);
        if (TOKEN ("function")) {
          list_module ();
        }
      } else if (TOKEN ("block")) {
        rc = scan (EXPECT_NONE);
        if (TOKEN ("data")) {
          list_module ();
        }
      }
    }
  }
}
