From 4cb0dbf938645e555ce380a10e6cb550c2c91b08 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <tunes@google.com> Date: Mon, 11 Nov 2013 13:53:51 -0500 Subject: [PATCH] Don't bind keywords as special variables in restore-image, whether it's valid or not, it confuses SBCL. Remove GCL 2.6 support. --- backward-interface.lisp | 4 ++-- output-translations.lisp | 5 +---- source-registry.lisp | 2 +- uiop/image.lisp | 20 +++++++++++--------- 4 files changed, 15 insertions(+), 16 deletions(-) diff --git a/backward-interface.lisp b/backward-interface.lisp index eec1e5db..30c11cae 100644 --- a/backward-interface.lisp +++ b/backward-interface.lisp @@ -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)) diff --git a/output-translations.lisp b/output-translations.lisp index 004557a3..6905cf5b 100644 --- a/output-translations.lisp +++ b/output-translations.lisp @@ -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) diff --git a/source-registry.lisp b/source-registry.lisp index da6ed0ce..a558ed1f 100644 --- a/source-registry.lisp +++ b/source-registry.lisp @@ -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))) diff --git a/uiop/image.lisp b/uiop/image.lisp index 98484dee..5909d04d 100644 --- a/uiop/image.lisp +++ b/uiop/image.lisp @@ -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))))))) -- GitLab