On 4/22/24 14:55, Diego wrote:
Hi all,
Sorry to be very late/unresponsive to this discussion. As I understand it from
reading the email thread, there are several optimizations and changes to
SRFI-143 that would make it more performant or inline with the intent of the
original SRFI.
Heyo! Better late than never!
I think there's two things being discussed:
1. SRFI-143 as it exists is rather slow compared to (chicken fixnum)
2. There seems to be an errata / post finalization note in SRFI-143 (the
text) that needs to be brought up regarding 2-arity vs. variadic
procedures in the spec. John mentioned he would pursue this, although
looking at the archives I haven't seen it yet.
I have unfortunately not had much time for scheme in the past couple years, and
though I'd love to get back to it eventually, I'd hate to simply sit on the
sources for this (or any other eggs I maintain) without allowing for it to
evolve.
I understand this feeling. Look at generalized-arrays (thread topic), I
sat on it for years!
I'd be happy to give Jeremy and anyone else interested in this effort
read/write access to the sources at https://git.sr.ht/~dieggsy/srfi-143, or
transfer the egg to a different maintainer/repo entirely if that approach is
preferred.
Diego
I don't have a SourceHut account, but from what I know of SourceHut I
believe either approach can be made to work (I may need to set up
git-send-email). For what it's worth, I've done the hard work of
converting everything to an R7RS egg as well as fixing the tests / arity
of every procedure to match that of (chicken fixnum) and what I presume
to be John's original intent with the SRFI.
See the attached file for the full patch. One thing I did not do was
update the svnwiki page in the repo. I can definitely do this but I only
spent about an hour or so on this and some plugin in my editor is
messing with the formatting. (classic excuse right?)
Anyways, happy to continue to get this out to folks. I don't know to
what extent users are currently using SRFI-143 so I'd be wary to push
this out, but I went to the liberty of bumping the version to 1.0.0
since this would definitely be a major breakage of the API.
Cheers,
--
Jeremy Steward
From d9d3a770afc54faf12558f59e37a33db7a016587 Mon Sep 17 00:00:00 2001
From: Jeremy Steward <jer...@thatgeoguy.ca>
Date: Mon, 22 Apr 2024 20:56:03 -0600
Subject: [PATCH] Convert egg to R7RS egg & variadic procedures to 2-arity
---
carries.scm | 63 -----------
srfi-143-impl.scm | 98 -----------------
srfi-143.egg | 12 ++-
srfi-143.release-info | 1 +
srfi-143.scm | 246 +++++++++++++++++++++++++++---------------
srfi-143.sld | 83 ++++++++++++++
tests/r6rs-test.scm | 176 ------------------------------
tests/run.scm | 34 +++---
8 files changed, 270 insertions(+), 443 deletions(-)
delete mode 100644 carries.scm
delete mode 100644 srfi-143-impl.scm
create mode 100644 srfi-143.sld
delete mode 100644 tests/r6rs-test.scm
diff --git a/carries.scm b/carries.scm
deleted file mode 100644
index 8c2253c..0000000
--- a/carries.scm
+++ /dev/null
@@ -1,63 +0,0 @@
-;;;; Generic implementation of carry functions from the R6RS standard.
-
-;;; These implementations of fx+/carry, fx-/carry, and fx*/carry
-;;; are very inefficient, and should be replaced by proper
-;;; assembly language operations if at all possible.
-;;; Furthermore, there are no tests for them,
-;;; because of their dependency on fx-width.
-
-(define exp-width (expt 2 fx-width))
-
-(define (fx+/carry i j k)
- (let*-values (((s) (+ i j k))
- ((q r) (balanced/ s exp-width)))
- (values r q)))
-
-(define (fx-/carry i j k)
- (let*-values (((d) (- i j k))
- ((q r) (balanced/ d exp-width)))
- (values r q)))
-
-(define (fx*/carry i j k)
- (let*-values (((s) (+ (* i j) k))
- ((q r) (balanced/ s exp-width)))
- (values r q)))
-
-;;; Helper functions from SRFI 151
-
-(define (floor-/+ n d)
- (let ((n (- 0 n)))
- (let ((q (quotient n d)) (r (remainder n d)))
- (if (zero? r)
- (values (- 0 q) r)
- (values (- (- 0 q) 1) (- d r))))))
-
-(define (ceiling-/- n d)
- (let ((n (- 0 n)) (d (- 0 d)))
- (let ((q (quotient n d)) (r (remainder n d)))
- (if (zero? r)
- (values q r)
- (values (+ q 1) (- d r))))))
-
-(define (euclidean/ n d)
- (if (and (exact-integer? n) (exact-integer? d))
- (cond ((and (negative? n) (negative? d)) (ceiling-/- n d))
- ((negative? n) (floor-/+ n d))
- ((negative? d)
- (let ((d (- 0 d)))
- (values (- 0 (quotient n d)) (remainder n d))))
- (else (values (quotient n d) (remainder n d))))
- (let ((q (if (negative? d) (ceiling (/ n d)) (floor (/ n d)))))
- (values q (- n (* d q))))))
-
-(define (balanced/ x y)
- (call-with-values
- (lambda () (euclidean/ x y))
- (lambda (q r)
- (cond ((< r (abs (/ y 2)))
- (values q r))
- ((> y 0)
- (values (+ q 1) (- x (* (+ q 1) y))))
- (else
- (values (- q 1) (- x (* (- q 1) y))))))))
-
diff --git a/srfi-143-impl.scm b/srfi-143-impl.scm
deleted file mode 100644
index 4949229..0000000
--- a/srfi-143-impl.scm
+++ /dev/null
@@ -1,98 +0,0 @@
-;;;; Procedures not provided by Chicken or by rubber-chicken.
-
-;;; Implementations of arithmetic functions
-
-(define (fx=? i j . ks)
- (if (null? ks)
- (chicken:fx= i j)
- (and (chicken:fx= i j) (apply fx=? j ks))))
-
-(define (fx<? i j . ks)
- (if (null? ks)
- (chicken:fx< i j)
- (and (chicken:fx< i j) (apply fx<? j ks))))
-
-(define (fx>? i j . ks)
- (if (null? ks)
- (chicken:fx> i j)
- (and (chicken:fx> i j) (apply fx>? j ks))))
-
-(define (fx<=? i j . ks)
- (if (null? ks)
- (chicken:fx<= i j)
- (and (chicken:fx<= i j) (apply fx<=? j ks))))
-
-(define (fx>=? i j . ks)
- (if (null? ks)
- (chicken:fx>= i j)
- (and (chicken:fx>= i j) (apply fx>=? j ks))))
-
-(define (fxzero? i) (chicken:fx= i 0))
-(define (fxpositive? i) (chicken:fx> i 0))
-(define (fxnegative? i) (chicken:fx< i 0))
-
-(define (fxmax i j . ks)
- (if (null? ks)
- (chicken:fxmax i j)
- (chicken:fxmax (chicken:fxmax i j) (apply fxmax j ks))))
-
-(define (fxmin i j . ks)
- (if (null? ks)
- (chicken:fxmin i j)
- (chicken:fxmin (chicken:fxmin i j) (apply fxmin j ks))))
-
-(define (fxabs i)
- (if (fxnegative? i) (fxneg i) i))
-
-(define (fxsquare i) (chicken:fx* i i))
-
-(define (fxarithmetic-shift i count)
- (if (negative? count)
- (fxarithmetic-shift-right i (fxneg count))
- (fxarithmetic-shift-left i count)))
-
-;;; Bitwise functions cloned from SRFI 151, fixnum version
-
-;; Helper function
-(define (mask start end) (fxnot (fxarithmetic-shift-left -1 (chicken:fx- end start))))
-
-(define (fxif mask n0 n1)
- (fxior (fxand mask n0)
- (fxand (fxnot mask) n1)))
-
-(define (fxbit-set? index n)
- (bit->boolean n index))
-
-(define (fxcopy-bit index to bool)
- (if bool
- (fxior to (fxarithmetic-shift-left 1 index))
- (fxand to (fxnot (fxarithmetic-shift-left 1 index)))))
-
-(define (fxfirst-set-bit i) (chicken:fx- (fxbit-count (fxxor i (chicken:fx- i 1))) 1))
-
-(define (fxbit-field n start end)
- (fxand (mask start end) (fxarithmetic-shift n (fxneg start))))
-
-(define (fxbit-field-rotate n count start end)
- (define width (chicken:fx- end start))
- (set! count (modulo count width))
- (let ((mask (fxnot (fxarithmetic-shift -1 width))))
- (define zn (fxand mask (fxarithmetic-shift n (fxneg start))))
- (fxior (fxarithmetic-shift
- (fxior (fxand mask (fxarithmetic-shift zn count))
- (fxarithmetic-shift zn (chicken:fx- count width)))
- start)
- (fxand (fxnot (fxarithmetic-shift mask start)) n))))
-
-(define (fxreverse k n)
- (do ((m (if (negative? n) (fxnot n) n) (fxarithmetic-shift-right m 1))
- (k (chicken:fx+ -1 k) (chicken:fx+ -1 k))
- (rvs 0 (fxior (fxarithmetic-shift-left rvs 1) (fxand 1 m))))
- ((fxnegative? k) (if (fxnegative? n) (fxnot rvs) rvs))))
-
-(define (fxbit-field-reverse n start end)
- (define width (chicken:fx- end start))
- (let ((mask (fxnot (fxarithmetic-shift-left -1 width))))
- (define zn (fxand mask (fxarithmetic-shift-right n start)))
- (fxior (fxarithmetic-shift-left (fxreverse width zn) start)
- (fxand (fxnot (fxarithmetic-shift-left mask start)) n))))
diff --git a/srfi-143.egg b/srfi-143.egg
index c3b35e5..2cc2718 100644
--- a/srfi-143.egg
+++ b/srfi-143.egg
@@ -3,9 +3,15 @@
((author "John Cowan")
(maintainer "Sergey Goldgaber")
(synopsis "SRFI 143: Fixnums")
+ (version "1.0.0")
(category math)
+ (dependencies r7rs)
(test-dependencies test)
(license "MIT")
- (components (extension srfi-143
- (source-dependencies "srfi-143-impl.scm"
- "carries.scm"))))
+ (components
+ (extension
+ srfi-143
+ (source "srfi-143.sld")
+ (source-dependencies "srfi-143.scm")
+ (types-file)
+ (csc-options "-X" "r7rs" "-R" "r7rs" "-O3" "-d2"))))
diff --git a/srfi-143.release-info b/srfi-143.release-info
index 75eb148..dacb8fc 100644
--- a/srfi-143.release-info
+++ b/srfi-143.release-info
@@ -1,6 +1,7 @@
(repo git "https://git.sr.ht/~dieggsy/srfi-143";)
(uri targz "https://git.sr.ht/~dieggsy/{egg-name}/archive/{egg-release}.tar.gz";)
+(release "1.0.0")
(release "0.4.1")
(release "0.4")
(release "0.3")
diff --git a/srfi-143.scm b/srfi-143.scm
index c061ab9..5bf3c64 100644
--- a/srfi-143.scm
+++ b/srfi-143.scm
@@ -1,86 +1,160 @@
-;;;; Chicken module for SRFI 143
-
-(module srfi-143 ()
-
- (import scheme)
- (import (chicken module))
- (import (rename (chicken base) (exact-integer-sqrt fxsqrt)))
-
- (export fx-width fx-greatest fx-least)
- (export fixnum? fx=? fx<? fx>? fx<=? fx>=?
- fxzero? fxpositive? fxnegative?
- fxodd? fxeven? fxmax fxmin)
- (export fx+ fx- fxneg fx* fx/ fxquotient fxremainder
- fxabs fxsquare fxsqrt)
- (export fx+/carry fx-/carry fx*/carry)
- (export fxnot fxand fxior fxxor fxarithmetic-shift
- fxarithmetic-shift-left fxarithmetic-shift-right
- fxbit-count fxlength fxif fxbit-set? fxcopy-bit
- fxfirst-set-bit fxbit-field
- fxbit-field-rotate fxbit-field-reverse)
-
- (import (only (chicken bitwise) bit->boolean))
- (import (rename (only (chicken fixnum)
- fxmax fxmin fx= fx< fx> fx<= fx>= fx/ fxlen fxrem
- fxshl fxshr fixnum-bits
- most-positive-fixnum most-negative-fixnum
- fx+ fx- fx*)
- (fxmax chicken:fxmax)
- (fxmin chicken:fxmin)
- (fx= chicken:fx=)
- (fx< chicken:fx<)
- (fx> chicken:fx>)
- (fx<= chicken:fx<=)
- (fx>= chicken:fx>=)
- (fx/ fxquotient)
- (fxlen fxlength)
- (fxrem fxremainder)
- (fxshl fxarithmetic-shift-left)
- (fxshr fxarithmetic-shift-right)
- (fixnum-bits fx-width)
- (most-positive-fixnum fx-greatest)
- (most-negative-fixnum fx-least)
- (fx+ chicken:fx+)
- (fx- chicken:fx-)
- (fx* chicken:fx*)))
- (import (only (chicken base) fixnum?))
- (import (only (chicken fixnum) fxneg fxand fxior fxxor
- fxnot fxodd? fxeven?))
- (import (only (chicken platform) register-feature!))
-
- (register-feature! 'srfi-143)
-
- ;; Core functions not available in Chicken
- (define fxbit-count
- (letrec ((logcnt (lambda (n tot)
- (if (fxzero? n)
- tot
- (logcnt (fxquotient n 16)
- (fx+ (vector-ref
- '#(0 1 1 2 1 2 2 3 1 2 2 3 2 3 3 4)
- (fxremainder n 16))
- tot))))))
- (lambda (n)
- (cond ((fxnegative? n) (logcnt (fxnot n) 0))
- ((fxpositive? n) (logcnt n 0))
- (else 0)))))
-
- (define (fx+ . args)
- (foldr chicken:fx+ 0 args))
-
- (define (fx- x . args)
- (if (null? args)
- (fxneg x)
- (foldl chicken:fx- x args)))
-
- (define (fx* . args)
- (foldr chicken:fx* 1 args))
-
- (define (fx/ x . args)
- (if (null? args)
- (fxquotient 1 x)
- (foldl fxquotient x args)))
-
-
- (include "carries.scm")
- (include "srfi-143-impl.scm"))
+;;; SRFI-143 — Fixnums
+;;;
+;;; Author: John Cowan
+;;;
+;;; Copyright (c) 2016 John Cowan. All Rights Reserved.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a
+;;; copy of this software and associated documentation files (the "Software"),
+;;; to deal in the Software without restriction, including without limitation
+;;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
+;;; and/or sell copies of the Software, and to permit persons to whom the
+;;; Software is furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+
+(define fxquotient fx/)
+(define (fxzero? i) (fx=? i 0))
+(define (fxpositive? i) (fx>? i 0))
+(define (fxnegative? i) (fx<? i 0))
+
+(define (fxabs i)
+ (if (fxnegative? i) (fxneg i) i))
+
+(define (fxsquare i) (fx* i i))
+
+(define (fxarithmetic-shift i count)
+ (if (negative? count)
+ (fxarithmetic-shift-right i (fxneg count))
+ (fxarithmetic-shift-left i count)))
+
+;;; Generic implementation of carry functions from the R6RS standard.
+;;;
+;;; These implementations of fx+/carry, fx-/carry, and fx*/carry are very
+;;; inefficient, and should be replaced by proper assembly language operations
+;;; if at all possible. Furthermore, there are no tests for them, because of
+;;; their dependency on fx-width.
+
+(define exp-width (expt 2 fx-width))
+
+(define (fx+/carry i j k)
+ (let*-values (((s) (+ i j k))
+ ((q r) (balanced/ s exp-width)))
+ (values r q)))
+
+(define (fx-/carry i j k)
+ (let*-values (((d) (- i j k))
+ ((q r) (balanced/ d exp-width)))
+ (values r q)))
+
+(define (fx*/carry i j k)
+ (let*-values (((s) (+ (* i j) k))
+ ((q r) (balanced/ s exp-width)))
+ (values r q)))
+
+;;; Helper functions from SRFI 151
+
+(define (floor-/+ n d)
+ (let ((n (- 0 n)))
+ (let ((q (quotient n d)) (r (remainder n d)))
+ (if (zero? r)
+ (values (- 0 q) r)
+ (values (- (- 0 q) 1) (- d r))))))
+
+(define (ceiling-/- n d)
+ (let ((n (- 0 n)) (d (- 0 d)))
+ (let ((q (quotient n d)) (r (remainder n d)))
+ (if (zero? r)
+ (values q r)
+ (values (+ q 1) (- d r))))))
+
+(define (euclidean/ n d)
+ (if (and (exact-integer? n) (exact-integer? d))
+ (cond ((and (negative? n) (negative? d)) (ceiling-/- n d))
+ ((negative? n) (floor-/+ n d))
+ ((negative? d)
+ (let ((d (- 0 d)))
+ (values (- 0 (quotient n d)) (remainder n d))))
+ (else (values (quotient n d) (remainder n d))))
+ (let ((q (if (negative? d) (ceiling (/ n d)) (floor (/ n d)))))
+ (values q (- n (* d q))))))
+
+(define (balanced/ x y)
+ (call-with-values
+ (lambda () (euclidean/ x y))
+ (lambda (q r)
+ (cond ((< r (abs (/ y 2)))
+ (values q r))
+ ((> y 0)
+ (values (+ q 1) (- x (* (+ q 1) y))))
+ (else
+ (values (- q 1) (- x (* (- q 1) y))))))))
+
+;;; Bitwise functions cloned from SRFI 151, fixnum version
+(define fxbit-count
+ (letrec ((logcnt (lambda (n tot)
+ (if (fxzero? n)
+ tot
+ (logcnt (fxquotient n 16)
+ (fx+ (vector-ref
+ '#(0 1 1 2 1 2 2 3 1 2 2 3 2 3 3 4)
+ (fxremainder n 16))
+ tot))))))
+ (lambda (n)
+ (cond ((fxnegative? n) (logcnt (fxnot n) 0))
+ ((fxpositive? n) (logcnt n 0))
+ (else 0)))))
+
+;; Helper function
+(define (mask start end)
+ (fxnot (fxarithmetic-shift-left -1 (fx- end start))))
+
+(define (fxif mask n0 n1)
+ (fxior (fxand mask n0)
+ (fxand (fxnot mask) n1)))
+
+(define (fxbit-set? index n)
+ (bit->boolean n index))
+
+(define (fxcopy-bit index to bool)
+ (if bool
+ (fxior to (fxarithmetic-shift-left 1 index))
+ (fxand to (fxnot (fxarithmetic-shift-left 1 index)))))
+
+(define (fxfirst-set-bit i) (fx- (fxbit-count (fxxor i (fx- i 1))) 1))
+
+(define (fxbit-field n start end)
+ (fxand (mask start end) (fxarithmetic-shift n (fxneg start))))
+
+(define (fxbit-field-rotate n count start end)
+ (define width (fx- end start))
+ (set! count (modulo count width))
+ (let ((mask (fxnot (fxarithmetic-shift -1 width))))
+ (define zn (fxand mask (fxarithmetic-shift n (fxneg start))))
+ (fxior (fxarithmetic-shift
+ (fxior (fxand mask (fxarithmetic-shift zn count))
+ (fxarithmetic-shift zn (fx- count width)))
+ start)
+ (fxand (fxnot (fxarithmetic-shift mask start)) n))))
+
+(define (fxreverse k n)
+ (do ((m (if (negative? n) (fxnot n) n) (fxarithmetic-shift-right m 1))
+ (k (fx+ -1 k) (fx+ -1 k))
+ (rvs 0 (fxior (fxarithmetic-shift-left rvs 1) (fxand 1 m))))
+ ((fxnegative? k) (if (fxnegative? n) (fxnot rvs) rvs))))
+
+(define (fxbit-field-reverse n start end)
+ (define width (fx- end start))
+ (let ((mask (fxnot (fxarithmetic-shift-left -1 width))))
+ (define zn (fxand mask (fxarithmetic-shift-right n start)))
+ (fxior (fxarithmetic-shift-left (fxreverse width zn) start)
+ (fxand (fxnot (fxarithmetic-shift-left mask start)) n))))
diff --git a/srfi-143.sld b/srfi-143.sld
new file mode 100644
index 0000000..c637d78
--- /dev/null
+++ b/srfi-143.sld
@@ -0,0 +1,83 @@
+;;; SRFI-143 — Fixnums
+;;;
+;;; Author: John Cowan
+;;;
+;;; Copyright (c) 2016 John Cowan. All Rights Reserved.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a
+;;; copy of this software and associated documentation files (the "Software"),
+;;; to deal in the Software without restriction, including without limitation
+;;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
+;;; and/or sell copies of the Software, and to permit persons to whom the
+;;; Software is furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+
+(define-library (srfi 143)
+ (import (scheme base))
+ (cond-expand
+ (chicken-5
+ (import (rename
+ (only (chicken fixnum)
+ fxmax fxmin
+ fx= fx< fx> fx<= fx>=
+ fx/ fx+ fx- fx*
+ fxlen fxrem fxshl fxshr
+ fixnum-bits
+ most-positive-fixnum
+ most-negative-fixnum
+ fxneg fxand fxior fxxor
+ fxnot fxodd? fxeven?)
+ (fx< fx<?)
+ (fx> fx>?)
+ (fx<= fx<=?)
+ (fx>= fx>=?)
+ (fx= fx=?)
+ (fxlen fxlength)
+ (fxrem fxremainder)
+ (fxshl fxarithmetic-shift-left)
+ (fxshr fxarithmetic-shift-right)
+ (fixnum-bits fx-width)
+ (most-positive-fixnum fx-greatest)
+ (most-negative-fixnum fx-least))
+ (only (chicken bitwise) bit->boolean)
+ (rename (only (chicken base)
+ fixnum?
+ exact-integer-sqrt)
+ (exact-integer-sqrt fxsqrt))
+ (only (chicken platform) register-feature!)))
+ (else
+ (error "This implementation of SRFI-143 is specific to CHICKEN Scheme.")))
+
+ (export fx-width fx-greatest fx-least)
+
+ (export fixnum? fx=? fx<? fx>? fx<=? fx>=?
+ fxzero? fxpositive? fxnegative?
+ fxodd? fxeven? fxmax fxmin)
+
+ (export fx+ fx- fxneg fx* fx/ fxquotient fxremainder
+ fxabs fxsquare fxsqrt)
+
+ (export fx+/carry fx-/carry fx*/carry)
+
+ (export fxnot fxand fxior fxxor fxarithmetic-shift
+ fxarithmetic-shift-left fxarithmetic-shift-right
+ fxbit-count fxlength fxif fxbit-set? fxcopy-bit
+ fxfirst-set-bit fxbit-field
+ fxbit-field-rotate fxbit-field-reverse)
+
+ (include "srfi-143.scm")
+ (begin
+ (register-feature! 'srfi-143))
+
+ ;; End of module
+ )
diff --git a/tests/r6rs-test.scm b/tests/r6rs-test.scm
deleted file mode 100644
index deed595..0000000
--- a/tests/r6rs-test.scm
+++ /dev/null
@@ -1,176 +0,0 @@
-(import (rnrs base) (rnrs io simple) (srfi-143))
-
- (define-syntax test
- (syntax-rules ()
- ((test name expected expr)
- (let ((res expr))
- (cond
- ((not (equal? expr expected))
- (display "FAIL: ")
- (display name)
- (display ": expected ")
- (write expected)
- (display " but got ")
- (write res)
- (newline)))))
- ((test expected expr)
- (test 'expr expected expr))))
-
- (test #t (fixnum? 32767))
- (test #f (fixnum? 1.1))
-
- (test #t (fx=? 1 1 1))
- (test #f (fx=? 1 2 2))
- (test #f (fx=? 1 1 2))
- (test #f (fx=? 1 2 3))
-
- (test #t (fx<? 1 2 3))
- (test #f (fx<? 1 1 2))
- (test #t (fx>? 3 2 1))
- (test #f (fx>? 2 1 1))
- (test #t (fx<=? 1 1 2))
- (test #f (fx<=? 1 2 1))
- (test #t (fx>=? 2 1 1))
- (test #f (fx>=? 1 2 1))
- (test '(#t #f) (list (fx<=? 1 1 2) (fx<=? 2 1 3)))
-
- (test #t (fxzero? 0))
- (test #f (fxzero? 1))
-
- (test #f (fxpositive? 0))
- (test #t (fxpositive? 1))
- (test #f (fxpositive? -1))
-
- (test #f (fxnegative? 0))
- (test #f (fxnegative? 1))
- (test #t (fxnegative? -1))
-
- (test #f (fxodd? 0))
- (test #t (fxodd? 1))
- (test #t (fxodd? -1))
- (test #f (fxodd? 102))
-
- (test #t (fxeven? 0))
- (test #f (fxeven? 1))
- (test #t (fxeven? -2))
- (test #t (fxeven? 102))
-
- (test 4 (fxmax 3 4))
- (test 5 (fxmax 3 5 4))
- (test 3 (fxmin 3 4))
- (test 3 (fxmin 3 5 4))
-
- (test 7 (fx+ 3 4))
- (test 12 (fx* 4 3))
-
- (test -1 (fx- 3 4))
- (test -3 (fxneg 3))
-
- (test 7 (fxabs -7))
- (test 7 (fxabs 7))
-
- (test 1764 (fxsquare 42))
- (test 4 (fxsquare 2))
-
- (test 2 (fxquotient 5 2))
- (test -2 (fxquotient -5 2))
- (test -2 (fxquotient 5 -2))
- (test 2 (fxquotient -5 -2))
-
- (test 1 (fxremainder 13 4))
- (test -1 (fxremainder -13 4))
- (test 1 (fxremainder 13 -4))
- (test -1 (fxremainder -13 -4))
-
- (let*-values (((root rem) (fxsqrt 32)))
- (test 35 (* root rem)))
-
- (test "test-1" -1 (fxnot 0))
- (test "test-2" 0 (fxand #b0 #b1))
- (test "test-115" 6 (fxand 14 6))
- (test "test-117" 14 (fxior 10 12))
- (test "test-119" 6 (fxxor 10 12))
- (test "test-122" 0 (fxnot -1))
- (test "test-125" 9 (fxif 3 1 8))
- (test "test-126" 0 (fxif 3 8 1))
- (test "test-135" 2 (fxbit-count 12))
- (test "test-137" 0 (fxlength 0))
- (test "test-138" 8 (fxlength 128))
- (test "test-139" 8 (fxlength 255))
- (test "test-140" 9 (fxlength 256))
- (test "test-141" -1 (fxfirst-set-bit 0))
- (test "test-142" 0 (fxfirst-set-bit 1))
- (test "test-143" 0 (fxfirst-set-bit 3))
- (test "test-144" 2 (fxfirst-set-bit 4))
- (test "test-145" 1 (fxfirst-set-bit 6))
- (test "test-146" 0 (fxfirst-set-bit -1))
- (test "test-147" 1 (fxfirst-set-bit -2))
- (test "test-148" 0 (fxfirst-set-bit -3))
- (test "test-149" 2 (fxfirst-set-bit -4))
- (test "test-160" #t (fxbit-set? 0 1))
- (test "test-161" #f (fxbit-set? 1 1))
- (test "test-162" #f (fxbit-set? 1 8))
- (test "test-163" #t (fxbit-set? 10000 -1))
- (test "test-167" #t (fxbit-set? 1000 -1))
- (test "test-168" 0 (fxcopy-bit 0 0 #f))
- (test "test-174" -1 (fxcopy-bit 0 -1 #t))
- (test "test-180" 1 (fxcopy-bit 0 0 #t))
- (test "test-181" #x106 (fxcopy-bit 8 6 #t))
- (test "test-182" 6 (fxcopy-bit 8 6 #f))
- (test "test-183" -2 (fxcopy-bit 0 -1 #f))
- (test "test-189" 0 (fxbit-field 6 0 1))
- (test "test-190" 3 (fxbit-field 6 1 3))
- (test "test-196" 2 (fxarithmetic-shift 1 1))
- (test "test-197" 0 (fxarithmetic-shift 1 -1))
- (test "test-200" #b110 (fxbit-field-rotate #b110 1 1 2))
- (test "test-201" #b1010 (fxbit-field-rotate #b110 1 2 4))
- (test "test-202" #b1011 (fxbit-field-rotate #b0111 -1 1 4))
- (test "test-208" #b110 (fxbit-field-rotate #b110 0 0 10))
- (test "test-211" 6 (fxbit-field-reverse 6 1 3))
- (test "test-212" 12 (fxbit-field-reverse 6 1 4))
- (test "test-248" -11 (fxnot 10))
- (test "test-249" 36 (fxnot -37))
- (test "test-250" 11 (fxior 3 10))
- (test "test-251" 10 (fxand 11 26))
- (test "test-252" 9 (fxxor 3 10))
- (test "test-254" 4 (fxand 37 12))
- (test "test-255" 32 (fxarithmetic-shift 8 2))
- (test "test-256" 4 (fxarithmetic-shift 4 0))
- (test "test-257" 4 (fxarithmetic-shift 8 -1))
- (test "test-263" 0 (fxlength 0))
- (test "test-264" 1 (fxlength 1))
- (test "test-265" 0 (fxlength -1))
- (test "test-266" 3 (fxlength 7))
- (test "test-267" 3 (fxlength -7))
- (test "test-268" 4 (fxlength 8))
- (test "test-269" 3 (fxlength -8))
- (test "test-272" #t (fxbit-set? 3 10))
- (test "test-273" #t (fxbit-set? 2 6))
- (test "test-274" #f (fxbit-set? 0 6))
- (test "test-276" #b100 (fxcopy-bit 2 0 #t))
- (test "test-277" #b1011 (fxcopy-bit 2 #b1111 #f))
- (test "test-280" 1 (fxfirst-set-bit 2))
- (test "test-282" 3 (fxfirst-set-bit 40))
- (test "test-283" 2 (fxfirst-set-bit -28))
- (test "test-288" 1 (fxand #b1 #b1))
- (test "test-289" 0 (fxand #b1 #b10))
- (test "test-290" #b10 (fxand #b11 #b10))
- (test "test-291" #b101 (fxand #b101 #b111))
- (test "test-292" #b111 (fxand -1 #b111))
- (test "test-293" #b110 (fxand -2 #b111))
- (test "test-331" 1 (fxarithmetic-shift 1 0))
- (test "test-333" 4 (fxarithmetic-shift 1 2))
- (test "test-334" 8 (fxarithmetic-shift 1 3))
- (test "test-335" 16 (fxarithmetic-shift 1 4))
- (test "test-346" -1 (fxarithmetic-shift -1 0))
- (test "test-347" -2 (fxarithmetic-shift -1 1))
- (test "test-348" -4 (fxarithmetic-shift -1 2))
- (test "test-349" -8 (fxarithmetic-shift -1 3))
- (test "test-350" -16 (fxarithmetic-shift -1 4))
- (test "test-363" #b1010 (fxbit-field #b1101101010 0 4))
- (test "test-364" #b101101 (fxbit-field #b1101101010 3 9))
- (test "test-365" #b10110 (fxbit-field #b1101101010 4 9))
- (test "test-366" #b110110 (fxbit-field #b1101101010 4 10))
- (test "test-373" 3 (fxif 1 1 2))
- (test "test-378" #b00110011 (fxif #b00111100 #b11110000 #b00001111))
- (test "test-379" #b1 (fxcopy-bit 0 0 #t))
diff --git a/tests/run.scm b/tests/run.scm
index 0a61714..8adf143 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -1,23 +1,23 @@
-(import srfi-143) (import test)
+(import srfi-143 test)
+
(test-group "fixnum"
(test-group "fixnum/arithmetic"
(test #t (fixnum? 32767))
(test #f (fixnum? 1.1))
- (test #t (fx=? 1 1 1))
- (test #f (fx=? 1 2 2))
- (test #f (fx=? 1 1 2))
- (test #f (fx=? 1 2 3))
-
- (test #t (fx<? 1 2 3))
- (test #f (fx<? 1 1 2))
- (test #t (fx>? 3 2 1))
- (test #f (fx>? 2 1 1))
- (test #t (fx<=? 1 1 2))
- (test #f (fx<=? 1 2 1))
- (test #t (fx>=? 2 1 1))
- (test #f (fx>=? 1 2 1))
- (test '(#t #f) (list (fx<=? 1 1 2) (fx<=? 2 1 3)))
+ (test #t (fx=? 1 1))
+ (test #f (fx=? 1 2))
+ (test #f (fx=? 1 2))
+ (test #f (fx=? 2 3))
+
+ (test #t (fx<? 1 2))
+ (test #f (fx<? 1 1))
+ (test #t (fx>? 3 2))
+ (test #f (fx>? 1 1))
+ (test #t (fx<=? 1 2))
+ (test #f (fx<=? 2 1))
+ (test #t (fx>=? 2 1))
+ (test #f (fx>=? 1 2))
(test #t (fxzero? 0))
(test #f (fxzero? 1))
@@ -41,9 +41,9 @@
(test #t (fxeven? 102))
(test 4 (fxmax 3 4))
- (test 5 (fxmax 3 5 4))
+ (test 5 (fxmax 3 5))
(test 3 (fxmin 3 4))
- (test 3 (fxmin 3 5 4))
+ (test 3 (fxmin 3 5))
(test 7 (fx+ 3 4))
(test 12 (fx* 4 3))
--
2.43.0
