mirror of
https://github.com/justinethier/cyclone.git
synced 2025-05-18 21:29:18 +02:00
205 lines
6.4 KiB
Scheme
205 lines
6.4 KiB
Scheme
#|
|
|
| Copyright (c) 1991, 1993, 2001, 2003, 2005 Aubrey Jaffer
|
|
| Copyright (c) 2017, Koz Ross
|
|
|
|
|
| All rights reserved.
|
|
|
|
|
| Redistribution and use in source and binary forms, with or without
|
|
| modification, are permitted provided that the following conditions are met:
|
|
| * Redistributions of source code must retain the above copyright
|
|
| notice, this list of conditions and the following disclaimer.
|
|
| * Redistributions in binary form must reproduce the above copyright
|
|
| notice, this list of conditions and the following disclaimer in the
|
|
| documentation and/or other materials provided with the distribution.
|
|
| * Neither the name of Cyclone nor the
|
|
| names of its contributors may be used to endorse or promote products
|
|
| derived from this software without specific prior written permission.
|
|
|
|
|
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
|
|
| ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
|
| WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
|
|
| DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY
|
|
| DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
|
|
| (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
|
|
| LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
|
|
| ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
|
| (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
|
|
| SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
|#
|
|
|
|
(define-c raw-logand
|
|
"(void* data, int argc, closure _, object k, object x, object y)"
|
|
"Cyc_check_int(data, x);
|
|
Cyc_check_int(data, y);
|
|
int result = ((int)unbox_number(x)) & ((int)unbox_number(y));
|
|
return_closcall1(data, k, obj_int2obj(result));")
|
|
|
|
(define (logand x . rest)
|
|
(if (null? rest)
|
|
x
|
|
(apply logand (raw-logand x (car rest)) (cdr rest))))
|
|
|
|
(define bitwise-and logand)
|
|
|
|
(define-c raw-logior
|
|
"(void* data, int argc, closure _, object k, object x, object y)"
|
|
"Cyc_check_int(data, x);
|
|
Cyc_check_int(data, y);
|
|
int result = ((int)unbox_number(x)) | ((int)unbox_number(y));
|
|
return_closcall1(data, k, obj_int2obj(result));")
|
|
|
|
(define (logior x . rest)
|
|
(if (null? rest)
|
|
x
|
|
(apply logior (raw-logior x (car rest)) (cdr rest))))
|
|
|
|
(define bitwise-ior logior)
|
|
|
|
(define-c raw-logxor
|
|
"(void* data, int argc, closure _, object k, object x, object y)"
|
|
"Cyc_check_int(data, x);
|
|
Cyc_check_int(data, y);
|
|
int result = ((int)unbox_number(x)) ^ ((int)unbox_number(y));
|
|
return_closcall1(data, k, obj_int2obj(result));")
|
|
|
|
(define (logxor x . rest)
|
|
(if (null? rest)
|
|
x
|
|
(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));
|
|
return_closcall1(data, k, obj_int2obj(result));")
|
|
|
|
(define bitwise-not lognot)
|
|
|
|
(define-c bitwise-if
|
|
"(void* data, int argc, closure _, object k,
|
|
object mask, object n0, object n1)"
|
|
"Cyc_check_int(data, mask);
|
|
Cyc_check_int(data, n0);
|
|
Cyc_check_int(data, n1);
|
|
int m = unbox_number(mask);
|
|
int result = (m & ((int)unbox_number(n0))) | ((~m) & ((int)unbox_number(n1)));
|
|
return_closcall1(data, k, obj_int2obj(result));")
|
|
|
|
(define bitwise-merge bitwise-if)
|
|
|
|
(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)
|
|
(if (zero? n)
|
|
tot
|
|
(logcount-rec (quotient n 16)
|
|
(+ (bytevector-u8-ref lookup (modulo n 16)) tot))))
|
|
(cond
|
|
((negative? n) (logcount-rec (lognot n) 0))
|
|
((positive? n) (logcount-rec n 0))
|
|
(else 0)))
|
|
|
|
(define bit-count logcount)
|
|
|
|
(define-c integer-length
|
|
"(void* data, int argc, closure _, object k, object x)"
|
|
"Cyc_check_int(data, x);
|
|
int input = (int)unbox_number(x);
|
|
int res = 0;
|
|
while (input) {
|
|
res++;
|
|
input >>= 1;
|
|
};
|
|
return_closcall1(data, k, obj_int2obj(res));")
|
|
|
|
(define (log2-binary-factors n)
|
|
(- (integer-length (raw-logand n (- n))) 1))
|
|
|
|
(define first-set-bit log2-binary-factors)
|
|
|
|
(define (logbit? index n)
|
|
(logtest (ash 1 index) n))
|
|
|
|
(define bit-set? logbit?)
|
|
|
|
(define (copy-bit index to bool)
|
|
(if bool
|
|
(logior to (ash 1 index))
|
|
(logand to (lognot (ash 1 index)))))
|
|
|
|
(define (bit-field n start end)
|
|
(logand (lognot (ash -1 (- end start)))
|
|
(ash n (- start))))
|
|
|
|
(define (copy-bit-field to from start end)
|
|
(bitwise-if (ash (lognot (ash -1 (- end start))) start)
|
|
(ash from start)
|
|
to))
|
|
|
|
(define-c ash
|
|
"(void* data, int argc, closure _, object k, object x, object y)"
|
|
"Cyc_check_int(data, x);
|
|
Cyc_check_int(data,y);
|
|
int bf = (int)unbox_number(x);
|
|
int shift = (int)unbox_number(y);
|
|
if (shift > 0) {
|
|
for (int i = 0; i < shift; i++) {
|
|
bf *= 2;
|
|
}
|
|
} else {
|
|
for (int i = 0; i < abs(shift); i++) {
|
|
bf /= 2;
|
|
}
|
|
}
|
|
return_closcall1(data, k, obj_int2obj(bf))")
|
|
|
|
(define arithmetic-shift ash)
|
|
|
|
(define (rotate-bit-field n count start end)
|
|
(define width (- end start))
|
|
(set! count (modulo count width))
|
|
(let ((mask (lognot (ash -1 width))))
|
|
(define zn (logand mask (ash n (- start))))
|
|
(logior (ash
|
|
(logior (logand mask (ash zn count))
|
|
(ash zn (- count width)))
|
|
start)
|
|
(logand (lognot (ash mask start)) n))))
|
|
|
|
(define (bit-reverse k n)
|
|
(do ((m (if (negative? n) (lognot n) n) (ash m -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 (ash n (- start))))
|
|
(logior (ash (bit-reverse width zn) start)
|
|
(logand (lognot (ash mask start)) n))))
|
|
|
|
(define (integer->list k . len)
|
|
(if (null? len)
|
|
(do ((k k (ash k -1))
|
|
(lst '() (cons (odd? k) lst)))
|
|
((<= k 0) lst))
|
|
(do ((idx (- (car len) 1) (- idx 1))
|
|
(k k (ash k -1))
|
|
(lst '() (cons (odd? k) lst)))
|
|
((negative? idx) lst))))
|
|
|
|
(define (list->integer bools)
|
|
(do ((bs bools (cdr bs))
|
|
(acc 0 (+ acc acc (if (car bs) 1 0))))
|
|
((null? bs) acc)))
|
|
|
|
(define (booleans->integer . bools)
|
|
(list->integer bools))
|