Changeset 15116


Ignore:
Timestamp:
Dec 6, 2011, 9:51:52 PM (8 years ago)
Author:
gz
Message:

Implement restarts dialog for remote listener

Location:
trunk/source
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/cocoa-ide/cocoa-listener.lisp

    r15109 r15116  
    579579
    580580(defun restarts-controller-for-context (context)
    581   (or (car (ccl::bt.restarts context))
    582       (setf (car (ccl::bt.restarts context))
    583             (let* ((tcr (ccl::bt.tcr context))
    584                    (tsp-range (inspector::make-tsp-stack-range tcr context))
    585                    (vsp-range (inspector::make-vsp-stack-range tcr context))
    586                    (csp-range (inspector::make-csp-stack-range tcr context))
    587                    (process (ccl::tcr->process tcr)))
    588               (make-instance 'sequence-window-controller
    589                              :sequence (cdr (ccl::bt.restarts context))
    590                              :result-callback #'(lambda (r)
    591                                                   (process-interrupt
    592                                                    process
    593                                                    #'invoke-restart-interactively
    594                                                    r))
    595                              :display #'(lambda (item stream)
    596                                           (let* ((ccl::*aux-vsp-ranges* vsp-range)
    597                                                  (ccl::*aux-tsp-ranges* tsp-range)
    598                                                  (ccl::*aux-csp-ranges* csp-range))
    599                                           (princ item stream)))
    600                              :title (format nil "Restarts for ~a(~d), break level ~d"
    601                                             (process-name process)
    602                                             (process-serial-number process)
    603                                             (ccl::bt.break-level context)))))))
    604                            
     581  (or (backtrace-context-restarts-window context)
     582      (setf (backtrace-context-restarts-window context) (restarts-dialog context))))
     583
     584(defmethod restarts-dialog ((context vector))
     585  (let* ((tcr (ccl::bt.tcr context))
     586         (tsp-range (ccl::make-tsp-stack-range tcr context))
     587         (vsp-range (ccl::make-vsp-stack-range tcr context))
     588         (csp-range (ccl::make-csp-stack-range tcr context))
     589         (process (ccl::tcr->process tcr)))
     590    (make-instance 'sequence-window-controller
     591      :sequence (cdr (ccl::bt.restarts context))
     592      :result-callback #'(lambda (r)
     593                           (process-interrupt
     594                            process
     595                            #'invoke-restart-interactively
     596                            r))
     597      :display #'(lambda (item stream)
     598                   (let* ((ccl::*aux-vsp-ranges* vsp-range)
     599                          (ccl::*aux-tsp-ranges* tsp-range)
     600                          (ccl::*aux-csp-ranges* csp-range))
     601                     (princ item stream)))
     602      :title (format nil "Restarts for ~a(~d), break level ~d"
     603                     (process-name process)
     604                     (process-serial-number process)
     605                     (ccl::backtrace-context-break-level context)))))
     606
    605607(objc:defmethod (#/restarts: :void) ((self hemlock-listener-document) sender)
    606608  (let* ((process (hemlock-document-process self)))
  • trunk/source/cocoa-ide/cocoa-remote-lisp.lisp

    r15109 r15116  
    153153
    154154(defmethod ccl::remote-context-class ((application cocoa-application)) 'cocoa-remote-backtrace-context)
     155
     156(defmethod restarts-dialog ((context cocoa-remote-backtrace-context))
     157  (let ((restarts (ccl::backtrace-context-restarts context))
     158        (thread (ccl::backtrace-context-thread context)))
     159    (make-instance 'sequence-window-controller
     160      :sequence (loop for i from 0 below (length restarts) collect i)
     161      :display (lambda (index stream) (princ (nth index restarts) stream))
     162      :result-callback (lambda (index)
     163                         (ccl::rlisp/invoke-restart-in-context thread index))
     164      :title (format nil "Restarts for ~a, break level ~d"
     165                     (ccl::rlisp-thread-description thread)
     166                     (ccl::backtrace-context-break-level context)))))
     167
     168
     169
     170
  • trunk/source/level-1/l1-readloop-lds.lisp

    r15115 r15116  
    641641  (not (null (find 'continue (cdr (bt.restarts context)) :key #'restart-name))))
    642642
     643(defmethod backtrace-context-break-level ((context vector))
     644  (bt.break-level context))
     645
     646(defmethod backtrace-context-restarts ((context vector))
     647  (cdr (bt.restarts context)))
     648
     649
    643650;;; Each of these stack ranges defines the entire range of (control/value/temp)
    644651;;; addresses; they can be used to addresses of stack-allocated objects
  • trunk/source/lib/swink.lisp

    r15109 r15116  
    614614                               (toplevel))))))))
    615615
     616(defun marshall-debugger-context (context)
     617  ;; TODO: neither :GO nor cmd-/ pay attention to the break condition, whereas bt.restarts does...
     618  (let* ((continuable (ccl::backtrace-context-continuable-p context))
     619         (restarts (ccl::backtrace-context-restarts context))
     620         (tcr (ccl::bt.tcr context))
     621         ;; Context for printing stack-consed refs
     622         (ccl::*aux-tsp-ranges* (ccl::make-tsp-stack-range tcr context))
     623         (ccl::*aux-vsp-ranges* (ccl::make-vsp-stack-range tcr context))
     624         (ccl::*aux-csp-ranges* (ccl::make-csp-stack-range tcr context))
     625         (break-level (ccl::bt.break-level context)))
     626    (list :break-level break-level
     627          :continuable-p (and continuable t)
     628          :restarts (mapcar #'princ-to-string restarts))))
     629 
     630(defvar *bt-context* nil)
     631
    616632(defun swink-read-loop (&key (break-level 0) &allow-other-keys)
    617633  (let* ((thread *current-server-thread*)
     
    620636         (*loading-file-source-file* nil)
    621637         (ccl::*loading-toplevel-location* nil)
    622          (context (find break-level ccl::*backtrace-contexts* :key (lambda (bt) (ccl::bt.break-level bt))))
     638         (*bt-context* (find break-level ccl::*backtrace-contexts* :key #'ccl::backtrace-context-break-level))
    623639         *** ** * +++ ++ + /// // / -)
    624     (when context
    625       ;; TODO: neither :GO nor cmd-/ pay attention to the break condition, whereas bt.restarts does...
    626       (let ((continuable (ccl::backtrace-context-continuable-p context)))
    627         (send-event conn `(:enter-break ,break-level ,(and continuable t)))))
     640    (when *bt-context*
     641      (send-event conn `(:enter-break ,(marshall-debugger-context *bt-context*))))
    628642
    629643    (flet ((repl-until-abort ()
     
    757771       (invoke-restart restart-name))
    758772     
     773      ((:invoke-restart-in-context index)
     774       (invoke-restart-interactively (nth index (ccl::backtrace-context-restarts *bt-context*))))
     775
    759776      ((:toplevel)
    760777       (toplevel)))))
  • trunk/source/library/remote-lisp.lisp

    r15109 r15116  
    6060  (rlisp-host-description (swink:thread-connection rthread)))
    6161
     62(defmethod rlisp-thread-description ((rthread remote-lisp-thread))
     63  (format nil "~a thread ~a" (rlisp-host-description rthread) (swink:thread-id rthread)))
     64
    6265(defmethod print-object ((rthread remote-lisp-thread) stream)
    6366  (print-unreadable-object (rthread stream :type t :identity t)
    64     (format stream "~a thread ~a"
    65             (rlisp-host-description rthread)
    66             (swink:thread-id rthread))))
     67    (princ (rlisp-thread-description rthread) stream)))
    6768
    6869(defmethod rlisp/invoke-restart ((rthread remote-lisp-thread) name)
    6970  (swink:send-event rthread `(:invoke-restart ,name)))
     71
     72(defmethod rlisp/invoke-restart-in-context ((rthread remote-lisp-thread) index)
     73  (swink:send-event rthread `(:invoke-restart-in-context ,index)))
    7074
    7175(defmethod rlisp/toplevel ((rthread remote-lisp-thread))
     
    176180
    177181(defclass remote-backtrace-context ()
    178   ((process :initform *current-process* :reader backtrace-context-process)
     182  ((thread :initarg :thread :reader backtrace-context-thread)
    179183   (break-level :initarg :break-level :reader backtrace-context-break-level)
    180    (continuable-p :initarg :continuable-p :reader backtrace-context-continuable-p)))
     184   (continuable-p :initarg :continuable-p :reader backtrace-context-continuable-p)
     185   (restarts :initarg :restarts :reader backtrace-context-restarts)))
    181186
    182187(defmethod remote-context-class ((application application)) 'remote-backtrace-context)
     
    196201       (warn ":READ-LOOP level confusion got ~s expected ~s" level (1+ *break-level*)))
    197202     (invoke-restart 'debug-restart level)) ;; restart at same level, aborted current expression.
    198     ((:enter-break level continuablep)
    199      (unless (or (eql level 0) (eql level (1+ *break-level*)))
    200        (warn ":ENTER-BREAK level confusion got ~s expected ~s" level (1+ *break-level*)))
    201      ;(format t "~&Error: ~a" condition-text)
    202      ;(when *show-restarts-on-break*
    203      ;  (format t "~&Remote restarts:")
    204      ;  (loop for (name description) in restarts
    205      ;    do (format t "~&~a ~a" name description))
    206      ;  (fresh-line))
    207      (let ((rcontext (make-instance (remote-context-class *application*)
    208                        :break-level level
    209                        :continuable-p continuablep)))
     203    ((:enter-break context-plist)
     204     (let* ((rcontext (apply #'make-instance (remote-context-class *application*)
     205                             :thread rthread
     206                             context-plist))
     207            (level (backtrace-context-break-level rcontext)))
     208       (unless (or (eql level 0) (eql level (1+ *break-level*)))
     209         (warn ":ENTER-BREAK level confusion got ~s expected ~s" level (1+ *break-level*)))
     210       ;(format t "~&Error: ~a" condition-text)
     211       ;(when *show-restarts-on-break*
     212       ;  (format t "~&Remote restarts:")
     213       ;  (loop for (name description) in restarts
     214       ;    do (format t "~&~a ~a" name description))
     215       ;  (fresh-line))
    210216       (unwind-protect
    211217           (progn
Note: See TracChangeset for help on using the changeset viewer.