Changeset 14192 in project
- Timestamp:
- 04/08/09 18:57:09 (11 years ago)
- Location:
- release/4/srfi-41
- Files:
-
- 1 added
- 9 edited
Legend:
- Unmodified
- Added
- Removed
-
release/4/srfi-41/tags/1.0.0/chicken-primitive-object-inlines.scm
r14178 r14192 690 690 (loop (%cdr ls)) ) ) ) 691 691 692 (define-inline (%list/1 obj) (%cons obj '())) 693 694 (define-inline (%list . objs) 695 (let loop ((objs objs)) 696 (if (%null? objs) '() 697 (%cons (%car objs) (loop (%cdr objs)) ) ) ) ) 698 692 699 (define-inline (%make-list n e) 693 700 (let loop ((n n) (ls '())) … … 704 711 (if (%fxzero? n) ls 705 712 (loop (%cdr ls) (%fxsub1 n)) ) ) ) 713 714 (define-inline (%any/1 pred? ls) 715 (let loop ((ls ls)) 716 (and (not (%null? ls)) 717 (or (pred? (%car ls)) 718 (loop (%cdr ls)) ) ) ) ) 719 720 (define-inline (%list-length ls0) 721 (let loop ((ls ls0) (n 0)) 722 (if (%null? ls) n 723 (loop (%cdr ls) (%fxadd1 n)) ) ) ) 706 724 707 725 ;; Structure (wordblock) … … 738 756 739 757 (define-inline (%port-filep port) (%peek-unsigned-integer port 0)) 740 (define-inline (%port-input-mode? port) (%wordblock-ref ?port 1))741 (define-inline (%port-class port) (%wordblock-ref ?port 2))742 (define-inline (%port-name port) (%wordblock-ref ?port 3))743 (define-inline (%port-row port) (%wordblock-ref ?port 4))744 (define-inline (%port-column port) (%wordblock-ref ?port 5))745 (define-inline (%port-eof? port) (%wordblock-ref ?port 6))746 (define-inline (%port-type port) (%wordblock-ref ?port 7))747 (define-inline (%port-closed? port) (%wordblock-ref ?port 8))748 (define-inline (%port-data port) (%wordblock-ref ?port 9))749 750 (define-inline (%input-port? x) (and (%port x) (%port-input-mode? x)))751 (define-inline (%output-port? x) (and (%port x) (not (%port-input-mode? x))))758 (define-inline (%port-input-mode? port) (%wordblock-ref port 1)) 759 (define-inline (%port-class port) (%wordblock-ref port 2)) 760 (define-inline (%port-name port) (%wordblock-ref port 3)) 761 (define-inline (%port-row port) (%wordblock-ref port 4)) 762 (define-inline (%port-column port) (%wordblock-ref port 5)) 763 (define-inline (%port-eof? port) (%wordblock-ref port 6)) 764 (define-inline (%port-type port) (%wordblock-ref port 7)) 765 (define-inline (%port-closed? port) (%wordblock-ref port 8)) 766 (define-inline (%port-data port) (%wordblock-ref port 9)) 767 768 (define-inline (%input-port? x) (and (%port? x) (%port-input-mode? x))) 769 (define-inline (%output-port? x) (and (%port? x) (not (%port-input-mode? x)))) 752 770 753 771 (define-inline (%port-filep-set! port fp) (%poke-integer port 0 fp)) -
release/4/srfi-41/trunk/chicken-primitive-object-inlines.scm
r14176 r14192 690 690 (loop (%cdr ls)) ) ) ) 691 691 692 (define-inline (%list/1 obj) (%cons obj '())) 693 694 (define-inline (%list . objs) 695 (let loop ((objs objs)) 696 (if (%null? objs) '() 697 (%cons (%car objs) (loop (%cdr objs)) ) ) ) ) 698 692 699 (define-inline (%make-list n e) 693 700 (let loop ((n n) (ls '())) … … 704 711 (if (%fxzero? n) ls 705 712 (loop (%cdr ls) (%fxsub1 n)) ) ) ) 713 714 (define-inline (%any/1 pred? ls) 715 (let loop ((ls ls)) 716 (and (not (%null? ls)) 717 (or (pred? (%car ls)) 718 (loop (%cdr ls)) ) ) ) ) 719 720 (define-inline (%list-length ls0) 721 (let loop ((ls ls0) (n 0)) 722 (if (%null? ls) n 723 (loop (%cdr ls) (%fxadd1 n)) ) ) ) 706 724 707 725 ;; Structure (wordblock) … … 738 756 739 757 (define-inline (%port-filep port) (%peek-unsigned-integer port 0)) 740 (define-inline (%port-input-mode? port) (%wordblock-ref ?port 1))741 (define-inline (%port-class port) (%wordblock-ref ?port 2))742 (define-inline (%port-name port) (%wordblock-ref ?port 3))743 (define-inline (%port-row port) (%wordblock-ref ?port 4))744 (define-inline (%port-column port) (%wordblock-ref ?port 5))745 (define-inline (%port-eof? port) (%wordblock-ref ?port 6))746 (define-inline (%port-type port) (%wordblock-ref ?port 7))747 (define-inline (%port-closed? port) (%wordblock-ref ?port 8))748 (define-inline (%port-data port) (%wordblock-ref ?port 9))749 750 (define-inline (%input-port? x) (and (%port x) (%port-input-mode? x)))751 (define-inline (%output-port? x) (and (%port x) (not (%port-input-mode? x))))758 (define-inline (%port-input-mode? port) (%wordblock-ref port 1)) 759 (define-inline (%port-class port) (%wordblock-ref port 2)) 760 (define-inline (%port-name port) (%wordblock-ref port 3)) 761 (define-inline (%port-row port) (%wordblock-ref port 4)) 762 (define-inline (%port-column port) (%wordblock-ref port 5)) 763 (define-inline (%port-eof? port) (%wordblock-ref port 6)) 764 (define-inline (%port-type port) (%wordblock-ref port 7)) 765 (define-inline (%port-closed? port) (%wordblock-ref port 8)) 766 (define-inline (%port-data port) (%wordblock-ref port 9)) 767 768 (define-inline (%input-port? x) (and (%port? x) (%port-input-mode? x))) 769 (define-inline (%output-port? x) (and (%port? x) (not (%port-input-mode? x)))) 752 770 753 771 (define-inline (%port-filep-set! port fp) (%poke-integer port 0 fp)) -
release/4/srfi-41/trunk/srfi-41.meta
r14176 r14192 12 12 "tests" 13 13 "chicken-primitive-object-inlines.scm" 14 "streams-inlines.scm" 14 15 "streams-primitive.scm" 15 16 "streams-derived.scm" -
release/4/srfi-41/trunk/streams-derived.scm
r14176 r14192 26 26 27 27 (include "chicken-primitive-object-inlines") 28 (include "streams-inlines") 29 (include "inline-type-checks") 28 30 29 31 ;;; 30 31 (define-inline (%any/1 pred? ls)32 (let loop ((ls ls))33 (and (not (%null? ls))34 (or (pred? (%car ls))35 (loop (%cdr ls)) ) ) ) )36 32 37 33 (define-inline (%check-streams loc strms nam) 38 34 (when (%any/1 not-stream? strms) 39 35 (error-stream loc strms nam) ) ) 40 41 ;;;42 36 43 37 (module streams-derived (;export … … 61 55 stream-zip 62 56 ;; WTF 63 $ stream-match-pattern$64 $ stream-match-test$)57 $$stream-match-pattern 58 $$stream-match-test) 65 59 66 60 (import scheme chicken 67 61 #;srfi-9 #;srfi-23 68 62 streams-primitive 69 (only type- checks70 check-number check-procedure check-cardinal-integer check-input-port check-list))71 72 (require-library #;srfi-9 #;srfi-23 streams-primitive type- checks)63 (only type-errors 64 error-number error-procedure error-cardinal-integer error-input-port error-list)) 65 66 (require-library #;srfi-9 #;srfi-23 streams-primitive type-errors) 73 67 74 68 ;;; 75 69 76 (define (not-stream? obj) ( not (stream? obj)))70 (define (not-stream? obj) (%not-stream? obj)) 77 71 78 72 ;;; … … 81 75 (syntax-rules () 82 76 ((define-stream (NAME . FORMAL) BODY0 BODY1 ...) 83 (define NAME (stream-lambda FORMAL BODY0 BODY1 ...)) )))77 (define NAME (stream-lambda FORMAL BODY0 BODY1 ...)) ) ) ) 84 78 85 79 (define-syntax stream 86 80 (syntax-rules () 87 81 ((stream) stream-null) 88 ((stream X Y ...) (stream-cons X (stream Y ...)) )))82 ((stream X Y ...) (stream-cons X (stream Y ...)) ) ) ) 89 83 90 84 (define-syntax stream-let 91 85 (syntax-rules () 92 86 ((stream-let TAG ((NAME VAL) ...) BODY0 BODY1 ...) 93 ((letrec ((TAG (stream-lambda (NAME ...) BODY0 BODY1 ...))) TAG) VAL ...) )))87 ((letrec ((TAG (stream-lambda (NAME ...) BODY0 BODY1 ...))) TAG) VAL ...) ) ) ) 94 88 95 89 ;FIXME - this forces use of `_' identifier 96 (define-syntax $ stream-match-pattern$90 (define-syntax $$stream-match-pattern 97 91 (syntax-rules (_) 98 92 99 (($ stream-match-pattern$STRM () (BINDING ...) BODY)93 (($$stream-match-pattern STRM () (BINDING ...) BODY) 100 94 (and (stream-null? STRM) 101 (let (BINDING ...) BODY)) )102 103 (($ stream-match-pattern$STRM (_ . REST) (BINDING ...) BODY)95 (let (BINDING ...) BODY)) ) 96 97 (($$stream-match-pattern STRM (_ . REST) (BINDING ...) BODY) 104 98 (and (stream-pair? STRM) 105 99 (let ((strm (stream-cdr STRM))) 106 ($ stream-match-pattern$ strm REST (BINDING ...) BODY))))107 108 (($ stream-match-pattern$STRM (VAR . REST) (BINDING ...) BODY)100 ($$stream-match-pattern strm REST (BINDING ...) BODY))) ) 101 102 (($$stream-match-pattern STRM (VAR . REST) (BINDING ...) BODY) 109 103 (and (stream-pair? STRM) 110 104 (let ((temp (stream-car STRM)) 111 105 (strm (stream-cdr STRM))) 112 ($ stream-match-pattern$ strm REST ((VAR temp) BINDING ...) BODY))))113 114 (($ stream-match-pattern$STRM _ (BINDING ...) BODY)115 (let (BINDING ...) BODY) )116 117 (($ stream-match-pattern$STRM VAR (BINDING ...) BODY)118 (let ((VAR STRM) BINDING ...) BODY) )))119 120 (define-syntax $ stream-match-test$106 ($$stream-match-pattern strm REST ((VAR temp) BINDING ...) BODY))) ) 107 108 (($$stream-match-pattern STRM _ (BINDING ...) BODY) 109 (let (BINDING ...) BODY) ) 110 111 (($$stream-match-pattern STRM VAR (BINDING ...) BODY) 112 (let ((VAR STRM) BINDING ...) BODY) ) ) ) 113 114 (define-syntax $$stream-match-test 121 115 (syntax-rules () 122 116 123 (($ stream-match-test$STRM (PATTERN FENDER EXPR))124 ($ stream-match-pattern$ STRM PATTERN () (and FENDER (list EXPR))))125 126 (($ stream-match-test$STRM (PATTERN EXPR))127 ($ stream-match-pattern$ STRM PATTERN () (list EXPR)))))117 (($$stream-match-test STRM (PATTERN FENDER EXPR)) 118 ($$stream-match-pattern STRM PATTERN () (and FENDER (list EXPR))) ) 119 120 (($$stream-match-test STRM (PATTERN EXPR)) 121 ($$stream-match-pattern STRM PATTERN () (list EXPR)) ) ) ) 128 122 129 123 (define-syntax stream-match … … 132 126 (let ((strm STRM-EXPR)) 133 127 (cond ((not (stream? strm)) (error-stream 'stream-match strm 'stream)) 134 (($ stream-match-test$strm CLAUSE) => car) ...135 (else (##sys#signal-hook #:error 'stream-match "no matching pattern")))) )))128 (($$stream-match-test strm CLAUSE) => car) ... 129 (else (##sys#signal-hook #:error 'stream-match "no matching pattern")))) ) ) ) 136 130 137 131 (define-syntax stream-of … … 139 133 140 134 ((stream-of "aux" EXPR BASE) 141 (stream-cons EXPR BASE) )135 (stream-cons EXPR BASE) ) 142 136 143 137 ((stream-of "aux" EXPR BASE (VAR in STREAM) REST ...) … … 145 139 (if (stream-null? strm) BASE 146 140 (let ((VAR (stream-car strm))) 147 (stream-of "aux" EXPR (loop (stream-cdr strm)) REST ...)))) )141 (stream-of "aux" EXPR (loop (stream-cdr strm)) REST ...)))) ) 148 142 149 143 ((stream-of "aux" EXPR BASE (VAR is EXP) REST ...) 150 (let ((VAR EXP)) (stream-of "aux" EXPR BASE REST ...)) )144 (let ((VAR EXP)) (stream-of "aux" EXPR BASE REST ...)) ) 151 145 152 146 ((stream-of "aux" EXPR BASE PRED? REST ...) 153 (if PRED? (stream-of "aux" EXPR BASE REST ...) BASE) )147 (if PRED? (stream-of "aux" EXPR BASE REST ...) BASE) ) 154 148 155 149 ((stream-of EXPR REST ...) 156 (stream-of "aux" EXPR stream-null REST ...) )))150 (stream-of "aux" EXPR stream-null REST ...) ) ) ) 157 151 158 152 ;; 159 153 154 (define stream-constant 155 (stream-lambda objs 156 (cond ((%null? objs) 157 stream-null ) 158 ((%null? (%cdr objs)) 159 (stream-cons (%car objs) (stream-constant (%car objs))) ) 160 (else 161 (stream-cons (%car objs) 162 (apply stream-constant (append (%cdr objs) (%list/1 (%car objs))))) ) ) ) ) 163 160 164 (define (list->stream objects) 161 165 162 166 (define-stream (list->stream$ objs) 163 (if ( null? objs) stream-null164 (stream-cons ( car objs) (list->stream$ (cdr objs))) ) )165 166 ( check-list 'list->stream objects 'objects)167 (if (%null? objs) stream-null 168 (stream-cons (%car objs) (list->stream$ (%cdr objs))) ) ) 169 170 (%check-list 'list->stream objects 'objects) 167 171 (list->stream$ objects) ) 168 172 169 173 (define (stream->list . args) 170 (let ((length (if (= 1 (length args)) #f (car args)))171 (streem (if (= 1 (length args)) (car args) (cadr args))))172 ( check-stream 'stream->list streem 'stream)173 (when length (check-cardinal-integer 'stream->list length 'length))174 (let loop ((n (or length-1)) (strm streem))175 (if (or ( zero? n) (stream-null? strm)) '()176 ( cons (stream-car strm) (loop (sub1 n) (stream-cdr strm))) ) ) ) )174 (let* ((count (and (%fx< 1 (%list-length args)) (%car args))) 175 (streem (if count (%cadr args) (%car args)))) 176 (%check-stream 'stream->list streem 'stream) 177 (when count (%check-cardinal-integer 'stream->list count 'count)) 178 (let loop ((n (or count -1)) (strm streem)) 179 (if (or (%fxzero? n) (stream-null? strm)) '() 180 (%cons (stream-car strm) (loop (%fxsub1 n) (stream-cdr strm))) ) ) ) ) 177 181 178 182 (define (port->stream . port) … … 180 184 (define-stream (port->stream$ p) 181 185 (let ((c (read-char p))) 182 (if ( eof-object? c) stream-null186 (if (%eof-object? c) stream-null 183 187 (stream-cons c (port->stream$ p)) ) ) ) 184 188 185 (let ((port (if ( null? port) (current-input-port) (car port))))186 ( check-input-port 'port->stream port 'port)189 (let ((port (if (%null? port) (current-input-port) (%car port)))) 190 (%check-input-port 'port->stream port 'port) 187 191 (port->stream$ port)) ) 188 192 189 193 (define (stream-length streem) 190 ( check-stream 'stream-length streem 'stream)194 (%check-stream 'stream-length streem 'stream) 191 195 (let loop ((len 0) (strm streem)) 192 196 (if (stream-null? strm) len 193 (loop ( add1 len) (stream-cdr strm)) ) ) )197 (loop (%fxadd1 len) (stream-cdr strm)) ) ) ) 194 198 195 199 (define (stream-ref streem index) 196 ( check-stream 'stream-ref streem 'stream)197 ( check-cardinal-integer 'stream-ref index 'index)200 (%check-stream 'stream-ref streem 'stream) 201 (%check-cardinal-integer 'stream-ref index 'index) 198 202 (let loop ((strm streem) (n index)) 199 203 (cond ((stream-null? strm) 200 (##sys#signal-hook #:bounds-error 'stream-ref "beyond end of stream" strm index))201 (( zero? n)202 (stream-car strm))203 (else 204 (loop (stream-cdr strm) (sub1 n)) ) ) ) )204 (##sys#signal-hook #:bounds-error 'stream-ref "beyond end of stream" strm index) ) 205 ((%fxzero? n) 206 (stream-car strm) ) 207 (else 208 (loop (stream-cdr strm) (%fxsub1 n)) ) ) ) ) 205 209 206 210 (define (stream-reverse streem) … … 210 214 (stream-reverse$ (stream-cdr strm) (stream-cons (stream-car strm) rev)) ) ) 211 215 212 ( check-stream 'stream-reverse streem 'stream)216 (%check-stream 'stream-reverse streem 'stream) 213 217 (stream-reverse$ streem stream-null) ) 214 218 … … 216 220 217 221 (define-stream (stream-append$ strms) 218 (cond ((null? (cdr strms)) (car strms)) 219 ((stream-null? (car strms)) (stream-append$ (cdr strms))) 220 (else (stream-cons (stream-car (car strms)) 221 (stream-append$ 222 (cons (stream-cdr (car strms)) (cdr strms)))) ) ) ) 223 224 (if (null? streems) stream-null 222 (cond ((%null? (%cdr strms)) 223 (%car strms) ) 224 ((stream-null? (%car strms)) 225 (stream-append$ (%cdr strms)) ) 226 (else 227 (stream-cons (stream-car (%car strms)) 228 (stream-append$ (%cons (stream-cdr (%car strms)) (%cdr strms)))) ) ) ) 229 230 (if (%null? streems) stream-null 225 231 (begin 226 232 (%check-streams 'stream-append streems 'stream) … … 231 237 (define-stream (stream-concat$ strm) 232 238 (cond ((stream-null? strm) 233 stream-null)239 stream-null ) 234 240 ((not (stream? (stream-car strm))) 235 (error-stream 'stream-concat strm))241 (error-stream 'stream-concat strm) ) 236 242 ((stream-null? (stream-car strm)) 237 (stream-concat$ (stream-cdr strm))) 238 (else 239 (stream-cons (stream-car (stream-car strm)) 240 (stream-concat$ 241 (stream-cons (stream-cdr (stream-car strm)) 242 (stream-cdr strm)))) ) ) ) 243 244 (check-stream 'stream-concat streem 'stream) 243 (stream-concat$ (stream-cdr strm)) ) 244 (else 245 (stream-cons (stream-car (stream-car strm)) 246 (stream-concat$ (stream-cons (stream-cdr (stream-car strm)) 247 (stream-cdr strm)))) ) ) ) 248 249 (%check-stream 'stream-concat streem 'stream) 245 250 (stream-concat$ streem) ) 246 251 247 (define stream-constant248 (stream-lambda objs249 (cond ((null? objs) stream-null)250 ((null? (cdr objs)) (stream-cons (car objs) (stream-constant (car objs))))251 (else (stream-cons (car objs)252 (apply stream-constant (append (cdr objs) (list (car objs))))) ) ) ) )253 254 252 (define (stream-drop count streem) 255 253 256 254 (define-stream (stream-drop$ n strm) 257 (if (or ( zero? n) (stream-null? strm)) strm258 (stream-drop$ ( sub1 n) (stream-cdr strm)) ) )259 260 ( check-stream 'stream-drop streem 'stream)261 ( check-cardinal-integer 'stream-drop count 'count)255 (if (or (%fxzero? n) (stream-null? strm)) strm 256 (stream-drop$ (%fxsub1 n) (stream-cdr strm)) ) ) 257 258 (%check-stream 'stream-drop streem 'stream) 259 (%check-cardinal-integer 'stream-drop count 'count) 262 260 (stream-drop$ count streem) ) 263 261 … … 268 266 (stream-drop-while$ (stream-cdr strm)) ) ) 269 267 270 ( check-procedure 'stream-drop-while predicate? 'predicate?)271 ( check-stream 'stream-drop-while streem 'stream)268 (%check-procedure 'stream-drop-while predicate? 'predicate?) 269 (%check-stream 'stream-drop-while streem 'stream) 272 270 (stream-drop-while$ streem) ) 273 271 … … 275 273 276 274 (define-stream (stream-take$ n strm) 277 (if (or (stream-null? strm) ( zero? n)) stream-null278 (stream-cons (stream-car strm) (stream-take$ ( sub1 n) (stream-cdr strm))) ) )279 280 ( check-stream 'stream-take streem 'stream)281 ( check-cardinal-integer 'stream-take count 'count)275 (if (or (stream-null? strm) (%fxzero? n)) stream-null 276 (stream-cons (stream-car strm) (stream-take$ (%fxsub1 n) (stream-cdr strm))) ) ) 277 278 (%check-stream 'stream-take streem 'stream) 279 (%check-cardinal-integer 'stream-take count 'count) 282 280 (stream-take$ count streem) ) 283 281 … … 286 284 (define-stream (stream-take-while$ strm) 287 285 (cond ((stream-null? strm) 288 stream-null)286 stream-null ) 289 287 ((predicate? (stream-car strm)) 290 (stream-cons (stream-car strm) (stream-take-while$ (stream-cdr strm))))291 (else 292 stream-null ) ) )293 294 ( check-procedure 'stream-take-while predicate? 'predicate?)295 ( check-stream 'stream-take-while streem 'stream)288 (stream-cons (stream-car strm) (stream-take-while$ (stream-cdr strm))) ) 289 (else 290 stream-null ) ) ) 291 292 (%check-procedure 'stream-take-while predicate? 'predicate?) 293 (%check-stream 'stream-take-while streem 'stream) 296 294 (stream-take-while$ streem) ) 297 295 … … 300 298 (define-stream (stream-filter$ strm) 301 299 (cond ((stream-null? strm) 302 stream-null)300 stream-null ) 303 301 ((predicate? (stream-car strm)) 304 (stream-cons (stream-car strm) (stream-filter$ (stream-cdr strm))))305 (else 306 (stream-filter$ (stream-cdr strm)) ) ) )307 308 ( check-procedure 'stream-filter predicate? 'predicate?)309 ( check-stream 'stream-filter streem 'stream)302 (stream-cons (stream-car strm) (stream-filter$ (stream-cdr strm))) ) 303 (else 304 (stream-filter$ (stream-cdr strm)) ) ) ) 305 306 (%check-procedure 'stream-filter predicate? 'predicate?) 307 (%check-stream 'stream-filter streem 'stream) 310 308 (stream-filter$ streem) ) 311 309 … … 317 315 (stream-scan$ (function base (stream-car strm)) (stream-cdr strm))) ) ) 318 316 319 ( check-procedure 'stream-scan function 'function)320 ( check-stream 'stream-scan streem 'stream)317 (%check-procedure 'stream-scan function 'function) 318 (%check-stream 'stream-scan streem 'stream) 321 319 (stream-scan$ base streem) ) 322 320 … … 325 323 (define (stream-folder base strms) 326 324 (if (%any/1 stream-null? strms) base 327 (stream-folder (apply function base ( mapstream-car strms))328 ( mapstream-cdr strms)) ) )329 330 ( check-procedure 'stream-fold function 'function)331 (let ((streems ( cons streem streems)))325 (stream-folder (apply function base (%list-map/1 stream-car strms)) 326 (%list-map/1 stream-cdr strms)) ) ) 327 328 (%check-procedure 'stream-fold function 'function) 329 (let ((streems (%cons streem streems))) 332 330 (%check-streams 'stream-fold streems 'stream) 333 331 (stream-folder base streems) ) ) … … 335 333 (define (stream-for-each procedure streem . streems) 336 334 337 (define (stream-for-each $strms)335 (define (stream-for-eacher strms) 338 336 (unless (%any/1 stream-null? strms) 339 (apply procedure ( mapstream-car strms))340 (stream-for-each $ (mapstream-cdr strms)) ) )341 342 ( check-procedure 'stream-for-each procedure 'procedure)343 (let ((streems ( cons streem streems)))337 (apply procedure (%list-map/1 stream-car strms)) 338 (stream-for-eacher (%list-map/1 stream-cdr strms)) ) ) 339 340 (%check-procedure 'stream-for-each procedure 'procedure) 341 (let ((streems (%cons streem streems))) 344 342 (%check-streams 'stream-for-each streems 'stream) 345 (stream-for-each $streems) ) )343 (stream-for-eacher streems) ) ) 346 344 347 345 (define (stream-map function streem . streems) … … 350 348 (define-stream (stream-map$ strms) 351 349 (if (%any/1 stream-null? strms) stream-null 352 (stream-cons (apply function ( mapstream-car strms))353 (stream-map$ ( mapstream-cdr strms))) ) )354 355 ( check-procedure 'stream-map function 'function)356 (let ((streems ( cons streem streems)))350 (stream-cons (apply function (%list-map/1 stream-car strms)) 351 (stream-map$ (%list-map/1 stream-cdr strms))) ) ) 352 353 (%check-procedure 'stream-map function 'function) 354 (let ((streems (%cons streem streems))) 357 355 (%check-streams 'stream-map streems 'stream) 358 356 (stream-map$ streems) ) ) … … 361 359 362 360 (define-stream (stream-from$ first delta) 363 (stream-cons first (stream-from$ ( + first delta) delta)) )364 365 (let ((delta (if ( null? step) 1 (car step))))366 ( check-number 'stream-from first 'first)367 ( check-number 'stream-from delta 'delta)361 (stream-cons first (stream-from$ (%fx+ first delta) delta)) ) 362 363 (let ((delta (if (%null? step) 1 (%car step)))) 364 (%check-number 'stream-from first 'first) 365 (%check-number 'stream-from delta 'delta) 368 366 (stream-from$ first delta) ) ) 369 367 … … 373 371 (stream-cons base (stream-iterate$ (function base))) ) 374 372 375 ( check-procedure 'stream-iterate function 'function)373 (%check-procedure 'stream-iterate function 'function) 376 374 (stream-iterate$ base) ) 377 375 … … 380 378 (define-stream (stream-range$ first past delta lt?) 381 379 (if (not (lt? first past)) stream-null 382 (stream-cons first (stream-range$ ( + first delta) past delta lt?)) ) )383 384 ( check-number 'stream-range first 'first)385 ( check-number 'stream-range past 'past)386 (let ((delta (cond (( pair? step) (car step)) ((< first past) 1) (else -1))))387 ( check-number 'stream-range delta 'delta)380 (stream-cons first (stream-range$ (%fx+ first delta) past delta lt?)) ) ) 381 382 (%check-number 'stream-range first 'first) 383 (%check-number 'stream-range past 'past) 384 (let ((delta (cond ((%pair? step) (%car step)) ((< first past) 1) (else -1)))) 385 (%check-number 'stream-range delta 'delta) 388 386 (let ((lt? (if (< 0 delta) < >))) 389 387 (stream-range$ first past delta lt?) ) ) ) … … 395 393 (stream-cons (mapper base) (stream-unfold$ (generator base))) ) ) 396 394 397 ( check-procedure 'stream-unfold mapper 'mapper)398 ( check-procedure 'stream-unfold predicate? 'predicate?)399 ( check-procedure 'stream-unfold generator 'generator)395 (%check-procedure 'stream-unfold mapper 'mapper) 396 (%check-procedure 'stream-unfold predicate? 'predicate?) 397 (%check-procedure 'stream-unfold generator 'generator) 400 398 (stream-unfold$ base) ) 401 399 … … 405 403 (call-with-values 406 404 (lambda () (generator seed)) 407 (lambda vs ( sub1 (length vs)))) )405 (lambda vs (%fxsub1 (length vs)))) ) 408 406 409 407 (define-stream (unfold-result-stream seed) … … 414 412 415 413 (define-stream (result-stream->output-stream result-stream i) 416 (let ((result ( list-ref (stream-car result-stream) (sub1 i))))417 (cond (( pair? result)418 (stream-cons ( car result)419 (result-stream->output-stream (stream-cdr result-stream) i)) )414 (let ((result (%list-ref (stream-car result-stream) (%fxsub1 i)))) 415 (cond ((%pair? result) 416 (stream-cons (%car result) 417 (result-stream->output-stream (stream-cdr result-stream) i)) ) 420 418 ((not result) 421 (result-stream->output-stream (stream-cdr result-stream) i) )422 (( null? result)423 stream-null )419 (result-stream->output-stream (stream-cdr result-stream) i) ) 420 ((%null? result) 421 stream-null ) 424 422 (else 425 423 (##sys#signal-hook #:runtime-error 'stream-unfolds "cannot happen" result) ) ) ) ) … … 427 425 (define (result-stream->output-streams result-stream) 428 426 (let loop ((i (len-values)) (outputs '())) 429 (if ( zero? i) (apply values outputs)430 (loop ( sub1 i) (cons (result-stream->output-stream result-stream i) outputs)) ) ) )431 432 ( check-procedure 'stream-unfolds generator 'generator)427 (if (%fxzero? i) (apply values outputs) 428 (loop (%fxsub1 i) (%cons (result-stream->output-stream result-stream i) outputs)) ) ) ) 429 430 (%check-procedure 'stream-unfolds generator 'generator) 433 431 (result-stream->output-streams (unfold-result-stream seed)) ) 434 432 … … 437 435 (define-stream (stream-zip$ strms) 438 436 (if (%any/1 stream-null? strms) stream-null 439 (stream-cons ( mapstream-car strms)440 (stream-zip$ ( mapstream-cdr strms))) ) )441 442 (let ((streems ( cons streem streems)))437 (stream-cons (%list-map/1 stream-car strms) 438 (stream-zip$ (%list-map/1 stream-cdr strms))) ) ) 439 440 (let ((streems (%cons streem streems))) 443 441 (%check-streams 'stream-zip streems 'stream) 444 442 (stream-zip$ streems) ) ) -
release/4/srfi-41/trunk/streams-math.scm
r14140 r14192 22 22 (no-procedure-checks) ) 23 23 24 (include "chicken-primitive-object-inlines") 25 (include "streams-inlines") 26 27 ;;; 28 24 29 (module streams-math (;export 25 stream-sum26 30 stream-max 27 31 stream-min 32 stream-sum 28 33 odd-numbers-stream 29 34 even-numbers-stream 35 cardinal-numbers-stream 30 36 natural-numbers-stream 31 37 prime-numbers-stream … … 38 44 ;;; 39 45 40 (define stream-sum (left-section stream-fold + 0)) 46 (define (stream-max streem) 47 (%check-stream 'stream-max streem 'stream) 48 (stream-fold-one max streem) ) 41 49 42 (define (stream-max strm) (stream-fold-one max strm)) 50 (define (stream-min streem) 51 (%check-stream 'stream-min streem 'stream) 52 (stream-fold-one min streem) ) 43 53 44 (define (stream- min strm) (stream-fold-one min strm))54 (define (stream-sum) (left-section stream-fold + 0)) 45 55 46 (define odd-numbers-stream(stream-from 1 2))56 (define (odd-numbers-stream) (stream-from 1 2)) 47 57 48 (define even-numbers-stream(stream-from 0 2))58 (define (even-numbers-stream) (stream-from 0 2)) 49 59 50 (define natural-numbers-stream(stream-iterate add1 0))60 (define (cardinal-numbers-stream) (stream-iterate add1 0)) 51 61 52 (define prime-numbers-stream 53 (let () 54 (define-stream (next base mult strm) 55 (let ((first (stream-car strm)) 56 (rest (stream-cdr strm))) 57 (cond ((< first mult) 58 (stream-cons first (next base mult rest))) 59 ((< mult first) 60 (next base (+ base mult) strm)) 61 (else 62 (next base (+ base mult) rest))))) 63 (define-stream (sift base strm) 64 (next base (+ base base) strm)) 65 (define-stream (sieve strm) 66 (let ((first (stream-car strm)) 67 (rest (stream-cdr strm))) 68 (stream-cons first (sieve (sift first rest))))) 69 (sieve (stream-from 2)))) 62 (define (natural-numbers-stream) (stream-iterate add1 1)) 63 64 (define (prime-numbers-stream) 65 66 (define-stream (next$ base mult strm) 67 (let ((first (stream-car strm)) 68 (rest (stream-cdr strm))) 69 (cond ((< first mult) 70 (stream-cons first (next$ base mult rest)) ) 71 ((< mult first) 72 (next$ base (+ base mult) strm) ) 73 (else 74 (next$ base (+ base mult) rest) ) ) ) ) 75 76 (define-stream (sift$ base strm) 77 (next$ base (+ base base) strm) ) 78 79 (define-stream (sieve$ strm) 80 (let ((first (stream-car strm)) 81 (rest (stream-cdr strm))) 82 (stream-cons first (sieve$ (sift$ first rest))) ) ) 83 84 (sieve$ (stream-from 2)) ) 70 85 71 86 ;; http://www.research.att.com/~njas/sequences/A051037 72 87 73 (define hamming-sequence-stream88 (define (hamming-sequence-stream) 74 89 (stream-cons 1 75 90 (stream-unique = … … 77 92 (stream-map (left-section * 2) hamming-sequence-stream) 78 93 (stream-map (left-section * 3) hamming-sequence-stream) 79 (stream-map (left-section * 5) hamming-sequence-stream)))) )94 (stream-map (left-section * 5) hamming-sequence-stream)))) ) 80 95 81 96 ) ;module streams-math -
release/4/srfi-41/trunk/streams-primitive.scm
r14176 r14192 24 24 25 25 (include "chicken-primitive-object-inlines") 26 (include "streams-inlines") 26 27 27 28 ;;; 28 29 30 (define-inline (%make-stream-box tag obj) (%cons tag obj)) 31 (define-inline (%stream-box-tag box) (%car box)) 32 (define-inline (%stream-box-value box) (%cdr box)) 33 (define-inline (%stream-box-tag-set! box tag) (%set-car!/immediate box tag)) 34 (define-inline (%stream-box-value-set! box val) (%set-cdr! box val)) 35 36 (define-inline (%make-stream-lazy thunk) (%make-stream (%make-stream-box 'lazy thunk))) 37 (define-inline (%make-stream-eager obj) (%make-stream (%make-stream-box 'eager obj))) 38 29 39 (define-inline (%make-stream prm) (%make-structure 'stream prm)) 30 (define-inline (%stream? obj) (%structure-instance? obj 'stream)) 40 ;;(define-inline (%stream? obj) (%structure-instance? obj 'stream)) ;from "streams-inlines.scm" 31 41 (define-inline (%stream-promise strm) (%structure-ref strm 1)) 32 42 (define-inline (%stream-promise-set! strm obj) (%structure-set! strm 1 obj)) … … 61 71 check-stream-occupied error-stream-occupied 62 72 ;; WTF 63 ($$stream-lazy $$make- lazy-stream)73 ($$stream-lazy $$make-stream-lazy) 64 74 ($$stream-delay $$stream-eager) 65 75 $$make-stream 66 $$make- lazy-stream76 $$make-stream-lazy 67 77 $$stream-eager 68 78 $$make-stream-pare) … … 76 86 ;;; 77 87 88 (define-check+error-type stream) 89 (define-check+error-type stream-occupied) 90 (define-error-type stream-pair) 91 92 ;;; 93 78 94 (define ($$make-stream prm) (%make-stream prm)) 79 95 (define (stream? obj) (%stream? obj)) 80 96 81 (define-check+error-type stream) 82 83 (define ($$make-lazy-stream thunk) (%make-stream (%cons 'lazy thunk))) 97 (define ($$make-stream-lazy thunk) (%make-stream-lazy thunk)) 84 98 85 99 (define-syntax $$stream-lazy 86 100 (syntax-rules () 87 ((_ EXPR) ($$make- lazy-stream(lambda () EXPR)) ) ) )101 ((_ EXPR) ($$make-stream-lazy (lambda () EXPR)) ) ) ) 88 102 89 (define ($$stream-eager obj) (%make-stream (%cons 'eager obj)))103 (define ($$stream-eager obj) (%make-stream-eager obj)) 90 104 91 105 (define-syntax $$stream-delay … … 93 107 ((_ EXPR) ($$stream-lazy ($$stream-eager EXPR)) ) ) ) 94 108 109 (define ($$make-stream-pare kar kdr) (%make-stream-pare kar kdr)) 110 111 ;;; 112 95 113 (define (stream-force promise) 96 114 (let ((content (%stream-promise promise))) 97 (case (% carcontent)115 (case (%stream-box-tag content) 98 116 ((eager) 99 (% cdrcontent) )117 (%stream-box-value content) ) 100 118 ((lazy) 101 (let* ((promise* ((% cdrcontent)))119 (let* ((promise* ((%stream-box-value content))) 102 120 (content (%stream-promise promise))) 103 (unless (%eq? 'eager (% carcontent))121 (unless (%eq? 'eager (%stream-box-tag content)) 104 122 (let ((prm (%stream-promise promise*))) 105 (%s et-car!/immediate content (%carprm))106 (%s et-cdr! content (%cdrprm)) )123 (%stream-box-tag-set! content (%stream-box-tag prm)) 124 (%stream-box-value-set! content (%stream-box-value prm)) ) 107 125 (%stream-promise-set! promise* content) ) 108 126 (stream-force promise) ) ) ) ) ) … … 113 131 (define (stream-occupied? obj) (and (%stream? obj) (not (%stream-null? obj)))) 114 132 115 (define-check+error-type stream-occupied)116 117 (define ($$make-stream-pare kar kdr) (%make-stream-pare kar kdr))118 119 133 (define-syntax stream-cons 120 134 (syntax-rules () … … 123 137 124 138 (define (stream-pair? obj) (and (%stream? obj) (%stream-pare? (stream-force obj)))) 125 126 (define-error-type stream-pair)127 139 128 140 (define (stream-car streem) -
release/4/srfi-41/trunk/streams-utils.scm
r14140 r14192 22 22 (local) 23 23 (no-procedure-checks) ) 24 25 (include "chicken-primitive-object-inlines") 26 (include "streams-inlines") 27 (include "inline-type-checks") 28 29 ;;; 30 31 (define-inline (%check-streams loc strms nam) 32 (when (%any/1 not-stream? strms) 33 (error-stream loc strms nam) ) ) 24 34 25 35 (module streams-utils (;export … … 50 60 stream-minimum) 51 61 52 (import scheme chicken (only data-structures complement right-section) streams) 53 54 (require-library streams) 62 (import scheme chicken 63 (only data-structures complement right-section) 64 streams 65 (only type-errors error-procedure error-string error-cardinal-integer)) 66 67 (require-library streams type-errors) 55 68 56 69 ;;; 57 70 71 (define (not-stream? obj) (%not-stream? obj)) 72 73 ;;; 74 58 75 (define-stream (stream-intersperse yy x) 76 (%check-stream 'stream-intersperse yy 'stream) 59 77 (stream-match yy 60 (() 61 (stream (stream x))) 78 (() (stream (stream x))) 62 79 ((y . ys) 63 (stream-append (stream (stream-cons x yy))64 (stream-map (lambda (z) (stream-cons y z))65 (stream-intersperse ys x))))))80 (stream-append (stream (stream-cons x yy)) 81 (stream-map (lambda (z) (stream-cons y z)) 82 (stream-intersperse ys x))) ) ) ) 66 83 67 84 (define-stream (stream-permutations xs) 85 (%check-stream 'stream-permutations xs 'stream) 68 86 (if (stream-null? xs) (stream (stream)) 69 (stream-concat 70 (stream-map (right-section stream-intersperse (stream-car xs)) 71 (stream-permutations (stream-cdr xs)))))) 87 (stream-concat (stream-map (right-section stream-intersperse (stream-car xs)) 88 (stream-permutations (stream-cdr xs)))) ) ) 72 89 73 90 (define-stream (file->stream filename #!optional (reader read-char)) 91 (%check-string 'file->streams filename 'filename) 92 (%check-procedure 'file->streams reader 'reader) 74 93 (let ((port (open-input-file filename))) 75 94 (stream-let loop ((obj (reader port))) 76 95 (if (eof-object? obj) (begin (close-input-port port) stream-null) 77 (stream-cons obj (loop (reader port))))))) 78 79 (define (stream-split n strm) 80 (values (stream-take n strm) (stream-drop n strm))) 96 (stream-cons obj (loop (reader port))) ) ) ) ) 97 98 (define (stream-split count strm) 99 (%check-stream 'stream-split strm 'stream) 100 (%check-cardinal-integer 'stream-split count 'count) 101 (values (stream-take count strm) (stream-drop count strm))) 81 102 82 103 (define-stream (stream-unique eql? strm) 83 (if (stream-null? strm) stream-null 84 (stream-cons (stream-car strm) 85 (stream-unique 86 eql? 87 (stream-drop-while (lambda (x) (eql? (stream-car strm) x)) strm))))) 104 (%check-stream 'stream-unique strm 'stream) 105 (%check-procedure 'stream-unique eql? 'equivalence) 106 (stream-let loop ((strm strm)) 107 (if (stream-null? strm) stream-null 108 (stream-cons (stream-car strm) 109 (loop (stream-drop-while (lambda (x) (eql? (stream-car strm) x)) strm))) ) ) ) 88 110 89 111 (define (stream-fold-one func strm) 90 (stream-fold func (stream-car strm) (stream-cdr strm))) 112 (%check-stream 'stream-fold-one strm 'stream) 113 (%check-procedure 'stream-fold-one func 'function) 114 (stream-fold func (stream-car strm) (stream-cdr strm)) ) 91 115 92 116 (define-stream (stream-member eql? obj strm) 117 (%check-stream 'stream-member strm 'stream) 118 (%check-procedure 'stream-member eql? 'equivalence) 93 119 (stream-let loop ((strm strm)) 94 120 (cond ((stream-null? strm) #f) 95 121 ((eql? obj (stream-car strm)) strm) 96 (else (loop (stream-cdr strm)) ))))122 (else (loop (stream-cdr strm)) ) ) ) ) 97 123 98 124 (define-stream (stream-merge lt? . strms) 99 (define-stream (merge-stream xx yy) 125 126 (define-stream (stream-merge$ xx yy) 100 127 (stream-match xx 101 (() 102 yy) 128 (() yy ) 103 129 ((x . xs) 104 (stream-match yy 105 (() 106 xx) 107 ((y . ys) 108 (if (lt? y x) (stream-cons y (merge-stream xx ys)) 109 (stream-cons x (merge-stream xs yy)))))))) 130 (stream-match yy 131 (() xx ) 132 ((y . ys) 133 (if (lt? y x) (stream-cons y (stream-merge$ xx ys)) 134 (stream-cons x (stream-merge$ xs yy))))) ) ) ) 135 136 (%check-procedure 'stream-merge lt? 'less-than) 137 (%check-streams 'stream-merge strms 'stream) 110 138 (stream-let loop ((strms strms)) 111 139 (cond ((null? strms) stream-null) 112 ((null? ( cdr strms)) (car strms))113 (else ( merge-stream (car strms) (apply stream-merge lt? (cdr strms)))))))140 ((null? (%cdr strms)) (%car strms)) 141 (else (stream-merge$ (%car strms) (apply stream-merge lt? (%cdr strms))) ) ) ) ) 114 142 115 143 (define (stream-partition pred? strm) 144 (%check-stream 'stream-partition strm 'stream) 145 (%check-procedure 'stream-partition pred? 'predicate) 116 146 (stream-unfolds 117 147 (lambda (s) … … 120 150 (d (stream-cdr s))) 121 151 (if (pred? a) (values d (list a) #f) 122 (values d #f (list a)) ))))123 strm) )152 (values d #f (list a)) ) ) ) ) 153 strm) ) 124 154 125 155 (define-stream (stream-finds eql? obj strm) 126 (stream-of (car x) 156 (%check-stream 'stream-finds strm 'stream) 157 (%check-procedure 'stream-finds eql? 'equivalence) 158 (stream-of (%car x) 127 159 (x in (stream-zip (stream-from 0) strm)) 128 (eql? obj ( cadr x))))160 (eql? obj (%cadr x))) ) 129 161 130 162 (define (stream-find eql? obj strm) 131 (stream-car (stream-append (stream-finds eql? obj strm) (stream #f)))) 163 (%check-stream 'stream-find strm 'stream) 164 (%check-procedure 'stream-find eql? 'equivalence) 165 (stream-car (stream-append (stream-finds eql? obj strm) (stream #f))) ) 132 166 133 167 (define-stream (stream-remove pred? strm) 134 (stream-filter (complement pred?) strm)) 168 (%check-stream 'stream-remove strm 'stream) 169 (%check-procedure 'stream-remove pred? 'predicate) 170 (stream-filter (complement pred?) strm) ) 135 171 136 172 (define (stream-every pred? strm) 173 (%check-stream 'stream-every strm 'stream) 174 (%check-procedure 'stream-every pred? 'predicate) 137 175 (let loop ((strm strm)) 138 176 (cond ((stream-null? strm) #t) 139 177 ((not (pred? (stream-car strm))) #f) 140 (else (loop (stream-cdr strm)) ))))178 (else (loop (stream-cdr strm)) ) ) ) ) 141 179 142 180 (define (stream-any pred? strm) 181 (%check-stream 'stream-any strm 'stream) 182 (%check-procedure 'stream-any pred? 'predicate) 143 183 (let loop ((strm strm)) 144 184 (cond ((stream-null? strm) #f) 145 185 ((pred? (stream-car strm)) #t) 146 (else (loop (stream-cdr strm)) ))))186 (else (loop (stream-cdr strm)) ) ) ) ) 147 187 148 188 (define (stream-and strm) 189 (%check-stream 'stream-and strm 'stream) 149 190 (let loop ((strm strm)) 150 191 (cond ((stream-null? strm) #t) 151 192 ((not (stream-car strm)) #f) 152 (else (loop (stream-cdr strm)) ))))193 (else (loop (stream-cdr strm)) ) ) ) ) 153 194 154 195 (define (stream-or strm) 196 (%check-stream 'stream-or strm 'stream) 155 197 (let loop ((strm strm)) 156 198 (cond ((stream-null? strm) #f) 157 199 ((stream-car strm) #t) 158 (else (loop (stream-cdr strm)) ))))200 (else (loop (stream-cdr strm)) ) ) ) ) 159 201 160 202 (define (stream-fold-right func base strm) 161 (let loop ((base base) (strm strm)) 203 (%check-stream 'stream-fold-right strm 'stream) 204 (%check-procedure 'stream-fold-right func 'function) 205 (let loop ((strm strm)) 162 206 (if (stream-null? strm) base 163 (func (stream-car strm) (loop base (stream-cdr strm))))))207 (func (stream-car strm) (loop (stream-cdr strm))) ) ) ) 164 208 165 209 (define (stream-fold-right-one func strm) 166 (stream-match strm 167 ((x) 168 x) 169 ((x . xs) 170 (func x (stream-fold-right-one func xs))))) 171 172 (define (stream-assoc key dict) 173 (cond ((stream-null? dict) #f) 174 ((equal? key (car (stream-car dict))) (stream-car dict)) 175 (else (stream-assoc key (stream-cdr dict))))) 210 (%check-stream 'stream-fold-right-one strm 'stream) 211 (%check-procedure 'stream-fold-right-one func 'function) 212 (let loop ((strm strm)) 213 (stream-match strm 214 ((x) x ) 215 ((x . xs) (func x (loop xs)) ) ) ) ) 216 217 (define (stream-assoc key dict #!optional (eql? equal?)) 218 (%check-stream 'stream-assoc dict 'stream) 219 (%check-procedure 'stream-assoc eql? 'equivalence) 220 (let loop ((dict dict)) 221 (cond ((stream-null? dict) #f) 222 ((eql? key (%car (stream-car dict))) (stream-car dict) ) 223 (else (loop (stream-cdr dict)) ) ) ) ) 176 224 177 225 (define (stream-equal? eql? xs ys) 178 (cond ((and (stream-null? xs) (stream-null? ys)) #t) 179 ((or (stream-null? xs) (stream-null? ys)) #f) 180 ((not (eql? (stream-car xs) (stream-car ys))) #f) 181 (else (stream-equal? eql? (stream-cdr xs) (stream-cdr ys))))) 226 (%check-stream 'stream-equal? xs 'stream1) 227 (%check-stream 'stream-equal? ys 'stream2) 228 (let loop ((xs xs) (ys ys)) 229 (cond ((and (stream-null? xs) (stream-null? ys)) #t) 230 ((or (stream-null? xs) (stream-null? ys)) #f) 231 ((not (eql? (stream-car xs) (stream-car ys))) #f) 232 (else (loop (stream-cdr xs) (stream-cdr ys)) ) ) ) ) 182 233 183 234 (define-stream (stream-quick-sort lt? strm) 235 (%check-stream 'stream-quick-sort strm 'stream) 236 (%check-procedure 'stream-quick-sort lt? 'less-than) 184 237 (let loop ((strm strm)) 185 238 (if (stream-null? strm) stream-null … … 188 241 (stream-append (loop (stream-filter (lambda (u) (lt? u x)) xs)) 189 242 (stream x) 190 (loop (stream-filter (lambda (u) (not (lt? u x))) xs))) ))))243 (loop (stream-filter (lambda (u) (not (lt? u x))) xs))) ) ) ) ) 191 244 192 245 (define-stream (stream-insertion-sort lt? strm) 193 (define-stream (insert strm x) 246 247 (define-stream (insert$ strm x) 194 248 (stream-match strm 195 249 (() 196 (stream x))250 (stream x) ) 197 251 ((y . ys) 198 (if (lt? y x) (stream-cons y (insert ys x)) 199 (stream-cons x strm))))) 200 (stream-fold insert stream-null strm)) 252 (if (lt? y x) (stream-cons y (insert$ ys x)) 253 (stream-cons x strm) ) ) ) ) 254 255 (%check-stream 'stream-insertion-sort strm 'stream) 256 (%check-procedure 'stream-insertion-sort lt? 'less-than) 257 (stream-fold insert$ stream-null strm) ) 201 258 202 259 (define-stream (stream-merge-sort lt? strm) 260 (%check-stream 'stream-merge-sort strm 'stream) 261 (%check-procedure 'stream-merge-sort lt? 'less-than) 203 262 (let loop ((strm strm)) 204 263 (let ((n (quotient (stream-length strm) 2))) 205 264 (if (zero? n) strm 206 (stream-merge lt? (loop (stream-take n strm)) (loop (stream-drop n strm))) ))))265 (stream-merge lt? (loop (stream-take n strm)) (loop (stream-drop n strm))) ) ) ) ) 207 266 208 267 (define (stream-maximum lt? strm) 209 (stream-fold-one (lambda (x y) (if (lt? x y) y x)) strm)) 268 (%check-stream 'stream-maximum strm 'stream) 269 (%check-procedure 'stream-maximum lt? 'less-than) 270 (stream-fold-one (lambda (x y) (if (lt? x y) y x)) strm) ) 210 271 211 272 (define (stream-minimum lt? strm) 212 (stream-fold-one (lambda (x y) (if (lt? x y) x y)) strm)) 273 (%check-stream 'stream-minimum strm 'stream) 274 (%check-procedure 'stream-minimum lt? 'less-than) 275 (stream-fold-one (lambda (x y) (if (lt? x y) x y)) strm) ) 213 276 214 277 ) ;module streams-utils -
release/4/srfi-41/trunk/streams.scm
r14140 r14192 23 23 stream-iterate stream-length stream-let stream-map stream-match 24 24 stream-of stream-range stream-ref stream-reverse stream-scan stream-take 25 stream-take-while stream-unfold stream-unfolds stream-zip) 25 stream-take-while stream-unfold stream-unfolds stream-zip 26 ;; Extras 27 stream-occupied? 28 ;; Common errors 29 check-stream error-stream 30 check-stream-occupied error-stream-occupied) 26 31 27 32 (import scheme chicken streams-primitive streams-derived) 28 29 33 (require-library streams-primitive streams-derived) 30 34 -
release/4/srfi-41/trunk/tests/run.scm
r14176 r14192 24 24 ((tester descrip expr result) 25 25 (let ((val (handle-exceptions exp 26 (begin27 #;(apply print ((condition-property-accessor 'exn 'location) exp) " : " ((condition-property-accessor 'exn 'message) exp) " : " ((condition-property-accessor 'exn 'arguments) exp))28 26 (string-append 29 27 (symbol->string ((condition-property-accessor 'exn 'location) exp)) 30 28 ": " ((condition-property-accessor 'exn 'message) exp)) 31 )32 29 expr ) ) ) 33 30 (unless (equal? val result) … … 122 119 ; stream->list 123 120 (tester (stream->list '()) "stream->list: bad `stream' argument type - expected a stream") 124 (tester (stream->list "four" strm123) "stream->list: bad ` length' argument type - expected a cardinal-integer")125 (tester (stream->list -1 strm123) "stream->list: bad ` length' argument type - expected a cardinal-integer")121 (tester (stream->list "four" strm123) "stream->list: bad `count' argument type - expected a cardinal-integer") 122 (tester (stream->list -1 strm123) "stream->list: bad `count' argument type - expected a cardinal-integer") 126 123 (tester (stream->list (stream)) '()) 127 124 (tester (stream->list strm123) '(1 2 3)) … … 364 361 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; leak tests 365 362 366 (define-constant SIZE 1000 )363 (define-constant SIZE 1000000) 367 364 368 365 ;;
Note: See TracChangeset
for help on using the changeset viewer.