QDouble.st
author Claus Gittinger <cg@exept.de>
Mon, 19 Jun 2017 09:15:41 +0200
changeset 4412 ad38e01db51a
parent 4411 8055a8f0b66f
child 4413 e3ee8be3627f
permissions -rw-r--r--
#FEATURE by cg class: QDouble class definition added: #exp changed: #ln class: QDouble class added: #invFact
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
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
     3
	      All Rights Reserved
4380
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:''
4392
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
    18
	classVariableNames:'DefaultPrintFormat QDoubleZero QDoubleOne Pi E Ln2 Ln10 Epsilon
4412
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
    19
		FMax FMin InvFact'
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    20
	poolDictionaries:''
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    21
	category:'Magnitude-Numbers'
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    22
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    23
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    24
!QDouble primitiveDefinitions!
4411
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
    25
ry:'Magnitude-Numbers'
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    26
! !
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    27
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    28
!QDouble primitiveFunctions!
4411
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
    29
= quick_two_sum(s1, *c3Ptr, &s2);
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    30
  } else {
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    31
    s0 = quick_two_sum(s0, *c2Ptr, &s1);
4411
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
    32
    if (s1 ! !
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    33
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    34
!QDouble class methodsFor:'documentation'!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    35
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    36
copyright
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    37
"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    38
 COPYRIGHT (c) 2017 by eXept Software AG
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
    39
	      All Rights Reserved
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    40
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    41
 This software is furnished under a license and may be used
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    42
 only in accordance with the terms of that license and with the
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    43
 inclusion of the above copyright notice.   This software may not
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    44
 be provided or otherwise made available to, or used by, any
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    45
 other person.  No title to or ownership of the software is
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    46
 hereby transferred.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    47
"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    48
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    49
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    50
documentation
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    51
"
4391
f2ece85e1ae3 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4390
diff changeset
    52
    ATTENTION: ongoing, unfinished work.
f2ece85e1ae3 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4390
diff changeset
    53
    This does not work correctly at the moment.
f2ece85e1ae3 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4390
diff changeset
    54
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    55
    QDoubles represent rational numbers with extended, but still limited precision.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    56
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    57
    In contrast to Floats (which use the C-compilers native 64bit 'double' format),
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    58
    QDoubles give you 212 bit or approx. 64 decimal digits of precision.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    59
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    60
    Representation:
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
    61
	QDoubles use 4 IEEE doubles, each keeping 53 bits of precision.
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    62
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    63
    Range and Precision of Storage Formats: see LimitedPrecisionReal >> documentation
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    64
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
    65
	Float decimalPrecision
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
    66
	QDouble decimalPrecision
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
    67
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    68
    [author:]
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
    69
	Claus Gittinger
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    70
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    71
    [see also:]
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
    72
	Number
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
    73
	Float ShortFloat Fraction FixedPoint Integer Complex
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
    74
	FloatArray DoubleArray
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    75
"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    76
! !
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    77
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    78
!QDouble class methodsFor:'instance creation'!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    79
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    80
basicNew
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    81
    "return a new quad-precision double - here we return 0.0
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    82
     Notice that numbers are usually NOT created this way ...
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    83
     It's implemented here to allow things like binary store & load
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    84
     of floats. (but even this support will go away eventually, it's not
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    85
     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
    86
     totally different representation - so floats should be
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    87
     binary stored in a device independent format."
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    88
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    89
%{  /* NOCONTEXT */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    90
#ifdef __SCHTEAM__
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    91
    ERROR("trying to instantiate a quad double");
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    92
#else
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
    93
    OBJ newFloat;
4404
2708f482fe13 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4395
diff changeset
    94
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
    95
    __qNew(newFloat, sizeof(struct __quadDoubleStruct));
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
    96
    __stx_setClass(newFloat, QDouble);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
    97
    __QuadDoubleInstPtr(newFloat)->d_quadDoubleValue[0] = 0.0;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
    98
    __QuadDoubleInstPtr(newFloat)->d_quadDoubleValue[1] = 0.0;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
    99
    __QuadDoubleInstPtr(newFloat)->d_quadDoubleValue[2] = 0.0;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   100
    __QuadDoubleInstPtr(newFloat)->d_quadDoubleValue[3] = 0.0;
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   101
    RETURN (newFloat);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   102
#endif /* not SCHTEAM */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   103
%}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   104
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   105
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   106
     self basicNew
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
    "Created: / 12-06-2017 / 16:00:38 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   110
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   111
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   112
d0:d0 d1:d1 d2:d2 d3:d3
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   113
    "return a new quad-precision double from individual double components"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   114
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   115
%{  /* NOCONTEXT */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   116
#ifdef __SCHTEAM__
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   117
    ERROR("trying to instantiate a quad double");
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   118
#else
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   119
    OBJ newQD;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   120
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   121
    if (__isFloatLike(d0)
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   122
     && __isFloatLike(d1)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   123
     && __isFloatLike(d2)
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   124
     && __isFloatLike(d3)) {
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   125
	__qNew_qdReal(newQD, __floatVal(d0), __floatVal(d1),
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   126
			     __floatVal(d2), __floatVal(d3));
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   127
	RETURN (newQD);
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   128
    }
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   129
#endif
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   130
%}.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   131
    self error:'invalid argument'
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   132
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   133
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   134
     self d0: 3.141592653589793116e+00
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   135
	  d1: 1.224646799147353207e-16
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   136
	  d2: -2.994769809718339666e-33
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   137
	  d3: 1.112454220863365282e-49
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   138
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   139
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   140
    "Created: / 12-06-2017 / 20:17:14 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   141
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   142
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   143
fromDoubleArray:aDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   144
    "return a new quad-precision double from coercing a double array"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   145
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   146
%{  /* NOCONTEXT */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   147
#ifdef __SCHTEAM__
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   148
    ERROR("trying to instantiate a quad double");
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   149
#else
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   150
    OBJ newQD;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   151
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   152
    if (__isDoubleArray(aDoubleArray)) {
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   153
	__qNew_qdReal(newQD,
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   154
		    __DoubleArrayInstPtr(aDoubleArray)->d_element[0],
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   155
		    __DoubleArrayInstPtr(aDoubleArray)->d_element[1],
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   156
		    __DoubleArrayInstPtr(aDoubleArray)->d_element[2],
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   157
		    __DoubleArrayInstPtr(aDoubleArray)->d_element[3]);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   158
	RETURN (newQD);
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   159
    }
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   160
#endif
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   161
%}.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   162
    self error:'invalid argument'
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   163
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   164
    "
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   165
     self fromDoubleArray(DoubleArray
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   166
				with: 3.141592653589793116e+00
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   167
				with: 1.224646799147353207e-16
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   168
				with: -2.994769809718339666e-33
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   169
				with: 1.112454220863365282e-49)
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   170
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   171
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   172
    "Created: / 12-06-2017 / 18:25:32 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   173
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   174
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   175
fromFloat:aFloat
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   176
    "return a new quad-precision double from coercing aFloat"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   177
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   178
%{  /* NOCONTEXT */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   179
#ifdef __SCHTEAM__
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   180
    ERROR("trying to instantiate a quad double");
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   181
#else
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   182
    double dVal;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   183
    OBJ newFloat;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   184
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   185
    if (__isFloatLike(aFloat)) {
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   186
	dVal = __floatVal(aFloat);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   187
    } else if (__isShortFloat(aFloat)) {
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   188
	dVal = __shortFloatVal(aFloat);
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   189
    } else {
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   190
	goto badArg;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   191
    }
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   192
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   193
    __qNew(newFloat, sizeof(struct __quadDoubleStruct));
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   194
    __stx_setClass(newFloat, QDouble);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   195
    __QuadDoubleInstPtr(newFloat)->d_quadDoubleValue[0] = dVal;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   196
    __QuadDoubleInstPtr(newFloat)->d_quadDoubleValue[1] = 0.0;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   197
    __QuadDoubleInstPtr(newFloat)->d_quadDoubleValue[2] = 0.0;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   198
    __QuadDoubleInstPtr(newFloat)->d_quadDoubleValue[3] = 0.0;
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   199
    RETURN (newFloat);
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   200
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   201
badArg: ;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   202
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   203
#endif
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   204
%}.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   205
    self error:'invalid argument'
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   206
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   207
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   208
     self fromFloat:1.0
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   209
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   210
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   211
    "Created: / 12-06-2017 / 16:06:54 / cg"
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
fromInteger:anInteger
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   215
    "return a new quad-precision double from coercing anInteger"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   216
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   217
%{  /* NOCONTEXT */
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   218
#ifndef __SCHTEAM__
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   219
    OBJ newFloat;
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   220
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   221
    if (__isSmallInteger(anInteger)) {
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   222
	__qNew(newFloat, sizeof(struct __quadDoubleStruct));
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   223
	__stx_setClass(newFloat, QDouble);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   224
	__QuadDoubleInstPtr(newFloat)->d_quadDoubleValue[0] = (double)(__smallIntegerVal(anInteger));
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   225
	__QuadDoubleInstPtr(newFloat)->d_quadDoubleValue[1] = 0.0;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   226
	__QuadDoubleInstPtr(newFloat)->d_quadDoubleValue[2] = 0.0;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   227
	__QuadDoubleInstPtr(newFloat)->d_quadDoubleValue[3] = 0.0;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   228
	RETURN (newFloat);
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   229
    }
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   230
#endif
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   231
%}.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   232
    ^ super fromInteger:anInteger
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   233
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   234
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   235
     self fromInteger:2
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   236
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   237
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   238
    "Created: / 12-06-2017 / 16:10:10 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   239
! !
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   240
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   241
!QDouble class methodsFor:'coercing & converting'!
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   242
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   243
coerce:aNumber
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   244
    "convert the argument aNumber into an instance of the receiver's class and return it."
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   245
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   246
    ^ aNumber asQDouble
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   247
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   248
    "Created: / 12-06-2017 / 17:13:47 / cg"
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   249
    "Modified: / 12-06-2017 / 21:09:06 / cg"
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   250
! !
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   251
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   252
!QDouble class methodsFor:'constants'!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   253
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   254
e
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   255
    "return the constant e as quad precision double.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   256
     (returns approx. 212 bits of precision)"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   257
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   258
    E isNil ifTrue:[
4388
742f099741bf *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4387
diff changeset
   259
	E := self fromDoubleArray:(DoubleArray
742f099741bf *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4387
diff changeset
   260
				    with: 2.718281828459045091e+00
742f099741bf *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4387
diff changeset
   261
				    with: 1.445646891729250158e-16
742f099741bf *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4387
diff changeset
   262
				    with: -2.127717108038176765e-33
742f099741bf *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4387
diff changeset
   263
				    with: 1.515630159841218954e-49)
742f099741bf *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4387
diff changeset
   264
    ].
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   265
    ^ E
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   266
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   267
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   268
     self e
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
    "Created: / 12-06-2017 / 18:29:36 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   272
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   273
4392
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   274
fmax
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   275
    "return the constant e as quad precision double.
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   276
     (returns approx. 212 bits of precision)"
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   277
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   278
    FMax isNil ifTrue:[
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   279
	FMax := self fromDoubleArray:(DoubleArray
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   280
				    with: 1.797693134862314E+308
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   281
				    with: 9.97920154767359795037e+291
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   282
				    with: 5.53956966280111259858e+275
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   283
				    with: 3.07507889307840487279e+259)
4392
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   284
    ].
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   285
    ^ FMax
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   286
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   287
    "
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   288
     Float fmax
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   289
     self fmax
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   290
    "
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   291
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   292
    "Created: / 14-06-2017 / 19:14:18 / cg"
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   293
!
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   294
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   295
fmin
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   296
    "return the smallest representable instance of this class"
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   297
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   298
    FMin isNil ifTrue:[
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   299
	FMin := 1.6259745436952323e-260 asQDouble
4392
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   300
    ].
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   301
    ^ FMin
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   302
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   303
    "
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   304
     QDouble fmin
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   305
     Float fmin
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   306
    "
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   307
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   308
    "Created: / 14-06-2017 / 19:14:49 / cg"
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   309
!
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   310
4411
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
   311
infinity
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
   312
    ^ Infinity positive
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
   313
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
   314
    "Created: / 18-06-2017 / 23:41:07 / cg"
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
   315
!
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
   316
4412
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
   317
invFact
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
   318
    InvFact isNil ifTrue:[
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
   319
        InvFact := Array new:15.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
   320
        InvFact at:1 put:(self d0:1.66666666666666657e-01 d1:9.25185853854297066e-18 d2:5.13581318503262866e-34 d3:2.85094902409834186e-50).
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
   321
        InvFact at:2 put:(self d0:4.16666666666666644e-02 d1:2.31296463463574266e-18 d2:1.28395329625815716e-34 d3:7.12737256024585466e-51).
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
   322
        InvFact at:3 put:(self d0:8.33333333333333322e-03 d1:1.15648231731787138e-19 d2:1.60494162032269652e-36 d3:2.22730392507682967e-53).
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
   323
        InvFact at:4 put:(self d0:1.38888888888888894e-03 d1:-5.30054395437357706e-20 d2:-1.73868675534958776e-36 d3:-1.63335621172300840e-52).
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
   324
        InvFact at:5 put:(self d0:1.98412698412698413e-04 d1:1.72095582934207053e-22 d2:1.49269123913941271e-40 d3:1.29470326746002471e-58).
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
   325
        InvFact at:6 put:(self d0:2.48015873015873016e-05 d1:2.15119478667758816e-23 d2:1.86586404892426588e-41 d3:1.61837908432503088e-59).
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
   326
        InvFact at:7 put:(self d0:2.75573192239858925e-06 d1:-1.85839327404647208e-22 d2:8.49175460488199287e-39 d3:-5.72661640789429621e-55).
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
   327
        InvFact at:8 put:(self d0:2.75573192239858883e-07 d1:2.37677146222502973e-23 d2:-3.26318890334088294e-40 d3:1.61435111860404415e-56).
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
   328
        InvFact at:9 put:(self d0:2.50521083854417202e-08 d1:-1.44881407093591197e-24 d2:2.04267351467144546e-41 d3:-8.49632672007163175e-58).
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
   329
        InvFact at:10 put:(self d0:2.08767569878681002e-09 d1:-1.20734505911325997e-25 d2:1.70222792889287100e-42 d3:1.41609532150396700e-58).
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
   330
        InvFact at:11 put:(self d0:1.60590438368216133e-10 d1:1.25852945887520981e-26 d2:-5.31334602762985031e-43 d3:3.54021472597605528e-59).
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
   331
        InvFact at:12 put:(self d0:1.14707455977297245e-11 d1:2.06555127528307454e-28 d2:6.88907923246664603e-45 d3:5.72920002655109095e-61).        
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
   332
        InvFact at:13 put:(self d0:7.64716373181981641e-13 d1:7.03872877733453001e-30 d2:-7.82753927716258345e-48 d3:1.92138649443790242e-64).
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
   333
        InvFact at:14 put:(self d0:4.77947733238738525e-14 d1:4.39920548583408126e-31 d2:-4.89221204822661465e-49 d3:1.20086655902368901e-65).
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
   334
        InvFact at:15 put:(self d0:2.81145725434552060e-15 d1:1.65088427308614326e-31 d2:-2.87777179307447918e-50 d3:4.27110689256293549e-67).
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
   335
    ].
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
   336
    ^ InvFact
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
   337
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
   338
    "Created: / 19-06-2017 / 02:22:23 / cg"
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
   339
!
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
   340
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   341
ln10
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   342
    "return the constant e as quad precision double.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   343
     (returns approx. 212 bits of precision)"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   344
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   345
    Ln10 isNil ifTrue:[
4388
742f099741bf *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4387
diff changeset
   346
	Ln10 := self fromDoubleArray:(DoubleArray
742f099741bf *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4387
diff changeset
   347
				    with: 2.302585092994045901e+00
742f099741bf *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4387
diff changeset
   348
				    with: -2.170756223382249351e-16
742f099741bf *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4387
diff changeset
   349
				    with: -9.984262454465776570e-33
742f099741bf *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4387
diff changeset
   350
				    with: -4.023357454450206379e-49)
742f099741bf *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4387
diff changeset
   351
    ].
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   352
    ^ Ln10
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   353
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   354
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   355
     self ln10
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   356
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   357
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   358
    "Created: / 12-06-2017 / 18:32:29 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   359
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   360
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   361
ln2
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   362
    "return the constant e as quad precision double.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   363
     (returns approx. 212 bits of precision)"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   364
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   365
    Ln2 isNil ifTrue:[
4388
742f099741bf *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4387
diff changeset
   366
	Ln2 := self fromDoubleArray:(DoubleArray
742f099741bf *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4387
diff changeset
   367
				    with: 6.931471805599452862e-01
742f099741bf *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4387
diff changeset
   368
				    with: 2.319046813846299558e-17
742f099741bf *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4387
diff changeset
   369
				    with: 5.707708438416212066e-34
742f099741bf *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4387
diff changeset
   370
				    with: -3.582432210601811423e-50)
742f099741bf *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4387
diff changeset
   371
    ].
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   372
    ^ Ln2
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   373
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   374
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   375
     self ln2
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   376
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   377
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   378
    "Created: / 12-06-2017 / 18:31:34 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   379
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   380
4411
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
   381
negativeInfinity
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
   382
    ^ Infinity negative
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
   383
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
   384
    "Created: / 18-06-2017 / 23:40:47 / cg"
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
   385
!
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
   386
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   387
pi
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   388
    "return the constant pi as quad precision double.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   389
     (returns approx. 212 bits of precision)"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   390
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   391
    Pi isNil ifTrue:[
4388
742f099741bf *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4387
diff changeset
   392
	Pi := self fromDoubleArray:(DoubleArray
742f099741bf *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4387
diff changeset
   393
				    with: 3.141592653589793116e+00
742f099741bf *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4387
diff changeset
   394
				    with: 1.224646799147353207e-16
742f099741bf *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4387
diff changeset
   395
				    with: -2.994769809718339666e-33
742f099741bf *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4387
diff changeset
   396
				    with: 1.112454220863365282e-49)
742f099741bf *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4387
diff changeset
   397
    ].
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   398
    ^ Pi
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   399
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   400
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   401
     self pi
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   402
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   403
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   404
    "Created: / 12-06-2017 / 18:27:13 / cg"
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   405
!
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   406
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   407
unity
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   408
    "return the neutral element for multiplication (1.0) as QDouble"
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   409
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   410
    QDoubleOne isNil ifTrue:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   411
	QDoubleOne := 1.0 asQDouble.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   412
    ].
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   413
    ^ QDoubleOne
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   414
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   415
    "
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   416
     self unity
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   417
    "
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   418
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   419
    "Created: / 15-06-2017 / 11:45:22 / cg"
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   420
!
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   421
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   422
zero
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   423
    "return the neutral element for addition (0.0) as QDouble"
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   424
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   425
    QDoubleZero isNil ifTrue:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   426
	QDoubleZero := 0.0 asQDouble
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   427
    ].
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   428
    ^ QDoubleZero
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   429
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   430
    "
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   431
     self zero
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   432
    "
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   433
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   434
    "Created: / 15-06-2017 / 11:44:13 / cg"
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   435
! !
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   436
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   437
!QDouble class methodsFor:'queries'!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   438
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   439
defaultPrintPrecision
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   440
    "return the number of decimal digits printed by default"
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   441
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   442
    ^ 10
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   443
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   444
    "
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   445
     ShortFloat defaultPrintPrecision
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   446
     Float defaultPrintPrecision
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   447
     LongFloat defaultPrintPrecision
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   448
     QDouble defaultPrintPrecision
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   449
    "
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   450
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   451
    "Created: / 17-06-2017 / 02:58:51 / cg"
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   452
!
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   453
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   454
epsilon
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   455
    "return the maximum relative spacing of instances of mySelf
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   456
     (i.e. the value-delta of the least significant bit)"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   457
4392
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   458
    ^ 1.2154326714572500565324311366323150942261000827598106963711353e-63
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   459
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   460
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   461
     Float epsilon
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   462
     ShortFloat epsilon
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   463
     QDouble epsilon
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
    "Created: / 12-06-2017 / 18:52:44 / cg"
4392
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   467
    "Modified: / 14-06-2017 / 19:12:23 / cg"
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   468
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   469
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   470
numBitsInExponent
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   471
    "answer the number of bits in the exponent"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   472
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   473
    ^ Float numBitsInExponent
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   474
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   475
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   476
     1.0 asQDouble class numBitsInExponent
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   477
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   478
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   479
    "Created: / 12-06-2017 / 11:11:04 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   480
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   481
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   482
numBitsInMantissa
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   483
    "answer the number of bits in the mantissa"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   484
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   485
    ^ Float precision * 4
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   486
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   487
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   488
     1.0 class numBitsInMantissa
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   489
     1.0 asShortFloat class numBitsInMantissa
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   490
     1.0 asLongFloat class numBitsInMantissa
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   491
     1.0 asDDouble class numBitsInMantissa
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   492
     1.0 asQDouble class numBitsInMantissa
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   493
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   494
     Float numBitsInMantissa
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   495
     ShortFloat numBitsInMantissa
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   496
     QDouble numBitsInMantissa
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   497
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   498
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   499
    "Created: / 12-06-2017 / 11:13:44 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   500
    "Modified: / 12-06-2017 / 18:48:48 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   501
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   502
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   503
precision
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   504
    "answer the number of bits in the mantissa"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   505
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   506
    ^ Float precision * 4
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   507
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   508
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   509
     1.0 class numBitsInMantissa
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   510
     1.0 asShortFloat class numBitsInMantissa
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   511
     1.0 asLongFloat class numBitsInMantissa
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   512
     1.0 asDDouble class numBitsInMantissa
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   513
     1.0 asQDouble class numBitsInMantissa
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   514
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   515
     Float numBitsInMantissa
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   516
     ShortFloat numBitsInMantissa
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   517
     QDouble numBitsInMantissa
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   518
     QDouble precision
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   519
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   520
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   521
    "Created: / 12-06-2017 / 18:49:11 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   522
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   523
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   524
radix
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   525
    "answer the radix of a Floats exponent
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   526
     This is an IEEE float, which is represented as binary"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   527
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   528
    ^ Float radix
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   529
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   530
    "Created: / 12-06-2017 / 18:50:04 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   531
! !
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   532
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   533
!QDouble methodsFor:'arithmetic'!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   534
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   535
* aNumber
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   536
    "return the product of the receiver and the argument, aNumber"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   537
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   538
    ^ aNumber productFromQDouble:self
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   539
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   540
    "
4392
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   541
     (((QDouble fromFloat:1e20) + (QDouble fromFloat:1.0)) * (QDouble fromFloat:2.0)) asDoubleArray
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   542
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   543
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   544
    "Created: / 13-06-2017 / 01:00:47 / cg"
4392
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   545
    "Modified (comment): / 14-06-2017 / 12:08:50 / cg"
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   546
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   547
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   548
+ aNumber
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   549
    "return the sum of the receiver and the argument, aNumber"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   550
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   551
    ^ aNumber sumFromQDouble:self
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 fromFloat:1e20) + (QDouble fromFloat:1.0)) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   555
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   556
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   557
    "Created: / 12-06-2017 / 16:17:46 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   558
    "Modified: / 12-06-2017 / 23:06:22 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   559
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   560
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   561
- aNumber
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   562
    "return the sum of the receiver and the argument, aNumber"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   563
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   564
    ^ self + (aNumber negated)
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   565
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   566
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   567
     (QDouble fromFloat:1e20) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   568
     ((QDouble fromFloat:1e20) - (QDouble fromFloat:1.0)) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   569
     (QDouble fromFloat:1e-20) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   570
     ((QDouble fromFloat:1e-20) - (QDouble fromFloat:1.0)) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   571
     ((QDouble fromFloat:2.0) - (QDouble fromFloat:1.0)) asDoubleArray
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   572
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   573
     ((QDouble fromFloat:2.0) - (QDouble fromFloat:1.0) + (QDouble fromFloat:1.0)) asDoubleArray
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   574
     ((QDouble fromFloat:1e-20) - (QDouble fromFloat:1.0) + (QDouble fromFloat:1.0)) asDoubleArray
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   575
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   576
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   577
    "Created: / 12-06-2017 / 23:41:39 / cg"
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   578
    "Modified (comment): / 15-06-2017 / 00:34:41 / cg"
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   579
!
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   580
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   581
/ aNumber
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   582
    "return the quotient of the receiver and the argument, aNumber"
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   583
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   584
    ^ aNumber quotientFromQDouble:self
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   585
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   586
    "
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   587
     ((QDouble fromFloat:1e20) / (QDouble fromFloat:2.0)) asDoubleArray
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   588
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   589
     ((QDouble fromFloat:1.2345) / (QDouble fromFloat:10.0)) asDoubleArray
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   590
     ((QDouble fromFloat:1.2345) / 10.0) asDoubleArray
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   591
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   592
    "
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   593
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   594
    "Created: / 13-06-2017 / 17:59:09 / cg"
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   595
    "Modified (comment): / 15-06-2017 / 00:14:26 / cg"
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   596
! !
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   597
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   598
!QDouble methodsFor:'coercing & converting'!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   599
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   600
asDoubleArray
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   601
    ^ DoubleArray
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   602
	    with:self d0
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   603
	    with:self d1
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   604
	    with:self d2
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   605
	    with:self d3.
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   606
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   607
    "
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   608
     (QDouble fromFloat:1.0) asDoubleArray
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   609
     (QDouble fromFloat:2.0) asDoubleArray
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   610
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   611
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   612
    "Created: / 12-06-2017 / 18:19:19 / cg"
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   613
    "Modified (comment): / 13-06-2017 / 17:58:09 / cg"
