From 1cea0c0feac1705274b63cc24aa9e0e09f01e3c0 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 11 Nov 2019 00:39:10 -0800
Subject: [PATCH] Finish implementing SRFI 143.

---
 src/libraries/inline-testing.scm     |   6 +-
 src/microcode/fixnum.c               |  20 ++
 src/runtime/library-standard.scm     |  46 ++++
 src/runtime/predicate.scm            |   4 +-
 src/runtime/primitive-arithmetic.scm | 239 ++++++++++++++++--
 src/runtime/runtime.pkg              |  23 +-
 src/sf/gconst.scm                    |   9 +-
 src/sf/usiexp.scm                    | 359 ++++++++++++++-------------
 tests/check.scm                      |   1 +
 tests/libraries/test-srfi-133.scm    |  26 ++
 tests/libraries/test-srfi-143.scm    | 194 +++++++++++++++
 11 files changed, 721 insertions(+), 206 deletions(-)
 create mode 100644 tests/libraries/test-srfi-143.scm

diff --git a/src/libraries/inline-testing.scm b/src/libraries/inline-testing.scm
index 0cd51b53d..760bf494a 100644
--- a/src/libraries/inline-testing.scm
+++ b/src/libraries/inline-testing.scm
@@ -264,6 +264,7 @@ USA.
 
 (define (summarize-test-results results)
   (let ((failing-results (filter failing-test-result? results)))
+    (for-each show-failing-result failing-results)
     (if (summarize?)
 	(begin
 	  (let ((failures (length failing-results))
@@ -278,14 +279,13 @@ USA.
 	    (write failures)
 	    (display " failure")
 	    (if (not (= 1 failures))
-		(display "s")))
-	  (for-each summarize-failing-result failing-results)))
+		(display "s")))))
     (null? failing-results)))
 
 (define (failing-test-result? result)
   (pair? (cdr result)))
 
-(define (summarize-failing-result failure)
+(define (show-failing-result failure)
   (newline)
   (newline)
   (display "evaluating ")
diff --git a/src/microcode/fixnum.c b/src/microcode/fixnum.c
index bf8256217..9c3f9b371 100644
--- a/src/microcode/fixnum.c
+++ b/src/microcode/fixnum.c
@@ -31,6 +31,7 @@ USA.
 
 #include "scheme.h"
 #include "prims.h"
+#include "bits.h"
 #include "fixnum.h"
 
 static long
@@ -286,6 +287,25 @@ DEFINE_PRIMITIVE ("FIXNUM-LSH", Prim_fixnum_lsh, 2, 2, 0)
   }
 }
 
+DEFINE_PRIMITIVE ("FXBIT-COUNT", Prim_fxbit_count, 1, 1, 0)
+{
+  PRIMITIVE_HEADER (1);
+  FIXNUM_RESULT (ulong_bit_count ((unsigned long) (arg_fixnum(1))));
+}
+
+DEFINE_PRIMITIVE ("FXLENGTH", Prim_fxlength, 1, 1, 0)
+{
+  PRIMITIVE_HEADER (1);
+  long n = (arg_fixnum(1));
+  FIXNUM_RESULT (ulong_length_in_bits ((unsigned long) ((n < 0) ? ~n : n)));
+}
+
+DEFINE_PRIMITIVE ("FXFIRST-SET-BIT", fxfirst_set_bit, 1, 1, 0)
+{
+  PRIMITIVE_HEADER (1);
+  FIXNUM_RESULT (ulong_first_set_bit ((unsigned long) (arg_fixnum(1))));
+}
+
 DEFINE_PRIMITIVE ("FIXNUM->FLONUM", Prim_fixnum_to_flonum, 1, 1,
 		  "(FIXNUM)\n\
 Equivalent to (INTEGER->FLONUM FIXNUM 2)")
diff --git a/src/runtime/library-standard.scm b/src/runtime/library-standard.scm
index c02b5d526..01021bdb8 100644
--- a/src/runtime/library-standard.scm
+++ b/src/runtime/library-standard.scm
@@ -975,6 +975,52 @@ USA.
 (define-standard-library '(srfi 131)
   '(define-record-type))
 
+(define-standard-library '(srfi 143)
+  '(fixnum?
+    fx*
+    fx*/carry
+    fx+
+    fx+/carry
+    fx-
+    fx-/carry
+    fx-greatest
+    fx-least
+    fx-width
+    fx<=?
+    fx<?
+    fx=?
+    fx>=?
+    fx>?
+    fxabs
+    fxand
+    fxarithmetic-shift
+    fxarithmetic-shift-left
+    fxarithmetic-shift-right
+    fxbit-count
+    fxbit-field
+    fxbit-field-reverse
+    fxbit-field-rotate
+    fxbit-set?
+    fxcopy-bit
+    fxeven?
+    fxfirst-set-bit
+    fxif
+    fxior
+    fxlength
+    fxmax
+    fxmin
+    fxneg
+    fxnegative?
+    fxnot
+    fxodd?
+    fxpositive?
+    fxquotient
+    fxremainder
+    fxsqrt
+    fxsquare
+    fxxor
+    fxzero?))
+
 ;;;; Synthetic libraries
 
 ;;; A synthetic library is one that's derived from legacy packages, much like a
