Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-18 21:29:19 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

adding (srfi 142), using that in place of (srfi 33)

Browse source
This commit is contained in:
Alex Shinn 2017-04-16 22:06:56 +09:00
parent 8feb1e761e
commit eb79e98d20
35 changed files with 373 additions and 105 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
Makefile
View file

@ -34,7 +34,7 @@ EXTRA_COMPILED_LIBS ?=
COMPILED_LIBS = $(CHIBI_COMPILED_LIBS) $(CHIBI_IO_COMPILED_LIBS) \
$(CHIBI_OPT_COMPILED_LIBS) $(CHIBI_CRYPTO_COMPILED_LIBS) \
$(EXTRA_COMPILED_LIBS) \
lib/srfi/18/threads$(SO) lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) \
lib/srfi/18/threads$(SO) lib/srfi/27/rand$(SO) lib/srfi/142/bit$(SO) \
lib/srfi/39/param$(SO) lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) \
lib/srfi/98/env$(SO) lib/scheme/time$(SO)
@ -281,7 +281,7 @@ install-base: all
$(MKDIR) $(DESTDIR)$(MODDIR)/chibi/char-set $(DESTDIR)$(MODDIR)/chibi/crypto $(DESTDIR)$(MODDIR)/chibi/io $(DESTDIR)$(MODDIR)/chibi/iset $(DESTDIR)$(MODDIR)/chibi/loop $(DESTDIR)$(MODDIR)/chibi/match $(DESTDIR)$(MODDIR)/chibi/math $(DESTDIR)$(MODDIR)/chibi/monad $(DESTDIR)$(MODDIR)/chibi/net $(DESTDIR)$(MODDIR)/chibi/optimize $(DESTDIR)$(MODDIR)/chibi/parse $(DESTDIR)$(MODDIR)/chibi/regexp $(DESTDIR)$(MODDIR)/chibi/show $(DESTDIR)$(MODDIR)/chibi/snow $(DESTDIR)$(MODDIR)/chibi/term
$(MKDIR) $(DESTDIR)$(MODDIR)/scheme/char
$(MKDIR) $(DESTDIR)$(MODDIR)/scheme/time
$(MKDIR) $(DESTDIR)$(MODDIR)/srfi/1 $(DESTDIR)$(MODDIR)/srfi/18 $(DESTDIR)$(MODDIR)/srfi/27 $(DESTDIR)$(MODDIR)/srfi/33 $(DESTDIR)$(MODDIR)/srfi/39 $(DESTDIR)$(MODDIR)/srfi/69 $(DESTDIR)$(MODDIR)/srfi/95 $(DESTDIR)$(MODDIR)/srfi/99 $(DESTDIR)$(MODDIR)/srfi/99/records
$(MKDIR) $(DESTDIR)$(MODDIR)/srfi/1 $(DESTDIR)$(MODDIR)/srfi/18 $(DESTDIR)$(MODDIR)/srfi/27 $(DESTDIR)$(MODDIR)/srfi/142 $(DESTDIR)$(MODDIR)/srfi/39 $(DESTDIR)$(MODDIR)/srfi/69 $(DESTDIR)$(MODDIR)/srfi/95 $(DESTDIR)$(MODDIR)/srfi/99 $(DESTDIR)$(MODDIR)/srfi/99/records
$(INSTALL) -m0644 $(META_FILES) $(DESTDIR)$(MODDIR)/
$(INSTALL) -m0644 lib/*.scm $(DESTDIR)$(MODDIR)/
$(INSTALL) -m0644 lib/chibi/*.sld lib/chibi/*.scm $(DESTDIR)$(MODDIR)/chibi/
@ -307,17 +307,17 @@ install-base: all
$(INSTALL) -m0644 lib/srfi/1/*.scm $(DESTDIR)$(MODDIR)/srfi/1/
$(INSTALL) -m0644 lib/srfi/18/*.scm $(DESTDIR)$(MODDIR)/srfi/18/
$(INSTALL) -m0644 lib/srfi/27/*.scm $(DESTDIR)$(MODDIR)/srfi/27/
$(INSTALL) -m0644 lib/srfi/33/*.scm $(DESTDIR)$(MODDIR)/srfi/33/
$(INSTALL) -m0644 lib/srfi/39/*.scm $(DESTDIR)$(MODDIR)/srfi/39/
$(INSTALL) -m0644 lib/srfi/69/*.scm $(DESTDIR)$(MODDIR)/srfi/69/
$(INSTALL) -m0644 lib/srfi/95/*.scm $(DESTDIR)$(MODDIR)/srfi/95/
$(INSTALL) -m0644 lib/srfi/99/*.sld $(DESTDIR)$(MODDIR)/srfi/99/
$(INSTALL) -m0644 lib/srfi/99/records/*.sld lib/srfi/99/records/*.scm $(DESTDIR)$(MODDIR)/srfi/99/records/
$(INSTALL) -m0644 lib/srfi/142/*.scm $(DESTDIR)$(MODDIR)/srfi/142/
$(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/crypto/
$(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/io/
$(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/optimize/
$(MKDIR) $(DESTDIR)$(BINMODDIR)/scheme/
$(MKDIR) $(DESTDIR)$(BINMODDIR)/srfi/18 $(DESTDIR)$(BINMODDIR)/srfi/27 $(DESTDIR)$(BINMODDIR)/srfi/33 $(DESTDIR)$(BINMODDIR)/srfi/39 $(DESTDIR)$(BINMODDIR)/srfi/69 $(DESTDIR)$(BINMODDIR)/srfi/95 $(DESTDIR)$(BINMODDIR)/srfi/98
$(MKDIR) $(DESTDIR)$(BINMODDIR)/srfi/18 $(DESTDIR)$(BINMODDIR)/srfi/27 $(DESTDIR)$(BINMODDIR)/srfi/142 $(DESTDIR)$(BINMODDIR)/srfi/39 $(DESTDIR)$(BINMODDIR)/srfi/69 $(DESTDIR)$(BINMODDIR)/srfi/95 $(DESTDIR)$(BINMODDIR)/srfi/98
$(INSTALL_EXE) -m0755 $(CHIBI_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/
$(INSTALL_EXE) -m0755 $(CHIBI_CRYPTO_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/crypto/
$(INSTALL_EXE) -m0755 $(CHIBI_IO_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/io/
@ -325,11 +325,11 @@ install-base: all
$(INSTALL_EXE) -m0755 lib/scheme/time$(SO) $(DESTDIR)$(BINMODDIR)/scheme/
$(INSTALL_EXE) -m0755 lib/srfi/18/threads$(SO) $(DESTDIR)$(BINMODDIR)/srfi/18
$(INSTALL_EXE) -m0755 lib/srfi/27/rand$(SO) $(DESTDIR)$(BINMODDIR)/srfi/27
$(INSTALL_EXE) -m0755 lib/srfi/33/bit$(SO) $(DESTDIR)$(BINMODDIR)/srfi/33
$(INSTALL_EXE) -m0755 lib/srfi/39/param$(SO) $(DESTDIR)$(BINMODDIR)/srfi/39
$(INSTALL_EXE) -m0755 lib/srfi/69/hash$(SO) $(DESTDIR)$(BINMODDIR)/srfi/69
$(INSTALL_EXE) -m0755 lib/srfi/95/qsort$(SO) $(DESTDIR)$(BINMODDIR)/srfi/95
$(INSTALL_EXE) -m0755 lib/srfi/98/env$(SO) $(DESTDIR)$(BINMODDIR)/srfi/98
$(INSTALL_EXE) -m0755 lib/srfi/142/bit$(SO) $(DESTDIR)$(BINMODDIR)/srfi/142
$(MKDIR) $(DESTDIR)$(INCDIR)
$(INSTALL) -m0644 $(INCLUDES) $(DESTDIR)$(INCDIR)/
$(MKDIR) $(DESTDIR)$(LIBDIR)
@ -396,13 +396,13 @@ uninstall:
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/1 $(DESTDIR)$(BINMODDIR)/srfi/1
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/18 $(DESTDIR)$(BINMODDIR)/srfi/18
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/27 $(DESTDIR)$(BINMODDIR)/srfi/27
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/33 $(DESTDIR)$(BINMODDIR)/srfi/33
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/39 $(DESTDIR)$(BINMODDIR)/srfi/39
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/69 $(DESTDIR)$(BINMODDIR)/srfi/69
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/95 $(DESTDIR)$(BINMODDIR)/srfi/95
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/98 $(DESTDIR)$(BINMODDIR)/srfi/98
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/99/records $(DESTDIR)$(BINMODDIR)/srfi/99/records
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/99 $(DESTDIR)$(BINMODDIR)/srfi/99
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/142 $(DESTDIR)$(BINMODDIR)/srfi/142
-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi $(DESTDIR)$(BINMODDIR)/srfi
-$(RMDIR) $(DESTDIR)$(MODDIR) $(DESTDIR)$(BINMODDIR)
-$(RM) $(DESTDIR)$(MANDIR)/chibi-scheme.1 $(DESTDIR)$(MANDIR)/chibi-ffi.1 $(DESTDIR)$(MANDIR)/chibi-doc.1

24
lib/chibi/base64.scm
View file

@ -141,18 +141,18 @@
dst
j
(bitwise-ior (arithmetic-shift b1 2)
(extract-bit-field 2 4 b2)))
(bit-field b2 4 6)))
(bytevector-u8-set!
dst
(+ j 1)
(bitwise-ior
(arithmetic-shift (extract-bit-field 4 0 b2) 4)
(extract-bit-field 4 2 b3)))
(arithmetic-shift (bit-field b2 0 4) 4)
(bit-field b3 2 6)))
(bytevector-u8-set!
dst
(+ j 2)
(bitwise-ior
(arithmetic-shift (extract-bit-field 2 0 b3) 6)
(arithmetic-shift (bit-field b3 0 2) 6)
c))
(lp (+ i 1) (+ j 3)
*outside-char* *outside-char* *outside-char*)))))))
@ -172,7 +172,7 @@
(bytevector-u8-set! dst
j
(bitwise-ior (arithmetic-shift b1 2)
(extract-bit-field 2 4 b2)))
(bit-field b2 4 6)))
(cond
((eqv? b3 *outside-char*)
(+ j 1))
@ -180,8 +180,8 @@
(bytevector-u8-set! dst
(+ j 1)
(bitwise-ior
(arithmetic-shift (extract-bit-field 4 0 b2) 4)
(extract-bit-field 4 2 b3)))
(arithmetic-shift (bit-field b2 0 4) 4)
(bit-field b3 2 6)))
(+ j 2))))))
;;> Variation of the above to read and write to ports.
@ -282,11 +282,11 @@
(+ j 1)
(enc (bitwise-ior
(arithmetic-shift (bitwise-and #b11 b1) 4)
(extract-bit-field 4 4 b2))))
(bit-field b2 4 8))))
(bytevector-u8-set!
res
(+ j 2)
(enc (arithmetic-shift (extract-bit-field 4 0 b2) 2)))
(enc (arithmetic-shift (bit-field b2 0 4) 2)))
(bytevector-u8-set! res (+ j 3) (char->integer #\=))
(+ j 4)))
(else
@ -300,13 +300,13 @@
(+ j 1)
(enc (bitwise-ior
(arithmetic-shift (bitwise-and #b11 b1) 4)
(extract-bit-field 4 4 b2))))
(bit-field b2 4 8))))
(bytevector-u8-set!
res
(+ j 2)
(enc (bitwise-ior
(arithmetic-shift (extract-bit-field 4 0 b2) 2)
(extract-bit-field 2 6 b3))))
(arithmetic-shift (bit-field b2 0 4) 2)
(bit-field b3 6 8))))
(bytevector-u8-set! res (+ j 3) (enc (bitwise-and #b111111 b3)))
(lp (+ i 3) (+ j 4)))))))

12
lib/chibi/base64.sld
View file

@ -6,14 +6,20 @@
(import (scheme base)
(chibi string))
(cond-expand
((library (srfi 142))
(import (srfi 142)))
((library (srfi 33))
(import (srfi 33)))
(import (srfi 33))
(begin
(define (%mask size) (bitwise-not (arithmetic-shift -1 size)))
(define (bit-field n start end)
(bitwise-and (arithmetic-shift n (- start)) (mask (- end start))))))
(else
(import (srfi 60))
(begin
(define (%mask size) (bitwise-not (arithmetic-shift -1 size)))
(define (extract-bit-field size position n)
(bitwise-and (%mask size) (arithmetic-shift n (- position)))))))
(define (bit-field n start end)
(bitwise-and (arithmetic-shift n (- start)) (mask (- end start)))))))
(cond-expand
(chibi (import (chibi io)))
(else

1
lib/chibi/binary-record.sld
View file

@ -2,6 +2,7 @@
(define-library (chibi binary-record)
(import (scheme base) (srfi 1))
(cond-expand
((library (srfi 142)) (import (srfi 142)))
((library (srfi 33)) (import (srfi 33)))
(else (import (srfi 60))))
(cond-expand

1
lib/chibi/bytevector.sld
View file

@ -11,6 +11,7 @@
bytevector->hex-string hex-string->bytevector)
(import (scheme base))
(cond-expand
((library (srfi 142)) (import (srfi 142)))
((library (srfi 33)) (import (srfi 33)))
(else (import (srfi 60))))
(include "bytevector.scm"))

1
lib/chibi/crypto/md5.sld
View file

@ -5,6 +5,7 @@
(define-library (chibi crypto md5)
(import (scheme base) (chibi bytevector))
(cond-expand
((library (srfi 142)) (import (srfi 142)))
((library (srfi 33)) (import (srfi 33)))
(else (import (srfi 60))))
(export md5)

1
lib/chibi/crypto/rsa.sld
View file

@ -5,6 +5,7 @@
(import (scheme base) (srfi 27)
(chibi bytevector) (chibi math prime))
(cond-expand
((library (srfi 142)) (import (srfi 142)))
((library (srfi 33)) (import (srfi 33)))
(else (import (srfi 60))))
(export make-rsa-key rsa-key-gen rsa-key-gen-from-primes rsa-pub-key

1
lib/chibi/crypto/sha2.sld
View file

@ -11,6 +11,7 @@
(include-shared "crypto"))
(else
(cond-expand
((library (srfi 142)) (import (srfi 142)))
((library (srfi 33)) (import (srfi 33)))
(else (import (srfi 60))))
(import (chibi bytevector))

1
lib/chibi/filesystem-test.sld
View file

@ -3,6 +3,7 @@
(import (scheme base) (scheme file) (scheme write)
(chibi filesystem) (chibi test))
(cond-expand
((library (srfi 142)) (import (srfi 142)))
((library (srfi 33)) (import (srfi 33)))
(else (import (srfi 60))))
(begin

1
lib/chibi/iset/base.sld
View file

@ -4,6 +4,7 @@
(chibi (import (chibi) (srfi 9)))
(else (import (scheme base))))
(cond-expand
((library (srfi 142)) (import (srfi 142)))
((library (srfi 33)) (import (srfi 33)))
(else (import (srfi 60))))
(include "base.scm")

1
lib/chibi/iset/constructors.sld
View file

@ -5,6 +5,7 @@
(else (import (scheme base))))
(import (chibi iset base) (chibi iset iterators))
(cond-expand
((library (srfi 142)) (import (srfi 142)))
((library (srfi 33)) (import (srfi 33)))
(else (import (srfi 60))))
(include "constructors.scm")

1
lib/chibi/iset/iterators.sld
View file

@ -5,6 +5,7 @@
(else (import (scheme base))))
(import (chibi iset base))
(cond-expand
((library (srfi 142)) (import (srfi 142)))
((library (srfi 33)) (import (srfi 33)))
(else (import (srfi 60))))
(include "iterators.scm")

2
lib/chibi/iset/optimize.scm
View file

@ -81,7 +81,7 @@
(%make-iset
(+ start last)
(+ start lo -1)
(extract-bit-field (- lo last) last bits)
(bit-field bits last lo)
#f
#f))
nodes)

1
lib/chibi/iset/optimize.sld
View file

@ -7,6 +7,7 @@
(chibi iset iterators)
(chibi iset constructors))
(cond-expand
((library (srfi 142)) (import (srfi 142)))
((library (srfi 33)) (import (srfi 33)))
(else
(import (srfi 60))

1
lib/chibi/math/prime.sld
View file

@ -2,6 +2,7 @@
(define-library (chibi math prime)
(import (scheme base) (scheme inexact) (srfi 27))
(cond-expand
((library (srfi 142)) (import (srfi 142)))
((library (srfi 33)) (import (srfi 33)))
(else (import (srfi 60))))
(export prime? nth-prime prime-above prime-below factor perfect?

1
lib/chibi/net.sld
View file

@ -23,6 +23,7 @@
sockaddr addrinfo)
(import (chibi) (chibi filesystem))
(cond-expand
((library (srfi 142)) (import (srfi 142)))
((library (srfi 33)) (import (srfi 33)))
(else (import (srfi 60))))
(include-shared "net")

2
lib/chibi/net/server-util.sld
View file

@ -3,7 +3,7 @@
(import (chibi) (chibi io) (chibi net) (chibi string) (chibi uri)
(chibi process) (chibi time) (chibi pathname) (chibi filesystem)
(chibi temp-file)
(srfi 33) (srfi 69))
(srfi 69) (srfi 142))
(export line-handler command-handler parse-command
get-host file-mime-type)
(include "server-util.scm"))

2
lib/chibi/process.sld
View file

@ -18,6 +18,6 @@
process->string process->sexp process->string-list
process->output+error process->output+error+status)
(import (chibi) (chibi io) (chibi string) (chibi filesystem))
(cond-expand (threads (import (srfi 18) (srfi 33))) (else #f))
(cond-expand (threads (import (srfi 18) (srfi 142))) (else #f))
(include-shared "process")
(include "process.scm"))

1
lib/chibi/quoted-printable.sld
View file

@ -7,6 +7,7 @@
quoted-printable-decode-bytevector)
(import (scheme base))
(cond-expand
((library (srfi 142)) (import (srfi 142)))
((library (srfi 33)) (import (srfi 33)))
(else (import (srfi 60))))
(cond-expand

1
lib/chibi/regexp.sld
View file

@ -57,6 +57,7 @@
(define %char-set:iso-control
(char-set-intersection char-set:ascii char-set:iso-control)))))
(cond-expand
((library (srfi 142)) (import (srfi 142)))
((library (srfi 33)) (import (srfi 33)))
(else (import (srfi 60))))
(import (chibi char-set boundary))

1
lib/chibi/regexp/pcre.sld
View file

@ -5,6 +5,7 @@
(srfi 1)
(chibi string) (chibi regexp))
(cond-expand
((library (srfi 142)) (import (srfi 142)))
((library (srfi 33)) (import (srfi 33)))
(else (import (srfi 60))))
(include "pcre.scm"))

1
lib/chibi/snow/commands.sld
View file

@ -56,6 +56,7 @@
(chibi uri)
(chibi zlib))
(cond-expand
((library (srfi 142)) (import (srfi 142)))
((library (srfi 33)) (import (srfi 33)))
(else (import (srfi 60))))
(include "commands.scm"))

7
lib/chibi/snow/fort.sld
View file

@ -29,10 +29,9 @@
(chibi sxml)
(chibi tar))
(cond-expand
((library (srfi 33))
(import (srfi 33)))
(else
(import (srfi 60))))
((library (srfi 142)) (import (srfi 142)))
((library (srfi 33)) (import (srfi 33)))
(else (import (srfi 60))))
(cond-expand
(chibi
(import (only (chibi ast)

2
lib/chibi/stty.sld
View file

@ -3,6 +3,6 @@
(export stty with-stty with-raw-io
get-terminal-width get-terminal-dimensions
TCSANOW TCSADRAIN TCSAFLUSH)
(import (chibi) (srfi 33) (srfi 69))
(import (chibi) (srfi 69) (srfi 142))
(include-shared "stty")
(include "stty.scm"))

7
lib/chibi/tar.sld
View file

@ -4,10 +4,9 @@
(chibi string) (chibi binary-record) (chibi pathname)
(chibi filesystem))
(cond-expand
((library (srfi 33))
(import (srfi 33)))
(else
(import (srfi 60))))
((library (srfi 142)) (import (srfi 142)))
((library (srfi 33)) (import (srfi 33)))
(else (import (srfi 60))))
(cond-expand
(chibi
(import (chibi system)))

1
lib/chibi/temp-file.sld
View file

@ -3,6 +3,7 @@
(import (scheme base) (scheme time)
(chibi filesystem) (chibi pathname))
(cond-expand
((library (srfi 142)) (import (srfi 142)))
((library (srfi 33)) (import (srfi 33)))
(else (import (srfi 60))))
(cond-expand

7
lib/chibi/term/edit-line.sld
View file

@ -9,10 +9,9 @@
make-keymap make-standard-keymap)
(import (scheme base) (scheme char) (scheme write))
(cond-expand
((library (srfi 33))
(import (srfi 33)))
(else
(import (srfi 60))))
((library (srfi 142)) (import (srfi 142)))
((library (srfi 33)) (import (srfi 33)))
(else (import (srfi 60))))
(cond-expand
(chibi
(import (chibi stty)))

2
lib/srfi/128.sld
View file

@ -1,6 +1,6 @@
(define-library (srfi 128)
(import (scheme base) (scheme char)
(srfi 27) (srfi 33) (srfi 69) (srfi 95) (srfi 98)
(srfi 27) (srfi 69) (srfi 95) (srfi 98) (srfi 142)
(only (chibi) fixnum? er-macro-transformer))
(export
;; Predicates:

24
lib/srfi/142.sld Normal file
View file

@ -0,0 +1,24 @@
(define-library (srfi 142)
(export bitwise-not
bitwise-and bitwise-ior
bitwise-xor bitwise-eqv
bitwise-nand bitwise-nor
bitwise-andc1 bitwise-andc2
bitwise-orc1 bitwise-orc2
arithmetic-shift bit-count integer-length
bitwise-if
bit-set? any-bit-set? every-bit-set?
first-set-bit
bit-field bit-field-any? bit-field-every?
bit-field-clear bit-field-set
bit-field-replace bit-field-replace-same
bit-field-rotate bit-field-reverse
copy-bit integer->list list->integer
integer->vector vector->integer
bits bit-swap
bitwise-fold bitwise-for-each bitwise-unfold
make-bitwise-generator)
(import (chibi))
(include-shared "142/bit")
(include "142/bitwise.scm"))

2
lib/srfi/33/bit.c → lib/srfi/142/bit.c
View file

@ -1,5 +1,5 @@
/* bit.c -- bitwise operators */
/* Copyright (c) 2009-2012 Alex Shinn. All rights reserved. */
/* Copyright (c) 2009-2017 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */
#include <chibi/eval.h>

