mirror of
https://git.sr.ht/~crc_/retroforth
synced 2024-11-16 19:48:56 +01:00
100 lines
3.6 KiB
Forth
100 lines
3.6 KiB
Forth
# Decimal Numbers
|
|
|
|
~~~
|
|
{{
|
|
'DPU var
|
|
:identify
|
|
@DPU n:zero? 0; drop
|
|
#20 io:scan-for dup n:negative?
|
|
[ drop 'IO_DEVICE_TYPE_0020_NOT_FOUND s:put nl ]
|
|
[ !DPU ] choose ;
|
|
---reveal---
|
|
:decimal:operation identify @DPU io:invoke ;
|
|
}}
|
|
~~~
|
|
|
|
~~~
|
|
:n:to-decimal (n-_dec:-n) #0 decimal:operation ;
|
|
:s:to-decimal (s-_dec:-n) #1 decimal:operation ;
|
|
:dec:to-number (dec:a-__-n) #2 decimal:operation ;
|
|
:dec:to-string (dec:n-__-s) s:empty dup #3 decimal:operation ;
|
|
:dec:+ (dec:ab-c) #4 decimal:operation ;
|
|
:dec:- (dec:ab-c) #5 decimal:operation ;
|
|
:dec:* (dec:ab-c) #6 decimal:operation ;
|
|
:dec:/ (dec:ab-c) #7 decimal:operation ;
|
|
:dec:floor (dec:ab-c) #8 decimal:operation ;
|
|
:dec:ceiling (dec:f-f) #9 decimal:operation ;
|
|
:dec:sqrt (dec:f-f) #10 decimal:operation ;
|
|
:dec:eq? (dec:ab-c) #11 decimal:operation ;
|
|
:dec:-eq? (dec:ab-c) #12 decimal:operation ;
|
|
:dec:lt? (dec:ab-c) #13 decimal:operation ;
|
|
:dec:gt? (dec:ab-c) #14 decimal:operation ;
|
|
:dec:depth (-n) #15 decimal:operation ;
|
|
:dec:dup (dec:a-aa) #16 decimal:operation ;
|
|
:dec:drop (dec:a-) #17 decimal:operation ;
|
|
:dec:swap (dec:ab-ba) #18 decimal:operation ;
|
|
:dec:log (dec:ab-c) #19 decimal:operation ;
|
|
:dec:power (dec:ab-c) #20 decimal:operation ;
|
|
:dec:sin (dec:f-f) #21 decimal:operation ;
|
|
:dec:cos (dec:f-f) #22 decimal:operation ;
|
|
:dec:tan (dec:f-f) #23 decimal:operation ;
|
|
:dec:asin (dec:f-f) #24 decimal:operation ;
|
|
:dec:acos (dec:f-f) #25 decimal:operation ;
|
|
:dec:atan (dec:f-f) #26 decimal:operation ;
|
|
:dec:push (dec:f-) #27 decimal:operation ;
|
|
:dec:pop (dec:-f) #28 decimal:operation ;
|
|
:dec:adepth (-n) #29 decimal:operation ;
|
|
~~~
|
|
|
|
Above this, additional functions are defined. First are words
|
|
to aid in structuring the floating point stack.
|
|
|
|
~~~
|
|
:dec:over (dec:ab-aba) dec:push dec:dup dec:pop dec:swap ;
|
|
:dec:tuck (dec:ab-bab) dec:dup dec:push dec:swap dec:pop ;
|
|
:dec:nip (dec:ab-b) dec:swap dec:drop ;
|
|
:dec:drop-pair (dec:ab-) dec:drop dec:drop ;
|
|
:dec:dup-pair (dec:ab-abab) dec:over dec:over ;
|
|
:dec:rot (dec:abc-bca) dec:push dec:swap dec:pop dec:swap ;
|
|
~~~
|
|
|
|
Then a word to allow creation of floating point values via a
|
|
`,` sigil.
|
|
|
|
~~~
|
|
:sigil:, (s-__dec:-a)
|
|
compiling? &s:keep &s:temp choose &s:to-decimal class:word ; immediate
|
|
~~~
|
|
|
|
~~~
|
|
:dec:square (dec:n-m) dec:dup dec:* ;
|
|
:dec:positive? (-f__dec:a-) #0 n:to-decimal dec:gt? ;
|
|
:dec:negative? (-f__dec:a-) #0 n:to-decimal dec:lt? ;
|
|
:dec:negate (dec:a-b) #-1 n:to-decimal dec:* ;
|
|
:dec:abs (dec:a-b) dec:dup dec:negative? &dec:negate if ;
|
|
:dec:put (dec:a-) dec:to-string s:put ;
|
|
|
|
:dec:PI (dec:-F) ,3.141592 ;
|
|
:dec:E (dec:-F) ,2.718281 ;
|
|
:dec:NAN (dec:-n) ,0 ,0 dec:/ ;
|
|
:dec:INF (dec:-n) ,1.0 ,0 dec:/ ;
|
|
:dec:-INF (dec:-n) ,-1.0 ,0 dec:/ ;
|
|
:dec:nan? (dec:n-,-f) dec:dup dec:-eq? ;
|
|
:dec:inf? (dec:n-,-f) dec:INF dec:eq? ;
|
|
:dec:-inf? (dec:n-,-f) dec:-INF dec:eq? ;
|
|
:dec:round (-|dec:a-b)
|
|
dec:dup dec:negative?
|
|
[ ,0.5 dec:- dec:ceiling ]
|
|
[ ,0.5 dec:+ dec:floor ] choose ;
|
|
:dec:min (dec:nn-n) dec:dup-pair dec:lt? &dec:drop &dec:nip choose ;
|
|
:dec:max (dec:nn-n) dec:dup-pair dec:gt? &dec:drop &dec:nip choose ;
|
|
:dec:limit (dec:nlu-n) dec:swap dec:push dec:min dec:pop dec:max ;
|
|
:dec:between? (dec:nlu-n) dec:rot dec:dup dec:push dec:rot dec:rot dec:limit dec:pop dec:eq? ;
|
|
:dec:inc (dec:n-n) ,1 dec:+ ;
|
|
:dec:dec (dec:n-n) ,1 dec:- ;
|
|
:dec:case (dec:ff-,q-)
|
|
dec:over dec:eq? [ dec:drop call #-1 ] [ drop #0 ] choose 0; pop drop-pair ;
|
|
:dec:sign (-n|dec:a-)
|
|
dec:dup ,0 dec:eq? [ #0 dec:drop ] if;
|
|
,0 dec:gt? [ #1 ] [ #-1 ] choose ;
|
|
~~~
|