Changeset 13606 in project

Timestamp:

03/09/09 04:25:02 (12 years ago)

Author:

Kon Lovett

Message:

Save.

Location:

release/4/err5rs-arithmetic/trunk

Files:

• err5rs-arithmetic-bitwise.scm (modified) (4 diffs)
• err5rs-arithmetic-fixnums.scm (modified) (4 diffs)
• err5rs-arithmetic-flonums.scm (modified) (2 diffs)
• err5rs-arithmetic.meta (modified) (1 diff)

release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-bitwise.scm

@@ -20 +20 @@
     ##sys#string-append ) )
 
+;;
+
 (require-library srfi-1 int-limits)
 
 (include "chicken-primitive-object-inlines")
+
+;TODO - add to chicken-primitive-object-inline
+
+(define-inline (%number? x) (##core#inline "C_i_numberp" x))
+
+(define-inline (%zero? n) (##core#inline "C_i_zerop" n))
+
+(define-inline (%arithmetic-shift x d) (##core#inline_allocate ("C_a_i_arithmetic_shift" 4) x d))
+
+(define-inline (%bitwise-not x) (##core#inline_allocate ("C_a_i_bitwise_not" 4) x))
+(define-inline (%bitwise-ior x y) (##core#inline_allocate ("C_a_i_bitwise_ior" 4) x y))
+(define-inline (%bitwise-and x y) (##core#inline_allocate ("C_a_i_bitwise_and" 4) x y))
+
+(define-inline (%negative? x) (##core#inline "C_i_negativep" x))
+
+;;
 
 #>
@@ -271 +289 @@
 ;;
 
-(define-inline (%boolean->bit b) (if b 1 0))
-
-(define-inline (%boolean->bit* bit) (if (zero? bit) 0 (%boolean->bit bit)))
-
-(define-inline (%arithmetic-shift x d) (##core#inline_allocate ("C_a_i_arithmetic_shift" 4) x d))
-
-(define-inline (%bitwise-not x) (##core#inline_allocate ("C_a_i_bitwise_not" 4) x))
-
-(define-inline (%bitwise-ior x y) (##core#inline_allocate ("C_a_i_bitwise_ior" 4) x y))
-
-(define-inline (%bitwise-and x y) (##core#inline_allocate ("C_a_i_bitwise_and" 4) x y))
-
-(define-inline (%negative? x) (##core#inline "C_i_negativep" x))
+(define-inline (%boolean->bit obj) (if obj 1 0))
+
+(define-inline (%boolean->bit* obj)
+  (if (and (%number obj) (%zero? obj)) 0
+      (%boolean->bit obj) ) )
 
 
@@ -403 +413 @@
   (let ((zeros (make-list machine-word-bits #f)))
     (lambda (n #!optional bitlen)
-      (if (zero? n)
+      (if (%zero? n)
           (if bitlen (take zeros bitlen) zeros)
           (let ((bitlen (or bitlen (*bitwise-length n))))
@@ -527 +537 @@
     (%check-non-negative-fixnum 'bitwise-integer->list bitlen)
     (%check-word-bits 'bitwise-integer->list bitlen) )
-  (bitwise-integer->list value bitlen) )
+  (*bitwise-integer->list value bitlen) )
 
 (define (bitwise-arithmetic-shift value signed-count)

release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-fixnums.scm

@@ -18 +18 @@
     ##sys#string-append ) )
 
+;;
+
 (require-library err5rs-arithmetic-bitwise)
 
 (include "chicken-primitive-object-inlines")
 
-
-;;;
+;TODO - add to chicken-primitive-object-inline
+
+(define-inline (%< x y) ((##core#primitive "C_lessp") x y))
+(define-inline (%<= x y) ((##core#primitive "C_less_or_equal_p") x y))
+(define-inline (%> x y) ((##core#primitive "C_greaterp") x y))
+(define-inline (%>= x y) ((##core#primitive "C_greater_or_equal_p") x y))
+
+(define-inline (%+ x y) ((##core#primitive "C_plus") x y))
+(define-inline (%- x y) ((##core#primitive "C_minus") x y))
+(define-inline (%* x y) ((##core#primitive "C_times") x y))
+(define-inline (%/ x y) ((##core#primitive "C_divide") x y))
+
+(define-inline (%quotient x y) ((##core#primitive "C_quotient") x y))
+
+(define-inline (%arithmetic-shift x d) (##core#inline_allocate ("C_a_i_arithmetic_shift" 4) x d))
+
+;;
 
 (define-inline (%fixnum-zero-division-error loc fx1 fx2)
@@ -56 +73 @@
 
 ;;
+
+;Note - argument order is (func acc cur) & not (func cur acc) as in (fold func).
 
 (define-inline (%fxfold-1 loc func init lyst)
@@ -71 +90 @@
         (let ((cur (%car ls)))
           (%check-fixnum loc cur)
-          (and (func acc (%car ls))
-               (loop (%cdr ls) (%car ls)) ) ) ) ) )
-
-;;
-
-(define-inline (%< x y) ((##core#primitive "C_lessp") x y))
-
-(define-inline (%<= x y) ((##core#primitive "C_less_or_equal_p") x y))
-
-(define-inline (%> x y) ((##core#primitive "C_greaterp") x y))
-
-(define-inline (%>= x y) ((##core#primitive "C_greater_or_equal_p") x y))
-
-(define-inline (%+ x y) ((##core#primitive "C_plus") x y))
-
-(define-inline (%- x y) ((##core#primitive "C_minus") x y))
-
-(define-inline (%* x y) ((##core#primitive "C_times") x y))
-
-(define-inline (%quotient x y) ((##core#primitive "C_quotient") x y))
-
-(define-inline (%arithmetic-shift x d) (##core#inline_allocate ("C_a_i_arithmetic_shift" 4) x d))
+          (and (func acc cur)
+               (loop (%cdr ls) cur) ) ) ) ) )
 
 ;;
@@ -191 +190 @@
 
 (define (*fx= x y) (%fx= x y))
-
 (define (*fx< x y) (%fx< x y))
-
 (define (*fx> x y) (%fx> x y))
-
 (define (*fx>= x y) (%fx>= x y))
-
 (define (*fx<= x y) (%fx<= x y))
-
 (define (*fxmax x y) (%fxmax x y))
-
 (define (*fxmin x y) (%fxmin x y))
-
 (define (*fxand x y) (%fxand x y))
-
 (define (*fxior x y) (%fxor x y))
-
 (define (*fxxor x y) (%fxxor x y))
-
 (define (*fx+ x y) (%fx+ x y))
-
 (define (*fx- x y) (%fx- x y))
-
 (define (*fx* x y) (%fx* x y))
-
 (define (*fx/ x y) (%fx/ x y))
 

release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-flonums.scm

@@ -1 @@
-;;;; flonum-extras.scm
+;;;; err5rs-arithmetic-flonums.scm
 ;;;; Kon Lovett, Mar '09
 
@@ -7 +7 @@
 (declare
         (usual-integrations)
-        (generic)
   (disable-interrupts)
+        (arithmetic-type generic)
+        (inline)
+        #;(local)
         (no-bound-checks)
-        (no-procedure-checks-for-usual-bindings)
+        (no-procedure-checks)
         (bound-to-procedure
-          ##sys#signal-hook
+          ##sys#check-exact
+          ##sys#check-inexact
           ##sys#check-integer
-          ##sys#flonum-fraction
-          ##sys#floor
-          ##sys#ceiling
-          ##sys#exact->inexact )
-  (export
-    ; Checked
-    real->flonum
-    fixnum->flonum
-    fl=?
-    fl<?
-    fl>?
-    fl<=?
-    fl>=?
-    flcompare
-    flinteger?
-    flzero?
-    flpositive?
-    flnegative?
-    flodd?
-    fleven?
-    flfinite?
-    flinfinite?
-    flnan?
-    fl+
-    fl*
-    fl-
-    fl/
-    flmax
-    flmin
-    flmax-and-min
-    flabs
-    flfraction
-    flfloor
-    flceiling
-    flround
-    fltruncate
-    fldiv
-    flmod
-    fldiv-and-mod
-    fldiv0
-    flmod0
-    fldiv0-and-mod0
-    flexp
-    fllog
-    flsin
-    flcos
-    fltan
-    flasin
-    flacos
-    flatan
-    flsqrt
-    flexpt
-    flnumerator
-    fldenominator
-    ; Unchecked
-    %fp=
-    %fp<
-    %fp>
-    %fp>=
-    %fp<=
-    %fpmax
-    %fpmin
-    %fp+
-    %fp-
-    %fp*
-    %fp/
-    ) )
-
-(require-library mathh)
+          ##sys#check-number
+          ##sys#signal-hook ) )
+
+;;
+
+(require-library srfi-1 mathh)
 
 (include "chicken-primitive-object-inlines")
 
+;TODO - add to chicken-primitive-object-inline
+
+(define-inline (%< x y) ((##core#primitive "C_lessp") x y))
+
+(define-inline (%finite? x) (##core#inline "C_i_finitep" x))
+
+(define-inline (%fp= x y) (##core#inline "C_flonum_equalp" x y))
+(define-inline (%fp< x y) (##core#inline "C_flonum_lessp" x y))
+(define-inline (%fp<= x y) (##core#inline "C_flonum_less_or_equal_p" x y))
+(define-inline (%fp> x y) (##core#inline "C_flonum_greaterp" x y))
+(define-inline (%fp>= x y) (##core#inline "C_flonum_greater_or_equal_p" x y))
+
+(define-inline (%fpmax x y) (##core#inline "C_i_flonum_max" x y))
+(define-inline (%fpmax x y) (##core#inline "C_i_flonum_min" x y))
+
+(define-inline (%fpfloor x) ((##core#primitive "C_flonum_floor") x))
+(define-inline (%fpceiling x) ((##core#primitive "C_flonum_ceiling") x))
+(define-inline (%fptruncate x) ((##core#primitive "C_flonum_truncate") x))
+(define-inline (%fpround x) ((##core#primitive "C_flonum_round") x))
+
+(define-inline (%fpfraction x) ((##core#primitive "C_flonum_fraction") x))
+
+(define-inline (%fpneg x y) (##core#inline_allocate ("C_a_i_flonum_negate" 4) x y))
+
+(define-inline (%fp- x y) (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y))
+(define-inline (%fp+ x y) (##core#inline_allocate ("C_a_i_flonum_plus" 4) x y))
+(define-inline (%fp* x y) (##core#inline_allocate ("C_a_i_flonum_times" 4) x y))
+(define-inline (%fp/ x y) (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y))
+
+(define-inline (%fpabs x) (##core#inline_allocate ("C_a_i_abs" 4) x))
+(define-inline (%fpacos x) (##core#inline_allocate ("C_a_i_acos" 4) x))
+(define-inline (%fpasin x) (##core#inline_allocate ("C_a_i_asin" 4) x))
+(define-inline (%fpatan x) (##core#inline_allocate ("C_a_i_atan" 4) x))
+(define-inline (%fpatan2 x) (##core#inline_allocate ("C_a_i_atan2" 4) x))
+(define-inline (%fpcos x) (##core#inline_allocate ("C_a_i_cos" 4) x))
+(define-inline (%fpexp x) (##core#inline_allocate ("C_a_i_exp" 4) x))
+(define-inline (%fplog x) (##core#inline_allocate ("C_a_i_log" 4) x))
+(define-inline (%fpsin x) (##core#inline_allocate ("C_a_i_sin" 4) x))
+(define-inline (%fpsqrt x) (##core#inline_allocate ("C_a_i_sqrt" 4) x))
+(define-inline (%fptan x) (##core#inline_allocate ("C_a_i_tan" 4) x))
+
+(define-inline (%expt x y) ((##core#primitive "C_expt") x y))
+
+(define-inline (%integer? x) (##core#inline "C_i_integerp" x))
+
+(define-inline (%exact->inexact x) ((##core#primitive "C_exact_to_inexact") x))
+
+;;
+
+(define-inline (%check-fixnum loc obj) (##sys#check-exact obj loc))
+
+(define-inline (%check-flonum loc obj) (##sys#check-inexact obj loc))
+
+(define-inline (%check-non-negative-integer loc obj)
+  (##sys#check-integer obj loc)
+  (unless (%< 0 obj)
+    (##sys#signal-hook #:type-error loc "bad argument type - not a non-negative integer" obj) ) )
+
+(define-inline (%check-number loc obj) (##sys#check-number obj loc))
+
+;;
+
+;Note - argument order is (func acc cur) & not (func cur acc) as in (fold func).
+
+(define-inline (%fpfold-1 loc func init lyst)
+  (%check-flonum loc init)
+  (let loop ([ls lyst] [acc init])
+          (if (%null? ls) acc
+              (let ([cur (%car ls)])
+          (%check-flonum loc cur)
+          (loop (%cdr ls) (func acc cur)) ) ) ) )
+
+(define-inline (%fpand-fold-1 loc func init lyst)
+  (%check-flonum loc init)
+  (let loop ([ls lyst] [acc init])
+          (or (%null? ls)
+        (let ([cur (%car ls)])
+          (%check-flonum loc cur)
+                (and (func acc cur)
+               (loop (%cdr ls) cur) ) ) ) ) )
+
+;;
+
+(define-inline (%fpquotient fpn fpd) (%fptruncate (%fp/ fpn fpd)))
+
+(define-inline (%fpremainder fpn fpd) (%fp- fpn (%fp* (%fpquotient fpn fpd) fpd)))
+
+(define-inline (%fpquotient-and-remainder  fpn fpd)
+  (let ([quo (%fpquotient fpn fpd)])
+    (values quo (%fp- fpn (%fp* quo fpd))) ) )
+
+(define-inline (%fpinteger? fp) (%integer? x))
+
+(define-inline (%fpnan? fp) (not (%fp= fp fp)))
+
+(define-inline (%fp=? x y) (%fp= x y))
+
+(define-inline (%fp<? x y) (or (and (%fp= -0.0 x) (%fp= 0.0 y)) (%fp< x y)))
+
+(define-inline (%fp<=? x y) (or (and (%fp= -0.0 x) (%fp= 0.0 y)) (%fp<= x y)))
+
+(define-inline (%fp>? x y) (or (and (%fp= 0.0 x) (%fp= -0.0 y)) (%fp> x y)))
+
+(define-inline (%fp>=? x y) (or (and (%fp= 0.0 x) (%fp= -0.0 y)) (%fp>= x y)))
+
+(define-inline (%fpdiv0-and-mod0 fpn fpd)
+  (let-values ([(quo rem) (%fpquotient-and-remainder  fpn fpd)])
+    (cond [(%fp>=? fpd 0.0)
+            (if (%fp<?
+                 rem
+                 (%fp/ fpd 2.0))
+                (if (%fp>=?
+                     rem
+                     (%fp/ fpd -2.0))
+                    (values quo rem)
+                    (values (%fp- quo 1.0)
+                            (%fp+ rem fpd)) )
+                (values (%fp+ quo 1.0)
+                        (%fp- rem fpd)) ) ]
+          [(%fp<?
+            rem
+            (%fp/ fpd -2.0))
+            (if (%fp>=?
+                 rem
+                 (%fp/ fpd 2.0))
+                (values quo rem)
+                (values (%fp+ quo 1.0)
+                        (%fp- rem fpd)) ) ]
+          [else
+            (values (%fp- quo 1.0)
+                    (%fp+ rem fpd)) ] ) ) )
+
+(define-inline (%fpdiv0 fpn fpd)
+  (let-values ([(quo rem) (%fpquotient-and-remainder  fpn fpd)])
+    (cond [(%fp>=? fpd 0.0)
+            (if (%fp<?
+                 rem
+                 (%fp/ fpd 2.0))
+                (if (%fp>=?
+                     rem
+                     (%fp/ fpd -2.0))
+                    quo
+                    (%fp- quo 1.0) )
+                (%fp+ quo 1.0) ) ]
+          [(%fp<?
+            rem
+            (%fp/ fpd -2.0))
+            (if (%fp>=?
+                 rem
+                 (%fp/ fpd 2.0))
+                quo
+                (%fp+ quo 1.0) ) ]
+          [else
+            (%fp- quo 1.0) ] ) ) )
+
+(define-inline (%fpmod0 fpn fpd)
+  (let ([rem (%fpremainder fpn fpd)])
+    (cond [(%fp>=? fpd 0.0)
+            (if (%fp<?
+                 rem
+                 (%fp/ fpd 2.0))
+                (if (%fp>=?
+                     rem
+                     (%fp/ fpd -2.0))
+                    rem
+                    (%fp+ rem fpd) )
+                (%fp- rem fpd) ) ]
+          [(%fp<?
+            rem
+            (%fp/ fpd -2.0))
+            (if (%fp>=?
+                 rem
+                 (%fp/ fpd 2.0))
+                rem
+                (%fp- rem fpd) )]
+          [else
+            (%fp+ rem fpd) ] ) ) )
+
+
 ;;;
 
-(define (check-flonum loc obj)
-  (unless (##core#inline "C_i_flonump" obj)
-    (##sys#signal-hook #:type-error loc "bad argument type - not a flonum" obj) ) )
-
-(define (check-non-negative-integer loc obj)
-  (##sys#check-integer obj loc)
-  (unless ((##core#primitive "C_lessp") 0 obj)
-    (##sys#signal-hook #:type-error loc "bad argument type - not a non-negative integer" obj) ) )
+(module err5rs-arithmetic-bitwise (;export
+  ; ERR5RS
+  real->flonum fixnum->flonum
+  fl=? fl<? fl>? fl<=? fl>=? flcompare
+  flinteger?
+  flzero? flpositive? flnegative? flodd? fleven?
+  flfinite? flinfinite? flnan?
+  fl+ fl* fl- fl/
+  flmax flmin flmax-and-min
+  flabs
+  flfraction
+  flfloor flceiling flround fltruncate
+  fldiv flmod fldiv-and-mod fldiv0 flmod0 fldiv0-and-mod0
+  flexp fllog flsin flcos fltan flasin flacos flatan flsqrt flexpt
+  flnumerator fldenominator)
+
+(import scheme chicken foreign srfi-1 mathh)
+
+
+;;; Procedures wrapping primitive-inlines for fold operations
+
+(define (*fp=? x y) (%fp=? x y))
+(define (*fp<? x y) (%fp<? x y))
+(define (*fp>? x y) (%fp>? x y))
+(define (*fp<=? x y) (%fp<=? x y))
+(define (*fp>=? x y) (%fp>=? x y))
+(define (*fpmax x y) (%fpmax x y))
+(define (*fpmin x y) (%fpmin x y))
+(define (*fp- x y) (%fp- x y))
+(define (*fp+ x y) (%fp+ x y))
+(define (*fp* x y) (%fp* x y))
+(define (*fp/ x y) (%fp/ x y))
+
 
 ;;;
 
-(define-inline (%fold1 loc func init lyst)
-  (check-flonum loc init)
-  (let loop ([acc init] [lyst lyst])
-          (if (null? lyst)
-              acc
-              (let ([cur (car lyst)])
-          (check-flonum loc cur)
-          (loop (func acc cur) (cdr lyst)) ) ) ) )
-
-(define-inline (%and-fold1 loc func init lyst)
-  (check-flonum loc init)
-  (let loop ([prv init] [lyst lyst])
-          (or (null? lyst)
-        (let ([cur (car lyst)])
-          (check-flonum loc cur)
-                (and (func prv cur)
-               (loop cur (cdr lyst)) ) ) ) ) )
+(define (real->flonum value)
+  (if (%flonum? value) value
+      (begin
+        (%check-number 'real->flonum value)
+        (%exact->inexact value) ) ) )
+
+(define (fixnum->flonum fx)
+  (%check-fixnum 'fixnum->flonum fx)
+  (%exact->inexact fx) )
+
 
 ;;;
 
-(define %fpfrac ##sys#flonum-fraction)
-
-(define %fptrunc ##sys#truncate)
-
-(define %fpfloor ##sys#floor)
-
-(define %fpceil ##sys#ceiling)
-
-(define-inline (%fprnd fp)
-  (if (##core#inline "C_flonum_equalp" 0.0 fp)
-      0.0
-      (%fptrunc (##core#inline_allocate ("C_a_i_flonum_plus" 4)
-                 fp
-                 (if (##core#inline "C_flonum_lessp" 0.0 fp) 0.5 -0.5))) ) )
-
-(define-inline (%fpquo fpn fpd)
-  (%fptrunc (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpn fpd)) )
-
-(define-inline (%fprem fpn fpd)
-  (##core#inline_allocate ("C_a_i_flonum_difference" 4)
-   fpn
-   (##core#inline_allocate ("C_a_i_flonum_times" 4)
-    (%fptrunc (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpn fpd))
-    fpd)) )
-
-(define-inline (%fpquo-and-rem fpn fpd)
-  (let ([quo (%fpquo fpn fpd)])
-    (values quo
-            (##core#inline_allocate ("C_a_i_flonum_difference" 4)
-             fpn
-             (##core#inline_allocate ("C_a_i_flonum_times" 4) quo fpd))) ) )
-
-(define-inline (%fpinteger? fp)
-  (##core#inline "C_flonum_equalp" 0.0 (%fpfrac fp)) )
-
-(define-inline (%fpnan? fp)
-  (not (##core#inline "C_flonum_equalp" fp fp)) )
-
-(define (%fp= x y)
-  (##core#inline "C_flonum_equalp" x y) )
-
-(define (%fp< x y)
-  (or (and (##core#inline "C_flonum_equalp" -0.0 x)
-           (##core#inline "C_flonum_equalp" 0.0 y))
-      (##core#inline "C_flonum_lessp" x y) ) )
-
-(define (%fp<= x y)
-  (or (and (##core#inline "C_flonum_equalp" -0.0 x)
-           (##core#inline "C_flonum_equalp" 0.0 y))
-      (##core#inline "C_flonum_less_or_equal_p" x y) ) )
-
-(define (%fp> x y)
-  (or (and (##core#inline "C_flonum_equalp" 0.0 x)
-           (##core#inline "C_flonum_equalp" -0.0 y))
-      (##core#inline "C_flonum_greaterp" x y) ) )
-
-(define (%fp>= x y)
-  (or (and (##core#inline "C_flonum_equalp" 0.0 x)
-           (##core#inline "C_flonum_equalp" -0.0 y))
-      (##core#inline "C_flonum_greater_or_equal_p" x y) ) )
-
-(define (%fpmax x y)
-  (##core#inline "C_i_flonum_max" x y) )
-
-(define (%fpmin x y)
-  (##core#inline "C_i_flonum_min" x y) )
-
-(define (%fp+ x y)
-  (##core#inline_allocate ("C_a_i_flonum_plus" 4) x y) )
-
-(define (%fp- x y)
-  (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y) )
-
-(define (%fp* x y)
-  (##core#inline_allocate ("C_a_i_flonum_times" 4) x y) )
-
-(define (%fp/ x y)
-  (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y) )
-
-(define-inline (%fpdiv0-and-mod0 fpn fpd)
-  (let-values ([(quo rem) (%fpquo-and-rem fpn fpd)])
-    (cond [(##core#inline "C_flonum_greater_or_equal_p" fpd 0.0)
-            (if (##core#inline "C_flonum_lessp"
-                 rem
-                 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd 2.0))
-                (if (##core#inline "C_flonum_greater_or_equal_p"
-                     rem
-                     (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd -2.0))
-                    (values quo rem)
-                    (values (##core#inline_allocate ("C_a_i_flonum_difference" 4) quo 1.0)
-                            (##core#inline_allocate ("C_a_i_flonum_plus" 4) rem fpd)) )
-                (values (##core#inline_allocate ("C_a_i_flonum_plus" 4) quo 1.0)
-                        (##core#inline_allocate ("C_a_i_flonum_difference" 4) rem fpd)) ) ]
-          [(##core#inline "C_flonum_lessp"
-            rem
-            (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd -2.0))
-            (if (##core#inline "C_flonum_greater_or_equal_p"
-                 rem
-                 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd 2.0))
-                (values quo rem)
-                (values (##core#inline_allocate ("C_a_i_flonum_plus" 4) quo 1.0)
-                        (##core#inline_allocate ("C_a_i_flonum_difference" 4) rem fpd)) ) ]
-          [else
-            (values (##core#inline_allocate ("C_a_i_flonum_difference" 4) quo 1.0)
-                    (##core#inline_allocate ("C_a_i_flonum_plus" 4) rem fpd)) ] ) ) )
-
-(define-inline (%fpdiv0 fpn fpd)
-  (let-values ([(quo rem) (%fpquo-and-rem fpn fpd)])
-    (cond [(##core#inline "C_flonum_greater_or_equal_p" fpd 0.0)
-            (if (##core#inline "C_flonum_lessp"
-                 rem
-                 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd 2.0))
-                (if (##core#inline "C_flonum_greater_or_equal_p"
-                     rem
-                     (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd -2.0))
-                    quo
-                    (##core#inline_allocate ("C_a_i_flonum_difference" 4) quo 1.0) )
-                (##core#inline_allocate ("C_a_i_flonum_plus" 4) quo 1.0) ) ]
-          [(##core#inline "C_flonum_lessp"
-            rem
-            (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd -2.0))
-            (if (##core#inline "C_flonum_greater_or_equal_p"
-                 rem
-                 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd 2.0))
-                quo
-                (##core#inline_allocate ("C_a_i_flonum_plus" 4) quo 1.0) ) ]
-          [else
-            (##core#inline_allocate ("C_a_i_flonum_difference" 4) quo 1.0) ] ) ) )
-
-(define-inline (%fpmod0 fpn fpd)
-  (let ([rem (%fprem fpn fpd)])
-    (cond [(##core#inline "C_flonum_greater_or_equal_p" fpd 0.0)
-            (if (##core#inline "C_flonum_lessp"
-                 rem
-                 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd 2.0))
-                (if (##core#inline "C_flonum_greater_or_equal_p"
-                     rem
-                     (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd -2.0))
-                    rem
-                    (##core#inline_allocate ("C_a_i_flonum_plus" 4) rem fpd) )
-                (##core#inline_allocate ("C_a_i_flonum_difference" 4) rem fpd) ) ]
-          [(##core#inline "C_flonum_lessp"
-            rem
-            (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd -2.0))
-            (if (##core#inline "C_flonum_greater_or_equal_p"
-                 rem
-                 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd 2.0))
-                rem
-                (##core#inline_allocate ("C_a_i_flonum_difference" 4) rem fpd) )]
-          [else
-            (##core#inline_allocate ("C_a_i_flonum_plus" 4) rem fpd) ] ) ) )
+(define (fl=? fl . fls)
+        (%fpand-fold-1 'fl=? *fp=? fl fls) )
+
+(define (fl<? fl . fls)
+        (%fpand-fold-1 'fl<? *fp<? fl fls) )
+
+(define (fl>? fl . fls)
+        (%fpand-fold-1 'fl>? *fp>? fl fls) )
+
+(define (fl<=? fl . fls)
+        (%fpand-fold-1 'fl<=? *fp<=? fl fls) )
+
+(define (fl>=? fl . fls)
+        (%fpand-fold-1 'fl>=? *fp>=? fl fls) )
+
+(define (flcompare fl1 fl2)
+  (%check-flonum 'flcompare fl1)
+  (%check-flonum 'flcompare fl2)
+        (cond [(%fp=? fl1 fl2)
+               (cond [(%fp=? -0.0 fl1)  (if (%fp=? -0.0 fl1) 0 1)]
+               [(%fp=? -0.0 fl2)  (if (%fp=? 0.0 fl1) -1 0)]
+                     [else              0])]
+              [(%fp<? fl1 fl2)
+               -1]
+              [else
+               1 ] ) )
+
+(define (flmax fl . fls)
+        (%fpfold-1 'flmax *fpmax fl fls) )
+
+(define (flmin fl . fls)
+        (%fpfold-1 'flmin *fpmin fl fls) )
+
+(define (flmax-and-min fl . fls)
+  (%check-flonum 'flmax-and-min fl)
+        (let loop ([ls fls] [mx fl] [mn fl])
+          (if (%null? ls) (values mx mn)
+              (let ([cur (%car ls)])
+                (%check-flonum 'flmax-and-min cur)
+          (loop (%cdr ls) (%fpmax mx cur) (%fpmin mn cur)) ) ) ) )
+
 
 ;;;
 
-(define (real->flonum value)
-  (if (##core#inline "C_i_flonump" value)
-      value
-      (##sys#exact->inexact value) ) )
-
-(define (fixnum->flonum fx)
-  (if (##core#inline "C_fixnump" fx)
-      (##sys#exact->inexact fx)
-      (##sys#signal-hook #:type-error 'fixnum->flonum
-                         "bad argument type - not a fixnum" fx) ) )
+(define (flinteger? fl)
+  (%check-flonum 'flinteger? fl)
+  (%fpinteger? fl) )
+
+(define (flzero? fl)
+  (%check-flonum 'flzero? fl)
+        (%fp=? 0.0 fl) )
+
+(define (flpositive? fl)
+  (%check-flonum 'flpositive? fl)
+        (%fp<? 0.0 fl) )
+
+(define (flnegative? fl)
+  (%check-flonum 'flnegative? fl)
+        (or (%fp=? -0.0 fl)
+      (%fp<? fl 0.0) ) )
+
+(define (flodd? fl)
+  (%check-flonum 'flodd? fl)
+  (not (%fp=? 0.0 (fpmod fl 2.0))) )
+
+(define (fleven? fl)
+  (%check-flonum 'fleven? fl)
+  (%fp=? 0.0 (fpmod fl 2.0)) )
+
+(define (flfinite? fl)
+  (%check-flonum 'flfinite? fl)
+  (%finite? fl) )
+
+(define (flinfinite? fl)
+  (%check-flonum 'flinfinite? fl)
+  (not (%finite? fl)) )
+
+(define (flnan? fl)
+  (%check-flonum 'flnan? fl)
+  (%fpnan? fl) )
+
 
 ;;;
 
-(define (fl=? fl . rest)
-        (%and-fold1 'fl=? %fp= fl rest) )
-
-(define (fl<? fl . rest)
-        (%and-fold1 'fl<? %fp< fl rest) )
-
-(define (fl>? fl . rest)
-        (%and-fold1 'fl>? %fp> fl rest) )
-
-(define (fl<=? fl . rest)
-        (%and-fold1 'fl<=? %fp<= fl rest) )
-
-(define (fl>=? fl . rest)
-        (%and-fold1 'fl>=? %fp>= fl rest) )
-
-(define (flcompare fl1 fl2)
-  (check-flonum 'flcompare fl1)
-  (check-flonum 'flcompare fl2)
-        (cond [(##core#inline "C_flonum_equalp" fl1 fl2)
-                (cond [(##core#inline "C_flonum_equalp" -0.0 fl1)
-                  (if (##core#inline "C_flonum_equalp" -0.0 fl1)
-                      0
-                      1) ]
-                      [(##core#inline "C_flonum_equalp" -0.0 fl2)
-                        (if (##core#inline "C_flonum_equalp" 0.0 fl1)
-                            -1
-                            0) ]
-                      [else
-                        0 ] ) ]
-              [(##core#inline "C_flonum_lessp" fl1 fl2)
-                -1 ]
-              [else
-                1 ] ) )
-
-(define (flmax fl . rest)
-        (%fold1 'flmax %fpmax fl rest) )
-
-(define (flmin fl . rest)
-        (%fold1 'flmin %fpmin fl rest) )
-
-(define (flmax-and-min fl . rest)
-  (check-flonum 'flmax-and-min fl)
-        (let loop ([mx fl]
-                   [mn fl]
-                   [lyst rest])
-          (if (null? lyst)
-              (values mx mn)
-              (let ([cur (car lyst)])
-                (check-flonum 'flmax-and-min cur)
-          (loop (##core#inline "C_i_flonum_max" mx cur)
-                (##core#inline "C_i_flonum_min" mn cur)
-                (cdr lyst)) ) ) ) )
-
-;;;
-
-(define (flinteger? fl)
-  (check-flonum 'flinteger? fl)
-  (%fpinteger? fl) )
-
-(define (flzero? fl)
-  (check-flonum 'flzero? fl)
-        (##core#inline "C_flonum_equalp" 0.0 fl) )
-
-(define (flpositive? fl)
-  (check-flonum 'flpositive? fl)
-        (##core#inline "C_flonum_lessp" 0.0 fl) )
-
-(define (flnegative? fl)
-  (check-flonum 'flnegative? fl)
-        (or (##core#inline "C_flonum_equalp" -0.0 fl)
-      (##core#inline "C_flonum_lessp" fl 0.0) ) )
-
-(define (flodd? fl)
-  (check-flonum 'flodd? fl)
-  (not (##core#inline "C_flonum_equalp" 0.0 (fpmod fl 2.0))) )
-
-(define (fleven? fl)
-  (check-flonum 'fleven? fl)
-  (##core#inline "C_flonum_equalp" 0.0 (fpmod fl 2.0)) )
-
-(define (flfinite? fl)
-  (check-flonum 'flfinite? fl)
-  (##core#inline "C_i_finitep" fl) )
-
-(define (flinfinite? fl)
-  (check-flonum 'flinfinite? fl)
-  (not (##core#inline "C_i_finitep" fl)) )
-
-(define (flnan? fl)
-  (check-flonum 'flnan? fl)
-  (%fpnan? fl) )
-
-;;;
-
-(define (fl+ fl . rest)
-        (%fold1 'fl+ %fp+ fl rest) )
-
-(define (fl* fl . rest)
-        (%fold1 'fl* %fp* fl rest) )
-
-(define (fl- fl . rest)
-  (or (and (null? rest)
-           (##core#inline_allocate ("C_a_i_flonum_negate" 4) fl) )
-      (%fold1 'fl- %fp- fl rest) ) )
-
-(define (fl/ fl . rest)
-  (or (and (null? rest)
-           (##core#inline_allocate ("C_a_i_flonum_quotient" 4) 1.0 fl) )
-        (%fold1 'fl/ %fp/ fl rest) ) )
+(define (fl+ fl . fls)
+        (%fpfold-1 'fl+ %fp+ fl fls) )
+
+(define (fl* fl . fls)
+        (%fpfold-1 'fl* %fp* fl fls) )
+
+(define (fl- fl . fls)
+  (if (%null? fls) (%fpneg fl)
+      (%fpfold-1 'fl- %fp- fl fls) ) )
+
+(define (fl/ fl . fls)
+  (if (%null? fls) (%fp/ 1.0 fl)
+        (%fpfold-1 'fl/ %fp/ fl fls) ) )
 
 (define (flabs fl)
-  (check-flonum 'flabs fl)
-  (##core#inline_allocate ("C_a_i_abs" 4) fl) )
+  (%check-flonum 'flabs fl)
+  (%fpabs fl) )
 
 (define (flfraction fl)
-  (check-flonum 'flfraction fl)
-  (%fpfrac fl) )
+  (%check-flonum 'flfraction fl)
+  (%fpfraction fl) )
 
 (define (fltruncate fl)
-  (check-flonum 'fltruncate fl)
-  (%fptrunc fl) )
+  (%check-flonum 'fltruncate fl)
+  (%fptruncate fl) )
 
 (define (flfloor fl)
-  (check-flonum 'flfloor fl)
+  (%check-flonum 'flfloor fl)
   (%fpfloor fl) )
 
 (define (flceiling fl)
-  (check-flonum 'flceiling fl)
+  (%check-flonum 'flceiling fl)
   (%fpceil fl) )
 
 (define (flround fl)
-  (check-flonum 'flround fl)
-  (%fprnd fl) )
+  (%check-flonum 'flround fl)
+  (%fpround fl) )
 
 (define (fldiv fln fld)
-  (check-flonum 'fldiv fln)
-  (check-flonum 'fldiv fld)
-  (%fpquo fln fld) )
+  (%check-flonum 'fldiv fln)
+  (%check-flonum 'fldiv fld)
+  (%fpquotient fln fld) )
 
 (define (flmod fln fld)
-  (check-flonum 'flmod fln)
-  (check-flonum 'flmod fld)
-  (%fprem fln fld) )
+  (%check-flonum 'flmod fln)
+  (%check-flonum 'flmod fld)
+  (%fpremainder fln fld) )
 
 (define (fldiv-and-mod fln fld)
-  (check-flonum 'fldiv-and-mod fln)
-  (check-flonum 'fldiv-and-mod fld)
-  (%fpquo-and-rem fln fld) )
+  (%check-flonum 'fldiv-and-mod fln)
+  (%check-flonum 'fldiv-and-mod fld)
+  (%fpquotient-and-remainder  fln fld) )
 
 (define (fldiv0 fln fld)
-  (check-flonum 'fldiv0 fln)
-  (check-flonum 'fldiv0 fld)
+  (%check-flonum 'fldiv0 fln)
+  (%check-flonum 'fldiv0 fld)
   (%fpdiv0 fln fld) )
 
 (define (flmod0 fln fld)
-  (check-flonum 'flmod0 fln)
-  (check-flonum 'flmod0 fld)
+  (%check-flonum 'flmod0 fln)
+  (%check-flonum 'flmod0 fld)
   (%fpmod0 fln fld) )
 
 (define (fldiv0-and-mod0 fln fld)
-  (check-flonum 'fldiv0-and-mod0 fln)
-  (check-flonum 'fldiv0-and-mod0 fld)
+  (%check-flonum 'fldiv0-and-mod0 fln)
+  (%check-flonum 'fldiv0-and-mod0 fld)
   (%fpdiv0-and-mod0 fln fld) )
 
 (define (flexp fl)
-  (check-flonum 'flexp fl)
-  (##core#inline_allocate ("C_a_i_exp" 4) fl) )
-
-(define (fllog fl . rest)
-  (check-flonum 'fllog fl)
-  (if (null? rest)
-      (##core#inline_allocate ("C_a_i_log" 4) fl)
-      (let ([base (car rest)])
-        (check-non-negative-integer 'fllog base)
-        ((make-log/base base) fl) ) ) )
+  (%check-flonum 'flexp fl)
+  (%fpexp fl) )
+
+(define (fllog fl #!optional base)
+  (define log/base  ;memoize log/base functions
+    (let ([bases '()])
+      (lambda (base)
+        (let ([cell (assv base bases)])
+               (if cell (cdr cell)
+                   (let ([func (make-log/base base)])
+                     (set! bases (alist-cons base func bases))
+                     func ) ) ) ) ) )
+  (%check-flonum 'fllog fl)
+  (if (not base) (%fplog fl)
+      (begin
+        (%check-non-negative-integer 'fllog base)
+        ((log/base base) fl) ) ) )
 
 (define (flsin fl)
-  (check-flonum 'flsin fl)
-  (##core#inline_allocate ("C_a_i_sin" 4) fl) )
+  (%check-flonum 'flsin fl)
+  (%fpsin fl) )
 
 (define (flcos fl)
-  (check-flonum 'flcos fl)
-  (##core#inline_allocate ("C_a_i_cos" 4) fl) )
+  (%check-flonum 'flcos fl)
+  (%fpcos fl) )
 
 (define (fltan fl)
-  (check-flonum 'fltan fl)
-  (##core#inline_allocate ("C_a_i_tan" 4) fl) )
+  (%check-flonum 'fltan fl)
+  (%fptan fl) )
 
 (define (flasin fl)
-  (check-flonum 'flasin fl)
-  (##core#inline_allocate ("C_a_i_asin" 4) fl) )
+  (%check-flonum 'flasin fl)
+  (%fpasin fl) )
 
 (define (flacos fl)
-  (check-flonum 'flacos fl)
-  (##core#inline_allocate ("C_a_i_acos" 4) fl) )
+  (%check-flonum 'flacos fl)
+  (%fpacos fl) )
 
 (define (flatan fl . rest)
-  (check-flonum 'flatan fl)
-  (if (null? rest)
-      (##core#inline_allocate ("C_a_i_atan" 4) fl)
-      (let ([fld (car rest)])
-        (check-flonum 'flatan fld)
-        (##core#inline_allocate ("C_a_i_atan2" 4) fl fld) ) ) )
+  (%check-flonum 'flatan fl)
+  (if (%null? rest) (%fpatan fl)
+      (let ([fld (%car rest)])
+        (%check-flonum 'flatan fld)
+        (%fpatan2 fl fld) ) ) )
 
 (define (flsqrt fl)
-  (check-flonum 'flsqrt fl)
-  (##core#inline_allocate ("C_a_i_sqrt" 4) fl) )
+  (%check-flonum 'flsqrt fl)
+  (%fpsqrt fl) )
 
 (define (flexpt fl exp)
-  (check-flonum 'flexpt fl)
-  (check-flonum 'flexpt exp)
-  (or (and (= 2.0 fl)
-           (ldexp 1.0 exp) )
-      ((##core#primitive "C_expt") fl exp) ) )
+  (%check-flonum 'flexpt fl)
+  (%check-flonum 'flexpt exp)
+  (if (= 2.0 fl) (ldexp 1.0 exp)
+      (%expt fl exp) ) )
 
 (define (flnumerator fl)
-  (check-flonum 'flnumerator fl)
+  (%check-flonum 'flnumerator fl)
   fl )
 
 (define (fldenominator fl)
-  (check-flonum 'fldenominator fl)
-  (if (%fpnan? fl)
-      fl
+  (%check-flonum 'fldenominator fl)
+  (if (%fpnan? fl) fl
       1.0 ) )
+
+) ;module err5rs-arithmetic-bitwise

release/4/err5rs-arithmetic/trunk/err5rs-arithmetic.meta

@@ -7 +7 @@
  (doc-from-wiki)
  (synopsis "ERR5RS Arithmetic")
- (needs setup-helper srfi-1 int-limits float-limits mathh)
+ (needs setup-helper srfi-1 int-limits mathh)
  (files
   "tests"