[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

Corrected reference implementation



Below is a corrected reference implementation (the one currently in the document has type errors).

Andre van Tonder

  ;;; PROMISES A LA SRFI-45:

  ;;; A separate implementation is necessary to
  ;;; have promises that answer #t to stream?
  ;;; This requires lots of complicated type conversions.

  (define-record-type s:promise (make-s:promise kind content) s:promise?
    (kind    s:promise-kind    set-s:promise-kind!)
    (content s:promise-content set-s:promise-content!))

  (define-record-type box (make-box x) box?
    (x unbox set-box!))

  (define-syntax srfi-40:lazy
     (syntax-rules ()
       ((lazy exp)
        (make-box (make-s:promise 'lazy (lambda () exp))))))

  (define (srfi-40:eager x)
    (make-stream (make-box (make-s:promise 'eager x))))

  (define-syntax srfi-40:delay
    (syntax-rules ()
      ((srfi-40:delay exp) (srfi-40:lazy (srfi-40:eager exp)))))

  (define (srfi-40:force promise)
    (let ((content (unbox promise)))
      (case (s:promise-kind content)
        ((eager) (s:promise-content content))
        ((lazy)
         (let* ((promise* (stream-promise ((s:promise-content content))))
                (content  (unbox promise)))
           (if (not (eqv? 'eager (s:promise-kind content)))
               (begin
                 (set-s:promise-kind! content (s:promise-kind (unbox promise*)))
                 (set-s:promise-content! content (s:promise-content (unbox promise*)))
                 (set-box! promise* content)))
           (srfi-40:force promise))))))


  ;;; STREAM -- LIBRARY OF SYNTAX AND FUNCTIONS TO MANIPULATE STREAMS

  ;;; A stream is a new data type, disjoint from all other data types, that
  ;;; contains a promise that, when forced, is either nil (a single object
  ;;; distinguishable from all other objects) or consists of an object (the
  ;;; stream element) followed by a stream.  Each stream element is evaluated
  ;;; exactly once, when it is first retrieved (not when it is created); once
  ;;; evaluated its value is saved to be returned by subsequent retrievals
  ;;; without being evaluated again.

  ;; STREAM-TYPE -- type of streams
  ;; STREAM? object -- #t if object is a stream, #f otherwise
  (define-record-type stream-type
    (make-stream promise)
    stream?
    (promise stream-promise))

  ;;; UTILITY FUNCTIONS

  ;; STREAM-ERROR message -- print message then abort execution
  ;  replace this with a call to the native error handler
  ;  if stream-error returns, so will the stream library function that called it
  (define stream-error error)

  ;;; STREAM SYNTAX AND FUNCTIONS

  ;; STREAM-NULL -- the distinguished nil stream
  (define stream-null (make-stream (srfi-40:delay '())))

  ;; STREAM-CONS object stream -- primitive constructor of streams
  (define-syntax stream-cons
    (syntax-rules ()
      ((stream-cons obj strm)
       (make-stream
        (srfi-40:delay
         (if (not (stream? strm))
             (stream-error "attempt to stream-cons onto non-stream")
             (cons obj strm)))))))

  ;; STREAM-NULL? object -- #t if object is the null stream, #f otherwise
  (define (stream-null? obj)
    (and (stream? obj) (null? (srfi-40:force (stream-promise obj)))))

  ;; STREAM-PAIR? object -- #t if object is a non-null stream, #f otherwise
  (define (stream-pair? obj)
    (and (stream? obj) (not (null? (srfi-40:force (stream-promise obj))))))

  ;; STREAM-CAR stream -- first element of stream
  (define (stream-car strm)
    (cond ((not (stream? strm)) (stream-error "attempt to take stream-car of non-stream"))
          ((stream-null? strm)  (stream-error "attempt to take stream-car of null stream"))
          (else (car (srfi-40:force (stream-promise strm))))))

  ;; STREAM-CDR stream -- remaining elements of stream after first
  (define (stream-cdr strm)
    (cond ((not (stream? strm)) (stream-error "attempt to take stream-cdr of non-stream"))
          ((stream-null? strm)  (stream-error "attempt to take stream-cdr of null stream"))
          (else (cdr (srfi-40:force (stream-promise strm))))))

  ;; STREAM-DELAY object -- the essential stream mechanism
  (define-syntax stream-delay
    (syntax-rules ()
      ((stream-delay expr)
       (make-stream
        (srfi-40:lazy expr)))))

  ;; STREAM object ... -- new stream whose elements are object ...
  (define (stream . objs)
    (let loop ((objs objs))
      (stream-delay
       (if (null? objs)
           stream-null
           (stream-cons (car objs) (loop (cdr objs)))))))

  ;; STREAM-UNFOLDN generator seed n -- n+1 streams from (generator seed)
  (define (stream-unfoldn gen seed n)
    (define (unfold-result-stream gen seed)
      (let loop ((seed seed))
        (stream-delay
         (call-with-values
          (lambda () (gen seed))
          (lambda (next . results)
            (stream-cons results (loop next)))))))
    (define (result-stream->output-stream result-stream i)
      (stream-delay
       (let ((result (list-ref (stream-car result-stream) i)))
         (cond ((pair? result)
                (stream-cons (car result)
                             (result-stream->output-stream
                              (stream-cdr result-stream) i)))
               ((not result)
                (result-stream->output-stream (stream-cdr result-stream) i))
               ((null? result) stream-null)
               (else (stream-error "can't happen"))))))
    (define (result-stream->output-streams result-stream n)
      (let loop ((i 0) (outputs '()))
        (if (= i n)
            (apply values (reverse outputs))
            (loop (+ i 1)
                  (cons (result-stream->output-stream result-stream i)
                        outputs)))))
    (result-stream->output-streams (unfold-result-stream gen seed) n))

  ;; STREAM-MAP func stream ... -- stream produced by applying func element-wise
  (define (stream-map func . strms)
    (cond ((not (procedure? func)) (stream-error "non-functional argument to stream-map"))
          ((null? strms) (stream-error "no stream arguments to stream-map"))
          ((not (every stream? strms)) (stream-error "non-stream argument to stream-map"))
          (else (let loop ((strms strms))
                  (stream-delay
                   (if (any stream-null? strms)
                       stream-null
                       (stream-cons (apply func (map stream-car strms))
                                    (loop (map stream-cdr strms)))))))))

  ;; STREAM-FOR-EACH proc stream ... -- apply proc element-wise for side-effects
  (define (stream-for-each proc . strms)
    (cond ((not (procedure? proc)) (stream-error "non-functional argument to stream-for-each"))
          ((null? strms) (stream-error "no stream arguments to stream-for-each"))
          ((not (every stream? strms)) (stream-error "non-stream argument to stream-for-each"))
          (else (let loop ((strms strms))
                  (if (not (any stream-null? strms))
                      (begin (apply proc (map stream-car strms))
                             (loop (map stream-cdr strms))))))))

  ;; STREAM-FILTER pred? stream -- new stream including only items passing pred?
  (define (stream-filter pred? strm)
    (cond ((not (procedure? pred?)) (stream-error "non-functional argument to stream-filter"))
          ((not (stream? strm)) (stream-error "attempt to apply stream-filter to non-stream"))
          (else (stream-unfoldn
                 (lambda (s)
                   (values
                    (stream-cdr s)
                    (cond ((stream-null? s) '())
                          ((pred? (stream-car s)) (list (stream-car s)))
                          (else #f))))
                 strm
                 1))))