Changeset 6612

Timestamp:

May 25, 2007, 5:37:58 AM (18 years ago)

Author:

Gary Byers

Message:

PROCESS-DEBUG-CONDITION for event-process errors (hey, it's a start.)

File:

• branches/ide-1.0/ccl/examples/cocoa-window.lisp (modified) (2 diffs)

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

@@ -108 +108 @@
         (#/performSelectorOnMainThread:withObject:waitUntilDone:
          *NSApp* (@selector "postEventAtStart:") e  t)))))
+
+
+(defparameter *debug-in-event-process* t)
+
+(defmethod process-debug-condition ((process appkit-process) condition frame-pointer)
+  "Better than nothing.  Not much better."
+  (when *debug-in-event-process*
+    (catch 'need-a-catch-frame-for-backtrace
+      (let* ((*debug-in-event-process* nil)
+             (context (new-backtrace-info nil
+                                          frame-pointer
+                                          (if *backtrace-contexts*
+                                            (or (child-frame
+                                                 (bt.youngest (car *backtrace-contexts*))
+                                                 nil)
+                                                (last-frame-ptr))
+                                            (last-frame-ptr))
+                                          (%current-tcr)
+                                          condition
+                                          (%current-frame-ptr)
+                                          #+ppc-target *fake-stack-frames*
+                                          #+x86-target (%current-frame-ptr)
+                                          (db-link)
+                                          (1+ *break-level*)))
+             (*backtrace-contexts* (cons context *backtrace-contexts*)))  
+        (format t "~%~%*** Error in event process: ~a~%~%" condition)
+        (print-call-history :context context :detailed-p t :count 20 :origin frame-pointer)
+        (format t "~%~%~%")
+        (force-output t)
+        ))))
 
 
@@ -243 +273 @@
                       (push attr-name implemented-attributes))))))
             (values (#/retain font) implemented-attributes))))))
+
 
 ;;; Create a paragraph style, mostly so that we can set tabs reasonably.