[Openmcl-cvs-notifications] r15116 - in /trunk/source: cocoa-ide/cocoa-listener.lisp cocoa-ide/cocoa-remote-lisp.lisp level-1/l1-readloop-lds.lisp lib/swink.lisp library/remote-lisp.lisp
gz at clozure.com
gz at clozure.com
Tue Dec 6 15:51:52 CST 2011
Author: gz
Date: Tue Dec 6 15:51:52 2011
New Revision: 15116
Log:
Implement restarts dialog for remote listener
Modified:
trunk/source/cocoa-ide/cocoa-listener.lisp
trunk/source/cocoa-ide/cocoa-remote-lisp.lisp
trunk/source/level-1/l1-readloop-lds.lisp
trunk/source/lib/swink.lisp
trunk/source/library/remote-lisp.lisp
Modified: trunk/source/cocoa-ide/cocoa-listener.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/cocoa-ide/cocoa-listener.lisp (original)
+++ trunk/source/cocoa-ide/cocoa-listener.lisp Tue Dec 6 15:51:52 2011
@@ -578,30 +578,32 @@
(#/showWindow: (backtrace-controller-for-context context) sender=
))))))
=
(defun restarts-controller-for-context (context)
- (or (car (ccl::bt.restarts context))
- (setf (car (ccl::bt.restarts context))
- (let* ((tcr (ccl::bt.tcr context))
- (tsp-range (inspector::make-tsp-stack-range tcr context=
))
- (vsp-range (inspector::make-vsp-stack-range tcr context=
))
- (csp-range (inspector::make-csp-stack-range tcr context=
))
- (process (ccl::tcr->process tcr)))
- (make-instance 'sequence-window-controller
- :sequence (cdr (ccl::bt.restarts context))
- :result-callback #'(lambda (r)
- (process-interrupt
- process
- #'invoke-restart-intera=
ctively
- r))
- :display #'(lambda (item stream)
- (let* ((ccl::*aux-vsp-ranges* vs=
p-range)
- (ccl::*aux-tsp-ranges* ts=
p-range)
- (ccl::*aux-csp-ranges* cs=
p-range))
- (princ item stream)))
- :title (format nil "Restarts for ~a(~d), brea=
k level ~d"
- (process-name process)
- (process-serial-number process)
- (ccl::bt.break-level context))=
)))))
- =
+ (or (backtrace-context-restarts-window context)
+ (setf (backtrace-context-restarts-window context) (restarts-dialog c=
ontext))))
+
+(defmethod restarts-dialog ((context vector))
+ (let* ((tcr (ccl::bt.tcr context))
+ (tsp-range (ccl::make-tsp-stack-range tcr context))
+ (vsp-range (ccl::make-vsp-stack-range tcr context))
+ (csp-range (ccl::make-csp-stack-range tcr context))
+ (process (ccl::tcr->process tcr)))
+ (make-instance 'sequence-window-controller
+ :sequence (cdr (ccl::bt.restarts context))
+ :result-callback #'(lambda (r)
+ (process-interrupt
+ process
+ #'invoke-restart-interactively
+ r))
+ :display #'(lambda (item stream)
+ (let* ((ccl::*aux-vsp-ranges* vsp-range)
+ (ccl::*aux-tsp-ranges* tsp-range)
+ (ccl::*aux-csp-ranges* csp-range))
+ (princ item stream)))
+ :title (format nil "Restarts for ~a(~d), break level ~d"
+ (process-name process)
+ (process-serial-number process)
+ (ccl::backtrace-context-break-level context)))))
+
(objc:defmethod (#/restarts: :void) ((self hemlock-listener-document) send=
er)
(let* ((process (hemlock-document-process self)))
(when process
Modified: trunk/source/cocoa-ide/cocoa-remote-lisp.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/cocoa-ide/cocoa-remote-lisp.lisp (original)
+++ trunk/source/cocoa-ide/cocoa-remote-lisp.lisp Tue Dec 6 15:51:52 2011
@@ -152,3 +152,19 @@
(restarts-window :initform nil :accessor backtrace-context-restarts-win=
dow)))
=
(defmethod ccl::remote-context-class ((application cocoa-application)) 'co=
coa-remote-backtrace-context)
+
+(defmethod restarts-dialog ((context cocoa-remote-backtrace-context))
+ (let ((restarts (ccl::backtrace-context-restarts context))
+ (thread (ccl::backtrace-context-thread context)))
+ (make-instance 'sequence-window-controller
+ :sequence (loop for i from 0 below (length restarts) collect i)
+ :display (lambda (index stream) (princ (nth index restarts) stream))
+ :result-callback (lambda (index)
+ (ccl::rlisp/invoke-restart-in-context thread inde=
x))
+ :title (format nil "Restarts for ~a, break level ~d"
+ (ccl::rlisp-thread-description thread)
+ (ccl::backtrace-context-break-level context)))))
+
+
+
+
Modified: trunk/source/level-1/l1-readloop-lds.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-readloop-lds.lisp (original)
+++ trunk/source/level-1/l1-readloop-lds.lisp Tue Dec 6 15:51:52 2011
@@ -640,6 +640,13 @@
(defmethod backtrace-context-continuable-p ((context vector))
(not (null (find 'continue (cdr (bt.restarts context)) :key #'restart-na=
me))))
=
+(defmethod backtrace-context-break-level ((context vector))
+ (bt.break-level context))
+
+(defmethod backtrace-context-restarts ((context vector))
+ (cdr (bt.restarts context)))
+
+
;;; Each of these stack ranges defines the entire range of (control/value/=
temp)
;;; addresses; they can be used to addresses of stack-allocated objects
;;; for printing.
Modified: trunk/source/lib/swink.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/swink.lisp (original)
+++ trunk/source/lib/swink.lisp Tue Dec 6 15:51:52 2011
@@ -613,18 +613,32 @@
(when (eq *current-process* ccl::*initial-pro=
cess*)
(toplevel))))))))
=
+(defun marshall-debugger-context (context)
+ ;; TODO: neither :GO nor cmd-/ pay attention to the break condition, whe=
reas bt.restarts does...
+ (let* ((continuable (ccl::backtrace-context-continuable-p context))
+ (restarts (ccl::backtrace-context-restarts context))
+ (tcr (ccl::bt.tcr context))
+ ;; Context for printing stack-consed refs
+ (ccl::*aux-tsp-ranges* (ccl::make-tsp-stack-range tcr context))
+ (ccl::*aux-vsp-ranges* (ccl::make-vsp-stack-range tcr context))
+ (ccl::*aux-csp-ranges* (ccl::make-csp-stack-range tcr context))
+ (break-level (ccl::bt.break-level context)))
+ (list :break-level break-level
+ :continuable-p (and continuable t)
+ :restarts (mapcar #'princ-to-string restarts))))
+ =
+(defvar *bt-context* nil)
+
(defun swink-read-loop (&key (break-level 0) &allow-other-keys)
(let* ((thread *current-server-thread*)
(conn (thread-connection thread))
(ccl::*break-level* break-level)
(*loading-file-source-file* nil)
(ccl::*loading-toplevel-location* nil)
- (context (find break-level ccl::*backtrace-contexts* :key (lambda=
(bt) (ccl::bt.break-level bt))))
+ (*bt-context* (find break-level ccl::*backtrace-contexts* :key #'=
ccl::backtrace-context-break-level))
*** ** * +++ ++ + /// // / -)
- (when context
- ;; TODO: neither :GO nor cmd-/ pay attention to the break condition,=
whereas bt.restarts does...
- (let ((continuable (ccl::backtrace-context-continuable-p context)))
- (send-event conn `(:enter-break ,break-level ,(and continuable t))=
)))
+ (when *bt-context*
+ (send-event conn `(:enter-break ,(marshall-debugger-context *bt-cont=
ext*))))
=
(flet ((repl-until-abort ()
(restart-case
@@ -756,6 +770,9 @@
((:invoke-restart restart-name)
(invoke-restart restart-name))
=
+ ((:invoke-restart-in-context index)
+ (invoke-restart-interactively (nth index (ccl::backtrace-context-re=
starts *bt-context*))))
+
((:toplevel)
(toplevel)))))
=
Modified: trunk/source/library/remote-lisp.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/library/remote-lisp.lisp (original)
+++ trunk/source/library/remote-lisp.lisp Tue Dec 6 15:51:52 2011
@@ -59,14 +59,18 @@
(defmethod rlisp-host-description ((rthread remote-lisp-thread))
(rlisp-host-description (swink:thread-connection rthread)))
=
+(defmethod rlisp-thread-description ((rthread remote-lisp-thread))
+ (format nil "~a thread ~a" (rlisp-host-description rthread) (swink:threa=
d-id rthread)))
+
(defmethod print-object ((rthread remote-lisp-thread) stream)
(print-unreadable-object (rthread stream :type t :identity t)
- (format stream "~a thread ~a"
- (rlisp-host-description rthread)
- (swink:thread-id rthread))))
+ (princ (rlisp-thread-description rthread) stream)))
=
(defmethod rlisp/invoke-restart ((rthread remote-lisp-thread) name)
(swink:send-event rthread `(:invoke-restart ,name)))
+
+(defmethod rlisp/invoke-restart-in-context ((rthread remote-lisp-thread) i=
ndex)
+ (swink:send-event rthread `(:invoke-restart-in-context ,index)))
=
(defmethod rlisp/toplevel ((rthread remote-lisp-thread))
(swink:send-event rthread `(:toplevel)))
@@ -175,9 +179,10 @@
(apply #'values return-values))))
=
(defclass remote-backtrace-context ()
- ((process :initform *current-process* :reader backtrace-context-process)
+ ((thread :initarg :thread :reader backtrace-context-thread)
(break-level :initarg :break-level :reader backtrace-context-break-leve=
l)
- (continuable-p :initarg :continuable-p :reader backtrace-context-contin=
uable-p)))
+ (continuable-p :initarg :continuable-p :reader backtrace-context-contin=
uable-p)
+ (restarts :initarg :restarts :reader backtrace-context-restarts)))
=
(defmethod remote-context-class ((application application)) 'remote-backtr=
ace-context)
=
@@ -195,18 +200,19 @@
(unless (eql level *break-level*)
(warn ":READ-LOOP level confusion got ~s expected ~s" level (1+ *br=
eak-level*)))
(invoke-restart 'debug-restart level)) ;; restart at same level, abor=
ted current expression.
- ((:enter-break level continuablep)
- (unless (or (eql level 0) (eql level (1+ *break-level*)))
- (warn ":ENTER-BREAK level confusion got ~s expected ~s" level (1+ *=
break-level*)))
- ;(format t "~&Error: ~a" condition-text)
- ;(when *show-restarts-on-break*
- ; (format t "~&Remote restarts:")
- ; (loop for (name description) in restarts
- ; do (format t "~&~a ~a" name description))
- ; (fresh-line))
- (let ((rcontext (make-instance (remote-context-class *application*)
- :break-level level
- :continuable-p continuablep)))
+ ((:enter-break context-plist)
+ (let* ((rcontext (apply #'make-instance (remote-context-class *applic=
ation*)
+ :thread rthread
+ context-plist))
+ (level (backtrace-context-break-level rcontext)))
+ (unless (or (eql level 0) (eql level (1+ *break-level*)))
+ (warn ":ENTER-BREAK level confusion got ~s expected ~s" level (1+=
*break-level*)))
+ ;(format t "~&Error: ~a" condition-text)
+ ;(when *show-restarts-on-break*
+ ; (format t "~&Remote restarts:")
+ ; (loop for (name description) in restarts
+ ; do (format t "~&~a ~a" name description))
+ ; (fresh-line))
(unwind-protect
(progn
(application-ui-operation *application* :enter-backtrace-cont=
ext rcontext)
More information about the Openmcl-cvs-notifications
mailing list