swapforth

1
( Floating-Point                             JCB 22:38 03/22/15)
2

3
\ The following words are already defined:
4
\
5
\ fdup
6
\ fdrop
7
\ fswap
8
\ f0<
9
\ fabs
10
\ f<
11
\ fliteral
12
\ f+
13
\ f-
14
\ f*
15
\ f/
16
\ f>  move from float-stack to the data-stack
17
\ >f  move from data-stack to the float-stack
18

19
: fconstant  : postpone fliteral postpone ; ;
20

21
: fover     f> f> tuck >f >f >f ;
22
: f0=       f> 0= ;
23
: f=        f- f0= ;
24
: f!        f> swap ! ;
25
: f@        @ >f ;
26
: frot      f> f> f> -rot >f >f >f ;
27
: falign    align ;
28
: faligned  aligned ;
29
: float+    cell+ ;
30
: floats    cells ;
31
: fvariable variable ;
32
: fmax      fover fover f< if fswap then fdrop ;
33
: fmin      fover fover f< invert if fswap then fdrop ;
34

35
: f>s
36
    f>d d>s
37
;
38

39
: d>f
40
    dup 0< if
41
        dnegate recurse fnegate
42
    else
43
        us>f [ 65536 s>f fdup f* ] fliteral f*
44
        us>f f+
45
    then
46
;
47

48
marker testing-float1
49
    $feed55000000. 2constant big1
50

51
    T{ 79218.   d>f f>d -> 79218.   }T
52
    T{ 0 79218  d>f f>d -> 0 79218  }T
53
    T{ -1.      d>f f>d -> -1.      }T
54
    T{ big1     d>f f>d -> big1     }T
55

56
testing-float1
57

58
LOCALWORDS      \ {
59

60
1 s>f               fconstant FLT_1
61
0 s>f               fconstant FLT_0
62
10 s>f              fconstant FLT_10
63
FLT_1 FLT_10 f/     fconstant FLT_.1
64

65
: exponent
66
    23 rshift $ff and
67
;
68

69
: isat ( caddr u c -- caddr u 0 | caddr' u' 1 )
70
    over 0= if
71
        drop dup    ( caddr 0 0 )
72
    else
73
        >r
74
        over c@ r> = negate
75
        dup >r
76
        /string
77
        r>
78
    then
79
;
80

81
: >+-number ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) \ signed version of >number
82
    [char] - isat if
83
        >number
84
        2swap dnegate 2swap
85
    else
86
        [char] + isat drop
87
        >number
88
    then
89
;
90

91
: tuck0. ( caddr u - 0. caddr u ) \ tuck0. 0. under the string, prepare for >number
92
    0. 2swap
93
;
94

95
: pow10 ( n -- 10**n)
96
    dup 0< if
97
        FLT_1
98
        negate recurse 
99
        f/
100
    else
101
        FLT_1
102
        0 ?do
103
            FLT_10 f*
104
        loop
105
    then
106
;
107

108
: isdigit
109
    [char] 0 [char] 9 1+ within
110
;
111

112
\ consume the decimal digits, accumulating a floating fraction
113
: >frac ( c-addr u -- c-addr' u' ) ( F: 0 -- r )
114
    FLT_.1 fswap
115
    begin
116
        over c@ isdigit
117
        over 0<> and
118
    while
119
        over c@ [char] 0 - 
120
        fover s>f f* f+
121
        fswap FLT_.1 f* fswap
122
        1 /string
123
    repeat
124
    fswap fdrop
125
;
126

127
: notafloat
128
    fdrop 2drop 2drop 2drop false
129
;
130

131
: finput ( c-addr u -- true | false ) ( F: -- r |  )
132
    [char] - isat >r
133
    [char] + isat drop
134

135
    tuck0.
136
    >number           ( int. caddr u )
137

138
    FLT_0
139
    [char] . isat if
140
        >frac
141
    then                ( int. caddr u ) ( F: frac )
142

143
    tuck0.              ( int. exp. caddr u ) ( F: frac )
144
    [char] e isat >r
145
    [char] E isat r> or if
146
        >+-number
147
        0= if
148
            drop
149
            d>s >r      \ save exponent
150
            d>f f+      \ sum int. and fraction
151
            r> pow10 f* \ exponentiate
152
            r@ if       \ apply sign
153
                fnegate
154
            then
155
            true
156
        else
157
            notafloat
158
        then
159
    else
160
        notafloat
161
    then
162
    r> drop \ sign
163
;
164

165
:noname
166
    >inwas @ >in !
167
    parse-name
168
    finput if
169
        ['] fliteral
170
    else
171
        -13 throw
172
    then
173
; is hook-number
174

175
PUBLICWORDS     \ }{
176

177
: floor
178
    f>
179
    $007fffff over exponent \ 127=no shift, 128==shift 1, etc
180
    127 - dup 0< if
181
        drop 2drop 0
182
    else
183
        23 min
184
        rshift invert and
185
    then
186
    >f
187
;
188

189
\ This is rubbish. Should use:
190
\ "How to Print Floating-Point Numbers Accurately" Steele & White
191
\ https://lists.nongnu.org/archive/html/gcl-devel/2012-10/pdfkieTlklRzN.pdf
192
\ http://hub.darcs.net/pointfree/cranberry-net/browse/code/wetland-mcu-nodes/blocks/float.frt
193

194
: f.
195
    fdup f0< if
196
        fnegate [char] - emit
197
    then
198
    fdup f>d 0 d.r
199
    [char] . emit
200
    fdup floor f- 10000000e0 f* f>d
201
    <# # # # # # # # #> type
202
    space
203
;
204

205
: .f
206
    fdepth >r
207
    [char] < emit
208
    r@ 0 .r
209
    [char] > emit
210
    space
211
    r@ 0 ?do
212
        f>
213
    loop
214
    r> 0 ?do
215
        >f fdup f.
216
    loop
217
;
218

219
: frac ( F: r0 -- r1 )
220
    fdup floor f-
221
;
222

223
: fmod ( F: r0 r1 -- r2 )
224
    fswap fover     ( r1 r0 r1 )
225
    f/ frac f*
226
;
227

228
: fround
229
    fdup f0< if
230
        fnegate recurse fnegate
231
    else
232
        fdup floor fswap frac       ( F: integer-part fraction-part )
233
        fdup 0.5e f= if
234
            fdrop                   \ round to nearest even
235
            0.5e f* 0.5e f+ floor 2.0e f*
236
        else
237
            0.5e f< invert if
238
                FLT_1 f+
239
            then
240
        then
241
    then
242
;
243

244
DONEWORDS       \ }
245

246
marker testing-float1
247

248
    T{ 0.0e fround f0= -> true }T
249
    T{ 0.0E fround f0= -> true }T
250
    T{ 7.499e fround 7.0e f= -> true }T
251
    T{ 7.501e fround 8.0e f= -> true }T
252
    T{ 0.500e fround 0.0e f= -> true }T
253
    T{ 1.500e fround 2.0e f= -> true }T
254
    T{ 2.500e fround 2.0e f= -> true }T
255
    T{ 3.500e fround 4.0e f= -> true }T
256

257
    T{ 0e f>d -> 0. }T
258
    T{ 79218e f>d -> 79218. }T
259
    T{ -79218e f>d -> -79218. }T
260

261
testing-float1
262