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