All SRFI 60 tests now pass

Makefile

@@ -4,7 +4,7 @@
 
 include Makefile.config
 
-CYCLONE = ../cyclone-bootstrap/cyclone -A . -A ../cyclone-bootstrap
+CYCLONE = cyclone
 TESTSCM = unit-tests srfi-60-tests
 TESTFILES = $(addprefix tests/, $(addsuffix .scm, $(TESTSCM)))
 BOOTSTRAP_DIR = ../cyclone-bootstrap
@@ -174,8 +174,8 @@ examples:
 	cd examples ; make
 
 .PHONY: test
-test: $(TESTFILES) $(CYCLONE) $(COBJECTS)
+test: $(TESTFILES) $(COBJECTS)
-	$(foreach f,$(TESTSCM), echo tests/$(f) ; $(CYCLONE) tests/$(f).scm && tests/$(f) && rm -rf tests/$(f);)
+	$(foreach f,$(TESTSCM), echo tests/$(f) ; $(CYCLONE) -I . tests/$(f).scm && tests/$(f) && rm -rf tests/$(f);)
 
 .PHONY: tags
 tags:
@@ -191,7 +191,7 @@ indent:
 .PHONY: clean
 clean:
 	rm -rf a.out *.o *.so *.a *.out tags cyclone icyc scheme/*.o scheme/*.c scheme/*.meta srfi/*.c srfi/*.meta srfi/*.o scheme/cyclone/*.o scheme/cyclone/*.c scheme/cyclone/*.meta cyclone.c dispatch.c icyc.c generate-c.c generate-c
-	$(foreach f,$(TESTSCM), rm -rf $(f) $(f).c tests/$(f).c;)
+	$(foreach f,$(TESTSCM), rm -rf $(f) $(f).c $(f).o tests/$(f).c tests/$(f).o;)
 	cd examples ; make clean
 
 install-includes:

srfi/60.scm

@@ -28,7 +28,7 @@
 (define (logand x . rest)
   (if (null? rest)
     x
-    (logand (raw-logand x (car rest)) (cdr rest))))
+    (apply logand (raw-logand x (car rest)) (cdr rest))))
 
 (define bitwise-and logand)
 
@@ -42,7 +42,7 @@
 (define (logior x . rest)
   (if (null? rest)
     x
-    (logior (raw-logior x (car rest)) (cdr rest))))
+    (apply logior (raw-logior x (car rest)) (cdr rest))))
 
 (define bitwise-ior logior)
 
@@ -56,12 +56,14 @@
 (define (logxor x . rest)
   (if (null? rest)
     x
-    (logxor (raw-logxor x (car rest)) (cdr rest))))
+    (apply logxor (raw-logxor x (car rest)) (cdr rest))))
+
+(define bitwise-xor logxor)
 
 (define-c lognot
   "(void* data, int argc, closure _, object k, object x)"
   "Cyc_check_int(data, x);
-  int result = ~(((int)unbox_number(x)));
+  int result = ~((int)unbox_number(x));
   return_closcall1(data, k, obj_int2obj(result));")
 
 (define bitwise-not lognot)
@@ -81,6 +83,8 @@
 (define (logtest n1 n2)
   (not (zero? (logand n1 n2))))
 
+(define any-bits-set? logtest)
+
 (define (logcount n)
   (define lookup #u8(0 1 1 2 1 2 2 3 1 2 2 3 2 3 3 4))
   (define (logcount-rec n tot)
@@ -96,7 +100,7 @@
 (define bit-count logcount)
 
 (define (integer-length x)
-  (exact (ceiling (log x 2))))
+  (exact (ceiling (log (+ x 1) 2))))
 
 (define (log2-binary-factors n)
   (- (integer-length (logand n (- n))) 1))
@@ -104,7 +108,7 @@
 (define first-set-bit log2-binary-factors)
 
 (define (logbit? index n)
-  (logtest (expt 2 index) n))
+  (logtest (exact (expt 2 index)) n))
 
 (define bit-set? logbit?)
 
@@ -122,14 +126,8 @@
               (ash from start)
               to))
 
-(define-c ash
+(define (ash x y)
-  "(void* data, int argc, closure _, object k, object n, object count)"
+  (exact (floor (* x (expt 2 y)))))
-  "Cyc_check_int(data, n);
-  Cyc_check_int(data, count);
-  int x = unbox_number(n);
-  int y = unbox_number(count);
-  int result = (y < 0) ? (x >> y) : (x << y);
-  return_closcall1(data, k, obj_int2obj(result));")
 
 (define arithmetic-shift ash)
 
@@ -146,15 +144,15 @@
 
 (define (bit-reverse k n)
   (do ((m (if (negative? n) (lognot n) n) (ash m -1))
-       (k (- k 1) (- k 1))
+       (k (+ -1 k) (+ -1 k))
        (rvs 0 (logior (ash rvs 1) (logand 1 m))))
       ((negative? k) (if (negative? n) (lognot rvs) rvs))))
 
 (define (reverse-bit-field n start end)
   (define width (- end start))
   (let ((mask (lognot (ash -1 width))))
-    (define zn (logand mask (arithmetic-shift n (- start))))
+    (define zn (logand mask (ash n (- start))))
-    (logior (arithmetic-shift (bit-reverse width zn) start)
+    (logior (ash (bit-reverse width zn) start)
             (logand (lognot (ash mask start)) n))))
 
 (define (integer->list k . len)

test.txt

@@ -0,0 +1 @@
+ok

tests/srfi-60-tests.scm

@@ -44,19 +44,15 @@
 
 (test-group
   "lognot"
-  (test "-10000001" (dec->bin (lognot #b10000000)))
+  (test "11111111111111111111111101111111" (dec->bin (lognot #b10000000)))
-  (test "-10000001" (dec->bin (bitwise-not #b10000000)))
+  (test "11111111111111111111111101111111" (dec->bin (bitwise-not #b10000000)))
-  (test "-1" (dec->bin (lognot #b0)))
+  (test "11111111111111111111111111111111" (dec->bin (lognot #b0)))
-  (test "-1" (dec->bin (bitwise-not #b0))))
+  (test "11111111111111111111111111111111" (dec->bin (bitwise-not #b0))))
 
 (test-group
   "logtest"
-  (do
+  (test-not (logtest #b0100 #b1011))
-    ((i 1 (when (= i j) (+ 1 i)))
+  (test-assert (logtest #b0100 #b0111)))
-     (j 0) (if (= i j) 0 (+ 1 j)))
-    ((= i 1024))
-    (test (not (zero? (logand i j))) (logtest i j))
-    (test (not (zero? (logand i j))) (any-bits-set? i j))))
 
 (test-group
   "logcount"
@@ -73,17 +69,16 @@
   (test 0 (integer-length 0))
   (test 4 (integer-length #b1111)))
 
-(define fsb-results #u8(-1 0 1 0 2 0 1 0 3 0 1 0 2 0 1 0 4))
-
 (test-group
   "log2-binary-factors"
   (do
-    ((i 0 (+ i 1)))
+    ((i 0 (+ i 1))
+     (fsb-results #(-1 0 1 0 2 0 1 0 3 0 1 0 2 0 1 0 4)))
     ((= i 17))
-    (let ((res (bytevector-u8-ref fsb-results i)))
+    (let ((res (vector-ref fsb-results i)))
       (test res (log2-binary-factors i))
       (test res (first-set-bit i))
-      (test res (log2-binary (- i)))
+      (test res (log2-binary-factors (- i)))
       (test res (first-set-bit (- i))))))
 
 (test-group 
@@ -91,7 +86,7 @@
   (test-assert (logbit? 0 #b1101))
   (test-assert (bit-set? 0 #b1101))
   (test-not (logbit? 1 #b1101))
-  (test-not (bit-set? 0 #b1101))
+  (test-not (bit-set? 1 #b1101))
   (test-assert (logbit? 2 #b1101))
   (test-assert (bit-set? 2 #b1101))
   (test-assert (logbit? 3 #b1101))
@@ -138,4 +133,6 @@
 
 (test-group
   "reverse-bit-field"
-  (test "e5" (number->string (reverse-bit-field #xa7 0 8) 16)))
+  (test "E5" (number->string (reverse-bit-field #xa7 0 8) 16)))
+
+(test-end)