Re: SRFI 63
David Van Horn <[email protected]> Tue, 13 Jun 2006 17:55:38 -0400
| Newsgroups | gmane.lisp.scheme.plt.schematics |
|---|---|
| Message-ID | <[email protected]> |
This is a multi-part message in MIME format.
--------------000804010201030407070803
Content-Type: text/plain; charset=us-ascii
Content-Transfer-Encoding: 7bit
Chongkai Zhu wrote:
> Got it and will insert it into PLT SVN.
Here is a patch that improves upon the representation of arrays,
includes contracts for all the bindings, and is written in a way that
makes it easier to swap in different implementations of, for example,
floc* or bool arrays.
Some of the contracts could be improved. In particular, list->array
should do more checking on the form of the list argument (checking that
it is rank-nested and rectangular). Array-ref and -set! should check
that they get and set values of the correct type and/or range.
Make-shared-array should ensure that mapper always returns indices
within the range of its array argument. Etc.
I also have a set of test cases. Is there an idiom for adding such a thing?
David
--------------000804010201030407070803
Content-Type: text/x-patch;
name="63.ss.patch"
Content-Transfer-Encoding: 7bit
Content-Disposition: inline;
filename="63.ss.patch"
Index: 63.ss
===================================================================
--- 63.ss (revision 3309)
+++ 63.ss (working copy)
@@ -1,23 +1,78 @@
-;; SRFI 63: Homogeneous and Heterogeneous Arrays
+;; Implementation of SRFI 63 "Homogeneous and Heterogeneous Arrays" for PLT
+;; Scheme.
+
+;; Copyright (C) 2006 David Van Horn
+
+;; Released under the same terms as the SRFI reference implementation.
+
+;; Parts of this file are based on SLIB "array.scm" Arrays for Scheme.
+;; Copyright (C) 2001, 2003, 2005, 2006 Aubrey Jaffer
+
(module |63| mzscheme
(require (lib "4.ss" "srfi")
(lib "9.ss" "srfi")
(lib "16.ss" "srfi")
(lib "contract.ss"))
+
+ (define-syntax enumerate
+ (syntax-rules ()
+ ((enumerate name (const val) ...)
+ (define-syntax name
+ (syntax-rules (const ...)
+ ((name const) val) ...)))))
+
+ (enumerate a:
+ (vector 0)
+ (floc128b 1) (floc64b 2) (floc32b 3) (floc16b 4)
+ (flor128b 5) (flor64b 6) (flor32b 7) (flor16b 8)
+ (floq128d 9) (floq64d 10) (floq32d 11)
+ (fixz64b 12) (fixz32b 13) (fixz16b 14) (fixz8b 15)
+ (fixn64b 16) (fixn32b 17) (fixn16b 18) (fixn8b 19)
+ (bool 20)
+ (string 21))
- (define-record-type :strict-array ;:strict-array
- (make-strict-array
- dimensions scales offset store store-ref store-set store-make)
+ ;; This implementation uses SRFI-4 vectors as the store for
+ ;; several of the homogeneous array types, but several types
+ ;; are implemented using plain vectors. To improve the
+ ;; implementation, simply update the appropriate entry in
+ ;; this table.
+ (define implementation-list
+ (let ((ls list-immutable))
+ (ls (ls (a: vector) make-vector vector-ref vector-set!)
+ (ls (a: floc128b) make-vector vector-ref vector-set!)
+ (ls (a: floc64b) make-f64vector f64vector-ref f64vector-set!)
+ (ls (a: floc32b) make-f32vector f32vector-ref f32vector-set!)
+ (ls (a: floc16b) make-vector vector-ref vector-set!)
+ (ls (a: flor128b) make-vector vector-ref vector-set!)
+ (ls (a: flor64b) make-vector vector-ref vector-set!)
+ (ls (a: flor32b) make-vector vector-ref vector-set!)
+ (ls (a: flor16b) make-vector vector-ref vector-set!)
+ (ls (a: floq128d) make-vector vector-ref vector-set!)
+ (ls (a: floq64d) make-vector vector-ref vector-set!)
+ (ls (a: floq32d) make-vector vector-ref vector-set!)
+ (ls (a: fixz64b) make-s64vector s64vector-ref s64vector-set!)
+ (ls (a: fixz32b) make-s32vector s32vector-ref s32vector-set!)
+ (ls (a: fixz16b) make-s16vector s16vector-ref s16vector-set!)
+ (ls (a: fixz8b) make-s8vector s8vector-ref s8vector-set!)
+ (ls (a: fixn64b) make-u64vector u64vector-ref u64vector-set!)
+ (ls (a: fixn32b) make-u32vector u32vector-ref u32vector-set!)
+ (ls (a: fixn16b) make-u16vector u16vector-ref u16vector-set!)
+ (ls (a: fixn8b) make-u8vector u8vector-ref u8vector-set!)
+ (ls (a: bool) make-vector vector-ref vector-set!)
+ (ls (a: string) make-string string-ref string-set!))))
+
+ ;; PLTisms: list-immutable, vector-immutable, sub1, add1,
+ ;; arithmetic-shift, contracts.
+
+ (define-record-type :strict-array
+ (make-strict-array dimensions scales offset store store-type)
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?
-
+ (store-type strict-array-store-type))
+
(define (array-dimensions array)
(cond ((vector? array) (list (vector-length array)))
((string? array) (list (string-length array)))
@@ -32,21 +87,32 @@
(cond ((string? array) array)
((vector? array) array)
(else (strict-array-store array))))
+
+ (define store-makers
+ (apply vector-immutable
+ (map (lambda (item) (list-ref item 1)) implementation-list)))
+ (define store-reffers
+ (apply vector-immutable
+ (map (lambda (item) (list-ref item 2)) implementation-list)))
+
+ (define store-setters
+ (apply vector-immutable
+ (map (lambda (item) (list-ref item 3)) implementation-list)))
+
+ (define (array-store-type array)
+ (cond ((string? array) (a: string))
+ ((vector? array) (a: vector))
+ (else (strict-array-store-type array))))
+
(define (array-store-ref array)
- (cond ((string? array) string-ref)
- ((vector? array) vector-ref)
- (else (strict-array-store-ref array))))
+ (vector-ref store-reffers (array-store-type array)))
(define (array-store-set array)
- (cond ((string? array) string-set!)
- ((vector? array) vector-set!)
- (else (strict-array-store-set array))))
+ (vector-ref store-setters (array-store-type array)))
- (define (array-store-make array)
- (cond ((string? array) make-string)
- ((vector? array) make-vector)
- (else (strict-array-store-make array))))
+ (define (array-store-maker array-type)
+ (vector-ref store-makers array-type))
(define (array-offset array)
(cond ((string? array) 0)
@@ -86,15 +152,14 @@
((and onedim? (vector? prot))
(apply make-vector (car dimensions) initializer))
(else
- (let ((store (apply (array-store-make prototype)
+ (let* ((store-type (array-store-type prototype))
+ (store (apply (array-store-maker store-type)
tcnt initializer)))
(let loop ((dims (reverse dimensions)) (scales '(1)))
(if (null? dims)
- (make-strict-array dimensions (cdr scales) 0
+ (make-strict-array dimensions (cdr scales) 0
store
- (array-store-ref prototype)
- (array-store-set prototype)
- (array-store-make prototype))
+ store-type)
(loop (cdr dims)
(cons (* (car dims) (car scales)) scales))))))))))
@@ -120,9 +185,7 @@
(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))))))
+ (array-store-type array))))))
(define (list->array rank proto lst)
(define dimensions
@@ -203,74 +266,165 @@
(apply + (array-offset array) (map * (array-scales array) indices))
obj))
- (define (tag-maker make-tagvector tagvector-ref tagvector-set)
+ (define (tag-maker array-type)
(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))))
+ (() (make-strict-array
+ '(0) '(1) 0
+ ((array-store-maker array-type) 0)
+ array-type))
+
+ ((x) (make-strict-array
+ '(1) '(1) 0
+ ((array-store-maker array-type) 1 x)
+ array-type))))
- (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:floc128b (tag-maker (a: floc128b)))
+ (define a:floc64b (tag-maker (a: floc64b)))
+ (define a:floc32b (tag-maker (a: floc32b)))
+ (define a:floc16b (tag-maker (a: floc16b)))
- (define a:floc32b (tag-maker make-f32vector f32vector-ref f32vector-set!))
- (define a:floc64b (tag-maker make-f64vector f64vector-ref f64vector-set!))
+ (define a:flor128b (tag-maker (a: flor128b)))
+ (define a:flor64b (tag-maker (a: flor64b)))
+ (define a:flor32b (tag-maker (a: flor32b)))
+ (define a:flor16b (tag-maker (a: flor16b)))
+
+ (define a:floq128d (tag-maker (a: floq128d)))
+ (define a:floq64d (tag-maker (a: floq64d)))
+ (define a:floq32d (tag-maker (a: floq32d)))
+
+ (define a:fixz64b (tag-maker (a: fixz64b)))
+ (define a:fixz16b (tag-maker (a: fixz16b)))
+ (define a:fixz32b (tag-maker (a: fixz32b)))
+ (define a:fixz8b (tag-maker (a: fixz8b)))
+
+ (define a:fixn64b (tag-maker (a: fixn64b)))
+ (define a:fixn32b (tag-maker (a: fixn32b)))
+ (define a:fixn16b (tag-maker (a: fixn16b)))
+ (define a:fixn8b (tag-maker (a: fixn8b)))
- ;; Don't have anything better to do in these cases.
+ (define a:bool (tag-maker (a: bool)))
+
- (define (vector-maker)
- (case-lambda
- (() (vector))
- ((x) (vector x))))
+ ;; --
+ ;; Contracts for module |63|.
- (define a:floc16b (vector-maker))
- (define a:floc128b (vector-maker))
+ ;; Returns a contract for a binary flonum complex prototype function
+ ;; given the number of bits (NOT USED).
+ (define (make-floc/c _)
+ (case-> (-> array?)
+ (-> (and/c inexact? complex?) array?)))
- (define a:flor16b (vector-maker))
- (define a:flor32b (vector-maker))
- (define a:flor64b (vector-maker))
- (define a:flor128b (vector-maker))
+ ;; Returns a contract for a binary flonum real prototype function
+ ;; given the number of bits (NOT USED).
+ (define (make-flor/c _)
+ (case-> (-> array?)
+ (-> (and/c inexact? real?) array?)))
- (define a:floq128d (vector-maker))
- (define a:floq64d (vector-maker))
- (define a:floq32d (vector-maker))
+ ;; Returns a contract for a decimal flonum rational prototype function
+ ;; given the number of bits (NOT USED).
+ (define (make-floq/c _)
+ (case-> (-> array?)
+ (-> (and/c exact? rational?) array?)))
- (define a:bool (vector-maker))
+ ;; Returns a contract for a binary fixnum prototype function given
+ ;; the number of bits and whether the elements are signed.
+ (define (make-fix/c n signed?)
+ (case->
+ (-> array?)
+ (-> (and/c exact?
+ (if signed?
+ (let ((x (arithmetic-shift 1 (sub1 n))))
+ (integer-in (- x) (sub1 x)))
+ (integer-in 0 (sub1 (arithmetic-shift 1 n)))))
+ array?)))
- (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? (-> any/c boolean?))
+ (s:equal? (-> any/c any/c boolean?))
+ (array-rank (-> any/c natural-number/c))
+ (array-dimensions (-> array? (listof natural-number/c)))
+
+ (make-array
+ (->r ((proto array?)) dimensions (listof natural-number/c)
+ (lambda (result)
+ (let ((rank (length dimensions)))
+ (cond ((and (string? proto) (= 1 rank))
+ (string? result))
+ ((and (vector? proto) (= 1 rank))
+ (vector? result))
+ (else
+ (equal? (array-store-type proto)
+ (array-store-type result))))))))
+
+ (make-shared-array
+ (->r ((array array?)
+ (mapper (->* () (listof natural-number/c)
+ ((listof natural-number/c)))))
+ indices (listof natural-number/c)
+ array?))
+
+ (list->array
+ (->r ((rank natural-number/c) (proto array?) (list list?)) array?))
+
+ (array->list
+ (->r ((array array?))
+ (lambda (result)
+ (or (zero? (array-rank array))
+ (list? result)))))
+
+ (array->vector
+ (->r ((array array?)) vector?))
+
+ (array-in-bounds?
+ (->r ((array array?)) indices (listof any/c) boolean?))
+
(array-set!
- (->r ((a array?) (_ any/c)) indices
- (lambda _ (apply array-in-bounds? a indices)) any))
+ (->r ((array array?) (_ any/c)) indices
+ (lambda _ (apply array-in-bounds? array indices))
+ any))
(array-ref
- (->r ((a array?)) indices
- (lambda _ (apply array-in-bounds? a indices)) any))
+ (->r ((array array?)) indices
+ (lambda _ (apply array-in-bounds? array indices))
+ any))
(vector->array
- (->r ((v vector?) (p array?)) dimensions
- (lambda _ (eqv? (vector-length v) (apply * dimensions))) any)))
+ (->r ((vector vector?) (proto array?)) dimensions
+ (lambda _ (eqv? (vector-length vector) (apply * dimensions)))
+ any))
+
+ ;; Binary flonum complex
+ (a:floc128b (make-floc/c 128))
+ (a:floc64b (make-floc/c 64))
+ (a:floc32b (make-floc/c 32))
+ (a:floc16b (make-floc/c 16))
- ) ; end of module |63|
\ No newline at end of file
+ ;; Binary flonum real
+ (a:flor128b (make-flor/c 128))
+ (a:flor64b (make-flor/c 64))
+ (a:flor32b (make-flor/c 32))
+ (a:flor16b (make-flor/c 16))
+
+ ;; Decimal flonum rational
+ (a:floq128d (make-floq/c 128))
+ (a:floq64d (make-floq/c 64))
+ (a:floq32d (make-floq/c 32))
+
+ ;; Binary fixnum
+ (a:fixz64b (make-fix/c 64 #t))
+ (a:fixz32b (make-fix/c 32 #t))
+ (a:fixz16b (make-fix/c 16 #t))
+ (a:fixz8b (make-fix/c 8 #t))
+ (a:fixn64b (make-fix/c 64 #f))
+ (a:fixn32b (make-fix/c 32 #f))
+ (a:fixn16b (make-fix/c 16 #f))
+ (a:fixn8b (make-fix/c 8 #f))
+
+ ;; Boolean
+ (a:bool
+ (case-> (-> array?)
+ (-> boolean? array?))))
+
+ ) ; end of module |63|
--------------000804010201030407070803
Content-Type: text/plain; charset="us-ascii"
MIME-Version: 1.0
Content-Transfer-Encoding: 7bit
Content-Disposition: inline
--------------000804010201030407070803
Content-Type: text/plain; charset="us-ascii"
MIME-Version: 1.0
Content-Transfer-Encoding: 7bit
Content-Disposition: inline
_______________________________________________
Schematics-development mailing list
Schematics-development-5NWGOfrQmneRv+LV9MX5uipxlwaOVQ5f@public.gmane.org
https://lists.sourceforge.net/lists/listinfo/schematics-development
--------------000804010201030407070803--