Changeset 6686

Timestamp:

Jun 8, 2007, 3:17:27 PM (17 years ago)

Author:

Gary Byers

Message:

Report conditions in the event process at most once.
Use defstatic for process-interrupt IDs.

File:

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

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

@@ -61 +61 @@
                  :void))
 
-(defvar *appkit-process-interrupt-ids* (make-id-map))
+(defstatic *appkit-process-interrupt-ids* (make-id-map))
 (defun register-appkit-process-interrupt (thunk)
   (assign-id-map-id *appkit-process-interrupt-ids* thunk))
@@ -112 +112 @@
 (defparameter *debug-in-event-process* t)
 
+(defparameter *event-process-reported-conditions* () "Things that we've already complained about on this event cycle.")
+
 (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)
+    (let* ((c (if (typep condition 'ns-lisp-exception)
+                (ns-lisp-exception-condition condition)
+                condition)))
+      (unless (member c *event-process-reported-conditions*)
+        (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))
-                                            (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)
-        ))))
+                                              (%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)
+            ))))))
 
 
@@ -186 +192 @@
   (let* ((app *NSApp*))
     (loop
-        (handler-case (#/run app)
+        (handler-case (let* ((*event-process-reported-conditions* nil))
+                        (#/run app))
           (error (c) (nslog-condition c)))
         (unless (#/isRunning app)