/* Copyright (C) 1991-99 Free Software Foundation, Inc.

   This file is part of GNU Pascal Library.

   Routines to read various things from files.

The GNU Pascal Library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public License as
published by the Free Software Foundation; either version 2 of the
License, or (at your option) any later version.

The GNU Pascal Library 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
Library General Public License for more details.

You should have received a copy of the GNU Library General Public
License along with the GNU Pascal Library; see the file COPYING.LIB.  If
not, write to the Free Software Foundation, Inc., 675 Mass Ave,
Cambridge, MA 02139, USA. */

/*
 * Authors: Jukka Virtanen <jtv@hut.fi>
 *          Frank Heckenbach <frank@pascal.gnu.de>
 */

#include "rts.h"
#include "fdr.h"
#include "varargs.h"

int
_p_internal_getc (File)
    FDR File;
{
  if (!(File->Flags & READ_WRITE_STRING_MASK))
    {
      if (tst_EOF (File)) return EOF;
      if (File->BufPos >= File->BufSize)
        _p_read_buffer (File);
    }
  if (_p_inoutres == 0)
    {
      clr_EOLN (File);
      if (File->BufPos < File->BufSize)
        {
          unsigned char ch = File->BufPtr [File->BufPos++];
          if (tst_TXT(File) && ch == NEWLINE)
            {
              clr_LGET(File);
              set_EOLN(File);
              set_EOFOK(File);
              m_FILBUF (File) = ch = ' ';
            }
          return ch;
        }
      set_EOF (File);
      set_EOLN (File);
    }
  return EOF;
}

static int
_p_direct_getc (File)
FDR File;
{
  /* If buffer is undefined, read in new contents */
  if (!tst_LGET (File))
    {
      set_LGET (File);
      return m_FILBUF (File);
    }
  return _p_internal_getc (File);
}

static int
_p_direct_getc_checkeof (File)
FDR File;
{
  int ch = _p_direct_getc (File);
  _p_ok_EOF (File);
  return ch;
}

static void
_p_ungetch (File, ch)
FDR File; int ch;
{
  if (ch != EOF && !tst_EOLN (File))
    {
      if (File->BufPos == 0) _p_internal_error (910); /* read buffer underflow */ \
      File->BufPos--;
      /* Don't do this for strings, because it's not necessary, and the
         string might be constant */
      if (!(File->Flags & READ_WRITE_STRING_MASK))
        File->BufPtr [File->BufPos] = ch;
    }
}

static inline int
TestDigit (ch, digit, base)
int ch, *digit, base;
{
  *digit = (ch >= '0' && ch <= '9') ? ch - '0'
         : (ch >= 'A' && ch <= 'Z') ? ch - 'A' + 10
         : (ch >= 'a' && ch <= 'z') ? ch - 'a' + 10
         : base;
  return *digit < base;
}

