Added most flonum primitives.

diff --git a/src/float.4th b/src/float.4th
index bd429ce..e100b46 100644 (file)
--- 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 (file)
--- 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 ==== {{{