(in-package #:com.metabang.trivial-timeout)

(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (and (find-symbol (symbol-name '#:with-timeout)
			  '#:com.metabang.trivial-timeout)
	     (fboundp (find-symbol (symbol-name '#:with-timeout)
			  '#:com.metabang.trivial-timeout)))
(define-condition timeout-error (error)
                  ()
  (:report (lambda (c s)
	     (declare (ignore c))
	     (format s "Process timeout")))
  (:documentation "An error signaled when the duration specified in 
the [with-timeout][] is exceeded."))

(defmacro with-timeout ((seconds) &body body)
  "Execute `body` for no more than `seconds` time. 

If `seconds` is exceeded, then a [timeout-error][] will be signaled. 

If `seconds` is nil, then the body will be run normally until it completes
or is interrupted."
  (let ((gseconds (gensym "seconds-"))
	(gdoit (gensym "doit-"))
	#+(and sbcl (not sb-thread))
	(glabel (gensym "label-"))
	#+(and sbcl (not sb-thread))
	(gused-timer? (gensym "used-timer-")))
    `(let ((,gseconds ,seconds))
       (flet ((,gdoit ()
		,@body))
	 (cond ((and (numberp ,gseconds) (> ,gseconds 0))
		#+allegro
		(mp:with-timeout (,gseconds (error 'timeout-error)) 
		  (,gdoit))
		#+cmu
		(mp:with-timeout (,gseconds) (,gdoit))
		#+(and sbcl sb-thread)
		(handler-case 
		    (sb-ext:with-timeout ,gseconds (,gdoit))
		  (sb-ext::timeout (c)
		    (error 'timeout-error)))
		#+(and sbcl (not sb-thread))
		(let ((,gused-timer? nil))
		  (catch ',glabel
		    (sb-ext:schedule-timer
		     (sb-ext:make-timer (lambda ()
					  (setf ,gused-timer? t)
					  (throw ',glabel nil)))
		     ,gseconds)
		    (,gdoit))
		  (when ,gused-timer?
		    (error 'timeout-error)))
		#+(or digitool openmcl ccl)
		,(let ((checker-process (format nil "Checker ~S" (gensym)))
		       (waiting-process (format nil "Waiter ~S" (gensym)))
		       (result (gensym))
		       (process (gensym)))
		      `(let* ((,result nil)
			      (,process (ccl:process-run-function 
					 ,checker-process
					 (lambda ()
					   (setf ,result (,gdoit)))))) 
			 (ccl:process-wait-with-timeout
			  ,waiting-process
			  (* ,gseconds #+(or openmcl ccl)
			     ccl:*ticks-per-second* #+digitool 60)
			  (lambda ()
			    (not (ccl::process-active-p ,process)))) 
			 (when (ccl::process-active-p ,process)
			   (ccl:process-kill ,process)
			   (cerror "Timeout" 'timeout-error))
			 ,result))
		#+lispworks
		,(let ((gresult (gensym "result-"))
		       (gprocess (gensym "process-")))
		      `(let* (,gresult
			      (,gprocess (mp:process-run-function "WITH-TIMEOUT"
								  '()
								  (lambda ()
								    (setq ,gresult (,gdoit))))))
			 (unless (mp:process-wait-with-timeout "WITH-TIMEOUT"
							       ,gseconds
							       (lambda ()
								 (not (mp:process-alive-p ,gprocess))))
			   (mp:process-kill ,gprocess)
			   (cerror "Timeout" 'timeout-error))
			 ,gresult))
		#-(or allegro cmu sbcl openmcl ccl mcl digitool lispworks)
		(,gdoit))
	       (t
		(,gdoit)))))))))
