//! @file macro.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 function statements.

#include <vif.h>

int_4 macro_depth, macro_nest;

static void macro_args (RECORD *name, int_4 *N)
{
  int_4 rc = scan (EXPECT_NONE);
  rc = scan (EXPECT_NONE);
  rc = scan (EXPECT_NONE);
  if (rc != WORD) {
    EXPECT (2501, "variable")
  } else {
    int_4 go_on;
    do {
      if (rc != WORD) {
        EXPECT (2502, "variable");
      }
      RECCPY (name[*N], curlex);
      (*N)++;
      rc = scan (EXPECT_NONE);
      if (TOKEN (",")) {
        go_on = TRUE;
        rc = scan (EXPECT_NONE);
      } else if (TOKEN (")")) {
        rc = scan (EXPECT_NONE);
        CHECKPOINT (2503, "=");
        go_on = FALSE;
      } else {
        EXPECT (2504, ", or )");
        go_on = FALSE;
      }
    } while (go_on);
  }
}

static void macro_parms (RECORD *pack, RECORD expr, int_4 N, int_4 *M)
{
  (void) scan (EXPECT_NONE);
  if (TOKEN ("(")) {
    macro_parms (pack, expr, N, M);
  } else if (TOKEN (",")) {
    macro_parms (pack, expr, N, M);
  } else if (TOKEN (")")) {
    return;
  } else {
    MODE mode;
    EXPR reg;
    NEW_RECORD (res);
    int k = macro_nest;
    memset (&reg, 0, sizeof (EXPR));
    express (&reg, NOTYPE, 0);
    macro_nest = k;
    (void) add_nest (pack[*M], macro_nest, &mode);
    _srecordf (res, "%s %s = %s; ", wtype (&mode, NOARG, NOFUN), edit_vn (pack[*M], macro_nest), reg.str);
    (*M)++;
    bufcat (expr, res, RECLN);
    macro_parms (pack, expr, N, M);
  }
}

void macro (EXPR *loc, IDENT *idf)
{
  UNSCAN;
  if (macro_depth++ > MAX_MACRO_DEPTH) {
// This could happen due to infinite recursion.
// A simple alternative to Warshall's algorithm.
    FATAL (2505, "macro expansion too deep", NO_TEXT);
  }
  int_4 savlin = curlin, savcol = curcol;
  int_4 savesp = nlocals;
  macro_nest++;
// Gather arguments.
  curlin = idf->line;
  curcol = 0;
  RECORD pack[MAX_ARGS];
  NEW_RECORD (expr);
  bzero (pack, sizeof (pack));
  bufcpy (expr, "({", RECLN);
  int_4 N = 0, M = 0;
  macro_args (pack, &N);
// Work out arguments.
  curlin = savlin;
  curcol = savcol;
  (void) scan (EXPECT_NONE);
  macro_parms (pack, expr, N, &M);
  int_4 savesp2 = nlocals;
  savlin = curlin;
  savcol = curcol;
  int_4 savprl = prelin;
  int_4 savprc = precol;
  NEW_RECORD (savlex);
  bufcpy (savlex, curlex, RECLN);
// Work out macro expression. 
  curlin = idf->line;
  curcol = 0;
  EXPR reg, new = (EXPR) {.mode = idf->mode};
  memset (&reg, 0, sizeof (reg));
  (void) scan (EXPECT_NONE);
  while (! TOKEN ("=")) {
    (void) scan (EXPECT_NONE);
  }
  (void) scan (EXPECT_NONE);
  express (&reg, NOTYPE, 0);
  if (!coerce (&new, &reg)) {
    MODE_ERROR (2506, qtype (&(reg.mode)), qtype (&(new.mode)));
  }  
  bufcat (expr, new.str, RECLN);
  bufcat (expr, ";})", RECLN);
  bufcpy (loc->str, expr, RECLN);
  loc->variant = EXPR_OTHER;
  loc->mode = new.mode;
  curlin = savlin;
  curcol = savcol;
  prelin = savprl;
  precol = savprc;
  bufcpy (curlex, savlex, RECLN);
// Disable parms and exit.
  for (int_4 k = savesp; k < savesp2; k++) {
    (&locals[k])->nest = -1;
  }
  macro_nest--;
}

static void do_macro ()
{
  MODE mode;
  IDENT *idf = find_local (curlex, &mode);
  if (idf == NO_IDENT) {
    idf = add_local (curlex, NOTYPE, NOLEN, UNIQ, NOPATCH, NOARG, LOCAL, MACRO); 
    impl_type (curlex, &idf->mode);
  }
  idf->line = curlin;
  idf->source = MACRO;
// Skip argument pack.
  int_4 rc = scan (EXPECT_NONE);
  do {
    rc = scan (EXPECT_NONE);
  } while (rc != END_OF_LINE && ! TOKEN (")"));
// Check syntax.
  if (rc == END_OF_LINE) {
    EXPECT (2507, "=");
  } else {
    rc = scan (EXPECT_NONE);
    CHECKPOINT (2508, "=");
    skip_card (FALSE);
  }
}

void decl_macros (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) {
      skip_card (FALSE);
    } else if (rc == WORD && IS_MACRO_DECLARATION) {
      do_macro ();
      skip_card (FALSE);
    } else if (strlen (curlex) > 0) {
// Backspace and done.
      RESTORE_POS (1);
      go_on = FALSE;
    }
  }
}

