//! @file rts-real32.h
//! @author (see below)
//
//! @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*32 and COMPLEX*64.

// The code is based on the HPA Library, available from:
//   <http://download-mirror.savannah.gnu.org/releases/hpalib/>
//
//   Copyright (C) 2000 Daniel A. Atkinson <DanAtk@aol.com>
//   Copyright (C) 2004 Ivano Primi <ivprimi@libero.it>  
//   Copyright (C) 2022 Marcel van der Veer <algol68g@xs4all.nl> - VIF version.
//
// The HPA Library is free software; you can redistribute it and/or
// modify it under the terms of the GNU Lesser General Public
// License as published by the Free Software Foundation; either
// version 2.1 of the License, or (at your option) any later version.
//
// The HPA 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
// Lesser General Public License for more details.
//
// You should have received a copy of the GNU Lesser General Public
// License along with the HPA Library; if not, write to the Free
// Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
// 02110-1301 USA.

#include <vif.h>

#define CX1I_CHAR 'i'
#define CX1I_STR  "i"
#define CXDEF_LDEL   '('
#define CXDEF_RDEL   ')'
#define CX_EMPTY_SEP "  "
#define CX_SEPARATOR ", "
#define CX_SEP_L     (strlen (CX_SEPARATOR))
#define XDEF_LIM        6
#define XFMT_ALT       2
#define XFMT_RAW       1
#define XFMT_STD       0
#define XOUT_FIXED      0
#define XOUT_SCIENTIFIC 1

#define HPA_VERSION 	 "1.7 VIF"
#define XERR_DFL 	 1
#define XLITTLE_ENDIAN 	 1
#define XMAX_10EX  4931
#define XMAX_DEGREE 50
#define XULONG_BITSIZE 	 32

#define cxconvert cxconv
#define CXCONV(x) (complex_64){x, X_0}
#define cxdiff cxsub
#define CXIM(z) (z).im
#define cxipow cxpwr
#define CXRE(z) (z).re
#define CXSWAP(z) (complex_64){(z).im, (z).re}

struct xoutflags
{
  int_2 fmt, notat, sf, mfwd, lim;
  signed char padding, ldel, rdel;
};

#if defined (XERR_IGN)
  #define xsigerr(errcond, errcode, where) 0
#else
  #define XENONE   0
  #define XEDIV    1
  #define XEDOM    2
  #define XEBADEXP 3
  #define XFPOFLOW 4
  #define XNERR    4
  #define XEINV    (XNERR + 1)
  int_4 xsigerr (int_4 errcond, int_4 errcode, const char *where);
#endif

#if (FLT256_LEN == 15)
static const int_4 xItt_div = 3;
static const int_4 xK_tanh = 6;
static const int_4 xMS_exp = 39;
static const int_4 xMS_hyp = 45;
static const int_4 xMS_trg = 55;
#else
#error invalid real*32 length
#endif

static const int_2 xD_bias = 15360;
static const int_2 xD_lex = 12;
static const int_2 xD_max = 2047;
static const int_2 X_EXPO_BIAS = 16383;
static const int_2 xF_bias = 16256;
static const int_2 xF_lex = 9;
static const int_2 xF_max = 255;
static const int_2 xK_lin = -8 * FLT256_LEN;
static const int_2 xMax_p = 16 * FLT256_LEN;
static const real_32 xE2max = {{0x400c, 0xfffb}};    // +16382.75 
static const real_32 xE2min = {{0xc00c, 0xfffb}};    // -16382.75 
static const real_32 xEmax = {{0x400c, 0xb16c}};
static const real_32 xEmin = {{0xc00c, 0xb16c}};
static const real_32 X_MINUS_INF = {{0xffff, 0x0}};
static const real_32 X_PLUS_INF = {{0x7fff, 0x0}};
static const real_32 X_VGV = {{0x4013, 0x8000}};
static const real_32 X_VSV = {{0x3ff2, 0x8000}};
static const unt_2 X_EXPO_MASK = 0x7fff;
static const unt_2 X_SIGN_MASK = 0x8000;

// List of constants, extended with respect to original HPA lib.

static const real_32 FLT256_MIN = // Minimum representable number
  {{0x0001, 0x8000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000}};
static const real_32 FLT256_MAX = // Maximum representable number
  {{0x7ffe, 0xffff, 0xffff, 0xffff, 0xffff, 0xffff, 0xffff, 0xffff, 0xffff, 0xffff, 0xffff, 0xffff, 0xffff, 0xffff, 0xffff, 0xffff}};
static const real_32 FLT256_EPSILON = // Minimum positive number such that 1 + FLT256_EPSILON != 1.
  {{0x3f11, 0x8000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000}};
static const real_32 FLT256_EPSILON_HALF = // Maximum positive number such that 1 + FLT256_EPSILON != 1.
  {{0x3f10, 0x8000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000}};
static const real_32 X_LOG10_2 =
  {{0x3ffd, 0x9a20, 0x9a84, 0xfbcf, 0xf798, 0x8f89, 0x59ac, 0x0b7c, 0x9178, 0x26ad, 0x30c5, 0x43d1, 0xf349, 0x8a5e, 0x6f26, 0xb7d3}};