155
lib/srfi/142/bitwise.scm Normal file
View file

@ -0,0 +1,155 @@
;; bitwise.scm -- high-level bitwise functions
;; Copyright (c) 2009-2017 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
(define (bitwise-not i) (- -1 i))
(define (bitwise-complement f) (lambda args (bitwise-not (apply f args))))
(define (make-nary proc2 default)
(lambda args
(if (null? args)
default
(let lp ((i (car args)) (ls (cdr args)))
(if (null? ls)
i
(lp (proc2 i (car ls)) (cdr ls)))))))
(define bitwise-and (make-nary bit-and -1))
(define bitwise-ior (make-nary bit-ior 0))
(define bitwise-xor (make-nary bit-xor 0))
(define bitwise-eqv (bitwise-complement (make-nary bit-xor -1)))
(define bitwise-nand (bitwise-complement (make-nary bit-and 0)))
(define bitwise-nor (bitwise-complement (make-nary bit-ior -1)))
(define (bitwise-andc1 i j) (bit-and (bitwise-not i) j))
(define (bitwise-andc2 i j) (bit-and i (bitwise-not j)))
(define (bitwise-orc1 i j) (bit-ior (bitwise-not i) j))
(define (bitwise-orc2 i j) (bit-ior i (bitwise-not j)))
(define (any-bit-set? test-bits i)
(not (zero? (bitwise-and test-bits i))))
(define (every-bit-set? test-bits i)
(= test-bits (bitwise-and test-bits i)))
(define (first-set-bit i)
(if (zero? i)
-1
(integer-length (- i (bit-and i (- i 1))))))
(define (mask len)
(- (arithmetic-shift 1 len) 1))
(define (range start end)
(arithmetic-shift (mask (- end start)) start))
(define (bitwise-if mask n m)
(bit-ior (bit-and mask n) (bit-and (bitwise-not mask) m)))
(define (bit-field n start end)
(bit-and (arithmetic-shift n (- start)) (mask (- end start))))
(define (bit-field-any? n start end)
(not (zero? (bit-and (arithmetic-shift n (- start)) (mask (- end start))))))
(define (bit-field-every? n start end)
(= (arithmetic-shift n (- start)) (mask (- end start))))
(define (copy-bit index i boolean)
(bit-field-replace i (if boolean 1 0) index (+ index 1)))
(define (bit-swap i1 i2 i)
(let ((b1 (bit-set? i1 i))
(b2 (bit-set? i2 i)))
(copy-bit i2 (copy-bit i1 i b2) b1)))
(define (bit-field-clear n start end)
(bit-field-replace n 0 start end))
(define (bit-field-set n start end)
(bit-ior n (range start end)))
(define (bit-field-replace dst src start end)
(bit-field-replace-same dst (arithmetic-shift src start) start end))
(define (bit-field-replace-same dst src start end)
(bitwise-if (range start end) src dst))
(define (bit-rotate i count)
(let ((len (integer-length i)))
(bit-ior (bit-and (arithmetic-shift i count) (mask len))
(arithmetic-shift i (- count len)))))
(define (bit-field-rotate i count start end)
(bitwise-if (range start end)
i
(arithmetic-shift (bit-rotate (bit-field i start end) count)
start)))
(define (bit-reverse i)
(let ((len (integer-length i)))
(let lp ((i i) (res 0))
(if (zero? i)
res
(lp (arithmetic-shift i -1)
(bit-ior (arithmetic-shift res 1)
(bit-and i 1)))))))
(define (bit-field-reverse i start end)
(bitwise-if (range start end)
i
(arithmetic-shift (bit-reverse (bit-field i start end)) start)))
(define (vector->integer vec)
(let ((len (vector-length vec)))
(let lp ((i 0) (exp 1) (res 0))
(cond
((= i len) res)
((vector-ref vec i) (lp (+ i 1) (* exp 2) (+ res exp)))
(else (lp (+ i 1) (* exp 2) res))))))
(define (integer->vector n . o)
(let* ((len (if (pair? o) (car o) (integer-length n)))
(res (make-vector len #f)))
(let lp ((n n) (i 0))
(cond
((>= i len)
res)
(else
(if (odd? n)
(vector-set! res i #t))
(lp (arithmetic-shift n -1) (+ i 1)))))))
(define (list->integer ls)
(vector->integer (list->vector ls)))
(define (integer->list n . o)
(vector->list (apply integer->vector n o)))
(define (bits . o) (list->integer o))
(define (bitwise-fold kons knil i)
(let lp ((i i) (acc knil))
(if (zero? i)
acc
(lp (arithmetic-shift i -1) (kons (odd? i) acc)))))
(define (bitwise-for-each proc i)
(bitwise-fold (lambda (b acc) (proc b)) #f i))
(define (bitwise-unfold stop? mapper successor seed)
(let lp ((state seed) (exp 1) (i 0))
(if (stop? state)
i
(lp (successor state)
(* exp 2)
(if (mapper state) (+ i exp) i)))))
(define make-bitwise-generator
(let ((eof (read-char (open-input-string ""))))
(lambda (i)
(lambda ()
(let ((res (odd? i)))
(set! i (arithmetic-shift i -1))
res)))))

112
lib/srfi/142/test.sld Normal file
View file

@ -0,0 +1,112 @@
(define-library (srfi 142 test)
(export run-tests)
(import (scheme base) (srfi 142) (chibi test))
(begin
(define (run-tests)
(test-begin "srfi-142: bitwise operations")
(test 0 (bitwise-and #b0 #b1))
(test 1 (bitwise-and #b1 #b1))
(test 0 (bitwise-and #b1 #b10))
(test #b10 (bitwise-and #b11 #b10))
(test #b101 (bitwise-and #b101 #b111))
(test #b111 (bitwise-and -1 #b111))
(test #b110 (bitwise-and -2 #b111))
(test 3769478 (bitwise-and -4290775858 1694076839))
(test 1680869008 (bitwise-and -193073517 1689392892))
(test -4294967295 (bitwise-ior 1 (- -1 #xffffffff)))
(test -18446744073709551615 (bitwise-ior 1 (- -1 #xffffffffffffffff)))
(test -4294967126 (bitwise-xor #b10101010 (- -1 #xffffffff)))
(test -18446744073709551446 (bitwise-xor #b10101010 (- -1 #xffffffffffffffff)))
(test -2600468497 (bitwise-ior 1694076839 -4290775858))
(test -184549633 (bitwise-ior -193073517 1689392892))
(test -2604237975 (bitwise-xor 1694076839 -4290775858))
(test -1865418641 (bitwise-xor -193073517 1689392892))
(test 3769478 (bitwise-and 1694076839 -4290775858))
(test 1680869008 (bitwise-and -193073517 1689392892))
(test 1 (arithmetic-shift 1 0))
(test 2 (arithmetic-shift 1 1))
(test 4 (arithmetic-shift 1 2))
(test 8 (arithmetic-shift 1 3))
(test 16 (arithmetic-shift 1 4))
(test (expt 2 31) (arithmetic-shift 1 31))
(test (expt 2 32) (arithmetic-shift 1 32))
(test (expt 2 33) (arithmetic-shift 1 33))
(test (expt 2 63) (arithmetic-shift 1 63))
(test (expt 2 64) (arithmetic-shift 1 64))
(test (expt 2 65) (arithmetic-shift 1 65))
(test (expt 2 127) (arithmetic-shift 1 127))
(test (expt 2 128) (arithmetic-shift 1 128))
(test (expt 2 129) (arithmetic-shift 1 129))
(test 3028397001194014464 (arithmetic-shift 11829675785914119 8))
(test -1 (arithmetic-shift -1 0))
(test -2 (arithmetic-shift -1 1))
(test -4 (arithmetic-shift -1 2))
(test -8 (arithmetic-shift -1 3))
(test -16 (arithmetic-shift -1 4))
(test (- (expt 2 31)) (arithmetic-shift -1 31))
(test (- (expt 2 32)) (arithmetic-shift -1 32))
(test (- (expt 2 33)) (arithmetic-shift -1 33))
(test (- (expt 2 63)) (arithmetic-shift -1 63))
(test (- (expt 2 64)) (arithmetic-shift -1 64))
(test (- (expt 2 65)) (arithmetic-shift -1 65))
(test (- (expt 2 127)) (arithmetic-shift -1 127))
(test (- (expt 2 128)) (arithmetic-shift -1 128))
(test (- (expt 2 129)) (arithmetic-shift -1 129))
(test 0 (arithmetic-shift 1 -63))
(test 0 (arithmetic-shift 1 -64))
(test 0 (arithmetic-shift 1 -65))
(test #x1000000000000000100000000000000000000000000000000
(arithmetic-shift #x100000000000000010000000000000000 64))
(test #x8e73b0f7da0e6452c810f32b809079e5
(arithmetic-shift #x8e73b0f7da0e6452c810f32b809079e562f8ead2522c6b7b -64))
(test-not (bit-set? 64 1))
(test-assert (bit-set? 64 #x10000000000000000))
(test #b1010 (bit-field #b1101101010 0 4))
(test #b101101 (bit-field #b1101101010 3 9))
(test #b10110 (bit-field #b1101101010 4 9))
(test #b110110 (bit-field #b1101101010 4 10))
(test 3 (bitwise-if 1 1 2))
(test #b00110011 (bitwise-if #b00111100 #b11110000 #b00001111))
(test #b1 (copy-bit 0 0 #t))
(test #b100 (copy-bit 2 0 #t))
(test #b1011 (copy-bit 2 #b1111 #f))
(test #b1110 (bit-swap 0 1 #b1101))
(test #b1011 (bit-swap 1 2 #b1101))
(test #b1011 (bit-swap 2 1 #b1101))
(test #b10000000101 (bit-swap 3 10 #b1101))
(test '(#t #t #t #f #t #f #t) (integer->list #b1010111))
(test '(#t #t #t #f #t) (integer->list #b1010111 5))
(test '(#t #t #t #f #t #f #t #f #f) (integer->list #b1010111 9))
(test '#(#t #t #t #f #t #f #t) (integer->vector #b1010111))
(test '#(#t #t #t #f #t #f #t #f #f) (integer->vector #b1010111 9))
(test #b1010111 (list->integer '(#t #t #t #f #t #f #t)))
(test #b1010111 (list->integer '(#t #t #t #f #t #f #t #f #f)))
(test #b1010111 (vector->integer '#(#t #t #t #f #t #f #t)))
(test #b1010111 (vector->integer '#(#t #t #t #f #t #f #t #f #f)))
(test #b1010111 (bits #t #t #t #f #t #f #t))
(test #b1010111 (bits #t #t #t #f #t #f #t #f #f))
(test '(#t #f #t #f #t #t #t) (bitwise-fold cons '() #b1010111))
(test 5
(let ((count 0))
(bitwise-for-each (lambda (b) (if b (set! count (+ count 1))))
#b1010111)
count))
(test #b101010101
(bitwise-unfold (lambda (i) (= i 10)) even? (lambda (i) (+ i 1)) 0))
(test-end))))

23
lib/srfi/33.sld
View file

@ -11,7 +11,22 @@
bit-set? any-bits-set? all-bits-set?
first-set-bit
extract-bit-field test-bit-field? clear-bit-field
replace-bit-field copy-bit-field)
(import (chibi))
(include-shared "33/bit")
(include "33/bitwise.scm"))
replace-bit-field copy-bit-field)
(import (scheme base)
(rename (srfi 142)
(bitwise-if bitwise-merge)
(any-bit-set? any-bits-set?)
(every-bit-set? all-bits-set?)
(bit-field-any? test-bit-field?)
(bit-field-clear clear-bit-field)))
(begin
(define (mask len)
(- (arithmetic-shift 1 len) 1))
(define (extract-bit-field size position n)
(bitwise-and (arithmetic-shift n (- position)) (mask size)))
(define (replace-bit-field size position newfield n)
(bitwise-ior
(bitwise-and n (bitwise-not (arithmetic-shift (mask size) position)))
(arithmetic-shift newfield position)))
(define (copy-bit-field size position from to)
(bitwise-merge (arithmetic-shift (mask size) position) to from))))

61
lib/srfi/33/bitwise.scm
View file

@ -1,61 +0,0 @@
;; bitwise.scm -- high-level bitwise functions
;; Copyright (c) 2009 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
(define (bitwise-not i) (- -1 i))
(define (bitwise-complement f) (lambda args (bitwise-not (apply f args))))
(define (make-nary proc2 default)
(lambda args
(if (null? args)
default
(let lp ((i (car args)) (ls (cdr args)))
(if (null? ls)
i
(lp (proc2 i (car ls)) (cdr ls)))))))
(define bitwise-and (make-nary bit-and -1))
(define bitwise-ior (make-nary bit-ior 0))
(define bitwise-xor (make-nary bit-xor 0))
(define bitwise-eqv (bitwise-complement (make-nary bit-xor -1)))
(define bitwise-nand (bitwise-complement (make-nary bit-and 0)))
(define bitwise-nor (bitwise-complement (make-nary bit-ior -1)))
(define (bitwise-andc1 i j) (bit-and (bitwise-not i) j))
(define (bitwise-andc2 i j) (bit-and i (bitwise-not j)))
(define (bitwise-orc1 i j) (bit-ior (bitwise-not i) j))
(define (bitwise-orc2 i j) (bit-ior i (bitwise-not j)))
(define (any-bits-set? test-bits i)
(not (zero? (bitwise-and test-bits i))))
(define (all-bits-set? test-bits i)
(= test-bits (bitwise-and test-bits i)))
(define (first-set-bit i)
(if (zero? i)
-1
(integer-length (- i (bit-and i (- i 1))))))
(define (mask len) (- (arithmetic-shift 1 len) 1))
(define (bitwise-merge mask n m)
(bit-ior (bit-and mask n) (bit-and (bitwise-not mask) m)))
(define (extract-bit-field size position n)
(bit-and (arithmetic-shift n (- position)) (mask size)))
(define (test-bit-field? size position n)
(not (zero? (bit-and (arithmetic-shift n (- position)) (mask size)))))
(define (replace-bit-field size position newfield n)
(bit-ior (bit-and n (bitwise-not (arithmetic-shift (mask size) position)))
(arithmetic-shift newfield position)))
(define (clear-bit-field size position n)
(replace-bit-field size position 0 n))
(define (copy-bit-field size position from to)
(bitwise-merge (arithmetic-shift (mask size) position) to from))

5
lib/srfi/33/test.sld
View file

@ -1,6 +1,6 @@
(define-library (srfi 33 test)
(export run-tests)
(import (chibi) (srfi 33) (chibi test))
(import (scheme base) (srfi 33) (chibi test))
(begin
(define (run-tests)
(test-begin "srfi-33: bitwise operations")
@ -68,4 +68,7 @@
(test-not (bit-set? 64 1))
(test-assert (bit-set? 64 #x10000000000000000))
(test 3 (bitwise-merge 1 1 2))
(test #b00110011 (bitwise-merge #b00111100 #b11110000 #b00001111))
(test-end))))