diff --git a/collects/srfi/43/vector-lib.ss b/collects/srfi/43/vector-lib.ss index a63a3ba17e..8f354adbf7 100644 --- a/collects/srfi/43/vector-lib.ss +++ b/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?) - (end nonneg-int?)) + (start natural-number/c) + (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?) - (send nonneg-int?)) + (sstart natural-number/c) + (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 ( 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?) - (end nonneg-int?)) + (start natural-number/c) + (end natural-number/c)) (<= start end (vector-length vec)) any))) (vector-reverse! (vec-start-end-contract mutable-vector/c)) diff --git a/collects/srfi/63.ss b/collects/srfi/63.ss deleted file mode 100644 index 313b7e02bf..0000000000 --- a/collects/srfi/63.ss +++ /dev/null @@ -1,3 +0,0 @@ -(module |63| mzscheme - (require (lib "63.ss" "srfi" "63")) - (provide (all-from (lib "63.ss" "srfi" "63")))) \ No newline at end of file diff --git a/collects/srfi/63/63.ss b/collects/srfi/63/63.ss deleted file mode 100644 index 29a16b1635..0000000000 --- a/collects/srfi/63/63.ss +++ /dev/null @@ -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?)))) - ) \ No newline at end of file