New SRFIs from Schematics maillist.
svn: r3144
This commit is contained in:
Chongkai Zhu
parent
a1cda35b2a
commit
7aabcee6fd
4
collects/srfi/63.ss
Normal file
4
collects/srfi/63.ss
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
(module |63| mzscheme
|
||||
(require (lib "63.ss" "srfi" "63"))
|
||||
(provide (all-from-except (lib "63.ss" "srfi" "63") s:equal?)
|
||||
(rename s:equal? equal?)))
|
||||
276
collects/srfi/63/63.ss
Normal file
276
collects/srfi/63/63.ss
Normal file
|
|
@ -0,0 +1,276 @@
|
|||
;; SRFI 63: Homogeneous and Heterogeneous Arrays
|
||||
(module |63| mzscheme
|
||||
(require (lib "4.ss" "srfi")
|
||||
(lib "9.ss" "srfi")
|
||||
(lib "16.ss" "srfi")
|
||||
(lib "contract.ss"))
|
||||
|
||||
(define-record-type :strict-array ;:strict-array
|
||||
(make-strict-array
|
||||
dimensions scales offset store store-ref store-set store-make)
|
||||
strict-array?
|
||||
(dimensions strict-array-dimensions)
|
||||
(scales strict-array-scales)
|
||||
(offset strict-array-offset)
|
||||
(store strict-array-store)
|
||||
(store-ref strict-array-store-ref) ; each array contains
|
||||
(store-set strict-array-store-set) ; its ref, acc, and maker
|
||||
(store-make strict-array-store-make)) ; procedures for its storage type.
|
||||
; maybe theres a better approach?
|
||||
|
||||
(define (array-dimensions array)
|
||||
(cond ((vector? array) (list (vector-length array)))
|
||||
((string? array) (list (string-length array)))
|
||||
(else (strict-array-dimensions array))))
|
||||
|
||||
(define (array-scales array)
|
||||
(cond ((string? array) '(1))
|
||||
((vector? array) '(1))
|
||||
(else (strict-array-scales array))))
|
||||
|
||||
(define (array-store array)
|
||||
(cond ((string? array) array)
|
||||
((vector? array) array)
|
||||
(else (strict-array-store array))))
|
||||
|
||||
(define (array-store-ref array)
|
||||
(cond ((string? array) string-ref)
|
||||
((vector? array) vector-ref)
|
||||
(else (strict-array-store-ref array))))
|
||||
|
||||
(define (array-store-set array)
|
||||
(cond ((string? array) string-set!)
|
||||
((vector? array) vector-set!)
|
||||
(else (strict-array-store-set array))))
|
||||
|
||||
(define (array-store-make array)
|
||||
(cond ((string? array) make-string)
|
||||
((vector? array) make-vector)
|
||||
(else (strict-array-store-make array))))
|
||||
|
||||
(define (array-offset array)
|
||||
(cond ((string? array) 0)
|
||||
((vector? array) 0)
|
||||
(else (strict-array-offset array))))
|
||||
|
||||
(define (array? obj)
|
||||
(or (string? obj)
|
||||
(vector? obj)
|
||||
(strict-array? obj)))
|
||||
|
||||
(define (s:equal? obj1 obj2)
|
||||
(or (equal? obj1 obj2)
|
||||
(and (array? obj1) (array? obj2)
|
||||
(equal? (array-dimensions obj1)
|
||||
(array-dimensions obj2))
|
||||
(s:equal? (array->vector obj1) (array->vector obj2)))))
|
||||
|
||||
(define (array-rank x)
|
||||
(if (array? x)
|
||||
(length (array-dimensions x))
|
||||
0))
|
||||
|
||||
(define (make-array prototype . dimensions)
|
||||
(let ((prot (array-store prototype))
|
||||
(pdims (array-dimensions prototype))
|
||||
(onedim? (eqv? 1 (length dimensions)))
|
||||
(tcnt (apply * dimensions)))
|
||||
(let ((initializer
|
||||
(if (zero? (apply * pdims)) '()
|
||||
(list ;; a list with single element at origin
|
||||
(apply array-ref prototype
|
||||
(map (lambda (x) 0) pdims))))))
|
||||
|
||||
(cond ((and onedim? (string? prot))
|
||||
(apply make-string (car dimensions) initializer))
|
||||
((and onedim? (vector? prot))
|
||||
(apply make-vector (car dimensions) initializer))
|
||||
(else
|
||||
(let ((store (apply (array-store-make prototype)
|
||||
tcnt initializer)))
|
||||
(let loop ((dims (reverse dimensions)) (scales '(1)))
|
||||
(if (null? dims)
|
||||
(make-strict-array dimensions (cdr scales) 0
|
||||
store
|
||||
(array-store-ref prototype)
|
||||
(array-store-set prototype)
|
||||
(array-store-make prototype))
|
||||
(loop (cdr dims)
|
||||
(cons (* (car dims) (car scales)) scales))))))))))
|
||||
|
||||
(define (make-shared-array array mapper . dimensions)
|
||||
(define odl (array-scales array))
|
||||
(define rank (length dimensions))
|
||||
(define shape
|
||||
(map (lambda (dim) (if (list? dim) dim (list 0 (sub1 dim)))) dimensions))
|
||||
|
||||
(do ((idx (sub1 rank) (sub1 idx))
|
||||
(uvt (if (zero? rank)
|
||||
'()
|
||||
(append (cdr (vector->list (make-vector rank 0))) '(1)))
|
||||
(append (cdr uvt) '(0)))
|
||||
(uvts '() (cons uvt uvts)))
|
||||
((negative? idx)
|
||||
(let ((ker0 (apply + (map * odl (apply mapper uvt)))))
|
||||
(make-strict-array
|
||||
(map (lambda (dim) (add1 (- (cadr dim) (car dim)))) shape)
|
||||
(map (lambda (uvt) (- (apply + (map * odl (apply mapper uvt))) ker0))
|
||||
uvts)
|
||||
(apply +
|
||||
(array-offset array)
|
||||
(map * odl (apply mapper (map car shape))))
|
||||
(array-store array)
|
||||
(array-store-ref array)
|
||||
(array-store-set array)
|
||||
(array-store-make array))))))
|
||||
|
||||
(define (list->array rank proto lst)
|
||||
(define dimensions
|
||||
(do ((shp '() (cons (length row) shp))
|
||||
(row lst (car lst))
|
||||
(rnk (sub1 rank) (sub1 rnk)))
|
||||
((negative? rnk) (reverse shp))))
|
||||
(let ((nra (apply make-array proto dimensions)))
|
||||
(define (l2ra dims idxs row)
|
||||
(cond ((null? dims)
|
||||
(apply array-set! nra row (reverse idxs)))
|
||||
(;; ERROR CHECKING (should be a contract)
|
||||
(if (not (eqv? (car dims) (length row)))
|
||||
(error "non-rectangular array" dims dimensions))
|
||||
|
||||
(do ((idx 0 (add1 idx))
|
||||
(row row (cdr row)))
|
||||
((>= idx (car dims)))
|
||||
(l2ra (cdr dims) (cons idx idxs) (car row))))))
|
||||
(l2ra dimensions '() lst)
|
||||
nra))
|
||||
|
||||
(define (array->list ra)
|
||||
(define (ra2l dims idxs)
|
||||
(if (null? dims)
|
||||
(apply array-ref ra (reverse idxs))
|
||||
(do ((lst '() (cons (ra2l (cdr dims) (cons idx idxs)) lst))
|
||||
(idx (sub1 (car dims)) (sub1 idx)))
|
||||
((negative? idx) lst))))
|
||||
(ra2l (array-dimensions ra) '()))
|
||||
|
||||
(define (vector->array vect prototype . dimensions)
|
||||
(let ((vdx (vector-length vect))
|
||||
(ra (apply make-array prototype dimensions)))
|
||||
(define (v2ra dims idxs)
|
||||
(cond ((null? dims)
|
||||
(set! vdx (sub1 vdx))
|
||||
(apply array-set! ra (vector-ref vect vdx) (reverse idxs)))
|
||||
(else
|
||||
(do ((idx (sub1 (car dims)) (sub1 idx)))
|
||||
((negative? idx) vect)
|
||||
(v2ra (cdr dims) (cons idx idxs))))))
|
||||
(v2ra dimensions '())
|
||||
ra))
|
||||
|
||||
(define (array->vector ra)
|
||||
(define dims (array-dimensions ra))
|
||||
(let* ((vdx (apply * dims))
|
||||
(vect (make-vector vdx)))
|
||||
(define (ra2v dims idxs)
|
||||
(if (null? dims)
|
||||
(let ((val (apply array-ref ra (reverse idxs))))
|
||||
(set! vdx (sub1 vdx))
|
||||
(vector-set! vect vdx val))
|
||||
(do ((idx (sub1 (car dims)) (sub1 idx)))
|
||||
((negative? idx) vect)
|
||||
(ra2v (cdr dims) (cons idx idxs)))))
|
||||
(ra2v dims '())
|
||||
vect))
|
||||
|
||||
(define (array-in-bounds? array . indices)
|
||||
(do ((bnds (array-dimensions array) (cdr bnds))
|
||||
(idxs indices (cdr idxs)))
|
||||
((or (null? bnds)
|
||||
(null? idxs)
|
||||
(not (integer? (car idxs)))
|
||||
(not (< -1 (car idxs) (car bnds))))
|
||||
(and (null? bnds) (null? idxs)))))
|
||||
|
||||
(define (array-ref array . indices)
|
||||
((array-store-ref array)
|
||||
(array-store array)
|
||||
(apply + (array-offset array) (map * (array-scales array) indices))))
|
||||
|
||||
(define (array-set! array obj . indices)
|
||||
((array-store-set array)
|
||||
(array-store array)
|
||||
(apply + (array-offset array) (map * (array-scales array) indices))
|
||||
obj))
|
||||
|
||||
(define (tag-maker make-tagvector tagvector-ref tagvector-set)
|
||||
(case-lambda
|
||||
(() (make-strict-array
|
||||
'(1) '(1) 0 (make-tagvector 1 0)
|
||||
tagvector-ref tagvector-set make-tagvector))
|
||||
((x) (make-strict-array
|
||||
'(1) '(1) 0 (make-tagvector 1 x)
|
||||
tagvector-ref tagvector-set make-tagvector))))
|
||||
|
||||
(define a:fixz8b (tag-maker make-s8vector s8vector-ref s8vector-set!))
|
||||
(define a:fixz16b (tag-maker make-s16vector s16vector-ref s16vector-set!))
|
||||
(define a:fixz32b (tag-maker make-s32vector s32vector-ref s32vector-set!))
|
||||
(define a:fixz64b (tag-maker make-s64vector s64vector-ref s64vector-set!))
|
||||
(define a:fixn8b (tag-maker make-u8vector u8vector-ref u8vector-set!))
|
||||
(define a:fixn16b (tag-maker make-u16vector u16vector-ref u16vector-set!))
|
||||
(define a:fixn32b (tag-maker make-u32vector u32vector-ref u32vector-set!))
|
||||
(define a:fixn64b (tag-maker make-u64vector u64vector-ref u64vector-set!))
|
||||
|
||||
(define a:floc32b (tag-maker make-f32vector f32vector-ref f32vector-set!))
|
||||
(define a:floc64b (tag-maker make-f64vector f64vector-ref f64vector-set!))
|
||||
|
||||
;; Don't have anything better to do in these cases.
|
||||
|
||||
(define (vector-maker)
|
||||
(case-lambda
|
||||
(() (vector))
|
||||
((x) (vector x))))
|
||||
|
||||
(define a:floc16b (vector-maker))
|
||||
(define a:floc128b (vector-maker))
|
||||
|
||||
(define a:flor16b (vector-maker))
|
||||
(define a:flor32b (vector-maker))
|
||||
(define a:flor64b (vector-maker))
|
||||
(define a:flor128b (vector-maker))
|
||||
|
||||
(define a:floq128d (vector-maker))
|
||||
(define a:floq64d (vector-maker))
|
||||
(define a:floq32d (vector-maker))
|
||||
|
||||
(define a:bool (vector-maker))
|
||||
|
||||
(provide array? s:equal? array-rank array-dimensions
|
||||
make-array make-shared-array
|
||||
list->array array->list array->vector
|
||||
array-in-bounds?
|
||||
|
||||
a:fixz8b a:fixz16b a:fixz32b a:fixz64b
|
||||
a:fixn8b a:fixn16b a:fixn32b a:fixn64b
|
||||
|
||||
a:floc16b a:floc32b a:floc64b a:floc128b
|
||||
a:flor16b a:flor32b a:flor64b a:flor128b
|
||||
|
||||
a:floq32d a:floq64d a:floq128d
|
||||
|
||||
a:bool)
|
||||
|
||||
(provide/contract
|
||||
(array-set!
|
||||
(->r ((a array?) (_ any/c)) indices
|
||||
(lambda _ (apply array-in-bounds? a indices)) any))
|
||||
|
||||
(array-ref
|
||||
(->r ((a array?)) indices
|
||||
(lambda _ (apply array-in-bounds? a indices)) any))
|
||||
|
||||
(vector->array
|
||||
(->r ((v vector?) (p array?)) dimensions
|
||||
(lambda _ (eqv? (vector-length v) (apply * dimensions))) any)))
|
||||
|
||||
) ; end of module |63|
|
||||
3
collects/srfi/66.ss
Normal file
3
collects/srfi/66.ss
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
(module |66| mzscheme
|
||||
(require (lib "66.ss" "srfi" "66"))
|
||||
(provide (all-from (lib "66.ss" "srfi" "66"))))
|
||||
24
collects/srfi/66/66.ss
Normal file
24
collects/srfi/66/66.ss
Normal file
|
|
@ -0,0 +1,24 @@
|
|||
(module |66| mzscheme
|
||||
(provide (rename bytes? u8vector?)
|
||||
(rename make-bytes make-u8vector)
|
||||
(rename bytes u8vector)
|
||||
(rename bytes->list u8vector->list)
|
||||
(rename list->bytes list->u8vector)
|
||||
(rename bytes-length u8vector-length)
|
||||
(rename bytes-ref u8vector-ref)
|
||||
(rename bytes-set! u8vector-set!)
|
||||
(rename bytes-copy u8vector-copy)
|
||||
u8vector=?
|
||||
u8vector-compare
|
||||
u8vector-copy!)
|
||||
|
||||
(define (u8vector=? v1 v2)
|
||||
(bytes=? v1 v2))
|
||||
|
||||
(define (u8vector-compare v1 v2)
|
||||
(cond ((bytes<? v1 v2) -1)
|
||||
((bytes>? v1 v2) 1)
|
||||
(else 0)))
|
||||
|
||||
(define (u8vector-copy! src src-start dest dest-start n)
|
||||
(bytes-copy! dest dest-start src src-start (+ src-start n))))
|
||||
3
collects/srfi/74.ss
Normal file
3
collects/srfi/74.ss
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
(module |74| mzscheme
|
||||
(require (lib "74.ss" "srfi" "74"))
|
||||
(provide (all-from (lib "74.ss" "srfi" "74"))))
|
||||
32
collects/srfi/74/74.ss
Normal file
32
collects/srfi/74/74.ss
Normal file
|
|
@ -0,0 +1,32 @@
|
|||
(module |74| mzscheme
|
||||
(require (lib "include.ss")
|
||||
(lib "26.ss" "srfi")
|
||||
(lib "60.ss" "srfi")
|
||||
(lib "66.ss" "srfi"))
|
||||
(provide
|
||||
endianness
|
||||
blob?
|
||||
make-blob
|
||||
blob-length
|
||||
blob-u8-ref blob-s8-ref
|
||||
blob-u8-set! blob-s8-set!
|
||||
blob-uint-ref blob-sint-ref
|
||||
blob-uint-set! blob-sint-set!
|
||||
blob-u16-ref blob-s16-ref
|
||||
blob-u16-native-ref blob-s16-native-ref
|
||||
blob-u16-set! blob-s16-set!
|
||||
blob-u16-native-set! blob-s16-native-set!
|
||||
blob-u32-ref blob-s32-ref
|
||||
blob-u32-native-ref blob-s32-native-ref
|
||||
blob-u32-set! blob-s32-set!
|
||||
blob-u32-native-set! blob-s32-native-set!
|
||||
blob-u64-ref blob-s64-ref
|
||||
blob-u64-native-ref blob-s64-native-ref
|
||||
blob-u64-set! blob-s64-set!
|
||||
blob-u64-native-set! blob-s64-native-set!
|
||||
blob=?
|
||||
blob-copy! blob-copy
|
||||
blob->u8-list u8-list->blob
|
||||
blob->uint-list blob->sint-list
|
||||
uint-list->blob sint-list->blob)
|
||||
(include (lib "blob.scm" "srfi" "74")))
|
||||
232
collects/srfi/74/blob.scm
Normal file
232
collects/srfi/74/blob.scm
Normal file
|
|
@ -0,0 +1,232 @@
|
|||
; Octet-addressed binary objects
|
||||
|
||||
; Copyright (C) Michael Sperber (2005). All Rights Reserved.
|
||||
;
|
||||
; Permission is hereby granted, free of charge, to any person
|
||||
; obtaining a copy of this software and associated documentation files
|
||||
; (the "Software"), to deal in the Software without restriction,
|
||||
; including without limitation the rights to use, copy, modify, merge,
|
||||
; publish, distribute, sublicense, and/or sell copies of the Software,
|
||||
; and to permit persons to whom the Software is furnished to do so,
|
||||
; subject to the following conditions:
|
||||
;
|
||||
; The above copyright notice and this permission notice shall be
|
||||
; included in all copies or substantial portions of the Software.
|
||||
;
|
||||
; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
|
||||
; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
|
||||
; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
|
||||
; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
|
||||
; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
|
||||
; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
|
||||
; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
||||
; SOFTWARE.
|
||||
|
||||
; This uses SRFIs 23, 26, 60, and 66
|
||||
|
||||
(define *endianness/little* (list 'little))
|
||||
(define *endianness/big* (list 'big))
|
||||
|
||||
(define-syntax endianness
|
||||
(syntax-rules (little big native)
|
||||
((endianness little) *endianness/little*)
|
||||
((endianness big) *endianness/big*)
|
||||
;; change this to the endianness of your architecture
|
||||
((endianness native) *endianness/big*)))
|
||||
|
||||
(define blob? u8vector?)
|
||||
|
||||
(define (make-blob k)
|
||||
(make-u8vector k 0))
|
||||
|
||||
(define (blob-length b)
|
||||
(u8vector-length b))
|
||||
|
||||
(define (blob-u8-ref b k)
|
||||
(u8vector-ref b k))
|
||||
(define (blob-u8-set! b k octet)
|
||||
(u8vector-set! b k octet))
|
||||
|
||||
(define (blob-s8-ref b k)
|
||||
(u8->s8 (u8vector-ref b k)))
|
||||
|
||||
(define (u8->s8 octet)
|
||||
(if (> octet 127)
|
||||
(- octet 256)
|
||||
octet))
|
||||
|
||||
(define (blob-s8-set! b k val)
|
||||
(u8vector-set! b k (s8->u8 val)))
|
||||
|
||||
(define (s8->u8 val)
|
||||
(if (negative? val)
|
||||
(+ val 256)
|
||||
val))
|
||||
|
||||
(define (index-iterate start count low-first?
|
||||
unit proc)
|
||||
(if low-first?
|
||||
(let loop ((index 0)
|
||||
(acc unit))
|
||||
(if (>= index count)
|
||||
acc
|
||||
(loop (+ index 1)
|
||||
(proc (+ start index) acc))))
|
||||
|
||||
(let loop ((index (- (+ start count) 1))
|
||||
(acc unit))
|
||||
(if (< index start)
|
||||
acc
|
||||
(loop (- index 1)
|
||||
(proc index acc))))))
|
||||
|
||||
(define (blob-uint-ref size endness blob index)
|
||||
(index-iterate index size
|
||||
(eq? (endianness big) endness)
|
||||
0
|
||||
(lambda (index acc)
|
||||
(+ (u8vector-ref blob index) (arithmetic-shift acc 8)))))
|
||||
|
||||
(define (blob-sint-ref size endness blob index)
|
||||
(let ((high-byte (u8vector-ref blob
|
||||
(if (eq? endness (endianness big))
|
||||
index
|
||||
(- (+ index size) 1)))))
|
||||
|
||||
(if (> high-byte 127)
|
||||
(- (+ 1
|
||||
(index-iterate index size
|
||||
(eq? (endianness big) endness)
|
||||
0
|
||||
(lambda (index acc)
|
||||
(+ (- 255 (u8vector-ref blob index))
|
||||
(arithmetic-shift acc 8))))))
|
||||
(index-iterate index size
|
||||
(eq? (endianness big) endness)
|
||||
0
|
||||
(lambda (index acc)
|
||||
(+ (u8vector-ref blob index) (arithmetic-shift acc 8)))))))
|
||||
|
||||
(define (make-uint-ref size)
|
||||
(cut blob-uint-ref size <> <> <>))
|
||||
|
||||
(define (make-sint-ref size)
|
||||
(cut blob-sint-ref size <> <> <>))
|
||||
|
||||
(define (blob-uint-set! size endness blob index val)
|
||||
(index-iterate index size (eq? (endianness little) endness)
|
||||
val
|
||||
(lambda (index acc)
|
||||
(u8vector-set! blob index (remainder acc 256))
|
||||
(quotient acc 256)))
|
||||
(values))
|
||||
|
||||
(define (blob-sint-set! size endness blob index val)
|
||||
(if (negative? val)
|
||||
(index-iterate index size (eq? (endianness little) endness)
|
||||
(- -1 val)
|
||||
(lambda (index acc)
|
||||
(u8vector-set! blob index (- 255 (remainder acc 256)))
|
||||
(quotient acc 256)))
|
||||
|
||||
(index-iterate index size (eq? (endianness little) endness)
|
||||
val
|
||||
(lambda (index acc)
|
||||
(u8vector-set! blob index (remainder acc 256))
|
||||
(quotient acc 256))))
|
||||
|
||||
(values))
|
||||
|
||||
(define (make-uint-set! size)
|
||||
(cut blob-uint-set! size <> <> <> <>))
|
||||
(define (make-sint-set! size)
|
||||
(cut blob-sint-set! size <> <> <> <>))
|
||||
|
||||
(define (make-ref/native base base-ref)
|
||||
(lambda (endness blob index)
|
||||
(ensure-aligned index base)
|
||||
(base-ref (endianness native) blob index)))
|
||||
|
||||
(define (make-set!/native base base-set!)
|
||||
(lambda (endness blob index val)
|
||||
(ensure-aligned index base)
|
||||
(base-set! (endianness native) blob index val)))
|
||||
|
||||
(define (ensure-aligned index base)
|
||||
(if (not (zero? (remainder index base)))
|
||||
(error "non-aligned blob access" index base)))
|
||||
|
||||
(define blob-u16-ref (make-uint-ref 2))
|
||||
(define blob-u16-set! (make-uint-set! 2))
|
||||
(define blob-s16-ref (make-sint-ref 2))
|
||||
(define blob-s16-set! (make-sint-set! 2))
|
||||
(define blob-u16-native-ref (make-ref/native 2 blob-u16-ref))
|
||||
(define blob-u16-native-set! (make-set!/native 2 blob-u16-set!))
|
||||
(define blob-s16-native-ref (make-ref/native 2 blob-s16-ref))
|
||||
(define blob-s16-native-set! (make-set!/native 2 blob-s16-set!))
|
||||
|
||||
(define blob-u32-ref (make-uint-ref 4))
|
||||
(define blob-u32-set! (make-uint-set! 4))
|
||||
(define blob-s32-ref (make-sint-ref 4))
|
||||
(define blob-s32-set! (make-sint-set! 4))
|
||||
(define blob-u32-native-ref (make-ref/native 4 blob-u32-ref))
|
||||
(define blob-u32-native-set! (make-set!/native 4 blob-u32-set!))
|
||||
(define blob-s32-native-ref (make-ref/native 4 blob-s32-ref))
|
||||
(define blob-s32-native-set! (make-set!/native 4 blob-s32-set!))
|
||||
|
||||
(define blob-u64-ref (make-uint-ref 8))
|
||||
(define blob-u64-set! (make-uint-set! 8))
|
||||
(define blob-s64-ref (make-sint-ref 8))
|
||||
(define blob-s64-set! (make-sint-set! 8))
|
||||
(define blob-u64-native-ref (make-ref/native 8 blob-u64-ref))
|
||||
(define blob-u64-native-set! (make-set!/native 8 blob-u64-set!))
|
||||
(define blob-s64-native-ref (make-ref/native 8 blob-s64-ref))
|
||||
(define blob-s64-native-set! (make-set!/native 8 blob-s64-set!))
|
||||
|
||||
; Auxiliary stuff
|
||||
|
||||
(define (blob-copy! source source-start target target-start count)
|
||||
(u8vector-copy! source source-start target target-start count))
|
||||
|
||||
(define (blob-copy b)
|
||||
(u8vector-copy b))
|
||||
|
||||
(define (blob=? b1 b2)
|
||||
(u8vector=? b1 b2))
|
||||
|
||||
(define (blob->u8-list b)
|
||||
(u8vector->list b))
|
||||
(define (blob->s8-list b)
|
||||
(map u8->s8 (u8vector->list b)))
|
||||
|
||||
(define (u8-list->blob l)
|
||||
(list->u8vector l))
|
||||
(define (s8-list->blob l)
|
||||
(list->u8vector (map s8->u8 l)))
|
||||
|
||||
(define (make-blob->int-list blob-ref)
|
||||
(lambda (size endness b)
|
||||
(let ((ref (cut blob-ref size endness b <>))
|
||||
(length (blob-length b)))
|
||||
(let loop ((i 0) (r '()))
|
||||
(if (>= i length)
|
||||
(reverse r)
|
||||
(loop (+ i size)
|
||||
(cons (ref i) r)))))))
|
||||
|
||||
(define blob->uint-list (make-blob->int-list blob-uint-ref))
|
||||
(define blob->sint-list (make-blob->int-list blob-sint-ref))
|
||||
|
||||
(define (make-int-list->blob blob-set!)
|
||||
(lambda (size endness l)
|
||||
(let* ((blob (make-blob (* size (length l))))
|
||||
(set! (cut blob-set! size endness blob <> <>)))
|
||||
(let loop ((i 0) (l l))
|
||||
(if (null? l)
|
||||
blob
|
||||
(begin
|
||||
(set! i (car l))
|
||||
(loop (+ i size) (cdr l))))))))
|
||||
|
||||
(define uint-list->blob (make-int-list->blob blob-uint-set!))
|
||||
(define sint-list->blob (make-int-list->blob blob-sint-set!))
|
||||
Loading…
Reference in New Issue
Block a user