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

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 @@ ...@@ -40,8 +40,8 @@
(defgeneric operation-on-warnings (operation)) (defgeneric operation-on-warnings (operation))
(defgeneric operation-on-failure (operation)) (defgeneric operation-on-failure (operation))
#-gcl2.6 (defgeneric (setf operation-on-warnings) (x operation)) (defgeneric (setf operation-on-warnings) (x operation))
#-gcl2.6 (defgeneric (setf operation-on-failure) (x operation)) (defgeneric (setf operation-on-failure) (x operation))
(defmethod operation-on-warnings ((o operation)) (defmethod operation-on-warnings ((o operation))
(declare (ignorable o)) *compile-file-warnings-behaviour*) (declare (ignorable o)) *compile-file-warnings-behaviour*)
(defmethod operation-on-failure ((o operation)) (defmethod operation-on-failure ((o operation))
......
...@@ -48,10 +48,7 @@ and the order is by decreasing length of namestring of the source pathname.") ...@@ -48,10 +48,7 @@ and the order is by decreasing length of namestring of the source pathname.")
(let ((directory (pathname-directory (car x)))) (let ((directory (pathname-directory (car x))))
(if (listp directory) (length directory) 0)))))))) (if (listp directory) (length directory) 0))))))))
new-value) new-value)
#-gcl2.6
(defun* ((setf output-translations)) (new-value) (set-output-translations new-value)) (defun* ((setf output-translations)) (new-value) (set-output-translations new-value))
#+gcl2.6
(defsetf output-translations set-output-translations)
(defun output-translations-initialized-p () (defun output-translations-initialized-p ()
(and *output-translations* t)) (and *output-translations* t))
...@@ -211,7 +208,7 @@ and the order is by decreasing length of namestring of the source pathname.") ...@@ -211,7 +208,7 @@ and the order is by decreasing length of namestring of the source pathname.")
(inherit *default-output-translations*) (inherit *default-output-translations*)
collect) collect)
(process-output-translations (funcall x) :inherit inherit :collect 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 (cond
((directory-pathname-p pathname) ((directory-pathname-p pathname)
(process-output-translations (validate-output-translations-directory pathname) (process-output-translations (validate-output-translations-directory pathname)
......
...@@ -219,7 +219,7 @@ system names to pathnames of .asd files") ...@@ -219,7 +219,7 @@ system names to pathnames of .asd files")
(defmethod process-source-registry ((x symbol) &key inherit register) (defmethod process-source-registry ((x symbol) &key inherit register)
(process-source-registry (funcall x) :inherit inherit :register 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 (cond
((directory-pathname-p pathname) ((directory-pathname-p pathname)
(let ((*here-directory* (resolve-symlinks* pathname))) (let ((*here-directory* (resolve-symlinks* pathname)))
......
...@@ -70,7 +70,7 @@ This is designed to abstract away the implementation specific quit forms." ...@@ -70,7 +70,7 @@ This is designed to abstract away the implementation specific quit forms."
#+cormanlisp (win32:exitprocess code) #+cormanlisp (win32:exitprocess code)
#+(or cmu scl) (unix:unix-exit code) #+(or cmu scl) (unix:unix-exit code)
#+ecl (si:quit 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) #+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) #+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) ? #+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." ...@@ -239,10 +239,10 @@ if we are not called from a directly executable image."
(setf *command-line-arguments* (command-line-arguments))) (setf *command-line-arguments* (command-line-arguments)))
(defun restore-image (&key (defun restore-image (&key
((:lisp-interaction *lisp-interaction*) *lisp-interaction*) (lisp-interaction *lisp-interaction*)
((:restore-hook *image-restore-hook*) *image-restore-hook*) (restore-hook *image-restore-hook* restore-hook-p)
((:prelude *image-prelude*) *image-prelude*) (prelude *image-prelude*)
((:entry-point *image-entry-point*) *image-entry-point*) (entry-point *image-entry-point*)
(if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY"))) (if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY")))
"From a freshly restarted Lisp image, restore the saved Lisp environment "From a freshly restarted Lisp image, restore the saved Lisp environment
by setting appropriate variables, running various hooks, and calling any specified entry point." 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 ...@@ -252,14 +252,16 @@ by setting appropriate variables, running various hooks, and calling any specifi
(return-from restore-image))) (return-from restore-image)))
(with-fatal-condition-handler () (with-fatal-condition-handler ()
(setf *image-restored-p* :in-progress) (setf *image-restored-p* :in-progress)
(when restore-hook-p
(setf *image-restore-hook* restore-hook))
(call-image-restore-hook) (call-image-restore-hook)
(standard-eval-thunk *image-prelude*) (standard-eval-thunk prelude)
(setf *image-restored-p* t) (setf *image-restored-p* t)
(let ((results (multiple-value-list (let ((results (multiple-value-list
(if *image-entry-point* (if entry-point
(call-function *image-entry-point*) (call-function entry-point)
t)))) t))))
(if *lisp-interaction* (if lisp-interaction
(apply 'values results) (apply 'values results)
(shell-boolean-exit (first 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