From 631c05ef31816dfd2c7e8ea0f19a008a1e732605 Mon Sep 17 00:00:00 2001 From: Tim Vaughan Date: Sun, 11 Dec 2016 23:45:05 +1300 Subject: [PATCH] Added most flonum primitives. --- src/float.4th | 55 +++++++++++++++--- src/scheme-primitives.4th | 115 ++++++++++++++++++++++++++++++++++++-- 2 files changed, 157 insertions(+), 13 deletions(-) diff --git a/src/float.4th b/src/float.4th index bd429ce..e100b46 100644 --- a/src/float.4th +++ b/src/float.4th @@ -2,9 +2,9 @@ ( Cheating for now by using forth.jl CODE/END-CODE to access Julia's floating point support. This isn't - at all portable. That said, the year is 2016 and most - CPUs implement these operations - even the trig functions, - so I don't feel too bad! ) + at all portable. That said, the year is 2016 and + I've only cheated for words that have corresponding + x87 FPU instructions, so I don't feel too bad! ) CODE f+ b = reinterpret(Float64, popPS()) @@ -36,6 +36,11 @@ CODE f^ pushPS(reinterpret(Int64, a^b)) END-CODE +CODE fsqrt + a = reinterpret(Float64, popPS()) + pushPS(reinterpret(Int64, sqrt(a))) +END-CODE + CODE f> b = reinterpret(Float64, popPS()) a = reinterpret(Float64, popPS()) @@ -88,6 +93,26 @@ CODE fexp pushPS(reinterpret(Int64, exp(a))) END-CODE +CODE fsin + a = reinterpret(Float64, popPS()) + pushPS(reinterpret(Int64, sin(a))) +END-CODE + +CODE fcos + a = reinterpret(Float64, popPS()) + pushPS(reinterpret(Int64, cos(a))) +END-CODE + +CODE ftan + a = reinterpret(Float64, popPS()) + pushPS(reinterpret(Int64, tan(a))) +END-CODE + +CODE fatan + a = reinterpret(Float64, popPS()) + pushPS(reinterpret(Int64, atan(a))) +END-CODE + CODE fnan? a = reinterpret(Float64, popPS()) if isnan(a) @@ -115,6 +140,11 @@ CODE f->i pushPS(Int64(round(a))) END-CODE +CODE fabs + a = reinterpret(Float64, popPS()) + pushPS(reinterpret(Int64, abs(a))) +END-CODE + : f/mod 2dup fmod -rot f/ ; @@ -133,12 +163,6 @@ END-CODE : flog10 flog [ 10 i->f flog ] literal f/ ; -: fabs - dup 0.0 f< if - -1.0 f* - then -; - : floor dup 0.0 f>= if dup 1.0 fmod f- @@ -151,6 +175,19 @@ END-CODE then ; +: fasin ( float -- res ) + dup + dup f* 1.0 swap f- fsqrt + f/ + + fatan +; + +: facos ( float -- res ) + dup f* 1.0 swap f/ 1.0 f- fsqrt + fatan +; + : fhead ( float -- ) floor f->i 0 .R ; diff --git a/src/scheme-primitives.4th b/src/scheme-primitives.4th index 934c80e..9289319 100644 --- a/src/scheme-primitives.4th +++ b/src/scheme-primitives.4th @@ -1,4 +1,4 @@ -\ ==== Type predicates ==== {{{ +\ ==== Type predilcates ==== {{{ :noname ( args -- boolobj ) nil objeq? boolean-type @@ -16,6 +16,10 @@ fixnum-type istype? -rot 2drop boolean-type ; 1 make-fa-primitive fixnum? +:noname ( args -- boolobj ) + flonum-type istype? -rot 2drop boolean-type +; 1 make-fa-primitive flonum? + :noname ( args -- boolobj ) character-type istype? -rot 2drop boolean-type ; 1 make-fa-primitive char? @@ -171,15 +175,15 @@ drop swap drop >= boolean-type ; 2 make-fa-primitive fix:>= -:noname ( fixnum fixnum -- boolobj ) +:noname ( fixnum -- boolobj ) drop 0= boolean-type ; 1 make-fa-primitive fix:zero? -:noname ( fixnum fixnum -- boolobj ) +:noname ( fixnum -- boolobj ) drop 0> boolean-type ; 1 make-fa-primitive fix:positive? -:noname ( fixnum fixnum -- boolobj ) +:noname ( fixnum -- boolobj ) drop 0< boolean-type ; 1 make-fa-primitive fix:negative? @@ -220,6 +224,109 @@ ; +\ --- Flonums --- + +:noname ( flonum flonum -- bool ) + objeq? boolean-type +; 2 make-fa-primitive flo:= + +:noname ( flonum flonum -- bool ) + drop swap drop f< boolean-type +; 2 make-fa-primitive flo:< + +:noname ( flonum flonum -- bool ) + drop swap drop f> boolean-type +; 2 make-fa-primitive flo:> + + +:noname ( flonum -- bool ) + drop 0.0 = boolean-type +; 1 make-fa-primitive flo:zero? + +:noname ( flonum -- bool ) + drop 0.0 f> boolean-type +; 1 make-fa-primitive flo:positive? + +:noname ( flonum -- bool ) + drop 0.0 f< boolean-type +; 1 make-fa-primitive flo:negative? + + +:noname ( flonum1 flonum2 -- flonum1+flonum2 ) + drop swap drop f+ flonum-type +; 2 make-fa-primitive flo:+ + +:noname ( flonum1 flonum2 -- flonum1-flonum2 ) + drop swap drop f- flonum-type +; 2 make-fa-primitive flo:- + +:noname ( flonum1 flonum2 -- flonum1*flonum2 ) + drop swap drop f* flonum-type +; 2 make-fa-primitive flo:* + +:noname ( flonum1 flonum2 -- flonum1/flonum2 ) + drop swap drop f/ flonum-type +; 2 make-fa-primitive flo:/ + +:noname ( flonum1 flonum2 -- flonum1/flonum2 ) + drop swap drop f/ flonum-type +; 2 make-fa-primitive flo:/ + + +:noname ( flonum -- bool ) + drop dup + fnan? swap finf? or invert +; 1 make-fa-primitive flo:finite? + + +:noname ( flonum -- flonum ) + swap fabs swap +; 1 make-fa-primitive flo:abs + +:noname ( flonum -- flonum ) + swap fexp swap +; 1 make-fa-primitive flo:exp + +:noname ( flonum -- flonum ) + swap flog swap +; 1 make-fa-primitive flo:log + +:noname ( flonum -- flonum ) + swap fsin swap +; 1 make-fa-primitive flo:sin + +:noname ( flonum -- flonum ) + swap fcos swap +; 1 make-fa-primitive flo:cos + +:noname ( flonum -- flonum ) + swap ftan swap +; 1 make-fa-primitive flo:tan + +:noname ( flonum -- flonum ) + swap fasin swap +; 1 make-fa-primitive flo:asin + +:noname ( flonum -- flonum ) + swap facos swap +; 1 make-fa-primitive flo:acos + +:noname ( flonum -- flonum ) + swap fatan swap +; 1 make-fa-primitive flo:atan + +:noname ( flonum -- flonum ) + swap fsqrt swap +; 1 make-fa-primitive flo:sqrt + +:noname ( flonum flonum -- flonum ) + drop swap drop f^ flonum-type +; 2 make-fa-primitive flo:expt + +:noname ( flonum -- flonum ) + swap floor swap +; 1 make-fa-primitive flo:floor + \ }}} \ ==== Pairs and Lists ==== {{{ -- 2.20.1