//! @file rts-io.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
//!
//! Runtime support for Fortran IO.

#include <vif.h>

FTNFILE _ffile[MAX_FILES];

char *action_default = "action_default";
char *action_read = "action_read";
char *action_write = "action_write";
char *action_readwrite = "action_readwrite";
char *form_formatted = "form_formatted";
char *form_unformatted = "form_unformatted";
char *disp_new = "disp_new";
char *disp_old = "disp_old";
char *disp_delete = "disp_delete";
char *disp_keep = "disp_keep";

// Fortran IO

void _fcheck (char *where, int_4 unit, char *action, char *form)
{
  FTNFILE *_f = &_ffile[unit];
  NEW_RECORD (str);
  __scale__ = 1;
  if (unit < 0 || unit >= MAX_FILES) {
    _srecordf (str, "unit number %d is not valid", unit);
    RTE (where, str);
  }
  if (action == NO_TEXT) {
// CLOSE, REWIND
    return;
  }
  if (_f->unit == NO_FILE) {
// File was not opened yet.
    NEW_RECORD (mode);
    NEW_RECORD (disp);
    if (_f->disp != NO_TEXT) {
      RECCPY (disp, _f->disp);
    } else {
      RECCPY (disp, disp_old);
    }
    if (_f->action == action_default) {
      _f->action = action;
    } else if (_f->action == action_readwrite) {
      action = action_readwrite;
    } else if (_f->action != action) {
      _srecordf (str, "inconsistent action: %s", action);
      RTE (where, str);
    }
    if (_f->form == NO_TEXT) {
      _f->form = form;
    } else if (_f->form != form) {
      _srecordf (str, "inconsistent formatting: %s", form);
      RTE (where, str);
    }
    RECCPY (mode, "UNKNOWN");
    if (form == form_formatted && action == action_read) {
      RECCPY (mode, "r");
    } else if (form == form_formatted && action == action_write) {
      RECCPY (mode, "w");
    } else if (form == form_formatted && action == action_readwrite) {
      if (EQUAL (disp, "disp_old")) {
        RECCPY (mode, "r+");
      } else if (EQUAL (disp, "disp_new")) {
        RECCPY (mode, "w+");
      }
    } else if (form == form_unformatted && action == action_read) {
      RECCPY (mode, "rb");
    } else if (form == form_unformatted && action == action_write) {
      RECCPY (mode, "wb");
    } else if (form == form_unformatted && action == action_readwrite) {
      if (EQUAL (disp, "disp_old")) {
        RECCPY (mode, "r+b");
      } else if (EQUAL (disp, "disp_new")) {
        RECCPY (mode, "w+b");
      }
    } else {
      _srecordf (str, "error: form=%s, action=%s, disp=%s", form, action, disp);
      RTE (where, str);
    }
    if (_f->in_stream) {
      if ((_f->unit = fmemopen (_f->buff, strlen (_f->buff) + 1, mode)) == NO_FILE) {
        _srecordf (str, "cannot open unit %d: form=%s, action=%s, disp=%s", unit, form, action, disp);
        RTE (where, str);
      }
    } else {
      if ((_f->unit = fopen (_f->name, mode)) == NO_FILE) {
        _srecordf (str, "cannot open unit %d: form=%s, action=%s, disp=%s", unit, form, action, disp);
        RTE (where, str);
      }
    }
    _rewind (where, unit);
  } else {
// File was opened.
    if (action == action_read) {
      if (unit == 0 && _f->record >= _f->records) {
        _srecordf (str, "unit %d: reading past end-of-file", unit);
        RTE (where, str);
      }
      if (_f->action == action_write) {
        _srecordf (str, "unit %d: not open for 'read'", unit);
        RTE (where, str);
      }
    } else if (action == action_write) {
      if (_f->action == action_read) {
        _srecordf (str, "unit %d: not open for 'write'", unit);
        RTE (where, str);
      }
    }
    if (_f->form != form) {
      if (form == form_formatted) {
        _srecordf (str, "unit %d: not open for formatted IO", unit);
      } else {
        _srecordf (str, "unit %d: not open for unformatted IO", unit);
      }
      RTE (where, str);
    }
  }
}

void _fregister (char *where, int_4 unit, int_4 lrecl, char *fn, char *form, char *action, char *disp)
{
  FTNFILE *_f = &_ffile[unit];
  if (unit >= 0 && unit < MAX_FILES) {
    int_4 len;
    if (_f->unit != NO_FILE) {
      NEW_RECORD (err);
      _srecordf (err, "'unit %d' already open", unit);
      RTE (where, err);
    }
    if (lrecl <= 0 || lrecl > MAX_LRECL) {
      lrecl = MAX_LRECL;
    }
    _ffile[unit] = (FTNFILE) {
    .form = form,.action = action,.disp = disp,.lrecl = lrecl};
    _f->buff = (char *) f_malloc (lrecl + 1);
    if (_f->in_stream) {
      _f->buff_init = TRUE;
      _f->action = action_read;
    } else {
      _f->buff_init = FALSE;
    }
    _f->buff_pos = 0;
    if (fn == NO_TEXT) {
      NEW_RECORD (buf);
      _f->vers++;
      _srecordf (buf, "ft%02df%03d", unit, _f->vers);
      len = strlen (buf) + 1;
      _f->name = (char *) f_malloc (len);
      strcpy (_f->name, buf);
    } else {
      len = strlen (fn) + 1;
      _f->name = (char *) f_malloc (len);
      strcpy (_f->name, fn);
    }
  } else {
    RTE (where, "unit out of range");
  }
}

void _funregister (char *where, int_4 unit)
{
  FTNFILE *_f = &_ffile[unit];
  if (unit >= 0 && unit < MAX_FILES) {
    if (_f->unit != NO_FILE) {
      _fclose (unit);
    }
    if (_f->disp == disp_delete) {
      remove (_f->name);
    }
    if (_f->name != NO_TEXT) {
      free (_f->name);
    }
    if (_f->buff != NO_TEXT) {
      free (_f->buff);
    }
    *_f = (FTNFILE) {
    .unit = NO_FILE,.name = NO_TEXT,.form = NO_TEXT,.action = NO_TEXT,.disp = NO_TEXT,.vers = 0,.buff = NO_TEXT,.buff_init = FALSE,.buff_pos = 0,.buff_len = 0};
  } else {
    RTE (where, "unit out of range");
  }
}

void _skip_eol (FILE * f)
{
  while (fgetc (f) != '\n');
}

void _ioerr (char *where, int_4 unit)
{
  NEW_RECORD (err);
  _srecordf (err, "'unit %d': IO error", unit);
  RTE (where, err);
}

void _ioerr_write (char *where, int_4 unit)
{
  NEW_RECORD (err);
  _srecordf (err, "'unit %d': IO error while writing", unit);
  RTE (where, err);
}

void _ioerr_read (char *where, int_4 unit)
{
  NEW_RECORD (err);
  _srecordf (err, "'unit %d': IO error while reading", unit);
  RTE (where, err);
}

void _ioend_read (char *where, int_4 unit)
{
  NEW_RECORD (err);
  _srecordf (err, "'unit %d': end of file while reading", unit);
  RTE (where, err);
}

int_4 _init_file_buffer (int_4 unit)
{
  FTNFILE *_f = &_ffile[unit];
  if (unit == 0) {
    if (_f->record < _f->records) {
      // String lengths are powers of 2 in VIF.
      int_4 len = 1;
      while (len <= _f->lrecl) {
        len *= 2;
      }
      _f->buff = &((_ffile[0].rewind)[_f->record * len]);
      _f->buff_init = TRUE;
      _f->buff_pos = 0;
      _f->buff_len = strlen (_f->buff);
      _f->record++;
      return 0;
    } else {
      _f->buff = NO_TEXT;
      _f->buff_init = FALSE;
      _f->buff_pos = 0;
      _f->buff_len = 0;
      return 1;
    }
  } else {
    if (_f->in_stream) {
      if (_f->record > 1) {
        char *q = _f->buff;
        while (q[0] != '\n') {
          q++;
        }
        _f->buff = &q[1];
      }
    } else {
      (void) fgets (_f->buff, _f->lrecl, _f->unit);
    }
    _f->buff_len = strlen (_f->buff);
    if (_f->buff[_f->buff_len - 1] == '\n') {
      _f->buff[_f->buff_len - 1] = '\0';
      _f->buff_len--;
    }
    _f->buff_init = TRUE;
    _f->buff_pos = 0;
    _f->record++;
    return 0;
  }
}

int_4 _rewind (char *where, int_4 unit)
{
  FTNFILE *_f = &_ffile[unit];
  if (unit == 0) {
    _f->record = 0;
    _init_file_buffer (0);
  } else if (_f != NO_FTNFILE) {
    if (_f->in_stream) {
      _f->buff = _f->rewind;
    } else {
      rewind (_f->unit);
    }
    _f->buff_pos = 0;
    _f->record = 1;
  } 
  if (_f == NO_FTNFILE || errno != 0) {
    RECORD buf;
    _srecordf (buf, "cannot rewind unit %d", unit);
    RTE (where, buf);
  }
  return 0;
}

int_4 _set_record (char *where, int_4 unit, int_4 rec)
{
  FTNFILE *_f = &_ffile[unit];
  if (unit == 0) {
    _f->record = rec - 1;
    _init_file_buffer (0);
  } else if (_f != NO_FTNFILE) {
    _rewind (where, unit);
    _init_file_buffer (unit);
    for (int_4 k = 1; k < rec; k++) {
      _init_file_buffer (unit);
    }
  }
  if (_f == NO_FTNFILE || errno != 0) {
    RECORD buf;
    _srecordf (buf, "cannot set record on unit %d", unit);
    RTE (where, buf);
  }
  return 0;
}

int_4 _backspace (char *where, int_4 unit)
{
  FTNFILE *_f = &_ffile[unit];
  _set_record (where, unit, _f->record - 1);
  if (_f == NO_FTNFILE || errno != 0) {
    RECORD buf;
    _srecordf (buf, "cannot backspace unit %d", unit);
    RTE (where, buf);
  }
  return 0;
}
