Update of /cvsroot/sbcl/sbcl/src/code
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv14360/src/code
Modified Files:
deadline.lisp target-error.lisp target-thread.lisp
Log Message:
1.0.37.6: Add SB-SYS:CANCEL-DEADLINE restart to DEADLINE-TIMEOUTs.
* Establish an SB-SYS:CANCEL-DEADLINE restart in SIGNAL-DEADLINE.
* Add an SB-SYS:CANCEL-DEADLINE restart function.
* Make SB-INT:READ-EVALUATED-FORM take an optional prompt. This
function is commonly used to query the user for input in restarts.
Use it in the SB-SYS:DEFER-DEADLINE restart in SIGNAL-DEADLINE.
* Bind *DEADLINE-SECONDS* in SB-THREAD:MAKE-THREAD. Not binding it
does not seem to have severe consequences, but that's not obvious
so just bind both so humans won't waste brain cycles on
it. SB-KERNEL:SUB-GC also binds both.
* Add usage of WITH-TEST to tests/deadline.impure.lisp. Also add
a test case for the new CANCEL-DEADLINE restart.
Index: deadline.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/deadline.lisp,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -d -r1.5 -r1.6
--- deadline.lisp 12 Jan 2008 15:29:04 -0000 1.5
+++ deadline.lisp 28 Mar 2010 17:35:37 -0000 1.6
@@ -88,20 +88,31 @@
(error 'deadline-timeout :seconds *deadline-seconds*)
(defer-deadline (&optional (seconds *deadline-seconds*))
:report "Defer the deadline for SECONDS more."
+ :interactive (lambda ()
+ (sb!int:read-evaluated-form
+ "By how many seconds shall the deadline ~
+ be deferred?: "))
(let* ((new-deadline-seconds (coerce seconds 'single-float))
(new-deadline (+ (seconds-to-internal-time new-deadline-seconds)
(get-internal-real-time))))
(setf *deadline* new-deadline
- *deadline-seconds* new-deadline-seconds)))))
+ *deadline-seconds* new-deadline-seconds)))
+ (cancel-deadline ()
+ :report "Cancel the deadline and continue."
+ (setf *deadline* nil *deadline-seconds* nil))))
nil)
(defun defer-deadline (seconds &optional condition)
"Find the DEFER-DEADLINE restart associated with CONDITION, and
-calls it with SECONDS as argument (deferring the deadline by that many
-seconds.) Continues from the indicated restart, or returns NIL if the
-restart is not found."
+invoke it with SECONDS as argument (deferring the deadline by that many
+seconds.) Otherwise return NIL if the restart is not found."
(try-restart 'defer-deadline condition seconds))
+(defun cancel-deadline (&optional condition)
+ "Find and invoke the CANCEL-DEADLINE restart associated with
+CONDITION, or return NIL if the restart is not found."
+ (try-restart 'cancel-deadline condition))
+
;;; Returns TIMEOUT-SEC, TIMEOUT-USEC, DEADLINE-SEC, DEADLINE-USEC, SIGNALP
;;;
;;; Takes *DEADLINE* into account: if it occurs before given SECONDS,
Index: target-error.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-error.lisp,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -d -r1.23 -r1.24
--- target-error.lisp 26 Sep 2009 21:34:46 -0000 1.23
+++ target-error.lisp 28 Mar 2010 17:35:37 -0000 1.24
@@ -156,8 +156,11 @@
;;; READ-EVALUATED-FORM is used as the interactive method for restart cases
;;; setup by the Common Lisp "casing" (e.g., CCASE and CTYPECASE) macros
;;; and by CHECK-TYPE.
-(defun read-evaluated-form ()
- (format *query-io* "~&Type a form to be evaluated:~%")
+(defun read-evaluated-form (&optional (prompt-control nil promptp)
+ &rest prompt-args)
+ (apply #'format *query-io*
+ (if promptp prompt-control "~&Type a form to be evaluated: ")
+ prompt-args)
(list (eval (read *query-io*))))
(defun check-type-error (place place-value type type-string)
Index: target-thread.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-thread.lisp,v
retrieving revision 1.122
retrieving revision 1.123
diff -u -d -r1.122 -r1.123
--- target-thread.lisp 28 Mar 2010 15:19:12 -0000 1.122
+++ target-thread.lisp 28 Mar 2010 17:35:37 -0000 1.123
@@ -918,6 +918,7 @@
(*handler-clusters* (sb!kernel::initial-handler-clusters))
(*condition-restarts* nil)
(sb!impl::*deadline* nil)
+ (sb!impl::*deadline-seconds* nil)
(sb!impl::*step-out* nil)
;; internal printer variables
(sb!impl::*previous-case* nil)
|