Changeset 6667

Timestamp:

Jun 3, 2007, 2:59:25 AM (17 years ago)

Author:

Gary Byers

Message:

New args+locals scheme.

File:

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

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

@@ -14 +14 @@
 
 (defclass frame-label (ns-lisp-string)
-    ((frame-number :initarg :frame-number :foreign-type :int :accessor frame-label-number)
-     (controller :initarg :controller :foreign-type :id :reader frame-label-controller)
+    ((frame-number  :foreign-type :int :accessor frame-label-number)
+     (controller :foreign-type :id :reader frame-label-controller)
      (frame-inspector :initform nil :accessor frame-label-frame-inspector))
   (:metaclass ns:+ns-object))
 
-(defclass frame-item (ns-lisp-string)
-    ((frame-label :initarg :frame-label :foreign-type :id :accessor frame-item-label)
-     (index :initarg :index :foreign-type :int :accessor frame-item-index))
-  (:metaclass ns:+ns-object))
-
+(objc:defmethod #/initWithFrameNumber:controller: ((self frame-label) (frame-number :int) controller)
+  (let* ((obj (#/init self)))
+    (unless (%null-ptr-p obj)
+      (setf (slot-value obj 'frame-number) frame-number
+            (slot-value obj 'controller) controller))
+    obj))
+
+
+(defclass item-label (ns-lisp-string)
+    ((frame-label :foreign-type :id :accessor item-label-label)
+     (index :foreign-type :int :accessor item-label-index))
+  (:metaclass ns:+ns-object))
+
+(objc:defmethod #/initWithFrameLabel:index: ((self item-label) the-frame-label (index :int))
+  (let* ((obj (#/init self)))
+    (unless (%null-ptr-p obj)
+      (setf (slot-value obj 'frame-label) the-frame-label
+            (slot-value obj 'index) index))
+    obj))
 
 (defclass backtrace-window-controller (ns:ns-window-controller)
@@ -46 +60 @@
          (font (default-font :name "Monaco" :size 12)))
     (unless (%null-ptr-p outline)
+      (#/setTarget: outline self)
+      (#/setDoubleAction: outline (@selector #/backtraceDoubleClick:))
+      (#/setShouldCascadeWindows: self nil)
       (let* ((columns (#/tableColumns outline)))
         (dotimes (i (#/count columns))
@@ -64 +81 @@
                                 (class-name (class-of break-condition))
                                 break-condition))))
-                      
                 (#/setFont: header-cell (default-font :attributes '(:bold)))
                 (#/setStringValue: header-cell (%make-nsstring break-condition-string))))))))
@@ -70 +86 @@
       (unless (%null-ptr-p window)
         (let* ((context (backtrace-controller-context self))
-               (process (tcr->process (bt.tcr context))))
+               (process (tcr->process (bt.tcr context)))
+               (listener-window (if (typep process 'cocoa-listener-process)
+                                  (cocoa-listener-process-window process))))
+          (when listener-window
+            (let* ((listener-frame (#/frame listener-window))
+                   (backtrace-width (ns:ns-rect-width (#/frame window)))
+                   (new-x (- (+ (ns:ns-rect-x listener-frame)
+                                (/ (ns:ns-rect-width listener-frame) 2))
+                             (/ backtrace-width 2))))
+              (ns:with-ns-point (p new-x (+ (ns:ns-rect-y listener-frame) (ns:ns-rect-height listener-frame)))
+                (#/setFrameOrigin: window p))))
           (#/setTitle:  window (%make-nsstring
                                 (format nil "Backtrace for ~a(~d), break level ~d"
@@ -76 +102 @@
                                         (process-serial-number process)
                                         (bt.break-level context)))))))))
+
+
+(objc:defmethod (#/backtraceDoubleClick: :void)
+    ((self backtrace-window-controller) sender)
+  (let* ((row (#/clickedRow sender)))
+    (if (>= row 0)
+      (let* ((item (#/itemAtRow: sender row))
+             (val-p nil)
+             (value nil))
+        (cond ((typep item 'frame-label)
+               (let* ((controller (frame-label-controller item))
+                      (inspector (backtrace-controller-inspector controller))
+                      (frame-number (frame-label-number item)))
+                 (setq val-p t value (inspector::line-n inspector frame-number))))
+              ((typep item 'item-label)
+               (let* ((the-frame-label (item-label-label item))
+                      (frame-inspector (frame-label-frame-inspector the-frame-label))
+                      (index (item-label-index item))
+                      (rawval (inspector::line-n frame-inspector index)))
+                 (if (and (consp rawval)
+                          (typep (car rawval) 'keyword))
+                 (setq val-p t value (cddr rawval))))))
+        (if val-p
+          (cinspect value))))))
+
+
+
 
 (objc:defmethod (#/outlineView:isItemExpandable: :<BOOL>)
@@ -108 +161 @@
            (let* ((label
                    (make-instance 'frame-label
+                                  :with-frame-number index
+                                  :controller self
                                   :string
                                   (let* ((value 
@@ -114 +169 @@
                                       (%lfun-name-string value)
                                       ":kernel")))))
-             (setf (slot-value label 'controller) self
-                   (slot-value label 'frame-number) index)
              label))
           ((our-frame-label-p self item)
@@ -126 +179 @@
                               :object (inspector::inspector-object inspector)
                               :update-line-count t)))))
-             (make-instance 'frame-item
-                            :frame-label item
+             (make-instance 'item-label
+                            :with-frame-label item
                             :index index
                             :string
                             (let* ((ccl::*aux-vsp-ranges* (inspector::vsp-range inspector))
-                                   (ccl::*aux-tsp-ranges* (inspector::tsp-range inspector)))
+                                   (ccl::*aux-tsp-ranges* (inspector::tsp-range inspector))
+                                   (ccl::*aux-csp-ranges* (inspector::csp-range inspector)))
                               (with-output-to-string (s)
-                                                     (multiple-value-bind (value label)
-                                                         (inspector::line-n
-                                                          frame-inspector
-                                                          index)
+                                                     (let* ((value
+                                                             (inspector::line-n
+                                                              frame-inspector
+                                                              index)))
                                                        (inspector::prin1-value
                                                         frame-inspector
                                                         s
-                                                        value
-                                                        label)))))))
+                                                        value)))))))
           (t (break) (%make-nsstring "Huh?")))))
 
@@ -182 +235 @@
         (let* ((window (bt.dialog context)))
           (when window
-            (#/performSelectorOnMainThread:withObject:waitUntilDone: window (@selector @/close)  +null-ptr+ t)))))))
+            (#/performSelectorOnMainThread:withObject:waitUntilDone: window (@selector #/close)  +null-ptr+ t)))))))