diff --git a/src/runtime/predicate.scm b/src/runtime/predicate.scm
index b96d79918..6d4b4386b 100644
--- a/src/runtime/predicate.scm
+++ b/src/runtime/predicate.scm
@@ -210,7 +210,7 @@ USA.
 			'<= exact-nonnegative-integer?)
    (register-predicate! non-positive-fixnum? 'non-positive-fixnum
 			'<= fix:fixnum?)
-   (register-predicate! radix? 'radix '<= index-fixnum?)
+   (register-predicate! radix? 'radix '<= non-negative-fixnum?)
 
    (register-predicate! flo:flonum? 'flonum '<= real?)
 
@@ -274,7 +274,7 @@ USA.
    (register-predicate! thread-mutex? 'thread-mutex)
    (register-predicate! undefined-value? 'undefined-value)
    (register-predicate! unicode-code-point? 'unicode-code-point
-			'<= index-fixnum?)
+			'<= non-negative-fixnum?)
    (register-predicate! unicode-scalar-value? 'unicode-scalar-value
 			'<= unicode-code-point?)
    (register-predicate! uninterned-symbol? 'uninterned-symbol '<= symbol?)
diff --git a/src/runtime/primitive-arithmetic.scm b/src/runtime/primitive-arithmetic.scm
index f2488b842..11e03ecdc 100644
--- a/src/runtime/primitive-arithmetic.scm
+++ b/src/runtime/primitive-arithmetic.scm
@@ -32,36 +32,35 @@ USA.
 ;;;; Fixnums
 
 (define-primitives
+  (%fx<? less-than-fixnum? 2)
+  (%fx=? equal-fixnum? 2)
+  (%fx>? greater-than-fixnum? 2)
+  (%fxand fixnum-and 2)
+  (%fxior fixnum-or 2)
+  (%fxxor fixnum-xor 2)
+  (fix:andc fixnum-andc 2)
   (fix:divide divide-fixnum 2)
   (fix:gcd gcd-fixnum 2)
   (fixnum? fixnum? 1)
   (fx* multiply-fixnum 2)
   (fx+ plus-fixnum 2)
   (fx- minus-fixnum 2)
-  (fx<? less-than-fixnum? 2)
-  (fx=? equal-fixnum? 2)
-  (fx>? greater-than-fixnum? 2)
-  (fxand fixnum-and 2)
-  (fxandc fixnum-andc 2)
   (fxarithmetic-shift fixnum-lsh 2)
+  (fxbit-count fxbit-count 1)
   (fxdecr minus-one-plus-fixnum 1)
+  (fxfirst-set-bit fxfirst-set-bit 1)
   (fxincr one-plus-fixnum 1)
-  (fxior fixnum-or 2)
+  (fxlength fxlength 1)
   (fxnegative? negative-fixnum? 1)
   (fxnot fixnum-not 1)
   (fxpositive? positive-fixnum? 1)
   (fxquotient fixnum-quotient 2)
   (fxremainder fixnum-remainder 2)
-  (fxxor fixnum-xor 2)
   (fxzero? zero-fixnum? 1)
   (non-negative-fixnum? index-fixnum? 1))
 
-(define (fx<=? n m) (not (fx>? n m)))
-(define (fx>=? n m) (not (fx<? n m)))
 (define (fxabs n) (if (fx<? n 0) (fx- 0 n) n))
 (define (fxarithmetic-shift-right n m) (fxarithmetic-shift n (fx- 0 m)))
-(define (fxmax n m) (if (fx>? n m) n m))
-(define (fxmin n m) (if (fx<? n m) n m))
 (define (fxneg n) (fx- 0 n))
 (define (fxsquare n) (fx* n n))
 
@@ -76,6 +75,196 @@ USA.
 (define (non-positive-fixnum? object)
   (and (fixnum? object)
        (not (fxpositive? object))))
+
+(define (fxodd? n)
+  (fix:= (fix:and n 1) 1))
+
+(define (fxeven? n)
+  (fix:= (fix:and n 1) 0))
+
+(define (fx<? n m . rest)
+  (let loop ((n n) (m m) (rest rest))
+    (if (pair? rest)
+	(and (%fx<? n m)
+	     (loop m (car rest) (cdr rest)))
+	(%fx<? n m))))
+
+(define (fx<=? n m . rest)
+  (let loop ((n n) (m m) (rest rest))
+    (if (pair? rest)
+	(and (not (%fx>? n m))
+	     (loop m (car rest) (cdr rest)))
+	(not (%fx>? n m)))))
+
+(define (fx=? n m . rest)
+  (let loop ((n n) (m m) (rest rest))
+    (if (pair? rest)
+	(and (%fx=? n m)
+	     (loop m (car rest) (cdr rest)))
+	(%fx=? n m))))
+
+(define (fx>? n m . rest)
+  (let loop ((n n) (m m) (rest rest))
+    (if (pair? rest)
+	(and (%fx>? n m)
+	     (loop m (car rest) (cdr rest)))
+	(%fx>? n m))))
+
+(define (fx>=? n m . rest)
+  (let loop ((n n) (m m) (rest rest))
+    (if (pair? rest)
+	(and (not (%fx<? n m))
+	     (loop m (car rest) (cdr rest)))
+	(not (%fx<? n m)))))
+
+(define (fxmax n m . rest)
+  (let loop ((n n) (m m) (rest rest))
+    (if (pair? rest)
+	(loop (if (fx>? n m) n m) (car rest) (cdr rest))
+	(if (fx>? n m) n m))))
+
+(define (fxmin n m . rest)
+  (let loop ((n n) (m m) (rest rest))
+    (if (pair? rest)
+	(loop (if (fx<? n m) n m) (car rest) (cdr rest))
+	(if (fx<? n m) n m))))
+
+(define (fxand n m . rest)
+  (let loop ((n n) (m m) (rest rest))
+    (if (pair? rest)
+	(loop (%fxand n m) (car rest) (cdr rest))
+	(%fxand n m))))
+
+(define (fxior n m . rest)
+  (let loop ((n n) (m m) (rest rest))
+    (if (pair? rest)
+	(loop (%fxior n m) (car rest) (cdr rest))
+	(%fxior n m))))
+
+(define (fxxor n m . rest)
+  (let loop ((n n) (m m) (rest rest))
+    (if (pair? rest)
+	(loop (%fxxor n m) (car rest) (cdr rest))
+	(%fxxor n m))))
+
+(define (fx+/carry i j k)
+  (let ((sum (+ i j k)))
+    (receive (q r) (balanced/ sum unsigned-limit)
+      (values r q))))
+
+(define (fx-/carry i j k)
+  (let ((diff (- i j k)))
+    (receive (q r) (balanced/ diff unsigned-limit)
+      (values r q))))
+
+(define (fx*/carry i j k)
+  (let ((prod (+ (* i j) k)))
+    (receive (q r) (balanced/ prod unsigned-limit)
+      (values r q))))
+
+(define (balanced/ x y)
+  (receive (q r) (euclidean/ x y)
+    (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)))))))
+
+(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 (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 (fxif mask i j)
+  (fxior (fxand mask i)
+	 (fxand (fxnot mask) j)))
+
+(define (fxbit-set? index i)
+  (if (not (fx<? index fx-width))
+      (error:bad-range-argument index 'fxbit-set?))
+  (not (fxzero? (fxand (fxarithmetic-shift-left 1 index) i))))
+
+(define (fxcopy-bit index i boolean)
+  (if (not (fx<? index fx-width))
+      (error:bad-range-argument index 'fxcopy-bit))
+  (if boolean
+      (fxior i (fxarithmetic-shift-left 1 index))
+      (fxand i (fxnot (fxarithmetic-shift-left 1 index)))))
+
+(define (fxbit-field i start end)
+  (if (not (fx<=? end fx-width))
+      (error:bad-range-argument end 'fxbit-field))
+  (if (not (fx<=? start end))
+      (error:bad-range-argument start 'fxbit-field))
+  (fxand (fxnot (fxarithmetic-shift-left -1 (fx- end start)))
+	 (fxarithmetic-shift i (fxneg start))))
+
+(define (fxbit-field-rotate i count start end)
+  (if (not (fx<=? end fx-width))
+      (error:bad-range-argument end 'fxbit-field))
+  (if (not (fx<=? start end))
+      (error:bad-range-argument start 'fxbit-field))
+  (let* ((field-width (fx- end start))
+	 (mask (fxnot (fxarithmetic-shift -1 field-width)))
+	 (field (fxand mask (fxarithmetic-shift i (fxneg start)))))
+    (fxior (fxarithmetic-shift (fxrotate field-width field mask count) start)
+	   (fxand (fxnot (fxarithmetic-shift mask start)) i))))
+
+(define (fxrotate field-width field mask count)
+  (let ((count (modulo count field-width)))
+    (fxior (fxand mask (fxarithmetic-shift field count))
+	   (fxarithmetic-shift field (fx- count field-width)))))
+
+(define (fxbit-field-reverse i start end)
+  (if (not (fx<=? end fx-width))
+      (error:bad-range-argument end 'fxbit-field))
+  (if (not (fx<=? start end))
+      (error:bad-range-argument start 'fxbit-field))
+  (let* ((field-width (fx- end start))
+	 (mask (fxnot (fxarithmetic-shift -1 field-width)))
+	 (field (fxand mask (fxarithmetic-shift i (fxneg start)))))
+    (fxior (fxarithmetic-shift (fxreverse field-width field) start)
+	   (fxand (fxnot (fxarithmetic-shift mask start)) i))))
+
+(define (fxreverse field-width field)
+  (let loop ((i (fx- field-width 1)) (n field) (m 0))
+    (if (fx<? i 0)
+	m
+	(loop (fx- i 1)
+	      (fxarithmetic-shift-right n 1)
+	      (fxior (fxarithmetic-shift-left m 1)
+		     (fxand n 1))))))
 
 (define (guarantee-limited-index-fixnum object limit #!optional caller)
   (guarantee index-fixnum? object caller)
@@ -88,16 +277,18 @@ USA.
 (define fx-width)
 (define fx-greatest)
 (define fx-least)
+(define unsigned-limit)
 (add-boot-init!
  (lambda ()
    (let loop ((n 1) (w 1))
      (if (fixnum? n)
 	 (loop (int:* n 2) (int:+ w 1))
-	 (let ((n (int:- n 1)))
-	   (if (not (fixnum? n))
-	       (error "Unable to compute largest fixnum:" n))
-	   (set! fx-greatest n)
-	   (set! fx-width w))))
+	 (let ((m (int:- n 1)))
+	   (if (not (fixnum? m))
+	       (error "Unable to compute largest fixnum:" m))
+	   (set! fx-greatest m)
+	   (set! fx-width w)
+	   (set! unsigned-limit (int:* n 2)))))
    (let loop ((n -1))
      (if (fixnum? n)
 	 (loop (int:* n 2))
@@ -497,4 +688,20 @@ USA.
 	(let ((j (int:quotient (int:+ i (int:quotient n i)) 2)))
 	  (if (int:>= j i)
 	      (values i (int:- n (int:* i i)))
+	      (loop j))))))
+
+(define (fxsqrt n)
+  (guarantee non-negative-fixnum? n 'fxsqrt)
+  (if (fxzero? n)
+      (values 0 0)
+      (let loop
+	  ((i
+	    (fxarithmetic-shift-left 1
+				     (let ((n-bits (fxlength n)))
+				       (if (fxeven? n-bits)
+					   (fxquotient n-bits 2)
+					   (fx+ (fxquotient n-bits 2) 1))))))
+	(let ((j (fxquotient (fx+ i (fxquotient n i)) 2)))
+	  (if (fx>=? j i)
+	      (values i (fx- n (fx* i i)))
 	      (loop j))))))
\ No newline at end of file
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index e9128a590..927c6380a 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -268,8 +268,6 @@ USA.
 	  (fix:> fx>?)
 	  (fix:>= fx>=?)
 	  (fix:and fxand)
-	  (fix:andc fxandc)
-	  (fix:andc fxandc)
 	  (fix:fixnum? fixnum?)
 	  (fix:lsh fxarithmetic-shift)
 	  (fix:max fxmax)
@@ -288,6 +286,7 @@ USA.
 	  (index-fixnum? non-negative-fixnum?)
 	  ->flonum
 	  exact-integer-sqrt
+	  fix:andc
 	  fix:divide
 	  fix:end-index
 	  fix:gcd
@@ -297,27 +296,47 @@ USA.
 	  fix:start-index
 	  fixnum?			;SRFI-143
 	  fx*				;SRFI-143
+	  fx*/carry			;SRFI-143
 	  fx+				;SRFI-143
+	  fx+/carry			;SRFI-143
 	  fx-				;SRFI-143
+	  fx-/carry			;SRFI-143
 	  fx-greatest			;SRFI-143
 	  fx-least			;SRFI-143
 	  fx-width			;SRFI-143
+	  fx<=?				;SRFI-143
+	  fx<?				;SRFI-143
+	  fx=?				;SRFI-143
+	  fx>=?				;SRFI-143
+	  fx>?				;SRFI-143
 	  fxabs				;SRFI-143
 	  fxand				;SRFI-143
 	  fxandc
 	  fxarithmetic-shift		;SRFI-143
 	  fxarithmetic-shift-right	;SRFI-143
+	  fxbit-count			;SRFI-143
+	  fxbit-field			;SRFI-143
+	  fxbit-field-reverse		;SRFI-143
+	  fxbit-field-rotate		;SRFI-143
+	  fxbit-set?			;SRFI-143
+	  fxcopy-bit			;SRFI-143
 	  fxdecr
+	  fxeven?			;SRFI-143
+	  fxfirst-set-bit		;SRFI-143
+	  fxif				;SRFI-143
 	  fxincr
 	  fxior				;SRFI-143
+	  fxlength			;SRFI-143
 	  fxmax				;SRFI-143
 	  fxmin				;SRFI-143
 	  fxneg				;SRFI-143
 	  fxnegative?			;SRFI-143
 	  fxnot				;SRFI-143
+	  fxodd?			;SRFI-143
 	  fxpositive?			;SRFI-143
 	  fxquotient			;SRFI-143
 	  fxremainder			;SRFI-143
+	  fxsqrt			;SRFI-143
 	  fxsquare			;SRFI-143
 	  fxxor				;SRFI-143
 	  fxzero?			;SRFI-143
diff --git a/src/sf/gconst.scm b/src/sf/gconst.scm
index da65fdd62..b5edfbffe 100644
--- a/src/sf/gconst.scm
+++ b/src/sf/gconst.scm
@@ -172,22 +172,19 @@ USA.
     (fx* multiply-fixnum 2)
     (fx+ plus-fixnum 2)
     (fx- minus-fixnum 2)
-    (fx<? less-than-fixnum? 2)
-    (fx=? equal-fixnum? 2)
-    (fx>? greater-than-fixnum? 2)
-    (fxand fixnum-and 2)
     (fxandc fixnum-andc 2)
     (fxarithmetic-shift fixnum-lsh 2)
     (fxarithmetic-shift-left fixnum-lsh 2)
+    (fxbit-count fxbit-count 1)
     (fxdecr minus-one-plus-fixnum 1)
+    (fxfirst-set-bit fxfirst-set-bit 1)
     (fxincr one-plus-fixnum 1)
-    (fxior fixnum-or 2)
+    (fxlength fxlength 1)
     (fxnegative? negative-fixnum? 1)
     (fxnot fixnum-not 1)
     (fxpositive? positive-fixnum? 1)
     (fxquotient fixnum-quotient 2)
     (fxremainder fixnum-remainder 2)
-    (fxxor fixnum-xor 2)
     (fxzero? zero-fixnum? 1)
     (general-car-cdr general-car-cdr)
     (get-fixed-objects-vector get-fixed-objects-vector)
diff --git a/src/sf/usiexp.scm b/src/sf/usiexp.scm
index 8e3118e69..53758b811 100644
--- a/src/sf/usiexp.scm
+++ b/src/sf/usiexp.scm
@@ -32,12 +32,23 @@ USA.
 
 ;;;; Fixed-arity arithmetic primitives
 
-(define (make-combination expression block primitive operands)
-  (combination/make expression
+(define (pcall expr block operator . operands)
+  (papply expr block operator operands))
+
+(define (papply expr block operator operands)
+  (combination/make expr
 		    block
-		    (constant/make #f primitive)
+		    (if (primitive-procedure? operator)
+			(pconst #f operator)
+			operator)
 		    operands))
 
+(define (pconst expr datum)
+  (constant/make (and expr (object/scode expr)) datum))
+
+(define (pif expr p c a)
+  (conditional/make (and expr (object/scode expr)) p c a))
+
 (define (make-operand-binding expression block operand make-body)
   (combination/make expression
 		    block
@@ -59,7 +70,7 @@ USA.
   (lambda (expr operands block)
     (if (and (pair? operands)
 	     (null? (cdr operands)))
-	(make-combination expr block primitive operands)
+	(papply expr block primitive operands)
 	#f)))
 
 (define (binary-arithmetic primitive)
@@ -67,7 +78,7 @@ USA.
     (if (and (pair? operands)
 	     (pair? (cdr operands))
 	     (null? (cddr operands)))
-	(make-combination expr block primitive operands)
+	(papply expr block primitive operands)
 	#f)))
 
 (define zero?-expansion
@@ -102,13 +113,11 @@ USA.
 	     (pair? (cdr operands))
 	     (null? (cddr operands)))
 	(cond ((constant-eq? (car operands) 0)
-	       (make-combination expr block if-left-zero
-				 (list (cadr operands))))
+	       (pcall expr block if-left-zero (cadr operands)))
 	      ((constant-eq? (cadr operands) 0)
-	       (make-combination expr block if-right-zero
-				 (list (car operands))))
+	       (pcall expr block if-right-zero (car operands)))
 	      (else
-	       (make-combination expr block binary-predicate operands)))
+	       (papply expr block binary-predicate operands)))
 	#f)))
 
 (define =-expansion
@@ -128,67 +137,72 @@ USA.
 
 ;;;; Fixnum Operations
 
-(define (fix:=-expansion expr operands block)
-  (if (and (pair? operands)
-	   (pair? (cdr operands))
-	   (null? (cddr operands)))
-      (make-combination expr block (ucode-primitive eq?) operands)
+(define (fx-compare prim)
+  (lambda (expr ops block)
+    (case (length ops)
+      ((2)
+       (pcall expr block prim (car ops) (cadr ops)))
+      ((3)
+       (pif expr
+	    (pcall #f block prim (car ops) (cadr ops))
+	    (pcall #f block prim (car ops) (caddr ops))
+	    (pconst #f #f)))
+      ((4)
+       (pif expr
+	    (pcall #f block prim (car ops) (cadr ops))
+	    (pif #f
+		 (pcall #f block prim (cadr ops) (caddr ops))
+		 (pcall #f block prim (caddr ops) (cadddr ops))
+		 (pconst #f #f))
+	    (pconst #f #f)))
+      (else #f))))
+
+(define fx=?-expansion (fx-compare (ucode-primitive eq?)))
+(define fx<?-expansion (fx-compare (ucode-primitive less-than-fixnum?)))
+(define fx>?-expansion (fx-compare (ucode-primitive greater-than-fixnum?)))
+
+(define (fxnot-compare prim)
+  (lambda (expr ops block)
+
+    (define (pnot expr operand)
+      (pcall expr block (ucode-primitive not) operand))
+
+    (case (length ops)
+      ((2)
+       (pnot expr (pcall #f block prim (car ops) (cadr ops))))
+      ((3)
+       (pif expr
+	    (pcall #f block prim (car ops) (cadr ops))
+	    (pconst #f #f)
+	    (pnot #f (pcall #f block prim (car ops) (caddr ops)))))
+      ((4)
+       (pif expr
+	    (pcall #f block prim (car ops) (cadr ops))
+	    (pconst #f #f)
+	    (pif #f
+		 (pcall #f block prim (cadr ops) (caddr ops))
+		 (pconst #f #f)
+		 (pnot #f (pcall #f block prim (caddr ops) (cadddr ops))))))
+      (else #f))))
+
+(define fx<=?-expansion (fxnot-compare (ucode-primitive greater-than-fixnum?)))
+(define fx>=?-expansion (fxnot-compare (ucode-primitive less-than-fixnum?)))
+
+(define (fxneg-expansion expr ops block)
+  (if (and (pair? ops)
+	   (null? (cdr ops)))
+      (pcall expr block (ucode-primitive minus-fixnum) (pconst #f 0) (car ops))
       #f))
 
-(define char=?-expansion
-  fix:=-expansion)
-
-(define (fix:<=-expansion expr operands block)
-  (if (and (pair? operands)
-	   (pair? (cdr operands))
-	   (null? (cddr operands)))
-      (make-combination
-       expr
-       block
-       (ucode-primitive not)
-       (list (make-combination #f
-			       block
-			       (ucode-primitive greater-than-fixnum?)
-			       operands)))
-      #f))
-
-(define (fix:>=-expansion expr operands block)
-  (if (and (pair? operands)
-	   (pair? (cdr operands))
-	   (null? (cddr operands)))
-      (make-combination
-       expr
-       block
-       (ucode-primitive not)
-       (list (make-combination #f
-			       block
-			       (ucode-primitive less-than-fixnum?)
-			       operands)))
-      #f))
-
-(define (fxneg-expansion expr operands block)
-  (if (and (pair? operands)
-	   (null? (cdr operands)))
-      (make-combination expr
-			block
-			(ucode-primitive minus-fixnum)
-			(constant/make #f 0)
-			(car operands))
-      #f))
-
-(define (fxarithmetic-shift-right-expansion expr operands block)
-  (if (and (pair? operands)
-	   (pair? (cdr operands))
-	   (null? (cddr operands)))
-      (make-combination expr
-			block
-			(ucode-primitive fixnum-lsh)
-			(car operands)
-			(make-combination #f
-					  block
-					  (ucode-primitive minus-fixnum)
-					  (constant/make #f 0)
-					  (cadr operands)))
+(define (fxarithmetic-shift-right-expansion expr ops block)
+  (if (and (pair? ops)
+	   (pair? (cdr ops))
+	   (null? (cddr ops)))
+      (pcall expr block (ucode-primitive fixnum-lsh)
+	     (car ops)
+	     (pcall #f block (ucode-primitive minus-fixnum)
+		    (pconst #f 0)
+		    (cadr ops)))
       #f))
 
 ;;;; N-ary Arithmetic Field Operations
@@ -218,16 +232,16 @@ USA.
   (right-accumulation 0
     (lambda (expr block x y)
       (cond ((constant-eq? x 1)
-	     (make-combination expr block (ucode-primitive 1+) (list y)))
+	     (pcall expr block (ucode-primitive 1+) y))
 	    ((constant-eq? y 1)
-	     (make-combination expr block (ucode-primitive 1+) (list x)))
+	     (pcall expr block (ucode-primitive 1+) x))
 	    (else
-	     (make-combination expr block (ucode-primitive &+) (list x y)))))))
+	     (pcall expr block (ucode-primitive &+) x y))))))
 
 (define *-expansion
   (right-accumulation 1
     (lambda (expr block x y)
-      (make-combination expr block (ucode-primitive &*) (list x y)))))
+      (pcall expr block (ucode-primitive &*) x y))))
 
 (define (expt-expansion expr operands block)
   (let ((make-binder
@@ -247,37 +261,23 @@ USA.
 	  ((constant-eq? (cadr operands) 2)
 	   (make-binder
 	    (lambda (block operand)
-	      (make-combination #f
-				block
-				(ucode-primitive &*)
-				(list operand operand)))))
+	      (pcall #f block (ucode-primitive &*) operand operand))))
 	  ((constant-eq? (cadr operands) 3)
 	   (make-binder
 	    (lambda (block operand)
-	      (make-combination
-	       #f
-	       block
-	       (ucode-primitive &*)
-	       (list operand
-		     (make-combination #f
-				       block
-				       (ucode-primitive &*)
-				       (list operand operand)))))))
+	      (pcall #f
+		     block
+		     (ucode-primitive &*)
+		     operand
+		     (pcall #f block (ucode-primitive &*) operand operand)))))
 	  ((constant-eq? (cadr operands) 4)
 	   (make-binder
 	    (lambda (block operand)
-	      (make-combination
-	       #f
-	       block
-	       (ucode-primitive &*)
-	       (list (make-combination #f
-				       block
-				       (ucode-primitive &*)
-				       (list operand operand))
-		     (make-combination #f
-				       block
-				       (ucode-primitive &*)
-				       (list operand operand)))))))
+	      (pcall #f
+		     block
+		     (ucode-primitive &*)
+		     (pcall #f block (ucode-primitive &*) operand operand)
+		     (pcall #f block (ucode-primitive &*) operand operand)))))
 	  (else #f))))
 
 (define (right-accumulation-inverse identity inverse-expansion make-binary)
@@ -302,19 +302,19 @@ USA.
   (right-accumulation-inverse 0 +-expansion
     (lambda (expr block x y)
       (if (constant-eq? y 1)
-	  (make-combination expr block (ucode-primitive -1+) (list x))
-	  (make-combination expr block (ucode-primitive &-) (list x y))))))
+	  (pcall expr block (ucode-primitive -1+) x)
+	  (pcall expr block (ucode-primitive &-) x y)))))
 
 (define /-expansion
   (right-accumulation-inverse 1 *-expansion
     (lambda (expr block x y)
-      (make-combination expr block (ucode-primitive &/) (list x y)))))
+      (pcall expr block (ucode-primitive &/) x y))))
 
 ;;;; N-ary List Operations
 
 (define (apply*-expansion expr operands block)
   (cond ((length=? operands 2)
-	 (make-combination expr block (ucode-primitive apply) operands))
+	 (papply expr block (ucode-primitive apply) operands))
 	((not (pair? operands)) #f)
 	((pair? (cdr operands))
 	 (apply*-expansion
@@ -330,21 +330,24 @@ USA.
 (define (cons*-expansion-loop expr block rest)
   (if (null? (cdr rest))
       (car rest)
-      (make-combination expr
-			block
-			(ucode-primitive cons)
-			(list (car rest)
-			      (cons*-expansion-loop #f block (cdr rest))))))
+      (pcall expr
+	     block
+	     (ucode-primitive cons)
+	     (car rest)
+	     (cons*-expansion-loop #f block (cdr rest)))))
 
 (define (list-expansion expr operands block)
   (list-expansion-loop expr block operands))
 
 (define (list-expansion-loop expr block rest)
-  (cond ((pair? rest) (make-combination expr block (ucode-primitive cons)
-			(list (car rest)
-			      (list-expansion-loop #f block (cdr rest)))))
-	((null? rest) (constant/make (and expr (object/scode expr)) '()))
-	(else (error "Improper list."))))
+  (cond ((pair? rest)
+	 (pcall expr block (ucode-primitive cons)
+		(car rest)
+		(list-expansion-loop #f block (cdr rest))))
+	((null? rest)
+	 (constant/make (and expr (object/scode expr)) '()))
+	(else
+	 (error "Improper list."))))
 
 ;;;; General CAR/CDR Encodings
 
@@ -371,33 +374,30 @@ USA.
       (let ((operand (first operands)))
 	(cond ((call-to-car? operand)
 	       ;; (car (car x)) => (caar x)
-	       (make-combination
-		expr block
-		(ucode-primitive general-car-cdr)
-		(list (first (combination/operands operand))
-		      (constant/make #f #b111))))
+	       (pcall expr block
+		      (ucode-primitive general-car-cdr)
+		      (first (combination/operands operand))
+		      (constant/make #f #b111)))
 	      ;; (car (cdr x)) => (cadr x)
 	      ((call-to-cdr? operand)
-	       (make-combination
-		expr block
-		(ucode-primitive general-car-cdr)
-		(list (first (combination/operands operand))
-		      (constant/make #f #b110))))
+	       (pcall expr block
+		      (ucode-primitive general-car-cdr)
+		      (first (combination/operands operand))
+		      (constant/make #f #b110)))
 
 	      ((call-to-general-car-cdr? operand)
-	       (make-combination
-		expr block
-		(ucode-primitive general-car-cdr)
-		(list (first (combination/operands operand))
+	       (pcall expr block
+		      (ucode-primitive general-car-cdr)
+		      (first (combination/operands operand))
 		      (constant/make
 		       #f
 		       (encode-general-car-cdr
 			(cons 'car
 			      (decode-general-car-cdr
 			       (constant/value
-				(second (combination/operands operand))))))))))
+				(second (combination/operands operand)))))))))
 	      (else
-	       (make-combination expr block (ucode-primitive car) operands))))
+	       (papply expr block (ucode-primitive car) operands))))
       ;; ill-formed call
       (begin
 	(warn "Wrong number of arguments in call to CAR.")
@@ -409,33 +409,30 @@ USA.
       (let ((operand (first operands)))
 	(cond ((call-to-car? operand)
 	       ;; (cdr (car x)) => (cdar x)
-	       (make-combination
-		expr block
-		(ucode-primitive general-car-cdr)
-		(list (first (combination/operands operand))
-		      (constant/make #f #b101))))
+	       (pcall expr block
+		      (ucode-primitive general-car-cdr)
+		      (first (combination/operands operand))
+		      (constant/make #f #b101)))
 	      ;; (cdr (car x)) => (cddr x)
 	      ((call-to-cdr? operand)
-	       (make-combination
-		expr block
-		(ucode-primitive general-car-cdr)
-		(list (first (combination/operands operand))
-		      (constant/make #f #b100))))
+	       (pcall expr block
+		      (ucode-primitive general-car-cdr)
+		      (first (combination/operands operand))
+		      (constant/make #f #b100)))
 
 	      ((call-to-general-car-cdr? (car operands))
-	       (make-combination
-		expr block
-		(ucode-primitive general-car-cdr)
-		(list (first (combination/operands operand))
+	       (pcall expr block
+		      (ucode-primitive general-car-cdr)
+		      (first (combination/operands operand))
 		      (constant/make
 		       #f
 		       (encode-general-car-cdr
 			(cons 'cdr
 			      (decode-general-car-cdr
 			       (constant/value
-				(second (combination/operands operand))))))))))
+				(second (combination/operands operand)))))))))
 	      (else
-	       (make-combination expr block (ucode-primitive cdr) operands))))
+	       (papply expr block (ucode-primitive cdr) operands))))
       ;; ill-formed call
       (begin
 	(warn "Wrong number of arguments in call to CDR.")
@@ -444,11 +441,11 @@ USA.
 (define (general-car-cdr-expansion encoding)
   (lambda (expr operands block)
     (if (length=? operands 1)
-	(make-combination expr
-			  block
-			  (ucode-primitive general-car-cdr)
-			  (list (car operands)
-				(constant/make #f encoding)))
+	(pcall expr
+	       block
+	       (ucode-primitive general-car-cdr)
+	       (car operands)
+	       (constant/make #f encoding))
 	#f)))
 
 (define caar-expansion (general-car-cdr-expansion #b111))
@@ -503,31 +500,33 @@ USA.
 	     (sequence/make
 	      (and expr (object/scode expr))
 	      (list (first operands)
-		    (make-combination #f block
-				      (ucode-primitive not) (cdr operands)))))
+		    (pcall #f block (ucode-primitive not) (cadr operands)))))
 	    ((expression/always-false? (second operands))
 	     (sequence/make
 	      (and expr (object/scode expr))
 	      (list (second operands)
-		    (make-combination #f block
-				      (ucode-primitive not)
-				      (list (car operands))))))
+		    (pcall #f block (ucode-primitive not) (car operands)))))
 	    (else
-	     (make-combination expr block (ucode-primitive eq?) operands)))
+	     (papply expr block (ucode-primitive eq?) operands)))
+      #f))
+
+(define (char=?-expansion expr operands block)
+  (if (and (pair? operands)
+	   (pair? (cdr operands))
+	   (null? (cddr operands)))
+      (papply expr block (ucode-primitive eq?) operands)
       #f))
 
 (define (make-string-expansion expr operands block)
   (if (and (pair? operands)
 	   (null? (cdr operands)))
-      (make-combination expr block (ucode-primitive string-allocate)
-			operands)
+      (papply expr block (ucode-primitive string-allocate) operands)
       #f))
 
 (define (make-bytevector-expansion expr operands block)
   (if (and (pair? operands)
 	   (null? (cdr operands)))
-      (make-combination expr block (ucode-primitive allocate-bytevector 1)
-			operands)
+      (papply expr block (ucode-primitive allocate-bytevector 1) operands)
       #f))
 
 (define (not-expansion expr operands block)
@@ -539,7 +538,7 @@ USA.
 	    ((expression/never-false? (first operands))
 	     (sequence/make (and expr (object/scode expr))
 			    (list (first operands) (constant/make #f #f))))
-	    (else (make-combination expr block (ucode-primitive not) operands)))
+	    (else (papply expr block (ucode-primitive not) operands)))
       #f))
 
 (define (guarantee-expansion expr operands block)
@@ -672,9 +671,9 @@ USA.
 (define (default-object?-expansion expr operands block)
   (if (and (pair? operands)
 	   (null? (cdr operands)))
-      (make-combination expr block (ucode-primitive eq?)
-			(list (car operands)
-			      (constant/make #f #!default)))
+      (pcall expr block (ucode-primitive eq?)
+	      (car operands)
+	      (constant/make #f #!default))
       #f))
 
 (define (make-disjunction expr . clauses)
@@ -685,9 +684,10 @@ USA.
 			  (car clauses) (loop (cdr clauses))))))
 
 (define (make-type-test expr block type operand)
-  (make-combination expr block
-		    (ucode-primitive object-type?)
-		    (list (constant/make #f type) operand)))
+  (pcall expr block
+	 (ucode-primitive object-type?)
+	 (constant/make #f type)
+	 operand))
 
 (define (string->symbol-expansion expr operands block)
   (declare (ignore block))
@@ -712,16 +712,17 @@ USA.
 (define (int:->flonum-expansion expr operands block)
   (if (and (pair? operands)
 	   (null? (cdr operands)))
-      (make-combination expr
-			block
-			(ucode-primitive integer->flonum 2)
-			(list (car operands) (constant/make #f #b10)))
+      (pcall expr
+	     block
+	     (ucode-primitive integer->flonum 2)
+	     (car operands)
+	     (constant/make #f #b10))
       #f))
 
 (define (make-primitive-expander primitive)
   (lambda (expr operands block)
     (if (procedure-arity-valid? primitive (length operands))
-	(make-combination expr block primitive operands)
+	(papply expr block primitive operands)
 	#f)))
 
 ;;;; Tables
@@ -782,8 +783,10 @@ USA.
 	    fix:=
 	    fix:>=
 	    fourth
+	    fx<?
 	    fx<=?
 	    fx=?
+	    fx>?
 	    fx>=?
 	    fxarithmetic-shift-right
 	    fxneg
@@ -863,13 +866,15 @@ USA.
 	   eq?-expansion
 	   fifth-expansion
 	   first-expansion
-	   fix:<=-expansion
-	   fix:=-expansion
-	   fix:>=-expansion
+	   fx<=?-expansion
+	   fx=?-expansion
+	   fx>=?-expansion
 	   fourth-expansion
-	   fix:<=-expansion
-	   fix:=-expansion
-	   fix:>=-expansion
+	   fx<?-expansion
+	   fx<=?-expansion
+	   fx=?-expansion
+	   fx>?-expansion
+	   fx>=?-expansion
 	   fxarithmetic-shift-right-expansion
 	   fxneg-expansion
 	   guarantee-expansion
diff --git a/tests/check.scm b/tests/check.scm
index 5de62fae5..790325ccf 100644
--- a/tests/check.scm
+++ b/tests/check.scm
@@ -116,6 +116,7 @@ USA.
     "ffi/test-ffi"
     "sos/test-genmult"
     ("libraries/test-srfi-133" inline)
+    ("libraries/test-srfi-143" inline)
     ))
 
 (with-working-directory-pathname
diff --git a/tests/libraries/test-srfi-133.scm b/tests/libraries/test-srfi-133.scm
index c597eb3aa..82e53871e 100644
--- a/tests/libraries/test-srfi-133.scm
+++ b/tests/libraries/test-srfi-133.scm
@@ -1,3 +1,29 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
 (import (scheme base)
 	(srfi 133))
 
diff --git a/tests/libraries/test-srfi-143.scm b/tests/libraries/test-srfi-143.scm
new file mode 100644
index 000000000..1216fad03
--- /dev/null
+++ b/tests/libraries/test-srfi-143.scm
@@ -0,0 +1,194 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+(import (scheme base)
+	(srfi 143))
+
+(fixnum? 32767) 'expect-true
+(fixnum? 1.1) 'expect-false
+
+(fx=? 1 1 1) 'expect-true
+(fx=? 1 2 2) 'expect-false
+(fx=? 1 1 2) 'expect-false
+(fx=? 1 2 3) 'expect-false
+
+(fx<? 1 2 3) 'expect-true
+(fx<? 1 1 2) 'expect-false
+(fx>? 3 2 1) 'expect-true
+(fx>? 2 1 1) 'expect-false
+(fx<=? 1 1 2) 'expect-true
+(fx<=? 1 2 1) 'expect-false
+(fx>=? 2 1 1) 'expect-true
+(fx>=? 1 2 1) 'expect-false
+(list (fx<=? 1 1 2) (fx<=? 2 1 3)) '(expect equal? '(#t #f))
+
+(fxzero? 0) 'expect-true
+(fxzero? 1) 'expect-false
+
+(fxpositive? 0) 'expect-false
+(fxpositive? 1) 'expect-true
+(fxpositive? -1) 'expect-false
+
+(fxnegative? 0) 'expect-false
+(fxnegative? 1) 'expect-false
+(fxnegative? -1) 'expect-true
+
+(fxodd? 0) 'expect-false
+(fxodd? 1) 'expect-true
+(fxodd? -1) 'expect-true
+(fxodd? 102) 'expect-false
+
+(fxeven? 0) 'expect-true
+(fxeven? 1) 'expect-false
+(fxeven? -2) 'expect-true
+(fxeven? 102) 'expect-true
+
+(fxmax 3 4) '(expect = 4)
+(fxmax 3 5 4) '(expect = 5)
+(fxmin 3 4) '(expect = 3)
+(fxmin 3 5 4) '(expect = 3)
+
+(fx+ 3 4) '(expect = 7)
+(fx* 4 3) '(expect = 12)
+
+(fx- 3 4) '(expect = -1)
+(fxneg 3) '(expect = -3)
+
+(fxabs -7) '(expect = 7)
+(fxabs 7) '(expect = 7)
+
+(fxsquare 42) '(expect = 1764)
+(fxsquare 2) '(expect = 4)
+
+(fxquotient 5 2) '(expect = 2)
+(fxquotient -5 2) '(expect = -2)
+(fxquotient 5 -2) '(expect = -2)
+(fxquotient -5 -2) '(expect = 2)
+
+(fxremainder 13 4) '(expect = 1)
+(fxremainder -13 4) '(expect = -1)
+(fxremainder 13 -4) '(expect = 1)
+(fxremainder -13 -4) '(expect = -1)
+
+(let*-values (((root rem) (fxsqrt 32)))
+  (* root rem))
+'(expect = 35)
+
+(fxnot 0) '(expect = -1)
+(fxand #b0 #b1) '(expect = 0)
+(fxand 14 6) '(expect = 6)
+(fxior 10 12) '(expect = 14)
+(fxxor 10 12) '(expect = 6)
+(fxnot -1) '(expect = 0)
+(fxif 3 1 8) '(expect = 9)
+(fxif 3 8 1) '(expect = 0)
+(fxbit-count 12) '(expect = 2)
+(fxlength 0) '(expect = 0)
+(fxlength 128) '(expect = 8)
+(fxlength 255) '(expect = 8)
+(fxlength 256) '(expect = 9)
+(fxfirst-set-bit 0) '(expect = -1)
+(fxfirst-set-bit 1) '(expect = 0)
+(fxfirst-set-bit 3) '(expect = 0)
+(fxfirst-set-bit 4) '(expect = 2)
+(fxfirst-set-bit 6) '(expect = 1)
+(fxfirst-set-bit -1) '(expect = 0)
+(fxfirst-set-bit -2) '(expect = 1)
+(fxfirst-set-bit -3) '(expect = 0)
+(fxfirst-set-bit -4) '(expect = 2)
+(fxbit-set? 0 1) 'expect-true
+(fxbit-set? 1 1) 'expect-false
+(fxbit-set? 1 8) 'expect-false
+(fxbit-set? fx-width 0) 'expect-error
+(fxbit-set? (- fx-width 1) 0) 'expect-false
+(fxbit-set? (- fx-width 2) 0) 'expect-false
+(fxbit-set? fx-width -1) 'expect-error
+(fxbit-set? (- fx-width 1) -1) 'expect-true
+(fxbit-set? (- fx-width 2) -1) 'expect-true
+(fxbit-set? 10000 -1) 'expect-error
+(fxbit-set? 1000 -1) 'expect-error
+(fxcopy-bit 0 0 #f) '(expect = 0)
+(fxcopy-bit 0 -1 #t) '(expect = -1)
+(fxcopy-bit 0 0 #t) '(expect = 1)
+(fxcopy-bit 8 6 #t) '(expect = #x106)
+(fxcopy-bit 8 6 #f) '(expect = 6)
+(fxcopy-bit 0 -1 #f) '(expect = -2)
+(fxbit-field 6 0 1) '(expect = 0)
+(fxbit-field 6 1 3) '(expect = 3)
+(fxarithmetic-shift 1 1) '(expect = 2)
+(fxarithmetic-shift 1 -1) '(expect = 0)
+(fxbit-field-rotate #b110 1 1 2) '(expect = #b110)
+(fxbit-field-rotate #b110 1 2 4) '(expect = #b1010)
+(fxbit-field-rotate #b0111 -1 1 4) '(expect = #b1011)
+(fxbit-field-rotate #b110 0 0 10) '(expect = #b110)
+(fxbit-field-reverse 6 1 3) '(expect = 6)
+(fxbit-field-reverse 6 1 4) '(expect = 12)
+(fxnot 10) '(expect = -11)
+(fxnot -37) '(expect = 36)
+(fxior 3  10) '(expect = 11)
+(fxand 11 26) '(expect = 10)
+(fxxor 3 10) '(expect = 9)
+(fxand 37 12) '(expect = 4)
+(fxarithmetic-shift 8 2) '(expect = 32)
+(fxarithmetic-shift 4 0) '(expect = 4)
+(fxarithmetic-shift 8 -1) '(expect = 4)
+(fxlength  0) '(expect = 0)
+(fxlength  1) '(expect = 1)
+(fxlength -1) '(expect = 0)
+(fxlength  7) '(expect = 3)
+(fxlength -7) '(expect = 3)
+(fxlength  8) '(expect = 4)
+(fxlength -8) '(expect = 3)
+(fxbit-set? 3 10) 'expect-true
+(fxbit-set? 2 6) 'expect-true
+(fxbit-set? 0 6) 'expect-false
+(fxcopy-bit 2 0 #t) '(expect = #b100)
+(fxcopy-bit 2 #b1111 #f) #b1011
+(fxfirst-set-bit 2) '(expect = 1)
+(fxfirst-set-bit 40) '(expect = 3)
+(fxfirst-set-bit -28) '(expect = 2)
+(fxand #b1 #b1) '(expect = 1)
+(fxand #b1 #b10) '(expect = 0)
+(fxand #b11 #b10) '(expect = #b10)
+(fxand #b101 #b111) '(expect = #b101)
+(fxand -1 #b111) '(expect = #b111)
+(fxand -2 #b111) '(expect = #b110)
+(fxarithmetic-shift 1 0) '(expect = 1)
+(fxarithmetic-shift 1 2) '(expect = 4)
+(fxarithmetic-shift 1 3) '(expect = 8)
+(fxarithmetic-shift 1 4) '(expect = 16)
+(fxarithmetic-shift -1 0) '(expect = -1)
+(fxarithmetic-shift -1 1) '(expect = -2)
+(fxarithmetic-shift -1 2) '(expect = -4)
+(fxarithmetic-shift -1 3) '(expect = -8)
+(fxarithmetic-shift -1 4) '(expect = -16)
+(fxbit-field #b1101101010 0 4) '(expect = #b1010)
+(fxbit-field #b1101101010 3 9) '(expect = #b101101)
+(fxbit-field #b1101101010 4 9) '(expect = #b10110)
+(fxbit-field #b1101101010 4 10) '(expect = #b110110)
+(fxif 1 1 2) '(expect = 3)
+(fxif #b00111100 #b11110000 #b00001111) '(expect = #b00110011)
+(fxcopy-bit 0 0 #t) '(expect = #b1)
-- 
2.25.1