diff --git a/lib/srfi/41.scm b/lib/srfi/41.scm index 6cba2443..ac973fca 100644 --- a/lib/srfi/41.scm +++ b/lib/srfi/41.scm @@ -1,73 +1,54 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; primitive layer adapted from SRFI 41 reference impl -;; TODO: rewrite this in terms or R7RS lazy primitives -(define-record-type Stream - (make-stream box) +(define-record-type + (make-stream promise) stream? - (box stream-promise stream-promise!)) + (promise stream-promise)) -(define-record-type Stream-Pare - (make-stream-pare kar kdr) - stream-pare? - (kar stream-kar) - (kdr stream-kdr)) +(define-record-type + (make-stream-null) + %stream-null?) -(define-syntax stream-lazy - (syntax-rules () - ((lazy expr) - (make-stream (cons 'lazy (lambda () expr)))))) +(define-record-type + (make-stream-pair head tail) + %stream-pair? + (head %stream-car) + (tail %stream-cdr)) -(define (stream-eager expr) - (make-stream (cons 'eager expr))) - -(define-syntax stream-delay - (syntax-rules () - ((stream-delay expr) - (stream-lazy (stream-eager expr))))) - -(define (stream-force promise) - (let ((content (stream-promise promise))) - (case (car content) - ((eager) (cdr content)) - ((lazy) (let* ((promise* ((cdr content))) - (content (stream-promise promise))) - (if (not (eqv? (car content) 'eager)) - (begin (set-car! content (car (stream-promise promise*))) - (set-cdr! content (cdr (stream-promise promise*))) - (stream-promise! promise* content))) - (stream-force promise)))))) - -(define stream-null (stream-delay (cons 'stream 'null))) - -(define (stream-pair? obj) - (and (stream? obj) (stream-pare? (stream-force obj)))) - -(define (stream-null? obj) - (and (stream? obj) - (eqv? (stream-force obj) - (stream-force stream-null)))) +(define stream-null (make-stream (make-promise (make-stream-null)))) (define-syntax stream-cons (syntax-rules () - ((stream-cons obj strm) - (stream-delay (make-stream-pare (stream-delay obj) (stream-lazy strm)))))) + ((stream-cons object stream) + (make-stream + (make-promise + (make-stream-pair + (delay object) + (delay-force (stream-promise stream)))))))) -(define (stream-car strm) - (cond ((not (stream? strm)) (error 'stream-car "non-stream")) - ((stream-null? strm) (error 'stream-car "null stream")) - (else (stream-force (stream-kar (stream-force strm)))))) +(define (stream-null? stream) + (and (stream? stream) + (%stream-null? (force (stream-promise stream))))) -(define (stream-cdr strm) - (cond ((not (stream? strm)) (error 'stream-cdr "non-stream")) - ((stream-null? strm) (error 'stream-cdr "null stream")) - (else (stream-kdr (stream-force strm))))) +(define (stream-pair? stream) + (and (stream? stream) + (%stream-pair? (force (stream-promise stream))))) + +(define (stream-car stream) + (force (%stream-car (force (stream-promise stream))))) + +(define (stream-cdr stream) + (let ((t (force (%stream-cdr (force (stream-promise stream)))))) + (make-stream (make-promise t)))) (define-syntax stream-lambda (syntax-rules () ((stream-lambda formals body0 body1 ...) - (lambda formals (stream-lazy (let () body0 body1 ...)))))) + (lambda formals + (make-stream + (delay-force (stream-promise (let () body0 body1 ...)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; derived