//! @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 formatted IO.

#include <vif.h>
#include <rts-real32.h>

#define SIGN(z) ((z) == 0 ? 0 : ((z) > 0 ? 1 : 0))
#define ERROR_CHAR '*'
#define POINT_CHAR '.'

void xsprintfmt (char *, const char *, ...);

// __scale__ is set by nP in formats.

int_4 __scale__ = 1;

void _fclose (int_4 k)
{
  if (_ffile[k].unit != NO_FILE) {
    (void) fclose (_ffile[k].unit);
    _ffile[k].unit = NO_FILE;
  }
}

static char *plusab (char *buf, char c)
{
  char z[2];
  z[0] = c;
  z[1] = '\0';
  bufcat (buf, z, RECLN);
  return buf;
}

static char *plusto (char ch, char *buf)
{
  memmove (&buf[1], &buf[0], strlen(buf) + 1);
  buf[0] = ch;
  return buf;
}

static char *unsign (char *buf)
{
  if (buf[0] == ' ') {
    char *q = buf;
    while (q[0] != '\0') {
      q[0] = q[1];
      q++;
    }
  }
  return buf;
}

static char *leading_spaces (char *buf, int_4 width)
{
  if (width > 0) {
    int_4 j = ABS (width) - (int_4) strlen (buf);
    while (--j >= 0) {
      (void) plusto (' ', buf);
    }
  }
  return buf;
}

static char *error_chars (char *buf, int_4 n)
{
  int_4 k = (n != 0 ? ABS (n) : 1);
  buf[k] = '\0';
  while (--k >= 0) {
    buf[k] = ERROR_CHAR;
  }
  return buf;
}

static char digchar (int_4 k)
{
  char *tab = "0123456789abcdefghijklmnopqrstuvwxyz";
  if (k >= 0 && k < (int_4) strlen (tab)) {
    return tab[k];
  } else {
    return ERROR_CHAR;
  }
}

// INTEGER*8

char *intnot (char *buf, int_8 k, int_4 width)
{
  int_8 n = ABS (k);
  buf[0] = '\0';
  do {
    (void) plusto (digchar (n % 10), buf);
    n /= 10;
  } while (n != 0);
  if (k < 0) {
    (void) plusto ('-', buf);
  }
  if (width > 0 && strlen (buf) > width) {
    (void) error_chars (buf, width);
  } else {
    (void) leading_spaces (buf, width);
  }
  return buf;
}

// REAL*32

void xsprintfmt (char *buffer, const char *fmt, ...)
{
  NEW_RECORD (ibuff);
  va_list ap;
  va_start (ap, fmt);
  vsprintf (ibuff, fmt, ap);
  va_end (ap);
  strcat (buffer, ibuff);
}

static int_4 special_value (char *s, real_32 u, int_4 sign)
{
  if ((xis_pinf (&u))) {
    if (sign != 0) {
      *s++ = '+';
    }
    strcpy (s, "Inf");
    return 1;
  } else if ((xis_minf (&u))) {
    strcpy (s, "-Inf");
    return 1;
  } else if ((xis_nan (&u))) {
    if (sign != 0) {
      *s++ = '\?';
    }
    strcpy (s, "NaN");
    return 1;
  } else {
    return 0;
  }
}

char *xsubfixed (char *buffer, real_32 v, logical_4 sign, int_4 digs)
{
  RECCLR (buffer);
  if ((special_value (buffer, v, sign))) {
    return buffer;
  }
  real_32 u = v;
  digs = _min (_abs (digs), FLT256_DIG);
// Put sign and take abs value.
  char *p = buffer;
  if (xlt (u, X_0)) {
    u = xneg (u);
    *(p++) = '-';
  } else if (sign) {
    *(p++) = '+';
  } else {
    *(p++) = ' ';
  }
// Round fraction
  real_32 eps = xmul(X_1_OVER_2, xtenup (-digs));
  u = xsum (u, eps);
//
  int_4 before;
  if (xlt (u, X_10)) {
    before = 1;
  } else if (xlt (u, X_100)) {
    before = 2;
  } else if (xlt (u, X_1000)) {
    before = 3;
  } else {
    before = (int_4) ceil (xtodbl (xlog10 (u)));
  }
//  Integral part.
  u = xdiv (u, xtenup (before));
  while (xge (u, X_1)) {
    u = xdiv (u, X_10);
    before++;
  }
  for (int_4 k = 0; k < before; ++k) {
    u = xmul (X_10, u);
    int_4 dig;
    u = xsfmod (u, &dig);
    *(p++) = (char) '0' + dig;
  }
// Fraction.
  *(p++) = '.';
  for (int_4 k = 0; k < digs; ++k) {
    u = xmul (X_10, u);
    int_4 dig;
    u = xsfmod (u, &dig);
    *(p++) = (char) '0' + dig;
  }
  return buffer;
}

