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 17002) +++ vector-lib.setup (working copy) @@ -1,14 +1,10 @@ +;;; -*- Hen -*- -(define has-exports? (string>=? (chicken-version) "2.310")) +(include "setup-helper") -(compile -s -O2 -d1 - ,@(if has-exports? '(-check-imports -emit-exports vector-lib.exports) '()) - vector-lib.scm) +(verify-extension-name "vector-lib") -(install-extension 'vector-lib - `("vector-lib.so" - "vector-lib.html" - ,@(if has-exports? '("vector-lib.exports") '()) ) - `((version 1.2) - ,@(if has-exports? `((exports "vector-lib.exports")) '()) - (documentation "vector-lib.html") ) ) +(setup-shared-extension-module + 'vector-lib + (extension-version 1.3) + compile-options: '(-O2 -d1)) Index: TODO =================================================================== --- TODO (revision 0) +++ TODO (revision 0) @@ -0,0 +1,20 @@ +# -*- mode: org; -*- +* TODO redefinitions + should we remove gratuitous redefinitions of standard bindings such + as receive? +* TODO untested functions + - vector-map! + - vector-index-right + - vector-skip-right + - vector-any + - vector-every + - vector-set! + - vector-swap! + - vector-fill! + - vector-reverse! + - vector-copy! + - vector-reverse-copy! + - vector->list + - reverse-vector->list + - list->vector + - reverse-list->vector Index: vector-lib.scm =================================================================== --- vector-lib.scm (revision 17002) +++ vector-lib.scm (working copy) @@ -1,91 +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 -;; Removed receive and let-optionals* macros (defined natively in Chicken) -;; Converted let-vector-start+end from define-syntax to define-macro -;; 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) - (not standard-bindings vector-fill! vector->list list->vector) - -;;; -------- Exported procedure index -------- - (export +;;; -------------------- +;;; 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 -(cond-expand - (paranoia) - (else - (declare - (no-bound-checks)))) - -(register-feature! 'srfi-43) - -;;; Taylor Campbell wrote this code; he places it in the public domain. - ;;; -------------------- @@ -118,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))) @@ -157,30 +195,21 @@ ;;; 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-macro (check-type pred? value callee) value) - (define-macro (check-index vec index callee) index) - (define-macro (check-indices vec start start-name end end-name callee) (values start end)))] - -[else - ;;; (CHECK-TYPE ) -> 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-macro (check-type pred? value callee) - (cond ((eq? pred? 'vector?) `(begin (##sys#check-vector ,value ,callee) ,value)) - ((eq? pred? 'nonneg-int?) `(begin (##sys#check-exact ,value ,callee) - (when (fx< ,value 0) - (##sys#error ,callee "value is negative" ,value)) - ,value)) - ((eq? pred? 'integer?) `(begin (##sys#check-exact ,value ,callee) ,value)) - ((eq? pred? 'list?) `(begin (##sys#check-list ,value ,callee) ,value)) - ((eq? pred? 'procedure?) value) - (else - (##sys#error 'check-type "invalid predicate" pred?)))) +(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))) ;;; (CHECK-INDEX ) -> index ;;; Ensure that INDEX is a valid index into VECTOR; if not, signal an @@ -191,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)))) @@ -214,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) @@ -242,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)) @@ -250,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 ;;; -------------------- @@ -291,18 +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-macro (let-vector-start+end callee vec args start+end . body) - (if (or (not (pair? start+end)) - (not (null? (cddr start+end)))) - (##sys#error 'let-vector-start+end "start+end must be a 2-element list" start+end) - (let ((start (car start+end)) - (end (cadr start+end))) - `(let ((,vec (check-type vector? ,vec ',callee))) - (receive (,start ,end) - (vector-parse-start+end ,vec ,args ',start ',end ',callee) - ,@body))))) +(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 ...))))) ;;; (%SMALLEST-LENGTH ) ;;; -> exact, nonnegative integer @@ -380,6 +412,7 @@ (- send 1) tstart)))) +;;; (%VECTOR-REVERSE! ) (define %vector-reverse! (letrec ((loop (lambda (vec i j) (cond ((<= i j) @@ -390,6 +423,8 @@ (lambda (vec start end) (loop vec start (- end 1))))) +;;; (%VECTOR-FOLD1 ) -> knil' +;;; (KONS ) -> knil' (define %vector-fold1 (letrec ((loop (lambda (kons knil len vec i) (if (= i len) @@ -400,6 +435,8 @@ (lambda (kons knil len vec) (loop kons knil len vec 0)))) +;;; (%VECTOR-FOLD2+ ...) -> knil' +;;; (KONS ...) -> knil' (define %vector-fold2+ (letrec ((loop (lambda (kons knil len vectors i) (if (= i len) @@ -411,6 +448,8 @@ (lambda (kons knil len vectors) (loop kons knil len vectors 0)))) +;;; (%VECTOR-MAP! ) -> target +;;; (F ) -> elt' (define %vector-map1! (letrec ((loop (lambda (f target vec i) (if (zero? i) @@ -422,6 +461,8 @@ (lambda (f target vec len) (loop f target vec len)))) +;;; (%VECTOR-MAP2+! ) -> target +;;; (F ...) -> elt' (define %vector-map2+! (letrec ((loop (lambda (f target vectors i) (if (zero? i) @@ -444,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 ...) -> 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 @@ -484,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)) @@ -496,7 +537,7 @@ vec))))) ;;; (VECTOR-UNFOLD-RIGHT ...) -> vector -;;; (F ...) -> [seed' ...] +;;; (F ...) -> [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. @@ -521,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) @@ -541,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. ;; @@ -559,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 ;;; Create a newly allocated vector whose elements are the reversed @@ -658,13 +699,13 @@ ;;; (VECTOR? ) -> boolean ;;; [R5RS] Return #T if VALUE is a vector and #F if not. -;(define vector? vector?) +(define vector? vector?) ;;; (VECTOR-EMPTY? ) -> 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= ...) -> boolean @@ -688,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+)) @@ -726,11 +767,11 @@ ;;; (VECTOR-REF ) -> 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 ) -> exact, nonnegative integer ;;; [R5RS] Return the length of VECTOR. -; (define vector-length vector-length) +(define vector-length vector-length) @@ -751,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 @@ -790,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) @@ -807,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)) @@ -826,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) @@ -856,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 @@ -872,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) @@ -986,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)) @@ -996,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)))))))))) @@ -1023,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))) @@ -1057,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))) @@ -1074,14 +1115,14 @@ ;;; (VECTOR-SET! ) -> unspecified ;;; [R5RS] Assign the location at INDEX in VECTOR to VALUE. -; (define vector-set! vector-set!) +(define vector-set! vector-set!) ;;; (VECTOR-SWAP! ) -> 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))))) @@ -1108,41 +1149,80 @@ ;;; (VECTOR-COPY! [ ]) ;;; -> 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! [ ]) -;; (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! [ ]) -> unspecified ;;; Destructively reverse the contents of the sequence of locations @@ -1199,13 +1279,12 @@ ;;; 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 (let ((%list->vector list->vector)) (lambda (lst . maybe-start+end) @@ -1215,23 +1294,32 @@ (%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*-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 [ ]) -> vector ;;; Produce a vector containing the elements in LIST, which must be a @@ -1244,20 +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 17002) +++ vector-lib.meta (working copy) @@ -1,10 +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 - "A port of the reference implementation of SRFI-43 with additions and fixes") + "A port of the reference implementation of SRFI-43") (license "Artistic") + (test-depends test) (author - "Taylor Campbell, with CHICKEN-specific modifications by William S. Annis. Adapted to final version and bugs fixed by Zbigniew Szadkowski")) + "Taylor Campbell; ported from scratch to hygienic Chicken with test suite by Peter Danenberg."))