4380
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
asFloat
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   617
    ^ self d0
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   618
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   619
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   620
     (QDouble fromFloat:1.0) asFloat
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   621
     (QDouble fromFloat:2.0) asFloat
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   622
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   623
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   624
    "Created: / 12-06-2017 / 18:15:27 / cg"
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   625
    "Modified: / 13-06-2017 / 17:56:50 / cg"
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   626
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   627
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   628
asQDouble
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   629
    "return a QDouble with same value as myself."
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   630
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   631
    ^ self
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   632
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   633
    "Created: / 15-06-2017 / 12:08:02 / cg"
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   634
!
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   635
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   636
coerce:aNumber
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   637
    "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
   638
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   639
    ^ aNumber asQDouble
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   640
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   641
    "Created: / 12-06-2017 / 17:13:47 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   642
    "Modified: / 12-06-2017 / 21:09:06 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   643
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   644
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   645
generality
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   646
    "return the generality value - see ArithmeticValue>>retry:coercing:"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   647
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   648
    ^ 95
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   649
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   650
    "Created: / 12-06-2017 / 17:13:14 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   651
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   652
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   653
negative
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   654
    ^ self d0 negative
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   655
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   656
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   657
     (QDouble fromFloat:0.0) negative
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   658
     (QDouble fromFloat:1.0) negative
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   659
     (QDouble fromFloat:-1.0) negative
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   660
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   661
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   662
    "Created: / 13-06-2017 / 01:57:39 / cg"
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   663
    "Modified: / 13-06-2017 / 17:58:26 / cg"
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   664
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   665
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   666
positive
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   667
    ^ self d0 positive
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   668
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   669
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   670
     (QDouble fromFloat:1.0) positive
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   671
     (QDouble fromFloat:-1.0) positive
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   672
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   673
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   674
    "Created: / 13-06-2017 / 01:56:53 / cg"
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   675
    "Modified: / 13-06-2017 / 17:58:41 / cg"
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   676
! !
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   677
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   678
!QDouble methodsFor:'comparing'!
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   679
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   680
< aNumber
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   681
    "return true, if the argument, aNumber is greater than the receiver"
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   682
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   683
    ^ aNumber lessFromQDouble:self
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   684
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   685
    "Created: / 13-06-2017 / 16:58:53 / cg"
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   686
!
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   687
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   688
= aNumber
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   689
    "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
   690
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   691
    ^ aNumber equalFromQDouble:self
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   692
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   693
    "Created: / 13-06-2017 / 17:12:09 / cg"
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   694
! !
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   695
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   696
!QDouble methodsFor:'double dispatching'!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   697
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   698
differenceFromFloat:aFloat
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   699
    "aFloat - self"
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   700
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   701
    ^ aFloat + (self negated)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   702
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   703
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   704
     1.0 - (QDouble fromFloat:1.0)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   705
     1e20 - (QDouble fromFloat:1.0)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   706
     (1.0 - (QDouble fromFloat:1.0)) asFloat
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   707
     (1e20 - (QDouble fromFloat:1.0)) asFloat
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   708
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   709
     (1.0 - (QDouble fromFloat:1.0)) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   710
     (1e20 - (QDouble fromFloat:1.0)) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   711
     (1e20 - (QDouble fromFloat:1.0) + 1e-20) asDoubleArray
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 / 23:38:05 / 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
differenceFromQDouble:aQDouble
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   718
    "aQDouble - self"
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   719
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   720
    ^ aQDouble + (self negated)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   721
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   722
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   723
     1.0 - (QDouble fromFloat:1.0)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   724
     1e20 - (QDouble fromFloat:1.0)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   725
     (1.0 - (QDouble fromFloat:1.0)) asFloat
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   726
     (1e20 - (QDouble fromFloat:1.0)) asFloat
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   727
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   728
     (1.0 - (QDouble fromFloat:1.0)) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   729
     (1e20 - (QDouble fromFloat:1.0)) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   730
     (1e20 - (QDouble fromFloat:1.0) + 1e-20) asDoubleArray
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
    "Created: / 12-06-2017 / 23:38:19 / cg"
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
equalFromQDouble:aQDouble
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   737
%{
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   738
    if (__Class(aQDouble) == QDouble) {
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   739
	double *a = __QuadDoubleInstPtr(self)->d_quadDoubleValue;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   740
	double *b = __QuadDoubleInstPtr(aQDouble)->d_quadDoubleValue;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   741
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   742
	RETURN ((a[0] == b[0]
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   743
		&& a[1] == b[1]
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   744
		&& a[2] == b[2]
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   745
		&& a[3] == b[3]) ? true : false);
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   746
    }
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   747
%}.
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   748
    ^ (aQDouble d0 = self d0)
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   749
    and:[ (aQDouble d1 = self d1)
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   750
    and:[ (aQDouble d2 = self d2)
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   751
    and:[ (aQDouble d3 = self d3) ]]]
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   752
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   753
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   754
     (QDouble fromFloat:1.0) = (QDouble fromFloat:1.0)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   755
     (QDouble fromFloat:1.0) = 1.0
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   756
     1.0 = (QDouble fromFloat:1.0)
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
    "Created: / 13-06-2017 / 03:01:19 / cg"
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   760
    "Modified: / 13-06-2017 / 18:01:52 / cg"
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   761
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   762
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   763
lessFromQDouble:aQDouble
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   764
    "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
   765
     Return true if aQDouble < self"
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   766
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   767
%{
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   768
    if (__Class(aQDouble) == QDouble) {
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   769
	double *a = __QuadDoubleInstPtr(aQDouble)->d_quadDoubleValue;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   770
	double *b = __QuadDoubleInstPtr(self)->d_quadDoubleValue;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   771
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   772
	// now compare if a < b!
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   773
	RETURN
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   774
	    ((a[0] < b[0] ||
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   775
	      (a[0] == b[0] && (a[1] < b[1] ||
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   776
		(a[1] == b[1] && (a[2] < b[2] ||
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   777
		  (a[2] == b[2] && a[3] < b[3])))))) ? true : false);
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   778
    }
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   779
%}.
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   780
    ^ super lessFromQDouble:aQDouble
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   781
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   782
    "
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   783
     (1.0 + 1e-40) > 1.0
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   784
     ((QDouble fromFloat:1.0) + (QDouble fromFloat:1e-40)) > (QDouble fromFloat:1.0)
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   785
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   786
     (QDouble fromFloat:1.0) > (QDouble fromFloat:1.0)
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   787
     (QDouble fromFloat:1.1) > (QDouble fromFloat:1.0)
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   788
     (QDouble fromFloat:1.0) > 1.0
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   789
     (QDouble fromFloat:1.1) > 1.0
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   790
     1.0 > (QDouble fromFloat:1.0)
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   791
   "
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   792
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   793
    "Created: / 13-06-2017 / 17:07:47 / cg"
