Changeset 14169 in project


Ignore:
Timestamp:
04/08/09 05:38:43 (11 years ago)
Author:
Kon Lovett
Message:

Save.

Location:
release/4/srfi-41/trunk
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • release/4/srfi-41/trunk/srfi-41.meta

    r14140 r14169  
    88 (doc-from-wiki)
    99 (synopsis "SRFI-41 (Streams)")
    10  (needs check-errors setup-helper)
     10 (needs check-errors srfi-45 setup-helper)
    1111 (files
    1212  "tests"
  • release/4/srfi-41/trunk/srfi-41.setup

    r14055 r14169  
    44
    55(verify-extension-name "srfi-41")
     6
     7(required-extension-version 'srfi-45 "2.1.0")
    68
    79(setup-shared-extension-module 'streams-primitive (extension-version "1.0.0"))
  • release/4/srfi-41/trunk/streams-derived.scm

    r14144 r14169  
    3939             (loop (map cdr lists)) ) ) ) )
    4040
    41 (define-inline (%check-for-non-stream loc strms)
     41(define-inline (%check-for-non-stream loc strms nam)
    4242  (when (%exists (lambda (x) (not (stream? x))) strms)
    43     (error-stream loc strms) ) )
     43    (error-stream loc strms nam) ) )
     44
    4445;;;
    4546
     
    9293     ((letrec ((TAG (stream-lambda (NAME ...) BODY0 BODY1 ...))) TAG) VAL ...))))
    9394
    94 #;
    95 (define-syntax stream-match-pattern
    96   (lambda (x)
    97 
    98     (define (wildcard? x)
    99       (and (identifier? x)
    100            (free-identifier=? x #'_)))
    101 
    102     (syntax-case x ()
    103       ((stream-match-pattern STRM () (BINDING ...) BODY)
    104        #'(and (stream-null? STRM)
    105               (let (BINDING ...) BODY)))
    106 
    107       ((stream-match-pattern STRM (W? . REST) (BINDING ...) BODY)
    108        (wildcard? #'W?)
    109        #'(and (stream-pair? STRM)
    110               (let ((STRM (stream-cdr STRM)))
    111                 (stream-match-pattern STRM REST (BINDING ...) BODY))))
    112 
    113       ((stream-match-pattern STRM (VAR . REST) (BINDING ...) BODY)
    114        #'(and (stream-pair? STRM)
    115               (let ((temp (stream-car STRM)) (STRM (stream-cdr STRM)))
    116                 (stream-match-pattern STRM REST ((VAR temp) BINDING ...) BODY))))
    117 
    118       ((stream-match-pattern STRM W? (BINDING ...) BODY)
    119        (wildcard? #'W?)
    120        #'(let (BINDING ...) BODY))
    121 
    122       ((stream-match-pattern STRM VAR (BINDING ...) BODY)
    123        #'(let ((VAR STRM) BINDING ...) BODY)))))
    124 
    125 #;
    126 (define-syntax stream-match-pattern
    127   (lambda (form r c)
    128     (let ((stream-null?$ (r 'stream-null?))
    129           (let$ (r 'let))
    130           (stream-pair?$ (r 'stream-pair?))
    131           (stream-car$ (r 'stream-car))
    132           (stream-cdr$ (r 'stream-cdr))
    133           (stream-match-pattern$ (r 'stream-match-pattern))
    134           (rest (cdr form)))
    135 
    136 ) ) )
    137 
    13895(define-syntax $stream-match-pattern$
    13996  (syntax-rules (_)
     
    173130    ((stream-match STRM-EXPR CLAUSE ...)
    174131     (let ((strm STRM-EXPR))
    175        (cond ((not (stream? strm)) (error-stream 'stream-match strm))
     132       (cond ((not (stream? strm)) (error-stream 'stream-match strm 'stream))
    176133             (($stream-match-test$ strm CLAUSE) => car) ...
    177134             (else (##sys#signal-hook #:error 'stream-match "no matching pattern")))))))
    178 
    179 #;
    180 (define-syntax stream-of-aux
    181   (syntax-rules (in is)
    182 
    183     ((stream-of-aux EXPR BASE)
    184      (stream-cons EXPR BASE))
    185 
    186     ((stream-of-aux EXPR BASE (VAR in STREAM) REST ...)
    187      (stream-let loop ((strm STREAM))
    188        (if (stream-null? strm) BASE
    189            (let ((VAR (stream-car strm)))
    190              (stream-of-aux EXPR (loop (stream-cdr strm)) REST ...)))))
    191 
    192     ((stream-of-aux EXPR BASE (VAR is EXP) REST ...)
    193      (let ((VAR EXP)) (stream-of-aux EXPR BASE REST ...)))
    194 
    195     ((stream-of-aux EXPR BASE PRED? REST ...)
    196      (if PRED? (stream-of-aux EXPR BASE REST ...) BASE))))
    197135
    198136(define-syntax stream-of
     
    219157;;
    220158
    221 (define (list->stream objs)
     159(define (list->stream objects)
    222160
    223161  (define-stream (list->stream$ objs)
     
    225163        (stream-cons (car objs) (list->stream$ (cdr objs))) ) )
    226164
    227   (check-list 'list->stream objs)
    228   (list->stream$ objs) )
     165  (check-list 'list->stream objects 'objects)
     166  (list->stream$ objects) )
    229167
    230168(define (stream->list . args)
    231   (let ((n (if (= 1 (length args)) #f (car args)))
    232         (strm (if (= 1 (length args)) (car args) (cadr args))))
    233     (check-stream 'stream->list strm)
    234     (when n (check-cardinal-integer 'stream->list n))
    235     (let loop ((n (or n -1)) (strm strm))
     169  (let ((length (if (= 1 (length args)) #f (car args)))
     170        (streem (if (= 1 (length args)) (car args) (cadr args))))
     171    (check-stream 'stream->list streem 'stream)
     172    (when length (check-cardinal-integer 'stream->list length 'length))
     173    (let loop ((n (or length -1)) (strm streem))
    236174      (if (or (zero? n) (stream-null? strm)) '()
    237           (cons (stream-car strm) (loop (- n 1) (stream-cdr strm))) ) ) ) )
     175          (cons (stream-car strm) (loop (sub1 n) (stream-cdr strm))) ) ) ) )
    238176
    239177(define (port->stream . port)
     
    244182          (stream-cons c (port->stream$ p)) ) )  )
    245183
    246   (let ((p (if (null? port) (current-input-port) (car port))))
    247     (check-input-port 'port->stream p)
    248     (port->stream$ p)) )
    249 
    250 (define (stream-append . strms)
     184  (let ((port (if (null? port) (current-input-port) (car port))))
     185    (check-input-port 'port->stream port 'port)
     186    (port->stream$ port)) )
     187
     188(define (stream-length streem)
     189  (check-stream 'stream-length streem 'stream)
     190  (let loop ((len 0) (strm streem))
     191    (if (stream-null? strm) len
     192        (loop (add1 len) (stream-cdr strm)) ) ) )
     193
     194(define (stream-ref streem index)
     195  (check-stream 'stream-ref streem 'stream)
     196  (check-cardinal-integer 'stream-ref index 'index)
     197  (let loop ((strm streem) (n index))
     198    (cond ((stream-null? strm)
     199           (##sys#signal-hook #:bounds-error 'stream-ref "beyond end of stream" strm index))
     200          ((zero? n)
     201           (stream-car strm))
     202          (else
     203           (loop (stream-cdr strm) (sub1 n)) ) ) ) )
     204
     205(define (stream-reverse streem)
     206
     207  (define-stream (stream-reverse$ strm rev)
     208    (if (stream-null? strm) rev
     209        (stream-reverse$ (stream-cdr strm) (stream-cons (stream-car strm) rev)) ) )
     210
     211  (check-stream 'stream-reverse streem 'stream)
     212  (stream-reverse$ streem stream-null) )
     213
     214(define (stream-append . streems)
    251215
    252216  (define-stream (stream-append$ strms)
     
    257221                              (cons (stream-cdr (car strms)) (cdr strms)))) ) ) )
    258222
    259   (if (null? strms) stream-null
     223  (if (null? streems) stream-null
    260224      (begin
    261         (%check-for-non-stream 'stream-append strms)
    262         (stream-append$ strms) ) ) )
    263 
    264 (define (stream-concat strm)
    265 
    266   (define-stream (stream-concat$ strmpair)
    267     (cond ((stream-null? strmpair)
     225        (%check-for-non-stream 'stream-append streems 'streams)
     226        (stream-append$ streems) ) ) )
     227
     228(define (stream-concat streem)
     229
     230  (define-stream (stream-concat$ strm)
     231    (cond ((stream-null? strm)
    268232           stream-null)
    269           ((not (stream? (stream-car strmpair)))
    270            (error-stream 'stream-concat strmpair))
    271           ((stream-null? (stream-car strmpair))
    272            (stream-concat$ (stream-cdr strmpair)))
     233          ((not (stream? (stream-car strm)))
     234           (error-stream 'stream-concat strm))
     235          ((stream-null? (stream-car strm))
     236           (stream-concat$ (stream-cdr strm)))
    273237          (else
    274            (stream-cons (stream-car (stream-car strmpair))
     238           (stream-cons (stream-car (stream-car strm))
    275239                        (stream-concat$
    276                          (stream-cons (stream-cdr (stream-car strmpair))
    277                                       (stream-cdr strmpair)))) ) ) )
    278 
    279   (check-stream 'stream-concat strm)
    280   (stream-concat$ strm) )
     240                         (stream-cons (stream-cdr (stream-car strm))
     241                                      (stream-cdr strm)))) ) ) )
     242
     243  (check-stream 'stream-concat streem 'stream)
     244  (stream-concat$ streem) )
    281245
    282246(define stream-constant
     
    287251                             (apply stream-constant (append (cdr objs) (list (car objs))))) ) ) ) )
    288252
    289 (define (stream-drop n strm)
     253(define (stream-drop count streem)
    290254
    291255  (define-stream (stream-drop$ n strm)
    292256    (if (or (zero? n) (stream-null? strm)) strm
    293         (stream-drop$ (- n 1) (stream-cdr strm)) ) )
    294 
    295   (check-stream 'stream-drop strm)
    296   (check-cardinal-integer 'stream-drop n)
    297   (stream-drop$ n strm) )
    298 
    299 (define (stream-drop-while pred? strm)
     257        (stream-drop$ (sub1 n) (stream-cdr strm)) ) )
     258
     259  (check-stream 'stream-drop streem 'stream)
     260  (check-cardinal-integer 'stream-drop count 'count)
     261  (stream-drop$ count streem) )
     262
     263(define (stream-drop-while predicate? streem)
    300264
    301265  (define-stream (stream-drop-while$ strm)
    302     (if (not (and (stream-pair? strm) (pred? (stream-car strm)))) strm
     266    (if (not (and (stream-pair? strm) (predicate? (stream-car strm)))) strm
    303267        (stream-drop-while$ (stream-cdr strm)) ) )
    304268
    305   (check-procedure 'stream-drop-while pred?)
    306   (check-stream 'stream-drop-while strm)
    307   (stream-drop-while$ strm) )
    308 
    309 (define (stream-filter pred? strm)
     269  (check-procedure 'stream-drop-while predicate? 'predicate?)
     270  (check-stream 'stream-drop-while streem 'stream)
     271  (stream-drop-while$ streem) )
     272
     273(define (stream-take count streem)
     274
     275  (define-stream (stream-take$ n strm)
     276    (if (or (stream-null? strm) (zero? n)) stream-null
     277        (stream-cons (stream-car strm) (stream-take$ (sub1 n) (stream-cdr strm))) ) )
     278
     279  (check-stream 'stream-take streem 'stream)
     280  (check-cardinal-integer 'stream-take count 'count)
     281  (stream-take$ count streem) )
     282
     283(define (stream-take-while predicate? streem)
     284
     285 (define-stream (stream-take-while$ strm)
     286    (cond ((stream-null? strm)
     287           stream-null)
     288          ((predicate? (stream-car strm))
     289           (stream-cons (stream-car strm) (stream-take-while$ (stream-cdr strm))))
     290          (else
     291           stream-null ) ) )
     292
     293  (check-procedure 'stream-take-while predicate? 'predicate?)
     294  (check-stream 'stream-take-while streem 'stream)
     295  (stream-take-while$ streem) )
     296
     297(define (stream-filter predicate? streem)
    310298
    311299  (define-stream (stream-filter$ strm)
    312300    (cond ((stream-null? strm)
    313301           stream-null)
    314           ((pred? (stream-car strm))
     302          ((predicate? (stream-car strm))
    315303           (stream-cons (stream-car strm) (stream-filter$ (stream-cdr strm))))
    316304          (else
    317305           (stream-filter$ (stream-cdr strm)) ) ) )
    318306
    319   (check-procedure 'stream-filter pred?)
    320   (check-stream 'stream-filter strm)
    321   (stream-filter$ strm) )
    322 
    323 #;
    324 (define (stream-fold proc base strm)
    325   (check-procedure 'stream-fold proc)
    326   (check-stream 'stream-fold strm)
    327   (let loop ((base base) (strm strm))
    328     (if (stream-null? strm) base
    329         (loop (proc base (stream-car strm)) (stream-cdr strm)))))
    330 
    331 (define (stream-fold proc base strm . strms)
     307  (check-procedure 'stream-filter predicate? 'predicate?)
     308  (check-stream 'stream-filter streem 'stream)
     309  (stream-filter$ streem) )
     310
     311(define (stream-scan function base streem)
     312
     313  (define-stream (stream-scan$ base strm)
     314    (if (stream-null? strm) (stream base)
     315        (stream-cons base
     316                    (stream-scan$ (function base (stream-car strm)) (stream-cdr strm))) ) )
     317
     318  (check-procedure 'stream-scan function 'function)
     319  (check-stream 'stream-scan streem 'stream)
     320  (stream-scan$ base streem) )
     321
     322(define (stream-fold function base streem . streems)
    332323
    333324  (define (stream-folder base strms)
    334325    (if (%exists stream-null? strms) base
    335         (stream-folder (apply proc base (map stream-car strms))
     326        (stream-folder (apply function base (map stream-car strms))
    336327                       (map stream-cdr strms)) ) )
    337328
    338   (check-procedure 'stream-fold proc)
    339   (let ((strms (cons strm strms)))
    340     (%check-for-non-stream 'stream-fold strms)
    341     (stream-folder base strms) ) )
    342 
    343 (define (stream-for-each proc strm . strms)
     329  (check-procedure 'stream-fold function 'function)
     330  (let ((streems (cons streem streems)))
     331    (%check-for-non-stream 'stream-fold streems 'streams)
     332    (stream-folder base streems) ) )
     333
     334(define (stream-for-each procedure streem . streems)
    344335
    345336  (define (stream-for-each$ strms)
    346337    (unless (%exists stream-null? strms)
    347       (apply proc (map stream-car strms))
     338      (apply procedure (map stream-car strms))
    348339      (stream-for-each$ (map stream-cdr strms)) ) )
    349340
    350   (check-procedure 'stream-for-each proc)
    351   (let ((strms (cons strm strms)))
    352     (%check-for-non-stream 'stream-for-each strms)
    353     (stream-for-each$ strms) ) )
    354 
    355 (define (stream-map proc strm . strms)
     341  (check-procedure 'stream-for-each procedure 'procedure)
     342  (let ((streems (cons streem streems)))
     343    (%check-for-non-stream 'stream-for-each streems 'streams)
     344    (stream-for-each$ streems) ) )
     345
     346(define (stream-map function streem . streems)
    356347
    357348  ; not tail-recursive to avoid `stream-reverse'
    358349  (define-stream (stream-map$ strms)
    359350    (if (%exists stream-null? strms) stream-null
    360         (stream-cons (apply proc (map stream-car strms))
     351        (stream-cons (apply function (map stream-car strms))
    361352                     (stream-map$ (map stream-cdr strms))) ) )
    362353
    363   (check-procedure 'stream-map proc)
    364   (let ((strms (cons strm strms)))
    365     (%check-for-non-stream 'stream-map strms)
    366     (stream-map$ strms) ) )
     354  (check-procedure 'stream-map function 'function)
     355  (let ((streems (cons streem streems)))
     356    (%check-for-non-stream 'stream-map streems 'streams)
     357    (stream-map$ streems) ) )
    367358
    368359(define (stream-from first . step)
     
    372363
    373364  (let ((delta (if (null? step) 1 (car step))))
    374     (check-number 'stream-from first)
    375     (check-number 'stream-from delta)
     365    (check-number 'stream-from first 'first)
     366    (check-number 'stream-from delta 'delta)
    376367    (stream-from$ first delta) ) )
    377368
    378 (define (stream-iterate proc base)
     369(define (stream-iterate function base)
    379370
    380371  (define-stream (stream-iterate$ base)
    381     (stream-cons base (stream-iterate$ (proc base))) )
    382 
    383   (check-procedure 'stream-iterate proc)
     372    (stream-cons base (stream-iterate$ (function base))) )
     373
     374  (check-procedure 'stream-iterate function 'function)
    384375  (stream-iterate$ base) )
    385 
    386 (define (stream-length strm)
    387   (check-stream 'stream-length strm)
    388   (let loop ((len 0) (strm strm))
    389     (if (stream-null? strm) len
    390         (loop (+ len 1) (stream-cdr strm)) ) ) )
    391376
    392377(define (stream-range first past . step)
     
    396381        (stream-cons first (stream-range$ (+ first delta) past delta lt?)) ) )
    397382
    398   (check-number 'stream-range first)
    399   (check-number 'stream-range past)
     383  (check-number 'stream-range first 'first)
     384  (check-number 'stream-range past 'past)
    400385  (let ((delta (cond ((pair? step) (car step)) ((< first past) 1) (else -1))))
    401     (check-number 'stream-range delta)
     386    (check-number 'stream-range delta 'delta)
    402387    (let ((lt? (if (< 0 delta) < >)))
    403388      (stream-range$ first past delta lt?) ) ) )
    404389
    405 (define (stream-ref strm idx)
    406   (check-stream 'stream-ref strm)
    407   (check-cardinal-integer 'stream-ref idx)
    408   (let loop ((strm strm) (n idx))
    409     (cond ((stream-null? strm)
    410            (##sys#signal-hook #:bounds-error 'stream-ref "beyond end of stream" strm idx))
    411           ((zero? n)
    412            (stream-car strm))
    413           (else
    414            (loop (stream-cdr strm) (- n 1)) ) ) ) )
    415 
    416 (define (stream-reverse strm)
    417 
    418   (define-stream (stream-reverse$ strm rev)
    419     (if (stream-null? strm) rev
    420         (stream-reverse$ (stream-cdr strm) (stream-cons (stream-car strm) rev)) ) )
    421 
    422   (check-stream 'stream-reverse strm)
    423   (stream-reverse$ strm stream-null) )
    424 
    425 (define (stream-scan proc base strm)
    426 
    427   (define-stream (stream-scan$ base strm)
    428     (if (stream-null? strm) (stream base)
    429         (stream-cons base (stream-scan$ (proc base (stream-car strm)) (stream-cdr strm))) ) )
    430 
    431   (check-procedure 'stream-scan proc)
    432   (check-stream 'stream-scan strm)
    433   (stream-scan$ base strm) )
    434 
    435 (define (stream-take n strm)
    436 
    437   (define-stream (stream-take$ n strm)
    438     (if (or (stream-null? strm) (zero? n)) stream-null
    439         (stream-cons (stream-car strm) (stream-take$ (- n 1) (stream-cdr strm))) ) )
    440 
    441   (check-stream 'stream-take strm)
    442   (check-cardinal-integer 'stream-take n)
    443   (stream-take$ n strm) )
    444 
    445 (define (stream-take-while pred? strm)
    446 
    447  (define-stream (stream-take-while$ strm)
    448     (cond ((stream-null? strm)
    449            stream-null)
    450           ((pred? (stream-car strm))
    451            (stream-cons (stream-car strm) (stream-take-while$ (stream-cdr strm))))
    452           (else
    453            stream-null ) ) )
    454 
    455   (check-procedure 'stream-take-while pred?)
    456   (check-stream 'stream-take-while strm)
    457   (stream-take-while$ strm) )
    458 
    459 (define (stream-unfold mapper pred? generator base)
     390(define (stream-unfold mapper predicate? generator base)
    460391
    461392  (define-stream (stream-unfold$ base)
    462     (if (not (pred? base)) stream-null
     393    (if (not (predicate? base)) stream-null
    463394        (stream-cons (mapper base) (stream-unfold$ (generator base))) ) )
    464395
    465   (check-procedure 'stream-unfold mapper)
    466   (check-procedure 'stream-unfold pred?)
    467   (check-procedure 'stream-unfold generator)
     396  (check-procedure 'stream-unfold mapper 'mapper)
     397  (check-procedure 'stream-unfold predicate? 'predicate?)
     398  (check-procedure 'stream-unfold generator 'generator)
    468399  (stream-unfold$ base) )
    469400
    470 (define (stream-unfolds gen seed)
    471 
    472   (define (len-values gen seed)
     401(define (stream-unfolds generator seed)
     402
     403  (define (len-values)
    473404    (call-with-values
    474       (lambda () (gen seed))
    475       (lambda vs (- (length vs) 1))) )
    476 
    477   (define-stream (unfold-result-stream gen seed)
     405      (lambda () (generator seed))
     406      (lambda vs (sub1 (length vs)))) )
     407
     408  (define-stream (unfold-result-stream seed)
    478409    (call-with-values
    479       (lambda () (gen seed))
     410      (lambda () (generator seed))
    480411      (lambda (next . results)
    481         (stream-cons results (unfold-result-stream gen next)))) )
     412        (stream-cons results (unfold-result-stream next)))) )
    482413
    483414  (define-stream (result-stream->output-stream result-stream i)
    484     (let ((result (list-ref (stream-car result-stream) (- i 1))))
     415    (let ((result (list-ref (stream-car result-stream) (sub1 i))))
    485416      (cond ((pair? result)
    486417             (stream-cons (car result)
     
    494425
    495426  (define (result-stream->output-streams result-stream)
    496     (let loop ((i (len-values gen seed)) (outputs '()))
     427    (let loop ((i (len-values)) (outputs '()))
    497428      (if (zero? i) (apply values outputs)
    498           (loop (- i 1) (cons (result-stream->output-stream result-stream i) outputs)) ) ) )
    499 
    500   (check-procedure 'stream-unfolds gen)
    501   (result-stream->output-streams (unfold-result-stream gen seed)) )
    502 
    503 (define (stream-zip strm . strms)
     429          (loop (sub1 i) (cons (result-stream->output-stream result-stream i) outputs)) ) ) )
     430
     431  (check-procedure 'stream-unfolds generator 'generator)
     432  (result-stream->output-streams (unfold-result-stream seed)) )
     433
     434(define (stream-zip streem . streems)
    504435
    505436  (define-stream (stream-zip$ strms)
     
    508439                     (stream-zip$ (map stream-cdr strms))) ) )
    509440
    510   (let ((strms (cons strm strms)))
    511     (%check-for-non-stream 'stream-zip strms)
    512     (stream-zip$ strms) ) )
     441  (let ((streems (cons streem streems)))
     442    (%check-for-non-stream 'stream-zip streems 'streams)
     443    (stream-zip$ streems) ) )
    513444
    514445) ;module streams-derived
  • release/4/srfi-41/trunk/streams-primitive.scm

    r14147 r14169  
    3131(define-inline (%stream-null? strm) (eq? (%stream-force strm) (%stream-force stream-null)))
    3232
     33(define-inline (%checked-stream-pair loc obj)
     34  (if (not (stream? obj)) (error-stream loc obj 'stream)
     35      (if (%stream-null? obj) (error-stream-occupied loc obj 'stream)
     36          (let ((val (%stream-force obj)))
     37          (if (stream-pare? val) val
     38              (error-stream-pair loc val 'stream)) ) ) ) )
     39
    3340(module streams-primitive (;export
    3441  ;; SRFI 41 primitive
    3542  stream?
    3643  stream-null stream-null?
    37   (stream-cons $stream-eager$ $make-stream-pare$)
     44  (stream-cons $$stream-eager $$make-stream-pare)
    3845  stream-pair? stream-car stream-cdr
    3946  stream-lambda
    4047  ;; Extras
    41   occupied-stream?
     48  stream-occupied?
    4249  ;; Common errors
    4350  check-stream error-stream
    44   check-occupied-stream error-occupied-stream
     51  check-stream-occupied error-stream-occupied
    4552  ;; WTF
    46   ($stream-lazy$ $make-stream$)
    47   ($stream-delay$ $stream-eager$)
    48   $make-stream$
    49   $stream-eager$
    50   $make-stream-pare$)
     53  ($$stream-lazy $$make-stream)
     54  ($$stream-delay $$stream-eager)
     55  $$make-stream
     56  $$stream-eager
     57  $$make-stream-pare)
    5158
    5259(import
     
    5562  #;srfi-9
    5663  (only srfi-45 eager lazy force)
    57   (only type-checks define-check+error-type))
     64  (only type-checks define-check+error-type)
     65  (only type-errors define-error-type))
    5866
    59 (require-library #;srfi-9 srfi-45 type-checks)
     67(require-library #;srfi-9 srfi-45 type-checks type-errors)
    6068
    6169;;;
    6270
    6371(define-record-type stream
    64   ($make-stream$ p)
     72  ($$make-stream p)
    6573  stream?
    6674  (p stream-promise) )
     
    6876(define-check+error-type stream)
    6977
    70 (define-syntax $stream-lazy$
    71   (syntax-rules ()
    72     ((_ EXPR) ($make-stream$ (lazy EXPR)) ) ) )
     78(define-syntax $$stream-lazy (syntax-rules () ((_ EXPR) ($$make-stream (lazy EXPR)))))
     79(define ($$stream-eager expr) ($$make-stream (eager expr)))
     80(define-syntax $$stream-delay (syntax-rules () ((_ EXPR) ($$stream-lazy ($$stream-eager EXPR)))))
    7381
    74 (define ($stream-eager$ expr) ($make-stream$ (eager expr)))
    75 
    76 (define-syntax $stream-delay$
    77   (syntax-rules ()
    78     ((_ EXPR) ($stream-lazy$ ($stream-eager$ EXPR)) ) ) )
    79 
    80 (define *stream-null-tag* (cons 'stream 'null))
    81 
    82 (define stream-null ($stream-delay$ *stream-null-tag*))
     82(define stream-null ($$stream-delay (cons 'stream 'null)))
    8383
    8484(define (stream-null? obj) (and (stream? obj) (%stream-null? obj)))
     85(define (stream-occupied? obj) (and (stream? obj) (not (%stream-null? obj))))
    8586
    86 (define (occupied-stream? obj) (and (stream? obj) (not (%stream-null? obj))))
    87 
    88 (define-check+error-type occupied-stream)
     87(define-check+error-type stream-occupied)
    8988
    9089(define-record-type stream-pare
    91   ($make-stream-pare$ kar kdr)
     90  ($$make-stream-pare kar kdr)
    9291  stream-pare?
    9392  (kar stream-kar)
     
    9796  (syntax-rules ()
    9897    ((_ OBJ STRM)
    99      ($stream-eager$ ($make-stream-pare$ ($stream-delay$ OBJ) ($stream-lazy$ STRM))) ) ) )
     98     ($$stream-eager ($$make-stream-pare ($$stream-delay OBJ) ($$stream-lazy STRM))) ) ) )
    10099
    101 (define (stream-pair? obj)
    102 #;(print 'stream-pair? " " obj " " (%stream-force obj))
    103   (and (stream? obj) (stream-pare? (%stream-force obj))) )
     100(define (stream-pair? obj) (and (stream? obj) (stream-pare? (%stream-force obj))))
    104101
    105 (define (checked-stream-pair loc obj)
    106 #;(print 'checked-stream-pair " " obj " " (%stream-force obj))
    107   (or (and-let* (((stream? obj))
    108                   (val (%stream-force obj))
    109                   ((stream-pare? val)))
    110         val)
    111       (##sys#signal-hook #:type-error loc "bad argument type - expected a stream-pair" obj)) )
     102(define-error-type stream-pair)
    112103
    113 (define (stream-car strm)
    114   (%stream-force (stream-kar (checked-stream-pair 'stream-car strm))) )
     104(define (stream-car streem)
     105  (%stream-force (stream-kar (%checked-stream-pair 'stream-car streem))) )
    115106
    116 (define (stream-cdr strm)
    117   (stream-kdr (checked-stream-pair 'stream-cdr strm)) )
     107(define (stream-cdr streem)
     108  (stream-kdr (%checked-stream-pair 'stream-cdr streem)) )
    118109
    119110(define-syntax stream-lambda
    120111  (syntax-rules ()
    121112    ((_ FORMALS BODY0 BODY1 ...)
    122      (lambda FORMALS ($stream-lazy$ (let () BODY0 BODY1 ...))) ) ) )
     113     (lambda FORMALS ($$stream-lazy (let () BODY0 BODY1 ...))) ) ) )
    123114
    124115) ;module streams-primitive
  • release/4/srfi-41/trunk/tests/run.scm

    r14147 r14169  
    2323      (tester "" expr result) )
    2424    ((tester descrip expr result)
    25       (handle-exceptions exp
    26           (string-append
    27            (symbol->string ((condition-property-accessor 'exn 'location) exp))
    28            ": "
    29            ((condition-property-accessor 'exn 'message) exp))
    30         (unless (equal? expr result)
     25      (let ((val (handle-exceptions exp
     26(begin
     27#;(apply print ((condition-property-accessor 'exn 'location) exp) " : " ((condition-property-accessor 'exn 'message) exp) " : " ((condition-property-accessor 'exn 'arguments) exp))
     28                     (string-append
     29                       (symbol->string ((condition-property-accessor 'exn 'location) exp))
     30                       ": " ((condition-property-accessor 'exn 'message) exp))
     31)
     32                   expr ) ) )
     33        (unless (equal? val result)
    3134          (newline) (display "failed tester: ") (display descrip) (newline)
    3235          (write 'expr) (newline)
     
    6568
    6669  ; stream-car
    67   (tester (stream-car "four") "stream-car: non-stream")
    68   (tester (stream-car stream-null) "stream-car: null stream")
     70  (tester (stream-car "four") "stream-car: bad `stream' argument type - expected a stream")
     71  (tester (stream-car stream-null) "stream-car: bad argument type - expected an occupied-stream")
    6972  (tester (stream-car strm123) 1)
    7073
    7174  ; stream-cdr
    72   (tester (stream-cdr "four") "stream-cdr: non-stream")
    73   (tester (stream-cdr stream-null) "stream-cdr: null stream")
     75  (tester (stream-cdr "four") "stream-cdr: bad `stream' argument type - expected a stream")
     76  (tester (stream-cdr stream-null) "stream-cdr: bad argument type - expected an occupied-stream")
    7477  (tester (stream-car (stream-cdr strm123)) 2)
    7578
     
    101104
    102105  ; list->stream
    103   (tester (list->stream "four") "list->stream: non-list argument")
     106  (tester (list->stream "four") "list->stream: bad `objects' argument type - expected a list")
    104107  (tester (stream->list (list->stream '())) '())
    105108  (tester (stream->list (list->stream '(1 2 3))) '(1 2 3))
     
    108111  (let* ((p (open-input-file "streams.ss"))
    109112         (s (port->stream p)))
    110     (tester (port->stream "four") "port->stream: non-input-port argument")
     113    (tester (port->stream "four") "port->stream: bad `port' argument type - expected an input-port")
    111114    (tester (string=? (list->string (stream->list 11 s)) "; Copyright") #t)
    112115    (close-input-port p))
     
    118121
    119122  ; stream->list
    120   (tester (stream->list '()) "stream->list: non-stream argument")
    121   (tester (stream->list "four" strm123) "stream->list: non-integer count")
    122   (tester (stream->list -1 strm123) "stream->list: negative count")
     123  (tester (stream->list '()) "stream->list: bad `stream' argument type - expected a stream")
     124  (tester (stream->list "four" strm123) "stream->list: bad `count' argument type - expected a cardinal-integer")
     125  (tester (stream->list -1 strm123) "stream->list: bad `count' argument type - expected a cardinal-integer")
    123126  (tester (stream->list (stream)) '())
    124127  (tester (stream->list strm123) '(1 2 3))
     
    127130
    128131  ; stream-append
    129   (tester (stream-append "four") "stream-append: non-stream argument")
     132  (tester (stream-append "four") "stream-append: bad `stream' argument type - expected a stream")
    130133  (tester (stream->list (stream-append strm123)) '(1 2 3))
    131134  (tester (stream->list (stream-append strm123 strm123)) '(1 2 3 1 2 3))
     
    135138
    136139  ; stream-concat
    137   (tester (stream-concat "four") "stream-concat: non-stream argument")
     140  (tester (stream-concat "four") "stream-concat: bad `stream' argument type - expected a stream")
    138141  (tester (stream->list (stream-concat (stream strm123))) '(1 2 3))
    139142  (tester (stream->list (stream-concat (stream strm123 strm123))) '(1 2 3 1 2 3))
     
    145148
    146149  ; stream-drop
    147   (tester (stream-drop "four" strm123) "stream-drop: non-integer argument")
    148   (tester (stream-drop -1 strm123) "stream-drop: negative argument")
    149   (tester (stream-drop 2 "four") "stream-drop: non-stream argument")
     150  (tester (stream-drop "four" strm123) "stream-drop: bad `count' argument type - expected a cardinal-integer")
     151  (tester (stream-drop -1 strm123) "stream-drop: bad `count' argument type - expected a cardinal-integer")
     152  (tester (stream-drop 2 "four") "stream-drop: bad `stream' argument type - expected a stream")
    150153  (tester (stream->list (stream-drop 0 stream-null)) '())
    151154  (tester (stream->list (stream-drop 0 strm123)) '(1 2 3))
     
    154157
    155158  ; stream-drop-while
    156   (tester (stream-drop-while "four" strm123) "stream-drop-while: non-procedural argument")
    157   (tester (stream-drop-while odd? "four") "stream-drop-while: non-stream argument")
     159  (tester (stream-drop-while "four" strm123) "stream-drop-while: bad `predicate?' argument type - expected a procedure")
     160  (tester (stream-drop-while odd? "four") "stream-drop-while: bad `stream' argument type - expected a stream")
    158161  (tester (stream->list (stream-drop-while odd? stream-null)) '())
    159162  (tester (stream->list (stream-drop-while odd? strm123)) '(2 3))
     
    163166
    164167  ; stream-filter
    165   (tester (stream-filter "four" strm123) "stream-filter: non-procedural argument")
    166   (tester (stream-filter odd? '()) "stream-filter: non-stream argument")
     168  (tester (stream-filter "four" strm123) "stream-filter: bad `predicate?' argument type - expected a procedure")
     169  (tester (stream-filter odd? '()) "stream-filter: bad `stream' argument type - expected a stream")
    167170  (tester (stream-null? (stream-filter odd? (stream))) #t)
    168171  (tester (stream->list (stream-filter odd? strm123)) '(1 3))
     
    178181
    179182  ; stream-fold
    180   (tester (stream-fold "four" 0 strm123) "stream-fold: non-procedural argument")
    181   (tester (stream-fold + 0 '()) "stream-fold: non-stream argument")
     183  (tester (stream-fold "four" 0 strm123) "stream-fold: bad `function' argument type - expected a procedure")
     184  (tester (stream-fold + 0 '()) "stream-fold: bad `stream' argument type - expected a stream")
    182185  (tester (stream-fold + 0 strm123) 6)
    183186
    184187  ; stream-for-each
    185   (tester (stream-for-each "four" strm123) "stream-for-each: non-procedural argument")
     188  (tester (stream-for-each "four" strm123) "stream-for-each: bad `procedure' argument type - expected a procedure")
    186189  #;(tester (stream-for-each display) "stream-for-each: no stream arguments")
    187   (tester (stream-for-each display "four") "stream-for-each: non-stream argument")
     190  (tester (stream-for-each display "four") "stream-for-each: bad `stream' argument type - expected a stream")
    188191  (tester (let ((sum 0)) (stream-for-each (lambda (x) (set! sum (+ sum x))) strm123) sum) 6)
    189192
    190193  ; stream-from
    191   (tester (stream-from "four") "stream-from: non-numeric starting number")
    192   (tester (stream-from 1 "four") "stream-from: non-numeric step size")
     194  (tester (stream-from "four") "stream-from: bad `first' argument type - expected a number")
     195  (tester (stream-from 1 "four") "stream-from: bad `delta' argument type - expected a number")
    193196  (tester (stream-ref (stream-from 0) 100) 100)
    194197  (tester (stream-ref (stream-from 1 2) 100) 201)
     
    196199
    197200  ; stream-iterate
    198   (tester (stream-iterate "four" 0) "stream-iterate: non-procedural argument")
     201  (tester (stream-iterate "four" 0) "stream-iterate: bad `function' argument type - expected a procedure")
    199202  (tester (stream->list 3 (stream-iterate (left-section + 1) 1)) '(1 2 3))
    200203
    201204  ; stream-length
    202   (tester (stream-length "four") "stream-length: non-stream argument")
     205  (tester (stream-length "four") "stream-length: bad `stream' argument type - expected a stream")
    203206  (tester (stream-length (stream)) 0)
    204207  (tester (stream-length strm123) 3)
     
    215218
    216219  ; stream-map
    217   (tester (stream-map "four" strm123) "stream-map: non-procedural argument")
     220  (tester (stream-map "four" strm123) "stream-map: bad `function' argument type - expected a procedure")
    218221  #;(tester (stream-map odd?) "stream-map: no stream arguments")
    219   (tester (stream-map odd? "four") "stream-map: non-stream argument")
     222  (tester (stream-map odd? "four") "stream-map: bad `stream' argument type - expected a stream")
    220223  (tester (stream->list (stream-map - strm123)) '(-1 -2 -3))
    221224  (tester (stream->list (stream-map + strm123 strm123)) '(2 4 6))
     
    225228
    226229  ; stream-match
    227   (tester (stream-match '(1 2 3) (_ 'ok)) "stream-match: non-stream argument")
     230  (tester (stream-match '(1 2 3) (_ 'ok)) "stream-match: bad `stream' argument type - expected a stream")
    228231  (tester (stream-match strm123 (() 42)) "stream-match: pattern failure")
    229232  (tester (stream-match stream-null (() 'ok)) 'ok)
     
    255258
    256259  ; stream-range
    257   (tester (stream-range "four" 0) "stream-range: non-numeric starting number")
    258   (tester (stream-range 0 "four") "stream-range: non-numeric ending number")
    259   (tester (stream-range 1 2 "three") "stream-range: non-numeric step size")
     260  (tester (stream-range "four" 0) "stream-range: bad `first' argument type - expected a number")
     261  (tester (stream-range 0 "four") "stream-range: bad `past' argument type - expected a number")
     262  (tester (stream-range 1 2 "three") "stream-range: bad `delta' argument type - expected a number")
    260263  (tester (stream->list (stream-range 0 5)) '(0 1 2 3 4))
    261264  (tester (stream->list (stream-range 5 0)) '(5 4 3 2 1))
     
    265268
    266269  ; stream-ref
    267   (tester (stream-ref '() 4) "stream-ref: non-stream argument")
    268   (tester (stream-ref natural-numbers-stream 3.5) "stream-ref: non-integer argument")
    269   (tester (stream-ref natural-numbers-stream -3) "stream-ref: negative argument")
     270  (tester (stream-ref '() 4) "stream-ref: bad `stream' argument type - expected a stream")
     271  (tester (stream-ref natural-numbers-stream 3.5) "stream-ref: bad `index' argument type - expected a cardinal-integer")
     272  (tester (stream-ref natural-numbers-stream -3) "stream-ref: bad `index' argument type - expected a cardinal-integer")
    270273  (tester (stream-ref strm123 5) "stream-ref: beyond end of stream")
    271274  (tester (stream-ref strm123 0) 1)
     
    274277
    275278  ; stream-reverse
    276   (tester (stream-reverse '()) "stream-reverse: non-stream argument")
     279  (tester (stream-reverse '()) "stream-reverse: bad `stream' argument type - expected a stream")
    277280  (tester (stream->list (stream-reverse (stream))) '())
    278281  (tester (stream->list (stream-reverse strm123)) '(3 2 1))
    279282
    280283  ; stream-scan
    281   (tester (stream-scan "four" 0 strm123) "stream-scan: non-procedural argument")
    282   (tester (stream-scan + 0 '()) "stream-scan: non-stream argument")
     284  (tester (stream-scan "four" 0 strm123) "stream-scan: bad `function' argument type - expected a procedure")
     285  (tester (stream-scan + 0 '()) "stream-scan: bad `stream' argument type - expected a stream")
    283286  (tester (stream->list (stream-scan + 0 strm123)) '(0 1 3 6))
    284287
    285288  ; stream-take
    286   (tester (stream-take 5 "four") "stream-take: non-stream argument")
    287   (tester (stream-take "four" strm123) "stream-take: non-integer argument")
    288   (tester (stream-take -4 strm123) "stream-take: negative argument")
     289  (tester (stream-take 5 "four") "stream-take: bad `stream' argument type - expected a stream")
     290  (tester (stream-take "four" strm123) "stream-take: bad `count' argument type - expected a cardinal-integer")
     291  (tester (stream-take -4 strm123) "stream-take: bad `count' argument type - expected a cardinal-integer")
    289292  (tester (stream->list (stream-take 5 stream-null)) '())
    290293  (tester (stream->list (stream-take 0 stream-null)) '())
     
    295298
    296299  ; stream-take-while
    297   (tester (stream-take-while odd? "four") "stream-take-while: non-stream argument")
    298   (tester (stream-take-while "four" strm123) "stream-take-while: non-procedural argument")
     300  (tester (stream-take-while odd? "four") "stream-take-while: bad `stream' argument type - expected a stream")
     301  (tester (stream-take-while "four" strm123) "stream-take-while: bad `predicate?' argument type - expected a procedure")
    299302  (tester (stream->list (stream-take-while odd? strm123)) '(1))
    300303  (tester (stream->list (stream-take-while even? strm123)) '())
     
    303306
    304307  ; stream-unfold
    305   (tester (stream-unfold "four" odd? + 0) "stream-unfold: non-procedural mapper")
    306   (tester (stream-unfold + "four" + 0) "stream-unfold: non-procedural pred?")
    307   (tester (stream-unfold + odd? "four" 0) "stream-unfold: non-procedural generator")
     308  (tester (stream-unfold "four" odd? + 0) "stream-unfold: bad `mapper' argument type - expected a procedure")
     309  (tester (stream-unfold + "four" + 0) "stream-unfold: bad `predicate?'  argument type - expected a procedure")
     310  (tester (stream-unfold + odd? "four" 0) "stream-unfold: bad `generator' argument type - expected a procedure")
    308311  (tester (stream->list (stream-unfold (right-section expt 2) (right-section < 10) (right-section + 1) 0))
    309312          '(0 1 4 9 16 25 36 49 64 81))
     
    323326  ; stream-zip
    324327  #;(tester (stream-zip) "stream-zip: no stream arguments")
    325   (tester (stream-zip "four") "stream-zip: non-stream argument")
    326   (tester (stream-zip strm123 "four") "stream-zip: non-stream argument")
     328  (tester (stream-zip "four") "stream-zip: bad `stream' argument type - expected a stream")
     329  (tester (stream-zip strm123 "four") "stream-zip: bad `stream' argument type - expected a stream")
    327330  (tester (stream->list (stream-zip strm123 stream-null)) '())
    328331  (tester (stream->list (stream-zip strm123)) '((1) (2) (3)))
     
    361364;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; leak tests
    362365
    363 (define-constant SIZE 10000000)
    364 
    365 #|
     366(define-constant SIZE 100000)
     367
     368;;
     369
    366370(print "Times3 Test - Please wait. No output means \"passed\".")
    367371(define (times3 n)
    368372  (stream-ref (stream-filter (lambda (x) (zero? (modulo x n))) (stream-from 0)) 3))
    369373(time (times3 SIZE))
    370 |#
    371 
    372 #| ; I don't see how this could possibly work!
     374
     375;;
     376
    373377(define-stream (traverse s) (traverse (stream-cdr s)))
     378
     379;;
    374380
    375381(print "Traverse Test - Please wait. No output means \"passed\".")
    376382(time (stream-ref (traverse (stream-from 0)) SIZE))
     383
     384;;
    377385
    378386(print "Traverse Test (with stream head held) - Please wait. No output means \"passed\".")
    379387(define strm (traverse (stream-from 0)))
    380388(time (stream-ref strm SIZE))
    381 |#
    382389
    383390; These tests can't be automated with portable code, so they need to be run by hand.
     
    388395; traversing a stream should take bounded space ...
    389396; (define-stream (traverse s) (traverse (stream-cdr s)))
    390 ; (stream-ref (traverse (stream-from 0)) 10000000)
     397; (stream-ref (traverse (stream-from 0)) SIZE)
    391398
    392399; ... even if something holds the head of the stream
    393400; (define s (traverse (stream-from 0)))
    394 ; (stream-ref s 10000000)
     401; (stream-ref s SIZE)
    395402
    396403; the infamous times3 test from SRFI-40
     
    402409;       (stream-from 0))
    403410;     3))
    404 ; (times3 10000000)
     411; (times3 SIZE)
Note: See TracChangeset for help on using the changeset viewer.