1;; SRFI-60 implementation for Kawa (almost everything is already built
2;; in, but some of the names differ slightly).
3;; Copyright (C) 2014 by Jamison Hope.  The implementations of
4;; integer->list, list->integer, and booleans->integer were taken with
5;; slight modifications from the reference implementation of SRFI-60,
6;; which is copyright (C) 1991, 1993, 2001, 2003, 2005 Aubrey Jaffer
7;
8;Permission to copy this software, to modify it, to redistribute it,
9;to distribute modified versions, and to use it for any purpose is
10;granted, subject to the following restrictions and understandings.
11;
12;1.  Any copy made of this software must include this copyright notice
13;in full.
14;
15;2.  I have made no warranty or representation that the operation of
16;this software will be error-free, and I am under no obligation to
17;provide any services, by way of maintenance, update, or otherwise.
18;
19;3.  In conjunction with products arising from the use of this
20;material, there shall be no use of my name in any advertising,
21;promotional, or sales literature without prior written consent in
22;each case.
23
24(module-compile-options warn-unknown-member: #t)
25
26(provide 'srfi-60)
27
28;;; These procedures are already Kawa built-ins and do not need to be
29;;; defined here: logand/bitwise-and, logior/bitwise-ior,
30;;; logxor/bitwise-xor, lognot/bitwise-not, bitwise-if, logtest,
31;;; logcount, integer-length, and ash/arithmetic-shift.
32
33(define-alias arithmetic-shift gnu.kawa.functions.BitwiseOp:ashift)
34(define-alias ash gnu.kawa.functions.BitwiseOp:ashift)
35(define-alias bitwise-and gnu.kawa.functions.BitwiseOp:and)
36(define-alias logand gnu.kawa.functions.BitwiseOp:and)
37(define-alias bitwise-ior gnu.kawa.functions.BitwiseOp:ior)
38(define-alias logior gnu.kawa.functions.BitwiseOp:ior)
39(define-alias bitwise-not gnu.kawa.functions.BitwiseOp:not)
40(define-alias lognot gnu.kawa.functions.BitwiseOp:not)
41(define-alias bitwise-xor gnu.kawa.functions.BitwiseOp:xor)
42(define-alias logxor gnu.kawa.functions.BitwiseOp:xor)
43(define-alias integer-length kawa.lib.numbers:bitwise-length)
44(define-alias bitwise-if kawa.lib.numbers:bitwise-if)
45(define-alias logtest kawa.lib.numbers:logtest)
46(define-alias logcount kawa.lib.numbers:logcount)
47
48;;; These procedures alias functionality provided by built-ins with
49;;; differing names:
50
51(define bitwise-merge       bitwise-if)
52(define any-bits-set?       logtest)
53(define bit-count           logcount)
54(define log2-binary-factors bitwise-first-bit-set)
55(define first-set-bit       bitwise-first-bit-set)
56(define bit-field           bitwise-bit-field)
57(define reverse-bit-field   bitwise-reverse-bit-field)
58
59;;; These procedures are similar to built-ins but with arguments
60;;; reordered:
61
62(define (logbit? index::int n::integer) ::boolean
63  (bitwise-bit-set? n index))
64(define bit-set? logbit?)
65
66(define (copy-bit-field to::integer from::integer start::int end::int)
67  ::integer
68  (bitwise-copy-bit-field to start end from))
69
70(define (rotate-bit-field n::integer count::int start::int end::int)
71  ::integer
72  (bitwise-rotate-bit-field n start end count))
73
74;;; This procedure has a slightly different signature compared to the
75;;; built-in bitwise-copy-bit: the first two arguments are swapped and
76;;; the last is a boolean instead of an int
77(define (copy-bit index::int from::integer bit::boolean)
78  ::integer
79  (bitwise-copy-bit from index (if bit 1 0)))
80
81;;; These procedures are entirely new, with implementations derived
82;;; from the SRFI-60 reference.
83(define (integer->list k::integer #!optional (len ::int (integer-length k)))
84  ::list
85  (do ((idx ::int (- len 1) (- idx 1))
86       (k ::integer k (ash k -1))
87       (lst ::list '() (cons (odd? k) lst)))
88      ((< idx 0) lst)))
89
90(define (list->integer bools::list) ::integer
91  (do ((bs bools (cdr bs))
92       (acc ::integer 0 (if (car bs) (+ acc acc 1) (+ acc acc))))
93      ((null? bs) acc)))
94
95(define (booleans->integer . bools)
96  (list->integer bools))
97