/* read an integer number */
extern signed long long _p_readi_check PROTO ((FDR, TRangeCheck, signed long long, signed long long));
signed long long
_p_readi_check (File, check, min, max)
FDR File;
TRangeCheck check;
signed long long min, max; /* Actually they are unsigned if check == UnsignedRangeCheck */
{
  int negative;
  int ch;
  unsigned long long num,          /* Absolute value of the number read */
                     u_min, u_max; /* bounds for the absolute value */
  int base = 10;
  int base_changed = 0;
  int digit;

  if (_p_inoutres) return 0;

  ch = _p_direct_getc_checkeof (File);
  negative = FALSE;
  while(isspace_nl(ch))
    ch = _p_direct_getc_checkeof (File);
  if (! (TestDigit (ch, &digit, base) || ch == '+' || ch == '-' || (ch == '$' && (File->Flags & INT_READ_HEX_MASK))))
    IOERROR(552,0); /* sign or digit expected */
  else
    {
      if (ch=='+' || ch=='-')
        {
          if (ch == '-')
            negative = TRUE;
          ch = _p_direct_getc_checkeof (File);
          if (! (TestDigit (ch, &digit, base) || (ch == '$' && (File->Flags & INT_READ_HEX_MASK))))
            IOERROR(551,0); /* digit expected after sign */
        }
    }

  /* Compute bounds for absolute value, depending on the actual sign */
  u_min = min;
  u_max = max;

  if (check == UnsignedRangeCheck && negative)
    {
      if (u_min == 0)
        u_max = 0;
      else
        IOERROR(553,0); /* Overflow while reading integer */
    }

  if (check == SignedRangeCheck)
    {
      if (negative)
        {
          if (min > 0) IOERROR(553,0); /* Overflow while reading integer */
          u_max = - min;
          u_min = (max > 0) ? 0 : - max;
        }
      else
        {
          if (min < 0) u_min = 0;
          if (max < 0) IOERROR(553,0); /* Overflow while reading integer */
        }
    }

  /* Check for `$' hex base specifier */
  if (ch == '$' && (File->Flags & INT_READ_HEX_MASK))
    {
      base = 0x10;
      base_changed = 1;
      ch = _p_direct_getc_checkeof (File);
      if (!TestDigit (ch, &digit, base))
        IOERROR(557,0);
    }

  /* Now the 'ch' contains the first digit. Get the integer */

  num = 0;

  do {
    if (check != NoRangeCheck &&
        num > (((u_max<36 && !base_changed && (File->Flags & INT_READ_BASE_SPEC_MASK))
                ?36: u_max) - digit) / base)
      IOERROR(553,0); /* Overflow while reading integer */

    num = num * base + digit;
    ch = _p_direct_getc (File);

    /* Check for `n#' base specifier */
    if (ch == '#' && (File->Flags & INT_READ_BASE_SPEC_MASK))
      {
        if (base_changed)
          IOERROR(559,0); /* Only one base specifier allowed in integer constant */

        if (num < 2 || num > 36)
          IOERROR(560,0); /* Base out of range (2..36) */

        base = num;
        base_changed = 1;
        num = 0;

        ch = _p_direct_getc_checkeof (File);
        if (!TestDigit (ch, &digit, base))
          IOERROR(558,0); /* Digit expected after `#' in integer constant */
      }
  } while (TestDigit (ch, &digit, base));

  if (check != NoRangeCheck && (num < u_min || num > u_max))
    IOERROR(553,0); /* Overflow while reading integer */

  if ((File->Flags & NUM_READ_CHK_WHITE_MASK) && !isspace_nl(ch))
    IOERROR(561,0); /* Invalid digit */

  _p_ungetch (File, ch);

  if ((File->Flags & VAL_MASK) && File->BufPos < File->BufSize)
    {
      File->BufPos++;
      IOERROR (565, 0); /* extra characters after number in `Val'' */
    }

  return negative ? -num : num;
}

extern signed long long _p_readi PROTO ((FDR));
signed long long
_p_readi (File)
FDR File;
{
  return _p_readi_check (File, NoRangeCheck, 0ll, 0ll);
}

/* check if two real numbers are approximately equal */
static int
_p_realeq (X, Y)
long double X, Y;
{
  long double tmp = 1.0e-6 * ((X >= 0) ? X : -X);
  return X-Y <= tmp && Y-X <= tmp;
}

static void
_p_check_real_overunderflow (tmp, p)
long double tmp, p;
{
  if (_p_inoutres) return;
  if (p == 0.0 && tmp != 0.0)
    IOERROR(564,); /* underflow while reading real number */
  if ((tmp < -1.0 || tmp > 1.0) && !_p_realeq(tmp, p))
    IOERROR(563,); /* overflow while reading real number */
}

