Index: /trunk/source/cocoa-ide/cocoa-listener.lisp =================================================================== --- /trunk/source/cocoa-ide/cocoa-listener.lisp (revision 15115) +++ /trunk/source/cocoa-ide/cocoa-listener.lisp (revision 15116) @@ -579,28 +579,30 @@ (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-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::bt.break-level context))))))) - + (or (backtrace-context-restarts-window context) + (setf (backtrace-context-restarts-window context) (restarts-dialog context)))) + +(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) sender) (let* ((process (hemlock-document-process self))) Index: /trunk/source/cocoa-ide/cocoa-remote-lisp.lisp =================================================================== --- /trunk/source/cocoa-ide/cocoa-remote-lisp.lisp (revision 15115) +++ /trunk/source/cocoa-ide/cocoa-remote-lisp.lisp (revision 15116) @@ -153,2 +153,18 @@ (defmethod ccl::remote-context-class ((application cocoa-application)) 'cocoa-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 index)) + :title (format nil "Restarts for ~a, break level ~d" + (ccl::rlisp-thread-description thread) + (ccl::backtrace-context-break-level context))))) + + + + Index: /trunk/source/level-1/l1-readloop-lds.lisp =================================================================== --- /trunk/source/level-1/l1-readloop-lds.lisp (revision 15115) +++ /trunk/source/level-1/l1-readloop-lds.lisp (revision 15116) @@ -641,4 +641,11 @@ (not (null (find 'continue (cdr (bt.restarts context)) :key #'restart-name)))) +(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 Index: /trunk/source/lib/swink.lisp =================================================================== --- /trunk/source/lib/swink.lisp (revision 15115) +++ /trunk/source/lib/swink.lisp (revision 15116) @@ -614,4 +614,20 @@ (toplevel)))))))) +(defun marshall-debugger-context (context) + ;; TODO: neither :GO nor cmd-/ pay attention to the break condition, whereas 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*) @@ -620,10 +636,8 @@ (*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-context*)))) (flet ((repl-until-abort () @@ -757,4 +771,7 @@ (invoke-restart restart-name)) + ((:invoke-restart-in-context index) + (invoke-restart-interactively (nth index (ccl::backtrace-context-restarts *bt-context*)))) + ((:toplevel) (toplevel))))) Index: /trunk/source/library/remote-lisp.lisp =================================================================== --- /trunk/source/library/remote-lisp.lisp (revision 15115) +++ /trunk/source/library/remote-lisp.lisp (revision 15116) @@ -60,12 +60,16 @@ (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:thread-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) index) + (swink:send-event rthread `(:invoke-restart-in-context ,index))) (defmethod rlisp/toplevel ((rthread remote-lisp-thread)) @@ -176,7 +180,8 @@ (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-level) - (continuable-p :initarg :continuable-p :reader backtrace-context-continuable-p))) + (continuable-p :initarg :continuable-p :reader backtrace-context-continuable-p) + (restarts :initarg :restarts :reader backtrace-context-restarts))) (defmethod remote-context-class ((application application)) 'remote-backtrace-context) @@ -196,16 +201,17 @@ (warn ":READ-LOOP level confusion got ~s expected ~s" level (1+ *break-level*))) (invoke-restart 'debug-restart level)) ;; restart at same level, aborted 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 *application*) + :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