Changeset 12706


Ignore:
Timestamp:
Aug 27, 2009, 9:26:50 PM (10 years ago)
Author:
palter
Message:

Viola! Pop-up the console window when an error occurs
in the event loop.

File:
1 edited

Legend:

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

    r12490 r12706  
    5252(defclass appkit-process (process)
    5353    ((have-interactive-terminal-io :initform t)))
     54
     55(defmethod event-loop-can-have-interactive-terminal-io ((process appkit-process))
     56  #+windows-target t
     57  #-windows-target (slot-value process 'have-interactive-terminal-io))
    5458
    5559;;; Interrupt the AppKit event process, by enqueing an event (if the
     
    8690      (unless (or (not (typep c 'error)) (member c *event-process-reported-conditions*))
    8791        (push c *event-process-reported-conditions*)
    88         (if (slot-value process 'have-interactive-terminal-io)
    89           (ccl::application-error ccl::*application* c frame-pointer)
    90           (catch 'need-a-catch-frame-for-backtrace
    91             (let* ((*debug-in-event-process* nil)
    92                    (context (ccl::new-backtrace-info nil
    93                                                      frame-pointer
    94                                                      (if ccl::*backtrace-contexts*
    95                                                        (or (ccl::child-frame
    96                                                             (ccl::bt.youngest (car ccl::*backtrace-contexts*))
    97                                                             nil)
    98                                                            (ccl::last-frame-ptr))
    99                                                        (ccl::last-frame-ptr))
    100                                                      (ccl::%current-tcr)
    101                                                      condition
    102                                                      (ccl::%current-frame-ptr)
    103                                                      #+ppc-target ccl::*fake-stack-frames*
    104                                                      #+x86-target (ccl::%current-frame-ptr)
    105                                                      (ccl::db-link)
    106                                                      (1+ ccl::*break-level*)))
    107                    (ccl::*backtrace-contexts* (cons context ccl::*backtrace-contexts*))) 
    108               (format t "~%~%*** Error in event process: ~a~%~%" condition)
    109               (print-call-history :context context :detailed-p t :count 20 :origin frame-pointer)
    110               (format t "~%~%~%")
    111               (force-output t)
    112               )))))))
     92        (cond ((slot-value process 'have-interactive-terminal-io)
     93               (ccl::application-error ccl::*application* c frame-pointer))
     94              #+windows-target
     95              ((connect-to-console-window process)
     96               (ccl::application-error ccl::*application* c frame-pointer))
     97              (t
     98               (catch 'need-a-catch-frame-for-backtrace
     99                 (let* ((*debug-in-event-process* nil)
     100                        (context
     101                         (ccl::new-backtrace-info nil
     102                                                  frame-pointer
     103                                                  (if ccl::*backtrace-contexts*
     104                                                      (or (ccl::child-frame
     105                                                           (ccl::bt.youngest
     106                                                            (car ccl::*backtrace-contexts*))
     107                                                           nil)
     108                                                          (ccl::last-frame-ptr))
     109                                                      (ccl::last-frame-ptr))
     110                                                  (ccl::%current-tcr)
     111                                                  condition
     112                                                  (ccl::%current-frame-ptr)
     113                                                  #+ppc-target ccl::*fake-stack-frames*
     114                                                  #+x86-target (ccl::%current-frame-ptr)
     115                                                  (ccl::db-link)
     116                                                  (1+ ccl::*break-level*)))
     117                        (ccl::*backtrace-contexts* (cons context ccl::*backtrace-contexts*))) 
     118                   (format t "~%~%*** Error in event process: ~a~%~%" condition)
     119                   (print-call-history :context context :detailed-p t :count 20
     120                                       :origin frame-pointer)
     121                   (format t "~%~%~%")
     122                   (force-output t)
     123                   ))))))))
     124
     125#+windows-target
     126(defun connect-to-console-window (process)
     127  (when (#_AllocConsole)
     128    (flet ((set-lisp-stream-fd (stream fd)
     129             (setf (ccl::ioblock-device (ccl::stream-ioblock stream t)) fd)))
     130      (let ((input-handle (#_GetStdHandle #$STD_INPUT_HANDLE))
     131            (output-handle (#_GetStdHandle #$STD_OUTPUT_HANDLE)))
     132        (set-lisp-stream-fd ccl::*stdin* (%ptr-to-int input-handle))
     133        (set-lisp-stream-fd ccl::*stdout* (%ptr-to-int output-handle)))
     134    ;; Ensure that output to the stream ccl::*stdout* -
     135    ;; which is connected to fd 1 - is flushed periodically
     136    ;; by the housekeeping task.  (ccl::*stdout* is
     137    ;; typically the output side of the two-way stream
     138    ;; which is the global/static value of *TERMINAL-IO*;
     139    ;; many standard streams are synonym streams to
     140    ;; *TERMINAL-IO*.
     141    (ccl::add-auto-flush-stream ccl::*stdout*)
     142    (setf (slot-value process 'have-interactive-terminal-io) t))))
    113143
    114144
     
    166196         (thread ccl::*current-process*))
    167197    (loop
    168       (if (not (slot-value thread 'have-interactive-terminal-io))
     198      (if (event-loop-can-have-interactive-terminal-io thread)
     199        (with-simple-restart (abort "Process the next event")
     200          (#/run app))
    169201        (let* ((ccl::*break-on-errors* nil))
    170202          (handler-case (let* ((*event-process-reported-conditions* nil))
    171203                          (if end-test
    172204                            (#/run app)
    173                           #|(#/runMode:beforeDate: (#/currentRunLoop ns:ns-run-loop)
    174                           #&NSDefaultRunLoopMode
    175                           (#/distantFuture ns:ns-date))|#
    176                           (#/run app)))
    177             (error (c) (nslog-condition c))))
    178         (with-simple-restart (abort "Process the next event")
    179           (#/run app)))
     205                            #|(#/runMode:beforeDate: (#/currentRunLoop ns:ns-run-loop)
     206                                                     #&NSDefaultRunLoopMode
     207                                                     (#/distantFuture ns:ns-date))|#
     208                            (#/run app)))
     209            (error (c) (nslog-condition c)))))
    180210      #+debug (log-debug "~&runMode exited, end-test: ~s isRunning ~s quitting: ~s" end-test (#/isRunning app) ccl::*quitting*)
    181211      (when (or (and end-test (funcall end-test))
Note: See TracChangeset for help on using the changeset viewer.