Sorry to reply to myself, but I've provided some better patches now, see
attached.
I went ahead and fixed the Makefile and SVNWiki pages as well. I can't
run test-new-egg but salmonella passes just fine.
Cheers,
--
Jeremy Steward
From 0fe5cff9482bc6a11594d907128ddbcad562976c Mon Sep 17 00:00:00 2001
From: Jeremy Steward <jer...@thatgeoguy.ca>
Date: Mon, 22 Apr 2024 21:54:21 -0600
Subject: [PATCH 3/3] Update svnwiki page with appropriate docs
---
srfi-143.svnwiki | 43 +++++++++++++++++++++----------------------
1 file changed, 21 insertions(+), 22 deletions(-)
diff --git a/srfi-143.svnwiki b/srfi-143.svnwiki
index 7f326e9..fd4be26 100644
--- a/srfi-143.svnwiki
+++ b/srfi-143.svnwiki
@@ -52,11 +52,9 @@ in the same way as {{(chicken fixnum}}).
=== Deviations from the specification
-In the CHICKEN implementation, {{fx+}}, {{fx-}}, and {{fx*}} are variadic,
-implemented with {{foldr}}, {{foldl}}, and {{foldr}}, respectively. For
-completeness, a variadic {{fx/}} is provided as well, implemented with
-{{foldl}}. It's not clear that this is much more useful than the SRFI's
-{{fxquotient}}.
+All procedures in this library are 2-arity wherever possible. The original
+SRFI-143 document lists these procedures as variadic, but for compatibility
+with {{(chicken fixnum)}} these are kept to 2-arity and re-exported.
=== Specification
@@ -105,23 +103,23 @@ Bound to the value {{-2^w-1}}, the smallest representable fixnum. (R6RS
Returns {{#t}} if obj is an exact integer within the fixnum range, and {{#f}}
otherwise.
-<procedure>(fx=? i ...)</procedure>
+<procedure>(fx=? i j)</procedure>
Semantically equivalent to {{=}}.
-<procedure>(fx<? i ...)</procedure>
+<procedure>(fx<? i j)</procedure>
Semantically equivalent to {{<}}.
-<procedure>(fx>? i ...)</procedure>
+<procedure>(fx>? i j)</procedure>
Semantically equivalent to {{>}}.
-<procedure>(fx<=? i ...)</procedure>
+<procedure>(fx<=? i j)</procedure>
Semantically equivalent to {{<=}}.
-<procedure>(fx>=? i ...)</procedure>
+<procedure>(fx>=? i j)</procedure>
Semantically equivalent to {{>=}}.
@@ -145,21 +143,21 @@ Semantically equivalent to {{odd?}}.
Semantically equivalent to {{even?}}.
-<procedure>(fxmax i j ...)</procedure>
+<procedure>(fxmax i j)</procedure>
Semantically equivalent to {{max}}.
-<procedure>(fxmin i j ...)</procedure>
+<procedure>(fxmin i j)</procedure>
Semantically equivalent to {{min}}.
==== Basic arithmetic
-<procedure>(fx+ i ...)</procedure>
+<procedure>(fx+ i j)</procedure>
Semantically equivalent to {{+}}.
-<procedure>(fx- i ...)</procedure>
+<procedure>(fx- i j)</procedure>
Semantically equivalent to {{-}}.
@@ -167,11 +165,11 @@ Semantically equivalent to {{-}}.
Semantically equivalent to {{-}}, but accepts exactly one argument.
-<procedure>(fx* i ...)</procedure>
+<procedure>(fx* i j)</procedure>
Semantically equivalent to {{*}}.
-<procedure>(fx/ i ...)</procedure>
+<procedure>(fx/ i j)</procedure>
Semantically equivalent to {{(foldr quotient i rest-args)}}.
@@ -243,15 +241,15 @@ are dropped for brevity and compatibility.
Semantically equivalent to {{bitwise-not}}.
-<procedure>(fxand i ...)</procedure>
+<procedure>(fxand i j)</procedure>
Semantically equivalent to {{bitwise-and}}.
-<procedure>(fxior i ...)</procedure>
+<procedure>(fxior i j)</procedure>
Semantically equivalent to {{bitwise-ior}}.
-<procedure>(fxxor i ...)</procedure>
+<procedure>(fxxor i j)</procedure>
Semantically equivalent to {{bitwise-xor}}.
@@ -331,17 +329,17 @@ Jaffer, Taylor Campbell, and the R6RS editors.
=== Copyright
Copyright (C) John Cowan (2016). 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
@@ -352,6 +350,7 @@ Jaffer, Taylor Campbell, and the R6RS editors.
=== Version history
+* 1.0.0 - Convert egg to R7RS library & convert variadic procedures to 2-arity procedures.
* 0.4.1 - Fix bug due to calling fixnum procedures with wrong number of arguments
* 0.4 - Implement variadic arithmetic operators, use fixnum operations internally
* 0.3 - Reorganize and reduce files
--
2.43.0
From c9e35def19b4f7c0753180ac395eb0f009b0ac60 Mon Sep 17 00:00:00 2001
From: Jeremy Steward <jer...@thatgeoguy.ca>
Date: Mon, 22 Apr 2024 21:29:41 -0600
Subject: [PATCH 2/3] Add chicken-lint to Makefile / clean up makefile
Some of the commands were a bit ??? so I did a bit of cleanup on the
Makefile.
---
Makefile | 36 ++++++++++++++++++++++++------------
1 file changed, 24 insertions(+), 12 deletions(-)
diff --git a/Makefile b/Makefile
index d613d59..7deea33 100644
--- a/Makefile
+++ b/Makefile
@@ -1,25 +1,37 @@
-CHICKEN_CLEAN := chicken-clean
-CHICKEN_INSTALL := chicken-install
-SALMONELLA := salmonella
-SALMONELLA_LOG := salmonella.log
-SALMONELLA_LOG_VIEWER := salmonella-log-viewer
-SRFI := srfi-143.scm
-TEST_NEW_EGG := test-new-egg
+CHICKEN_CLEAN := chicken-clean
+CHICKEN_INSTALL := chicken-install
+CHICKEN_LINT := chicken-lint
+CSI := csi
+SALMONELLA := salmonella
+SALMONELLA_LOG := salmonella.log
+SALMONELLA_LOG_VIEWER := salmonella-log-viewer
+SRFI := srfi-143.sld
+MKFILE_PATH := $(abspath $(lastword $(MAKEFILE_LIST)))
+PWD := $(dir $(MKFILE_PATH))
+SCHEME_FILES := srfi-143-impl.scm srfi-143.sld tests/run.scm
-all: test
+.PHONY: all clean compile lint salmonella test view print-%
+all: lint test
clean:
$(CHICKEN_CLEAN)
rm -f $(SALMONELLA_LOG)
compile:
- $(CHICKEN-INSTALL) -n
+ $(CHICKEN_INSTALL) -n
+
+lint:
+ $(CHICKEN_LINT) -I $(PWD) -X r7rs -R r7rs $(SCHEME_FILES)
+
+test: compile
+ $(CSI) -setup-mode -ns tests/run.scm
salmonella:
$(SALMONELLA)
-test:
- $(CHICKEN_INSTALL) -n -test
-
view:
$(SALMONELLA_LOG_VIEWER) $(SALMONELLA_LOG)
+
+## Debugging make-vars, call `make print-MYVAR`
+print-%:
+ @echo "$*=$($*)"
--
2.43.0
From 50888746e74614d7ed583e34eb110cc9c9e629b5 Mon Sep 17 00:00:00 2001
From: Jeremy Steward <jer...@thatgeoguy.ca>
Date: Mon, 22 Apr 2024 20:56:03 -0600
Subject: [PATCH 1/3] Convert egg to R7RS egg & variadic procedures to 2-arity
---
carries.scm | 63 ---------------
srfi-143-impl.scm | 177 +++++++++++++++++++++++++++++-------------
srfi-143.egg | 12 ++-
srfi-143.release-info | 1 +
srfi-143.scm | 86 --------------------
srfi-143.sld | 83 ++++++++++++++++++++
tests/r6rs-test.scm | 176 -----------------------------------------
tests/run.scm | 34 ++++----
8 files changed, 232 insertions(+), 400 deletions(-)
delete mode 100644 carries.scm
delete mode 100644 srfi-143.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
index 4949229..92f4541 100644
--- a/srfi-143-impl.scm
+++ b/srfi-143-impl.scm
@@ -1,60 +1,127 @@
-;;;; 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))))
+;;; 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) (chicken:fx* 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)))
+ (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))
+ (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))
+ (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
+ (vector 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 (chicken:fx- end start))))
+(define (mask start end)
+ (fxnot (fxarithmetic-shift-left -1 (fx- end start))))
(define (fxif mask n0 n1)
(fxior (fxand mask n0)
@@ -65,33 +132,33 @@
(define (fxcopy-bit index to bool)
(if bool
- (fxior to (fxarithmetic-shift-left 1 index))
- (fxand to (fxnot (fxarithmetic-shift-left 1 index)))))
+ (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 (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 (chicken:fx- end start))
+ (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 (chicken:fx- count width)))
- start)
+ (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 (chicken:fx+ -1 k) (chicken:fx+ -1 k))
+ (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 (chicken:fx- end start))
+ (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)
diff --git a/srfi-143.egg b/srfi-143.egg
index c3b35e5..5b2660e 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-impl.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
deleted file mode 100644
index c061ab9..0000000
--- a/srfi-143.scm
+++ /dev/null
@@ -1,86 +0,0 @@
-;;;; 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"))
diff --git a/srfi-143.sld b/srfi-143.sld
new file mode 100644
index 0000000..4d326c5
--- /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-impl.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
