Changeset 11450 for trunk/source/level-1


Ignore:
Timestamp:
Dec 2, 2008, 6:11:23 AM (11 years ago)
Author:
gz
Message:

On non-windows platforms, handle SIGTERM by quitting in an orderly fashion. If ccl:*quit-interrupt-hook* is non-nil, it should be a function of no arguments to be invoked before quitting.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-events.lisp

    r10141 r11450  
    118118                            (clear-input *terminal-io*))))))
    119119
    120 
    121 
     120(defglobal *quit-interrupt-hook* nil)
     121
     122(defun force-async-quit ()
     123  (when *quit-interrupt-hook*
     124    (funcall *quit-interrupt-hook*))
     125  (quit 143))
    122126
    123127(defstatic *running-periodic-tasks* nil)
     
    143147             (when (functionp f) (funcall f)))))))
    144148
     149(defconstant $user-interrupt-break 1)
     150(defconstant $user-interrupt-quit 2)
     151
    145152(defun housekeeping ()
    146153  (progn
    147154    (handle-gc-hooks)
    148155    (unless *inhibit-abort*
    149       (when (break-event-pending-p)
    150         (let* ((proc (select-interactive-abort-process)))
    151           (if proc
    152             (force-break-in-listener proc)))))
     156      (let ((id (pending-user-interrupt)))
     157        (cond ((eql id $user-interrupt-quit)
     158               ;; Doesn't matter where it happens, but try to use a process that
     159               ;; has a shot at reporting any problems in user hook.
     160               (let* ((proc (or (select-interactive-abort-process)
     161                                *initial-process*)))
     162                 (process-interrupt proc #'force-async-quit)))
     163              ((eql id $user-interrupt-break)
     164               (let* ((proc (select-interactive-abort-process)))
     165                 (if proc
     166                   (force-break-in-listener proc)))))))
    153167    (flet ((maybe-run-periodic-task (task)
    154168             (let ((now (get-tick-count))
Note: See TracChangeset for help on using the changeset viewer.