extern long double _p_read_longreal PROTO ((FDR));
long double
_p_read_longreal (File)
FDR File;
{
  int require_fractional = 0;
  int negative = FALSE;
  int expon = 0, lastexp;
  int enegative = FALSE;
  int ch, i;
  long double val = 0.0, lastval, frac = 1.0;

  if (_p_inoutres) return 0.0;

  ch = _p_direct_getc_checkeof (File);

  while(isspace_nl(ch))
    ch = _p_direct_getc_checkeof (File);

  if (! (isdigit(ch) || ch == '+' || ch == '-' || (ch == '.' && !(File->Flags & REAL_READ_ISO7185_ONLY_MASK))))
    IOERROR(552, 0.0); /* Sign or digit expected */
  else
    {
      if (ch == '+' || ch == '-')
        {
          if (ch == '-')
            negative = TRUE;
          ch = _p_direct_getc_checkeof (File);

          /* Skip spaces between sign and digit (or '.') */
          while(isspace_nl(ch))
            ch = _p_direct_getc_checkeof (File);
        }
    }

  if (! (isdigit(ch) || (ch == '.' && !(File->Flags & REAL_READ_ISO7185_ONLY_MASK))))
    IOERROR((File->Flags & REAL_READ_ISO7185_ONLY_MASK)
      ? 551  /* Digit expected after sign */
      : 562, /* Digit or `.' expected after sign */
      0.0);

  require_fractional = ((File->Flags & REAL_READ_ISO7185_ONLY_MASK) || !isdigit (ch));

  /* Read the mantissa. ch is now a digit (or '.') */
  while (isdigit(ch))
    {
      lastval = val;
      val = 10.0 * val + (ch - '0');
      if (!_p_realeq((val - (ch - '0')) / 10.0, lastval))
        IOERROR(563, 0.0); /* Overflow while reading real number */
      ch = _p_direct_getc (File);
    }

  if (ch == '.')
    { /* Read the fractional part */
      ch = _p_direct_getc (File);

      if (require_fractional && !isdigit(ch))
        IOERROR(554, 0.0); /* Digit expected after decimal point */

      while(isdigit(ch))
        {
          frac /= 10.0;
          val += frac * (ch - '0');
          ch = _p_direct_getc (File);
        }
    }

  /* read the exponent */
  if (ch=='e' || ch=='E') {
    ch = _p_direct_getc_checkeof (File);
    if (ch == '+' || ch == '-') {
      if (ch == '-')
        enegative = TRUE;
      ch = _p_direct_getc_checkeof (File);
    }

    if (!isdigit(ch)) {
      IOERROR(555, 0.0); /* Digit expected while reading exponent */
    }

    while(isdigit(ch)) {
      lastexp =expon;
      expon = 10 * expon + (ch-'0');
      if ((expon - (ch - '0')) / 10 != lastexp)
        IOERROR(556, 0.0); /* Exponent out of range */
      ch = _p_direct_getc (File);
    }

    if (enegative)
      {
        frac = 1.0;
        for (i = 1; i <= expon; i++)
          frac /= 10.0;

        if (frac == 0.0)
          IOERROR(556, 0.0); /* Exponent out of range */

        val *= frac;
      }
    else
      for (i = 1; i<= expon; i++)
      {
        lastval = val;
        val = 10.0 * val;
        if (!_p_realeq(val / 10.0, lastval))
          IOERROR(556, 0.0); /* Exponent out of range */
      }

  }

  if ((File->Flags & NUM_READ_CHK_WHITE_MASK) && !isspace_nl(ch))
    IOERROR(561, 0.0); /* invalid digit */

  _p_ungetch (File, ch);

  if ((File->Flags & VAL_MASK) && File->BufPos < File->BufSize)
    {
      File->BufPos++;
      IOERROR (565, 0.0); /* extra characters after number in `Val'' */
    }

  return negative ? -val : val;
}

extern float _p_read_shortreal PROTO ((FDR));
float
_p_read_shortreal (File)
FDR File;
{
  long double tmp = _p_read_longreal (File);
  volatile float p = (float) tmp;
  _p_check_real_overunderflow (tmp, (long double) p);
  return _p_inoutres ? 0.0 : p;
}

extern double _p_read_real PROTO ((FDR));
double
_p_read_real (File)
FDR File;
{
  long double tmp = _p_read_longreal (File);
  volatile double p = (double) tmp;
  _p_check_real_overunderflow (tmp, (long double) p);
  return _p_inoutres ? 0.0 : p;
}

