suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

improves upon the representation of arrays

Browse Source 
svn: r3591
This commit is contained in:
Chongkai Zhu 2006-07-04 14:31:05 +00:00
parent ee4748f66d
commit ba5c6607d8
1 changed files with 234 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

314
collects/srfi/63/63.ss
View File

@ -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|
;; 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|