From 7aabcee6fd2a90ad538fead07e4e423ac5a68105 Mon Sep 17 00:00:00 2001 From: Chongkai Zhu Date: Wed, 31 May 2006 04:59:30 +0000 Subject: [PATCH] New SRFIs from Schematics maillist. svn: r3144 --- collects/srfi/63.ss | 4 + collects/srfi/63/63.ss | 276 ++++++++++++++++++++++++++++++++++++++ collects/srfi/66.ss | 3 + collects/srfi/66/66.ss | 24 ++++ collects/srfi/74.ss | 3 + collects/srfi/74/74.ss | 32 +++++ collects/srfi/74/blob.scm | 232 ++++++++++++++++++++++++++++++++ 7 files changed, 574 insertions(+) create mode 100644 collects/srfi/63.ss create mode 100644 collects/srfi/63/63.ss create mode 100644 collects/srfi/66.ss create mode 100644 collects/srfi/66/66.ss create mode 100644 collects/srfi/74.ss create mode 100644 collects/srfi/74/74.ss create mode 100644 collects/srfi/74/blob.scm diff --git a/collects/srfi/63.ss b/collects/srfi/63.ss new file mode 100644 index 0000000000..565bb9221a --- /dev/null +++ b/collects/srfi/63.ss @@ -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?))) \ No newline at end of file diff --git a/collects/srfi/63/63.ss b/collects/srfi/63/63.ss new file mode 100644 index 0000000000..e0e703003d --- /dev/null +++ b/collects/srfi/63/63.ss @@ -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| \ No newline at end of file diff --git a/collects/srfi/66.ss b/collects/srfi/66.ss new file mode 100644 index 0000000000..c3cc76f75d --- /dev/null +++ b/collects/srfi/66.ss @@ -0,0 +1,3 @@ +(module |66| mzscheme + (require (lib "66.ss" "srfi" "66")) + (provide (all-from (lib "66.ss" "srfi" "66")))) \ No newline at end of file diff --git a/collects/srfi/66/66.ss b/collects/srfi/66/66.ss new file mode 100644 index 0000000000..7384a05551 --- /dev/null +++ b/collects/srfi/66/66.ss @@ -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) + (else 0))) + + (define (u8vector-copy! src src-start dest dest-start n) + (bytes-copy! dest dest-start src src-start (+ src-start n)))) \ No newline at end of file diff --git a/collects/srfi/74.ss b/collects/srfi/74.ss new file mode 100644 index 0000000000..65a03fbcbd --- /dev/null +++ b/collects/srfi/74.ss @@ -0,0 +1,3 @@ +(module |74| mzscheme + (require (lib "74.ss" "srfi" "74")) + (provide (all-from (lib "74.ss" "srfi" "74")))) \ No newline at end of file diff --git a/collects/srfi/74/74.ss b/collects/srfi/74/74.ss new file mode 100644 index 0000000000..1809d08d0e --- /dev/null +++ b/collects/srfi/74/74.ss @@ -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"))) \ No newline at end of file diff --git a/collects/srfi/74/blob.scm b/collects/srfi/74/blob.scm new file mode 100644 index 0000000000..2cf349745e --- /dev/null +++ b/collects/srfi/74/blob.scm @@ -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!))