Here is another safe-for-space version of srfi-45 promises that detects
reentrant promises and should be faster.

It follows closely the description of the G-machine handling of tail calls
(enhanced with black holes) in the reference:

   Richard Jones - "Tail recursion without space leaks"

This implementation has the following advantages over the previous
implementations that were based on naive graph reduction:

  - It is faster (for a given data representation), since the root node is not
    overwritten on each iteration, but only after the final promise in a lazy
    chain is forced.

  - Reentrant promises are detected early and a runtime exception is raised for
    them.

This second property is not consistent with r5rs, but it is IMO a very useful
feature.  Here is a simple example where it raises an exception:

   (let ((p (delay (force p))))
     (force p))                  ==> Error: reentrant promise

Implementation:
===============

;; <promise> ::= (lazy   . <thunk of promise>)   (delayed     promise)
;;             | (value  . <object>)             (forced      promise)
;;             | (shared . <promise>)            (shared      promise)
;;             | (hole   . #f)                   (black-holed promise)

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

(define-syntax delay
   (syntax-rules ()
     ((delay exp) (lazy (cons 'value exp)))))

(define (force root-node)

   (define (dispatch node)
     (let ((type    (car node))
           (content (cdr node)))
       (set-car! node 'shared)     ; maintain any sharing by
       (set-cdr! node root-node)   ; pointing back to root
       (case type
         ((lazy)   (dispatch (content)))
         ((value)  (set-car! root-node 'value)   ; overwrite root at end
                   (set-cdr! root-node content)
                   content)
         ((shared) (dispatch content))
         (else     (error "Invalid promise")))))

   (case (car root-node)
     ((lazy)   (let ((thunk (cdr root-node)))
                 (set-car! root-node 'hole)   ; blackhole root note so that
                 (set-cdr! root-node #f)      ; we do not hold on to chain
                 (dispatch (thunk))))
     ((value)  (cdr root-node))
     ((shared) (force (cdr root-node)))
     ((hole)   (error "Reentrant promise"))
     (else     (error "Invalid promise"))))

Andre