//! @file decls.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 declarations.

#include <vif.h>

void idfs_reset (void)
{
// Before explicit declarations reset implicit ones.
// Then do explicit declarations, followed by implicit ones.
  int_4 k;
  for (k = 0; k < nlocals; k++) {
    IDENT *idf = &locals[k];
    if (idf->parm == NO_TEXT && !idf->mode.fun) {
      idf->mode.type = NOTYPE;
    }
  }
}

void idfs_unused (void)
{
// Before explicit declarations reset implicit ones.
// Then do explicit declarations, followed by implicit ones.
  int_4 k;
  for (k = 0; k < nlocals; k++) {
    IDENT *idf = &locals[k];
    idf->used = FALSE;
  }
}

void get_init (IDENT *idf, MODE *mode)
{
  EXPR reg;
  memset (&reg, 0, sizeof (EXPR));
  (void) scan (EXPECT_NONE);
  factor (&reg);
  if (accept_mode (reg.mode.type, reg.mode.len, mode->type, mode->len)) {
    cpp_direct (nprocs, prelin, BODY);
    NEW_RECORD (str);
    if (mode->type == CHARACTER) {
      _srecordf (str, "bufcpy (%s, %s, %d);\n", C_NAME (idf), reg.str, mode->len);
    } else {
      _srecordf (str, "%s = %s;\n", C_NAME (idf), reg.str);
    }
    code (nprocs, BODY, str);
  } else {
    ERROR (1001, "expect type", qtype (mode));
  }
}

void dec_local (void)
{
  int_4 rc;
  MODE mode;
  NEW_RECORD (base);
  RECCPY (base, curlex);
// Remove length specification.
  char *star = strchr (base, '*');
  if (star != NO_TEXT) {
    *star = '\0';
  }
// 
  f2c_type (curlex, &mode, NOARG, NOFUN);
  rc = scan (EXPECT_NONE);
  if (rc == END_OF_LINE) {
    EXPECT (1002, "identifier");
  }
  while (rc != END_OF_LINE) {
    IDENT *idf = NO_IDENT;
// Identifier, store with leading mode unless length N is specified as idf*N.
    NEW_RECORD (name);
    if (rc != WORD) {
      EXPECT (1003, "identifier");
    } else {
      if (/* reserved (curlex) */ FALSE) {
        ERROR (1004, "reserved symbol", curlex);
      }
      RECCPY (name, curlex);
      rc = scan (EXPECT_NONE);
      if (!TOKEN ("*")) {
// identifier
        idf = add_local (name, mode.type, mode.len, UNIQ, NOPATCH, NOARG, LOCAL, SOURCE);
      } else {
// identifier*length
        NEW_RECORD (length);
        rc = scan (EXPECT_NONE);
        bufcpy (length, curlex, RECLN);
        if (TOKEN ("(")) {
// identifier*(length)
          rc = scan (EXPECT_NONE);
          bufcpy (length, curlex, RECLN);
          (void) scan (")");
        }
        if (rc == WORD) {
          IDENT *ldf = find_local (length, NO_MODE);
          if (ldf == NO_IDENT || ldf->parm == NO_TEXT) {
            SYNTAX (1005, length);
          } else if (ldf->mode.type != INTEGER) {
            EXPECT (1006, "integer");
          } else {
            NEW_RECORD (new);
            snprintf (new, RECLN, "%s*%s", base, ldf->parm);
            MODE mode_n;
            f2c_type (new, &mode_n, NOARG, NOFUN);
            norm_mode (&mode_n);
            idf = add_local (name, mode_n.type, mode_n.len, UNIQ, NOPATCH, NOARG, LOCAL, SOURCE);
          }
          rc = scan (EXPECT_NONE);
        } else if (rc == INT_NUMBER || EQUAL (length, "*")) {
          NEW_RECORD (new);
          MODE mode_n;
	  if (EQUAL (length, "*")) {
            snprintf (new, RECLN, "%s*(*)", base);
	  } else {
            snprintf (new, RECLN, "%s*%s", base, length);
	  }
          f2c_type (new, &mode_n, NOARG, NOFUN);
          norm_mode (&mode_n);
          idf = add_local (name, mode_n.type, mode_n.len, UNIQ, NOPATCH, NOARG, LOCAL, SOURCE);
          rc = scan (EXPECT_NONE);
        } else {
          SYNTAX (1007, name);
        }
      }
//
    }
    if (TOKEN ("(") && idf != NO_IDENT) {
      if (IS_ROW (idf->mode)) {
        ERROR (1008, "variable already dimensioned", F_NAME (idf));
      }
      get_dims (idf, 1);
      rc = scan (EXPECT_NONE);
      if (TOKEN ("*")) {
        NEW_RECORD (length);
        rc = scan (EXPECT_NONE);
        bufcpy (length, curlex, RECLN);
        if (TOKEN ("(")) {
// identifier*(length)
          rc = scan (EXPECT_NONE);
          bufcpy (length, curlex, RECLN);
          (void) scan (")");
        }
        if (rc == WORD) {
          IDENT *ldf = find_local (length, NO_MODE);
          if (ldf == NO_IDENT || ldf->parm == NO_TEXT) {
            SYNTAX (1009, length);
          } else if (ldf->mode.type != INTEGER) {
            EXPECT (1010, "integer");
          } else {
            NEW_RECORD (new);
            snprintf (new, RECLN, "%s*%s", base, ldf->parm);
            MODE mode_n;
            f2c_type (new, &mode_n, NOARG, NOFUN);
            norm_mode (&mode_n);
            idf->mode.type = mode_n.type;
            idf->mode.len = mode_n.len;
          }
          rc = scan (EXPECT_NONE);
        } else if (rc == INT_NUMBER || EQUAL (length, "*")) {
          NEW_RECORD (new);
          snprintf (new, RECLN, "%s*%s", base, length);
          MODE mode_n;
          f2c_type (new, &mode_n, NOARG, NOFUN);
          norm_mode (&mode_n);
          idf->mode.type = mode_n.type;
          idf->mode.len = mode_n.len;
          rc = scan (EXPECT_NONE);
        } else {
          SYNTAX (1011, name);
        }
      }
//
    } else if (TOKEN ("/") && idf != NO_IDENT) {
      get_init (idf, &mode);
      rc = scan (EXPECT_NONE);
      if (!TOKEN ("/")) {
        EXPECT (1012, "/");
      } 
      rc = scan (EXPECT_NONE);
    }
    if (TOKEN (",")) {
      rc = scan (EXPECT_NONE);
      if (! WITHIN) {
        SYNTAX (1013, NO_TEXT);
      }
    } else {
      if (rc != END_OF_LINE) {
        SYNTAX (1014, NO_TEXT);
        rc = scan (EXPECT_NONE);
      }
    }
  }
}