4380
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
productFromFloat:aFloat
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   797
%{
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   798
    if (__isFloatLike(aFloat)) {
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   799
	double *a = __QuadDoubleInstPtr(self)->d_quadDoubleValue;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   800
	double b = __floatVal(aFloat);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   801
	double p0, p1, p2, p3;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   802
	double q0, q1, q2;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   803
	double s0, s1, s2, s3, s4;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   804
	OBJ newQD;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   805
	int savedCV;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   806
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   807
	fpu_fix_start(&savedCV);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   808
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   809
	m_two_prod(p0, a[0], b, q0);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   810
	m_two_prod(p1, a[1], b, q1);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   811
	m_two_prod(p2, a[2], b, q2);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   812
	p3 = a[3] * b;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   813
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   814
	s0 = p0;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   815
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   816
	m_two_sum(s1, q0, p1, s2);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   817
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   818
	m_three_sum(s2, q1, p2);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   819
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   820
	m_three_sum2(q1, q2, p3);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   821
	s3 = q1;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   822
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   823
	s4 = q2 + p2;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   824
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   825
	m_renorm5(s0, s1, s2, s3, s4);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   826
	fpu_fix_end(&savedCV);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   827
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   828
	__qNew_qdReal(newQD, s0, s1, s2, s3);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   829
	RETURN( newQD );
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   830
    }
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   831
%}.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   832
    ^ super productFromFloat:aFloat.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   833
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   834
    "
