Quoth Peter Danenberg on Setting Orange, the 15th of Chaos:
> I've attached a patch against chicken 3, even thought it's basically a
> rewrite from scratch . . .
Whoops; I just realized, of course, that vector-lib exists in chicken
4. Here's a patch against chicken 4 with test suite, etc.
Index: tests/run.scm
===================================================================
--- tests/run.scm (revision 0)
+++ tests/run.scm (revision 0)
@@ -0,0 +1,210 @@
+(use vector-lib
+ test)
+
+(test
+ "make-vector"
+ '#(3 3 3 3 3)
+ (make-vector 5 3))
+
+(test
+ "vector"
+ '#(0 1 2 3 4)
+ (vector 0 1 2 3 4))
+
+;;; fixed; the original has #(0 -1 -2 -3 -4 -5 -6 -7 -8 -8)
+(test
+ "vector-unfold"
+ '#(0 -1 -2 -3 -4 -5 -6 -7 -8 -9)
+ (vector-unfold (lambda (i x) (values x (- x 1))) 10 0))
+
+(let ((copy-vector
+ (lambda (vector)
+ (vector-unfold (lambda (i)
+ (vector-ref vector i)) (vector-length vector)))))
+ (test
+ "vector-unfold (copy-vector)"
+ '#(1 2 3)
+ (copy-vector '#(1 2 3))))
+
+(let ((reverse-vector
+ (lambda (vector)
+ (vector-unfold-right
+ (lambda (i x)
+ (values (vector-ref vector x) (+ x 1)))
+ (vector-length vector) 0))))
+ (test
+ "vector-unfold-right (reverse-vector)"
+ '#(3 2 1)
+ (reverse-vector '#(1 2 3))))
+
+(test
+ "vector-copy"
+ '#(a b c d e f g h i)
+ (vector-copy '#(a b c d e f g h i)))
+
+(test
+ "vector-copy with start"
+ '#(g h i)
+ (vector-copy '#(a b c d e f g h i) 6))
+
+(test
+ "vector-copy with start, end"
+ '#(d e f)
+ (vector-copy '#(a b c d e f g h i) 3 6))
+
+(test
+ "vector-copy with start, end, fill"
+ '#(g h i x x x)
+ (vector-copy '#(a b c d e f g h i) 6 12 'x))
+
+(test
+ "vector-reverse-copy"
+ '#(1 2 3 4)
+ (vector-reverse-copy '#(5 4 3 2 1 0) 1 5))
+
+(test
+ "vector-append"
+ '#(a b c d)
+ (vector-append '#(a) '#(b c d)))
+
+(test
+ "vector-append with subvectors"
+ '#(a #(b) #(c))
+ (vector-append '#(a #(b)) '#(#(c))))
+
+(test
+ "vector-concatenate"
+ '#(a b c d)
+ (vector-concatenate '(#(a b) #(c d))))
+
+(test-assert
+ "vector?"
+ (vector? '#(a b c)))
+
+(test
+ "vector? on list"
+ #f
+ (vector? '(a b c)))
+
+(test
+ "vector? on boolean"
+ #f
+ (vector? #t))
+
+(test-assert
+ "vector? on null-vector"
+ (vector? '#()))
+
+(test
+ "vector? on null-list"
+ #f
+ (vector? '()))
+
+(test
+ "vector-empty? on non-empty vector"
+ #f
+ (vector-empty? '#(a)))
+
+(test
+ "vector-empty? on vector with sub-list"
+ #f
+ (vector-empty? '#(())))
+
+(test
+ "vector-empty? on vector with sub-vector"
+ #f
+ (vector-empty? '#(#())))
+
+(test-assert
+ "vector-empty? on empty vector"
+ (vector-empty? '#()))
+
+(test-assert
+ "vector= with eq?"
+ (vector= eq? '#(a b c d) '#(a b c d)))
+
+(test
+ "vector= with eq? on unequal vectors"
+ #f
+ (vector= eq? '#(a b c d) '#(a b d c)))
+
+(test
+ "vector= with = on unequal vectors"
+ #f
+ (vector= = '#(1 2 3 4 5) '#(1 2 3 4)))
+
+(test-assert
+ "vector= with ="
+ (vector= = '#(1 2 3 4) '#(1 2 3 4)))
+
+(test-assert
+ "vector= trivial medadic"
+ (vector= eq?))
+
+(test-assert
+ "vector= trivial monadic"
+ (vector= eq? '#(a)))
+
+(test
+ "vector= with eq? and vector (unequal)"
+ #f
+ (vector= eq? (vector (vector 'a))
+ (vector (vector 'a))))
+
+(test-assert
+ "vector= with eq? and vector (equal?)"
+ (vector= equal? (vector (vector 'a))
+ (vector (vector 'a))))
+
+(test
+ "vector-ref"
+ 'c
+ (vector-ref '#(a b c d)
+ 2))
+
+(test
+ "vector-length"
+ 3
+ (vector-length '#(a b c)))
+
+(let ((longest-string-length
+ (lambda (vector-of-strings)
+ (vector-fold (lambda (index len str)
+ (max (string-length str) len))
+ 0
+ vector-of-strings))))
+ (test
+ "vector-fold (longest-string-length)"
+ 3
+ (longest-string-length '#("a" "aa" "aaa"))))
+
+(let ((vector->list
+ (lambda (vector)
+ (vector-fold-right
+ (lambda (index tail elt)
+ (cons elt tail)) '() vector))))
+ (test
+ "vector-fold-right (vector->list)"
+ '(a b c d)
+ (vector->list '#(a b c d))))
+
+(test
+ "vector-map"
+ '#(1 4 9 16)
+ (vector-map (lambda (i x) (* x x))
+ (vector-unfold (lambda (i x) (values x (+ x 1))) 4 1)))
+
+(test
+ "vector-for-each"
+ "foo\nbar\nbaz\nquux\nzot\n"
+ (with-output-to-string
+ (lambda ()
+ (vector-for-each (lambda (i x) (display x) (newline))
+ '#("foo" "bar" "baz" "quux" "zot")))))
+
+(test
+ "vector-count"
+ 3
+ (vector-count (lambda (i elt) (even? elt))
+ '#(3 1 4 1 5 9 2 5 6)))
+
Index: vector-lib.setup
===================================================================
--- vector-lib.setup (revision 17003)
+++ vector-lib.setup (working copy)
@@ -1,7 +1,10 @@
-(compile -s -O2 -d2 vector-lib.scm -j vector-lib)
-(compile -s -O2 -d2 vector-lib.import.scm)
+;;; -*- Hen -*-
-(install-extension 'vector-lib
- `("vector-lib.so"
- "vector-lib.import.so")
- `((version 1.2)))
+(include "setup-helper")
+
+(verify-extension-name "vector-lib")
+
+(setup-shared-extension-module
+ 'vector-lib
+ (extension-version 1.3)
+ compile-options: '(-O2 -d1))
Index: vector-lib.scm
===================================================================
--- vector-lib.scm (revision 17003)
+++ vector-lib.scm (working copy)
@@ -1,99 +1,52 @@
-;;; SRFI 43: Vector library
-;;; Taylor Campbell's reference implementation ported to Chicken Scheme.
+;;;;;; SRFI 43: Vector library -*- Scheme -*-
+;;;
+;;; $Id: vector-lib.scm,v 1.7 2009/03/29 09:46:03 sperber Exp $
+;;;
+;;; Taylor Campbell wrote this code; he places it in the public domain.
+;;; Will Clinger [wdc] made some corrections, also in the public domain.
-;; The reference implementation now includes all fixes that were formerly
-;; applied to this file.
-
-;; These changes were made for Chicken:
-;; Removed redundant offset checks in VECTOR-COPY and VECTOR-REVERSE-COPY
-;; Import receive and let-optionals from Chicken
-;; check-type uses native type checking
-;; Procedures pass symbol, not procedure object, as callee
-;; Clean up error display on Chicken
-
-; Copyright (c) 2005, 2006, 2007, 2008 Jim Ursetto. All rights reserved.
-;
-; Redistribution and use in source and binary forms, with or without
-; modification, are permitted provided that the following conditions are met:
-;
-; Redistributions of source code must retain the above copyright notice,
-; this list of conditions and the following disclaimer. Redistributions in
-; binary form must reproduce the above copyright notice, this list of
-; conditions and the following disclaimer in the documentation and/or
-; other materials provided with the distribution. Neither the name of the
-; author nor the names of its contributors may be used to endorse or
-; promote products derived from this software without specific prior
-; written permission.
-;
-; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
-; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
-; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
-; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
-; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
-; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
-; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
-; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
-; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-(declare
- (fixnum))
-
-(cond-expand
- (paranoia)
- (else
- (declare
- (no-bound-checks))))
-
-(register-feature! 'srfi-43)
-
-;;; -------- Exported procedure index --------
-(module vector-lib
- (
+;;; --------------------
+;;; Exported procedure index
+;;;
;;; * Constructors
- ; make-vector vector
- vector-unfold vector-unfold-right
- vector-copy vector-reverse-copy
- vector-append vector-concatenate
+;;; make-vector vector
+;;; vector-unfold vector-unfold-right
+;;; vector-copy vector-reverse-copy
+;;; vector-append vector-concatenate
+;;;
;;; * Predicates
- ; vector?
- vector-empty?
- vector=
+;;; vector?
+;;; vector-empty?
+;;; vector=
+;;;
;;; * Selectors
- ; vector-ref vector-length
+;;; vector-ref
+;;; vector-length
+;;;
;;; * Iteration
- vector-fold vector-fold-right
- vector-map vector-map!
- vector-for-each
- vector-count
+;;; vector-fold vector-fold-right
+;;; vector-map vector-map!
+;;; vector-for-each
+;;; vector-count
+;;;
;;; * Searching
- vector-index vector-skip
- vector-index-right vector-skip-right
- vector-binary-search
- vector-any vector-every
+;;; vector-index vector-skip
+;;; vector-index-right vector-skip-right
+;;; vector-binary-search
+;;; vector-any vector-every
+;;;
;;; * Mutators
- ; vector-set!
- vector-swap!
- vector-fill!
- vector-reverse!
- vector-copy! vector-reverse-copy!
- vector-reverse!
+;;; vector-set!
+;;; vector-swap!
+;;; vector-fill!
+;;; vector-reverse!
+;;; vector-copy! vector-reverse-copy!
+;;; vector-reverse!
+;;;
;;; * Conversion
- vector->list reverse-vector->list
- list->vector reverse-list->vector)
+;;; vector->list reverse-vector->list
+;;; list->vector reverse-list->vector
- ;; This jujitsu with the standard bindings lets us avoid multiply-defined
- ;; messages and unconditionally overwriting standard bindings at toplevel.
- ;; It is subject to change as the Chicken module system evolves.
- (import (except scheme list->vector vector->list vector-fill!)
- (prefix (only scheme list->vector vector->list vector-fill!)
- %)
- (only chicken let-optionals receive)
- (only data-structures conc))
-
-;;; Taylor Campbell wrote this code; he places it in the public domain.
-
;;; --------------------
@@ -126,8 +79,85 @@
;;; --------------------
+;;; Chicken-specific modularization
+(module vector-lib
+(;; * Constructors
+
+make-vector vector vector-unfold vector-unfold-right vector-copy
+vector-reverse-copy vector-append vector-concatenate
+
+;; * Predicates
+
+vector? vector-empty? vector=
+
+;; * Selectors
+
+vector-ref vector-length
+
+;; * Iteration
+
+vector-fold vector-fold-right vector-map vector-map! vector-for-each
+vector-count
+
+;; * Searching
+
+vector-index vector-skip vector-index-right vector-skip-right
+vector-binary-search vector-any vector-every
+
+;; * Mutators
+
+vector-set! vector-swap! vector-fill! vector-reverse! vector-copy!
+vector-reverse-copy! vector-reverse!
+
+;; * Conversion
+
+vector->list reverse-vector->list list->vector reverse-list->vector)
+
+(import scheme chicken)
+
+;;; --------------------
;;; Utilities
+;;; SRFI 8, too trivial to put in the dependencies list.
+(define-syntax receive
+ (syntax-rules ()
+ ((receive ?formals ?producer ?body1 ?body2 ...)
+ (call-with-values (lambda () ?producer)
+ (lambda ?formals ?body1 ?body2 ...)))))
+
+;;; Not the best LET*-OPTIONALS, but not the worst, either. Use Olin's
+;;; if it's available to you.
+(define-syntax let*-optionals
+ (syntax-rules ()
+ ((let*-optionals (?x ...) ((?var ?default) ...) ?body1 ?body2 ...)
+ (let ((args (?x ...)))
+ (let*-optionals args ((?var ?default) ...) ?body1 ?body2 ...)))
+ ((let*-optionals ?args ((?var ?default) ...) ?body1 ?body2 ...)
+ (let*-optionals:aux ?args ?args ((?var ?default) ...)
+ ?body1 ?body2 ...))))
+
+(define-syntax let*-optionals:aux
+ (syntax-rules ()
+ ((aux ?orig-args-var ?args-var () ?body1 ?body2 ...)
+ (if (null? ?args-var)
+ (let () ?body1 ?body2 ...)
+ (error "too many arguments" (length ?orig-args-var)
+ ?orig-args-var)))
+ ((aux ?orig-args-var ?args-var
+ ((?var ?default) ?more ...)
+ ?body1 ?body2 ...)
+ (if (null? ?args-var)
+ (let* ((?var ?default) ?more ...) ?body1 ?body2 ...)
+ (let ((?var (car ?args-var))
+ (new-args (cdr ?args-var)))
+ (let*-optionals:aux ?orig-args-var new-args
+ (?more ...)
+ ?body1 ?body2 ...))))))
+
+(define (nonneg-int? x)
+ (and (integer? x)
+ (not (negative? x))))
+
(define (between? x y z)
(and (< x y)
(<= y z)))
@@ -165,33 +195,22 @@
;;; is. I doubt there will be many other methods of index checking,
;;; though the index checkers might be better implemented natively.
-(cond-expand [unsafe
- (eval-when (compile)
- (define-inline (check-type pred? value callee) value)
- (define-inline (check-index vec index callee) index)
- (define-inline (check-indices vec start start-name end end-name callee)
- (values start end)))]
-
-[else
-
;;; (CHECK-TYPE <type-predicate?> <value> <callee>) -> value
;;; Ensure that VALUE satisfies TYPE-PREDICATE?; if not, signal an
;;; error stating that VALUE did not satisfy TYPE-PREDICATE?, showing
;;; that this happened while calling CALLEE. Return VALUE if no
;;; error was signalled.
+(define (check-type pred? value callee)
+ (if (pred? value)
+ value
+ ;; Recur: when (or if) the user gets a debugger prompt, he can
+ ;; proceed where the call to ERROR was with the correct value.
+ (check-type pred?
+ (error "erroneous value"
+ (list pred? value)
+ `(while calling ,callee))
+ callee)))
-(import (only chicken when))
-(define-syntax check-type
- (syntax-rules (vector? integer? list? nonneg-int? procedure?)
- ((_ vector? value callee) (begin (##sys#check-vector value callee)
value))
- ((_ integer? value callee) (begin (##sys#check-exact value callee)
value))
- ((_ list? value callee) (begin (##sys#check-list value callee)
value))
- ((_ nonneg-int? value callee) (begin (##sys#check-exact value callee)
- (when (< value 0)
- (##sys#error callee "value is
negative" value))
- value))
- ((_ procedure? value callee) value)))
-
;;; (CHECK-INDEX <vector> <index> <callee>) -> index
;;; Ensure that INDEX is a valid index into VECTOR; if not, signal an
;;; error stating that it is not and that this happened in a call to
@@ -201,15 +220,17 @@
(let ((index (check-type integer? index callee)))
(cond ((< index 0)
(check-index vec
- (##sys#error callee "vector index too low"
- `(index ,index)
- `(vector ,vec))
+ (error "vector index too low"
+ index
+ `(into vector ,vec)
+ `(while calling ,callee))
callee))
((>= index (vector-length vec))
(check-index vec
- (##sys#error callee "vector index too high"
- `(index ,index)
- `(vector ,vec))
+ (error "vector index too high"
+ index
+ `(into vector ,vec)
+ `(while calling ,callee))
callee))
(else index))))
@@ -224,12 +245,13 @@
;;; while calling CALLEE. Also ensure that VEC is in fact a vector.
;;; Returns no useful value.
(define (check-indices vec start start-name end end-name callee)
- (let ((lose (lambda (why . other-info)
- (apply ##sys#error `(,callee ,(conc "vector range out of
bounds: " why)
- ,@other-info
- (,start-name ,start)
- (,end-name ,end)
- (vector ,vec)))))
+ (let ((lose (lambda things
+ (apply error "vector range out of bounds"
+ (append things
+ `(vector was ,vec)
+ `(,start-name was ,start)
+ `(,end-name was ,end)
+ `(while calling ,callee)))))
(start (check-type integer? start callee))
(end (check-type integer? end callee)))
(cond ((> start end)
@@ -252,7 +274,7 @@
((>= start (vector-length vec))
(check-indices vec
(lose `(,start-name > len)
- `(len ,(vector-length vec)))
+ `(len was ,(vector-length vec)))
start-name
end end-name
callee))
@@ -260,13 +282,12 @@
(check-indices vec
start start-name
(lose `(,end-name > len)
- `(len ,(vector-length vec)))
+ `(len was ,(vector-length vec)))
end-name
callee))
(else
(values start end)))))
-]) ;; cond-expand unsafe
;;; --------------------
@@ -301,16 +322,19 @@
(cadr args) end-name
callee))
(else
- (##sys#error callee "too many arguments" (cddr args))))))
+ (error "too many arguments"
+ `(extra args were ,(cddr args))
+ `(while calling ,callee))))))
(define-syntax let-vector-start+end
(syntax-rules ()
- ((let-vector-start+end callee vec args (start end) body1 body2 ...)
- (let ((vec (check-type vector? vec callee)))
- (receive (start end)
- (vector-parse-start+end vec args 'start 'end
- callee)
- body1 body2 ...)))))
+ ((let-vector-start+end ?callee ?vec ?args (?start ?end)
+ ?body1 ?body2 ...)
+ (let ((?vec (check-type vector? ?vec ?callee)))
+ (receive (?start ?end)
+ (vector-parse-start+end ?vec ?args '?start '?end
+ ?callee)
+ ?body1 ?body2 ...)))))
;;; (%SMALLEST-LENGTH <vector-list> <default-length> <callee>)
;;; -> exact, nonnegative integer
@@ -388,6 +412,7 @@
(- send 1)
tstart))))
+;;; (%VECTOR-REVERSE! <vector>)
(define %vector-reverse!
(letrec ((loop (lambda (vec i j)
(cond ((<= i j)
@@ -398,6 +423,8 @@
(lambda (vec start end)
(loop vec start (- end 1)))))
+;;; (%VECTOR-FOLD1 <kons> <knil> <vector>) -> knil'
+;;; (KONS <index> <knil> <elt>) -> knil'
(define %vector-fold1
(letrec ((loop (lambda (kons knil len vec i)
(if (= i len)
@@ -408,6 +435,8 @@
(lambda (kons knil len vec)
(loop kons knil len vec 0))))
+;;; (%VECTOR-FOLD2+ <kons> <knil> <vector> ...) -> knil'
+;;; (KONS <index> <knil> <elt> ...) -> knil'
(define %vector-fold2+
(letrec ((loop (lambda (kons knil len vectors i)
(if (= i len)
@@ -419,6 +448,8 @@
(lambda (kons knil len vectors)
(loop kons knil len vectors 0))))
+;;; (%VECTOR-MAP! <f> <target> <length> <vector>) -> target
+;;; (F <index> <elt>) -> elt'
(define %vector-map1!
(letrec ((loop (lambda (f target vec i)
(if (zero? i)
@@ -430,6 +461,8 @@
(lambda (f target vec len)
(loop f target vec len))))
+;;; (%VECTOR-MAP2+! <f> <target> <vectors> <len>) -> target
+;;; (F <index> <elt> ...) -> elt'
(define %vector-map2+!
(letrec ((loop (lambda (f target vectors i)
(if (zero? i)
@@ -452,11 +485,11 @@
;;; [R5RS] Create a vector of length LENGTH. If FILL is present,
;;; initialize each slot in the vector with it; if not, the vector's
;;; initial contents are unspecified.
-; (define make-vector make-vector)
+(define make-vector make-vector)
;;; (VECTOR <elt> ...) -> vector
;;; [R5RS] Create a vector containing ELEMENT ..., in order.
-; (define vector vector)
+(define vector vector)
;;; This ought to be able to be implemented much more efficiently -- if
;;; we have the number of arguments available to us, we can create the
@@ -492,8 +525,8 @@
(vector-set! vec i elt)
(unfold2+! f vec (+ i 1) len new-seeds))))))
(lambda (f len . initial-seeds)
- (let ((f (check-type procedure? f 'vector-unfold))
- (len (check-type nonneg-int? len 'vector-unfold)))
+ (let ((f (check-type procedure? f vector-unfold))
+ (len (check-type nonneg-int? len vector-unfold)))
(let ((vec (make-vector len)))
(cond ((null? initial-seeds)
(tabulate! f vec 0 len))
@@ -504,7 +537,7 @@
vec)))))
;;; (VECTOR-UNFOLD-RIGHT <f> <length> <initial-seed> ...) -> vector
-;;; (F <index> <seed> ...) -> [seed' ...]
+;;; (F <seed> ...) -> [seed' ...]
;;; Like VECTOR-UNFOLD, but it generates elements from LENGTH to 0
;;; (still exclusive with LENGTH and inclusive with 0), not 0 to
;;; LENGTH as with VECTOR-UNFOLD.
@@ -529,8 +562,8 @@
(vector-set! vec i elt)
(unfold2+! f vec (- i 1) new-seeds))))))
(lambda (f len . initial-seeds)
- (let ((f (check-type procedure? f 'vector-unfold-right))
- (len (check-type nonneg-int? len 'vector-unfold-right)))
+ (let ((f (check-type procedure? f vector-unfold-right))
+ (len (check-type nonneg-int? len vector-unfold-right)))
(let ((vec (make-vector len))
(i (- len 1)))
(cond ((null? initial-seeds)
@@ -549,7 +582,7 @@
;;; the new locations from which there is no respective element in
;;; VECTOR are filled with FILL.
(define (vector-copy vec . args)
- (let ((vec (check-type vector? vec 'vector-copy)))
+ (let ((vec (check-type vector? vec vector-copy)))
;; We can't use LET-VECTOR-START+END, because we have one more
;; argument, and we want finer control, too.
;;
@@ -567,33 +600,33 @@
new-vector))))
;;; Auxiliary for VECTOR-COPY.
+;;; [wdc] Corrected to allow 0 <= start <= (vector-length vec).
(define (vector-copy:parse-args vec args)
- (if (null? args)
- (values 0 (vector-length vec) (unspecified-value))
- (let ((start (check-index vec (car args) 'vector-copy)))
- (if (null? (cdr args))
- (values start (vector-length vec) (unspecified-value))
- (let ((end (check-type nonneg-int? (cadr args)
- 'vector-copy)))
- (cond ((>= start (vector-length vec))
- (##sys#error 'vector-copy "start bound out of bounds"
- `(start ,start)
- `(end ,end)
- `(vector ,vec)))
- ((> start end)
- (##sys#error 'vector-copy "can't invert a vector copy!"
- `(start ,start)
- `(end ,end)
- `(vector ,vec)))
- ((null? (cddr args))
- (values start end (unspecified-value)))
- (else
- (let ((fill (caddr args)))
- (if (null? (cdddr args))
- (values start end fill)
- (##sys#error 'vector-copy
- "too many arguments"
- (cdddr args)))))))))))
+ (define (parse-args start end n fill)
+ (let ((start (check-type nonneg-int? start vector-copy))
+ (end (check-type nonneg-int? end vector-copy)))
+ (cond ((and (<= 0 start end)
+ (<= start n))
+ (values start end fill))
+ (else
+ (error "illegal arguments"
+ `(while calling ,vector-copy)
+ `(start was ,start)
+ `(end was ,end)
+ `(vector was ,vec))))))
+ (let ((n (vector-length vec)))
+ (cond ((null? args)
+ (parse-args 0 n n (unspecified-value)))
+ ((null? (cdr args))
+ (parse-args (car args) n n (unspecified-value)))
+ ((null? (cddr args))
+ (parse-args (car args) (cadr args) n (unspecified-value)))
+ ((null? (cdddr args))
+ (parse-args (car args) (cadr args) n (caddr args)))
+ (else
+ (error "too many arguments"
+ vector-copy
+ (cdddr args))))))
;;; (VECTOR-REVERSE-COPY <vector> [<start> <end>]) -> vector
;;; Create a newly allocated vector whose elements are the reversed
@@ -666,13 +699,13 @@
;;; (VECTOR? <value>) -> boolean
;;; [R5RS] Return #T if VALUE is a vector and #F if not.
-;(define vector? vector?)
+(define vector? vector?)
;;; (VECTOR-EMPTY? <vector>) -> boolean
;;; Return #T if VECTOR has zero elements in it, i.e. VECTOR's length
;;; is 0, and #F if not.
(define (vector-empty? vec)
- (let ((vec (check-type vector? vec 'vector-empty?)))
+ (let ((vec (check-type vector? vec vector-empty?)))
(zero? (vector-length vec))))
;;; (VECTOR= <elt=?> <vector> ...) -> boolean
@@ -696,15 +729,15 @@
;;; are compared. The precise order in which ELT=? is applied is not
;;; specified.
(define (vector= elt=? . vectors)
- (let ((elt=? (check-type procedure? elt=? 'vector=)))
+ (let ((elt=? (check-type procedure? elt=? vector=)))
(cond ((null? vectors)
#t)
((null? (cdr vectors))
- (check-type vector? (car vectors) 'vector=)
+ (check-type vector? (car vectors) vector=)
#t)
(else
(let loop ((vecs vectors))
- (let ((vec1 (check-type vector? (car vecs) 'vector=))
+ (let ((vec1 (check-type vector? (car vecs) vector=))
(vec2+ (cdr vecs)))
(or (null? vec2+)
(and (binary-vector= elt=? vec1 (car vec2+))
@@ -734,11 +767,11 @@
;;; (VECTOR-REF <vector> <index>) -> value
;;; [R5RS] Return the value that the location in VECTOR at INDEX is
;;; mapped to in the store.
-; (define vector-ref vector-ref)
+(define vector-ref vector-ref)
;;; (VECTOR-LENGTH <vector>) -> exact, nonnegative integer
;;; [R5RS] Return the length of VECTOR.
-; (define vector-length vector-length)
+(define vector-length vector-length)
@@ -759,8 +792,8 @@
;;; <=>
;;; (KONS (... (KONS (KONS KNIL E_1) E_2) ... E_N-1) E_N)
(define (vector-fold kons knil vec . vectors)
- (let ((kons (check-type procedure? kons 'vector-fold))
- (vec (check-type vector? vec 'vector-fold)))
+ (let ((kons (check-type procedure? kons vector-fold))
+ (vec (check-type vector? vec vector-fold)))
(if (null? vectors)
(%vector-fold1 kons knil (vector-length vec) vec)
(%vector-fold2+ kons knil
@@ -798,8 +831,8 @@
vectors
(- i 1))))))
(lambda (kons knil vec . vectors)
- (let ((kons (check-type procedure? kons 'vector-fold-right))
- (vec (check-type vector? vec 'vector-fold-right)))
+ (let ((kons (check-type procedure? kons vector-fold-right))
+ (vec (check-type vector? vec vector-fold-right)))
(if (null? vectors)
(loop1 kons knil vec (- (vector-length vec) 1))
(loop2+ kons knil (cons vec vectors)
@@ -815,8 +848,8 @@
;;; from the old vectors by (F I (vector-ref VECTOR I) ...). The
;;; dynamic order of application of F is unspecified.
(define (vector-map f vec . vectors)
- (let ((f (check-type procedure? f 'vector-map))
- (vec (check-type vector? vec 'vector-map)))
+ (let ((f (check-type procedure? f vector-map))
+ (vec (check-type vector? vec vector-map)))
(if (null? vectors)
(let ((len (vector-length vec)))
(%vector-map1! f (make-vector len) vec len))
@@ -834,8 +867,8 @@
;;; application of F is unspecified, so it is dangerous for F to
;;; manipulate the first VECTOR.
(define (vector-map! f vec . vectors)
- (let ((f (check-type procedure? f 'vector-map!))
- (vec (check-type vector? vec 'vector-map!)))
+ (let ((f (check-type procedure? f vector-map!))
+ (vec (check-type vector? vec vector-map!)))
(if (null? vectors)
(%vector-map1! f vec vec (vector-length vec))
(%vector-map2+! f vec (cons vec vectors)
@@ -864,8 +897,8 @@
(apply f i (vectors-ref vecs i))
(for-each2+ f vecs (+ i 1) len))))))
(lambda (f vec . vectors)
- (let ((f (check-type procedure? f 'vector-for-each))
- (vec (check-type vector? vec 'vector-for-each)))
+ (let ((f (check-type procedure? f vector-for-each))
+ (vec (check-type vector? vec vector-for-each)))
(if (null? vectors)
(for-each1 f vec 0 (vector-length vec))
(for-each2+ f (cons vec vectors) 0
@@ -880,8 +913,8 @@
;;; and a count is tallied of the number of elements for which a
;;; true value is produced by PREDICATE?. This count is returned.
(define (vector-count pred? vec . vectors)
- (let ((pred? (check-type procedure? pred? 'vector-count))
- (vec (check-type vector? vec 'vector-count)))
+ (let ((pred? (check-type procedure? pred? vector-count))
+ (vec (check-type vector? vec vector-count)))
(if (null? vectors)
(%vector-fold1 (lambda (index count elt)
(if (pred? index elt)
@@ -994,7 +1027,7 @@
;;; Perform a binary search through VECTOR for VALUE, comparing each
;;; element to VALUE with CMP.
(define (vector-binary-search vec value cmp . maybe-start+end)
- (let ((cmp (check-type procedure? cmp 'vector-binary-search)))
+ (let ((cmp (check-type procedure? cmp vector-binary-search)))
(let-vector-start+end vector-binary-search vec maybe-start+end
(start end)
(let loop ((start start) (end end) (j #f))
@@ -1004,7 +1037,7 @@
(let ((comparison
(check-type integer?
(cmp (vector-ref vec i) value)
- 'vector-binary-search:cmp)))
+ `(,cmp for ,vector-binary-search))))
(cond ((zero? comparison) i)
((positive? comparison) (loop start i i))
(else (loop i end i))))))))))
@@ -1031,8 +1064,8 @@
(loop2+ pred? vectors (+ i 1)
len len-1)))))))
(lambda (pred? vec . vectors)
- (let ((pred? (check-type procedure? pred? 'vector-any))
- (vec (check-type vector? vec 'vector-any)))
+ (let ((pred? (check-type procedure? pred? vector-any))
+ (vec (check-type vector? vec vector-any)))
(if (null? vectors)
(let ((len (vector-length vec)))
(loop1 pred? vec 0 len (- len 1)))
@@ -1065,8 +1098,8 @@
(loop2+ pred? vectors (+ i 1)
len len-1)))))))
(lambda (pred? vec . vectors)
- (let ((pred? (check-type procedure? pred? 'vector-every))
- (vec (check-type vector? vec 'vector-every)))
+ (let ((pred? (check-type procedure? pred? vector-every))
+ (vec (check-type vector? vec vector-every)))
(if (null? vectors)
(let ((len (vector-length vec)))
(loop1 pred? vec 0 len (- len 1)))
@@ -1082,14 +1115,14 @@
;;; (VECTOR-SET! <vector> <index> <value>) -> unspecified
;;; [R5RS] Assign the location at INDEX in VECTOR to VALUE.
-; (define vector-set! vector-set!)
+(define vector-set! vector-set!)
;;; (VECTOR-SWAP! <vector> <index1> <index2>) -> unspecified
;;; Swap the values in the locations at INDEX1 and INDEX2.
(define (vector-swap! vec i j)
- (let ((vec (check-type vector? vec 'vector-swap!)))
- (let ((i (check-index vec i 'vector-swap!))
- (j (check-index vec j 'vector-swap!)))
+ (let ((vec (check-type vector? vec vector-swap!)))
+ (let ((i (check-index vec i vector-swap!))
+ (j (check-index vec j vector-swap!)))
(let ((x (vector-ref vec i)))
(vector-set! vec i (vector-ref vec j))
(vector-set! vec j x)))))
@@ -1100,52 +1133,96 @@
;;;
;;; This one can probably be made really fast natively.
(define vector-fill!
- (lambda (vec value . maybe-start+end)
- (if (null? maybe-start+end)
- (%vector-fill! vec value) ;+++
- (let-vector-start+end vector-fill! vec maybe-start+end
- (start end)
- (do ((i start (+ i 1)))
- ((= i end))
- (vector-set! vec i value))))))
+ (let ((%vector-fill! vector-fill!)) ; Take the native one, under
+ ; the assumption that it's
+ ; faster, so we can use it if
+ ; there are no optional
+ ; arguments.
+ (lambda (vec value . maybe-start+end)
+ (if (null? maybe-start+end)
+ (%vector-fill! vec value) ;+++
+ (let-vector-start+end vector-fill! vec maybe-start+end
+ (start end)
+ (do ((i start (+ i 1)))
+ ((= i end))
+ (vector-set! vec i value)))))))
;;; (VECTOR-COPY! <target> <tstart> <source> [<sstart> <send>])
;;; -> unspecified
-;;; Copy the values in the locations in [SSTART,SEND) from SOURCE
+;;; Copy the values in the locations in [SSTART,SEND) from SOURCE to
;;; to TARGET, starting at TSTART in TARGET.
-;; (Note: removed start+end offset checks that can never be triggered,
-;; as the checks are already done in let-vector-start+end.)
+;;; [wdc] Corrected to allow 0 <= sstart <= send <= (vector-length source).
(define (vector-copy! target tstart source . maybe-sstart+send)
- (let* ((target (check-type vector? target 'vector-copy!))
- (tstart (check-index target tstart 'vector-copy!)))
- (let-vector-start+end vector-copy! source maybe-sstart+send
- (sstart send)
- (%vector-copy! target tstart source sstart send))))
+ (define (doit! sstart send source-length)
+ (let ((tstart (check-type nonneg-int? tstart vector-copy!))
+ (sstart (check-type nonneg-int? sstart vector-copy!))
+ (send (check-type nonneg-int? send vector-copy!)))
+ (cond ((and (<= 0 sstart send source-length)
+ (<= (+ tstart (- send sstart)) (vector-length target)))
+ (%vector-copy! target tstart source sstart send))
+ (else
+ (error "illegal arguments"
+ `(while calling ,vector-copy!)
+ `(target was ,target)
+ `(target-length was ,(vector-length target))
+ `(tstart was ,tstart)
+ `(source was ,source)
+ `(source-length was ,source-length)
+ `(sstart was ,sstart)
+ `(send was ,send))))))
+ (let ((n (vector-length source)))
+ (cond ((null? maybe-sstart+send)
+ (doit! 0 n n))
+ ((null? (cdr maybe-sstart+send))
+ (doit! (car maybe-sstart+send) n n))
+ ((null? (cddr maybe-sstart+send))
+ (doit! (car maybe-sstart+send) (cadr maybe-sstart+send) n))
+ (else
+ (error "too many arguments"
+ vector-copy!
+ (cddr maybe-sstart+send))))))
;;; (VECTOR-REVERSE-COPY! <target> <tstart> <source> [<sstart> <send>])
-;; (Note: removed start+end offset checks that can never be triggered,
-;; as the checks are already done in let-vector-start+end.)
+;;; [wdc] Corrected to allow 0 <= sstart <= send <= (vector-length source).
(define (vector-reverse-copy! target tstart source . maybe-sstart+send)
- (let* ((target (check-type vector? target 'vector-reverse-copy!))
- (tstart (check-index target tstart 'vector-reverse-copy!)))
- (let-vector-start+end vector-reverse-copy source maybe-sstart+send
- (sstart send)
+ (define (doit! sstart send source-length)
+ (let ((tstart (check-type nonneg-int? tstart vector-reverse-copy!))
+ (sstart (check-type nonneg-int? sstart vector-reverse-copy!))
+ (send (check-type nonneg-int? send vector-reverse-copy!)))
(cond ((and (eq? target source)
- (= sstart tstart))
- (%vector-reverse! target tstart send))
- ((and (eq? target source)
(or (between? sstart tstart send)
- (between? sstart (+ tstart (- send sstart))
- send)))
- (##sys#error 'vector-reverse-copy!
- "vector range for self-copying overlaps"
- `(vector ,target)
- `(tstart ,tstart)
- `(sstart ,sstart)
- `(send ,send)))
+ (between? tstart sstart
+ (+ tstart (- send sstart)))))
+ (error "vector range for self-copying overlaps"
+ vector-reverse-copy!
+ `(vector was ,target)
+ `(tstart was ,tstart)
+ `(sstart was ,sstart)
+ `(send was ,send)))
+ ((and (<= 0 sstart send source-length)
+ (<= (+ tstart (- send sstart)) (vector-length target)))
+ (%vector-reverse-copy! target tstart source sstart send))
(else
- (%vector-reverse-copy! target tstart
- source sstart send))))))
+ (error "illegal arguments"
+ `(while calling ,vector-reverse-copy!)
+ `(target was ,target)
+ `(target-length was ,(vector-length target))
+ `(tstart was ,tstart)
+ `(source was ,source)
+ `(source-length was ,source-length)
+ `(sstart was ,sstart)
+ `(send was ,send))))))
+ (let ((n (vector-length source)))
+ (cond ((null? maybe-sstart+send)
+ (doit! 0 n n))
+ ((null? (cdr maybe-sstart+send))
+ (doit! (car maybe-sstart+send) n n))
+ ((null? (cddr maybe-sstart+send))
+ (doit! (car maybe-sstart+send) (cadr maybe-sstart+send) n))
+ (else
+ (error "too many arguments"
+ vector-reverse-copy!
+ (cddr maybe-sstart+send))))))
;;; (VECTOR-REVERSE! <vector> [<start> <end>]) -> unspecified
;;; Destructively reverse the contents of the sequence of locations
@@ -1166,19 +1243,20 @@
;;; between START, whose default is 0, and END, whose default is the
;;; length of VECTOR, from VECTOR.
(define vector->list
- (lambda (vec . maybe-start+end)
- (if (null? maybe-start+end) ; Oughta use CASE-LAMBDA.
- (%vector->list vec) ;+++
- (let-vector-start+end
- vector->list vec maybe-start+end (start end)
- ;;(unfold (lambda (i) ; No SRFI 1.
- ;; (< i start))
- ;; (lambda (i) (vector-ref vec i))
- ;; (lambda (i) (- i 1))
- ;; (- end 1))
- (do ((i (- end 1) (- i 1))
- (result '() (cons (vector-ref vec i) result)))
- ((< i start) result))))))
+ (let ((%vector->list vector->list))
+ (lambda (vec . maybe-start+end)
+ (if (null? maybe-start+end) ; Oughta use CASE-LAMBDA.
+ (%vector->list vec) ;+++
+ (let-vector-start+end vector->list vec maybe-start+end
+ (start end)
+ ;(unfold (lambda (i) ; No SRFI 1.
+ ; (< i start))
+ ; (lambda (i) (vector-ref vec i))
+ ; (lambda (i) (- i 1))
+ ; (- end 1))
+ (do ((i (- end 1) (- i 1))
+ (result '() (cons (vector-ref vec i) result)))
+ ((< i start) result)))))))
;;; (REVERSE-VECTOR->LIST <vector> [<start> <end>]) -> list
;;; Produce a list containing the elements in the locations between
@@ -1201,38 +1279,47 @@
;;; whose default is the length of LIST. It is suggested that if the
;;; length of LIST is known in advance, the START and END arguments
;;; be passed, so that LIST->VECTOR need not call LENGTH to determine
-;;; the length.
+;;; the the length.
;;;
;;; This implementation diverges on circular lists, unless LENGTH fails
;;; and causes - to fail as well. Given a LENGTH* that computes the
;;; length of a list's cycle, this wouldn't diverge, and would work
;;; great for circular lists.
-
(define list->vector
- (lambda (lst . maybe-start+end)
- ;; Checking the type of a proper list is expensive, so we do it
- ;; amortizedly, or let %LIST->VECTOR or LIST-TAIL do it.
- (if (null? maybe-start+end) ; Oughta use CASE-LAMBDA.
- (%list->vector lst) ;+++
- ;; We can't use LET-VECTOR-START+END, because we're using the
- ;; bounds of a _list_, not a vector.
- (let ((lst (check-type list? lst 'list->vector)))
- (let-optionals maybe-start+end
- ((start 0)
- (end (length lst))) ; Ugh -- LENGTH
- (let ((start (check-type nonneg-int? start
'list->vector))
- (end (check-type nonneg-int? end
'list->vector)))
- ((lambda (f)
- (vector-unfold f (- end start) (list-tail lst
start)))
- (lambda (index l)
- (cond ((null? l)
- (##sys#error 'list->vector "list too
short"
- `(list ,lst)
- `(attempted end ,end)))
- ((pair? l)
- (values (car l) (cdr l)))
- (else
- (##sys#not-a-proper-list-error lst
'list->vector)))))))))))
+ (let ((%list->vector list->vector))
+ (lambda (lst . maybe-start+end)
+ ;; Checking the type of a proper list is expensive, so we do it
+ ;; amortizedly, or let %LIST->VECTOR or LIST-TAIL do it.
+ (if (null? maybe-start+end) ; Oughta use CASE-LAMBDA.
+ (%list->vector lst) ;+++
+ ;; We can't use LET-VECTOR-START+END, because we're using the
+ ;; bounds of a _list_, not a vector.
+ (let*-optionals maybe-start+end
+ ((start 0)
+ (end (length lst))) ; Ugh -- LENGTH
+ (let ((start (check-type nonneg-int? start list->vector))
+ (end (check-type nonneg-int? end list->vector)))
+ ((lambda (f)
+ (vector-unfold f (- end start) (list-tail lst start)))
+ (lambda (index l)
+ (cond ((null? l)
+ (error "list was too short"
+ `(list was ,lst)
+ `(attempted end was ,end)
+ `(while calling ,list->vector)))
+ ((pair? l)
+ (values (car l) (cdr l)))
+ (else
+ ;; Make this look as much like what CHECK-TYPE
+ ;; would report as possible.
+ (error "erroneous value"
+ ;; We want SRFI 1's PROPER-LIST?, but it
+ ;; would be a waste to link all of SRFI
+ ;; 1 to this module for only the single
+ ;; function PROPER-LIST?.
+ (list list? lst)
+ `(while calling
+ ,list->vector))))))))))))
;;; (REVERSE-LIST->VECTOR <list> [<start> <end>]) -> vector
;;; Produce a vector containing the elements in LIST, which must be a
@@ -1245,19 +1332,24 @@
;;; This also diverges on circular lists unless, again, LENGTH returns
;;; something that makes - bork.
(define (reverse-list->vector lst . maybe-start+end)
- (let-optionals maybe-start+end
+ (let*-optionals maybe-start+end
((start 0)
(end (length lst))) ; Ugh -- LENGTH
- (let ((start (check-type nonneg-int? start 'reverse-list->vector))
- (end (check-type nonneg-int? end 'reverse-list->vector)))
+ (let ((start (check-type nonneg-int? start reverse-list->vector))
+ (end (check-type nonneg-int? end reverse-list->vector)))
((lambda (f)
(vector-unfold-right f (- end start) (list-tail lst start)))
(lambda (index l)
(cond ((null? l)
- (##sys#error 'reverse-list->vector "list too short"
- `(list ,lst)
- `(attempted end ,end)))
+ (error "list too short"
+ `(list was ,lst)
+ `(attempted end was ,end)
+ `(while calling ,reverse-list->vector)))
((pair? l)
(values (car l) (cdr l)))
(else
- (##sys#not-a-proper-list-error lst
'reverse-list->vector)))))))))
+ (error "erroneous value"
+ (list list? lst)
+ `(while calling ,reverse-list->vector)))))))))
+
+)
Index: vector-lib.meta
===================================================================
--- vector-lib.meta (revision 17003)
+++ vector-lib.meta (working copy)
@@ -1,9 +1,11 @@
;;; vector-lib.meta -*- Hen -*-
((egg "vector-lib.egg")
- (files "vector-lib.scm" "vector-lib.html" "vector-lib.setup")
+ (files "vector-lib.scm" "vector-lib.setup" "TODO")
(doc-from-wiki)
(category data)
(synopsis
- "Port of the SRFI-43 reference implementation")
- (license "BSD")
- (author "Taylor Campbell"))
+ "A port of the reference implementation of SRFI-43")
+ (license "Artistic")
+ (test-depends test)
+ (author
+ "Taylor Campbell; ported from scratch to hygienic Chicken with test suite
by Peter Danenberg."))
_______________________________________________
Chicken-users mailing list
[email protected]
http://lists.nongnu.org/mailman/listinfo/chicken-users
