Changeset 7340 in project
 Timestamp:
 01/12/08 20:45:59 (12 years ago)
 Location:
 vectorlib
 Files:

 2 edited
Legend:
 Unmodified
 Added
 Removed

vectorlib/vectorlib.scm
r404 r7340 1 1 ;;; SRFI 43: Vector library 2 2 ;;; Taylor Campbell's reference implementation ported to Chicken Scheme. 3 ;;; $Id: vectorlib.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 VECTORCOPY and VECTORREVERSECOPY 9 ;; Removed receive and letoptionals* macros (defined natively in Chicken) 10 ;; Converted letvectorstart+end from definesyntax to definemacro 11 ;; checktype 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 USE32 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/srfi43/postmailarchive/msg00001.html37 38 ;; Also included are the following fixes:39 ;; vectormap fix from http://srfi.schemers.org/srfi43/postmailarchive/msg00008.html40 ;; list>vector and reverselist>vector obey START and disallow negative length41 ;; (note: START/END are not in the official doc, but are in Taylor's implementation)42 ;; Fixed vectorunfold arity problem in list>vector43 ;; Removed redundant offset checks in VECTORCOPY and VECTORREVERSECOPY44 45 ;; and these changes made for Chicken:46 ;; Removed receive and letoptionals* macros (defined natively in Chicken)47 ;; Converted letvectorstart+end from definesyntax to definemacro48 ;; checktype 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 VECTORTABULATE: it's superseded by VECTORUNFOLD.553 554 ;;; (VECTORTABULATE <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 (vectortabulate f len)560 ;++ (checktype procedure? f vectortabulate)561 ;++ (checktype nonnegint? len vectortabulate)562 ;++ (let ((newvector (makevector len)))563 ;++ (do ((i 0 (+ i 1)))564 ;++ ((= i len) newvector)565 ;++ (vectorset! newvector i (f i)))))566 567 541 ;;; (VECTORCOPY <vector> [<start> <end> <fill>]) > vector 568 542 ;;; Create a newly allocated vector containing the elements from the … … 850 824 (vectorlength vec) 851 825 vectormap))) 852 (%vectormap2+! f (makevector len) (cons vec vectors) len))))) 826 (%vectormap2+! f (makevector len) (cons vec vectors) 827 len))))) 853 828 854 829 ;;; (VECTORMAP! <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 ;;; (VECTORCOPY! <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 letvectorstart+end.) 1150 1125 (define (vectorcopy! target tstart source . maybesstart+send) 1151 1126 (let* ((target (checktype vector? target 'vectorcopy!)) … … 1156 1131 1157 1132 ;;; (VECTORREVERSECOPY! <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 letvectorstart+end.) 1158 1135 (define (vectorreversecopy! target tstart source . maybesstart+send) 1159 1136 (let* ((target (checktype vector? target 'vectorreversecopy!)) … … 1241 1218 ;;; great for circular lists. 1242 1219 1243 ;; The implementor designed for no SRFI1.1244 (define (drop lis k)1245 (##sys#checkexact 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 (checktype nonnegint? start 'list>vector)) 1263 (end (checktype nonnegint? end 'list>vector)) 1264 (len (fx end start))) 1265 (condexpand [unsafe] [else 1266 (if (negative? len) 1267 (##sys#error 'list>vector "length is negative" len))]) 1234 (end (checktype nonnegint? end 'list>vector))) 1268 1235 ((lambda (f) 1269 (vectorunfold f len (droplst start)))1236 (vectorunfold f ( end start) (listtail lst start))) 1270 1237 (lambda (index l) 1271 1238 (cond ((null? l) … … 1293 1260 (end (length lst))) ; Ugh  LENGTH 1294 1261 (let ((start (checktype nonnegint? start 'reverselist>vector)) 1295 (end (checktype nonnegint? end 'reverselist>vector)) 1296 (len (fx end start))) 1297 (condexpand [unsafe] [else 1298 (if (negative? len) 1299 (##sys#error 'list>vector "length is negative" len))]) 1262 (end (checktype nonnegint? end 'reverselist>vector))) 1300 1263 ((lambda (f) 1301 (vectorunfoldright f len (droplst start)))1264 (vectorunfoldright f ( end start) (listtail lst start))) 1302 1265 (lambda (index l) 1303 1266 (cond ((null? l) 
vectorlib/vectorlib.setup
r1881 r7340 10 10 "vectorlib.html" 11 11 ,@(if hasexports? '("vectorlib.exports") '()) ) 12 `((version 1. 1)12 `((version 1.2) 13 13 ,@(if hasexports? `((exports "vectorlib.exports")) '()) 14 14 (documentation "vectorlib.html") ) )
Note: See TracChangeset
for help on using the changeset viewer.