4387
879309cae427 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4386
diff changeset
   835
     (QDouble fromFloat:1.0) productFromFloat:2.0
879309cae427 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4386
diff changeset
   836
     ((QDouble fromFloat:1e20) + (QDouble fromFloat:1.0)) productFromFloat:2.0
879309cae427 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4386
diff changeset
   837
     ((QDouble fromFloat:1e20) + (QDouble fromFloat:1.0)) productFromFloat:2e20
879309cae427 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4386
diff changeset
   838
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   839
     2.0 * (QDouble fromFloat:1.0)
4387
879309cae427 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4386
diff changeset
   840
     2.0 * (QDouble fromFloat:3.0)
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   841
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   842
     2.0 * ((QDouble fromFloat:1e20) + (QDouble fromFloat:1.0))
4387
879309cae427 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4386
diff changeset
   843
     (2.0 * ((QDouble fromFloat:1e20) + (QDouble fromFloat:1.0))) - (QDouble fromFloat:1e20) - (QDouble fromFloat:1e20)
879309cae427 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4386
diff changeset
   844
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   845
     (2.0 * (QDouble fromFloat:1.0)) asFloat
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   846
     (1e20 * (QDouble fromFloat:1.0)) asFloat
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   847
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   848
     (1e20 * (QDouble fromFloat:1.0) * 1e-20) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   849
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   850
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   851
    "Created: / 13-06-2017 / 00:58:56 / cg"
4387
879309cae427 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4386
diff changeset
   852
    "Modified: / 14-06-2017 / 11:42:57 / cg"
4380
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
productFromQDouble:aQDouble
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   856
%{
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   857
    if (__Class(aQDouble) == QDouble) {
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   858
	double *a = __QuadDoubleInstPtr(self)->d_quadDoubleValue;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   859
	double *b = __QuadDoubleInstPtr(aQDouble)->d_quadDoubleValue;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   860
	OBJ newQD;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   861
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   862
	// sloppy
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   863
	double p0, p1, p2, p3, p4, p5;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   864
	double q0, q1, q2, q3, q4, q5;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   865
	double t0, t1;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   866
	double s0, s1, s2;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   867
	int savedCV;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   868
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   869
	fpu_fix_start(&savedCV);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   870
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   871
	m_two_prod(p0, a[0], b[0], q0);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   872
	// fprintf(stderr, "%f * %f -> %f, %f\n", a[0], b[0], p0, q0);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   873
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   874
	m_two_prod(p1, a[0], b[1], q1);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   875
	m_two_prod(p2, a[1], b[0], q2);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   876
	// fprintf(stderr, "%f * %f -> %f, %f\n", a[0], b[1], p1, q1);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   877
	// fprintf(stderr, "%f * %f -> %f, %f\n", a[1], b[0], p2, q2);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   878
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   879
	m_two_prod(p3, a[0], b[2], q3);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   880
	m_two_prod(p4, a[1], b[1], q4);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   881
	m_two_prod(p5, a[2], b[0], q5);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   882
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   883
	// fprintf(stderr, "%f * %f -> %f, %f\n", a[0], b[2], p3, q3);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   884
	// fprintf(stderr, "%f * %f -> %f, %f\n", a[1], b[1], p4, q4);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   885
	// fprintf(stderr, "%f * %f -> %f, %f\n", a[2], b[0], p5, q5);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   886
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   887
	/* Start Accumulation */
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   888
	m_three_sum(p1, p2, q0);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   889
	// fprintf(stderr, "mul7: after three_sum: p1:%e p2:%e q0:%e\n", p1, p2, q0);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   890
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   891
	/* Six-Three Sum  of p2, q1, q2, p3, p4, p5. */
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   892
	m_three_sum(p2, q1, q2);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   893
	// fprintf(stderr, "mul8: after three_sum: p2:%e q1:%e q2:%e\n", p2, q1, q2);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   894
	m_three_sum(p3, p4, p5);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   895
	// fprintf(stderr, "mul9: after three_sum: p3:%e p4:%e p5:%e\n", p3, p4, p5);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   896
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   897
	/* compute (s0, s1, s2) = (p2, q1, q2) + (p3, p4, p5). */
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   898
	m_two_sum(s0, p2, p3, t0);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   899
	// fprintf(stderr, "mul10: after two_sum: s0:%e p2:%e p3:%e t0:%e\n", s0, p2, p3, t0);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   900
	m_two_sum(s1, q1, p4, t1);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   901
	// fprintf(stderr, "mul11: after two_sum: s1:%e q1:%e p4:%e t1:%e\n", s1, q1, p4, t1);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   902
	s2 = q2 + p5;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   903
	m_two_sum(s1, s1, t0, t0);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   904
	// fprintf(stderr, "mul12: after two_sum: s1:%e s1:%e t0:%e t0:%e\n", s1, s1, t0, t0);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   905
	s2 += (t0 + t1);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   906
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   907
	/* O(eps^3) order terms */
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   908
	s1 += a[0]*b[3] + a[1]*b[2] + a[2]*b[1] + a[3]*b[0] + q0 + q3 + q4 + q5;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   909
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   910
	// fprintf(stderr, "before renorm5: p0:%e p2:%e s0:%e s1:%e s2:%e\n", p0, p1, s0, s1, s2);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   911
	m_renorm5(p0, p1, s0, s1, s2);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   912
	// fprintf(stderr, "after renorm5: p0:%e p2:%e s0:%e s1:%e s2:%e\n", p0, p1, s0, s1, s2);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   913
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   914
	fpu_fix_end(&savedCV);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   915
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   916
	__qNew_qdReal(newQD, p0, p1, s0, s1);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   917
	RETURN( newQD );
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   918
    }
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   919
%}.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   920
    ^ super productFromQDouble:aQDouble.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   921
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   922
    "
4387
879309cae427 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4386
diff changeset
   923
     (QDouble fromFloat:1.0) * 2.0
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   924
     2.0 * (QDouble fromFloat:1.0)
4387
879309cae427 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4386
diff changeset
   925
     (QDouble fromFloat:1.0) * (QDouble fromFloat:2.0)
879309cae427 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4386
diff changeset
   926
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   927
     1e20 * (QDouble fromFloat:1.0)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   928
     (2.0 * (QDouble fromFloat:1.0)) asFloat
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   929
     (1e20 * (QDouble fromFloat:1.0)) asFloat
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   930
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   931
     (1e20 * (QDouble fromFloat:1.0) * 1e-20) asDoubleArray
4392
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   932
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   933
     ( ((QDouble fromFloat:1.0) + (QDouble fromFloat:1e20)) * (QDouble fromFloat:2.0)) asDoubleArray
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   934
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   935
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   936
    "Created: / 13-06-2017 / 01:06:22 / cg"
4392
a64fe2606d82 #BUGFIX by cg
Claus Gittinger <cg@exept.de>
parents: 4391
diff changeset
   937
    "Modified: / 14-06-2017 / 16:59:58 / cg"
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   938
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   939
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   940
quotientFromQDouble:aQDouble
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   941
    "sloppy"
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   942
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   943
    |q0 q1 q2 q3 r|
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   944
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   945
    q0 := aQDouble d0 / self d0.
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   946
    "/ Stdout showCR:('q0: %1 (a[0]=%2; b[0]=%3)\n' bindWith:q0 with:self d0 with:aQDouble d0).
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   947
    r := aQDouble - (self * q0).
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   948
    "/ Stdout showCR:('r: %1\n' bindWith:r asDoubleArray).
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   949
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   950
    q1 := r d0 / self d0.
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   951
    "/ Stdout showCR:('q1: %1 (r[0]=%2; b[0]=%3)\n' bindWith:q1 with:r d0 with:aQDouble d0).
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   952
    r := r - (self * q1).
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   953
    "/ Stdout showCR:('r: %1\n' bindWith:r asDoubleArray).
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   954
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   955
    q2 := r d0 / self d0.
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   956
    "/ Stdout showCR:('q2: %1 (r[0]=%2; b[0]=%3)\n' bindWith:q2 with:r d0 with:aQDouble d0).
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   957
    r := r - (self * q2).
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   958
    "/ Stdout showCR:('r: %1\n' bindWith:r asDoubleArray).
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   959
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   960
    q3 := r d0 / self d0.
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   961
    "/ Stdout showCR:('q3: %1 (r[0]=%2; b[0]=%3)\n' bindWith:q3 with:r d0 with:aQDouble d0).
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   962
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   963
    r := self class d0:q0 d1:q1 d2:q2 d3:q3.
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   964
    "/ Stdout showCR:('before renorm: %1\n' bindWith:r asDoubleArray).
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   965
    r renorm.
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   966
    "/ Stdout showCR:('after renorm: %1\n' bindWith:r asDoubleArray).
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
   967
    ^ r
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   968
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
   969
    "
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   970
     2.0 / (QDouble fromFloat:2.0)
