Re: Bug fix

[Andre van Tonder <andre@xxxxxxxxxxxxxxxxx>]

Thank you to Alexandro and John for pointing out the bugs in the
implementation.  I have fixed them and included the suggested extra
tests in the update below.

Best regards
Andre

;=====================================================================
; Boxes

(define (box x) (list x))
(define unbox car)
(define set-box! set-car!)

;==========================================================
; Primitives for lazy evaluation:

(define-syntax lazy
   (syntax-rules ()
     ((lazy exp)
      (box (box (cons 'lazy (lambda () exp)))))))

(define (eager x)
   (box (box (cons 'eager x))))

(define-syntax delay
   (syntax-rules ()
     ((delay exp) (lazy (eager exp)))))

(define (force promise)
   (let ((content (unbox (unbox promise))))
     (case (car content)
       ((eager) (cdr content))
       ((lazy)  (let* ((promise* ((cdr content)))
                       (content  (unbox (unbox promise))))
                  (when (not (eqv? (car content) 'eager))    ; for reentrancy test 3
                    (set-box! (unbox promise) (unbox (unbox promise*)))
                    (set-box! promise* (unbox promise)))
                  (force promise))))))


;============================================================
; BENCHMARKS:
;============================================================


;============================================================
; Memoization test 1:

(define s (delay (begin (display 'hello) 1)))

(force s)
(force s)
                ;===> Should display 'hello once

;============================================================
; Memoization test 2:

(let ((s (delay (begin (display 'bonjour) 2))))
   (+ (force s) (force s)))

                ;===> Should display 'bonjour once

;============================================================
; Memoization test 3: (pointed out by Alejandro Forero Cuervo)

(define s (delay (begin (display 'hi) 1)))
(define t (lazy s))

(force t)
(force s)
                ;===> Should display 'hi once

;============================================================
; Memoization test 4: Stream memoization

(define (stream-drop s index)
   (lazy
    (if (zero? index)
        s
        (stream-drop (cdr (force s)) (- index 1)))))

(define (from n)
   (delay (begin
            (display 'ho)
            (cons n (from (+ n 1))))))
(define s (from 0))

(car (force (stream-drop s 4)))
(car (force (stream-drop s 4)))

                ;===> Should display 'ho five times

;=============================================================
; Reentrancy test 1: from R5RS

(define count 0)
(define p
   (delay (begin (set! count (+ count 1))
                 (if (> count x)
                     count
                     (force p)))))
(define x 5)
(force p)                     ;===>  6
(set! x 10)
(force p)                     ;===>  6


;===========================================================
; Reentrancy test 2: from SRFI 40

(define f
   (let ((first? #t))
     (delay
       (if first?
           (begin
             (set! first? #f)
             (force f))
           'second))))

(force f)                     ;===> 'second

;===========================================================
; Reentrancy test 3: due to John Shutt

(define q
   (let ((count 5))
     (define (get-count) count)
     (define p (delay (if (<= count 0)
                          count
                          (begin (set! count (- count 1))
                                 (force p)
                                 (set! count (+ count 2))
                                 count))))
     (list get-count p)))
(define get-count (car q))
(define p (cadr q))

(get-count)  ; =>   5
(force p)    ; =>   0
(get-count)  ; =>   10

;=============================================================
; Test leaks:  All the leak tests should run in bounded space.

;============================================================
; Leak test 1: Infinite loop in bounded space.

(define (loop) (lazy (loop)))
;(force (loop))

;============================================================
; Leak test 2: Pending memos should not accumulate
;              in shared structures.

(define s (loop))
;(force s)

;============================================================
; Leak test 3: Safely traversing infinite stream.

(define (from n)
   (delay (cons n (from (+ n 1)))))

(define (traverse s)
   (lazy (traverse (cdr (force s)))))
;(force (traverse (from 0)))

;============================================================
; Leak test 4: Safely traversing infinite stream
;              while pointer to head of result exists.

(define s (traverse (from 0)))
;(force s)


;=========================================================================
; Convenient list deconstructor.

(define-syntax match
   (syntax-rules ()
     ((match exp
        (()      exp1)
        ((h . t) exp2))
      (let ((lst exp))
        (cond ((null? lst) exp1)
              ((pair? lst) (let ((h (car lst))
                                 (t (cdr lst)))
                             exp2))
              (else 'match-error))))))

;==============================================================
(define (stream-filter p? s)
   (lazy (match (force s)
           (()      (delay '()))
           ((h . t) (if (p? h)
                        (delay (cons h (stream-filter p? t)))
                        (stream-filter p? t))))))


;============================================================
; Leak test 5: Naive stream-filter should run in bounded space.
;              Simplest case.

;(force (stream-filter (lambda (n) (= n 10000000000))
;                      (from 0)))

; The stream-ref procedure below does not strictly need to be lazy.
; It is defined lazy for the purpose of testing safe compostion of lazy procedures in
; the times3 benchmark below (previous candidate solutions had failed this).

(define (stream-ref s index)
   (lazy
    (match (force s)
      (()      'error)
      ((h . t) (if (zero? index)
                   (delay h)
                   (stream-ref t (- index 1)))))))

; Check that evenness is correctly implemented - should terminate:

(force (stream-ref (stream-filter zero? (from 0))
                    0))

;============================================================
; Leak test 6: Another long traversal should run in bounded space.

(define s (stream-ref (from 0) 100000000))
;(force s)

(define (times3 n)
   (stream-ref (stream-filter
                (lambda (x) (zero? (modulo x n)))
                (from 0))
               3))

;============================================================
; Leak test 7: Infamous example from SRFI 40.

(force (times3 7))
;(force (times3 100000000))