char *xfixed (char *buf, real_32 x, int_4 width, int_4 digs, int_4 precision)
{
  width = _abs (width);
  digs = _min (abs (digs), precision);
  xsubfixed (buf, x, FALSE, digs);
  unsign (buf);
  if (width > 0 && strlen (buf) > width) {
    return error_chars (buf, width);
  } else {
    return leading_spaces (buf, width);
  }
}

char *xfloat (char *buf, real_32 z, int_4 width, int_4 digs, int_4 expos, int_4 mult, int_4 precision, char sym)
{
  buf[0] = '\0';
  width = _abs (width);
  digs = _min (abs (digs), precision);
  expos = _abs (expos);
  if (expos > 5) {
    return error_chars (buf, width);
  }
// Scientific notation mult = 1, Engineering notation mult = 3
  mult = _max (1, mult);
// Default __scale__ is 1.
  int_4 q = 1;
  char *max = "1";
  real_32 x = xabs (z), lwb, upb;
//
  if (__scale__ < 0 || __scale__ > 3) {
    __scale__ = 1;
  }
  if (mult == 1) {
    if (__scale__ == 0) {
      lwb = X_1_OVER_10;
      upb = X_1;
      q = 1;
      max = "0.1";
    } else if (__scale__ == 1) {
      lwb = X_1;
      upb = X_10;
      q = 0;
      max = "1";
    } else if (__scale__ == 2) {
      lwb = X_10;
      upb = X_100;
      q = -1;
      max = "10";
    } else if (__scale__ == 3) {
      lwb = X_100;
      upb = X_1000;
      max = "100";
      q = -2;
    }
  }
// Standardize.
  int_4 p = 0;
  if (xnot0 (&x)) {
    p = (int_4) round (xtodbl (xlog10 (xabs(x)))) + q;
    x = xdiv (x, xtenup (p));
    if (xle (x, lwb)) {
      x = xmul (x, X_10);
      p--;
    } 
    if (xge (x, upb)) {
      x = xdiv (x, X_10);
      p++;
    } 
    while (p % mult != 0) {
      x = xmul (x, X_10);
      p--;
    }
  }
// Form number.
  NEW_RECORD (mant);
  xsubfixed (mant, x, FALSE, digs);
// Correction of rounding issue by which |mant| equals UPB.
  if (strchr (mant, ERROR_CHAR) == NO_TEXT && xge (xabs (strtox (mant, NO_REF_TEXT)), upb)) {
    if (mant[0] == ' ' || mant[0] == '+') {
      _srecordf (mant, "%c%s", mant[0], max);
    } else {
      _srecordf (mant, "%s", max);
    }
    if (digs > 0) {
      plusab (mant, '.');
      for (int_4 k = 0; k < digs; k++) {
        plusab (mant, '0');
      }
    }
    p++;
  }
//
  NEW_RECORD (fmt);
  if (xsgn (&z) < 0) {
    mant[0] = '-';
  }
  _srecordf (fmt, "%%s%c%%+0%dd", sym, expos);
  _srecordf (buf, fmt, mant, p);
  unsign (buf);
  if (width > 0 && (strchr (buf, ERROR_CHAR) != NO_TEXT || strlen (buf) > width)) {
    if (digs > 0) {
      return xfloat (buf, z, width, digs - 1, expos, mult, precision, sym);
    } else {
      return error_chars (buf, width);
    }
  } else {
    return leading_spaces (buf, width);
  }
}

