QDouble.st
author Claus Gittinger <cg@exept.de>
Tue, 13 Jun 2017 18:06:51 +0200
changeset 4386 0a320155d78a
parent 4385 3bfafdde1cb5
child 4387 879309cae427
permissions -rw-r--r--
#REFACTORING by cg class: QDouble added: #/ #renorm comment/format in: #asDoubleArray #d0 #d1 #d3 changed: #asFloat #equalFromQDouble: #negative #positive #quotientFromQDouble:
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
     1
"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
     2
 COPYRIGHT (c) 2017 by eXept Software AG
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
     3
              All Rights Reserved
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
     4
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
     5
 This software is furnished under a license and may be used
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
     6
 only in accordance with the terms of that license and with the
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
     7
 inclusion of the above copyright notice.   This software may not
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
     8
 be provided or otherwise made available to, or used by, any
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
     9
 other person.  No title to or ownership of the software is
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    10
 hereby transferred.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    11
"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    12
"{ Package: 'stx:libbasic2' }"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    13
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    14
"{ NameSpace: Smalltalk }"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    15
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    16
LimitedPrecisionReal variableByteSubclass:#QDouble
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    17
	instanceVariableNames:''
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    18
	classVariableNames:'DefaultPrintFormat QDoubleZero QDoubleOne Pi E Ln2 Ln10 Epsilon'
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    19
	poolDictionaries:''
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    20
	category:'Magnitude-Numbers'
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    21
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    22
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    23
!QDouble primitiveDefinitions!
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
    24
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    25
%{
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    26
#include <stdio.h>
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    27
#include <errno.h>
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    28
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    29
#define __USE_ISOC9X 1
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    30
#define __USE_ISOC99 1
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    31
#include <math.h>
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    32
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    33
/*
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    34
 * on some systems, errno is a macro ... check for it here
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    35
 */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    36
#ifndef errno
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    37
 extern errno;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    38
#endif
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    39
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    40
#if !defined (__win32__)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    41
# include <locale.h>
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    42
#endif
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    43
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    44
#if defined (__aix__)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    45
# include <float.h>
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    46
#endif
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    47
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    48
#if defined(__irix__) || defined(__solaris__) || defined(__sunos__)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    49
# include <nan.h>
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    50
#endif
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    51
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    52
#if defined(__linux__)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    53
# ifndef NAN
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    54
#  include <bits/nan.h>
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    55
# endif
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    56
#endif
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    57
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    58
struct qd_real {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    59
    double x[4];    /* The Components. */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    60
};
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    61
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    62
struct __quadDoubleStruct {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    63
        STX_OBJ_HEADER
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    64
#ifdef __NEED_DOUBLE_ALIGN
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    65
        __FILLTYPE_DOUBLE f_filler;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    66
#endif
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    67
        double d_quadDoubleValue[4];
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    68
};
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    69
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    70
#define __QuadDoubleInstPtr(obj)      ((struct __quadDoubleStruct *)(__objPtr(obj)))
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    71
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    72
#ifndef __isQuadDouble
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    73
# define __isQuadDouble(o) \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    74
        (__Class(o) == @global(QuadDouble))
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    75
#endif
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    76
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    77
#ifndef __qIsQuadDouble
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    78
# define __qIsQuadDouble(o) \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    79
        (__qClass(o) == @global(QuadDouble))
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    80
#endif
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    81
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    82
#define __qNew_qdReal(newQD, d0,d1,d2,d3) { \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    83
    __qNew(newQD, sizeof(struct __quadDoubleStruct)); \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    84
    __stx_setClass(newQD, QDouble);                \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    85
    __QuadDoubleInstPtr(newQD)->d_quadDoubleValue[0] = d0;   \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    86
    __QuadDoubleInstPtr(newQD)->d_quadDoubleValue[1] = d1;   \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    87
    __QuadDoubleInstPtr(newQD)->d_quadDoubleValue[2] = d2;   \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    88
    __QuadDoubleInstPtr(newQD)->d_quadDoubleValue[3] = d3;   \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    89
}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    90
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    91
// qd_real(c0, c1, c2, c3);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    92
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    93
#define _QD_SPLITTER 134217729.0               // = 2^27 + 1
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    94
#define _QD_SPLIT_THRESH 6.69692879491417e+299 // = 2^996
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    95
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    96
#define m_quick_two_sum(rslt, a, b, err) {\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    97
  double s = a + b;\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    98
  err = b - (s - a);\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    99
  rslt = s; \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   100
}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   101
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   102
#define m_two_sum(rslt, a, b, err) {\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   103
  double s = a + b;\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   104
  double bb = s - a;\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   105
  err = (a - (s - bb)) + (b - bb);\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   106
  rslt = s;\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   107
}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   108
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   109
#define m_three_sum(a, b, c) { \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   110
  double t1, t2, t3; \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   111
  m_two_sum(t1, a, b, t2); \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   112
  m_two_sum(a, c, t1, t3); \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   113
  m_two_sum(b, t2, t3, c); \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   114
}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   115
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   116
#define m_three_sum2(a, b, c) {\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   117
  double t1, t2, t3;\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   118
  m_two_sum(t1, a, b, t2);\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   119
  m_two_sum(a, c, t1, t3);\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   120
  b = t2 + t3;\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   121
}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   122
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   123
#ifndef QD_FMS
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   124
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   125
/* Computes high word and lo word of a */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   126
#define m_split(a, hi, lo) {\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   127
  double temp;\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   128
  if (a > _QD_SPLIT_THRESH || a < -_QD_SPLIT_THRESH) {\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   129
    a *= 3.7252902984619140625e-09;\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   130
    temp = _QD_SPLITTER * a;\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   131
    hi = temp - (temp - a);\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   132
    lo = a - hi;\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   133
    hi *= 268435456.0;\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   134
    lo *= 268435456.0;\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   135
  } else {\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   136
    temp = _QD_SPLITTER * a;\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   137
    hi = temp - (temp - a);\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   138
    lo = a - hi;\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   139
  }\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   140
}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   141
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   142
#endif
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   143
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   144
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   145
#ifdef QD_FMS
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   146
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   147
/* Computes fl(a*b) and err(a*b). */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   148
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   149
#define m_two_prod(rslt, a, b, err) {\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   150
  double p = a * b;\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   151
  err = QD_FMS(a, b, p);\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   152
  rslt = p; \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   153
}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   154
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   155
#else
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   156
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   157
#define m_two_prod(rslt, a, b, err) {\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   158
  double a_hi, a_lo, b_hi, b_lo;\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   159
  double p = a * b;\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   160
  m_split(a, a_hi, a_lo);\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   161
  m_split(b, b_hi, b_lo);\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   162
  err = ((a_hi * b_hi - p) + a_hi * b_lo + a_lo * b_hi) + a_lo * b_lo;\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   163
  rslt = p; \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   164
}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   165
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   166
#endif
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   167
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   168
#ifdef QD_FMS
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   169
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   170
#define m_two_sqr(rslt, a, err) {\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   171
  double p = a * a;\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   172
  err = QD_FMS(a, a, p);\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   173
  rslt = p;\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   174
}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   175
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   176
#else
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   177
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   178
#define m_two_sqr(rslt, a, err) {\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   179
  double hi, lo;\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   180
  double q = a * a;\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   181
  m_split(a, hi, lo);\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   182
  err = ((hi * hi - q) + 2.0 * hi * lo) + lo * lo;\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   183
  rslt = q;\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   184
}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   185
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   186
#endif
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   187
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   188
#define m_renorm4(c0, c1, c2, c3) {\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   189
  double s0, s1, s2 = 0.0, s3 = 0.0;\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   190
\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   191
    if (! isinf(c0)) { \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   192
\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   193
        m_quick_two_sum(s0, c2, c3, c3);\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   194
        m_quick_two_sum(s0, c1, s0, c2);\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   195
        m_quick_two_sum(c0, c0, s0, c1);\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   196
\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   197
        s0 = c0;\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   198
        s1 = c1;\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   199
        if (s1 != 0.0) {\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   200
             m_quick_two_sum(s1, s1, c2, s2);\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   201
            if (s2 != 0.0) {\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   202
                 m_quick_two_sum(s2, s2, c3, s3);\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   203
            } else {\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   204
                 m_quick_two_sum(s1, s1, c3, s2);\
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   205
            }\
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   206
        } else {\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   207
            m_quick_two_sum(s0, s0, c2, s1);\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   208
            if (s1 != 0.0) {\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   209
                 m_quick_two_sum(s1, s1, c3, s2);\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   210
            } else {\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   211
                 m_quick_two_sum(s0, s0, c3, s1);\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   212
            }\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   213
        }\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   214
\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   215
        c0 = s0;\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   216
        c1 = s1;\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   217
        c2 = s2;\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   218
        c3 = s3;\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   219
    }\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   220
}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   221
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   222
#define m_renorm5(c0, c1, c2, c3, c4) { \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   223
    double s0, s1, s2 = 0.0, s3 = 0.0; \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   224
