diff --git a/code/lispinit.lisp b/code/lispinit.lisp index acf29d31b164f350ffb2412fd1ceae3b9312e289..98f9fd3c6ffc3b979104e543e813e3601822ee9d 100644 --- a/code/lispinit.lisp +++ b/code/lispinit.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/lispinit.lisp,v 1.60 2000/09/14 14:31:52 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/lispinit.lisp,v 1.61 2000/10/16 17:31:47 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -599,16 +599,6 @@ (t (format t "~&Received EOF.~%"))))))))))) -(defun %handled-top-level () - "Wrap %top-level read-eval-print loop in an error handler for *batch-mode*." - (handler-case - (progn - (%top-level) - (quit)) - (error (cond) - (format *error-output* "Error in batch processing:~%~A" cond) - (throw '%end-of-the-world 1)))) - ;;; %Halt -- Interface ;;; diff --git a/code/save.lisp b/code/save.lisp index 8261a16cb7a0d184a5ec6a07851c356bf41bcd68..e74ba3a1633127167ef0fe9e0e1a543ac4a02361 100644 --- a/code/save.lisp +++ b/code/save.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/save.lisp,v 1.37 2000/08/24 19:55:29 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/save.lisp,v 1.38 2000/10/16 17:31:05 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -156,56 +156,59 @@ :environment-name environment-name) #-gencgc (gc) #+gencgc (gc :full t)) (dolist (f *before-save-initializations*) (funcall f)) - (flet - ((restart-lisp () + (labels + ((%restart-lisp () + (with-simple-restart (abort "Skip remaining initializations.") + (catch 'top-level-catcher + (reinit) + (environment-init) + (dolist (f *after-save-initializations*) (funcall f)) + (when process-command-line + (ext::process-command-strings)) + (setf *editor-lisp-p* nil) + (macrolet ((find-switch (name) + `(find ,name *command-line-switches* + :key #'cmd-switch-name + :test #'(lambda (x y) + (declare (simple-string x y)) + (string-equal x y))))) + (when site-init + (load site-init :if-does-not-exist nil :verbose nil)) + (when (and process-command-line (find-switch "edit")) + (setf *editor-lisp-p* t)) + (when (and load-init-file + (not (and process-command-line + (find-switch "noinit")))) + (let* ((cl-switch (find-switch "init")) + (name (and cl-switch + (or (cmd-switch-value cl-switch) + (car (cmd-switch-words cl-switch)))))) + (if name + (load (merge-pathnames name #p"home:") + :if-does-not-exist nil) + (or (load "home:init" :if-does-not-exist nil) + (load "home:.cmucl-init" + :if-does-not-exist nil)))))) + (when process-command-line + (ext::invoke-switch-demons *command-line-switches* + *command-switch-demons*)) + (when print-herald + (print-herald)))) + (funcall init-function)) + (restart-lisp () (unix:unix-exit (catch '%end-of-the-world (unwind-protect - (progn - (with-simple-restart (abort "Skip remaining initializations.") - (catch 'top-level-catcher - (reinit) - (environment-init) - (dolist (f *after-save-initializations*) (funcall f)) - (when process-command-line - (ext::process-command-strings)) - (setf *editor-lisp-p* nil) - (macrolet ((find-switch (name) - `(find ,name *command-line-switches* - :key #'cmd-switch-name - :test #'(lambda (x y) - (declare (simple-string x y)) - (string-equal x y))))) - (when site-init - (load site-init :if-does-not-exist nil :verbose nil)) - (when (and process-command-line (find-switch "edit")) - (setf *editor-lisp-p* t)) - (when (and load-init-file - (not (and process-command-line - (find-switch "noinit")))) - (let* ((cl-switch (find-switch "init")) - (name (and cl-switch - (or (cmd-switch-value cl-switch) - (car (cmd-switch-words - cl-switch)))))) - (if name - (load (merge-pathnames name #p"home:") - :if-does-not-exist nil) - (or (load "home:init" :if-does-not-exist nil) - (load "home:.cmucl-init" - :if-does-not-exist nil)))))) - (when process-command-line - (ext::invoke-switch-demons *command-line-switches* - *command-switch-demons*)) - (when print-herald - (print-herald)))) - (funcall (if (and *batch-mode* - (eq init-function #'%top-level)) - #'%handled-top-level - init-function))) + (if *batch-mode* + (handler-case + (%restart-lisp) + (error (cond) + (format *error-output* "Error in batch processing:~%~A" + cond) + (throw '%end-of-the-world 1))) + (%restart-lisp)) (finish-standard-output-streams)))))) - (let ((initial-function (get-lisp-obj-address #'restart-lisp))) (without-gcing (save (unix-namestring core-file-name nil) initial-function))))