//! @file common.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 COMMON.

#include <vif.h>

void merge_commons (void)
{
  int_4 k, g;
  for (k = 0; k < nlocals; k++) {
    IDENT *idf = &locals[k];
    int_4 found = FALSE;
    if (NOT_LOCAL (idf) && idf->common != EXTERN) {
      for (g = 0; g < nglobals && !found; g++) {
        IDENT *idg = &globals[g];
        if (idf->common == idg->common && EQUAL (C_NAME (idf), C_NAME (idg))) {
          int_4 same = TRUE;
          found = TRUE;
          same &= (idf->mode.type == idg->mode.type);
          same &= (idf->mode.len == idg->mode.len);
          same &= (idf->mode.dim == idg->mode.dim);
          if (same) {
            int_4 n;
            for (n = 0; n < idf->mode.dim; n++) {
              same &= (EQUAL (idf->lwb[n], idg->lwb[n]));
              same &= (EQUAL (idf->upb[n], idg->upb[n]));
            }
          }
          if (!same) {
            NEW_RECORD (where);
            _srecordf (where, "%s in block %s", F_NAME (idg), commons[idg->common]);
            ERROR (701, "common block consistency", where);
          }
        }
      }
      if (!found) {
        if (nglobals >= MAX_IDENTS) {
          ERROR (702, "too many common identifiers", NO_TEXT);
          return;
        }
// Copy-paste into global name space.
        IDENT *idn = &globals[nglobals++];
        memcpy (idn, idf, sizeof (IDENT));
      }
    }
  }
}

void common (void)
{
  int_4 cblck = LOCAL, rc;
  rc = scan (EXPECT_NONE);
  if (!TOKEN ("/")) {
    cblck = add_block ("_common");
  }
  while (WITHIN) {
    if (TOKEN (",")) {
      rc = scan (EXPECT_NONE);
      if (!WITHIN) {
        SYNTAX (703, "common block");
      }
    } else if (TOKEN ("/")) {
      rc = scan (EXPECT_NONE);
      if (rc != WORD) {
        SYNTAX (704, "common block name");
      } else {
        cblck = add_block (curlex);
      }
      rc = scan ("/");
      rc = scan (EXPECT_NONE);
    } else if (rc == WORD) {
      if (/* reserved (curlex) */ FALSE) {
        ERROR (705, "reserved symbol", curlex);
      }
      MODE mode;
      IDENT *idf = void_decl (curlex, &mode);
      if (idf != NO_IDENT) {
        idf->common = cblck;
      }
      rc = scan (EXPECT_NONE);
      if (TOKEN ("(") && idf != NO_IDENT) {
        if (IS_ROW (idf->mode)) {
          ERROR (706, "already dimensioned", F_NAME (idf));
        }
        get_dims (idf, 1);
        rc = scan (EXPECT_NONE);
      }
    } else {
      SYNTAX (707, "common block");
      rc = scan (EXPECT_NONE);
    }
  }
}

void get_common (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) {
      common ();
      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) {
      skip_card (FALSE);
    } else if (strlen (curlex) > 0) {
// Backspace and done.
      RESTORE_POS (1);
      go_on = FALSE;
    }
  }
}
