Changeset 14176 in project


Ignore:
Timestamp:
04/08/09 06:57:59 (11 years ago)
Author:
Kon Lovett
Message:

SRFI 45 use rqrd extra level of indirection so dropped in favor of direct impl.

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

Legend:

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

    r14169 r14176  
    88 (doc-from-wiki)
    99 (synopsis "SRFI-41 (Streams)")
    10  (needs check-errors srfi-45 setup-helper)
     10 (needs check-errors setup-helper)
    1111 (files
    1212  "tests"
     13  "chicken-primitive-object-inlines.scm"
    1314  "streams-primitive.scm"
    1415  "streams-derived.scm"
  • release/4/srfi-41/trunk/streams-derived.scm

    r14169 r14176  
    2525    ##sys#signal-hook))
    2626
     27(include "chicken-primitive-object-inlines")
     28
    2729;;;
    2830
    29 (define-inline (%any-car pred? lists)
    30   (let loop ((lists lists))
    31     (and (not (null? lists))
    32          (or (pred? (caar lists))
    33              (loop (cdr lists)) ) ) ) )
    34 
    35 (define-inline (%exists pred? lists)
    36   (let loop ((lists lists))
    37     (and (not (null? lists))
    38          (or (%any-car pred? lists)
    39              (loop (map cdr lists)) ) ) ) )
    40 
    41 (define-inline (%check-for-non-stream loc strms nam)
    42   (when (%exists (lambda (x) (not (stream? x))) strms)
     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
     37(define-inline (%check-streams loc strms nam)
     38  (when (%any/1 not-stream? strms)
    4339    (error-stream loc strms nam) ) )
    4440
     
    7874;;;
    7975
     76(define (not-stream? obj) (not (stream? obj)))
     77
     78;;;
     79
    8080(define-syntax define-stream
    8181  (syntax-rules ()
     
    9393     ((letrec ((TAG (stream-lambda (NAME ...) BODY0 BODY1 ...))) TAG) VAL ...))))
    9494
     95;FIXME - this forces use of `_' identifier
    9596(define-syntax $stream-match-pattern$
    9697  (syntax-rules (_)
     
    223224  (if (null? streems) stream-null
    224225      (begin
    225         (%check-for-non-stream 'stream-append streems 'streams)
     226        (%check-streams 'stream-append streems 'stream)
    226227        (stream-append$ streems) ) ) )
    227228
     
    323324
    324325  (define (stream-folder base strms)
    325     (if (%exists stream-null? strms) base
     326    (if (%any/1 stream-null? strms) base
    326327        (stream-folder (apply function base (map stream-car strms))
    327328                       (map stream-cdr strms)) ) )
     
    329330  (check-procedure 'stream-fold function 'function)
    330331  (let ((streems (cons streem streems)))
    331     (%check-for-non-stream 'stream-fold streems 'streams)
     332    (%check-streams 'stream-fold streems 'stream)
    332333    (stream-folder base streems) ) )
    333334
     
    335336
    336337  (define (stream-for-each$ strms)
    337     (unless (%exists stream-null? strms)
     338    (unless (%any/1 stream-null? strms)
    338339      (apply procedure (map stream-car strms))
    339340      (stream-for-each$ (map stream-cdr strms)) ) )
     
    341342  (check-procedure 'stream-for-each procedure 'procedure)
    342343  (let ((streems (cons streem streems)))
    343     (%check-for-non-stream 'stream-for-each streems 'streams)
     344    (%check-streams 'stream-for-each streems 'stream)
    344345    (stream-for-each$ streems) ) )
    345346
     
    348349  ; not tail-recursive to avoid `stream-reverse'
    349350  (define-stream (stream-map$ strms)
    350     (if (%exists stream-null? strms) stream-null
     351    (if (%any/1 stream-null? strms) stream-null
    351352        (stream-cons (apply function (map stream-car strms))
    352353                     (stream-map$ (map stream-cdr strms))) ) )
     
    354355  (check-procedure 'stream-map function 'function)
    355356  (let ((streems (cons streem streems)))
    356     (%check-for-non-stream 'stream-map streems 'streams)
     357    (%check-streams 'stream-map streems 'stream)
    357358    (stream-map$ streems) ) )
    358359
     
    435436
    436437  (define-stream (stream-zip$ strms)
    437     (if (%exists stream-null? strms) stream-null
     438    (if (%any/1 stream-null? strms) stream-null
    438439        (stream-cons (map stream-car strms)
    439440                     (stream-zip$ (map stream-cdr strms))) ) )
    440441
    441442  (let ((streems (cons streem streems)))
    442     (%check-for-non-stream 'stream-zip streems 'streams)
     443    (%check-streams 'stream-zip streems 'stream)
    443444    (stream-zip$ streems) ) )
    444445
  • release/4/srfi-41/trunk/streams-primitive.scm

    r14169 r14176  
    2121  (inline)
    2222  (local)
    23   (no-procedure-checks)
    24   (bound-to-procedure
    25     ##sys#signal-hook) )
     23  (no-procedure-checks))
     24
     25(include "chicken-primitive-object-inlines")
    2626
    2727;;;
    2828
    29 (define-inline (%stream-force strm) (force (stream-promise strm)))
     29(define-inline (%make-stream prm) (%make-structure 'stream prm))
     30(define-inline (%stream? obj) (%structure-instance? obj 'stream))
     31(define-inline (%stream-promise strm) (%structure-ref strm 1))
     32(define-inline (%stream-promise-set! strm obj) (%structure-set! strm 1 obj))
    3033
    31 (define-inline (%stream-null? strm) (eq? (%stream-force strm) (%stream-force stream-null)))
     34(define-inline (%make-stream-pare kar kdr) (%make-structure 'stream-pare kar kdr))
     35(define-inline (%stream-pare? obj) (%structure-instance? obj 'stream-pare))
     36(define-inline (%stream-kar pare) (%structure-ref pare 1))
     37(define-inline (%stream-kdr pare) (%structure-ref pare 2))
     38
     39(define-inline (%stream-null? strm) (%eq? (stream-force strm) (stream-force stream-null)))
    3240
    3341(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)) ) ) ) )
     42  (cond
     43    ((not (%stream? obj)) (error-stream loc obj 'stream) )
     44    ((%stream-null? obj) (error-stream-occupied loc obj 'stream) )
     45    (else
     46      (let ((val (stream-force obj)))
     47        (if (%stream-pare? val) val
     48            (error-stream-pair loc val 'stream)) ) ) ) )
    3949
    4050(module streams-primitive (;export
     
    5161  check-stream-occupied error-stream-occupied
    5262  ;; WTF
    53   ($$stream-lazy $$make-stream)
     63  ($$stream-lazy $$make-lazy-stream)
    5464  ($$stream-delay $$stream-eager)
    5565  $$make-stream
     66  $$make-lazy-stream
    5667  $$stream-eager
    5768  $$make-stream-pare)
    5869
    59 (import
    60   (except scheme force)
    61   (except chicken promise?)
    62   #;srfi-9
    63   (only srfi-45 eager lazy force)
     70(import scheme chicken
    6471  (only type-checks define-check+error-type)
    6572  (only type-errors define-error-type))
    6673
    67 (require-library #;srfi-9 srfi-45 type-checks type-errors)
     74(require-library type-checks type-errors)
    6875
    6976;;;
    7077
    71 (define-record-type stream
    72   ($$make-stream p)
    73   stream?
    74   (p stream-promise) )
     78(define ($$make-stream prm) (%make-stream prm))
     79(define (stream? obj) (%stream? obj))
    7580
    7681(define-check+error-type stream)
    7782
    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)))))
     83(define ($$make-lazy-stream thunk) (%make-stream (%cons 'lazy thunk)))
    8184
    82 (define stream-null ($$stream-delay (cons 'stream 'null)))
     85(define-syntax $$stream-lazy
     86  (syntax-rules ()
     87    ((_ EXPR) ($$make-lazy-stream (lambda () EXPR)) ) ) )
    8388
    84 (define (stream-null? obj) (and (stream? obj) (%stream-null? obj)))
    85 (define (stream-occupied? obj) (and (stream? obj) (not (%stream-null? obj))))
     89(define ($$stream-eager obj) (%make-stream (%cons 'eager obj)))
     90
     91(define-syntax $$stream-delay
     92  (syntax-rules ()
     93    ((_ EXPR) ($$stream-lazy ($$stream-eager EXPR)) ) ) )
     94
     95(define (stream-force promise)
     96  (let ((content (%stream-promise promise)))
     97    (case (%car content)
     98      ((eager)
     99        (%cdr content) )
     100      ((lazy)
     101        (let* ((promise* ((%cdr content)))
     102               (content  (%stream-promise promise)))
     103          (unless (%eq? 'eager (%car content))
     104            (let ((prm (%stream-promise promise*)))
     105              (%set-car!/immediate content (%car prm))
     106              (%set-cdr! content (%cdr prm)) )
     107            (%stream-promise-set! promise* content) )
     108         (stream-force promise) ) ) ) ) )
     109
     110(define stream-null ($$stream-delay (%cons 'stream 'null)))
     111
     112(define (stream-null? obj) (and (%stream? obj) (%stream-null? obj)))
     113(define (stream-occupied? obj) (and (%stream? obj) (not (%stream-null? obj))))
    86114
    87115(define-check+error-type stream-occupied)
    88116
    89 (define-record-type stream-pare
    90   ($$make-stream-pare kar kdr)
    91   stream-pare?
    92   (kar stream-kar)
    93   (kdr stream-kdr))
     117(define ($$make-stream-pare kar kdr) (%make-stream-pare kar kdr))
    94118
    95119(define-syntax stream-cons
    96120  (syntax-rules ()
    97     ((_ OBJ STRM)
    98      ($$stream-eager ($$make-stream-pare ($$stream-delay OBJ) ($$stream-lazy STRM))) ) ) )
     121    ((_ EXPR STRM)
     122     ($$stream-eager ($$make-stream-pare ($$stream-delay EXPR) ($$stream-lazy STRM))) ) ) )
    99123
    100 (define (stream-pair? obj) (and (stream? obj) (stream-pare? (%stream-force obj))))
     124(define (stream-pair? obj) (and (%stream? obj) (%stream-pare? (stream-force obj))))
    101125
    102126(define-error-type stream-pair)
    103127
    104128(define (stream-car streem)
    105   (%stream-force (stream-kar (%checked-stream-pair 'stream-car streem))) )
     129  (stream-force (%stream-kar (%checked-stream-pair 'stream-car streem))) )
    106130
    107131(define (stream-cdr streem)
    108   (stream-kdr (%checked-stream-pair 'stream-cdr streem)) )
     132  (%stream-kdr (%checked-stream-pair 'stream-cdr streem)) )
    109133
    110134(define-syntax stream-lambda
  • release/4/srfi-41/trunk/tests/run.scm

    r14169 r14176  
    6969  ; stream-car
    7070  (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")
     71  (tester (stream-car stream-null) "stream-car: bad `stream' argument type - expected a stream-occupied")
    7272  (tester (stream-car strm123) 1)
    7373
    7474  ; stream-cdr
    7575  (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")
     76  (tester (stream-cdr stream-null) "stream-cdr: bad `stream' argument type - expected a stream-occupied")
    7777  (tester (stream-car (stream-cdr strm123)) 2)
    7878
     
    122122  ; stream->list
    123123  (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")
     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")
    126126  (tester (stream->list (stream)) '())
    127127  (tester (stream->list strm123) '(1 2 3))
     
    229229  ; stream-match
    230230  (tester (stream-match '(1 2 3) (_ 'ok)) "stream-match: bad `stream' argument type - expected a stream")
    231   (tester (stream-match strm123 (() 42)) "stream-match: pattern failure")
     231  (tester (stream-match strm123 (() 42)) "stream-match: no matching pattern")
    232232  (tester (stream-match stream-null (() 'ok)) 'ok)
    233233  (tester (stream-match strm123 (() 'no) (else 'ok)) 'ok)
     
    307307  ; stream-unfold
    308308  (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")
     309  (tester (stream-unfold + "four" + 0) "stream-unfold: bad `predicate?' argument type - expected a procedure")
    310310  (tester (stream-unfold + odd? "four" 0) "stream-unfold: bad `generator' argument type - expected a procedure")
    311311  (tester (stream->list (stream-unfold (right-section expt 2) (right-section < 10) (right-section + 1) 0))
     
    364364;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; leak tests
    365365
    366 (define-constant SIZE 100000)
     366(define-constant SIZE 1000)
    367367
    368368;;
     
    373373(time (times3 SIZE))
    374374
     375#| ; How is this supposed to work?
    375376;;
    376377
     
    387388(define strm (traverse (stream-from 0)))
    388389(time (stream-ref strm SIZE))
     390|#
    389391
    390392; These tests can't be automated with portable code, so they need to be run by hand.
Note: See TracChangeset for help on using the changeset viewer.