void _fprintf_int_8 (char *str, char *fmt, int_8 elem)
{
  int_4 len = 0;
  if (fmt[0] == '%') {
    fmt++;
  }
  if (isdigit (fmt[0])) {
    len = strtol (fmt, NO_REF_TEXT, 10);
  }
  intnot (str, elem, len);
}

void _fprintf_real_32 (char *buf, char *fmt, real_32 item, int_4 expw, int_4 precision)
{
  int_4 dec = 0, len = 0, expos = 0;
  if (fmt[0] == '%') {
    fmt++;
  }
  char expo_char = fmt[strlen (fmt) - 1];
  if (expo_char == 'n') {
    expo_char = 'e';
  } else if (expo_char == 'N') {
    expo_char = 'E';
  }
  char *p1, *p2, *expo;
  if (fmt[0] == '.') {
    fmt++;
    dec = strtol (fmt, &p2, 10);
  } else {
    len = strtol (fmt, &p1, 10);
    dec = strtol (&p1[1], &p2, 10);
  }
  if (tolower (expo_char) == 'e') {
    int_4 ee = strtol (&p2[1], &expo, 10);
    expos = (ee == 0 ? expw : ee);
  }
  if (tolower (expo_char) == 'f') {
    xfixed (buf, item, len, dec, precision);
  } else if (tolower (expo[0]) == 'n') {
    xfloat (buf, item, len, dec, expos, 3, precision, expo_char);
  } else {
    xfloat (buf, item, len, dec, expos, 1, precision, expo_char);
  }
  return;
}

