//! @file rts-real16.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 REAL*16 and COMPLEX*32.

#include <vif.h>

#define MAX_DOUBLE_EXPO 4932

static real_16 pow_10_double[] = {
  10.0q, 100.0q, 1.0e4q, 1.0e8q, 1.0e16q, 1.0e32q, 1.0e64q, 1.0e128q, 1.0e256q, 1.0e512q, 1.0e1024q, 1.0e2048q, 1.0e4096q
};

real_16 ten_up_double (int_4 expo)
{
// This way appears sufficiently accurate.
  real_16 dbl_expo = 1.0q, *dep;
  logical_4 neg_expo;
  if (expo == 0) {
    return 1.0q;
  }
  neg_expo = (logical_4) (expo < 0);
  if (neg_expo) {
    expo = -expo;
  }
  if (expo > MAX_DOUBLE_EXPO) {
    expo = 0;
    errno = EDOM;
  }
//  ABEND (expo > MAX_DOUBLE_EXPO, ERROR_INVALID_VALUE, __func__);
  for (dep = pow_10_double; expo != 0; expo >>= 1, dep++) {
    if (expo & 0x1) {
      dbl_expo *= *dep;
    }
  }
  return neg_expo ? 1.0q / dbl_expo : dbl_expo;
}

//! @brief Transform string into real-16.
// From Algol 68 Genie.

real_16 _strtoquad (char *s, char **end)
{
  int_4 i, dot = -1, pos = 0, pow = 0, expo;
  real_16 sum, W, y[FLT128_DIG];
  errno = 0;
  for (i = 0; i < FLT128_DIG; i++) {
    y[i] = 0.0q;
  }
  while (isspace (s[0])) {
    s++;
  }
// Scan mantissa digits and put them into "y".
  if (s[0] == '-') {
    W = -1.0q;
  } else {
    W = 1.0q;
  }
  if (s[0] == '+' || s[0] == '-') {
    s++;
  }
  while (s[0] == '0') {
    s++;
  }
  while (pow < FLT128_DIG && s[pos] != '\0' && (isdigit (s[pos]) || s[pos] == '.')) {
    if (s[pos] == '.') {
      dot = pos;
    } else {
      int_4 val = (int_4) s[pos] - (int_4) '0';
      y[pow] = W * val;
      W /= 10.0q;
      pow++;
    }
    pos++;
  }
  if (end != NO_REF_TEXT) {
    (*end) = &(s[pos]);
  }
// Sum from low to high to preserve precision.
  sum = 0.0q;
  for (i = FLT128_DIG - 1; i >= 0; i--) {
    sum = sum + y[i];
  }
// See if there is an exponent.
  if (_EXPCHAR (s[pos])) {
    expo = (int_4) strtol (&(s[++pos]), end, 10);
  } else {
    expo = 0;
  }
// Standardise.
  if (dot >= 0) {
    expo += dot - 1;
  } else {
    expo += pow - 1;
  }
  while (sum != 0.0q && fabsq (sum) < 1.0q) {
    sum *= 10.0q;
    expo -= 1;
  }
//
  if (errno == 0) {
    return sum * ten_up_double (expo);
  } else {
    return 0.0q;
  }
}