4387
879309cae427 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4386
diff changeset
   971
     2.0 / (QDouble fromFloat:1.0)
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   972
     1e20 / (QDouble fromFloat:1.0)
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   973
     (2.0 / (QDouble fromFloat:1.0)) asFloat
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   974
     (1e20 / (QDouble fromFloat:1.0)) asFloat
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   975
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   976
     (QDouble fromFloat:2.0) / 2.0
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   977
     (QDouble fromFloat:1e20) / 2.0
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   978
     ((QDouble fromFloat:1.0) / 2.0) asFloat
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   979
     ((QDouble fromFloat:1e20 / 2.0)) asFloat
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   980
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
   981
     ((1e20 + (QDouble fromFloat:1.0) + 1e-20) / 2.0) asDoubleArray
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   982
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   983
     ((QDouble fromFloat:10.0) quotientFromQDouble: (QDouble fromFloat:1.234)) asDoubleArray
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   984
     ((QDouble fromFloat:1.234) / (QDouble fromFloat:10.0)) asDoubleArray
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
   985
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   986
q0: 1.234000e-01 (a[0]=1.234000e+00; b[0]=1.000000e+01)
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   987
a: 1.234000e+00/0.000000e+00/0.000000e+00/0.000000e+00
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   988
b: 1.000000e+01/0.000000e+00/0.000000e+00/0.000000e+00
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   989
(b * q0): 1.234000e+00/-2.775558e-17/0.000000e+00/0.000000e+00
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   990
r: 2.775558e-17/0.000000e+00/0.000000e+00/0.000000e+00
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   991
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   992
q1: 2.775558e-18 (r[0]=2.775558e-17; b[0]=1.000000e+01)
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   993
r: -1.540744e-33/0.000000e+00/0.000000e+00/0.000000e+00
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   994
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   995
q2: -1.540744e-34 (r[0]=-1.540744e-33; b[0]=1.000000e+01)
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   996
r: 8.552847e-50/0.000000e+00/0.000000e+00/0.000000e+00
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   997
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   998
q3: 8.552847e-51 (r[0]=8.552847e-50; b[0]=1.000000e+01)
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
   999
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1000
before renorm: 1.234000e-01/2.775558e-18/-1.540744e-34/8.552847e-51
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1001
after renorm: 1.234000e-01/2.775558e-18/-1.540744e-34/8.552847e-51
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1002
1.234/10.0 is: 0.123400 / 0.000000 / -0.000000 / 0.000000
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1003
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1004
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1005
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1006
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1007
    "Created: / 13-06-2017 / 17:50:35 / cg"
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1008
    "Modified (comment): / 15-06-2017 / 01:02:05 / cg"
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1009
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1010
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1011
sumFromFloat:aFloat
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1012
%{
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1013
    if (__isFloatLike(aFloat)) {
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1014
	double *a = __QuadDoubleInstPtr(self)->d_quadDoubleValue;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1015
	double b = __floatVal(aFloat);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1016
	double c0, c1, c2, c3;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1017
	double e;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1018
	OBJ newQD;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1019
	int savedCV;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1020
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1021
	fpu_fix_start(&savedCV);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1022
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1023
	m_two_sum(c0, a[0], b, e);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1024
	m_two_sum(c1 ,a[1], e, e);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1025
	m_two_sum(c2, a[2], e, e);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1026
	m_two_sum(c3, a[3], e, e);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1027
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1028
	m_renorm5(c0, c1, c2, c3, e);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1029
	fpu_fix_end(&savedCV);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1030
	__qNew_qdReal(newQD, c0, c1, c2, c3);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1031
	RETURN( newQD );
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1032
    }
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1033
%}.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1034
    ^ super sumFromFloat:aFloat.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1035
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)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1038
     1e20 + (QDouble fromFloat:1.0)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1039
     (1.0 + (QDouble fromFloat:1.0)) asFloat
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1040
     (1e20 + (QDouble fromFloat:1.0)) asFloat
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1041
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1042
     (1.0 + (QDouble fromFloat:1.0)) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1043
     (1e20 + (QDouble fromFloat:1.0)) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1044
     (1e20 + (QDouble fromFloat:1.0) + 1e-20) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1045
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1046
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1047
    "Created: / 12-06-2017 / 17:16:41 / cg"
4387
879309cae427 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4386
diff changeset
  1048
    "Modified: / 14-06-2017 / 11:43:47 / cg"
4380
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
sumFromQDouble:aQDouble
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1052
%{
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1053
    if (__Class(aQDouble) == QDouble) {
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1054
	double *a = __QuadDoubleInstPtr(self)->d_quadDoubleValue;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1055
	double *b = __QuadDoubleInstPtr(aQDouble)->d_quadDoubleValue;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1056
	OBJ newQD;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1057
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1058
#ifndef QD_IEEE_ADD
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1059
	// sloppy_add...
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1060
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1061
# if 0
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1062
	double s0, s1, s2, s3;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1063
	double t0, t1, t2, t3;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1064
	int savedCV;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1065
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1066
	fpu_fix_start(&savedCV);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1067
	m_two_sum(s0, a[0], b[0], t0);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1068
	m_two_sum(s1, a[1], b[1], t1);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1069
	m_two_sum(s2, a[2], b[2], t2);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1070
	m_two_sum(s3, a[3], b[3], t3);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1071
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1072
	m_two_sum(s1, s1, t0, t0);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1073
	m_three_sum(s2, t0, t1);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1074
	m_three_sum2(s3, t0, t2);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1075
	t0 = t0 + t1 + t3;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1076
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1077
	m_renorm5(s0, s1, s2, s3, t0);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1078
	fpu_fix_end(&savedCV);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1079
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1080
	__qNew_qdReal(newQD, s0, s1, s2, s3);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1081
	RETURN(newQD);
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1082
# else
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1083
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1084
	/* Same as above, but addition re-organized to minimize
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1085
	   data dependency ... unfortunately some compilers are
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1086
	   not very smart to do this automatically */
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1087
	double s0, s1, s2, s3;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1088
	double t0, t1, t2, t3;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1089
	double v0, v1, v2, v3;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1090
	double u0, u1, u2, u3;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1091
	double w0, w1, w2, w3;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1092
	int savedCV;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1093
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1094
	fpu_fix_start(&savedCV);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1095
	s0 = a[0] + b[0];
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1096
	s1 = a[1] + b[1];
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1097
	s2 = a[2] + b[2];
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1098
	s3 = a[3] + b[3];
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1099
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1100
	v0 = s0 - a[0];
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1101
	v1 = s1 - a[1];
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1102
	v2 = s2 - a[2];
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1103
	v3 = s3 - a[3];
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1104
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1105
	u0 = s0 - v0;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1106
	u1 = s1 - v1;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1107
	u2 = s2 - v2;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1108
	u3 = s3 - v3;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1109
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1110
	w0 = a[0] - u0;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1111
	w1 = a[1] - u1;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1112
	w2 = a[2] - u2;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1113
	w3 = a[3] - u3;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1114
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1115
	u0 = b[0] - v0;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1116
	u1 = b[1] - v1;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1117
	u2 = b[2] - v2;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1118
	u3 = b[3] - v3;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1119
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1120
	t0 = w0 + u0;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1121
	t1 = w1 + u1;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1122
	t2 = w2 + u2;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1123
	t3 = w3 + u3;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1124
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1125
	m_two_sum(s1, s1, t0, t0);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1126
	m_three_sum(s2, t0, t1);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1127
	m_three_sum2(s3, t0, t2);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1128
	t0 = t0 + t1 + t3;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1129
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1130
	/* renormalize */
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1131
	m_renorm5(s0, s1, s2, s3, t0);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1132
	fpu_fix_end(&savedCV);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1133
	__qNew_qdReal(newQD, s0, s1, s2, s3);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1134
	RETURN(newQD);
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1135
# endif
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1136
#else
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1137
	// ieee_add...
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1138
	int i, j, k;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1139
	double s, t;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1140
	double u, v;   /* double-length accumulator */
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1141
	double x[4] = {0.0, 0.0, 0.0, 0.0};
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1142
	int savedCV;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1143
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1144
	fpu_fix_start(&savedCV);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1145
	i = j = k = 0;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1146
	if (abs(a[i]) > abs(b[j]))
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1147
	  u = a[i++];
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1148
	else
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1149
	  u = b[j++];
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1150
	if (abs(a[i]) > abs(b[j]))
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1151
	  v = a[i++];
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1152
	else
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1153
	  v = b[j++];
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1154
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1155
	u = quick_two_sum(u, v, v);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1156
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1157
	while (k < 4) {
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1158
	  if (i >= 4 && j >= 4) {
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1159
	    x[k] = u;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1160
	    if (k < 3)
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1161
	      x[++k] = v;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1162
	    break;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1163
	  }
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1164
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1165
	  if (i >= 4)
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1166
	    t = b[j++];
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1167
	  else if (j >= 4)
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1168
	    t = a[i++];
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1169
	  else if (abs(a[i]) > abs(b[j])) {
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1170
	    t = a[i++];
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1171
	  } else
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1172
	    t = b[j++];
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1173
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1174
	  s = quick_three_accum(u, v, t);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1175
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1176
	  if (s != 0.0) {
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1177
	    x[k++] = s;
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1178
	  }
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1179
	}
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1180
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1181
	/* add the rest. */
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1182
	for (k = i; k < 4; k++)
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1183
	  x[3] += a[k];
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1184
	for (k = j; k < 4; k++)
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1185
	  x[3] += b[k];
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1186
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1187
	m_renorm4(x[0], x[1], x[2], x[3]);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1188
	fpu_fix_end(&savedCV);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1189
	__qNew_qdReal(newQD, x[0], x[1], x[2], x[3]);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1190
	RETURN(newQD);
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1191
#endif
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1192
    }
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1193
%}.
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1194
    ^ super sumFromQDouble:aQDouble
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1195
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1196
    "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1197
     (QDouble fromFloat:1.0) + (QDouble fromFloat:1.0)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1198
     (QDouble fromFloat:1.0) + 1.0
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1199
     1.0 + (QDouble fromFloat:1.0)
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1200
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1201
     ((QDouble fromFloat:1.0) + (QDouble fromFloat:1.0)) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1202
     ((QDouble fromFloat:1.0) + 1.0) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1203
     (1.0 + (QDouble fromFloat:1.0)) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1204
     (1e-20 + (QDouble fromFloat:1.0)) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1205
     (1e20 + (QDouble fromFloat:1.0)) asDoubleArray
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1206
   "
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1207
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1208
    "Created: / 12-06-2017 / 21:15:43 / cg"
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1209
    "Modified: / 15-06-2017 / 00:49:10 / cg"
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1210
! !
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1211
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1212
!QDouble methodsFor:'inspecting'!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1213
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1214
inspectorExtraAttributes
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1215
    "extra (pseudo instvar) entries to be shown in an inspector."
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1216
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1217
    ^ super inspectorExtraAttributes
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1218
	add:'-{doubles}' ->
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1219
	    [
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1220
		self asDoubleArray printString
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1221
	    ];
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1222
	yourself
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1223
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1224
    "Created: / 12-06-2017 / 23:43:05 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1225