int_4 _vif_printf (int_4 unit, char *fmt, void *elem, int_4 type, int_4 len)
{
  FTNFILE *_f = &_ffile[unit];
  if (fmt == NO_TEXT) {
    return ERR;
  }
  if (fmt == FMT_TERM) {
    return 1;
  }
  if (strlen (fmt) == 0) {
    return 1;
  }
  if (strcmp (fmt, "\n") == 0) {
    fprintf (_f->unit, "\n");
    return 1;
  }
  if (fmt != NO_TEXT && type == NOTYPE) {
    if (strcmp (fmt, "0") == 0) {
      __scale__ = 0;
    } else if (strcmp (fmt, "1") == 0) {
      __scale__ = 1;
    } else if (strcmp (fmt, "2") == 0) {
      __scale__ = 2;
    } else if (strcmp (fmt, "3") == 0) {
      __scale__ = 3;
    } else {
      fprintf (_f->unit, fmt);
    }
    return 1;
  }
// 
  char mod = tolower (fmt[strlen (fmt) - 1]);
  if (mod == 's') {
    if (type == NOTYPE) {
      fprintf (_f->unit, fmt);
      return 1;
    } else if (type == CHARACTER) {
      fprintf (_f->unit, fmt, (char *) elem);
      return 1;
    } else if (type == LOGICAL) {
      fprintf (_f->unit, fmt, (*(int_4 *) elem ? 't' : 'f'));
      return 1;
    } else if (type == INTEGER && len == 4) {
      int_4 awid = len, width;
      if (sscanf (fmt, "%%%ds", &width) == 1) {
        awid = _abs (width);
      }
      int_4 sum = *(int_4 *) elem;
      for (int_4 k = 0; k < len && k < awid; k++) {
        char ch = sum % (UCHAR_MAX + 1);
        fprintf (_f->unit, "%c", ch);
        sum /= (UCHAR_MAX + 1); 
      }
      return 1;
    } else if (type == REAL && len == 8) {
      int_4 awid = len, width;
      if (sscanf (fmt, "%%%ds", &width) == 1) {
        awid = _abs (width);
      }
      real_8 sum = *(real_8 *) elem;
      for (int_4 k = 0; k < len && k < awid; k++) {
        char ch = (int_4) fmod (sum, (UCHAR_MAX + 1));
        fprintf (_f->unit, "%c", ch);
        sum = floor (sum / (UCHAR_MAX + 1)); 
      }
      return 1;
    } else {
      return ERR;
    }
  } else if (mod == 'c') {
    if (type == LOGICAL) {
      fprintf (_f->unit, fmt, (*(int_4 *) elem ? 't' : 'f'));
    } else {
      return ERR;
    }
    return 1;
  } else if (mod == 'd') {
// INTEGER
    if (type == INTEGER && len == 2) {
      NEW_RECORD (buf);
      _fprintf_int_8 (buf, fmt, (int_8) *(int_2 *) elem);
      fprintf (_f->unit, "%s", buf);
    } else if (type == INTEGER && len == 4) {
      NEW_RECORD (buf);
      _fprintf_int_8 (buf, fmt, (int_8) *(int_4 *) elem);
      fprintf (_f->unit, "%s", buf);
    } else if (type == INTEGER && len == 8) {
      NEW_RECORD (buf);
      _fprintf_int_8 (buf, fmt, (int_8) *(int_8 *) elem);
      fprintf (_f->unit, "%s", buf);
    } else if (type == INTEGER && len == 16) {
      NEW_RECORD (buf);
      _fprintf_int_8 (buf, fmt, (int_8) *(int_8 *) elem);
      fprintf (_f->unit, "%s", buf);
    } else {
      return ERR;
    }
    return 1;
  } else if (mod == 'e' || mod == 'n' || mod == 'f') {
// REAL and COMPLEX
    NEW_RECORD (buf);
    if (type == INTEGER && len == 2) {
      _fprintf_real_32 (buf, fmt, flttox ((real_4) *(int_2 *) elem), 4, FLT_DIG);
      fprintf (_f->unit, "%s", buf);
    } else if (type == INTEGER && len == 4) {
      _fprintf_real_32 (buf, fmt, dbltox ((real_8) *(int_4 *) elem), 4, FLT_DIG);
      fprintf (_f->unit, "%s", buf);
    } else if (type == INTEGER && len == 8) {
      _fprintf_real_32 (buf, fmt, dbltox ((real_8) *(int_8 *) elem), 4, FLT_DIG);
      fprintf (_f->unit, "%s", buf);
    } else if (type == REAL && len == 4) {
      _fprintf_real_32 (buf, fmt, flttox (*(real_4 *) elem), 4, FLT_DIG);
      fprintf (_f->unit, "%s", buf);
    } else if (type == REAL && len == 8) {
      _fprintf_real_32 (buf, fmt, dbltox (*(real_8 *) elem), 4, DBL_DIG);
      fprintf (_f->unit, "%s", buf);
    } else if (type == REAL && len == 16) {
      _fprintf_real_32 (buf, fmt, quadtox (*(real_16 *) elem), 5, FLT128_DIG);
      fprintf (_f->unit, "%s", buf);
    } else if (type == REAL && len == 32) {
      _fprintf_real_32 (buf, fmt, *(real_32 *) elem, 5, FLT256_DIG);
      fprintf (_f->unit, "%s", buf);
    } else if (type == COMPLEX && len == 8) {
      real_4 z = crealf (*(complex_8 *) elem);
      _vif_printf (unit, fmt, &z, REAL, 4);
    } else if (type == COMPLEX && len == -8) {
      real_4 z = cimagf (*(complex_8 *) elem);
      _vif_printf (unit, fmt, &z, REAL, 4);
    } else if (type == COMPLEX && len == 16) {
      real_8 z = creal (*(complex_16 *) elem);
      _vif_printf (unit, fmt, &z, REAL, 8);
    } else if (type == COMPLEX && len == -16) {
      real_8 z = cimag (*(complex_16 *) elem);
      _vif_printf (unit, fmt, &z, REAL, 8);
    } else if (type == COMPLEX && len == 32) {
      real_16 z = crealq (*(complex_32 *) elem);
      _vif_printf (unit, fmt, &z, REAL, 16);
    } else if (type == COMPLEX && len == -32) {
      real_16 z = cimagq (*(complex_32 *) elem);
      _vif_printf (unit, fmt, &z, REAL, 16);
    } else if (type == COMPLEX && len == 64) {
      real_32 z = cxreal (*(complex_64 *) elem);
      _vif_printf (unit, fmt, &z, REAL, 32);
    } else if (type == COMPLEX && len == -64) {
      real_32 z = cximag (*(complex_64 *) elem);
      _vif_printf (unit, fmt, &z, REAL, 32);
    } else {
      return ERR;
    }
    return 1;
  }
  return ERR;
}

