diff --git a/srfi/60.scm b/srfi/60.scm new file mode 100644 index 00000000..9c9fe64d --- /dev/null +++ b/srfi/60.scm @@ -0,0 +1,176 @@ +;;; "60.scm", bit access and operations for integers for Scheme +;;; Copyright (C) 1991, 1993, 2001, 2003, 2005 Aubrey Jaffer +;;; Copyright (C) 2017 Koz Ross +; +;Permission to copy this software, to modify it, to redistribute it, +;to distribute modified versions, and to use it for any purpose is +;granted, subject to the following restrictions and understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warranty or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(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 = unbox_number(x) & unbox_number(y); + return_closcall1(data, k, obj_int2obj(result));") + +(define (logand (x . rest)) + (if (null? rest) + x + (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 = unbox_number(x) | unbox_number(y); + return_closcall1(data, k, obj_int2obj(result));") + +(define (logior (x . rest)) + (if (null? rest) + x + (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 = unbox_number(x) ^ unbox_number(y); + return_closcall1(data, k, obj_int2obj(result));") + +(define (logxor (x . rest)) + (if (null? rest) + x + (logxor (raw-logxor x (car rest)) (cdr rest)))) + +(define-c lognot + "(void* data, int argc, closure _, object k, object x)" + "Cyc_check_int(data, x); + int result = ~(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 & unbox_number(n0)) | ((~m) & 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 (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 (integer-length x) + (exact (ceiling (log x 2)))) + +(define (log2-binary-factors n) + (- (integer-length (logand n (- n))) 1)) + +(define first-set-bit log2-binary-factors) + +(define (logbit? index n) + (logtest (expt 2 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 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 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 (- k 1) (- k 1)) + (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) + (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)) diff --git a/srfi/60.sld b/srfi/60.sld new file mode 100644 index 00000000..8ab61128 --- /dev/null +++ b/srfi/60.sld @@ -0,0 +1,27 @@ +;;;; Cyclone Scheme +;;;; https://github.com/justinethier/cyclone +;;;; +;;;; Copyright (c) 2014-2017, Justin Ethier +;;;; Copyright (c) 2017, Koz Ross +;;;; +;;;; This module is an interface to the Integers as Bits library. +;;;; +;;;; NOTE: This does not support arbitrary-precision numbers, as Cyclone +;;;; doesn't have them yet. This will need to be modified accordingly once +;;;; this support is provided. +(define-library (srfi 60) + (import (scheme base) + (scheme inexact)) + (export + any-bits-set? arithmetic-shift ash + bit-count bit-field bit-set? bitwise-and bitwise-if bitwise-ior + bitwise-merge bitwise-not bitwise-xor booleans->integer + copy-bit copy-bit-field + first-set-bit + integer-length integer->list + list->integer log2-binary-factors logbit? logand logcount logior lognot + logtest logxor + reverse-bit-field rotate-bit-field) + (include "60.scm") + (begin) +)