static const real_32 X_MINUS_1 = // -1
  {{0xbfff, 0x8000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000}};
static const real_32 X_0 =
  {{0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000}};
static const real_32 X_1_OVER_10 =
  {{0x3ffb, 0xcccc, 0xcccc, 0xcccc, 0xcccc, 0xcccc, 0xcccc, 0xcccc, 0xcccc, 0xcccc, 0xcccc, 0xcccc, 0xcccc, 0xcccc, 0xcccc, 0xcccc}};
static const real_32 X_1_OVER_2 = 
  {{0x3ffe, 0x8000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000}};
static const real_32 X_1 =
  {{0x3fff, 0x8000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000}};
static const real_32 X_2 =
  {{0x4000, 0x8000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000}};
static const real_32 X_3 =
  {{0x4000, 0xc000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000}};
static const real_32 X_4 =
  {{0x4001, 0x8000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000}} ;
static const real_32 X_5 =
  {{0x4001, 0xa000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000}} ;
static const real_32 X_6 =
  {{0x4001, 0xc000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000}} ;
static const real_32 X_7 =
  {{0x4001, 0xe000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000}} ;
static const real_32 X_8 =
  {{0x4002, 0x8000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000}} ;
static const real_32 X_9 =
  {{0x4002, 0x9000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000}} ;
static const real_32 X_10 =
  {{0x4002, 0xa000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000}};
static const real_32 X_100 =
  {{0x4005, 0xc800, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000}};
static const real_32 X_1000=
  {{0x4008, 0xfa00, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000}};

static const real_32 X_PI_OVER_4 = 
  {{0x3ffe, 0xc90f, 0xdaa2, 0x2168, 0xc234, 0xc4c6, 0x628b, 0x80dc, 0x1cd1, 0x2902, 0x4e08, 0x8a67, 0xcc74, 0x020b, 0xbea6, 0x3b14}};
static const real_32 X_PI_OVER_2 = 
  {{0x3fff, 0xc90f, 0xdaa2, 0x2168, 0xc234, 0xc4c6, 0x628b, 0x80dc, 0x1cd1, 0x2902, 0x4e08, 0x8a67, 0xcc74, 0x020b, 0xbea6, 0x3b14}};
static const real_32 X_PI = 
  {{0x4000, 0xc90f, 0xdaa2, 0x2168, 0xc234, 0xc4c6, 0x628b, 0x80dc, 0x1cd1, 0x2902, 0x4e08, 0x8a67, 0xcc74, 0x020b, 0xbea6, 0x3b14}};
static const real_32 X_LN_2 = 
  {{0x3ffe, 0xb172, 0x17f7, 0xd1cf, 0x79ab, 0xc9e3, 0xb398, 0x03f2, 0xf6af, 0x40f3, 0x4326, 0x7298, 0xb62d, 0x8a0d, 0x175b, 0x8bab}};
static const real_32 X_SQRT_2 = 
  {{0x3fff, 0xb504, 0xf333, 0xf9de, 0x6484, 0x597d, 0x89b3, 0x754a, 0xbe9f, 0x1d6f, 0x60ba, 0x893b, 0xa84c, 0xed17, 0xac85, 0x8334}};
static const real_32 X_LOG2_E = 
  {{0x3fff, 0xb8aa, 0x3b29, 0x5c17, 0xf0bb, 0xbe87, 0xfed0, 0x691d, 0x3e88, 0xeb57, 0x7aa8, 0xdd69, 0x5a58, 0x8b25, 0x166c, 0xd1a1}};
static const real_32 X_LOG2_10 = 
  {{0x4000, 0xd49a, 0x784b, 0xcd1b, 0x8afe, 0x492b, 0xf6ff, 0x4daf, 0xdb4c, 0xd96c, 0x55fe, 0x37b3, 0xad4e, 0x91b6, 0xac80, 0x82e8}};
static const real_32 X_LOG10_E = 
  {{0x3ffd, 0xde5b, 0xd8a9, 0x3728, 0x7195, 0x355b, 0xaaaf, 0xad33, 0xdc32, 0x3ee3, 0x4602, 0x45c9, 0xa202, 0x3a3f, 0x2d44, 0xf78f}};
static const real_32 X_RND_CORR = 
  {{0x3ffe, 0x8000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x01ae}};
static const real_32 X_FIX_CORR = 
  {{0x3f17, 0xc000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000}};
static const real_32 X_NAN = 
  {{0x0000, 0xffff, 0xffff, 0xffff, 0xffff, 0xffff, 0xffff, 0xffff, 0xffff, 0xffff, 0xffff, 0xffff, 0xffff, 0xffff, 0xffff, 0xffff}};

static const complex_64 X_0_0I = {
  {{0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000}},
  {{0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000}}
};

static const complex_64 X_1_0I = {
  {{0x3fff, 0x8000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000}},
  {{0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000}}
};

static const complex_64 X_0_1I = {
  {{0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000}},
  {{0x3fff, 0x8000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000}}
};

