Commit 4cb0dbf9 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Don't bind keywords as special variables in restore-image,

whether it's valid or not, it confuses SBCL.
Remove GCL 2.6 support.
parent 9ff9d31a
......@@ -40,8 +40,8 @@
(defgeneric operation-on-warnings (operation))
(defgeneric operation-on-failure (operation))
#-gcl2.6 (defgeneric (setf operation-on-warnings) (x operation))
#-gcl2.6 (defgeneric (setf operation-on-failure) (x operation))
(defgeneric (setf operation-on-warnings) (x operation))
(defgeneric (setf operation-on-failure) (x operation))
(defmethod operation-on-warnings ((o operation))
(declare (ignorable o)) *compile-file-warnings-behaviour*)
(defmethod operation-on-failure ((o operation))
......
......@@ -48,10 +48,7 @@ and the order is by decreasing length of namestring of the source pathname.")
(let ((directory (pathname-directory (car x))))
(if (listp directory) (length directory) 0))))))))
new-value)
#-gcl2.6
(defun* ((setf output-translations)) (new-value) (set-output-translations new-value))
#+gcl2.6
(defsetf output-translations set-output-translations)
(defun output-translations-initialized-p ()
(and *output-translations* t))
......@@ -211,7 +208,7 @@ and the order is by decreasing length of namestring of the source pathname.")
(inherit *default-output-translations*)
collect)
(process-output-translations (funcall x) :inherit inherit :collect collect))
(defmethod process-output-translations ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit collect)
(defmethod process-output-translations ((pathname pathname) &key inherit collect)
(cond
((directory-pathname-p pathname)
(process-output-translations (validate-output-translations-directory pathname)
......
......@@ -219,7 +219,7 @@ system names to pathnames of .asd files")
(defmethod process-source-registry ((x symbol) &key inherit register)
(process-source-registry (funcall x) :inherit inherit :register register))
(defmethod process-source-registry ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit register)
(defmethod process-source-registry ((pathname pathname) &key inherit register)
(cond
((directory-pathname-p pathname)
(let ((*here-directory* (resolve-symlinks* pathname)))
......
......@@ -70,7 +70,7 @@ This is designed to abstract away the implementation specific quit forms."
#+cormanlisp (win32:exitprocess code)
#+(or cmu scl) (unix:unix-exit code)
#+ecl (si:quit code)
#+gcl (#+gcl2.6 lisp:quit #-gcl2.6 system:quit code)
#+gcl (system:quit code)
#+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code)
#+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t)
#+mcl (progn code (ccl:quit)) ;; or should we use FFI to call libc's exit(3) ?
......@@ -239,10 +239,10 @@ if we are not called from a directly executable image."
(setf *command-line-arguments* (command-line-arguments)))
(defun restore-image (&key
((:lisp-interaction *lisp-interaction*) *lisp-interaction*)
((:restore-hook *image-restore-hook*) *image-restore-hook*)
((:prelude *image-prelude*) *image-prelude*)
((:entry-point *image-entry-point*) *image-entry-point*)
(lisp-interaction *lisp-interaction*)
(restore-hook *image-restore-hook* restore-hook-p)
(prelude *image-prelude*)
(entry-point *image-entry-point*)
(if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY")))
"From a freshly restarted Lisp image, restore the saved Lisp environment
by setting appropriate variables, running various hooks, and calling any specified entry point."
......@@ -252,14 +252,16 @@ by setting appropriate variables, running various hooks, and calling any specifi
(return-from restore-image)))
(with-fatal-condition-handler ()
(setf *image-restored-p* :in-progress)
(when restore-hook-p
(setf *image-restore-hook* restore-hook))
(call-image-restore-hook)
(standard-eval-thunk *image-prelude*)
(standard-eval-thunk prelude)
(setf *image-restored-p* t)
(let ((results (multiple-value-list
(if *image-entry-point*
(call-function *image-entry-point*)
(if entry-point
(call-function entry-point)
t))))
(if *lisp-interaction*
(if lisp-interaction
(apply 'values results)
(shell-boolean-exit (first results)))))))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment