;; Schachtelbare Engines

(define (new-engine resume)
  (lambda (ticks return expire)
    ((call-with-current-continuation
      (lambda (escape)
	(run resume
	     (stop-timer)
	     ticks
	     (lambda (value ticks)
	       (escape (lambda () (return value ticks))))
	     (lambda (engine)
	       (escape (lambda () (expire engine))))))))))

(define (run resume parent-ticks child-ticks return expire)
  (let ((ticks (if (and (active?)
			(< parent-ticks child-ticks))
		   parent-ticks
		   child-ticks)))
    (push (- parent-ticks ticks)
	  (- child-ticks ticks)
	  return
	  expire)
    (resume ticks)))

(define (go ticks)
  (if (active?)
      (if (zero? ticks)
	  (timer-handler)
	  (start-timer ticks timer-handler))))

(define (do-return value ticks)
  (pop (lambda (parent-ticks child-ticks return expire)
	 (go (+ parent-ticks ticks))
	 (return value (+ child-ticks ticks)))))

(define (do-expire resume)
  (pop (lambda (parent-ticks child-ticks return expire)
	 (if (> child-ticks 0)
	     (do-expire (lambda (ticks)
			  (run resume ticks child-ticks return expire)))
	     (begin
	       (go parent-ticks)
	       (expire (new-engine resume)))))))

(define (timer-handler)
  (go (call-with-current-continuation do-expire)))

(define stack '())

(define (push . l)
  (set! stack (cons l stack)))

(define (pop handler)
  (if (null? stack)
      (error "attempt to return from inactive engine")
      (let ((top (car stack)))
	(set! stack (cdr stack))
	(apply handler top))))

(define (active?)
  (not (null? stack)))

(define (make-engine proc)
  (new-engine
   (lambda (ticks)
     (go ticks)
     (proc)
     (error "invalid completion"))))

(define (engine-return value)
  (do-return value (stop-timer)))