void _fscanf_real (char *str, FTNFILE * _f, int_4 width, int_4 buflen)
{
  while (_f->buff_pos < buflen && _f->buff[_f->buff_pos] == ' ') {
    _f->buff_pos++;
  }
  for (int_4 k = 0; k < width && _f->buff_pos < buflen && _f->buff[_f->buff_pos] != ' '; k++) {
    str[k] = _f->buff[_f->buff_pos++];
    str[k + 1] = '\0';
  }
}

int_4 _vif_scanf (int_4 unit, char *fmt, void *elem, int_4 type, int_4 len)
{
  int_4 width = 0, rc = 0, N = 0;
  FTNFILE *_f = &_ffile[unit];
// A NOP.
  if (fmt == FMT_TERM) {
    return 1;
  }
// Re-init on next call.
  if (fmt == NO_TEXT) {
    _f->buff_init = FALSE;
    return 1;
  }
  if (strlen (fmt) == 0) {
    return 1;
  }
// (Re)init if needed.
  if (!_f->buff_init) {
    _init_file_buffer (unit);
  } 
  if (strcmp (fmt, "\n") == 0) {
// Reading newline just reinits the buffer.
    _init_file_buffer (unit);
    return 1;
  }
// Textual strings are skipped and not checked.
  if (fmt != NO_TEXT && type == NOTYPE) {
    int_4 awid = strlen (fmt);
    if (_f->buff_pos + awid < _f->buff_len) {
      _f->buff_pos += awid;
    }
    return 1;
  }
// Fortran items A, D, E, F, I and Q.
  char mod = fmt[strlen (fmt) - 1];
  if (mod == 's' && sscanf (fmt, "%%%ds", &width) == 1) {
    int_4 awid = _abs (width);
    if (type == NOTYPE || elem == NO_TEXT) {
      if (_f->buff_pos + awid > _f->buff_len) {
        return ERR;
      }
      _f->buff_pos += awid;     // Just skip it. Fortran would check.
      return 1;
    }
    if (type == CHARACTER) {
      char *str = (char *) elem;
      for (int_4 k = 0; k < awid && _f->buff_pos < _f->buff_len; k++) {
        str[k] = _f->buff[_f->buff_pos++];
      }
// In VIF trailing space is cut.
      for (int_4 k = strlen (str) - 1; k > 0 && str[k] == ' '; k--) {
        str[k] = '\0';
      }
      return 1;
    } else if (type == INTEGER && len == 4) {
      NEW_RECORD (str);
      int_4 k;
      for (k = 0; k < awid && _f->buff_pos < _f->buff_len; k++) {
        str[k] = _f->buff[_f->buff_pos++];
      }
      str[k] = '\0';
      *(int_4 *) elem = _str_to_int4 (str);
      return 1;
    } else if (type == REAL && len == 8) {
      NEW_RECORD (str);
      int_4 k;
      for (k = 0; k < awid && _f->buff_pos < _f->buff_len; k++) {
        str[k] = _f->buff[_f->buff_pos++];
      }
      str[k] = '\0';
      *(real_8 *) elem = _str_to_real8 (str);
      return 1;
    }
    return 0;
  }
  if (mod == 'c' && strcmp (fmt, "%c") == 0) {
    NEW_RECORD (nfmt);
    if (len == 4) {
      char ch;
      _srecordf (nfmt, "%%c%%n");
      rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (char *) &ch, &N);
      *(logical_4 *) elem = (ch == 't');
    }
    _f->buff_pos += N;
    return rc;
  }
  if (mod == 'd' && strcmp (fmt, "%d") == 0) {
    NEW_RECORD (nfmt);
    if (len == 2) {
      int_4 i;
      _srecordf (nfmt, "%%d%%n");
      rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (int_4 *) &i, &N);
      *(int_2 *) elem = i;
    } else if (len == 4) {
      _srecordf (nfmt, "%%d%%n");
      rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (int_4 *) elem, &N);
    } else if (len == 8) {
      _srecordf (nfmt, "%%lld%%nn");
      rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (int_8 *) elem, &N);
    }
    _f->buff_pos += N;
    return rc;
  }
  if (mod == 'd' && type == INTEGER && sscanf (fmt, "%%%dd", &width) == 1) {
    NEW_RECORD (nfmt);
    int_4 awid = _abs (width);
    if (_f->buff_pos + awid > _f->buff_len) {
      return ERR;
    }
// Vintage Fortran reads blanks as zero.
    char *q = &_f->buff[_f->buff_pos];
    int_4 k = width - 1;
    while (k >= 0) {
      if (q[k] == ' ') {
        q[k] = '0';
      } else if (!isdigit(q[k])) {
        break;
      }
      k--;
    }
//
    if (len == 2) {
      int_4 i;
      _srecordf (nfmt, "%%%dd", width);
      rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (int_4 *) &i);
      *(int_2 *) elem = i;
    } else if (len == 4) {
      _srecordf (nfmt, "%%%dd", width);
      rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (int_4 *) elem);
    } else if (len == 8) {
      _srecordf (nfmt, "%%%dlld", width);
      rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (int_8 *) elem);
    }
    _f->buff_pos += awid;
    return rc;
  }
