Commit 896ceedf authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Fix upgrade on clisp on ecl

Get rid of undefined-function and any clisp or ecl specific code in it in
uiop/utility as well as of a lingering #-clisp in asdf/upgrade. Whatever
issues previous generations of upgrade code tried to address, they happily
do not apply today.

Update test-sysdef-asdf to better test asdf self-upgrade.
parent 90b32a83
...@@ -22,9 +22,9 @@ ...@@ -22,9 +22,9 @@
)) ))
(in-package :asdf/output-translations) (in-package :asdf/output-translations)
;; (setf output-translations) at some point used to be a macro for the sake of ;; (setf output-translations) between 2.27 and 3.0.3 was using a defsetf macro
;; obsolete versions of GCL. Make sure that macro doesn't come to haunt us. ;; for the sake of obsolete versions of GCL 2.6. Make sure it doesn't come to haunt us.
(when-upgrading () (undefine-function '(setf output-translations))) (when-upgrading (:version "3.1.2") (fmakunbound '(setf output-translations)))
(with-upgradability () (with-upgradability ()
(define-condition invalid-output-translation (invalid-configuration warning) (define-condition invalid-output-translation (invalid-configuration warning)
......
...@@ -51,11 +51,13 @@ ...@@ -51,11 +51,13 @@
;; But if we cheat on our version, that should work ;; But if we cheat on our version, that should work
(setf asdf::*asdf-version* "3.0") (setf asdf::*asdf-version* "3.0")
(clear-system "asdf") (clear-system "asdf")
(defparameter *count* 0) (def-test-system "fooey")
(defmethod input-files :after ((load-op operation) (c system)) (defparameter *ticks* 0)
(incf *count*)) (defun tick () (incf *ticks*))
(defmethod input-files :after ((load-op operation) (c system)) (tick))
(input-files 'load-op "asdf") (input-files 'load-op "asdf")
(assert-equal *count* 3) (assert-equal *ticks* 3)
(assert (find-system "fooey" nil))
(with-expected-failure (#+xcl t) (with-expected-failure (#+xcl t)
;; expected-failure: XCL has trouble with the ASDF upgrade ;; expected-failure: XCL has trouble with the ASDF upgrade
(load-system :asdf) (load-system :asdf)
...@@ -63,29 +65,35 @@ ...@@ -63,29 +65,35 @@
(system-source-file (find-system :asdf)))) (system-source-file (find-system :asdf))))
;; Upgrading from an old-enough version redefined away the input-files method! ;; Upgrading from an old-enough version redefined away the input-files method!
(setf *count* 4) (setf *ticks* 4)
(input-files 'load-op "asdf") (input-files 'load-op "asdf")
(assert-equal *count* 4) (assert-equal *ticks* 4)
;; It also cleared away previously defined systems
(assert (not (find-system "fooey" nil)))
;; The data-punting upgrade will mess up component identity, so clear the cache ;; The data-punting upgrade will mess up component identity, so clear the cache
(clear-cache) (clear-cache)
(setf asdf::*asdf-version* asdf/upgrade::*oldest-forward-compatible-asdf-version*) (setf asdf::*asdf-version* asdf/upgrade::*oldest-forward-compatible-asdf-version*)
(clear-system "asdf") (clear-system "asdf")
(setf *count* 5) (def-test-system "fooey")
(setf *ticks* 5)
(defmethod input-files :after ((load-op operation) (c system)) (defmethod input-files :after ((load-op operation) (c system))
(incf *count*)) (incf *ticks*))
(input-files 'load-op "uiop") (input-files 'load-op "uiop")
(assert-equal *count* 8) (assert-equal *ticks* 8)
(with-expected-failure (#+xcl t) (with-expected-failure (#+xcl t)
;; expected-failure: XCL has trouble with the ASDF upgrade ;; expected-failure: XCL has trouble with the ASDF upgrade
(load-system :asdf)) (load-system :asdf))
;; Upgrading from an recent-enough version, the input-files method was preserved! ;; Upgrading from a recent-enough version, the input-files method was preserved!
;; But we need to clear the cache for it not to be short-circuited. ;; But we need to clear the cache for it not to be short-circuited.
(clear-cache) (clear-cache)
(setf *count* 9) (assert (find-system "fooey" nil))
(input-files 'load-op "uiop")
(assert-equal *count* 12) (setf *ticks* 9)
(eval '(input-files 'load-op "uiop"))
(assert-equal *ticks* 12)
;;; disabling this test on windows since it relies on running make-asdf.bat, which ;;; disabling this test on windows since it relies on running make-asdf.bat, which
;;; does not work for me under cygwin. - rpg 2016-03-20 ;;; does not work for me under cygwin. - rpg 2016-03-20
......
...@@ -12,7 +12,7 @@ ...@@ -12,7 +12,7 @@
;; magic helper to define debugging functions: ;; magic helper to define debugging functions:
#:uiop-debug #:load-uiop-debug-utility #:*uiop-debug-utility* #:uiop-debug #:load-uiop-debug-utility #:*uiop-debug-utility*
#:with-upgradability ;; (un)defining functions in an upgrade-friendly way #:with-upgradability ;; (un)defining functions in an upgrade-friendly way
#:undefine-function #:undefine-functions #:defun* #:defgeneric* #:defun* #:defgeneric*
#:nest #:if-let ;; basic flow control #:nest #:if-let ;; basic flow control
#:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists #:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists
#:remove-plist-keys #:remove-plist-key ;; plists #:remove-plist-keys #:remove-plist-key ;; plists
...@@ -43,24 +43,6 @@ ...@@ -43,24 +43,6 @@
;; even if the signature and/or generic-ness of the function has changed. ;; even if the signature and/or generic-ness of the function has changed.
;; For a generic function, this invalidates any previous DEFMETHOD. ;; For a generic function, this invalidates any previous DEFMETHOD.
(eval-when (:load-toplevel :compile-toplevel :execute) (eval-when (:load-toplevel :compile-toplevel :execute)
(defun undefine-function (function-spec)
(cond
((symbolp function-spec)
;; undefining the previous function is the portable way
;; of overriding any incompatible previous gf,
;; but CLISP needs extra help with getting rid of previous methods.
#+clisp
(let ((f (and (fboundp function-spec) (fdefinition function-spec))))
(when (typep f 'clos:standard-generic-function)
(loop :for m :in (clos:generic-function-methods f)
:do (remove-method f m))))
(fmakunbound function-spec))
((and (consp function-spec) (eq (car function-spec) 'setf)
(consp (cdr function-spec)) (null (cddr function-spec)))
(fmakunbound function-spec))
(t (error "bad function spec ~S" function-spec))))
(defun undefine-functions (function-spec-list)
(map () 'undefine-function function-spec-list))
(macrolet (macrolet
((defdef (def* def) ((defdef (def* def)
`(defmacro ,def* (name formals &rest rest) `(defmacro ,def* (name formals &rest rest)
...@@ -72,8 +54,8 @@ ...@@ -72,8 +54,8 @@
`(progn `(progn
;; We usually try to do it only for the functions that need it, ;; We usually try to do it only for the functions that need it,
;; which happens in asdf/upgrade - however, for ECL, we need this hammer. ;; which happens in asdf/upgrade - however, for ECL, we need this hammer.
,@(when (or supersede #+(or clasp ecl) t) ,@(when supersede
`((undefine-function ',name))) `((fmakunbound ',name)))
,@(when (and #+(or clasp ecl) (symbolp name)) ; fails for setf functions on ecl ,@(when (and #+(or clasp ecl) (symbolp name)) ; fails for setf functions on ecl
`((declaim (notinline ,name)))) `((declaim (notinline ,name))))
(,',def ,name ,formals ,@rest)))))) (,',def ,name ,formals ,@rest))))))
......
...@@ -123,11 +123,10 @@ previously-loaded version of ASDF." ...@@ -123,11 +123,10 @@ previously-loaded version of ASDF."
;; with the old ASDF during upgrade, and many implementations bork ;; with the old ASDF during upgrade, and many implementations bork
'((#:compile-concatenated-source-op (#:operation) ())))) '((#:compile-concatenated-source-op (#:operation) ()))))
(loop :for name :in redefined-functions (loop :for name :in redefined-functions
:for sym = (find-symbol* name :asdf nil) :do :for sym = (find-symbol* name :asdf nil)
(when sym :do (when sym (fmakunbound sym)))
;; CLISP seemingly can't fmakunbound and define a function in the same fasl. Sigh. (labels ((asym (x) (multiple-value-bind (s p)
#-clisp (fmakunbound sym))) (if (consp x) (values (car x) (cadr x)) (values x :asdf))
(labels ((asym (x) (multiple-value-bind (s p) (if (consp x) (values (car x) (cadr x)) (values x :asdf))
(find-symbol* s p nil))) (find-symbol* s p nil)))
(asyms (l) (mapcar #'asym l))) (asyms (l) (mapcar #'asym l)))
(loop* :for (name superclasses slots) :in redefined-classes (loop* :for (name superclasses slots) :in redefined-classes
......
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