upgrade

svn: r5920

collects/srfi/43/vector-lib.ss

@@ -6,11 +6,6 @@
            (lib "etc.ss" "mzlib")
            (lib "contract.ss"))
   
-  (define (nonneg-int? x)
-    (and (integer? x)
-         (exact? x)
-         (not (negative? x))))
-  
   (define mutable-vector/c
     (and/c vector? (not/c immutable?)))
   
@@ -18,12 +13,12 @@
     (case->
      (-> vector? any)
      (->r ((vec vector?)
-           (start (and/c nonneg-int?
+           (start (and/c natural-number/c
                          (<=/c (vector-length vec)))))
           any)
      (->pp ((vec vector?)
-            (start nonneg-int?)
+            (start natural-number/c)
-            (end nonneg-int?))
+            (end natural-number/c))
            (<= start end (vector-length vec))
            any)))
   
@@ -55,7 +50,7 @@
     (->r ((f (lambda (f)
                (and (procedure? f)
                     (procedure-arity-includes? f (add1 (length seeds))))))
-          (len nonneg-int?))
+          (len natural-number/c))
           seeds list?
           any))
   
@@ -63,19 +58,19 @@
     (case->
      (-> vector? any)
      (->r ((vec vector?)
-           (start (and/c nonneg-int?
+           (start (and/c natural-number/c
                          (<=/c (vector-length vec)))))
           any)
      (->r ((vec vector?)
-           (start (and/c nonneg-int?
+           (start (and/c natural-number/c
                          (<=/c (vector-length vec))))
-           (end (and/c nonneg-int?
+           (end (and/c natural-number/c
                        (>=/c start))))
           any)
      (->r ((vec vector?)
-           (start (and/c nonneg-int?
+           (start (and/c natural-number/c
                          (<=/c (vector-length vec))))
-           (end (and/c nonneg-int?
+           (end (and/c natural-number/c
                        (>=/c start)))
            (fill any/c))
           any)))
@@ -663,35 +658,35 @@
   (define copy!-contract
     (case->
      (->r ((target mutable-vector/c)
-           (tstart (and/c nonneg-int?
+           (tstart (and/c natural-number/c
                           (<=/c (- (vector-length target)
                                    (vector-length source)))))
            (source vector?))
           any)
      (->r ((target mutable-vector/c)
-           (tstart (and/c nonneg-int?
+           (tstart (and/c natural-number/c
                           (<=/c (- (vector-length target)
                                    (- (vector-length source)
                                       sstart)))))
            (source vector?)
-           (sstart (and/c nonneg-int?
+           (sstart (and/c natural-number/c
                           (<=/c (vector-length source)))))
           any)
      (->pp ((target mutable-vector/c)
-            (tstart (and/c nonneg-int?
+            (tstart (and/c natural-number/c
                            (<=/c (- (vector-length target)
                                     (- send sstart)))))
             (source vector?)
-            (sstart nonneg-int?)
+            (sstart natural-number/c)
-            (send nonneg-int?))
+            (send natural-number/c))
            (<= sstart send (vector-length source))
            any)))
   
   (provide/contract (vector-swap!
                      (->r ((vec mutable-vector/c)
-                           (i (and/c nonneg-int?
+                           (i (and/c natural-number/c
                                      (</c (vector-length vec))))
-                           (j (and/c nonneg-int?
+                           (j (and/c natural-number/c
                                      (</c (vector-length vec)))))
                           any))
                     (rename my-vector-fill! s:vector-fill!
@@ -699,13 +694,13 @@
                              (-> vector? any/c any)
                              (->r ((vec vector?)
                                    (fill any/c)
-                                   (start (and/c nonneg-int?
+                                   (start (and/c natural-number/c
                                                  (<=/c (vector-length vec)))))
                                   any)
                              (->pp ((vec vector?)
                                     (fill any/c)
-                                    (start nonneg-int?)
+                                    (start natural-number/c)
-                                    (end nonneg-int?))
+                                    (end natural-number/c))
                                    (<= start end (vector-length vec))
                                    any)))
                     (vector-reverse! (vec-start-end-contract mutable-vector/c))

collects/srfi/63.ss

@@ -1,3 +0,0 @@
-(module |63| mzscheme
-  (require (lib "63.ss" "srfi" "63"))
-  (provide (all-from (lib "63.ss" "srfi" "63"))))

collects/srfi/63/63.ss

@@ -1,302 +0,0 @@
-;; Implementation of SRFI 63 "Homogeneous and Heterogeneous Arrays" for PLT 
-;; Scheme.
-
-;; Copyright (C) 2007 Chongkai Zhu
-
-;; 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 "contract.ss"))
-  
-  (define-struct array:rtd
-                 (dimensions
-                  scales            ;list of dimension scales
-                  offset            ;exact integer
-                  store             ;data
-                  )
-                 #f)
-  
-  (define (array:dimensions array)
-    (cond ((vector? array) (list (vector-length array)))
-          ((string? array) (list (string-length array)))
-          ((bytes? array) (list (bytes-length array)))
-          (else (array:rtd-dimensions array))))
-  
-  (define (array:scales obj)
-    (if (or (string? obj)
-            (bytes? obj)
-            (vector? obj))
-        '(1)
-        (array:rtd-scales obj)))
-  
-  (define (array:store obj)
-    (if (or (string? obj)
-            (bytes? obj)
-            (vector? obj))
-        obj
-        (array:rtd-store obj)))
-  
-  (define (array:offset obj)
-    (if (or (string? obj)
-            (bytes? obj)
-            (vector? obj))
-        0
-        (array:rtd-offset obj)))
-  
-  (define (array? obj)
-    (or (string? obj)
-        (bytes? obj)
-        (vector? obj)
-        (array:rtd? obj)))
-  
-  (define (array-rank obj)
-    (if (array? obj) (length (array:dimensions obj)) 0))
-  
-  (define array-dimensions array:dimensions)
-  
-  (define (make-array prototype . dimensions)
-    (define tcnt (apply * dimensions))
-    (let ((store
-           (cond ((string? prototype)
-                  (case (string-length prototype)
-                    ((0) (make-string tcnt))
-                    (else (make-string tcnt
-                                       (string-ref prototype 0)))))
-                 ((bytes? prototype)
-                  (case (bytes-length prototype)
-                    ((0) (make-bytes tcnt))
-                    (else (make-bytes tcnt
-                                      (bytes-ref prototype 0)))))
-                 (else
-                  (let ((pdims (array:dimensions prototype)))
-                    (case (apply * pdims)
-                      ((0) (make-vector tcnt))
-                      (else (make-vector tcnt
-                                         (apply array-ref prototype
-                                                (map (lambda (x) 0) pdims))))))))))
-      (define (loop dims scales)
-        (if (null? dims)
-            (make-array:rtd dimensions (cdr scales) 0 store)
-            (loop (cdr dims) (cons (* (car dims) (car scales)) scales))))
-      (loop (reverse dimensions) '(1))))
-  
-  (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 (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-array:rtd
-          (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))))))
-  
-  (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)))
-              ((unless (eqv? (car dims) (length row))
-                 (error 'list->array
-                        "non-rectangular array ~a ~a"
-                        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)
-    (define vdx (vector-length vect))
-    (unless (eqv? vdx (apply * dimensions))
-      (error 'vector->array
-             "~a not equal to ~a" vdx (cons '* dimensions)))
-    (let ((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)
-              vect)
-            (do ((idx (sub1 (car dims)) (sub1 idx)))
-              ((negative? idx) vect)
-              (ra2v (cdr dims) (cons idx idxs)))))
-      (ra2v dims '())))
-  
-  (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-in-bounds? array . indices)
-    (array:in-bounds? array indices))
-  
-  (define (array-ref array . indices)
-    (define store (array:store array))
-    (or (array:in-bounds? array indices)
-        (error 'array-ref "bad-indices ~a" indices))
-    ((cond ((string? store)
-            string-ref)
-           ((bytes? store)
-            bytes-ref)
-           (else
-            vector-ref))
-     store (apply + (array:offset array) (map * (array:scales array) indices))))
-  
-  (define (array-set! array obj . indices)
-    (define store (array:store array))
-    (or (array:in-bounds? array indices)
-        (error 'array-set! "bad-indices ~a" indices))
-    ((cond ((string? store)
-            string-set!)
-           ((bytes? store)
-            bytes-set!)
-           (else
-            vector-set!))
-     store (apply + (array:offset array) (map * (array:scales array) indices))
-     obj))
-  
-  (define A: vector)
-  
-  (define (make-floc/c _)
-    (case-> (-> array?)
-            (-> (and/c inexact? complex?) array?)))
-  
-  (define (make-flor/c _)
-    (case-> (-> array?)
-            (-> (and/c inexact? real?) array?)))
-  
-  (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/contract
-   
-   (array? (-> 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) array?))
-   
-   (make-shared-array
-    (->r ((array array?) 
-          (mapper procedure?))
-         indices (listof natural-number/c)
-         array?))
-   
-   (list->array
-    (->r ((rank natural-number/c)
-          (proto array?)
-          (list (if (zero? rank)
-                    any/c
-                    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 ((array array?) (_ any/c)) indices 
-         (lambda _ (apply array-in-bounds? array indices)) 
-         any))
-   
-   (array-ref
-    (->r ((array array?)) indices 
-         (lambda _ (apply array-in-bounds? array indices)) 
-         any))
-   
-   (vector->array 
-    (->r ((vector vector?) (proto array?)) dimensions 
-         (lambda _ (eqv? (vector-length vector) (apply * dimensions)))
-         any))
-   
-   ;; Binary flonum complex
-   (rename A: A:floC128b (make-floc/c 128))
-   (rename A: A:floC64b  (make-floc/c  64))
-   (rename A: A:floC32b  (make-floc/c  32))
-   (rename A: A:floC16b  (make-floc/c  16))
-   
-   ;; Binary flonum real
-   (rename A: A:floR128b (make-flor/c 128))
-   (rename A: A:floR64b  (make-flor/c  64))
-   (rename A: A:floR32b  (make-flor/c  32))
-   (rename A: A:floR16b  (make-flor/c  16))
-   
-   ;; Binary fixnum
-   (rename A: A:fixZ64b (make-fix/c 64 #t))
-   (rename A: A:fixZ32b (make-fix/c 32 #t))
-   (rename A: A:fixZ16b (make-fix/c 16 #t))
-   (rename A: A:fixZ8b  (make-fix/c  8 #t))
-   (rename A: A:fixN64b (make-fix/c 64 #f))
-   (rename A: A:fixN32b (make-fix/c 32 #f))
-   (rename A: A:fixN16b (make-fix/c 16 #f))
-   (rename A: A:fixN8b  (make-fix/c  8 #f))
-   
-   ;; Boolean
-   (rename A: A:bool
-    (case-> (-> array?)
-            (-> boolean? array?))))
-  )