Changeset 14144 in project


Ignore:
Timestamp:
04/07/09 04:56:23 (11 years ago)
Author:
Kon Lovett
Message:

Use of signal-hook, specific test for stream-pair, test data.

Location:
release/4/srfi-41/trunk
Files:
1 added
3 edited

Legend:

Unmodified
Added
Removed
  • release/4/srfi-41/trunk/streams-derived.scm

    r14141 r14144  
    133133          (stream-match-pattern$ (r 'stream-match-pattern))
    134134          (rest (cdr form)))
    135      
     135
    136136) ) )
    137137
     
    175175       (cond ((not (stream? strm)) (error-stream 'stream-match strm))
    176176             (($stream-match-test$ strm CLAUSE) => car) ...
    177              (else (error 'stream-match "no matching pattern")))))))
     177             (else (##sys#signal-hook #:error 'stream-match "no matching pattern")))))))
    178178
    179179#;
     
    223223  (define-stream (list->stream$ objs)
    224224    (if (null? objs) stream-null
    225         (stream-cons (car objs) (list->stream$ (cdr objs)))) )
     225        (stream-cons (car objs) (list->stream$ (cdr objs))) ) )
    226226
    227227  (check-list 'list->stream objs)
    228   (list->stream$ objs))
    229 
    230 (define (port->stream . port)
    231 
    232   (define-stream (port->stream$ p)
    233     (let ((c (read-char p)))
    234       (if (eof-object? c) stream-null
    235           (stream-cons c (port->stream$ p)))) )
    236 
    237   (let ((p (if (null? port) (current-input-port) (car port))))
    238     (check-input-port 'port->stream p)
    239     (port->stream$ p)))
     228  (list->stream$ objs) )
    240229
    241230(define (stream->list . args)
     
    244233    (check-stream 'stream->list strm)
    245234    (when n (check-cardinal-integer 'stream->list n))
    246     (let loop ((n (if n n -1)) (strm strm))
     235    (let loop ((n (or n -1)) (strm strm))
    247236      (if (or (zero? n) (stream-null? strm)) '()
    248           (cons (stream-car strm) (loop (- n 1) (stream-cdr strm)))))))
     237          (cons (stream-car strm) (loop (- n 1) (stream-cdr strm))) ) ) ) )
     238
     239(define (port->stream . port)
     240
     241  (define-stream (port->stream$ p)
     242    (let ((c (read-char p)))
     243      (if (eof-object? c) stream-null
     244          (stream-cons c (port->stream$ p)) ) )  )
     245
     246  (let ((p (if (null? port) (current-input-port) (car port))))
     247    (check-input-port 'port->stream p)
     248    (port->stream$ p)) )
    249249
    250250(define (stream-append . strms)
     
    255255          (else (stream-cons (stream-car (car strms))
    256256                             (stream-append$
    257                               (cons (stream-cdr (car strms)) (cdr strms)))))) )
     257                              (cons (stream-cdr (car strms)) (cdr strms)))) ) ) )
    258258
    259259  (if (null? strms) stream-null
    260260      (begin
    261261        (%check-for-non-stream 'stream-append strms)
    262         (stream-append$ strms))))
     262        (stream-append$ strms) ) ) )
    263263
    264264(define (stream-concat strm)
     
    275275                        (stream-concat$
    276276                         (stream-cons (stream-cdr (stream-car strmpair))
    277                                       (stream-cdr strmpair)))))) )
     277                                      (stream-cdr strmpair)))) ) ) )
    278278
    279279  (check-stream 'stream-concat strm)
    280   (stream-concat$ strm))
     280  (stream-concat$ strm) )
    281281
    282282(define stream-constant
     
    285285          ((null? (cdr objs)) (stream-cons (car objs) (stream-constant (car objs))))
    286286          (else (stream-cons (car objs)
    287                              (apply stream-constant (append (cdr objs) (list (car objs)))))))))
     287                             (apply stream-constant (append (cdr objs) (list (car objs))))) ) ) ) )
    288288
    289289(define (stream-drop n strm)
     
    291291  (define-stream (stream-drop$ n strm)
    292292    (if (or (zero? n) (stream-null? strm)) strm
    293         (stream-drop$ (- n 1) (stream-cdr strm))) )
     293        (stream-drop$ (- n 1) (stream-cdr strm)) ) )
    294294
    295295  (check-stream 'stream-drop strm)
    296296  (check-cardinal-integer 'stream-drop n)
    297   (stream-drop$ n strm))
     297  (stream-drop$ n strm) )
    298298
    299299(define (stream-drop-while pred? strm)
     
    301301  (define-stream (stream-drop-while$ strm)
    302302    (if (not (and (stream-pair? strm) (pred? (stream-car strm)))) strm
    303         (stream-drop-while$ (stream-cdr strm))) )
     303        (stream-drop-while$ (stream-cdr strm)) ) )
    304304
    305305  (check-procedure 'stream-drop-while pred?)
    306306  (check-stream 'stream-drop-while strm)
    307   (stream-drop-while$ strm))
     307  (stream-drop-while$ strm) )
    308308
    309309(define (stream-filter pred? strm)
     
    315315           (stream-cons (stream-car strm) (stream-filter$ (stream-cdr strm))))
    316316          (else
    317            (stream-filter$ (stream-cdr strm)))) )
     317           (stream-filter$ (stream-cdr strm)) ) ) )
    318318
    319319  (check-procedure 'stream-filter pred?)
    320320  (check-stream 'stream-filter strm)
    321   (stream-filter$ strm))
     321  (stream-filter$ strm) )
    322322
    323323#;
     
    334334    (if (%exists stream-null? strms) base
    335335        (stream-folder (apply proc base (map stream-car strms))
    336                        (map stream-cdr strms))) )
     336                       (map stream-cdr strms)) ) )
    337337
    338338  (check-procedure 'stream-fold proc)
     
    346346    (unless (%exists stream-null? strms)
    347347      (apply proc (map stream-car strms))
    348       (stream-for-each$ (map stream-cdr strms))))
     348      (stream-for-each$ (map stream-cdr strms)) ) )
    349349
    350350  (check-procedure 'stream-for-each proc)
     
    359359    (if (%exists stream-null? strms) stream-null
    360360        (stream-cons (apply proc (map stream-car strms))
    361                      (stream-map$ (map stream-cdr strms)))) )
     361                     (stream-map$ (map stream-cdr strms))) ) )
    362362
    363363  (check-procedure 'stream-map proc)
     
    374374    (check-number 'stream-from first)
    375375    (check-number 'stream-from delta)
    376     (stream-from$ first delta)))
     376    (stream-from$ first delta) ) )
    377377
    378378(define (stream-iterate proc base)
     
    382382
    383383  (check-procedure 'stream-iterate proc)
    384   (stream-iterate$ base))
     384  (stream-iterate$ base) )
    385385
    386386(define (stream-length strm)
     
    388388  (let loop ((len 0) (strm strm))
    389389    (if (stream-null? strm) len
    390         (loop (+ len 1) (stream-cdr strm)))))
     390        (loop (+ len 1) (stream-cdr strm)) ) ) )
    391391
    392392(define (stream-range first past . step)
     
    394394  (define-stream (stream-range$ first past delta lt?)
    395395    (if (not (lt? first past)) stream-null
    396         (stream-cons first (stream-range$ (+ first delta) past delta lt?))) )
     396        (stream-cons first (stream-range$ (+ first delta) past delta lt?)) ) )
    397397
    398398  (check-number 'stream-range first)
     
    401401    (check-number 'stream-range delta)
    402402    (let ((lt? (if (< 0 delta) < >)))
    403       (stream-range$ first past delta lt?))))
     403      (stream-range$ first past delta lt?) ) ) )
    404404
    405405(define (stream-ref strm idx)
     
    412412           (stream-car strm))
    413413          (else
    414            (loop (stream-cdr strm) (- n 1))))))
     414           (loop (stream-cdr strm) (- n 1)) ) ) ) )
    415415
    416416(define (stream-reverse strm)
     
    418418  (define-stream (stream-reverse$ strm rev)
    419419    (if (stream-null? strm) rev
    420         (stream-reverse$ (stream-cdr strm) (stream-cons (stream-car strm) rev))) )
     420        (stream-reverse$ (stream-cdr strm) (stream-cons (stream-car strm) rev)) ) )
    421421
    422422  (check-stream 'stream-reverse strm)
    423   (stream-reverse$ strm stream-null))
     423  (stream-reverse$ strm stream-null) )
    424424
    425425(define (stream-scan proc base strm)
     
    427427  (define-stream (stream-scan$ base strm)
    428428    (if (stream-null? strm) (stream base)
    429         (stream-cons base (stream-scan$ (proc base (stream-car strm)) (stream-cdr strm)))) )
     429        (stream-cons base (stream-scan$ (proc base (stream-car strm)) (stream-cdr strm))) ) )
    430430
    431431  (check-procedure 'stream-scan proc)
    432432  (check-stream 'stream-scan strm)
    433   (stream-scan$ base strm))
     433  (stream-scan$ base strm) )
    434434
    435435(define (stream-take n strm)
     
    437437  (define-stream (stream-take$ n strm)
    438438    (if (or (stream-null? strm) (zero? n)) stream-null
    439         (stream-cons (stream-car strm) (stream-take$ (- n 1) (stream-cdr strm)))) )
     439        (stream-cons (stream-car strm) (stream-take$ (- n 1) (stream-cdr strm))) ) )
    440440
    441441  (check-stream 'stream-take strm)
    442442  (check-cardinal-integer 'stream-take n)
    443   (stream-take$ n strm))
     443  (stream-take$ n strm) )
    444444
    445445(define (stream-take-while pred? strm)
    446  
     446
    447447 (define-stream (stream-take-while$ strm)
    448448    (cond ((stream-null? strm)
     
    451451           (stream-cons (stream-car strm) (stream-take-while$ (stream-cdr strm))))
    452452          (else
    453            stream-null)) )
     453           stream-null ) ) )
    454454
    455455  (check-procedure 'stream-take-while pred?)
    456456  (check-stream 'stream-take-while strm)
    457   (stream-take-while$ strm))
     457  (stream-take-while$ strm) )
    458458
    459459(define (stream-unfold mapper pred? generator base)
     
    461461  (define-stream (stream-unfold$ base)
    462462    (if (not (pred? base)) stream-null
    463         (stream-cons (mapper base) (stream-unfold$ (generator base)))) )
     463        (stream-cons (mapper base) (stream-unfold$ (generator base))) ) )
    464464
    465465  (check-procedure 'stream-unfold mapper)
    466466  (check-procedure 'stream-unfold pred?)
    467467  (check-procedure 'stream-unfold generator)
    468   (stream-unfold$ base))
     468  (stream-unfold$ base) )
    469469
    470470(define (stream-unfolds gen seed)
     
    473473    (call-with-values
    474474      (lambda () (gen seed))
    475       (lambda vs (- (length vs) 1))))
     475      (lambda vs (- (length vs) 1))) )
    476476
    477477  (define-stream (unfold-result-stream gen seed)
     
    490490            ((null? result)
    491491             stream-null)
    492             (else 
    493              (##sys#signal-hook #:runtime-error 'stream-unfolds "cannot happen" result)))) )
     492            (else
     493             (##sys#signal-hook #:runtime-error 'stream-unfolds "cannot happen" result) ) ) ) )
    494494
    495495  (define (result-stream->output-streams result-stream)
    496496    (let loop ((i (len-values gen seed)) (outputs '()))
    497497      (if (zero? i) (apply values outputs)
    498           (loop (- i 1) (cons (result-stream->output-stream result-stream i) outputs)))))
     498          (loop (- i 1) (cons (result-stream->output-stream result-stream i) outputs)) ) ) )
    499499
    500500  (check-procedure 'stream-unfolds gen)
    501   (result-stream->output-streams (unfold-result-stream gen seed)))
     501  (result-stream->output-streams (unfold-result-stream gen seed)) )
    502502
    503503(define (stream-zip strm . strms)
     
    506506    (if (%exists stream-null? strms) stream-null
    507507        (stream-cons (map stream-car strms)
    508                      (stream-zip$ (map stream-cdr strms)))) )
     508                     (stream-zip$ (map stream-cdr strms))) ) )
    509509
    510510  (let ((strms (cons strm strms)))
  • release/4/srfi-41/trunk/streams-primitive.scm

    r14141 r14144  
    2121  (inline)
    2222  (local)
    23   (no-procedure-checks) )
     23  (no-procedure-checks)
     24  (bound-to-procedure
     25    ##sys#signal-hook) )
    2426
    2527;;;
     
    5254  (except chicken promise?)
    5355  #;srfi-9
    54   (only srfi-45 #;eager lazy force)
     56  (only srfi-45 eager lazy force)
    5557  (only type-checks define-check+error-type))
    5658
     
    6870(define-syntax $stream-lazy$
    6971  (syntax-rules ()
    70     ((_ EXPR) ($make-stream$ (lazy EXPR)))))
     72    ((_ EXPR) ($make-stream$ (lazy EXPR)) ) ) )
    7173
    72 (define ($stream-eager$ expr) ($make-stream$ expr #;(eager expr)))
     74(define ($stream-eager$ expr) ($make-stream$ (eager expr)))
    7375
    7476(define-syntax $stream-delay$
    7577  (syntax-rules ()
    76     ((_ EXPR) ($stream-lazy$ ($stream-eager$ EXPR)))))
     78    ((_ EXPR) ($stream-lazy$ ($stream-eager$ EXPR)) ) ) )
    7779
    7880(define *stream-null-tag* (cons 'stream 'null))
     
    9294  (kdr stream-kdr))
    9395
    94 (define (stream-pair? obj)
    95   (and (stream? obj)
    96        (stream-pare? (%stream-force obj))))
    97 
    9896(define-syntax stream-cons
    9997  (syntax-rules ()
    100     ((stream-cons OBJ STRM)
    101      ($stream-eager$ ($make-stream-pare$ ($stream-delay$ OBJ) ($stream-lazy$ STRM))))))
     98    ((_ OBJ STRM)
     99     ($stream-eager$ ($make-stream-pare$ ($stream-delay$ OBJ) ($stream-lazy$ STRM))) ) ) )
     100
     101(define (stream-pair? obj) (and (stream? obj) (stream-pare? (%stream-force obj))))
     102
     103(define (checked-stream-pair loc obj)
     104  (or (and (stream? obj) (let ((val (%stream-force obj))) (and (stream-pare? val) val)))
     105      (##sys#signal-hook #:type-error loc "bad argument type - expected a stream-pair" obj)) )
    102106
    103107(define (stream-car strm)
    104   (check-occupied-stream 'stream-car strm)
    105   (%stream-force (stream-kar (%stream-force strm))))
     108  (%stream-force (stream-kar (checked-stream-pair 'stream-car strm))) )
    106109
    107110(define (stream-cdr strm)
    108   (check-occupied-stream 'stream-cdr strm)
    109   (stream-kdr (%stream-force strm)))
     111  (stream-kdr (checked-stream-pair 'stream-cdr strm)) )
    110112
    111113(define-syntax stream-lambda
    112114  (syntax-rules ()
    113     ((stream-lambda FORMALS BODY0 BODY1 ...)
    114      (lambda FORMALS ($stream-lazy$ (let () BODY0 BODY1 ...))))))
     115    ((_ FORMALS BODY0 BODY1 ...)
     116     (lambda FORMALS ($stream-lazy$ (let () BODY0 BODY1 ...))) ) ) )
    115117
    116118) ;module streams-primitive
  • release/4/srfi-41/trunk/tests/run.scm

    r14055 r14144  
     1(use data-structures)
    12(use streams streams-utils streams-math)
    23
     
    2223      (tester "" expr result) )
    2324    ((tester descrip expr result)
    24       (unless (equal? expr result)
    25         (newline) (display "failed tester: ") (display descrip) (newline)
    26         (display 'expr) (newline)
    27         (display "expected: ") (display result) (newline)
    28         (display "returned: ") (display expr) (newline)))))
    29 
    30 (define (error s x . r)
    31   (string-append (symbol->string s) ": " x) )
     25      (handle-exceptions exp
     26(begin (print exp)
     27(string-append
     28           (symbol->string (or ((condition-property-accessor 'exn 'location) exp) 'unknown))
     29           ": "
     30           ((condition-property-accessor 'exn 'message) exp))
     31)
     32        (unless (equal? expr result)
     33          (newline) (display "failed tester: ") (display descrip) (newline)
     34          (write 'expr) (newline)
     35          (display "expected: ") (write result) (newline)
     36          (display "returned: ") (write expr) (newline) ) ) ) ) )
    3237
    3338(define strm123 (stream 1 2 3))
     
    314319            (if (zero? n)
    315320                (values 'dummy '())
    316                 (values
    317                   (cons (- n 1) (stream-cdr s))
    318                   (list (stream-car s))))))
     321                (values (cons (- n 1) (stream-cdr s)) (list (stream-car s))))))
    319322        (cons 5 (stream-from 0))))
    320323      '(0 1 2 3 4))
Note: See TracChangeset for help on using the changeset viewer.