Changeset 15116

Timestamp:

Dec 6, 2011, 1:51:52 PM (13 years ago)

Author:

gz

Message:

Implement restarts dialog for remote listener

Location:

trunk/source

Files:

• cocoa-ide/cocoa-listener.lisp (modified) (1 diff)
• cocoa-ide/cocoa-remote-lisp.lisp (modified) (1 diff)
• level-1/l1-readloop-lds.lisp (modified) (1 diff)
• lib/swink.lisp (modified) (3 diffs)
• library/remote-lisp.lisp (modified) (3 diffs)

trunk/source/cocoa-ide/cocoa-listener.lisp

@@ -579 +579 @@
 
 (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)))

trunk/source/cocoa-ide/cocoa-remote-lisp.lisp

@@ -153 +153 @@
 
 (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)))))
+
+
+
+

trunk/source/level-1/l1-readloop-lds.lisp

@@ -641 +641 @@
   (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

trunk/source/lib/swink.lisp

@@ -614 +614 @@
                                (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 +636 @@
          (*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 +771 @@
        (invoke-restart restart-name))
       
+      ((:invoke-restart-in-context index)
+       (invoke-restart-interactively (nth index (ccl::backtrace-context-restarts *bt-context*))))
+
       ((:toplevel)
        (toplevel)))))

trunk/source/library/remote-lisp.lisp

@@ -60 +60 @@
   (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 +180 @@
 
 (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 +201 @@
        (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