From dc46cb5b40ed284a97e0fe51df3018705a8226e9 Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Mon, 11 Jan 1999 19:05:36 +0000
Subject: [PATCH] Add the with-timeout macro.

---
 code/exports.lisp    |  4 ++--
 code/multi-proc.lisp | 33 +++++++++++++++++++++++++++++++--
 2 files changed, 33 insertions(+), 4 deletions(-)

diff --git a/code/exports.lisp b/code/exports.lisp
index cdfcb3b4c..13cb4259e 100644
--- a/code/exports.lisp
+++ b/code/exports.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.159 1998/12/19 15:52:06 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.160 1999/01/11 19:05:35 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1704,4 +1704,4 @@
 	   "PROCESS-WAIT" "PROCESS-WAIT-WITH-TIMEOUT" 
 	   "PROCESS-WHOSTATE" "PROCESS-YIELD" "PROCESSP" "RESTART-PROCESS" 
 	   "SHOW-PROCESSES" "STACK-GROUP-RESUME" "WITHOUT-SCHEDULING"
-	   "WITH-LOCK-HELD"))
+	   "WITH-LOCK-HELD" "WITH-TIMEOUT"))
diff --git a/code/multi-proc.lisp b/code/multi-proc.lisp
index d5a7c8d7e..2151c71a6 100644
--- a/code/multi-proc.lisp
+++ b/code/multi-proc.lisp
@@ -5,7 +5,7 @@
 ;;; the Public domain, and is provided 'as is'.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/multi-proc.lisp,v 1.31 1998/09/26 18:24:42 pw Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/multi-proc.lisp,v 1.32 1999/01/11 19:05:36 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1527,6 +1527,35 @@
 	 (process-wait-with-timeout "Sleep" n (constantly nil)))))
 
 
+
+;;; With-Timeout-Internal  --  Internal
+;;;
+(defun with-timeout-internal (timeout function timeout-function)
+  (catch 'timer-interrupt
+    (let* ((current-process mp:*current-process*)
+	   (timer-process (mp:make-process
+			   #'(lambda ()
+			       (sleep timeout)
+			       (mp:process-interrupt
+				current-process
+				#'(lambda () (throw 'timer-interrupt nil))))
+			   :name "Timeout timer")))
+      (unwind-protect
+	   (return-from with-timeout-internal (funcall function))
+	(mp:destroy-process timer-process))))
+   (funcall timeout-function))
+
+;;; With-Timeout  --  Public
+;;;
+(defmacro with-timeout ((timeout &body timeout-forms) &body body)
+  "Executes body and returns the values of the last form in body. However, if
+  the execution takes longer than timeout seconds, abort it and evaluate
+  timeout-forms, returning the values of last form."
+  `(flet ((fn () . ,body)
+	  (tf () . ,timeout-forms))
+    (with-timeout-internal ,timeout #'fn #'tf)))
+
+
 ;;; Show-Processes  --  Public
 ;;;
 (defun show-processes (&optional verbose)
@@ -1536,7 +1565,7 @@
   (fresh-line)
   (dolist (process *all-processes*)
     (when (eq process *current-process*)
-      (format t "* "))
+      (format t "-> "))
     (format t "~s ~s ~a~%" process (process-whostate process) 
 	    (process-state process))
     (when verbose
-- 
GitLab