Re: SRFI 63

Is this in svn yet?  It look like the last change to SRFI
63 was 31 May, and this email was sent 13 June.  I'll add
it if you haven't had time.

N.

--- David Van Horn <[email protected]> wrote:

> On Tue, 13 Jun 2006, Chongkai Zhu wrote:
> > Yes. Please send me both the new 63.ss file and the
> test.
> 
> 63.ss is attached.  My laptop died an ugly death last
> night, so the test 
> cases may be lost for a while.
> 
> David> ;; 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))
> 
>   ;; 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-type strict-array-store-type))
>     
>   (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 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)
>     (vector-ref store-reffers (array-store-type array)))
>   
>   (define (array-store-set array)
>     (vector-ref store-setters (array-store-type array)))
>   
>   (define (array-store-maker array-type)
>     (vector-ref store-makers array-type))
>   
>   (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-type (array-store-type
> prototype))
>                       (store (apply (array-store-maker
> store-type)
>                                    tcnt initializer)))
>                  (let loop ((dims (reverse dimensions))
> (scales '(1)))
>                    (if (null? dims)
> 
=== message truncated ===> >
_______________________________________________
> Schematics-development mailing list
> Schematics-development-5NWGOfrQmneRv+LV9MX5uipxlwaOVQ5f@public.gmane.org
>
https://lists.sourceforge.net/lists/listinfo/schematics-development
> 


Email: noelwelsh <at> yahoo <dot> com   noel <at> untyped <dot> com
AIM: noelhwelsh
Blogs: http://monospaced.blogspot.com/  http://www.untyped.com/untyping/

__________________________________________________
Do You Yahoo!?
Tired of spam?  Yahoo! Mail has the best spam protection around 
http://mail.yahoo.com 

Using Tomcat but need to do more? Need to support web services, security?
Get stuff done quickly with pre-integrated technology to make your job easier
Download IBM WebSphere Application Server v.1.0.1 based on Apache Geronimo
http://sel.as-us.falkag.net/sel?cmd=lnk&kid=120709&bid=263057&dat=121642