diff --git a/.gitignore b/.gitignore index 5daa53ca..fafc92d7 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,6 @@ +# Annoying stray test file +test.txt + # Object files *.o *.ko diff --git a/Makefile b/Makefile index e055c388..71530ff6 100644 --- a/Makefile +++ b/Makefile @@ -5,7 +5,7 @@ include Makefile.config CYCLONE = cyclone -TESTSCM = unit-tests +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) - $(foreach f,$(TESTSCM), echo tests/$(f) ; ./cyclone -A . tests/$(f).scm && tests/$(f) && rm -rf tests/$(f);) +test: $(TESTFILES) $(COBJECTS) + $(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: diff --git a/srfi/60.scm b/srfi/60.scm index 8a464286..49713776 100644 --- a/srfi/60.scm +++ b/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 - "(void* data, int argc, closure _, object k, object n, object count)" - "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 (ash x y) + (exact (floor (* x (expt 2 y))))) (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)))) - (logior (arithmetic-shift (bit-reverse width zn) start) + (define zn (logand mask (ash n (- start)))) + (logior (ash (bit-reverse width zn) start) (logand (lognot (ash mask start)) n)))) (define (integer->list k . len) diff --git a/tests/srfi-60-tests.scm b/tests/srfi-60-tests.scm index 04c7b427..9991e8c6 100644 --- a/tests/srfi-60-tests.scm +++ b/tests/srfi-60-tests.scm @@ -44,19 +44,15 @@ (test-group "lognot" - (test "-10000001" (dec->bin (lognot #b10000000))) - (test "-10000001" (dec->bin (bitwise-not #b10000000))) - (test "-1" (dec->bin (lognot #b0))) - (test "-1" (dec->bin (bitwise-not #b0)))) + (test "11111111111111111111111101111111" (dec->bin (lognot #b10000000))) + (test "11111111111111111111111101111111" (dec->bin (bitwise-not #b10000000))) + (test "11111111111111111111111111111111" (dec->bin (lognot #b0))) + (test "11111111111111111111111111111111" (dec->bin (bitwise-not #b0)))) (test-group "logtest" - (do - ((i 1 (when (= i j) (+ 1 i))) - (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-not (logtest #b0100 #b1011)) + (test-assert (logtest #b0100 #b0111))) (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)