! !
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1226
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1227
!QDouble methodsFor:'mathematical functions'!
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1228
4412
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1229
exp
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1230
    "/ Strategy:  We first reduce the size of x by noting that
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1231
    "/
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1232
    "/  exp(kr + m * log(2)) = 2^m * exp(r)^k
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1233
    "/
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1234
    "/     where m and k are integers.  By choosing m appropriately
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1235
    "/     we can make |kr| <= log(2) / 2 = 0.347.  Then exp(r) is
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1236
    "/     evaluated using the familiar Taylor series.  Reducing the
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1237
    "/     argument substantially speeds up the convergence.       */
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1238
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1239
    |k inv_k d0 m mul_pwr2 r
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1240
     s p t thresh _eps i|
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1241
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1242
    _eps := 1.21543267145725e-63. "/ = 2^-209.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1243
    
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1244
    k := 1.0 ldexp:16.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1245
    inv_k := 1.0 / k.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1246
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1247
    d0 := self d0.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1248
    (d0 <= -709.0) ifTrue:[
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1249
        ^ 0.0 asQDouble.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1250
    ].    
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1251
    (d0 >= 709.0) ifTrue:[  
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1252
        ^ Infinity positive
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1253
    ].    
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1254
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1255
    self isZero ifTrue:[
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1256
        ^ 1.0 asQDouble.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1257
    ].    
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1258
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1259
    self isOne ifTrue:[
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1260
        ^ self class e
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1261
    ].
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1262
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1263
    "/  double m = std::floor(a.x[0] / qd_real::_log2.x[0] + 0.5);
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1264
    m := (d0 / Float ln2 + 0.5) floor.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1265
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1266
    mul_pwr2 := [:a :b | QDouble d0:(a d0 * b) d1:(a d1 * b) d2:(a d2 * b) d3:(a d3 * b) ].
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1267
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1268
    "/  qd_real r = mul_pwr2(a - qd_real::_log2 * m, inv_k);
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1269
    r := mul_pwr2 value:(self - (self class ln2 * m)) value:inv_k.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1270
    thresh := inv_k * _eps.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1271
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1272
    p := r squared.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1273
    s := r + (mul_pwr2 value:p value:0.5).
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1274
    i := 1.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1275
    [
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1276
        p := p * r.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1277
        t := p * (self class invFact at:i).
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1278
        i := i+1.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1279
        s := s + t.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1280
    ] doWhile:[ (t asFloat abs > thresh) and:[i < 10] ]. "/ (std::abs(to_double(t)) > thresh && i < 9);
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1281
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1282
    s := (mul_pwr2 value:s value:2.0) + s squared.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1283
    s := (mul_pwr2 value:s value:2.0) + s squared.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1284
    s := (mul_pwr2 value:s value:2.0) + s squared.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1285
    s := (mul_pwr2 value:s value:2.0) + s squared.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1286
    s := (mul_pwr2 value:s value:2.0) + s squared.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1287
    s := (mul_pwr2 value:s value:2.0) + s squared.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1288
    s := (mul_pwr2 value:s value:2.0) + s squared.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1289
    s := (mul_pwr2 value:s value:2.0) + s squared.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1290
    s := (mul_pwr2 value:s value:2.0) + s squared.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1291
    s := (mul_pwr2 value:s value:2.0) + s squared.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1292
    s := (mul_pwr2 value:s value:2.0) + s squared.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1293
    s := (mul_pwr2 value:s value:2.0) + s squared.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1294
    s := (mul_pwr2 value:s value:2.0) + s squared.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1295
    s := (mul_pwr2 value:s value:2.0) + s squared.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1296
    s := (mul_pwr2 value:s value:2.0) + s squared.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1297
    s := (mul_pwr2 value:s value:2.0) + s squared.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1298
    s := s + 1.0.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1299
    ^ s ldexp:m asInteger.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1300
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1301
    "
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1302
     1.0 exp -> 2.71828182845905
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1303
     1.0 asQDouble exp -> 2.71828182845905
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1304
    "
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1305
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1306
    "Created: / 19-06-2017 / 01:49:32 / cg"
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1307
!
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1308
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1309
floor
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1310
    "return the receiver truncated towards negative infinity"
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1311
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1312
%{
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1313
    double *a = __QuadDoubleInstPtr(self)->d_quadDoubleValue;
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1314
    OBJ newQD;
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1315
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1316
    double x0, x1, x2, x3;
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1317
    x1 = x2 = x3 = 0.0;
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1318
    x0 =floor(a[0]);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1319
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1320
    if (x0 == a[0]) {
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1321
	x1 = floor(a[1]);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1322
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1323
	if (x1 == a[1]) {
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1324
	    x2 = floor(a[2]);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1325
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1326
	    if (x2 == a[2]) {
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1327
		x3 = floor(a[3]);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1328
	    }
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1329
	}
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1330
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1331
	m_renorm4(x0, x1, x2, x3);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1332
	__qNew_qdReal(newQD, x0, x1, x2, x3);
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1333
	RETURN( newQD );
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1334
    }
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1335
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1336
    __qNew_qdReal(newQD, x0, x1, x2, x3);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1337
    RETURN( newQD );
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1338
%}.
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1339
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1340
    "
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1341
     (QDouble fromFloat:4.0) floor
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1342
     (QDouble fromFloat:4.1) floor
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1343
     (QDouble fromFloat:0.1) floor
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1344
     (0.1 + (QDouble fromFloat:1.0)) floor
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1345
     (1e20 + (QDouble fromFloat:1.0)) floor
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1346
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1347
     (QDouble fromFloat:1.5) floor
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1348
     (QDouble fromFloat:0.5) floor
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1349
     (QDouble fromFloat:-0.5) floor
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1350
     (QDouble fromFloat:-1.5) floor
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1351
    "
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1352
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1353
    "Created: / 13-06-2017 / 01:52:44 / cg"
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1354
    "Modified (comment): / 13-06-2017 / 17:33:19 / cg"
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1355
!
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1356
4411
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
  1357
ln
4412
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1358
    |d0 x|
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1359
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1360
    d0 := self d0.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1361
    d0 = 1.0 ifTrue:[
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1362
        self isOne ifTrue:[ ^ self class zero ].
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1363
    ].
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1364
    d0 < 0.0 ifTrue:[
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1365
        ^ self class
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1366
            raise:#domainErrorSignal
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1367
            receiver:self
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1368
            selector:#ln
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1369
            arguments:#()
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1370
            errorString:'bad receiver in ln'
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1371
    ].
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1372
    d0 = 0.0 ifTrue:[
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1373
        ^ Infinity negative
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1374
    ].
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1375
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1376
    "/ initial approx.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1377
    x := d0 ln asQDouble.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1378
    "/ two iterations of taylor
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1379
    x := x + (self * (x negated exp)) - 1.0.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1380
    x := x + (self * (x negated exp)) - 1.0.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1381
    x := x + (self * (x negated exp)) - 1.0.
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1382
    ^ x
4411
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
  1383
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
  1384
    "
4412
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1385
     -1 ln
4411
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
  1386
     1.0 asQDouble ln
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
  1387
    "
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
  1388
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
  1389
    "Created: / 18-06-2017 / 23:32:54 / cg"
4412
ad38e01db51a #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4411
diff changeset
  1390
    "Modified: / 19-06-2017 / 01:17:02 / cg"
4411
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
  1391
