Completed flonum primitives.

diff --git a/src/float.4th b/src/float.4th
index e100b46..51ba158 100644 (file)
--- a/src/float.4th
+++ b/src/float.4th
@@ -21,19 +21,19 @@ END-CODE
 CODE f*
     b = reinterpret(Float64, popPS())
     a = reinterpret(Float64, popPS())
-    pushPS(reinterpret(Int64, a*b))
+    pushPS(reinterpret(Int64, a*b + 0.0))
 END-CODE
 
 CODE f/
     b = reinterpret(Float64, popPS())
     a = reinterpret(Float64, popPS())
-    pushPS(reinterpret(Int64, a/b))
+    pushPS(reinterpret(Int64, a/b + 0.0))
 END-CODE
 
 CODE f^
     b = reinterpret(Float64, popPS())
     a = reinterpret(Float64, popPS())
-    pushPS(reinterpret(Int64, a^b))
+    pushPS(reinterpret(Int64, a^b + 0.0))
 END-CODE
 
 CODE fsqrt
@@ -80,7 +80,7 @@ END-CODE
 CODE fmod
     b = reinterpret(Float64, popPS())
     a = reinterpret(Float64, popPS())
-    pushPS(reinterpret(Int64, a%b))
+    pushPS(reinterpret(Int64, a%b + 0.0))
 END-CODE
 
 CODE flog
@@ -145,6 +145,11 @@ CODE fabs
     pushPS(reinterpret(Int64, abs(a)))
 END-CODE
 
+CODE fround
+    a = reinterpret(Float64, popPS())
+    pushPS(reinterpret(Int64, round(a)))
+END-CODE
+
 : f/mod
     2dup fmod -rot f/ ;
 
@@ -163,9 +168,12 @@ END-CODE
 : flog10
     flog [ 10 i->f flog ] literal f/ ;
 
+: truncate
+    dup 1.0 fmod f- ;
+
 : floor
     dup 0.0 f>= if
-        dup 1.0 fmod f-
+        truncate
     else
         dup 1.0 fmod dup 0.0 <> if
             f- 1.0 f-
@@ -175,6 +183,18 @@ END-CODE
     then
 ;
 
+: ceiling
+    dup 0.0 f>= if
+        dup 1.0 fmod dup 0.0 <> if
+            f- 1.0 f+
+        else
+            drop
+        then
+    else
+        truncate
+    then
+;
+
 : fasin ( float -- res )
     dup
     dup f* 1.0 swap f- fsqrt

diff --git a/src/scheme-primitives.4th b/src/scheme-primitives.4th
index 9289319..8dad18e 100644 (file)
--- a/src/scheme-primitives.4th
+++ b/src/scheme-primitives.4th
@@ -327,6 +327,38 @@
     swap floor swap
 ; 1 make-fa-primitive flo:floor
 
+:noname ( flonum -- flonum )
+    swap ceiling swap
+; 1 make-fa-primitive flo:ceiling
+
+:noname ( flonum -- flonum )
+    swap truncate swap
+; 1 make-fa-primitive flo:truncate
+
+:noname ( flonum -- flonum )
+    swap fround swap
+; 1 make-fa-primitive flo:round
+
+:noname ( flonum -- flonum )
+    drop floor f->i fixnum-type
+; 1 make-fa-primitive flo:floor->exact
+
+:noname ( flonum -- flonum )
+    drop ceiling f->i fixnum-type
+; 1 make-fa-primitive flo:ceiling->exact
+
+:noname ( flonum -- flonum )
+    drop truncate f->i fixnum-type
+; 1 make-fa-primitive flo:truncate->exact
+
+:noname ( flonum -- flonum )
+    drop f->i fixnum-type
+; 1 make-fa-primitive flo:round->exact
+
+:noname ( flonum flonum -- flonum )
+    drop swap drop f/ fatan flonum-type
+; 2 make-fa-primitive flo:atan2
+
 \ }}}
 
 \ ==== Pairs and Lists ==== {{{