\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   225
    if (! isinf(c0)) { \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   226
        m_two_sum(s0, c3, c4, c4); \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   227
        m_quick_two_sum(s0, c2, s0, c3); \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   228
        m_quick_two_sum(s0, c1, s0, c2); \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   229
        m_quick_two_sum(c0, c0, s0, c1); \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   230
\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   231
        s0 = c0; \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   232
        s1 = c1; \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   233
\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   234
        m_two_sum(s0, c0, c1, s1); \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   235
        if (s1 != 0.0) { \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   236
            m_quick_two_sum(s1, s1, c2, s2); \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   237
            if (s2 != 0.0) { \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   238
                m_quick_two_sum(s2 ,s2, c3, s3); \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   239
                if (s3 != 0.0) {\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   240
                    s3 += c4; \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   241
                } else {\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   242
                    s2 += c4;\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   243
                }\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   244
            } else { \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   245
                m_quick_two_sum(s1, s1, c3, s2); \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   246
                if (s2 != 0.0) {\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   247
                    m_quick_two_sum(s2, s2, c4, s3); \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   248
                } else { \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   249
                    m_quick_two_sum(s1, s1, c4, s2); \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   250
                } \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   251
            } \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   252
        } else { \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   253
            m_quick_two_sum(s0,s0, c2, s1); \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   254
            if (s1 != 0.0) { \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   255
                m_quick_two_sum(s1,s1, c3, s2); \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   256
                if (s2 != 0.0) {\
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   257
                    m_quick_two_sum(s2,s2, c4, s3); \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   258
                } else { \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   259
                    m_quick_two_sum(s1 ,s1, c4, s2); \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   260
                } \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   261
            } else { \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   262
                m_quick_two_sum(s0,s0, c3, s1); \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   263
                if (s1 != 0.0) { \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   264
                    m_quick_two_sum(s1,s1, c4, s2); \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   265
                } else { \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   266
                    m_quick_two_sum(s0,s0, c4, s1); \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   267
                } \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   268
            } \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   269
        } \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   270
 \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   271
        c0 = s0; \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   272
        c1 = s1; \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   273
        c2 = s2; \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   274
        c3 = s3; \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   275
    } \
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   276
}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   277
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   278
%}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   279
! !
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   280
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   281
!QDouble primitiveFunctions!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   282
%{
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   283
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   284
/*********** Basic Functions ************/
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   285
/* Computes fl(a+b) and err(a+b).  Assumes |a| >= |b|. */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   286
inline double 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   287
quick_two_sum(double a, double b, double *errPtr) {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   288
  double s = a + b;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   289
  *errPtr = b - (s - a);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   290
  return s;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   291
}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   292
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   293
/* Computes fl(a-b) and err(a-b).  Assumes |a| >= |b| */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   294
inline double 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   295
quick_two_diff(double a, double b, double *errPtr) {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   296
  double s = a - b;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   297
  *errPtr = (a - s) - b;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   298
  return s;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   299
}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   300
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   301
/* Computes fl(a+b) and err(a+b).  */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   302
inline double 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   303
two_sum(double a, double b, double *errPtr) {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   304
  double s = a + b;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   305
  double bb = s - a;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   306
  *errPtr = (a - (s - bb)) + (b - bb);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   307
  return s;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   308
}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   309
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   310
/* Computes fl(a-b) and err(a-b).  */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   311
inline double 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   312
two_diff(double a, double b, double *errPtr) {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   313
  double s = a - b;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   314
  double bb = s - a;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   315
  *errPtr = (a - (s - bb)) - (b + bb);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   316
  return s;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   317
}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   318
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   319
#ifndef QD_FMS
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   320
/* Computes high word and lo word of a */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   321
inline void 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   322
split(double a, double *hiPtr, double *loPtr) {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   323
  double temp;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   324
  if (a > _QD_SPLIT_THRESH || a < -_QD_SPLIT_THRESH) {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   325
    a *= 3.7252902984619140625e-09;  // 2^-28
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   326
    temp = _QD_SPLITTER * a;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   327
    *hiPtr = temp - (temp - a);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   328
    *loPtr = a - *hiPtr;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   329
    *hiPtr *= 268435456.0;          // 2^28
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   330
    *loPtr *= 268435456.0;          // 2^28
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   331
  } else {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   332
    temp = _QD_SPLITTER * a;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   333
    *hiPtr = temp - (temp - a);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   334
    *loPtr = a - *hiPtr;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   335
  }
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   336
}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   337
#endif
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   338
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   339
/* Computes fl(a*b) and err(a*b). */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   340
inline double 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   341
two_prod(double a, double b, double *errPtr) {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   342
#ifdef QD_FMS
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   343
  double p = a * b;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   344
  *errPtr = QD_FMS(a, b, p);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   345
  return p;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   346
#else
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   347
  double a_hi, a_lo, b_hi, b_lo;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   348
  double p = a * b;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   349
  split(a, &a_hi, &a_lo);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   350
  split(b, &b_hi, &b_lo);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   351
  *errPtr = ((a_hi * b_hi - p) + a_hi * b_lo + a_lo * b_hi) + a_lo * b_lo;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   352
  return p;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   353
#endif
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   354
}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   355
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   356
/* Computes fl(a*a) and err(a*a).  Faster than the above method. */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   357
inline double 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   358
two_sqr(double a, double *errPtr) {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   359
#ifdef QD_FMS
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   360
  double p = a * a;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   361
  *errPtr = QD_FMS(a, a, p);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   362
  return p;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   363
#else
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   364
  double hi, lo;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   365
  double q = a * a;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   366
  split(a, &hi, &lo);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   367
  *errPtr = ((hi * hi - q) + 2.0 * hi * lo) + lo * lo;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   368
  return q;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   369
#endif
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   370
}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   371
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   372
/* Computes the nearest integer to d. */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   373
inline double 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   374
nint(double d) {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   375
  if (d == floor(d))
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   376
    return d;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   377
  return floor(d + 0.5);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   378
}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   379
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   380
/* Computes the truncated integer. */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   381
inline double 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   382
aint(double d) {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   383
  return (d >= 0.0) ? floor(d) : ceil(d);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   384
}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   385
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   386
inline void 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   387
renorm4(double *c0Ptr, double *c1Ptr, double *c2Ptr, double *c3Ptr) {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   388
  double s0, s1, s2 = 0.0, s3 = 0.0;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   389
  double c0 = *c0Ptr;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   390
  
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   391
  if (isinf(c0)) return;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   392
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   393
  s0 = quick_two_sum(*c2Ptr, *c3Ptr, c3Ptr);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   394
  s0 = quick_two_sum(*c1Ptr, s0, c2Ptr);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   395
  c0 = quick_two_sum(c0, s0, c1Ptr);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   396
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   397
  s0 = c0;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   398
  s1 = *c1Ptr;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   399
  if (s1 != 0.0) {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   400
    s1 = quick_two_sum(s1, *c2Ptr, &s2);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   401
    if (s2 != 0.0)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   402
      s2 = quick_two_sum(s2, *c3Ptr, &s3);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   403
    else
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   404
      s1 = quick_two_sum(s1, *c3Ptr, &s2);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   405
  } else {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   406
    s0 = quick_two_sum(s0, *c2Ptr, &s1);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   407
    if (s1 != 0.0)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   408
      s1 = quick_two_sum(s1, *c3Ptr, &s2);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   409
    else
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   410
      s0 = quick_two_sum(s0, *c3Ptr, &s1);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   411
  }
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   412
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   413
  *c0Ptr = s0;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   414
  *c1Ptr = s1;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   415
  *c2Ptr = s2;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   416
  *c3Ptr = s3;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   417
}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   418
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   419
inline void 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   420
renorm5(double *c0Ptr, double *c1Ptr, double *c2Ptr, double *c3Ptr, double *c4Ptr) {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   421
  double s0, s1, s2 = 0.0, s3 = 0.0;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   422
  
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   423
  if (isinf(*c0Ptr)) return;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   424
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   425
  s0 = quick_two_sum(*c3Ptr, *c4Ptr, c4Ptr);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   426
  s0 = quick_two_sum(*c2Ptr, s0, c3Ptr);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   427
  s0 = quick_two_sum(*c1Ptr, s0, c2Ptr);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   428
  *c0Ptr = quick_two_sum(*c0Ptr, s0, c1Ptr);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   429
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   430
  s0 = *c0Ptr;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   431
  s1 = *c1Ptr;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   432
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   433
  s0 = quick_two_sum(*c0Ptr, *c1Ptr, &s1);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   434
  if (s1 != 0.0) {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   435
    s1 = quick_two_sum(s1, *c2Ptr, &s2);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   436
    if (s2 != 0.0) {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   437
      s2 =quick_two_sum(s2, *c3Ptr, &s3);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   438
      if (s3 != 0.0)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   439
        s3 += *c4Ptr;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   440
      else
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   441
        s2 += *c4Ptr;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   442
    } else {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   443
      s1 = quick_two_sum(s1, *c3Ptr, &s2);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   444
      if (s2 != 0.0)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   445
        s2 = quick_two_sum(s2, *c4Ptr, &s3);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   446
      else
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   447
        s1 = quick_two_sum(s1, *c4Ptr, &s2);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   448
    }
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   449
  } else {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   450
    s0 = quick_two_sum(s0, *c2Ptr, &s1);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   451
    if (s1 != 0.0) {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   452
      s1 = quick_two_sum(s1, *c3Ptr, &s2);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   453
      if (s2 != 0.0)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   454
        s2 = quick_two_sum(s2, *c4Ptr, &s3);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   455
      else
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   456
        s1 = quick_two_sum(s1, *c4Ptr, &s2);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   457
    } else {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   458
      s0 = quick_two_sum(s0, *c3Ptr, &s1);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   459
      if (s1 != 0.0)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   460
        s1 = quick_two_sum(s1, *c4Ptr, &s2);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   461
      else
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   462
        s0 = quick_two_sum(s0, *c4Ptr, &s1);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   463
    }
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   464
  }
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   465
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   466
  *c0Ptr = s0;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   467
  *c1Ptr = s1;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   468
  *c2Ptr = s2;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   469
  *c3Ptr = s3;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   470
}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   471
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   472
inline void 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   473
three_sum(double *aPtr, double *bPtr, double *cPtr) {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   474
  double t1, t2, t3;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   475
  t1 = two_sum(*aPtr, *bPtr, &t2);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   476
  *aPtr  = two_sum(*cPtr, t1, &t3);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   477
  *bPtr  = two_sum(t2, t3, cPtr);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   478
}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   479
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   480
inline void three_sum2(double *aPtr, double *bPtr, double *cPtr) {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   481
  double t1, t2, t3;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   482
  t1 = two_sum(*aPtr, *bPtr, &t2);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   483
  *aPtr  = two_sum(*cPtr, t1, &t3);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   484
  *bPtr = t2 + t3;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   485
}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   486
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   487
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   488
#if 0
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   489
/* These are provided to give consistent 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   490
   interface for double with double-double and quad-double. */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   491
inline void 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   492
sincosh(double t, double &sinh_t, double &cosh_t) {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   493
  sinh_t = sinh(t);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   494
  cosh_t = cosh(t);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   495
}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   496
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   497
inline double 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   498
sqr(double t) {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   499
  return t * t;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   500
}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   501
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   502
inline double 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   503
to_double(double a) { 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   504
    return a; 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   505
}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   506
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   507
inline int    
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   508
to_int(double a)    { 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   509
    return static_cast<int>(a); 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   510
}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   511
#endif
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   512
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   513
%}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   514
! !
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   515
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   516
!QDouble class methodsFor:'documentation'!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   517
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   518
copyright
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   519
"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   520
 COPYRIGHT (c) 2017 by eXept Software AG
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   521
              All Rights Reserved
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   522
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   523
 This software is furnished under a license and may be used
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   524
 only in accordance with the terms of that license and with the
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   525
 inclusion of the above copyright notice.   This software may not
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   526
 be provided or otherwise made available to, or used by, any
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   527
 other person.  No title to or ownership of the software is
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   528
 hereby transferred.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   529