// REAL, standard format
  if (type == REAL && strcmp (fmt, "%e") == 0) {
    if (len == 4) {
      NEW_RECORD (nfmt);
      _srecordf (nfmt, "%%e%%n");
      rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (real_4 *) elem, &N);
      _f->buff_pos += N;
      return rc;
    } else if (len == 8) {
      NEW_RECORD (nfmt);
      _srecordf (nfmt, "%%le%%n");
      rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (real_8 *) elem, &N);
      _f->buff_pos += N;
      return rc;
    } else if (len == 16) {
      NEW_RECORD (str);
      _fscanf_real (str, _f, RECLN - 1, _f->buff_len);
      *(real_16 *) (elem) = _strtoquad (str, NO_REF_TEXT);
      return 1;
    } else if (len == 32) {
      NEW_RECORD (str);
      _fscanf_real (str, _f, RECLN - 1, _f->buff_len);
      *(real_32 *) (elem) = strtox (str, NO_REF_TEXT);
      return 1;
    }
  }
// REAL, format, note that only width can be specified.
  if ((mod == 'e' || mod == 'f') && type == REAL && sscanf (fmt, "%%%d", &width) == 1) {
    int_4 awid = _abs (width);
    if (_f->buff_pos + awid > _f->buff_len) {
      return ERR;
    }
    if (len == 4) {
      rc = sscanf (&_f->buff[_f->buff_pos], fmt, (real_4 *) elem);
      _f->buff_pos += width;
    } else if (len == 8) {
      NEW_RECORD (nfmt);
      _srecordf (nfmt, "%%%dl%c", width, mod);
      rc = sscanf (&_f->buff[_f->buff_pos], nfmt, (real_8 *) elem);
      _f->buff_pos += width;
    } else if (len == 16) {
      NEW_RECORD (str);
      _fscanf_real (str, _f, (awid > RECLN - 1 ? RECLN - 1 : awid), _f->buff_len);
      *(real_16 *) (elem) = _strtoquad (str, NO_REF_TEXT);
      return 1;
    } else if (len == 32) {
      NEW_RECORD (str);
      _fscanf_real (str, _f, (awid > RECLN - 1 ? RECLN - 1 : awid), _f->buff_len);
      *(real_32 *) (elem) = strtox (str, NO_REF_TEXT);
      return 1;
    }
    return rc;
  }
