Merge pull request #161 from kozross/master

Adding SRFI 60

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))

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)
+)