!
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
  1392
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1393
negated
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1394
    ^ self class
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1395
	d0:(self d0) negated
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1396
	d1:(self d1) negated
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1397
	d2:(self d2) negated
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1398
	d3:(self d3) negated
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1399
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1400
    "
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1401
     (QDouble fromFloat:1.0) negated
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1402
     ((QDouble fromFloat:1e20) + (QDouble fromFloat:1.0)) negated asDoubleArray
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1403
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1404
     (((QDouble fromFloat:1e20) + (QDouble fromFloat:1.0))
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1405
     + ((QDouble fromFloat:1e20) + (QDouble fromFloat:1.0))) asDoubleArray
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1406
    "
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1407
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1408
    "Created: / 12-06-2017 / 20:14:55 / cg"
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1409
    "Modified (comment): / 12-06-2017 / 23:46:57 / cg"
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1410
!
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1411
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1412
squared
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1413
%{
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1414
    double *a = __QuadDoubleInstPtr(self)->d_quadDoubleValue;
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1415
    double p0, p1, p2, p3, p4, p5;
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1416
    double q0, q1, q2, q3;
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1417
    double s0, s1;
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1418
    double t0, t1;
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1419
    double t;
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1420
    OBJ newQD;
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1421
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1422
    m_two_sqr(p0, a[0], q0);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1423
    t = 2.0 * a[0];
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1424
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1425
    m_two_prod(p1, t, a[1], q1);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1426
    m_two_prod(p2, t, a[2], q2);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1427
    m_two_sqr(p3, a[1], q3);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1428
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1429
    m_two_sum(p1, q0, p1, q0);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1430
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1431
    m_two_sum(q0, q0, q1, q1);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1432
    m_two_sum(p2, p2, p3, p3);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1433
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1434
    m_two_sum(s0, q0, p2, t0);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1435
    m_two_sum(s1, q1, p3, t1);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1436
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1437
    m_two_sum(s1, s1, t0, t0);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1438
    t0 += t1;
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1439
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1440
    m_quick_two_sum(s1, s1, t0, t0);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1441
    m_quick_two_sum(p2, s0, s1, t1);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1442
    m_quick_two_sum(p3, t1, t0, q0);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1443
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1444
    p4 = 2.0 * a[0] * a[3];
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1445
    p5 = 2.0 * a[1] * a[2];
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1446
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1447
    m_two_sum(p4, p4, p5, p5);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1448
    m_two_sum(q2, q2, q3, q3);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1449
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1450
    m_two_sum(t0, p4, q2, t1);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1451
    t1 = t1 + p5 + q3;
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1452
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1453
    m_two_sum(p3, p3, t0, p4);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1454
    p4 = p4 + q0 + t1;
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1455
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1456
    m_renorm5(p0, p1, p2, p3, p4);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1457
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1458
    __qNew_qdReal(newQD, p0, p1, s0, s1);
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1459
    RETURN( newQD );
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1460
%}.
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1461
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1462
    "
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1463
     (QDouble fromFloat:4.0) squared
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1464
     (1e20 + (QDouble fromFloat:1.0)) squared
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1465
    "
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1466
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1467
    "Created: / 13-06-2017 / 01:27:58 / cg"
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
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1470
!QDouble methodsFor:'printing & storing'!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1471
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1472
digitsWithPrecision:precision
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1473
    "generate digits and exponent.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1474
     if precision is >0, that many digits are generated.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1475
     If it is 0 the required number of digits is generated
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1476
     (but never more than the decimalPrecision, which is 65)"
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1477
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1478
    |numDigits r exp i d out str|
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1479
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1480
    numDigits := precision+1. "/ number of digits
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1481
    r := self abs.
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1482
    self d0 = 0.0 ifTrue:[
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1483
	^ { String new:(precision max:1) withAll:$0 . 0 }
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1484
    ].
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1485
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1486
    out := WriteStream on:(String new:precision+5).
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1487
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1488
    "/ determine approx. exponent
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1489
    exp := self d0 abs log10 floor.
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1490
    exp < -300 ifTrue:[
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1491
	"/ 1e-305 asQDouble
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1492
	r := r * (10.0 raisedToInteger:300).
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1493
	r := r / (10.0 raisedToInteger:(exp+300)).
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1494
    ] ifFalse:[
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1495
	exp > 300 ifTrue:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1496
	    "/ 1e305 asQDouble
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1497
	    "/ lexpr(x,exp) = x * 2 ^ exp
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1498
self halt.
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1499
	    r := r * (2 raisedTo:-53).
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1500
	    r := r / (10.0 asQDouble raisedTo: exp).
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1501
	    r := r * (2 raisedTo:53).
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1502
	] ifFalse:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1503
	    r := r / (10.0 asQDouble raisedTo:exp).
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1504
	]
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1505
    ].
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1506
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1507
    "/ Fix exponent if we are off by one
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1508
    (r >= 10.0) ifTrue:[
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1509
	r := r / 10.0.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1510
	exp := exp + 1.
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1511
    ] ifFalse:[
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1512
	(r < 1.0) ifTrue:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1513
	    r := r * 10.0.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1514
	    exp := exp - 1.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1515
	]
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1516
    ].
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1517
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1518
    ((r >= 10.0) or:[ r < 1.0 ]) ifTrue:[
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1519
	self error:'can''t compute exponent.'.
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1520
    ].
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1521
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1522
    "/
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1523
    "/ Extract the digits
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1524
    "/ notice, that the d1,d2 and d3 components might
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1525
    "/ be negative; therefore characters out of the 0..9 range
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1526
    "/ might be produced here
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1527
    "/
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1528
    i := 1.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1529
    [ (precision ~~ 0 and:[ i <= numDigits ])
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1530
    or:[ (precision == 0 and:[r d0 ~= 0.0])  ]] whileTrue:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1531
	d := r d0 truncated.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1532
	r := r - d.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1533
	r := r * 10.0.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1534
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1535
	out nextPut:($0 + d).
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1536
	i := i + 1.
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1537
    ].
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1538
    numDigits := i-1.
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1539
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1540
    str := out contents.
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1541
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1542
    "/ Fix out-of-range digits.
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1543
    numDigits to:2 by:-1 do:[:i |
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1544
	(str at:i) < $0 ifTrue:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1545
	    str at:i-1 put:(str at:i-1) - 1.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1546
	    str at:i put:(str at:i) + 10.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1547
	] ifFalse:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1548
	    (str at:i) > $9 ifTrue:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1549
		str at:i-1 put:(str at:i-1) + 1.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1550
		str at:i put:(str at:i) - 10.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1551
	    ].
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1552
	].
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1553
    ].
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1554
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1555
    str first <= $0 ifTrue:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1556
	self error:'non-positive leading digit'
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1557
    ].
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1558
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1559
    "/ Round, handle carry
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1560
    (str at:numDigits) >= $5 ifTrue:[
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1561
	str at:numDigits-1 put:(str at:numDigits-1) + 1.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1562
	i := numDigits-1.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1563
	[i > 1 and:[(str at:i) > $9]] whileTrue:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1564
	    str at:i put:(str at:i) - 10.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1565
	    i := i - 1.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1566
	    str at:i put:(str at:i) + 1.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1567
	]
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1568
    ].
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1569
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1570
    "/ If first digit is 10, shift everything.
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1571
    str first > $9 ifTrue:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1572
	exp := exp + 1.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1573
	str at:1 put:$0.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1574
	str := '1',str
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1575
    ].
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1576
    ^ { (str copyTo:numDigits-1) . exp }
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1577
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1578
    "
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1579
     0 asQDouble digitsWithPrecision:1      -> #('0' 0)
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1580
     0 asQDouble digitsWithPrecision:0      -> #('0' 0)
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1581
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1582
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1583
     1.2345 printfPrintString:'%.4f'
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1584
     1.2345 asQDouble digitsWithPrecision:5 -> #('12345' 0)
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1585
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1586
     --- but 1.2345 is not really what you think:
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1587
     1.2345 printfPrintString:'%.20f'
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1588
     1.2345 asQDouble digitsWithPrecision:20 -> #('12344999999999999307' 0)
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1589
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1590
     12.345 asQDouble digitsWithPrecision:5 -> #('12345' 1)
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1591
     12345 asQDouble digitsWithPrecision:5 -> #('12345' 4)
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1592
     12345.1 asQDouble digitsWithPrecision:5 -> #('12345' 4)
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1593
     12345.9 asQDouble digitsWithPrecision:5 -> #('12346' 4)
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1594
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1595
     1.2345 asQDouble / 10.0 asQDouble
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1596
     1.2345 asQDouble / 10.0
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1597
    "
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1598
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1599
    "Created: / 15-06-2017 / 09:10:01 / cg"
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1600
    "Modified: / 16-06-2017 / 10:01:03 / cg"
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1601
!
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1602
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1603
printOn:aStream
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1604
    "return a printed representation of the receiver.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1605
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1606
     Notice:
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1607
	this code was adapted from an ugly piece of c++ code,
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1608
	which was obviously hacked.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1609
	It does need a rework.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1610
	As an alternative, use the printf functions, which should also deal wth QDoubles"
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1611
4404
2708f482fe13 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4395
diff changeset
  1612
    PrintfScanf printf:'%f' on:aStream argument:self.
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1613
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1614
"/    self
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1615
"/        printOn:aStream precision:40 width:0
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1616
"/        fixed:true showPositive:false uppercase:false fillChar:(Character space)
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1617
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1618
    "
4404
2708f482fe13 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4395
diff changeset
  1619
     (1.2345 asQDouble) printOn:Transcript    . Transcript cr.
2708f482fe13 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4395
diff changeset
  1620
     (1.2345 asFloat) printOn:Transcript      . Transcript cr.
2708f482fe13 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4395
diff changeset
  1621
     (1.2345 asLongFloat) printOn:Transcript  . Transcript cr.
2708f482fe13 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4395
diff changeset
  1622
     (1.2345 asShortFloat) printOn:Transcript . Transcript cr.
2708f482fe13 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4395
diff changeset
  1623
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1624
     ((QDouble fromFloat:1.2345) / 10.0) printOn:Transcript
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1625
    "
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1626
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1627
    "Created: / 15-06-2017 / 01:51:36 / cg"
4404
2708f482fe13 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4395
diff changeset
  1628
    "Modified: / 17-06-2017 / 03:30:41 / cg"
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1629
!
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1630
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1631
printOn:aStream precision:precisionIn width:width
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1632
    fixed:fixed showPositive:showPositive uppercase:uppercase fillChar:fillChar
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1633
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1634
    "return a printed representation of the receiver.
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1635
     This is a parametrized entry, which can be used by printf-like functions.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1636
     Notice:
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1637
	this code was adapted from an ugly piece of c++ code,
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1638
	which was obviously hacked.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1639
	It does need a rework.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1640
	As an alternative, use the printf functions, which should also deal wth QDoubles
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1641
    "
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1642
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1643
    "
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1644
     1.2345 asQDouble printString
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1645
     12.345 asQDouble printString
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1646
     12345 asQDouble printString
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1647
    "
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1648
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1649
    |sgn count delta exp precision|
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1650
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1651
"/    self d1 = 0.0 ifTrue:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1652
"/        self d0 printOn:aStream.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1653
"/        ^ self.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1654
"/    ].
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1655
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1656
    count := 0.
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1657
    sgn := true.
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1658
    exp := 0.
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1659
    precision := precisionIn.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1660
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1661
    self isInfinite ifTrue:[
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1662
	self < 0 ifTrue:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1663
	    aStream nextPut:$-.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1664
	    count := 1.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1665
	] ifFalse:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1666
	    showPositive ifTrue:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1667
		aStream nextPut:$+.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1668
		count := 1.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1669
	    ] ifFalse:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1670
		sgn := false.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1671
	    ].
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1672
	].
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1673
	uppercase ifTrue:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1674
	    aStream nextPutAll:'INF'
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1675
	] ifFalse:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1676
	    aStream nextPutAll:'inf'
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1677
	].
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1678
	count := count + 3.
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1679
    ] ifFalse:[
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1680
	self isNaN ifTrue:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1681
	    uppercase ifTrue:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1682
		aStream nextPutAll:'NAN'
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1683
	    ] ifFalse:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1684
		aStream nextPutAll:'nan'
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1685
	    ].
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1686
	    count := count + 3.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1687
	] ifFalse:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1688
	    self < 0 ifTrue:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1689
		aStream nextPut:$-.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1690
		count := count + 1.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1691
	    ] ifFalse:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1692
		showPositive ifTrue:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1693
		    aStream nextPut:$+.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1694
		    count := count + 1.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1695
		] ifFalse:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1696
		    sgn := false.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1697
		].
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1698
	    ].
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1699
	    self = 0.0 ifTrue:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1700
		aStream nextPut:$0.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1701
		count := count + 1.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1702
		precision > 0 ifTrue:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1703
		    aStream nextPut:$..
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1704
		    count := count + 1.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1705
		    precision timesRepeat:[ aStream nextPut:$0 ].
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1706
		    count := count + precision.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1707
		].
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1708
		self halt.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1709
	    ] ifFalse:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1710
		|off d d_width_extra|
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1711
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1712
		"/ non-zero case
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1713
		off := fixed
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1714
			ifTrue:[ 1 + self asFloat abs log10 floor asInteger ]
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1715
			ifFalse:[1].
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1716
		d := precision + off.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1717
		d_width_extra := d.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1718
		fixed ifTrue:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1719
		    d_width_extra := 40 max:d.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1720
		].
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1721
		"/ highly special case - fixed mode, precision is zero, abs(*this) < 1.0
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1722
		"/ without this trap a number like 0.9 printed fixed with 0 precision prints as 0
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1723
		"/ should be rounded to 1.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1724
		(fixed and:[ (precision == 0) and:[ (self abs < 1.0) ]]) ifTrue:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1725
		    (self abs >= 0.5) ifTrue:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1726
			aStream nextPut:$1
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1727
		    ] ifFalse:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1728
			aStream nextPut:$0
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1729
		    ].
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1730
		    ^ self
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1731
		].
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1732
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1733
		"/ handle near zero to working precision (but not exactly zero)
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1734
		(fixed and:[ d <= 0 ]) ifTrue:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1735
		    aStream nextPut:$0.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1736
		    (precision > 0) ifTrue:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1737
			aStream nextPut:$. .
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1738
			aStream next:precision put:$0.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1739
		    ]
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1740
		] ifFalse:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1741
		    "/ default
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1742
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1743
		    |t j|
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1744
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1745
		    t := self digitsWithPrecision:(fixed ifTrue:[d_width_extra] ifFalse:[d])+1.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1746
		    exp := t second.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1747
		    t := t first.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1748
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1749
		    fixed ifTrue:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1750
			"/ fix the string if it's been computed incorrectly
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1751
			"/ round here in the decimal string if required
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1752
			t := self round_string_qd:t at:(d + 1) offset:off.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1753
			precision := t at:3.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1754
			off := t at:2.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1755
			t := t at:1.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1756
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1757
			(off > 0) ifTrue:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1758
			    aStream next:off putAll:t startingAt:1.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1759
			    (precision > 0) ifTrue:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1760
				aStream nextPut:$. .
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1761
				aStream next:precision-1 putAll:t startingAt:off+1.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1762
			    ]
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1763
			] ifFalse:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1764
			    aStream nextPutAll:'0.'.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1765
			    (off < 0) ifTrue:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1766
				aStream next:off negated put:$0.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1767
			    ].
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1768
			    aStream next:d putAll:t startingAt:0.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1769
			]
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1770
		    ] ifFalse:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1771
			aStream nextPut:(t at:1).
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1772
			(precision > 0) ifTrue:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1773
			    aStream nextPut:$. .
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1774
			].
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1775
			aStream next:precision putAll:t startingAt:2.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1776
		    ]
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1777
		].
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1778
	    ].
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1779
	]
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1780
    ].
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1781
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1782
    "/ trap for improper offset with large values
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1783
    "/ without this trap, output of values of the for 10^j - 1 fail for j > 28
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1784
    "/ and are output with the point in the wrong place, leading to a dramatically off value
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1785
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1786
"/    (fixed and:[ (precision > 0) ]) ifTrue:[
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1787
"/        "/ make sure that the value isn't dramatically larger
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1788
"/        from_string = atof(s.c_str());
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1789
"/
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1790
"/        // if this ratio is large, then we've got problems
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1791
"/        if( fabs( from_string / this->x[0] ) > 3.0 ){
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1792
"/
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1793
"/                int point_position;
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1794
"/                char temp;
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1795
"/
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1796
"/                // loop on the string, find the point, move it up one
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1797
"/                // don't act on the first character
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1798
"/                for(i=1; i < s.length(); i++){
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1799
"/                        if(s[i] == '.'){
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1800
"/                                s[i] = s[i-1] ;
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1801
"/                                s[i-1] = '.' ;
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1802
"/                                break;
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1803
"/                        }
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1804
"/                }
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1805
"/
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1806
"/                from_string = atof(s.c_str());
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1807
"/                // if this ratio is large, then the string has not been fixed
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1808
"/                if( fabs( from_string / this->x[0] ) > 3.0 ){
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1809
"/                        dd_real::error("Re-rounding unsuccessful in large number fixed point trap.") ;
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1810
"/                }
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1811
"/        }
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1812
"/    }
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1813
"/
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1814
    fixed ifFalse:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1815
      "/ Fill in exponent part
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1816
      aStream nextPut:(uppercase ifTrue:[$E] ifFalse:[$e]).
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1817
      aStream print:exp.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1818
    ].
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1819
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1820
    "/ fill in the blanks
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1821
    (delta := width-count) > 0 ifTrue:[
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1822
	self halt.
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1823
"/    if (fmt & ios_base::internal) {
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1824
"/      if (sgn)
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1825
"/        s.insert(static_cast<string::size_type>(1), delta, fill);
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1826
"/      else
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1827
"/        s.insert(static_cast<string::size_type>(0), delta, fill);
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1828
"/    } else if (fmt & ios_base::left) {
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1829
"/      s.append(delta, fill);
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1830
"/    } else {
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1831
"/      s.insert(static_cast<string::size_type>(0), delta, fill);
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1832
"/    }
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1833
"/  }
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1834
    ].
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1835
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1836
    "Created: / 15-06-2017 / 02:37:31 / cg"
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1837
    "Modified (comment): / 16-06-2017 / 14:48:30 / cg"