// COMPLEX, standard
  if (mod == 'e' && type == COMPLEX && strcmp (fmt, "%e") == 0) {
    if (_abs (len) == 8) {
      NEW_RECORD (nfmt);
      real_4 x;
      complex_8 *z = (complex_8 *) elem;
      _srecordf (nfmt, "%%e%%n");
      rc = sscanf (&_f->buff[_f->buff_pos], nfmt, &x, &N);
      _f->buff_pos += N;
      if (len > 0) {
        *z = CMPLXF (x, 0);
      } else {
        *z = CMPLXF (crealf (*z), x);
      }
      return rc;
    } else if (_abs (len) == 16) {
      NEW_RECORD (nfmt);
      real_8 x;
      complex_16 *z = (complex_16 *) elem;
      _srecordf (nfmt, "%%le%%n");
      rc = sscanf (&_f->buff[_f->buff_pos], nfmt, &x, &N);
      _f->buff_pos += N;
      if (len > 0) {
        *z = CMPLX (x, 0);
      } else {
        *z = CMPLX (creal (*z), x);
      }
      return rc;
    } else if (_abs (len) == 32) {
      NEW_RECORD (str);
      complex_32 *z = (complex_32 *) elem;
      _fscanf_real (str, _f, RECLN - 1, _f->buff_len);
      if (len > 0) {
        *z = CMPLXQ (_strtoquad (str, NO_REF_TEXT), 0.0q);
      } else {
        *z = CMPLXQ (crealq (*z), _strtoquad (str, NO_REF_TEXT));
      }
      return 1;
    } else if (_abs (len) == 64) {
      NEW_RECORD (str);
      complex_64 *z = (complex_64 *) elem;
      _fscanf_real (str, _f, RECLN - 1, _f->buff_len);
      if (len > 0) {
        z->re = strtox (str, NO_REF_TEXT);
      } else {
        z->im = strtox (str, NO_REF_TEXT);
      }
      return 1;
    }
  }
// COMPLEX, format, note that only width can be specified.
  if ((mod == 'e' || mod == 'f') && type == COMPLEX && sscanf (fmt, "%%%de", &width) == 1) {
    int_4 awid = _abs (width);
    if (_f->buff_pos + awid > _f->buff_len) {
      return ERR;
    }
    if (_abs (len) == 8) {
      real_4 x;
      complex_8 *z = (complex_8 *) elem;
      rc = sscanf (&_f->buff[_f->buff_pos], fmt, &x);
      _f->buff_pos += width;
      if (len > 0) {
        *z = CMPLXF (x, 0);
      } else {
        *z = CMPLXF (crealf (*z), x);
      }
      return rc;
    } else if (_abs (len) == 16) {
      real_8 x;
      complex_16 *z = (complex_16 *) elem;
      NEW_RECORD (nfmt);
      _srecordf (nfmt, "%%%dl%c", width, mod);
      rc = sscanf (&_f->buff[_f->buff_pos], nfmt, &x);
      _f->buff_pos += width;
      if (len > 0) {
        *z = CMPLX (x, 0);
      } else {
        *z = CMPLX (creal (*z), x);
      }
      return rc;
    } else if (_abs (len) == 32) {
      NEW_RECORD (str);
      complex_32 *z = (complex_32 *) elem;
      _fscanf_real (str, _f, (awid > RECLN - 1 ? RECLN - 1 : awid), _f->buff_len);
      if (len > 0) {
        *z = CMPLXQ (_strtoquad (str, NO_REF_TEXT), 0.0q);
      } else {
        *z = CMPLXQ (crealq (*z), _strtoquad (str, NO_REF_TEXT));
      }
      return 1;
    } else if (_abs (len) == 64) {
      NEW_RECORD (str);
      complex_64 *z = (complex_64 *) elem;
      _fscanf_real (str, _f, (awid > RECLN - 1 ? RECLN - 1 : awid), _f->buff_len);
      if (len > 0) {
        z->re = strtox (str, NO_REF_TEXT);
      } else {
        z->im = strtox (str, NO_REF_TEXT);
      }
      return 1;
    }
  }
// No conversion :-(
  return ERR;
}