IDENT *extf_decl (char *name, MODE *mode)
{
  IDENT *idf = impl_decl (name, mode);
  if (idf->external) {
    ERROR (1015, "variable already set external", F_NAME (idf));
  } else if (idf->intrinsic) {
    ERROR (1016, "variable already set intrinsic", F_NAME (idf));
  } else {
    idf->external = TRUE;
  }
  return idf;
}

void get_decls (void)
{
  int_4 go_on = TRUE;
  idfs_reset ();
  while (go_on) {
    SAVE_POS (1);
    int_4 rc = scan (EXPECT_NONE);
    if (rc == DECLAR) {
      dec_local ();
      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) {
      parameter ();
      skip_card (FALSE);
    } else if (TOKEN ("common") && IS_NOT_ASSIGNMENT) {
      common ();
      skip_card (FALSE);
    } else if (TOKEN ("dimension") && IS_NOT_ASSIGNMENT) {
      dimension ();
      skip_card (FALSE);
    } else if (TOKEN ("equivalence") && IS_NOT_ASSIGNMENT) {
      skip_card (FALSE);
    } else if (TOKEN ("external") && IS_NOT_ASSIGNMENT) {
      externals ();
    } else if (TOKEN ("intrinsic") && IS_NOT_ASSIGNMENT) {
      intrinsics ();
    } else if (TOKEN ("data") && IS_NOT_ASSIGNMENT) {
      skip_card (FALSE);
    } else if (rc == WORD && IS_MACRO_DECLARATION) {
      skip_card (FALSE);
    } else if (strlen (curlex) > 0) {
// Backspace and done.
      RESTORE_POS (1);
      go_on = FALSE;
    }
  }
  idfs_impl ();
}