4385
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1838
!
3bfafdde1cb5 #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4380
diff changeset
  1839
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1840
printString
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1841
    "return a printed representation of the receiver"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1842
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1843
    ^ String streamContents:[:s | self printOn:s]
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1844
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1845
    "Created: / 12-06-2017 / 23:41:04 / cg"
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1846
    "Modified: / 15-06-2017 / 01:53:46 / cg"
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1847
!
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1848
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1849
round_string_qd:str at:precisionIn offset:offsetIn
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1850
    "returns a triple of: { new-str . new-offset . new-precision }"
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1851
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1852
    "/
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1853
    "/ Input string must be all digits or errors will occur.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1854
    "/
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1855
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1856
    |i numDigits offsetOut precisionOut|
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1857
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1858
    numDigits := precisionIn.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1859
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1860
    offsetOut := offsetIn.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1861
    precisionOut := precisionIn.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1862
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1863
    "/ Round, handle carry
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1864
    ((str at:numDigits) >= $5) ifTrue:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1865
	str at:numDigits-1 put:(str at:numDigits-1)+1.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1866
	i := numDigits-1.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1867
	[ i > 1 and:[ (str at:i) > $9] ] whileTrue:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1868
	    str at:i put:(str at:i)-10.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1869
	    i := i - 1.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1870
	    str at:i put:(str at:i)+1.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1871
	]
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1872
    ].
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1873
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1874
    "/ If first digit is 10, shift everything.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1875
    (str at:1) > $9 ifTrue:[
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1876
	"/ e++; // don't modify exponent here
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1877
	str replaceFrom:2 with:str startingAt:1.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1878
	str at:1 put:$1.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1879
	str at:2 put:$0.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1880
	offsetOut := offsetOut + 1.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1881
	precisionOut := precisionOut + 1.
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1882
    ].
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1883
    ^ { (str copyTo:precisionOut) . offsetOut . precisionOut }
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1884
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1885
    "Created: / 16-06-2017 / 10:12:39 / cg"
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1886
    "Modified (comment): / 16-06-2017 / 11:22:03 / cg"
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1887
! !
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1888
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1889
!QDouble methodsFor:'private accessing'!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1890
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1891
d0
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1892
    "the most significant (and highest valued) 53 bits of precision"
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1893
%{
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1894
    RETURN ( __MKFLOAT(__QuadDoubleInstPtr(self)->d_quadDoubleValue[0]) );
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1895
%}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1896
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1897
    "Created: / 12-06-2017 / 20:15:12 / cg"
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1898
    "Modified (comment): / 13-06-2017 / 17:59:47 / cg"
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1899
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1900
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1901
d1
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1902
    "the next most significant (and next highest valued) 53 bits of precision"
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1903
%{
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1904
    RETURN ( __MKFLOAT(__QuadDoubleInstPtr(self)->d_quadDoubleValue[1]) );
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1905
%}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1906
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1907
    "Created: / 12-06-2017 / 20:15:12 / cg"
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1908
    "Modified (comment): / 13-06-2017 / 18:00:00 / cg"
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1909
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1910
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1911
d2
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1912
%{
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1913
    RETURN ( __MKFLOAT(__QuadDoubleInstPtr(self)->d_quadDoubleValue[2]) );
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1914
%}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1915
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1916
    "Created: / 12-06-2017 / 20:15:29 / cg"
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1917
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1918
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1919
d3
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1920
    "the least significant (and smallest valued) 53 bits of precision"
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1921
%{
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1922
    RETURN ( __MKFLOAT(__QuadDoubleInstPtr(self)->d_quadDoubleValue[3]) );
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1923
%}
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1924
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1925
    "Created: / 12-06-2017 / 20:15:32 / cg"
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1926
    "Modified (comment): / 13-06-2017 / 18:00:18 / cg"
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1927
!
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1928
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1929
renorm
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1930
    "destructive renormalization"
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1931
%{
4395
3a01a83b6303 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4393
diff changeset
  1932
    double *a = __QuadDoubleInstPtr(self)->d_quadDoubleValue;
4386
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1933
    double c0, c1, c2, c3;
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1934
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1935
    c0 = a[0];
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1936
    c1 = a[1];
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1937
    c2 = a[2];
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1938
    c3 = a[3];
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1939
    m_renorm4(c0, c1, c2, c3);
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1940
    a[0] = c0;
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1941
    a[1] = c1;
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1942
    a[2] = c2;
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1943
    a[3] = c3;
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1944
    RETURN( self );
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1945
%}.
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1946
    ^ self error.
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1947
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1948
    "
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1949
     (QDouble fromFloat:1.0) renorm
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1950
    "
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1951
0a320155d78a #REFACTORING by cg
Claus Gittinger <cg@exept.de>
parents: 4385
diff changeset
  1952
    "Created: / 13-06-2017 / 18:05:33 / cg"
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1953
    "Modified: / 15-06-2017 / 00:12:59 / cg"
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1954
! !
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1955
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1956
!QDouble methodsFor:'testing'!
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1957
4404
2708f482fe13 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4395
diff changeset
  1958
isFinite
2708f482fe13 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4395
diff changeset
  1959
    ^ self d0 isFinite
2708f482fe13 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4395
diff changeset
  1960
2708f482fe13 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4395
diff changeset
  1961
    "Created: / 17-06-2017 / 03:40:30 / cg"
2708f482fe13 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4395
diff changeset
  1962
!
2708f482fe13 *** empty log message ***
Claus Gittinger <cg@exept.de>
parents: 4395
diff changeset
  1963
4393
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1964
isInfinite
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1965
    ^ self d0 isInfinite
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1966
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1967
    "Created: / 15-06-2017 / 01:57:57 / cg"
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1968
!
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1969
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1970
isNaN
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1971
    ^ self d0 isNaN
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1972
4084ca142033 #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4392
diff changeset
  1973
    "Created: / 15-06-2017 / 01:57:35 / cg"
4411
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
  1974
!
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
  1975
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
  1976
isOne
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
  1977
    ^ self d0 = 1.0
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
  1978
    and:[ self d1 = 0.0
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
  1979
    and:[ self d2 = 0.0
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
  1980
    and:[ self d3 = 0.0 ]]]
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
  1981
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
  1982
    "Created: / 18-06-2017 / 23:29:07 / cg"
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
  1983
!
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
  1984
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
  1985
isZero
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
  1986
    ^ self d0 = 0.0
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
  1987
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
  1988
    "Created: / 18-06-2017 / 23:29:25 / cg"
4380
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1989
! !
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1990
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1991
!QDouble class methodsFor:'documentation'!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1992
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1993
version
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1994
    ^ '$Header$'
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1995
!
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1996
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1997
version_CVS
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1998
    ^ '$Header$'
1f4fe7f1c1d3 initial checkin
Claus Gittinger <cg@exept.de>
parents:
diff changeset
  1999
! !
4411
8055a8f0b66f #FEATURE by cg
Claus Gittinger <cg@exept.de>
parents: 4404
diff changeset
  2000