Changeset 6711

Timestamp:

Jun 12, 2007, 12:59:09 PM (17 years ago)

Author:

Gary Byers

Message:

Lisp menu stuff (restarts dialog, etc.)
Listener window menu validation to move cmd-l key equivalent around.

File:

• branches/ide-1.0/ccl/examples/cocoa-listener.lisp (modified) (9 diffs)

branches/ide-1.0/ccl/examples/cocoa-listener.lisp

@@ -101 +101 @@
          
 
+(defclass hemlock-listener-frame (hemlock-frame)
+    ()
+  (:metaclass ns:+ns-object))
 
 
@@ -229 +232 @@
 
 (defun hemlock::listener-document-send-string (document string)
-  (let* ((controller (#/objectAtIndex: (#/windowControllers document) 0))
-         (filehandle (slot-value controller 'filehandle))
-         (len (length string))
-         (data (#/autorelease (make-instance 'ns:ns-mutable-data
-                                             :with-length len)))
-         (bytes (#/mutableBytes data)))
-    (%cstr-pointer string bytes nil)
-    (#/writeData: filehandle data)
-    (#/synchronizeFile filehandle)))
+  (let* ((buffer (hemlock-document-buffer document))
+         (process (if buffer (hi::buffer-process buffer))))
+    (if process
+      (hi::send-string-to-listener-process process string))))
 
 
@@ -269 +267 @@
   nil)
 
+
+
 (objc:defmethod #/init ((self hemlock-listener-document))
   (let* ((doc (call-next-method)))
@@ -292 +292 @@
 (defloadvar *next-listener-y-pos* nil) ; likewise
 
+(objc:defmethod (#/close :void) ((self hemlock-listener-document))
+  (if (zerop (decf *cocoa-listener-count*))
+    (setq *next-listener-x-pos* nil
+          *next-listener-y-pos* nil))
+  (call-next-method))
+
 (objc:defmethod (#/makeWindowControllers :void) ((self hemlock-listener-document))
   (let* ((textstorage (slot-value self 'textstorage))
          (window (%hemlock-frame-for-textstorage
+                  hemlock-listener-frame
                   textstorage
                   *listener-columns*
@@ -335 +342 @@
       (ccl::force-break-in-listener process))))
 
+(objc:defmethod (#/continue: :void) ((self hemlock-listener-document) sender)
+  (declare (ignore sender))
+  (let* ((buffer (hemlock-document-buffer self))
+         (process (if buffer (hi::buffer-process buffer))))
+    (when (typep process 'cocoa-listener-process)
+      (process-interrupt process #'continue))))
+
+(objc:defmethod (#/exitBreak: :void) ((self hemlock-listener-document) sender)
+  (declare (ignore sender))
+  (let* ((buffer (hemlock-document-buffer self))
+         (process (if buffer (hi::buffer-process buffer))))
+    (when (typep process 'cocoa-listener-process)
+      (process-interrupt process #'abort-break))))
+
 (defmethod listener-backtrace-context ((proc cocoa-listener-process))
   (car (cocoa-listener-process-backtrace-contexts proc)))
 
 (objc:defmethod (#/backtrace: :void) ((self hemlock-listener-document) sender)
-  (declare (ignore sender))
   (let* ((buffer (hemlock-document-buffer self))
          (process (if buffer (hi::buffer-process buffer))))
@@ -345 +365 @@
       (let* ((context (listener-backtrace-context process)))
         (when context
-          (#/showWindow: (backtrace-controller-for-context context) +null-ptr+))))))
+          (#/showWindow: (backtrace-controller-for-context context) sender))))))
+
+(defun restarts-controller-for-context (context)
+  (or (car (bt.restarts context))
+      (setf (car (bt.restarts context))
+            (let* ((tcr (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 (tcr->process (bt.tcr context))))
+              (make-instance 'sequence-window-controller
+                             :sequence (cdr (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)
+                                            (bt.break-level context)))))))
+                            
+(objc:defmethod (#/restarts: :void) ((self hemlock-listener-document) sender)
+  (let* ((buffer (hemlock-document-buffer self))
+         (process (if buffer (hi::buffer-process buffer))))
+    (when (typep process 'cocoa-listener-process)
+      (let* ((context (listener-backtrace-context process)))
+        (when context
+          (#/showWindow: (restarts-controller-for-context context) sender))))))
 
 (objc:defmethod (#/continue: :void) ((self hemlock-listener-document) sender)
@@ -354 +407 @@
       (let* ((context (listener-backtrace-context process)))
         (when context
-          (hi::send-string-to-listener-process process ":go
-"))))))
+          (process-interrupt process #'invoke-restart-interactively 'continue))))))
+
+
+
 
 
@@ -374 +429 @@
           ((eql action (@selector #/revertDocumentToSaved:))
            (values t nil))
+          ((eql action (@selector #/makeKeyAndOrderFront:))
+           (let* ((target (#/target item))
+                  (window (cocoa-listener-process-window process)))
+             (if (eql target window)
+               (progn
+                 (#/setKeyEquivalent: item #@"L")
+                 (#/setKeyEquivalentModifierMask: item #$NSCommandKeyMask))
+               (#/setKeyEquivalent: item #@""))
+             (values t t)))
           ((eql action (@selector #/interrupt:)) (values t t))
-          ((eql action (@selector #/backtrace:))
+          ((eql action (@selector #/continue:))
+           (let* ((context (listener-backtrace-context process)))
+             (values
+              t
+              (and context
+                   (find 'continue (cdr (bt.restarts context))
+                         :key #'restart-name)))))
+          ((or (eql action (@selector #/backtrace:))
+               (eql action (@selector #/exitBreak:))
+               (eql action (@selector #/restarts:)))
            (values t
                    (not (null (listener-backtrace-context process)))))))
@@ -455 +528 @@
       (destructuring-bind (package path string) selection
         (hi::send-string-to-listener-process target-listener string :package package :path path)))))
-  
+
+;;; Give the windows menu item for the top listener a command-key
+;;; equivalent of cmd-L.  Remove command-key equivalents from other windows.
+;;; (There are probably other ways of doing this.)
+(objc:defmethod (#/validateMenuItem: :<BOOL>) ((self hemlock-listener-frame)
+                                               item)
+  (let* ((action (#/action item)))
+    (when (eql action (@selector #/makeKeyAndOrderFront:))
+      (let* ((target (#/target item)))
+        (when (eql target self)
+          (let* ((top-doc (#/topListener hemlock-listener-document))
+                 (our-doc (#/document (#/windowController self))))
+            (if (eql our-doc top-doc)
+              (progn
+                (#/setKeyEquivalent: item #@"l")
+                (#/setKeyEquivalentModifierMask: item #$NSCommandKeyMask))
+              (#/setKeyEquivalent: item +null-ptr+)))))))
+  (call-next-method item))