extern complex_64 atocx (const char *);
extern complex_64 cxacos (complex_64);
extern complex_64 cxacosh (complex_64);
extern complex_64 cxadd (complex_64, complex_64, int_4);
extern complex_64 cxasin (complex_64);
extern complex_64 cxasinh (complex_64);
extern complex_64 cxatan (complex_64);
extern complex_64 cxatanh (complex_64);
extern complex_64 cxceil (complex_64);
extern complex_64 cxconj (complex_64);
extern complex_64 cxcos (complex_64);
extern complex_64 cxcosh (complex_64);
extern complex_64 cxdiv (complex_64, complex_64);
extern complex_64 cxdrot (complex_64);
extern complex_64 cxexp10 (complex_64);
extern complex_64 cxexp2 (complex_64);
extern complex_64 cxexp (complex_64);
extern complex_64 cxfix (complex_64);
extern complex_64 cxfloor (complex_64);
extern complex_64 cxfrac (complex_64);
extern complex_64 cxgdiv (complex_64, complex_64);
extern complex_64 cxgmod (complex_64, complex_64);
extern complex_64 cxidiv (complex_64, complex_64);
extern complex_64 cxinv (complex_64);
extern complex_64 cxlog10 (complex_64);
extern complex_64 cxlog2 (complex_64);
extern complex_64 cxlog (complex_64);
extern complex_64 cxlog_sqrt (complex_64);
extern complex_64 cxmod (complex_64, complex_64);
extern complex_64 cxmul (complex_64, complex_64);
extern complex_64 cxneg (complex_64);
extern complex_64 cxpow (complex_64, complex_64);
extern complex_64 cxpwr (complex_64, int_4);
extern complex_64 cxreset (real_32, real_32);
extern complex_64 cxrmul (real_32, complex_64);
extern complex_64 cxroot (complex_64, int_4, int_4);
extern complex_64 cxround (complex_64);
extern complex_64 cxrrot (complex_64);
extern complex_64 cxsin (complex_64);
extern complex_64 cxsinh (complex_64);
extern complex_64 cxsqr (complex_64);
extern complex_64 cxsqrt (complex_64);
extern complex_64 cxsub (complex_64, complex_64);
extern complex_64 cxsum (complex_64, complex_64);
extern complex_64 cxswap (complex_64);
extern complex_64 cxtan (complex_64);
extern complex_64 cxtanh (complex_64);
extern complex_64 cxtrunc (complex_64);
extern complex_64 dctocx (real_8, real_8);
extern complex_64 fctocx (real_4, real_4);
extern complex_64 ictocx (int_4, int_4);
extern complex_64 uctocx (unt_4, unt_4);

extern int_4 xgetexp (const real_32 *);
extern int_4 xgetsgn (const real_32 *);
extern int_4 xreal_cmp (const real_32 *, const real_32 *);

extern logical_4 cxeq (complex_64, complex_64);
extern logical_4 cxis0 (const complex_64*);
extern logical_4 cxneq (complex_64, complex_64);
extern logical_4 cxnot0 (const complex_64*);
extern logical_4 cxrec (complex_64, complex_64 *);
extern logical_4 xisordnumb (const real_32 *);

extern real_32 cxabs (complex_64);
extern real_32 cxarg (complex_64);
extern real_32 xacosh (real_32);
extern real_32 xacos (real_32);
extern real_32 xacotan (real_32);
extern real_32 _xaint_4 (real_32);
extern real_32 xasinh (real_32);
extern real_32 xasin (real_32);
extern real_32 xatan2 (real_32, real_32);
extern real_32 xatanh (real_32);
extern real_32 xatan (real_32);
extern real_32 xceil (real_32);
extern real_32* xchcof (int_4, real_32 (*) (real_32));
extern real_32 xcosh (real_32);
extern real_32 xcos (real_32);
extern real_32 xcotan (real_32);
extern real_32 xevtch (real_32, real_32 *, int_4);
extern real_32 xexp10 (real_32);
extern real_32 xexp2 (real_32);
extern real_32 xexp (real_32);
extern real_32 xfix (real_32);
extern real_32 xfloor (real_32);
extern real_32 xfmod (real_32, real_32, real_32 *);
extern real_32 xfrexp (real_32, int_4 *);
extern real_32 xlog2 (real_32);
extern real_32 xlog (real_32);
extern real_32 _xmax (real_32, real_32);
extern real_32 _xmin (real_32, real_32);
extern real_32 _xnint_4 (real_32);
extern real_32 xpow (real_32, real_32);
extern real_32 xreal_2 (real_32, int_4);
extern real_32 _xsgn (real_32, real_32);
extern real_32 xsinh (real_32);
extern real_32 xsin (real_32);
extern real_32 xsqrt (real_32);
extern real_32 xtanh (real_32);
extern real_32 xtan (real_32);
extern void cxtodc (const complex_64 *, real_8 *, real_8 *);
extern void cxtofc (const complex_64 *, real_4 *, real_4 *);
extern void _xdump (real_32 *);
extern void xlshift (int_4, unt_2 *, int_4);
extern void xrshift (int_4, unt_2 *, int_4);

static real_32 c_tan (real_32 u);
static real_32 rred (real_32 u, int_4 i, int_4 *p);