extern char _p_read_char PROTO ((FDR));
char
_p_read_char (File)
FDR File;
{
  if (_p_inoutres)
    return ' ';
  else
    return _p_direct_getc_checkeof (File);
}

/* read a string up to the max length or newline, whichever comes first.
 * The number of characters read is returned. */
extern int _p_read_string PROTO((FDR, char *, int));
int
_p_read_string (File, str, maxlen)
FDR File;
char *str;
int maxlen;
{
  int length = 0;

  if (_p_inoutres) return 0;

  if (maxlen < 0)
    _p_internal_error (907); /* String length cannot be negative */

  /* If EOLN(File) is on, nothing is read and length is left zero. */
  if (!tst_EOLN (File))
    {
      int ch = _p_direct_getc (File);
      while (!tst_EOLN (File) && ch != EOF && length < maxlen)
        {
          *str++ = ch;
          length++;
          ch = _p_direct_getc (File);
        }
      _p_ungetch (File, ch);
    }
  return length;
}

extern void _p_readln PROTO ((FDR));
void
_p_readln (File)
FDR File;
{
  if (_p_inoutres) return;
  while (!tst_EOF(File) && !tst_EOLN(File))
    _p_getbyte (File);
  /* Now EOLN is not true, because we just read it off */
  clr_EOLN(File);
  set_LGET(File);
  set_EOFOK(File);
}

extern void _p_read_init PROTO ((FDR, int));
void
_p_read_init (File, Flags)
FDR File;
int Flags;
{
  File->Flags = Flags;
  _p_ok_READ(File);
  if (tst_TTY(File))
    _p_fflush(TRUE);
}

extern void _p_readstr_init PROTO ((FDR, char *, int, int));
void
_p_readstr_init (File, s, Length, Flags)
FDR File;
char *s;
int Length, Flags;
{
  File->BufPtr = s;
  File->BufSize = Length;
  File->BufPos = 0;
  File->Flags = Flags;
  m_FILSTA (File) = 0;
  clr_EOF (File);
  clr_EOFOK (File);
  clr_EOLN (File);
  set_LGET (File);
  set_TXT (File);
  SET_STATUS (File, FiRONLY);
  if (File->BufPos >= File->BufSize)
    {
      set_EOF (File);
      set_EOLN (File);
    }
}

extern void _p_val_init PROTO ((FDR, char *, int, int));
void
_p_val_init (File, s, Length, Flags)
FDR File;
char *s;
int Length, Flags;
{
  _p_start_temp_io_error ();
  _p_readstr_init (File, s, Length, Flags);
}

extern int _p_get_val_return_value PROTO ((FDR));
int
_p_get_val_return_value (File)
FDR File;
{
  return _p_end_temp_io_error () ? File->BufPos + !!tst_EOF (File) : 0;
}

/* Read the various integer types */
#define read_check NoRangeCheck
/* Input range checking is not supported in _p_read() and _p_readstr() that
   the following macro belongs to, but it is supported in _p_readi_check(). */
#define READ_INT(sign,type,type2) \
  if (read_check != NoRangeCheck) \
    { \
      sign type *i = va_arg (p, sign type *); \
      sign long long min = va_arg (p, sign type2); \
      sign long long max = va_arg (p, sign type2); \
      *i = (sign long long) _p_readi_check (File, read_check, min, max); \
    } \
  else \
    *(va_arg (p, sign type *)) = (sign long long) _p_readi (File); \
  break;

/* common to _p_read() and _p_readstr() */
#define READ_VARIOUS_TYPES \
  case P_S_BYTE:     READ_INT (signed, char, int) \
  case P_S_SHORT:    READ_INT (signed, short, int) \
  case P_S_INT:      READ_INT (signed, int, int) \
  case P_S_LONG:     READ_INT (signed, long, long long) \
  case P_S_LONGLONG: READ_INT (signed, long long, long long) \
  case P_U_BYTE:     READ_INT (unsigned, char, int) \
  case P_U_SHORT:    READ_INT (unsigned, short, int) \
  case P_U_INT:      READ_INT (unsigned, int, int) \
  case P_U_LONG:     READ_INT (unsigned, long, long long) \
  case P_U_LONGLONG: READ_INT (unsigned, long long, long long) \
  case P_SHORT_REAL: \
    *(va_arg (p, float *)) = _p_read_shortreal (File); \
    break; \
  case P_REAL: \
    *(va_arg (p, double *)) = _p_read_real (File); \
    break; \
  case P_LONG_REAL: \
    *(va_arg (p, long double *)) = _p_read_longreal (File); \
    break; \
  case P_CHAR: \
    *(va_arg (p, char *)) = _p_read_char (File); \
    break; \
  case P_STRING: \
    { \
      char *str = va_arg (p, char *); /* pointer to string */ \
      int *s_curlen = va_arg (p, int *); /* pointer to current string length */ \
      int s_maxlen  = va_arg (p, int); /* maximum length */ \
      if (!s_curlen) _p_internal_error (908); /* Incorrect reading of string */ \
      *s_curlen = _p_read_string (File, str, s_maxlen); \
      break; \
    } \
  case P_SHORT_STRING: \
    { \
      char *str = va_arg (p, char *); /* pointer to string */ \
      char *s_curlen = va_arg (p, char *); /* pointer to current string length */ \
      int s_maxlen  = va_arg (p, int); /* maximum length */ \
      if (!s_curlen) _p_internal_error (908); /* Incorrect reading of string */ \
      *s_curlen = _p_read_string (File, str, s_maxlen); \
      break; \
    } \
  case P_FIXED_STRING: \
    { \
      char *str = va_arg (p, char *); /* pointer to string */ \
      int s_maxlen = va_arg (p, int); /* maximum length */ \
      int length = _p_read_string (File, str, s_maxlen); \
      while (length < s_maxlen) str [length++] = ' '; /* fill with spaces */ \
      break; \
    } \
  case P_CSTRING: \
    { \
      char *str = va_arg (p, char *); /* pointer to string */ \
      int s_maxlen = va_arg (p, int); /* maximum length */ \
      int curlen = _p_read_string (File, str, s_maxlen - 1); /* reserve space for terminator */ \
      str [curlen] = 0; /* Add #0 terminator for CStrings */ \
      break; \
    }

/* read various things from TEXT files
   _p_read does not return immediately when _p_inoutres is set, but loops
   through all the arguments and sets them to "zero" values */
void
_p_read (File, count, va_alist)
FDR File;
int count;
va_dcl
{
  va_list p;
  _p_read_init (File, 0);
  va_start (p);
  while (count--)
    {
      int Flags = va_arg (p, int); /* Type we are reading */
      /* The type code is only
         needed for the following switch and can be removed when the
         switch is "built in".

         The subroutines only need the modifier flags. They should
         be constant during one Read{,ln,Str} call, and can therefore
         be initialized once in the _p_read_init() call above, eliminating
         the following assignment. */
      File->Flags = Flags;

      switch (Flags & INPUT_TYPE_MASK)
      {
        READ_VARIOUS_TYPES
        case P_LINE:
          if (count != 0)
            _p_internal_error (900); /* Compiler calls `Readln' incorrectly */
          _p_readln (File);
          break;
        default:
          _p_internal_error (902); /* unknown code in `Read' */
      }
    }
  va_end (p);
}

/* read from a string
   _p_readstr does not return immediately when _p_inoutres is set, but loops
   through all the arguments and sets them to "zero" values */
void
_p_readstr (string, maxchars, count, va_alist)
char *string;
int maxchars, count;
va_dcl
{
  va_list p;
  struct Fdr TempFile; /* This is no real file, be careful what you do with it. Don't call initfdr(). ;*/
  FDR File = &TempFile; /* needed by READ_VARIOUS_TYPES */

  va_start (p);

  _p_readstr_init (File, string, ((maxchars == -1) ? _p_strlen (string) /* CString */
                                                   : maxchars           /* Pascal string */ ),
                   READ_WRITE_STRING_MASK);

  while (count--)
    {
      int Flags = va_arg (p, int);
      /* cf. the comment in _p_read(), but note READ_WRITE_STRING_MASK */
      File->Flags = READ_WRITE_STRING_MASK | Flags;

      switch (Flags & INPUT_TYPE_MASK)
      {
        READ_VARIOUS_TYPES
        default:
          _p_internal_error (903); /* unknown code in `ReadStr' */
      }
    }
  va_end (p);
}

