Changeset 12205


Ignore:
Timestamp:
Jun 5, 2009, 6:59:20 PM (10 years ago)
Author:
gz
Message:

Merge r11495, r12082: new options in ccl:quit.

Location:
trunk/source/level-1
Files:
2 edited

Legend:

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

    r11757 r12205  
    643643(defmethod process-exit-application ((process process) thunk)
    644644  (when (eq process *initial-process*)
    645     (prepare-to-quit)
     645    (with-standard-abort-handling "Exit Lisp"
     646      (prepare-to-quit)
     647      (fresh-line *stdout*)
     648      (finish-output *stdout*))
    646649    (%set-toplevel thunk)
    647     (fresh-line *stdout*)
    648     (finish-output *stdout*)
    649650    (toplevel)))
    650651
  • trunk/source/level-1/l1-readloop.lisp

    r12069 r12205  
    108108
    109109
    110 (defun quit (&optional (exit-status 0))
    111   (unless (typep exit-status '(signed-byte 32))
    112     (report-bad-arg exit-status '(signed-byte 32)))
     110(defun quit (&optional (exit 0) &key error-handler)
     111  "exit must be either a (signed-byte 32) exit status or a function to call to exit lisp
     112   error-handler can be a function of one argument, the condition, that will be called if an
     113   error occurs while preparing to quit.  The error handler should exit"
     114  (if (or (null exit) (typep exit '(signed-byte 32)))
     115    (setq exit (let ((exit-status (or exit 0)))
     116                 #'(lambda () (#__exit exit-status))))
     117    (unless (typep exit 'function)
     118      (report-bad-arg exit '(or (signed-byte 32) function))))
    113119  (let* ((ip *initial-process*)
    114120         (cp *current-process*))
     
    116122      (process-interrupt ip
    117123                         #'(lambda ()
    118                              (process-exit-application *current-process*
    119                                                        #'(lambda ()
    120                                                            (%set-toplevel nil)
    121                                                            (#__exit exit-status)))))
     124                             (handler-bind ((error (lambda (c)
     125                                                     (when error-handler
     126                                                       (funcall error-handler c)))))
     127                               (process-exit-application *current-process*
     128                                                         #'(lambda ()
     129                                                             (%set-toplevel nil)
     130                                                             (funcall exit) ;; must exit
     131                                                             (bug "Exit function didn't exit"))))))
    122132      (unless (eq cp ip)
    123133        (process-kill cp)))))
Note: See TracChangeset for help on using the changeset viewer.