"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   530
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   531
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   532
documentation
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   533
"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   534
    QDoubles represent rational numbers with extended, but still limited precision.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   535
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   536
    In contrast to Floats (which use the C-compilers native 64bit 'double' format),
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   537
    QDoubles give you 212 bit or approx. 64 decimal digits of precision.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   538
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   539
    Representation:
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   540
        QDoubles use 4 IEEE doubles, each keeping 53 bits of precision.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   541
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   542
    Range and Precision of Storage Formats: see LimitedPrecisionReal >> documentation
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   543
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   544
    [author:]
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   545
        Claus Gittinger
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   546
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   547
    [see also:]
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   548
        Number
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   549
        Float ShortFloat Fraction FixedPoint Integer Complex
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   550
        FloatArray DoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   551
"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   552
! !
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   553
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   554
!QDouble class methodsFor:'instance creation'!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   555
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   556
basicNew
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   557
    "return a new quad-precision double - here we return 0.0
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   558
     Notice that numbers are usually NOT created this way ...
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   559
     It's implemented here to allow things like binary store & load
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   560
     of floats. (but even this support will go away eventually, it's not
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   561
     a good idea to store the bits of a float - the reader might have a
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   562
     totally different representation - so floats should be
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   563
     binary stored in a device independent format."
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   564
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   565
%{  /* NOCONTEXT */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   566
#ifdef __SCHTEAM__
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   567
    ERROR("trying to instantiate a quad double");
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   568
#else
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   569
    OBJ newFloat;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   570
printf("xxx\n");
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   571
    __qNew(newFloat, sizeof(struct __quadDoubleStruct));              
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   572
    __stx_setClass(newFloat, QDouble);                         
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   573
    __QuadDoubleInstPtr(newFloat)->d_quadDoubleValue[0] = 0.0;        
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   574
    __QuadDoubleInstPtr(newFloat)->d_quadDoubleValue[1] = 0.0;        
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   575
    __QuadDoubleInstPtr(newFloat)->d_quadDoubleValue[2] = 0.0;        
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   576
    __QuadDoubleInstPtr(newFloat)->d_quadDoubleValue[3] = 0.0;        
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   577
    RETURN (newFloat);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   578
#endif /* not SCHTEAM */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   579
%}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   580
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   581
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   582
     self basicNew
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   583
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   584
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   585
    "Created: / 12-06-2017 / 16:00:38 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   586
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   587
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   588
d0:d0 d1:d1 d2:d2 d3:d3
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   589
    "return a new quad-precision double from individual double components"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   590
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   591
%{  /* NOCONTEXT */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   592
#ifdef __SCHTEAM__
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   593
    ERROR("trying to instantiate a quad double");
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   594
#else
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   595
    OBJ newQD;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   596
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   597
    if (__isFloatLike(d0) 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   598
     && __isFloatLike(d1)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   599
     && __isFloatLike(d2)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   600
     && __isFloatLike(d3)) {    
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   601
        __qNew_qdReal(newQD, __floatVal(d0), __floatVal(d1),        
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   602
                             __floatVal(d2), __floatVal(d3));        
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   603
        RETURN (newQD);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   604
    }
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   605
#endif
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   606
%}.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   607
    self error:'invalid argument'
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   608
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   609
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   610
     self d0: 3.141592653589793116e+00
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   611
          d1: 1.224646799147353207e-16
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   612
          d2: -2.994769809718339666e-33
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   613
          d3: 1.112454220863365282e-49
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   614
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   615
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   616
    "Created: / 12-06-2017 / 20:17:14 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   617
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   618
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   619
fromDoubleArray:aDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   620
    "return a new quad-precision double from coercing a double array"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   621
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   622
%{  /* NOCONTEXT */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   623
#ifdef __SCHTEAM__
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   624
    ERROR("trying to instantiate a quad double");
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   625
#else
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   626
    OBJ newQD;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   627
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   628
    if (__isDoubleArray(aDoubleArray)) {    
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   629
        __qNew_qdReal(newQD, 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   630
                    __DoubleArrayInstPtr(aDoubleArray)->d_element[0],        
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   631
                    __DoubleArrayInstPtr(aDoubleArray)->d_element[1],        
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   632
                    __DoubleArrayInstPtr(aDoubleArray)->d_element[2],        
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   633
                    __DoubleArrayInstPtr(aDoubleArray)->d_element[3]);        
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   634
        RETURN (newQD);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   635
    }
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   636
#endif
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   637
%}.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   638
    self error:'invalid argument'
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   639
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   640
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   641
     self fromDoubleArray(DoubleArray 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   642
                                with: 3.141592653589793116e+00
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   643
                                with: 1.224646799147353207e-16
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   644
                                with: -2.994769809718339666e-33
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   645
                                with: 1.112454220863365282e-49)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   646
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   647
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   648
    "Created: / 12-06-2017 / 18:25:32 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   649
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   650
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   651
fromFloat:aFloat
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   652
    "return a new quad-precision double from coercing aFloat"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   653
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   654
%{  /* NOCONTEXT */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   655
#ifdef __SCHTEAM__
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   656
    ERROR("trying to instantiate a quad double");
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   657
#else
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   658
    double dVal;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   659
    OBJ newFloat;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   660
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   661
    if (__isFloatLike(aFloat)) {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   662
        dVal = __floatVal(aFloat);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   663
    } else if (__isShortFloat(aFloat)) {       
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   664
        dVal = __shortFloatVal(aFloat);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   665
    } else {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   666
        goto badArg;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   667
    }    
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   668
        
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   669
    __qNew(newFloat, sizeof(struct __quadDoubleStruct));              
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   670
    __stx_setClass(newFloat, QDouble);                         
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   671
    __QuadDoubleInstPtr(newFloat)->d_quadDoubleValue[0] = dVal;        
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   672
    __QuadDoubleInstPtr(newFloat)->d_quadDoubleValue[1] = 0.0;        
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   673
    __QuadDoubleInstPtr(newFloat)->d_quadDoubleValue[2] = 0.0;        
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   674
    __QuadDoubleInstPtr(newFloat)->d_quadDoubleValue[3] = 0.0;        
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   675
    RETURN (newFloat);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   676
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   677
badArg: ;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   678
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   679
#endif
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   680
%}.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   681
    self error:'invalid argument'
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   682
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   683
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   684
     self fromFloat:1.0
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   685
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   686
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   687
    "Created: / 12-06-2017 / 16:06:54 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   688
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   689
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   690
fromInteger:anInteger
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   691
    "return a new quad-precision double from coercing anInteger"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   692
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   693
%{  /* NOCONTEXT */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   694
#ifndef __SCHTEAM__
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   695
    OBJ newFloat;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   696
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   697
    if (__isSmallInteger(anInteger)) {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   698
        __qNew(newFloat, sizeof(struct __quadDoubleStruct));              
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   699
        __stx_setClass(newFloat, QDouble);                         
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   700
        __QuadDoubleInstPtr(newFloat)->d_quadDoubleValue[0] = (double)(__smallIntegerVal(anInteger));        
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   701
        __QuadDoubleInstPtr(newFloat)->d_quadDoubleValue[1] = 0.0;        
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   702
        __QuadDoubleInstPtr(newFloat)->d_quadDoubleValue[2] = 0.0;        
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   703
        __QuadDoubleInstPtr(newFloat)->d_quadDoubleValue[3] = 0.0;        
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   704
        RETURN (newFloat);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   705
    }
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   706
#endif
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   707
%}.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   708
    ^ super fromInteger:anInteger
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   709
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   710
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   711
     self fromInteger:2
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   712
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   713
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   714
    "Created: / 12-06-2017 / 16:10:10 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   715
! !
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   716
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   717
!QDouble class methodsFor:'constants'!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   718
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   719
e
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   720
    "return the constant e as quad precision double.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   721
     (returns approx. 212 bits of precision)"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   722
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   723
    E isNil ifTrue:[
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   724
        E := self fromDoubleArray(DoubleArray 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   725
                                    with: 2.718281828459045091e+00
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   726
                                    with: 1.445646891729250158e-16
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   727
                                    with: -2.127717108038176765e-33
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   728
                                    with: 1.515630159841218954e-49)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   729
    ].    
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   730
    ^ E
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   731
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   732
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   733
     self e
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   734
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   735
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   736
    "Created: / 12-06-2017 / 18:29:36 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   737
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   738
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   739
ln10
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   740
    "return the constant e as quad precision double.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   741
     (returns approx. 212 bits of precision)"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   742
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   743
    Ln10 isNil ifTrue:[
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   744
        Ln10 := self fromDoubleArray(DoubleArray 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   745
                                    with: 2.302585092994045901e+00
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   746
                                    with: -2.170756223382249351e-16
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   747
                                    with: -9.984262454465776570e-33
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   748
                                    with: -4.023357454450206379e-49)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   749
    ].    
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   750
    ^ Ln10
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   751
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   752
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   753
     self ln10
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   754
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   755
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   756
    "Created: / 12-06-2017 / 18:32:29 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   757
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   758
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   759
ln2
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   760
    "return the constant e as quad precision double.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   761
     (returns approx. 212 bits of precision)"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   762
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   763
    Ln2 isNil ifTrue:[
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   764
        Ln2 := self fromDoubleArray(DoubleArray 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   765
                                    with: 6.931471805599452862e-01
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   766
                                    with: 2.319046813846299558e-17
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   767
                                    with: 5.707708438416212066e-34
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   768
                                    with: -3.582432210601811423e-50)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   769
    ].    
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   770
    ^ Ln2
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   771
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   772
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   773
     self ln2
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   774
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   775
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   776
    "Created: / 12-06-2017 / 18:31:34 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   777
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   778
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   779
pi
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   780
    "return the constant pi as quad precision double.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   781
     (returns approx. 212 bits of precision)"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   782
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   783
    Pi isNil ifTrue:[
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   784
        Pi := self fromDoubleArray(DoubleArray 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   785
                                    with: 3.141592653589793116e+00
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   786
                                    with: 1.224646799147353207e-16
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   787
                                    with: -2.994769809718339666e-33
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   788
                                    with: 1.112454220863365282e-49)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   789
    ].    
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   790
    ^ Pi
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   791
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   792
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   793
     self pi
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   794
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   795
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   796
    "Created: / 12-06-2017 / 18:27:13 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   797
! !
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   798
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   799
!QDouble class methodsFor:'queries'!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   800
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   801
epsilon
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   802
    "return the maximum relative spacing of instances of mySelf
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   803
     (i.e. the value-delta of the least significant bit)"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   804
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   805
    ^ Float epsilon
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   806
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   807
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   808
     Float epsilon
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   809
     ShortFloat epsilon
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   810
     QDouble epsilon
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   811
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   812
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   813
    "Created: / 12-06-2017 / 18:52:44 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   814
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   815
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   816
numBitsInExponent
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   817
    "answer the number of bits in the exponent"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   818
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   819
    ^ Float numBitsInExponent
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   820
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   821
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   822
     1.0 asQDouble class numBitsInExponent
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   823
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   824
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   825
    "Created: / 12-06-2017 / 11:11:04 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   826
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   827
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   828
numBitsInMantissa
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   829
    "answer the number of bits in the mantissa"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   830
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   831
    ^ Float precision * 4
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   832
    
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   833
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   834
     1.0 class numBitsInMantissa
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   835
     1.0 asShortFloat class numBitsInMantissa
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   836
     1.0 asLongFloat class numBitsInMantissa
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   837
     1.0 asDDouble class numBitsInMantissa
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   838
     1.0 asQDouble class numBitsInMantissa
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   839
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   840
     Float numBitsInMantissa
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   841
     ShortFloat numBitsInMantissa
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   842
     QDouble numBitsInMantissa
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   843
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   844
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   845
    "Created: / 12-06-2017 / 11:13:44 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   846
    "Modified: / 12-06-2017 / 18:48:48 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   847
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   848
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   849
precision
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   850
    "answer the number of bits in the mantissa"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   851
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   852
    ^ Float precision * 4
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   853
    
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   854
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   855
     1.0 class numBitsInMantissa
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   856
     1.0 asShortFloat class numBitsInMantissa
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   857
     1.0 asLongFloat class numBitsInMantissa
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   858
     1.0 asDDouble class numBitsInMantissa
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   859
     1.0 asQDouble class numBitsInMantissa
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   860
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   861
     Float numBitsInMantissa
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   862
     ShortFloat numBitsInMantissa
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   863
     QDouble numBitsInMantissa
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   864
     QDouble precision
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   865
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   866
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   867
    "Created: / 12-06-2017 / 18:49:11 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   868
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   869
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   870
radix
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   871
    "answer the radix of a Floats exponent
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   872
     This is an IEEE float, which is represented as binary"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   873
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   874
    ^ Float radix
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   875
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   876
    "Created: / 12-06-2017 / 18:50:04 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   877
! !
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   878
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   879
!QDouble methodsFor:'arithmetic'!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   880
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   881
* aNumber
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   882
    "return the product of the receiver and the argument, aNumber"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   883
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   884
    ^ aNumber productFromQDouble:self
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   885
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   886
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   887
     ((QDouble fromFloat:1e20) + (QDouble fromFloat:1.0)) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   888
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   889
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   890
    "Created: / 13-06-2017 / 01:00:47 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   891
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   892
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   893
+ aNumber
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   894
    "return the sum of the receiver and the argument, aNumber"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   895
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   896
    ^ aNumber sumFromQDouble:self
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   897
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   898
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   899
     ((QDouble fromFloat:1e20) + (QDouble fromFloat:1.0)) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   900
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   901
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   902
    "Created: / 12-06-2017 / 16:17:46 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   903
    "Modified: / 12-06-2017 / 23:06:22 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   904
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   905
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   906
- aNumber
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   907
    "return the sum of the receiver and the argument, aNumber"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   908
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   909
    ^ (aNumber negated) sumFromQDouble:self
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   910
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   911
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   912
     (QDouble fromFloat:1e20) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   913
     ((QDouble fromFloat:1e20) - (QDouble fromFloat:1.0)) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   914
     (QDouble fromFloat:1e-20) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   915
     ((QDouble fromFloat:1e-20) - (QDouble fromFloat:1.0)) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   916
     ((QDouble fromFloat:2.0) - (QDouble fromFloat:1.0)) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   917
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   918
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   919
    "Created: / 12-06-2017 / 23:41:39 / cg"
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   920
!
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   921
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   922
/ aNumber
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   923
    "return the quotient of the receiver and the argument, aNumber"
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   924
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   925
    ^ aNumber quotientFromQDouble:self
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   926
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   927
    "
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   928
     ((QDouble fromFloat:1e20) / (QDouble fromFloat:2.0)) asDoubleArray
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   929
    "
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   930
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   931
    "Created: / 13-06-2017 / 17:59:09 / cg"
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   932
! !
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   933
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   934
!QDouble methodsFor:'coercing & converting'!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   935
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   936
asDoubleArray
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   937
    ^ DoubleArray 
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   938
            with:self d0 
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   939
            with:self d1 
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   940
            with:self d2 
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   941
            with:self d3.
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   942
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   943
    "
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   944
     (QDouble fromFloat:1.0) asDoubleArray
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   945
     (QDouble fromFloat:2.0) asDoubleArray
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   946
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   947
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   948
    "Created: / 12-06-2017 / 18:19:19 / cg"
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   949
    "Modified (comment): / 13-06-2017 / 17:58:09 / cg"
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   950
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   951
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   952
asFloat
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   953
    ^ self d0
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   954
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   955
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   956
     (QDouble fromFloat:1.0) asFloat
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   957
     (QDouble fromFloat:2.0) asFloat
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   958
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   959
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   960
    "Created: / 12-06-2017 / 18:15:27 / cg"
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   961
    "Modified: / 13-06-2017 / 17:56:50 / cg"
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   962
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   963
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   964
coerce:aNumber
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   965
    "convert the argument aNumber into an instance of the receiver's class and return it."
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   966
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   967
    ^ aNumber asQDouble
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   968
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   969
    "Created: / 12-06-2017 / 17:13:47 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   970
    "Modified: / 12-06-2017 / 21:09:06 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   971
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   972
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   973
generality
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   974
    "return the generality value - see ArithmeticValue>>retry:coercing:"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   975
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   976
    ^ 95
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   977
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   978
    "Created: / 12-06-2017 / 17:13:14 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   979
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   980
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   981
negative
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   982
    ^ self d0 negative
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   983
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   984
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   985
     (QDouble fromFloat:0.0) negative
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   986
     (QDouble fromFloat:1.0) negative
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   987
     (QDouble fromFloat:-1.0) negative
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   988
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   989
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   990
    "Created: / 13-06-2017 / 01:57:39 / cg"
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   991
    "Modified: / 13-06-2017 / 17:58:26 / cg"
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   992
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   993
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   994
positive
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   995
    ^ self d0 positive
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   996
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   997
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   998
     (QDouble fromFloat:1.0) positive
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   999
     (QDouble fromFloat:-1.0) positive
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1000
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1001
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1002
    "Created: / 13-06-2017 / 01:56:53 / cg"
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1003
    "Modified: / 13-06-2017 / 17:58:41 / cg"
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1004
! !
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1005
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1006
!QDouble methodsFor:'comparing'!
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1007
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1008
< aNumber
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1009
    "return true, if the argument, aNumber is greater than the receiver"
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1010
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1011
    ^ aNumber lessFromQDouble:self
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1012
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1013
    "Created: / 13-06-2017 / 16:58:53 / cg"
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1014
!
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1015
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1016
= aNumber
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1017
    "return true, if the argument, aNumber has the same value as than the receiver"
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1018
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1019
    ^ aNumber equalFromQDouble:self
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1020
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1021
    "Created: / 13-06-2017 / 17:12:09 / cg"
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1022
! !
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1023
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1024
!QDouble methodsFor:'double dispatching'!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1025
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1026
differenceFromFloat:aFloat
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1027
    "aFloat - self"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1028
    
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1029
    ^ aFloat + (self negated)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1030
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1031
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1032
     1.0 - (QDouble fromFloat:1.0)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1033
     1e20 - (QDouble fromFloat:1.0)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1034
     (1.0 - (QDouble fromFloat:1.0)) asFloat
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1035
     (1e20 - (QDouble fromFloat:1.0)) asFloat
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1036
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1037
     (1.0 - (QDouble fromFloat:1.0)) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1038
     (1e20 - (QDouble fromFloat:1.0)) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1039
     (1e20 - (QDouble fromFloat:1.0) + 1e-20) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1040
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1041
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1042
    "Created: / 12-06-2017 / 23:38:05 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1043
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1044
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1045
differenceFromQDouble:aQDouble
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1046
    "aQDouble - self"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1047
    
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1048
    ^ aQDouble + (self negated)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1049
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1050
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1051
     1.0 - (QDouble fromFloat:1.0)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1052
     1e20 - (QDouble fromFloat:1.0)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1053
     (1.0 - (QDouble fromFloat:1.0)) asFloat
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1054
     (1e20 - (QDouble fromFloat:1.0)) asFloat
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1055
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1056
     (1.0 - (QDouble fromFloat:1.0)) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1057
     (1e20 - (QDouble fromFloat:1.0)) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1058
     (1e20 - (QDouble fromFloat:1.0) + 1e-20) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1059
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1060
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1061
    "Created: / 12-06-2017 / 23:38:19 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1062
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1063
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1064
equalFromQDouble:aQDouble
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1065
%{
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1066
    if (__Class(aQDouble) == QDouble) {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1067
        double *a = __QuadDoubleInstPtr(self)->d_quadDoubleValue;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1068
        double *b = __QuadDoubleInstPtr(aQDouble)->d_quadDoubleValue;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1069
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1070
        RETURN ((a[0] == b[0] 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1071
                && a[1] == b[1] 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1072
                && a[2] == b[2] 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1073
                && a[3] == b[3]) ? true : false);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1074
    }
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1075
%}.
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1076
    ^ (aQDouble d0 = self d0)
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1077
    and:[ (aQDouble d1 = self d1)
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1078
    and:[ (aQDouble d2 = self d2)
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1079
    and:[ (aQDouble d3 = self d3) ]]]
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1080
    
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1081
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1082
     (QDouble fromFloat:1.0) = (QDouble fromFloat:1.0)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1083
     (QDouble fromFloat:1.0) = 1.0
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1084
     1.0 = (QDouble fromFloat:1.0)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1085
   "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1086
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1087
    "Created: / 13-06-2017 / 03:01:19 / cg"
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1088
    "Modified: / 13-06-2017 / 18:01:52 / cg"
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1089
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1090
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1091
lessFromQDouble:aQDouble
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1092
    "sent when aQDouble does not know how to compare to the receiver..
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1093
     Return true if aQDouble < self"
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1094
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1095
%{
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1096
    if (__Class(aQDouble) == QDouble) {
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1097
        double *a = __QuadDoubleInstPtr(aQDouble)->d_quadDoubleValue;
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1098
        double *b = __QuadDoubleInstPtr(self)->d_quadDoubleValue;
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1099
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1100
        // now compare if a < b!
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1101
        RETURN 
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1102
            ((a[0] < b[0] || 
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1103
              (a[0] == b[0] && (a[1] < b[1] ||
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1104
                (a[1] == b[1] && (a[2] < b[2] ||
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1105
                  (a[2] == b[2] && a[3] < b[3])))))) ? true : false);
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1106
    }
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1107
%}.
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1108
    ^ super lessFromQDouble:aQDouble
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1109
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1110
    "
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1111
     (1.0 + 1e-40) > 1.0
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1112
     ((QDouble fromFloat:1.0) + (QDouble fromFloat:1e-40)) > (QDouble fromFloat:1.0)
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1113
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1114
     (QDouble fromFloat:1.0) > (QDouble fromFloat:1.0)
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1115
     (QDouble fromFloat:1.1) > (QDouble fromFloat:1.0)
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1116
     (QDouble fromFloat:1.0) > 1.0
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1117
     (QDouble fromFloat:1.1) > 1.0
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1118
     1.0 > (QDouble fromFloat:1.0)
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1119
   "
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1120
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1121
    "Created: / 13-06-2017 / 17:07:47 / cg"
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1122
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1123
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1124
productFromFloat:aFloat
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1125
%{
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1126
    if (__isFloatLike(aFloat)) {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1127
        double *a = __QuadDoubleInstPtr(self)->d_quadDoubleValue; 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1128
        double b = __floatVal(aFloat);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1129
        double p0, p1, p2, p3;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1130
        double q0, q1, q2;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1131
        double s0, s1, s2, s3, s4;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1132
        OBJ newQD;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1133
        
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1134
        m_two_prod(p0, a[0], b, q0);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1135
        m_two_prod(p1, a[1], b, q1);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1136
        m_two_prod(p2, a[2], b, q2);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1137
        p3 = a[3] * b;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1138
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1139
        s0 = p0;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1140
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1141
        m_two_sum(s1, q0, p1, s2);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1142
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1143
        m_three_sum(s2, q1, p2);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1144
        
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1145
        m_three_sum2(q1, q2, p3);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1146
        s3 = q1;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1147
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1148
        s4 = q2 + p2;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1149
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1150
        m_renorm5(s0, s1, s2, s3, s4);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1151
        __qNew_qdReal(newQD, s0, s1, s2, s3);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1152
        RETURN( newQD );
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1153
    }
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1154
%}.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1155
    ^ super productFromFloat:aFloat.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1156
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1157
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1158
     2.0 * (QDouble fromFloat:1.0)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1159
     1e20 * (QDouble fromFloat:1.0)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1160
     (2.0 * (QDouble fromFloat:1.0)) asFloat
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1161
     (1e20 * (QDouble fromFloat:1.0)) asFloat
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1162
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1163
     (1e20 * (QDouble fromFloat:1.0) * 1e-20) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1164
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1165
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1166
    "Created: / 13-06-2017 / 00:58:56 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1167
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1168
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1169
productFromQDouble:aQDouble
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1170
%{
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1171
    if (__Class(aQDouble) == QDouble) {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1172
        double *a = __QuadDoubleInstPtr(self)->d_quadDoubleValue;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1173
        double *b = __QuadDoubleInstPtr(aQDouble)->d_quadDoubleValue;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1174
        OBJ newQD;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1175
// sloppy        
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1176
        double p0, p1, p2, p3, p4, p5;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1177
        double q0, q1, q2, q3, q4, q5;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1178
        double t0, t1;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1179
        double s0, s1, s2;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1180
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1181
        m_two_prod(p0, a[0], b[0], q0);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1182
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1183
        m_two_prod(p1, a[0], b[1], q1);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1184
        m_two_prod(p2, a[1], b[0], q2);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1185
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1186
        m_two_prod(p3, a[0], b[2], q3);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1187
        m_two_prod(p4, a[1], b[1], q4);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1188
        m_two_prod(p5, a[2], b[0], q5);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1189
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1190
        /* Start Accumulation */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1191
        m_three_sum(p1, p2, q0);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1192
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1193
        /* Six-Three Sum  of p2, q1, q2, p3, p4, p5. */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1194
        m_three_sum(p2, q1, q2);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1195
        m_three_sum(p3, p4, p5);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1196
        /* compute (s0, s1, s2) = (p2, q1, q2) + (p3, p4, p5). */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1197
        m_two_sum(s0, p2, p3, t0);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1198
        m_two_sum(s1, q1, p4, t1);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1199
        s2 = q2 + p5;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1200
        m_two_sum(s1, s1, t0, t0);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1201
        s2 += (t0 + t1);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1202
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1203
        /* O(eps^3) order terms */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1204
        s1 += a[0]*b[3] + a[1]*b[2] + a[2]*b[1] + a[3]*b[0] + q0 + q3 + q4 + q5;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1205
        m_renorm5(p0, p1, s0, s1, s2);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1206
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1207
        __qNew_qdReal(newQD, p0, p1, s0, s1);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1208
        RETURN( newQD );
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1209
    }
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1210
%}.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1211
    ^ super productFromQDouble:aQDouble.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1212
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1213
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1214
     2.0 * (QDouble fromFloat:1.0)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1215
     1e20 * (QDouble fromFloat:1.0)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1216
     (2.0 * (QDouble fromFloat:1.0)) asFloat
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1217
     (1e20 * (QDouble fromFloat:1.0)) asFloat
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1218
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1219
     (1e20 * (QDouble fromFloat:1.0) * 1e-20) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1220
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1221
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1222
    "Created: / 13-06-2017 / 01:06:22 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1223
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1224
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1225
quotientFromQDouble:aQDouble
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1226
    "sloppy"
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1227
    
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1228
    |q0 q1 q2 q3 r|
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1229
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1230
    q0 := self d0 / aQDouble d0.
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1231
    r := self - (aQDouble * q0).
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1232
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1233
    q1 := r d0 / aQDouble d0.
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1234
    r := r - (aQDouble * q1).
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1235
    
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1236
    q2 := r d0 / aQDouble d0.
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1237
    r := r - (aQDouble * q2).
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1238
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1239
    q3 := r d0 / aQDouble d0.
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1240
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1241
    r := self class d0:q0 d1:q1 d2:q2 d3:q3.
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1242
    r renorm.
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1243
    ^ r
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1244
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1245
    "
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1246
     2.0 / (QDouble fromFloat:2.0)
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1247
     1e20 / (QDouble fromFloat:1.0)
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1248
     (2.0 / (QDouble fromFloat:1.0)) asFloat
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1249
     (1e20 / (QDouble fromFloat:1.0)) asFloat
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1250
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1251
     (QDouble fromFloat:2.0) / 2.0
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1252
     (QDouble fromFloat:1e20) / 2.0
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1253
     ((QDouble fromFloat:1.0) / 2.0) asFloat
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1254
     ((QDouble fromFloat:1e20 / 2.0)) asFloat
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1255
     
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1256
     ((1e20 + (QDouble fromFloat:1.0) + 1e-20) / 2.0) asDoubleArray
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1257
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1258
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1259
    "Created: / 13-06-2017 / 17:50:35 / cg"
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1260
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1261
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1262
sumFromFloat:aFloat
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1263
%{
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1264
    if (__isFloatLike(aFloat)) {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1265
        double *a = __QuadDoubleInstPtr(self)->d_quadDoubleValue; 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1266
        double b = __floatVal(aFloat);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1267
        double c0, c1, c2, c3;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1268
        double e;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1269
        OBJ newQD;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1270
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1271
        m_two_sum(c0, a[0], b, e);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1272
        m_two_sum(c1 ,a[1], e, e);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1273
        m_two_sum(c2, a[2], e, e);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1274
        m_two_sum(c3, a[3], e, e);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1275
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1276
        m_renorm5(c0, c1, c2, c3, e);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1277
        __qNew_qdReal(newQD, c0, c1, c2, c3);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1278
        RETURN( newQD );
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1279
    }
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1280
%}.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1281
    ^ super sumFromFloat:aFloat.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1282
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1283
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1284
     1.0 + (QDouble fromFloat:1.0)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1285
     1e20 + (QDouble fromFloat:1.0)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1286
     (1.0 + (QDouble fromFloat:1.0)) asFloat
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1287
     (1e20 + (QDouble fromFloat:1.0)) asFloat
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1288
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1289
     (1.0 + (QDouble fromFloat:1.0)) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1290
     (1e20 + (QDouble fromFloat:1.0)) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1291
     (1e20 + (QDouble fromFloat:1.0) + 1e-20) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1292
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1293
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1294
    "Created: / 12-06-2017 / 17:16:41 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1295
    "Modified: / 12-06-2017 / 22:57:03 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1296
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1297
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1298
sumFromQDouble:aQDouble
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1299
%{
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1300
    if (__Class(aQDouble) == QDouble) {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1301
        double *a = __QuadDoubleInstPtr(self)->d_quadDoubleValue;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1302
        double *b = __QuadDoubleInstPtr(aQDouble)->d_quadDoubleValue;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1303
        OBJ newQD;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1304
        
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1305
#ifndef QD_IEEE_ADD
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1306
        // sloppy_add...
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1307
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1308
        /*
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1309
        double s0, s1, s2, s3;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1310
        double t0, t1, t2, t3;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1311
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1312
        m_two_sum(s0, a[0], b[0], t0);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1313
        m_two_sum(s1, a[1], b[1], t1);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1314
        m_two_sum(s2, a[2], b[2], t2);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1315
        m_two_sum(s3, a[3], b[3], t3);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1316
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1317
        m_two_sum(s1, s1, t0, t0);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1318
        m_three_sum(s2, t0, t1);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1319
        m_three_sum2(s3, t0, t2);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1320
        t0 = t0 + t1 + t3;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1321
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1322
        m_renorm5(s0, s1, s2, s3, t0);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1323
        return qd_real(s0, s1, s2, s3, t0);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1324
        */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1325
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1326
        /* Same as above, but addition re-organized to minimize
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1327
           data dependency ... unfortunately some compilers are
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1328
           not very smart to do this automatically */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1329
        double s0, s1, s2, s3;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1330
        double t0, t1, t2, t3;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1331
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1332
        double v0, v1, v2, v3;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1333
        double u0, u1, u2, u3;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1334
        double w0, w1, w2, w3;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1335
        
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1336
        s0 = a[0] + b[0];
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1337
        s1 = a[1] + b[1];
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1338
        s2 = a[2] + b[2];
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1339
        s3 = a[3] + b[3];
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1340
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1341
        v0 = s0 - a[0];
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1342
        v1 = s1 - a[1];
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1343
        v2 = s2 - a[2];
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1344
        v3 = s3 - a[3];
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1345
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1346
        u0 = s0 - v0;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1347
        u1 = s1 - v1;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1348
        u2 = s2 - v2;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1349
        u3 = s3 - v3;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1350
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1351
        w0 = a[0] - u0;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1352
        w1 = a[1] - u1;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1353
        w2 = a[2] - u2;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1354
        w3 = a[3] - u3;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1355
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1356
        u0 = b[0] - v0;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1357
        u1 = b[1] - v1;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1358
        u2 = b[2] - v2;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1359
        u3 = b[3] - v3;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1360
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1361
        t0 = w0 + u0;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1362
        t1 = w1 + u1;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1363
        t2 = w2 + u2;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1364
        t3 = w3 + u3;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1365
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1366
        m_two_sum(s1, s1, t0, t0);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1367
        m_three_sum(s2, t0, t1);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1368
        m_three_sum2(s3, t0, t2);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1369
        t0 = t0 + t1 + t3;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1370
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1371
        /* renormalize */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1372
        m_renorm5(s0, s1, s2, s3, t0);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1373
        __qNew_qdReal(newQD, s0, s1, s2, s3);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1374
        RETURN(newQD);                 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1375
#else
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1376
        // ieee_add...
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1377
        int i, j, k;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1378
        double s, t;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1379
        double u, v;   /* double-length accumulator */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1380
        double x[4] = {0.0, 0.0, 0.0, 0.0};
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1381
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1382
        i = j = k = 0;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1383
        if (abs(a[i]) > abs(b[j]))
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1384
          u = a[i++];
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1385
        else
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1386
          u = b[j++];
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1387
        if (abs(a[i]) > abs(b[j]))
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1388
          v = a[i++];
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1389
        else
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1390
          v = b[j++];
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1391
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1392
        u = quick_two_sum(u, v, v);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1393
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1394
        while (k < 4) {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1395
          if (i >= 4 && j >= 4) {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1396
            x[k] = u;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1397
            if (k < 3)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1398
              x[++k] = v;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1399
            break;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1400
          }
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1401
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1402
          if (i >= 4)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1403
            t = b[j++];
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1404
          else if (j >= 4)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1405
            t = a[i++];
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1406
          else if (abs(a[i]) > abs(b[j])) {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1407
            t = a[i++];
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1408
          } else
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1409
            t = b[j++];
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1410
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1411
          s = quick_three_accum(u, v, t);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1412
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1413
          if (s != 0.0) {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1414
            x[k++] = s;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1415
          }
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1416
        }
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1417
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1418
        /* add the rest. */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1419
        for (k = i; k < 4; k++)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1420
          x[3] += a[k];
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1421
        for (k = j; k < 4; k++)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1422
          x[3] += b[k];
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1423
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1424
        m_renorm4(x[0], x[1], x[2], x[3]);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1425
        __qNew_qdReal(newQD, x[0], x[1], x[2], x[3]);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1426
        RETURN(newQD);                 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1427
#endif
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1428
    }
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1429
%}.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1430
    ^ super sumFromQDouble:aQDouble
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1431
    
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1432
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1433
     (QDouble fromFloat:1.0) + (QDouble fromFloat:1.0)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1434
     (QDouble fromFloat:1.0) + 1.0
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1435
     1.0 + (QDouble fromFloat:1.0)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1436
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1437
     ((QDouble fromFloat:1.0) + (QDouble fromFloat:1.0)) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1438
     ((QDouble fromFloat:1.0) + 1.0) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1439
     (1.0 + (QDouble fromFloat:1.0)) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1440
     (1e-20 + (QDouble fromFloat:1.0)) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1441
     (1e20 + (QDouble fromFloat:1.0)) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1442
   "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1443
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1444
    "Created: / 12-06-2017 / 21:15:43 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1445
    "Modified: / 13-06-2017 / 00:30:45 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1446
! !
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1447
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1448
!QDouble methodsFor:'inspecting'!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1449
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1450
inspectorExtraAttributes
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1451
    "extra (pseudo instvar) entries to be shown in an inspector."
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1452
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1453
    ^ super inspectorExtraAttributes
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1454
        add:'-{doubles}' ->
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1455
            [
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1456
                self asDoubleArray printString
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1457
            ];
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1458
        yourself
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1459
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1460
    "Created: / 12-06-2017 / 23:43:05 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1461
! !
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1462
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1463
!QDouble methodsFor:'mathematical functions'!
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1464
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1465
floor
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1466
    "return the receiver truncated towards negative infinity"
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1467
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1468
%{
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1469
    double *a = __QuadDoubleInstPtr(self)->d_quadDoubleValue;
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1470
    OBJ newQD;
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1471
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1472
    double x0, x1, x2, x3;
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1473
    x1 = x2 = x3 = 0.0;
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1474
    x0 =floor(a[0]);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1475
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1476
    if (x0 == a[0]) {
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1477
        x1 = floor(a[1]);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1478
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1479
        if (x1 == a[1]) {
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1480
            x2 = floor(a[2]);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1481
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1482
            if (x2 == a[2]) {
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1483
                x3 = floor(a[3]);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1484
            }
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1485
        }
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1486
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1487
        m_renorm4(x0, x1, x2, x3);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1488
        __qNew_qdReal(newQD, x0, x1, x2, x3);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1489
        RETURN( newQD );
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1490
    }
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1491
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1492
    __qNew_qdReal(newQD, x0, x1, x2, x3);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1493
    RETURN( newQD );
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1494
%}.
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1495
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1496
    "
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1497
     (QDouble fromFloat:4.0) floor
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1498
     (QDouble fromFloat:4.1) floor
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1499
     (QDouble fromFloat:0.1) floor
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1500
     (0.1 + (QDouble fromFloat:1.0)) floor
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1501
     (1e20 + (QDouble fromFloat:1.0)) floor 
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1502
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1503
     (QDouble fromFloat:1.5) floor
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1504
     (QDouble fromFloat:0.5) floor
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1505
     (QDouble fromFloat:-0.5) floor
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1506
     (QDouble fromFloat:-1.5) floor
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1507
    "
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1508
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1509
    "Created: / 13-06-2017 / 01:52:44 / cg"
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1510
    "Modified (comment): / 13-06-2017 / 17:33:19 / cg"
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1511
!
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1512
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1513
negated
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1514
    ^ self class 
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1515
        d0:(self d0) negated 
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1516
        d1:(self d1) negated 
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1517
        d2:(self d2) negated 
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1518
        d3:(self d3) negated
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1519
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1520
    "    
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1521
     (QDouble fromFloat:1.0) negated
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1522
     ((QDouble fromFloat:1e20) + (QDouble fromFloat:1.0)) negated asDoubleArray
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1523
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1524
     (((QDouble fromFloat:1e20) + (QDouble fromFloat:1.0))
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1525
     + ((QDouble fromFloat:1e20) + (QDouble fromFloat:1.0))) asDoubleArray
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1526
    "
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1527
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1528
    "Created: / 12-06-2017 / 20:14:55 / cg"
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1529
    "Modified (comment): / 12-06-2017 / 23:46:57 / cg"
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1530
!
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1531
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1532
squared
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1533
%{
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1534
    double *a = __QuadDoubleInstPtr(self)->d_quadDoubleValue;
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1535
    double p0, p1, p2, p3, p4, p5;
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1536
    double q0, q1, q2, q3;
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1537
    double s0, s1;
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1538
    double t0, t1;
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1539
    double t;
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1540
    OBJ newQD;
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1541
    
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1542
    m_two_sqr(p0, a[0], q0);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1543
    t = 2.0 * a[0];
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1544
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1545
    m_two_prod(p1, t, a[1], q1);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1546
    m_two_prod(p2, t, a[2], q2);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1547
    m_two_sqr(p3, a[1], q3);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1548
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1549
    m_two_sum(p1, q0, p1, q0);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1550
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1551
    m_two_sum(q0, q0, q1, q1);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1552
    m_two_sum(p2, p2, p3, p3);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1553
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1554
    m_two_sum(s0, q0, p2, t0);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1555
    m_two_sum(s1, q1, p3, t1);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1556
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1557
    m_two_sum(s1, s1, t0, t0);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1558
    t0 += t1;
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1559
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1560
    m_quick_two_sum(s1, s1, t0, t0);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1561
    m_quick_two_sum(p2, s0, s1, t1);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1562
    m_quick_two_sum(p3, t1, t0, q0);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1563
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1564
    p4 = 2.0 * a[0] * a[3];
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1565
    p5 = 2.0 * a[1] * a[2];
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1566
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1567
    m_two_sum(p4, p4, p5, p5);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1568
    m_two_sum(q2, q2, q3, q3);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1569
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1570
    m_two_sum(t0, p4, q2, t1);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1571
    t1 = t1 + p5 + q3;
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1572
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1573
    m_two_sum(p3, p3, t0, p4);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1574
    p4 = p4 + q0 + t1;
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1575
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1576
    m_renorm5(p0, p1, p2, p3, p4);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1577
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1578
    __qNew_qdReal(newQD, p0, p1, s0, s1);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1579
    RETURN( newQD );
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1580
%}.
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1581
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1582
    "
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1583
     (QDouble fromFloat:4.0) squared
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1584
     (1e20 + (QDouble fromFloat:1.0)) squared 
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1585
    "
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1586
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1587
    "Created: / 13-06-2017 / 01:27:58 / cg"
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1588
! !
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1589
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1590
!QDouble methodsFor:'printing & storing'!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1591
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1592
printDigitsOn:outStream precision:precision exponentInto:expn
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1593
    |numDigits r e i d|
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1594
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1595
    numDigits := precision+1. "/ number of digits
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1596
    r := self abs.
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1597
    self d0 = 0.0 ifTrue:[
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1598
        expn value:0.
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1599
        precision timesRepeat:[ outStream nextPut:$0 ].
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1600
        ^ self.
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1601
    ].
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1602
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1603
    "/ determine approx. exponent
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1604
    e := self d0 abs log10 floor.
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1605
    self halt.
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1606
    e < -300 ifTrue:[
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1607
        r := r * (10.0 raisedToInteger:300).
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1608
        r := r / (10.0 raisedToInteger:(e+300)).
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1609
    ] ifFalse:[
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1610
        e > 300 ifTrue:[
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1611
        ] ifFalse:[
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1612
        ]
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1613
    ].
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1614
    
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1615
    
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1616
    "
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1617
     1.2345 asQDouble printDigitsOn:Transcript precision:5 exponentInto:[:e |]
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1618
    "
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1619
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1620
    "Created: / 13-06-2017 / 17:28:08 / cg"
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1621
!
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1622
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1623
printString
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1624
    "return a printed representation of the receiver"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1625
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1626
    self d1 = 0.0 ifTrue:[
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1627
        ^ self d0 printString
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1628
    ].
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1629
    ^ self d0 printString , '...'
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1630
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1631
    "Created: / 12-06-2017 / 23:41:04 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1632
! !
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1633
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1634
!QDouble methodsFor:'private accessing'!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1635
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1636
d0
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1637
    "the most significant (and highest valued) 53 bits of precision"
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1638
%{
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1639
    RETURN ( __MKFLOAT(__QuadDoubleInstPtr(self)->d_quadDoubleValue[0]) ); 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1640
%}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1641
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1642
    "Created: / 12-06-2017 / 20:15:12 / cg"
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1643
    "Modified (comment): / 13-06-2017 / 17:59:47 / cg"
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1644
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1645
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1646
d1
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1647
    "the next most significant (and next highest valued) 53 bits of precision"
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1648
%{
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1649
    RETURN ( __MKFLOAT(__QuadDoubleInstPtr(self)->d_quadDoubleValue[1]) ); 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1650
%}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1651
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1652
    "Created: / 12-06-2017 / 20:15:12 / cg"
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1653
    "Modified (comment): / 13-06-2017 / 18:00:00 / cg"
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1654
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1655
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1656
d2
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1657
%{
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1658
    RETURN ( __MKFLOAT(__QuadDoubleInstPtr(self)->d_quadDoubleValue[2]) ); 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1659
%}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1660
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1661
    "Created: / 12-06-2017 / 20:15:29 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1662
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1663
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1664
d3
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1665
    "the least significant (and smallest valued) 53 bits of precision"
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1666
%{
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1667
    RETURN ( __MKFLOAT(__QuadDoubleInstPtr(self)->d_quadDoubleValue[3]) ); 
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1668
%}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1669
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1670
    "Created: / 12-06-2017 / 20:15:32 / cg"
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1671
    "Modified (comment): / 13-06-2017 / 18:00:18 / cg"
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1672
!
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1673
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1674
renorm
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1675
%{
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1676
    double *a = __QuadDoubleInstPtr(self)->d_quadDoubleValue; 
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1677
    double c0, c1, c2, c3;
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1678
    OBJ newQD;
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1679
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1680
    c0 = a[0];
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1681
    c1 = a[1];
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1682
    c2 = a[2];
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1683
    c3 = a[3];
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1684
    m_renorm4(c0, c1, c2, c3);
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1685
    a[0] = c0;
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1686
    a[1] = c1;
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1687
    a[2] = c2;
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1688
    a[3] = c3;
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1689
    RETURN( self );
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1690
%}.
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1691
    ^ self error.
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1692
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1693
    "
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1694
     (QDouble fromFloat:1.0) renorm
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1695
    "
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1696
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1697
    "Created: / 13-06-2017 / 18:05:33 / cg"
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1698
! !
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1699
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1700
!QDouble class methodsFor:'documentation'!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1701
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1702
version
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1703
    ^ '$Header$'
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1704
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1705
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1706
version_CVS
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1707
    ^ '$Header$'
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1708
! !
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1709