Skip to content
Snippets Groups Projects
Commit 15fd349b authored by dtc's avatar dtc
Browse files

When in batch mode, exit upon errors, even during initialisation.

parent 818aa89a
No related branches found
No related tags found
No related merge requests found
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -599,16 +599,6 @@
(t (t
(format t "~&Received EOF.~%"))))))))))) (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 ;;; %Halt -- Interface
;;; ;;;
......
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -156,56 +156,59 @@
:environment-name environment-name) :environment-name environment-name)
#-gencgc (gc) #+gencgc (gc :full t)) #-gencgc (gc) #+gencgc (gc :full t))
(dolist (f *before-save-initializations*) (funcall f)) (dolist (f *before-save-initializations*) (funcall f))
(flet (labels
((restart-lisp () ((%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 (unix:unix-exit
(catch '%end-of-the-world (catch '%end-of-the-world
(unwind-protect (unwind-protect
(progn (if *batch-mode*
(with-simple-restart (abort "Skip remaining initializations.") (handler-case
(catch 'top-level-catcher (%restart-lisp)
(reinit) (error (cond)
(environment-init) (format *error-output* "Error in batch processing:~%~A"
(dolist (f *after-save-initializations*) (funcall f)) cond)
(when process-command-line (throw '%end-of-the-world 1)))
(ext::process-command-strings)) (%restart-lisp))
(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)))
(finish-standard-output-streams)))))) (finish-standard-output-streams))))))
(let ((initial-function (get-lisp-obj-address #'restart-lisp))) (let ((initial-function (get-lisp-obj-address #'restart-lisp)))
(without-gcing (without-gcing
(save (unix-namestring core-file-name nil) initial-function)))) (save (unix-namestring core-file-name nil) initial-function))))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment