(define (ensure body-lambda ensuring-lambda)
  (dynamic-wind
      (lambda () #t)
      body-lambda
      ensuring-lambda))

(define (with-sigaction signum handler flags lamb)
    (let ((old-sigaction (sigaction signum)))
      (if flags (sigaction signum handler flags) (sigaction signum handler))
      (ensure 
       lamb
       (lambda ()
	 (sigaction signum (car old-sigaction) (cdr old-sigaction))))))

(define (with-timeout t thunk . handler)  
    (let ((time-left (alarm 0))	;;time left on an outer alarm
	  (start-time (current-time)))
      (alarm time-left)	;;continue the outer countdown
      (catch 'parent-timeout-error
	(lambda ()
	  (catch 'timeout-error
	    (lambda ()
	      (with-sigaction SIGALRM
		(lambda (sig)
		  (if (and (< time-left t) (not (equal? time-left 0)))
		      (throw 'parent-timeout-error) 
		      (throw 'timeout-error)))     
		#f    
		(lambda ()
		  (ensure 
		   (lambda ()  
		     (begin
		      (if (or (< t time-left) (equal? time-left 0))   
			  (alarm t)) ;;time out in the shorter time, not the most recently set time
		      (thunk)))
		   (lambda ()
		     (if (equal? time-left 0) 
			 (alarm 0)
			 ;;reset the outer alarm if there was one, subtracting time taken by the thunk
			 (let* ((time-taken (- (current-time) start-time))
				(time-remaining (- time-left time-taken))) 
			   (alarm 0) 
			   (if (<= 0 time-remaining) ; guile 1.3 is broken and
			       (alarm time-remaining) ; this can happen.
			       (raise SIGALRM))))))))) ;better late than never?
	    (lambda (k . v)
	      (if (null? handler)
		  (throw k)
		  ((car handler))))))
	(lambda (k . v)
	  (raise SIGALRM)))))

(define (assert-equals expected observed message)
  (if (equal? expected observed) 
      #t
      (begin
	(map display (list "Expected: " expected "\nObserved: " observed
			   "\n" message "\n")) 
	#f)))

(display (version)) (newline)
(if (and 
     (assert-equals 7 (with-timeout 2 (lambda () (+ 2 5))) 
		    "should not time out")
     
     (assert-equals 
      'caught 
      (catch 'timeout-error 
	     (lambda () (with-timeout 2 (lambda () 
					  (while #t "infinite monkeys"))))
	     (lambda (k . v) 'caught))
      "should time out with default handler")     
     
     (assert-equals 
      "specified handler"
      (with-timeout 2
		    (lambda () (begin (sleep 4) (display "fell asleep")))
		    (lambda () "specified handler"))  
      "should time out with specified handler")
     
     (assert-equals
      9
      (with-timeout 2
		    (lambda ()
		      (let ((foo (+ 2 3)))
			(with-timeout 2 (lambda () (+ foo 4))))))
      "nested timeouts that should not time out")
     
     (assert-equals
      "inner timeout"
      (with-timeout 5
		    (lambda ()
		      (let ((foo (+ 2 3)))
			(with-timeout 2
				      (lambda () (sleep 10))
				      (lambda () "inner timeout"))))
		    (lambda () "outer timeout"))
      "nested timeouts where the inner one should time out")
     
     (assert-equals
      "outer timeout"
      (with-timeout 2
		    (lambda ()
		      (let ((foo (+ 2 3)))
			(with-timeout 
			 5
			 (lambda ()
			   (begin
			     (sleep 10)
			     (display "oh no, you fell asleep!")))
			 (lambda () "inner timeout"))))
		    (lambda () "outer timeout"))
      "outer time has expired, and outer handler is used")
     
     (assert-equals
      "outer timeout" 
      (with-timeout 2
		    (lambda ()
		      (let ((foo (+ 2 3)))
			(with-timeout 5 
				      (lambda () (+ 8 7)) 
				      (lambda () "inner timeout"))
			(sleep 10)
			"oh no, you fell asleep!"))
		    (lambda () "outer timeout"))   
      (string-append "nested timeouts where the inner one should finish "
		     "but the outer one should still time out"))
     
     (assert-equals
      "outer timeout" 
      (with-timeout 2
		    (lambda ()
		      (let ((foo (+ 2 3)))
			(with-timeout 2
				      (lambda ()
					(+ 8 7))
				      (lambda ()
					"inner timeout"))
			(sleep 10)
			"oh no, you fell asleep!"))
		    (lambda ()
		      "outer timeout")) 
      "when the times are the same, the outer handler is used")
     )
    (display "good!\n")
    (primitive-exit 1))