Changeset 11450 for trunk/source/level-1

Timestamp:

Dec 2, 2008, 6:11:23 AM (12 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:

• trunk/source/level-1/l1-events.lisp (modified) (2 diffs)

trunk/source/level-1/l1-events.lisp

@@ -118 +118 @@
                             (clear-input *terminal-io*))))))
 
-
-
+(defglobal *quit-interrupt-hook* nil)
+
+(defun force-async-quit ()
+  (when *quit-interrupt-hook*
+    (funcall *quit-interrupt-hook*))
+  (quit 143))
 
 (defstatic *running-periodic-tasks* nil)
@@ -143 +147 @@
              (when (functionp f) (funcall f)))))))
 
+(defconstant $user-interrupt-break 1)
+(defconstant $user-interrupt-quit 2)
+
 (defun housekeeping ()
   (progn
     (handle-gc-hooks)
     (unless *inhibit-abort*
-      (when (break-event-pending-p)
-        (let* ((proc (select-interactive-abort-process)))
-          (if proc
-            (force-break-in-listener proc)))))
+      (let ((id (pending-user-interrupt)))
+        (cond ((eql id $user-interrupt-quit)
+               ;; Doesn't matter where it happens, but try to use a process that
+               ;; has a shot at reporting any problems in user hook.
+               (let* ((proc (or (select-interactive-abort-process)
+                                *initial-process*)))
+                 (process-interrupt proc #'force-async-quit)))
+              ((eql id $user-interrupt-break)
+               (let* ((proc (select-interactive-abort-process)))
+                 (if proc
+                   (force-break-in-listener proc)))))))
     (flet ((maybe-run-periodic-task (task)
              (let ((now (get-tick-count))