#define VAL_ROUTINE(FUNCTION) \
{ \
  struct Fdr TempFile; /* This is no real file, be careful what you do with it. Don't call initfdr(). ;*/ \
  _p_val_init (&TempFile, string, ((maxchars == -1) ? _p_strlen (string) : maxchars ), \
               READ_WRITE_STRING_MASK | VAL_MASK | flags); \
  *var = FUNCTION; \
  return _p_get_val_return_value (&TempFile); \
}

#define VAL_REAL(func,type,read_func) \
extern int func PROTO ((char *, int, int, type *)); \
int func (string, maxchars, flags, var) \
char *string; int maxchars, flags; type *var; \
VAL_ROUTINE (read_func (&TempFile))

VAL_REAL(_p_val_shortreal, float,       _p_read_shortreal)
VAL_REAL(_p_val_real,      double,      _p_read_real)
VAL_REAL(_p_val_longreal,  long double, _p_read_longreal)

/* read from a string into one integer argument */
#define VAL_INT_NOCHECK(func,sign,type) \
extern int func PROTO ((char *, int, int, sign type *)); \
int func (string, maxchars, flags, var) \
char *string; int maxchars, flags; sign type *var; \
VAL_ROUTINE (_p_readi (&TempFile))

VAL_INT_NOCHECK (_p_val_byteint_nocheck,   signed,   char)
VAL_INT_NOCHECK (_p_val_shortint_nocheck,  signed,   short)
VAL_INT_NOCHECK (_p_val_integer_nocheck,   signed,   int)
VAL_INT_NOCHECK (_p_val_medint_nocheck,    signed,   long)
VAL_INT_NOCHECK (_p_val_longint_nocheck,   signed,   long long)
VAL_INT_NOCHECK (_p_val_bytecard_nocheck,  unsigned, char)
VAL_INT_NOCHECK (_p_val_shortcard_nocheck, unsigned, short)
VAL_INT_NOCHECK (_p_val_cardinal_nocheck,  unsigned, int)
VAL_INT_NOCHECK (_p_val_medcard_nocheck,   unsigned, long)
VAL_INT_NOCHECK (_p_val_longcard_nocheck,  unsigned, long long)

#if 0 /* so they don't waste space in libgpc.a -- not implemented in the compiler yet, anyway */
#define VAL_INT_CHECK(func,check,sign,type) \
extern int func PROTO ((char *, int, int, sign type *, sign type, sign type)); \
int func (string, maxchars, flags, var, min, max) \
char *string; int maxchars, flags; sign type *var; sign type min,max; \
VAL_ROUTINE (_p_readi_check (&TempFile, check, (sign long long) min, (sign long long) max))

VAL_INT_CHECK (_p_val_byteint_check,   SignedRangeCheck,   signed,   char)
VAL_INT_CHECK (_p_val_shortint_check,  SignedRangeCheck,   signed,   short)
VAL_INT_CHECK (_p_val_integer_check,   SignedRangeCheck,   signed,   int)
VAL_INT_CHECK (_p_val_medint_check,    SignedRangeCheck,   signed,   long)
VAL_INT_CHECK (_p_val_longint_check,   SignedRangeCheck,   signed,   long long)
VAL_INT_CHECK (_p_val_bytecard_check,  UnsignedRangeCheck, unsigned, char)
VAL_INT_CHECK (_p_val_shortcard_check, UnsignedRangeCheck, unsigned, short)
VAL_INT_CHECK (_p_val_cardinal_check,  UnsignedRangeCheck, unsigned, int)
VAL_INT_CHECK (_p_val_medcard_check,   UnsignedRangeCheck, unsigned, long)
VAL_INT_CHECK (_p_val_longcard_check,  UnsignedRangeCheck, unsigned, long long)
#endif
