Changeset 7340 in project
- Timestamp:
- 01/12/08 20:45:59 (12 years ago)
- Location:
- vector-lib
- Files:
-
- 2 edited
Legend:
- Unmodified
- Added
- Removed
-
vector-lib/vector-lib.scm
r404 r7340 1 1 ;;; SRFI 43: Vector library 2 2 ;;; Taylor Campbell's reference implementation ported to Chicken Scheme. 3 ;;; $Id: vector-lib.scm,v 1.8 2005/05/25 16:26:44 zb Exp zb $ 4 5 ; ----------------------------TERMS OF USE-------------------------------- 6 ; Copyright (c) 2005, Zbigniew Szadkowski. All rights reserved. 3 4 ;; The reference implementation now includes all fixes that were formerly 5 ;; applied to this file. 6 7 ;; These changes were made for Chicken: 8 ;; Removed redundant offset checks in VECTOR-COPY and VECTOR-REVERSE-COPY 9 ;; Removed receive and let-optionals* macros (defined natively in Chicken) 10 ;; Converted let-vector-start+end from define-syntax to define-macro 11 ;; check-type uses native type checking 12 ;; Procedures pass symbol, not procedure object, as callee 13 ;; Clean up error display on Chicken 14 15 ; Copyright (c) 2005, 2006, 2007, 2008 Jim Ursetto. All rights reserved. 7 16 ; 8 17 ; Redistribution and use in source and binary forms, with or without … … 29 38 ; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 30 39 ; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 ; ----------------------------TERMS OF USE--------------------------------32 33 ;; The reference implementation of SRFI 43 on srfi.schemers.org is buggy34 ;; (as of 24 May 2005). This code is derived from Taylor Campbell's updated35 ;; version of 4 Feb 2005, which can be found at36 ;; http://srfi.schemers.org/srfi-43/post-mail-archive/msg00001.html37 38 ;; Also included are the following fixes:39 ;; vector-map fix from http://srfi.schemers.org/srfi-43/post-mail-archive/msg00008.html40 ;; list->vector and reverse-list->vector obey START and disallow negative length41 ;; (note: START/END are not in the official doc, but are in Taylor's implementation)42 ;; Fixed vector-unfold arity problem in list->vector43 ;; Removed redundant offset checks in VECTOR-COPY and VECTOR-REVERSE-COPY44 45 ;; and these changes made for Chicken:46 ;; Removed receive and let-optionals* macros (defined natively in Chicken)47 ;; Converted let-vector-start+end from define-syntax to define-macro48 ;; check-type uses native type checking49 ;; Procedures pass symbol, not procedure object, as callee50 ;; Clean up error display on Chicken51 40 52 41 (declare … … 550 539 vec))))) 551 540 552 ;++ Flush VECTOR-TABULATE: it's superseded by VECTOR-UNFOLD.553 554 ;;; (VECTOR-TABULATE <f> <length>) -> vector555 ;;; (F <index>)556 ;;; Create a vector whose length is LENGTH. Initialize it with the557 ;;; results of (f INDEX) for every INDEX in the resulting vector.558 ;;; The order of applications of F is unspecified.559 ;++(define (vector-tabulate f len)560 ;++ (check-type procedure? f vector-tabulate)561 ;++ (check-type nonneg-int? len vector-tabulate)562 ;++ (let ((new-vector (make-vector len)))563 ;++ (do ((i 0 (+ i 1)))564 ;++ ((= i len) new-vector)565 ;++ (vector-set! new-vector i (f i)))))566 567 541 ;;; (VECTOR-COPY <vector> [<start> <end> <fill>]) -> vector 568 542 ;;; Create a newly allocated vector containing the elements from the … … 850 824 (vector-length vec) 851 825 vector-map))) 852 (%vector-map2+! f (make-vector len) (cons vec vectors) len))))) 826 (%vector-map2+! f (make-vector len) (cons vec vectors) 827 len))))) 853 828 854 829 ;;; (VECTOR-MAP! <f> <vector> ...) -> unspecified … … 1026 1001 (let loop ((start start) (end end) (j #f)) 1027 1002 (let ((i (quotient (+ start end) 2))) 1028 (if ( and j (= i j))1003 (if (or (= start end) (and j (= i j))) 1029 1004 #f 1030 1005 (let ((comparison … … 1144 1119 ;;; (VECTOR-COPY! <target> <tstart> <source> [<sstart> <send>]) 1145 1120 ;;; -> unspecified 1146 ;;; Copy the values in the locations in [SSTART,SEND) from SOURCE to1121 ;;; Copy the values in the locations in [SSTART,SEND) from SOURCE 1147 1122 ;;; to TARGET, starting at TSTART in TARGET. 1148 ;; (Note: original code had a bunch of offset checks that could never1149 ;; be triggered, as the offsets were already checked earlier.)1123 ;; (Note: removed start+end offset checks that can never be triggered, 1124 ;; as the checks are already done in let-vector-start+end.) 1150 1125 (define (vector-copy! target tstart source . maybe-sstart+send) 1151 1126 (let* ((target (check-type vector? target 'vector-copy!)) … … 1156 1131 1157 1132 ;;; (VECTOR-REVERSE-COPY! <target> <tstart> <source> [<sstart> <send>]) 1133 ;; (Note: removed start+end offset checks that can never be triggered, 1134 ;; as the checks are already done in let-vector-start+end.) 1158 1135 (define (vector-reverse-copy! target tstart source . maybe-sstart+send) 1159 1136 (let* ((target (check-type vector? target 'vector-reverse-copy!)) … … 1241 1218 ;;; great for circular lists. 1242 1219 1243 ;; The implementor designed for no SRFI-1.1244 (define (drop lis k)1245 (##sys#check-exact k 'drop)1246 (let iter ((lis lis) (k k))1247 (if (eq? 0 k) lis (iter (cdr lis) (fx- k 1)))))1248 1249 1220 (define list->vector 1250 1221 (let ((%list->vector list->vector)) … … 1261 1232 (end (length lst))) ; Ugh -- LENGTH 1262 1233 (let ((start (check-type nonneg-int? start 'list->vector)) 1263 (end (check-type nonneg-int? end 'list->vector)) 1264 (len (fx- end start))) 1265 (cond-expand [unsafe] [else 1266 (if (negative? len) 1267 (##sys#error 'list->vector "length is negative" len))]) 1234 (end (check-type nonneg-int? end 'list->vector))) 1268 1235 ((lambda (f) 1269 (vector-unfold f len (droplst start)))1236 (vector-unfold f (- end start) (list-tail lst start))) 1270 1237 (lambda (index l) 1271 1238 (cond ((null? l) … … 1293 1260 (end (length lst))) ; Ugh -- LENGTH 1294 1261 (let ((start (check-type nonneg-int? start 'reverse-list->vector)) 1295 (end (check-type nonneg-int? end 'reverse-list->vector)) 1296 (len (fx- end start))) 1297 (cond-expand [unsafe] [else 1298 (if (negative? len) 1299 (##sys#error 'list->vector "length is negative" len))]) 1262 (end (check-type nonneg-int? end 'reverse-list->vector))) 1300 1263 ((lambda (f) 1301 (vector-unfold-right f len (droplst start)))1264 (vector-unfold-right f (- end start) (list-tail lst start))) 1302 1265 (lambda (index l) 1303 1266 (cond ((null? l) -
vector-lib/vector-lib.setup
r1881 r7340 10 10 "vector-lib.html" 11 11 ,@(if has-exports? '("vector-lib.exports") '()) ) 12 `((version 1. 1)12 `((version 1.2) 13 13 ,@(if has-exports? `((exports "vector-lib.exports")) '()) 14 14 (documentation "vector-lib.html") ) )
Note: See TracChangeset
for help on using the changeset viewer.