From c1652787329e1b3086bdaef6fca5bf5932fa292a Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <tunes@google.com> Date: Fri, 22 May 2015 22:33:33 -0400 Subject: [PATCH] Support for notification that some functions are deprecated. Deprecation goes through the following phases: style-warning, warning, cerror, functionality removed. Automatically upgrade the deprecation phase at every minor version change (not every release). Include minimal testing of the deprecation functionality. Add deprecation TODO items. Deprecation will start with 3.2. --- Makefile | 2 +- TODO | 11 +++ action.lisp | 20 ++-- backward-interface.lisp | 181 ++++++++++++++++++----------------- backward-internals.lisp | 2 +- bin/bump-version | 4 +- bundle.lisp | 2 +- footer.lisp | 4 +- make-asdf.bat | 2 +- make-asdf.sh | 2 +- test/script-support.lisp | 24 +++-- test/test-deprecation.script | 68 +++++++++++++ tools/version.lisp | 2 +- uiop/backward-driver.lisp | 46 ++++++--- uiop/driver.lisp | 2 +- uiop/run-program.lisp | 2 +- uiop/uiop.asd | 12 +-- uiop/utility.lisp | 98 +++++++++---------- uiop/version.lisp | 181 +++++++++++++++++++++++++++++++++++ uiop/version.lisp-expr | 2 - upgrade.lisp | 8 +- 21 files changed, 484 insertions(+), 191 deletions(-) create mode 100644 test/test-deprecation.script create mode 100644 uiop/version.lisp delete mode 100644 uiop/version.lisp-expr diff --git a/Makefile b/Makefile index 7b85d790b..9f80d2eb0 100644 --- a/Makefile +++ b/Makefile @@ -78,7 +78,7 @@ SCL ?= scl XCL ?= xcl header_lisp := header.lisp -driver_lisp := uiop/package.lisp uiop/common-lisp.lisp uiop/utility.lisp uiop/os.lisp uiop/pathname.lisp uiop/filesystem.lisp uiop/stream.lisp uiop/image.lisp uiop/lisp-build.lisp uiop/launch-program.lisp uiop/run-program.lisp uiop/configuration.lisp uiop/backward-driver.lisp uiop/driver.lisp +driver_lisp := uiop/package.lisp uiop/common-lisp.lisp uiop/utility.lisp uiop/version.lisp uiop/os.lisp uiop/pathname.lisp uiop/filesystem.lisp uiop/stream.lisp uiop/image.lisp uiop/lisp-build.lisp uiop/launch-program.lisp uiop/run-program.lisp uiop/configuration.lisp uiop/backward-driver.lisp uiop/driver.lisp defsystem_lisp := upgrade.lisp cache.lisp component.lisp system.lisp find-system.lisp find-component.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp parse-defsystem.lisp bundle.lisp concatenate-source.lisp output-translations.lisp source-registry.lisp package-inferred-system.lisp backward-interface.lisp backward-internals.lisp interface.lisp user.lisp footer.lisp all_lisp := $(header_lisp) $(driver_lisp) $(defsystem_lisp) diff --git a/TODO b/TODO index 28dc717eb..1899bc60b 100644 --- a/TODO +++ b/TODO @@ -453,3 +453,14 @@ It looks like SWANK can be fixed soon, though, so we'll see. but instead store the name of these directories, so these files will be read recursively by asdf, allowing for semi-modular updates. + +* Properly deprecate all that needs to go +** Get lisa, readable, bourbaki to NOT include ASDF 1 anymore in their sources. +** Identify all the things in ASDF that we want to deprecate, and make + sure we deprecate them all in 3.2. +** Implement support for deprecating old packages, + by having all functions and macros under the old package name be + proxies to those in the new package name? + (Exception: special variables can't be proxies, have to be imported.) +** Eradicate Quicklisp systems that depend on asdf-driver or + asdf-package-system, make them depend on uiop and asdf3.1 instead. diff --git a/action.lisp b/action.lisp index a6702345a..36895cac2 100644 --- a/action.lisp +++ b/action.lisp @@ -258,15 +258,23 @@ The class needs to be updated for ASDF 3.1 and specify appropriate propagation m :format-arguments (list (type-of o))))) + (with-asdf-deprecation (:style-warning "3.2") + (defun backward-compatible-depends-on (o c) + "DEPRECATED: all subclasses of OPERATION used in ASDF should inherit from one of + DOWNWARD-OPERATION UPWARD-OPERATION SIDEWAY-OPERATION SELFWARD-OPERATION NON-PROPAGATING-OPERATION. + The function BACKWARD-COMPATIBLE-DEPENDS-ON temporarily provides ASDF2 behaviour for those that + don't. In the future this functionality will be removed, and the default will be no propagation." + `(,@(sideway-operation-depends-on o c) + ,@(when (typep c 'parent-component) (downward-operation-depends-on o c))))) + (defmethod component-depends-on ((o operation) (c component)) `(;; Normal behavior, to allow user-specified in-order-to dependencies ,@(cdr (assoc (type-of o) (component-in-order-to c))) - ;; For backward-compatibility with ASDF2, any operation that doesn't specify propagation - ;; or non-propagation through an appropriate mixin will be downward and sideway. - ,@(unless (typep o '(or downward-operation upward-operation sideway-operation - selfward-operation non-propagating-operation)) - `(,@(sideway-operation-depends-on o c) - ,@(when (typep c 'parent-component) (downward-operation-depends-on o c)))))) + ;; For backward-compatibility with ASDF2, any operation that doesn't specify propagation + ;; or non-propagation through an appropriate mixin will be downward and sideway. + ,@(unless (typep o '(or downward-operation upward-operation sideway-operation + selfward-operation non-propagating-operation)) + (backward-compatible-depends-on o c)))) (defmethod downward-operation ((o operation)) nil) (defmethod sideway-operation ((o operation)) nil)) diff --git a/backward-interface.lisp b/backward-interface.lisp index d5e92ec10..9a0959e3b 100644 --- a/backward-interface.lisp +++ b/backward-interface.lisp @@ -19,29 +19,37 @@ #:explain)) (in-package :asdf/backward-interface) -(with-upgradability () +;; NB: the warning status of these functions may have to be distinguished later, +;; as some get removed faster than the others in client code. +(with-asdf-deprecation (:style-warning "3.2") + ;; These conditions from ASDF 1 and 2 are used by many packages in Quicklisp; ;; but ASDF3 replaced them with somewhat different variants of uiop:compile-condition ;; that do not involve ASDF actions. ;; TODO: find the offenders and stop them. - (define-condition operation-error (error) ;; Bad, backward-compatible name - ;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel - ((component :reader error-component :initarg :component) - (operation :reader error-operation :initarg :operation)) - (:report (lambda (c s) - (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>") - (type-of c) (error-operation c) (error-component c))))) - (define-condition compile-error (operation-error) ()) - (define-condition compile-failed (compile-error) ()) - (define-condition compile-warned (compile-error) ()) - - (defun component-load-dependencies (component) - "DEPRECATED. Please use COMPONENT-SIDEWAY-DEPENDENCIES instead." + (progn + (define-condition operation-error (error) ;; Bad, backward-compatible name + ;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel + ((component :reader error-component :initarg :component) + (operation :reader error-operation :initarg :operation)) + (:report (lambda (c s) + (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>") + (type-of c) (error-operation c) (error-component c))))) + (define-condition compile-error (operation-error) ()) + (define-condition compile-failed (compile-error) ()) + (define-condition compile-warned (compile-error) ())) + + ;; In Quicklisp 2015-05, still used by lisp-executable, staple, repl-utilities, cffi + (defun component-load-dependencies (component) ;; from ASDF 2.000 to 2.26 + "DEPRECATED. Please use COMPONENT-SIDEWAY-DEPENDENCIES instead; or better, +define your operations with proper use of SIDEWAY-OPERATION, SELFWARD-OPERATION, +or define methods on PREPARE-OP, etc." ;; Old deprecated name for the same thing. Please update your software. (component-sideway-dependencies component)) ;; These old interfaces from ASDF1 have never been very meaningful ;; but are still used in obscure places. + ;; In Quicklisp 2015-05, still used by cl-protobufs and clx. (defgeneric operation-on-warnings (operation) (:documentation "DEPRECATED. Please use UIOP:*COMPILE-FILE-WARNINGS-BEHAVIOUR* instead.")) (defgeneric operation-on-failure (operation) @@ -50,19 +58,23 @@ (:documentation "DEPRECATED. Please SETF UIOP:*COMPILE-FILE-WARNINGS-BEHAVIOUR* instead.")) (defgeneric (setf operation-on-failure) (x operation) (:documentation "DEPRECATED. Please SETF UIOP:*COMPILE-FILE-FAILURE-BEHAVIOUR* instead.")) - (defmethod operation-on-warnings ((o operation)) - *compile-file-warnings-behaviour*) - (defmethod operation-on-failure ((o operation)) - *compile-file-failure-behaviour*) - (defmethod (setf operation-on-warnings) (x (o operation)) - (setf *compile-file-warnings-behaviour* x)) - (defmethod (setf operation-on-failure) (x (o operation)) - (setf *compile-file-failure-behaviour* x)) - + (progn + (defmethod operation-on-warnings ((o operation)) + *compile-file-warnings-behaviour*) + (defmethod operation-on-failure ((o operation)) + *compile-file-failure-behaviour*) + (defmethod (setf operation-on-warnings) (x (o operation)) + (setf *compile-file-warnings-behaviour* x)) + (defmethod (setf operation-on-failure) (x (o operation)) + (setf *compile-file-failure-behaviour* x))) + + ;; Quicklisp 2015-05: Still used by SLIME's swank-asdf (!), common-lisp-stat, + ;; js-parser, osicat, babel, staple, weblocks, cl-png, plain-odbc, autoproject, + ;; cl-blapack, com.informatimago, cells-gtk3, asdf-dependency-grovel, + ;; cl-glfw, cffi, jwacs, montezuma (defun system-definition-pathname (x) ;; As of 2.014.8, we mean to make this function obsolete, ;; but that won't happen until all clients have been updated. - ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead" "DEPRECATED. This function used to expose ASDF internals with subtle differences with respect to user expectations, that have been refactored away since. We recommend you use ASDF:SYSTEM-SOURCE-FILE instead for a @@ -71,69 +83,72 @@ ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME if that's whay you mean." ;;) (system-source-file x)) - ;; TRAVERSE is the function used to compute a plan in ASDF 1 and 2. ;; It was never officially exposed but some people still used it. (defgeneric traverse (operation component &key &allow-other-keys) (:documentation - "Generate and return a plan for performing OPERATION on COMPONENT. + "DEPRECATED. Use MAKE-PLAN and PLAN-ACTIONS, or REQUIRED-COMPONENTS, +or some other supported interface instead. + +Generate and return a plan for performing OPERATION on COMPONENT. The plan returned is a list of dotted-pairs. Each pair is the CONS of ASDF operation object and a COMPONENT object. The pairs will be processed in order by OPERATE.")) - (define-convenience-action-methods traverse (operation component &key)) - + (progn + (define-convenience-action-methods traverse (operation component &key))) (defmethod traverse ((o operation) (c component) &rest keys &key plan-class &allow-other-keys) - (plan-actions (apply 'make-plan plan-class o c keys)))) + (plan-actions (apply 'make-plan plan-class o c keys))) -;;;; ASDF-Binary-Locations compatibility -;; This remains supported for legacy user, but not recommended for new users. -;; We suspect there are no more legacy users in 2016. -(with-upgradability () + ;; ASDF-Binary-Locations compatibility + ;; This remains supported for legacy user, but not recommended for new users. + ;; We suspect there are no more legacy users in 2016. (defun enable-asdf-binary-locations-compatibility (&key - (centralize-lisp-binaries nil) - (default-toplevel-directory - (subpathname (user-homedir-pathname) ".fasls/")) ;; Use ".cache/common-lisp/" instead ??? - (include-per-user-information nil) - (map-all-source-files (or #+(or clasp clisp ecl mkcl) t nil)) - (source-to-target-mappings nil) - (file-types `(,(compile-file-type) - "build-report" - #+clasp (compile-file-type :output-type :object) - #+ecl (compile-file-type :type :object) - #+mkcl (compile-file-type :fasl-p nil) - #+clisp "lib" #+sbcl "cfasl" - #+sbcl "sbcl-warnings" #+clozure "ccl-warnings"))) + (centralize-lisp-binaries nil) + (default-toplevel-directory + ;; Use ".cache/common-lisp/" instead ??? + (subpathname (user-homedir-pathname) ".fasls/")) + (include-per-user-information nil) + (map-all-source-files (or #+(or clasp clisp ecl mkcl) t nil)) + (source-to-target-mappings nil) + (file-types `(,(compile-file-type) + "build-report" + #+clasp (compile-file-type :output-type :object) + #+ecl (compile-file-type :type :object) + #+mkcl (compile-file-type :fasl-p nil) + #+clisp "lib" #+sbcl "cfasl" + #+sbcl "sbcl-warnings" #+clozure "ccl-warnings"))) + "DEPRECATED. Use asdf-output-translations instead." #+(or clasp clisp ecl mkcl) (when (null map-all-source-files) (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL")) (let* ((patterns (if map-all-source-files (list *wild-file*) (loop :for type :in file-types - :collect (make-pathname :type type :defaults *wild-file*)))) + :collect (make-pathname :type type :defaults *wild-file*)))) (destination-directory - (if centralize-lisp-binaries - `(,default-toplevel-directory - ,@(when include-per-user-information - (cdr (pathname-directory (user-homedir-pathname)))) - :implementation ,*wild-inferiors*) - `(:root ,*wild-inferiors* :implementation)))) + (if centralize-lisp-binaries + `(,default-toplevel-directory + ,@(when include-per-user-information + (cdr (pathname-directory (user-homedir-pathname)))) + :implementation ,*wild-inferiors*) + `(:root ,*wild-inferiors* :implementation)))) (initialize-output-translations `(:output-translations ,@source-to-target-mappings #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) #+abcl (#p"/___jar___file___root___/**/*.*" (,@destination-directory)) ,@(loop :for pattern :in patterns - :collect `((:root ,*wild-inferiors* ,pattern) - (,@destination-directory ,pattern))) + :collect `((:root ,*wild-inferiors* ,pattern) + (,@destination-directory ,pattern))) (t t) :ignore-inherited-configuration)))) - - (defmethod operate :before (operation-class system &rest args &key &allow-other-keys) - (declare (ignore operation-class system args)) - (when (find-symbol* '#:output-files-for-system-and-operation :asdf nil) - (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using. + (progn + (defmethod operate :before (operation-class system &rest args &key &allow-other-keys) + (declare (ignore operation-class system args)) + (when (find-symbol* '#:output-files-for-system-and-operation :asdf nil) + (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using. ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS, which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS, and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details. @@ -143,39 +158,32 @@ ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual; call that function where you would otherwise have loaded and configured A-B-L.")))) -;;; run-shell-command -;; WARNING! The function below is not just deprecated but also dysfunctional. -;; Please use asdf/run-program:run-program instead. -(with-upgradability () + ;; run-shell-command from ASDF 2, lightly fixed from ASDF 1, copied from MK-DEFSYSTEM. Die! (defun run-shell-command (control-string &rest args) - "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and -synchronously execute the result using a Bourne-compatible shell, with -output to *VERBOSE-OUT*. Returns the shell's exit code. - -PLEASE DO NOT USE. -Deprecated function, for backward-compatibility only. + "PLEASE DO NOT USE. This function is not just DEPRECATED, but also dysfunctional. Please use UIOP:RUN-PROGRAM instead." #-(and ecl os-windows) (let ((command (apply 'format nil control-string args))) (asdf-message "; $ ~A~%" command) (let ((exit-code - (ignore-errors + (ignore-errors (nth-value 2 (run-program command :force-shell t :ignore-error-status t - :output *verbose-out*))))) + :output *verbose-out*))))) (typecase exit-code ((integer 0 255) exit-code) (t 255)))) #+(and ecl os-windows) - (not-implemented-error "run-shell-command" "for ECL on Windows.") - )) - - -(with-upgradability () - (defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused. + (not-implemented-error "run-shell-command" "for ECL on Windows.")) + ;; HOW do we get rid of variables??? With a symbol-macro that issues a warning? + ;; In Quicklisp 2015-05, cl-protobufs still uses it, but that should be fixed in next version. + (progn + (defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused. -;;; backward-compatibility methods. Do NOT use in new code. NOT SUPPORTED. -(with-upgradability () + ;; Do NOT use in new code. NOT SUPPORTED. + ;; NB: When this goes away, remove the slot PROPERTY in COMPONENT. + ;; In Quicklisp 2014-05, it's still used by yaclml, amazon-ecs, blackthorn-engine, cl-tidy. + ;; See TODO for further cleanups required before to get rid of it. (defgeneric component-property (component property)) (defgeneric (setf component-property) (new-value component property)) @@ -188,16 +196,15 @@ Please use UIOP:RUN-PROGRAM instead." (setf (cdr a) new-value) (setf (slot-value c 'properties) (acons property new-value (slot-value c 'properties))))) - new-value)) + new-value) -;;; This method survives from ASDF 1, but really it is superseded by action-description. -(with-upgradability () + ;; This method survives from ASDF 1, but really it is superseded by action-description. (defgeneric explain (operation component) (:documentation "Display a message describing an action. + DEPRECATED. Use ASDF:ACTION-DESCRIPTION and/or ASDF::FORMAT-ACTION instead.")) + (progn + (define-convenience-action-methods explain (operation component))) (defmethod explain ((o operation) (c component)) - (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (action-description o c))) - (define-convenience-action-methods explain (operation component))) - - + (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (action-description o c)))) diff --git a/backward-internals.lisp b/backward-internals.lisp index 23274b8c9..ac178336c 100644 --- a/backward-internals.lisp +++ b/backward-internals.lisp @@ -7,7 +7,7 @@ (:export #:load-sysdef)) (in-package :asdf/backward-internals) -(with-upgradability () +(with-asdf-deprecation (:style-warning "3.2") (defun load-sysdef (name pathname) (declare (ignore name pathname)) ;; Needed for backward compatibility with swank-asdf from SLIME 2015-12-01 or older. diff --git a/bin/bump-version b/bin/bump-version index b8342c158..d61faeb8b 100755 --- a/bin/bump-version +++ b/bin/bump-version @@ -23,7 +23,7 @@ our $file = $asdf_dir . "version.lisp-expr"; our @transform_ref = ( [ "version.lisp-expr", "\"", "\"" ], - [ "uiop/version.lisp-expr", "\"", "\"" ], + [ "uiop/version.lisp", "(defparameter *uiop-version* \"", "\")" ], [ "asdf.asd", " :version \"", "\" ;; to be automatically updated by make bump-version" ], [ "header.lisp", "This is ASDF ", ": Another System Definition Facility." ], [ "upgrade.lisp", "\\(asdf-version \"", "\"\\)" ], @@ -70,7 +70,7 @@ sub transform_files { my $regex = "(" . $entry[1] . ")" . "(([0-9]+\.)+[0-9]+)" . "(" . $entry[2] .")"; my $filename = $asdf_dir . $file; my $data = read_text($filename); - my $count = ($data =~ s/$regex/$1$new$4/); + my $count = ($data =~ s/$regex/$1$new$4/g); if ($count == 0) { die "Unable to replace $regex with $1$new$4"; } diff --git a/bundle.lisp b/bundle.lisp index 0406c2951..dedc27997 100644 --- a/bundle.lisp +++ b/bundle.lisp @@ -291,7 +291,7 @@ or of opaque libraries shipped along the source code.")) ;;; a FASL, a statically linked library, a shared library, etc. ;;; The different targets are defined by specialization. ;;; -(when-upgrading (:version "3.1.9") +(when-upgrading (:version "3.2.0") ;; Cancel any previously defined method (defmethod initialize-instance :after ((instance bundle-op) &rest initargs &key &allow-other-keys) (declare (ignore initargs)))) diff --git a/footer.lisp b/footer.lisp index 75ce19a0b..0b0adffce 100644 --- a/footer.lisp +++ b/footer.lisp @@ -16,9 +16,9 @@ ;;;; Register ASDF itself and all its subsystems as preloaded. (with-upgradability () - (dolist (s '("asdf" "uiop" "asdf-defsystem" "asdf-package-system")) + (dolist (s '("asdf" "uiop" "asdf-package-system")) ;; Don't bother with these system names, no one relies on them anymore: - ;; "asdf-utils" "asdf-bundle" "asdf-driver" + ;; "asdf-utils" "asdf-bundle" "asdf-driver" "asdf-defsystem" (register-preloaded-system s :version *asdf-version*))) diff --git a/make-asdf.bat b/make-asdf.bat index 56506d98f..321ed65f8 100644 --- a/make-asdf.bat +++ b/make-asdf.bat @@ -4,7 +4,7 @@ set here=%~dp0 set header_lisp=header.lisp -set driver_lisp=uiop\package.lisp + uiop\common-lisp.lisp + uiop\utility.lisp + uiop\os.lisp + uiop\pathname.lisp + uiop\filesystem.lisp + uiop\stream.lisp + uiop\image.lisp + uiop\lisp-build.lisp + uiop\launch-program.lisp + uiop\run-program.lisp + uiop\configuration.lisp + uiop\backward-driver.lisp + uiop\driver.lisp +set driver_lisp=uiop\package.lisp + uiop\common-lisp.lisp + uiop\utility.lisp + uiop\version.lisp + uiop\os.lisp + uiop\pathname.lisp + uiop\filesystem.lisp + uiop\stream.lisp + uiop\image.lisp + uiop\lisp-build.lisp + uiop\launch-program.lisp + uiop\run-program.lisp + uiop\configuration.lisp + uiop\backward-driver.lisp + uiop\driver.lisp set defsystem_lisp=upgrade.lisp + cache.lisp + component.lisp + system.lisp + find-system.lisp + find-component.lisp + operation.lisp + action.lisp + lisp-action.lisp + plan.lisp + operate.lisp + parse-defsystem.lisp + bundle.lisp + concatenate-source.lisp + output-translations.lisp + source-registry.lisp + package-inferred-system.lisp + backward-interface.lisp + backward-internals.lisp + interface.lisp + user.lisp + footer.lisp %~d0 diff --git a/make-asdf.sh b/make-asdf.sh index 1ec22de6d..2a894a916 100755 --- a/make-asdf.sh +++ b/make-asdf.sh @@ -5,7 +5,7 @@ here="$(dirname $0)" header_lisp="header.lisp" -driver_lisp="uiop/package.lisp uiop/common-lisp.lisp uiop/utility.lisp uiop/os.lisp uiop/pathname.lisp uiop/filesystem.lisp uiop/stream.lisp uiop/image.lisp uiop/lisp-build.lisp uiop/launch-program.lisp uiop/run-program.lisp uiop/configuration.lisp uiop/backward-driver.lisp uiop/driver.lisp" +driver_lisp="uiop/package.lisp uiop/common-lisp.lisp uiop/utility.lisp uiop/version.lisp uiop/os.lisp uiop/pathname.lisp uiop/filesystem.lisp uiop/stream.lisp uiop/image.lisp uiop/lisp-build.lisp uiop/launch-program.lisp uiop/run-program.lisp uiop/configuration.lisp uiop/backward-driver.lisp uiop/driver.lisp" defsystem_lisp="upgrade.lisp cache.lisp component.lisp system.lisp find-system.lisp find-component.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp parse-defsystem.lisp bundle.lisp concatenate-source.lisp output-translations.lisp source-registry.lisp package-inferred-system.lisp backward-interface.lisp backward-internals.lisp interface.lisp user.lisp footer.lisp" all () { diff --git a/test/script-support.lisp b/test/script-support.lisp index 192e07ffe..eb7a8a5cc 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -15,7 +15,7 @@ Some constraints: (:export #:asym #:acall #:asymval #:*test-directory* #:*asdf-directory* #:*build-directory* #:*implementation* - #:deftest #:is #:signals #:errors #:with-expected-failure + #:deftest #:is #:signals #:does-not-signal #:errors #:with-expected-failure #:assert-compare #:assert-equal #:assert-pathname-equal #:assert-pathnames-equal #:hash-table->alist #:load-asdf #:maybe-compile-asdf @@ -127,17 +127,27 @@ Some constraints: (,condition (,x) (format *error-output* "~&Received signal ~S~%" ,x) (finish-output *error-output*) - t) + ,x) (:no-error (&rest ,x) (error "Expression ~S fails to raise condition ~S, instead returning~{ ~S~}" - ',sexp ',condition ,x)) - (t (,x) - (error "Expression ~S raises signal ~S, not ~S" ',sexp ,x ',condition))))) -(defmacro errors (condition sexp) + ',sexp ',condition ,x))))) +(defmacro does-not-signal (condition sexp &aux (x (gensym))) + `(progn + (format *error-output* "~&Checking that ~S does NOT signal ~S~%" ',sexp ',condition) + (finish-output *error-output*) + (handler-case + ,sexp + (,condition (,x) + (error "~&Condition signaled: ~S~%" ,x)) + (:no-error (&rest ,x) + t)))) +(defmacro errors (condition sexp &aux (x (gensym))) `(progn (format *error-output* "~&Checking whether ~S signals error ~S~%" ',sexp ',condition) (finish-output *error-output*) - (assert-equal ',condition (type-of (nth-value 1 (ignore-errors ,sexp)))))) + (let ((,x (nth-value 1 (ignore-errors ,sexp)))) + (assert-equal ',condition (type-of ,x)) + ,x))) (defmacro with-expected-failure ((&optional condition) &body body) `(call-with-expected-failure ,condition (lambda () ,@body))) (defun call-with-expected-failure (condition thunk) diff --git a/test/test-deprecation.script b/test/test-deprecation.script new file mode 100644 index 000000000..913221694 --- /dev/null +++ b/test/test-deprecation.script @@ -0,0 +1,68 @@ +;;-*- Lisp -*- + +(setf asdf::*asdf-version* "6.7.8") + +(DBG "Check still-valid code") +(asdf::with-asdf-deprecation (:style-warning "7.0") + (defun still-valid () t)) +(does-not-signal deprecated-function-condition (eval '(still-valid))) +(does-not-signal deprecated-function-condition (compile () '(lambda () (still-valid)))) + +(defmacro check-deprecation (condition name body) + `(let ((c (signals ,condition (eval ',body)))) + (assert-equal (deprecated-function-name c) ',name))) + +(defmacro check-deprecation-warning (condition name body) + `(progn + (check-deprecation ,condition ,name ,body) + (nest #+(or abcl (and ecl ecl-bytecmp) mkcl) (does-not-signal condition) + #+ccl (signals ccl::compiler-warning) + #-(or abcl ccl (and ecl ecl-bytecmp) mkcl) + (check-deprecation ,condition ,name) + (compile () '(lambda () ,body))))) + +(defmacro check-deprecation-error (condition name body) + `(progn + (check-deprecation ,condition ,name ,body) + (nest #+allegro (signals style-warning) + #+(or cmucl (and ecl (not ecl-bytecmp))) (signals c::compiler-error) + #+(or (and ecl ecl-bytecmp) mkcl) (does-not-signal condition) + #+sbcl (signals simple-warning) + #-(or allegro cmucl ecl mkcl sbcl) + (check-deprecation ,condition ,name) + (compile () '(lambda () ,body))))) + +(defmacro check-deprecation-delete (condition name body) + `(progn + (check-deprecation ,condition ,name ,body) + (nest #+(or cmucl (and ecl (not ecl-bytecmp))) (signals c::compiler-error) + #+mkcl (errors compiler:compiler-error) + #+sbcl (signals sb-c:compiler-error) + #-(or cmucl (and ecl (not ecl-bytecmp)) mkcl sbcl) + (check-deprecation ,condition ,name) + (compile () '(lambda () ,body))))) + +(DBG "Check style-warning") +(asdf::with-asdf-deprecation (:style-warning "6") + (defun should-style-warn () t)) +(check-deprecation-warning deprecated-function-style-warning should-style-warn (should-style-warn)) + +(DBG "Check warning") +(asdf::with-asdf-deprecation (:style-warning "5") ;; next-version 6 is warning... + (defun should-warn () t)) +(check-deprecation-warning deprecated-function-warning should-warn (should-warn)) + +(DBG "Check warning") +(asdf::with-asdf-deprecation (:style-warning "6.5") ;; next- next-version 6.7 is error! + (defun should-error () t)) +(check-deprecation-error deprecated-function-error should-error (should-error)) + +(DBG "Check delete") +(check-deprecation-delete + deprecated-function-should-be-deleted (past-due-f past-due-m) + (asdf::with-asdf-deprecation (:style-warning "6.7.1") + ;; next- next- next-version 6.7.4 is delete! + (defun past-due-f () t) + (progn (foo)) + (defgeneric past-due-gf ()) + (defmethod past-due-m ()))) diff --git a/tools/version.lisp b/tools/version.lisp index 19d2e066a..cf53e7f9f 100644 --- a/tools/version.lisp +++ b/tools/version.lisp @@ -41,7 +41,7 @@ (defparameter *versioned-files* '(("version.lisp-expr" "\"" "\"") - ("uiop/version.lisp-expr" "\"" "\"") + ("uiop/version.lisp" "(defparameter *uiop-version* \"" "\")") ("asdf.asd" " :version \"" "\" ;; to be automatically updated by make bump-version") ("header.lisp" "This is ASDF " ": Another System Definition Facility.") ("upgrade.lisp" " (asdf-version \"" "\")") diff --git a/uiop/backward-driver.lisp b/uiop/backward-driver.lisp index 7be4af774..7f3c809ec 100644 --- a/uiop/backward-driver.lisp +++ b/uiop/backward-driver.lisp @@ -1,43 +1,45 @@ -;;;; ------------------------------------------------------------------------- -;;; Hacks for backward-compatibility of the driver +;;; ------------------------------------------------------------------------- +;;; Hacks for backward-compatibility with older versions of UIOP (uiop/package:define-package :uiop/backward-driver - (:use :uiop/common-lisp :uiop/package :uiop/utility + (:recycle :uiop/backward-driver :asdf/backward-driver :uiop) + (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/version :uiop/pathname :uiop/stream :uiop/os :uiop/image :uiop/run-program :uiop/lisp-build :uiop/configuration) (:export #:coerce-pathname #:user-configuration-directories #:system-configuration-directories #:in-first-directory #:in-user-configuration-directory #:in-system-configuration-directory - )) + #:version-compatible-p)) (in-package :uiop/backward-driver) -;;;; Backward compatibility with various pathname functions. +(eval-when (:compile-toplevel :load-toplevel :execute) +(with-deprecation ((version-deprecation *uiop-version* :style-warning "3.2.0" :warning "3.2.1")) + ;; Backward compatibility with ASDF 2.000 to 2.26 -(with-upgradability () + ;; For backward-compatibility only, for people using internals + ;; Reported users in quicklisp 2015-11: hu.dwim.asdf (removed in next release) + ;; Will be removed after 2015-12. (defun coerce-pathname (name &key type defaults) - ;; For backward-compatibility only, for people using internals - ;; Reported users in quicklisp 2015-11: hu.dwim.asdf (removed in next release) - ;; Will be removed after 2015-12. - ;;(warn "Please don't use ASDF::COERCE-PATHNAME. Use ASDF/PATHNAME:PARSE-UNIX-NAMESTRING.") + "DEPRECATED. Please use UIOP:PARSE-UNIX-NAMESTRING instead." (parse-unix-namestring name :type type :defaults defaults)) ;; Backward compatibility for ASDF 2.27 to 3.1.4 (defun user-configuration-directories () "Return the current user's list of user configuration directories for configuring common-lisp. - DEPRECATED. Use uiop:xdg-config-pathnames instead." +DEPRECATED. Use UIOP:XDG-CONFIG-PATHNAMES instead." (xdg-config-pathnames "common-lisp")) (defun system-configuration-directories () "Return the list of system configuration directories for common-lisp. - DEPRECATED. Use uiop:config-system-pathnames instead." +DEPRECATED. Use UIOP:CONFIG-SYSTEM-PATHNAMES instead." (system-config-pathnames "common-lisp")) (defun in-first-directory (dirs x &key (direction :input)) "Finds the first appropriate file named X in the list of DIRS for I/O in DIRECTION \(which may be :INPUT, :OUTPUT, :IO, or :PROBE). - If direction is :INPUT or :PROBE, will return the first extant file named +If direction is :INPUT or :PROBE, will return the first extant file named X in one of the DIRS. - If direction is :OUTPUT or :IO, will simply return the file named X in the +If direction is :OUTPUT or :IO, will simply return the file named X in the first element of DIRS that exists. DEPRECATED." (find-preferred-file (mapcar #'(lambda (dir) (subpathname (ensure-directory-pathname dir) x)) dirs) @@ -49,4 +51,18 @@ DEPRECATED." (defun in-system-configuration-directory (x &key (direction :input)) "Return the pathname for the file named X under the system configuration directory for common-lisp. DEPRECATED." - (find-preferred-file (system-config-pathnames "common-lisp" x) :direction direction))) + (find-preferred-file (system-config-pathnames "common-lisp" x) :direction direction)) + + + ;; Backward compatibility with ASDF 1 to ASDF 2.32 + + (defun version-compatible-p (provided-version required-version) + "Is the provided version a compatible substitution for the required-version? +If major versions differ, it's not compatible. +If they are equal, then any later version is compatible, +with later being determined by a lexicographical comparison of minor numbers. +DEPRECATED." + (let ((x (parse-version provided-version nil)) + (y (parse-version required-version nil))) + (and x y (= (car x) (car y)) (lexicographic<= '< (cdr y) (cdr x))))))) + diff --git a/uiop/driver.lisp b/uiop/driver.lisp index e59d3c111..9b7807d7d 100644 --- a/uiop/driver.lisp +++ b/uiop/driver.lisp @@ -10,7 +10,7 @@ ;; that could cause potential conflicts for packages that would :use (cl uiop) ;; or :use (closer-common-lisp uiop), etc. (:use-reexport - :uiop/package :uiop/utility + :uiop/package :uiop/utility :uiop/version :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image :uiop/launch-program :uiop/run-program :uiop/lisp-build :uiop/configuration :uiop/backward-driver)) diff --git a/uiop/run-program.lisp b/uiop/run-program.lisp index 795a6b2e9..8ab680807 100644 --- a/uiop/run-program.lisp +++ b/uiop/run-program.lisp @@ -3,7 +3,7 @@ (uiop/package:define-package :uiop/run-program (:nicknames :asdf/run-program) ; OBSOLETE. Used by cl-sane, printv. - (:use :uiop/common-lisp :uiop/package :uiop/utility + (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/version :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream :uiop/launch-program) (:export #:run-program diff --git a/uiop/uiop.asd b/uiop/uiop.asd index 630c8ff63..7abab7a19 100644 --- a/uiop/uiop.asd +++ b/uiop/uiop.asd @@ -27,16 +27,16 @@ It is transcluded into asdf.lisp together with ASDF/DEFSYSTEM, so if you did (re you already have a matching UIOP loaded." :author "Francois-Rene Rideau" :licence "MIT" - :class #.(if (find-class 'package-system nil) 'package-system 'system) - #+asdf3 :version #+asdf3 (:read-file-form "version.lisp-expr") - #+asdf-unicode :encoding #+asdf-unicode :utf-8 + :class #+asdf3.1 package-system #-asdf3.1 system + #+asdf3.1 :version #+asdf3.1 (:read-file-form "version.lisp" :at (2 2 2)) + #+asdf3 :encoding #+asdf3 :utf-8 #+asdf3 :around-compile #+asdf3 call-without-redefinition-warnings :components - ((:static-file "version.lisp-expr") - (:static-file "contrib/debug.lisp") + ((:static-file "contrib/debug.lisp") (:file "package") (:file "common-lisp" :depends-on ("package")) (:file "utility" :depends-on ("common-lisp")) + (:file "version" :depends-on ("utility")) (:file "os" :depends-on ("utility")) (:file "pathname" :depends-on ("utility" "os")) (:file "filesystem" :depends-on ("os" "pathname")) @@ -46,5 +46,5 @@ you already have a matching UIOP loaded." (:file "launch-program" :depends-on ("stream")) (:file "run-program" :depends-on ("launch-program")) (:file "configuration" :depends-on ("image")) - (:file "backward-driver" :depends-on ("lisp-build" "run-program" "configuration")) + (:file "backward-driver" :depends-on ("lisp-build" "run-program" "configuration" "version")) (:file "driver" :depends-on ("backward-driver")))) diff --git a/uiop/utility.lisp b/uiop/utility.lisp index 00c270045..3a617297b 100644 --- a/uiop/utility.lisp +++ b/uiop/utility.lisp @@ -14,6 +14,7 @@ #:with-upgradability ;; (un)defining functions in an upgrade-friendly way #:defun* #:defgeneric* #:nest #:if-let ;; basic flow control + #:parse-body ;; macro definition helper #:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists #:remove-plist-keys #:remove-plist-key ;; plists #:emptyp ;; sequences @@ -22,7 +23,7 @@ #:base-string-p #:strings-common-element-type #:reduce/strcat #:strcat ;; strings #:first-char #:last-char #:split-string #:stripln #:+cr+ #:+lf+ #:+crlf+ #:string-prefix-p #:string-enclosed-p #:string-suffix-p - #:standard-case-symbol-name #:find-standard-case-symbol + #:standard-case-symbol-name #:find-standard-case-symbol ;; symbols #:coerce-class ;; CLOS #:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps #:earlier-stamp #:stamps-earliest #:earliest-stamp @@ -31,7 +32,7 @@ #:ensure-function #:access-at #:access-at-count ;; functions #:call-function #:call-functions #:register-hook-function #:lexicographic< #:lexicographic<= ;; version - #:parse-version #:unparse-version #:version< #:version<= #:version-compatible-p + #:simple-style-warning #:style-warn ;; simple style warnings #:match-condition-p #:match-any-condition-p ;; conditions #:call-with-muffled-conditions #:with-muffled-conditions #:not-implemented-error #:parameter-error)) @@ -117,6 +118,30 @@ to supersede any previous definition." ,then-form ,else-form))))) +;;; Macro definition helper +(with-upgradability () + (defun parse-body (body &key documentation whole) ;; from alexandria + "Parses BODY into (values remaining-forms declarations doc-string). +Documentation strings are recognized only if DOCUMENTATION is true. +Syntax errors in body are signalled and WHOLE is used in the signal +arguments when given." + (let ((doc nil) + (decls nil) + (current nil)) + (tagbody + :declarations + (setf current (car body)) + (when (and documentation (stringp current) (cdr body)) + (if doc + (error "Too many documentation strings in ~S." (or whole body)) + (setf doc (pop body))) + (go :declarations)) + (when (and (listp current) (eql (first current) 'declare)) + (push (pop body) decls) + (go :declarations))) + (values body (nreverse decls) doc)))) + + ;;; List manipulation (with-upgradability () (defmacro while-collecting ((&rest collectors) &body body) @@ -153,7 +178,7 @@ Returns two values: \(A B C\) and \(1 2 3\)." (if (listp x) x (list x)))) -;;; remove a key from a plist, i.e. for keyword argument cleanup +;;; Remove a key from a plist, i.e. for keyword argument cleanup (with-upgradability () (defun remove-plist-key (key plist) "Remove a single key from a plist" @@ -503,39 +528,8 @@ up to the given equality TEST" (dolist (x list h) (setf (gethash x h) t)))) -;;; Version handling +;;; Lexicographic comparison of lists of numbers (with-upgradability () - (defun unparse-version (version-list) - "From a parsed version (a list of natural numbers), compute the version string" - (format nil "~{~D~^.~}" version-list)) - - (defun parse-version (version-string &optional on-error) - "Parse a VERSION-STRING as a series of natural numbers separated by dots. -Return a (non-null) list of integers if the string is valid; -otherwise return NIL. - -When invalid, ON-ERROR is called as per CALL-FUNCTION before to return NIL, -with format arguments explaining why the version is invalid. -ON-ERROR is also called if the version is not canonical -in that it doesn't print back to itself, but the list is returned anyway." - (block nil - (unless (stringp version-string) - (call-function on-error "~S: ~S is not a string" 'parse-version version-string) - (return)) - (unless (loop :for prev = nil :then c :for c :across version-string - :always (or (digit-char-p c) - (and (eql c #\.) prev (not (eql prev #\.)))) - :finally (return (and c (digit-char-p c)))) - (call-function on-error "~S: ~S doesn't follow asdf version numbering convention" - 'parse-version version-string) - (return)) - (let* ((version-list - (mapcar #'parse-integer (split-string version-string :separator "."))) - (normalized-version (unparse-version version-list))) - (unless (equal version-string normalized-version) - (call-function on-error "~S: ~S contains leading zeros" 'parse-version version-string)) - version-list))) - (defun lexicographic< (element< x y) "Lexicographically compare two lists of using the function element< to compare elements. element< is a strict total order; the resulting order on X and Y will also be strict." @@ -548,26 +542,20 @@ element< is a strict total order; the resulting order on X and Y will also be st (defun lexicographic<= (element< x y) "Lexicographically compare two lists of using the function element< to compare elements. element< is a strict total order; the resulting order on X and Y will be a non-strict total order." - (not (lexicographic< element< y x))) - - (defun version< (version1 version2) - "Compare two version strings" - (let ((v1 (parse-version version1 nil)) - (v2 (parse-version version2 nil))) - (lexicographic< '< v1 v2))) - - (defun version<= (version1 version2) - "Compare two version strings" - (not (version< version2 version1))) - - (defun version-compatible-p (provided-version required-version) - "Is the provided version a compatible substitution for the required-version? -If major versions differ, it's not compatible. -If they are equal, then any later version is compatible, -with later being determined by a lexicographical comparison of minor numbers." - (let ((x (parse-version provided-version nil)) - (y (parse-version required-version nil))) - (and x y (= (car x) (car y)) (lexicographic<= '< (cdr y) (cdr x)))))) + (not (lexicographic< element< y x)))) + + +;;; Simple style warnings +(with-upgradability () + (define-condition simple-style-warning + #+sbcl (sb-int:simple-style-warning) #-sbcl (simple-condition style-warning) + ()) + + (defun style-warn (datum &rest arguments) + (etypecase datum + (string (warn (make-condition 'simple-style-warning :format-control datum :format-arguments arguments))) + (symbol (assert (subtypep datum 'style-warning)) (apply 'warn datum arguments)) + (style-warning (apply 'warn datum arguments))))) ;;; Condition control diff --git a/uiop/version.lisp b/uiop/version.lisp new file mode 100644 index 000000000..df0faaf95 --- /dev/null +++ b/uiop/version.lisp @@ -0,0 +1,181 @@ +(uiop/package:define-package :uiop/version + (:recycle :uiop/version :uiop/utility :asdf) + (:use :uiop/common-lisp :uiop/package :uiop/utility) + (:export + #:*uiop-version* + #:parse-version #:unparse-version #:version< #:version<= ;; version support, moved from uiop/utility + #:next-version + #:deprecated-function-condition #:deprecated-function-name ;; deprecation control + #:deprecated-function-style-warning #:deprecated-function-warning + #:deprecated-function-error #:deprecated-function-should-be-deleted + #:version-deprecation #:with-deprecation)) +(in-package :uiop/version) + +(with-upgradability () + (defparameter *uiop-version* "3.1.7.27") + + (defun unparse-version (version-list) + "From a parsed version (a list of natural numbers), compute the version string" + (format nil "~{~D~^.~}" version-list)) + + (defun parse-version (version-string &optional on-error) + "Parse a VERSION-STRING as a series of natural numbers separated by dots. +Return a (non-null) list of integers if the string is valid; +otherwise return NIL. + +When invalid, ON-ERROR is called as per CALL-FUNCTION before to return NIL, +with format arguments explaining why the version is invalid. +ON-ERROR is also called if the version is not canonical +in that it doesn't print back to itself, but the list is returned anyway." + (block nil + (unless (stringp version-string) + (call-function on-error "~S: ~S is not a string" 'parse-version version-string) + (return)) + (unless (loop :for prev = nil :then c :for c :across version-string + :always (or (digit-char-p c) + (and (eql c #\.) prev (not (eql prev #\.)))) + :finally (return (and c (digit-char-p c)))) + (call-function on-error "~S: ~S doesn't follow asdf version numbering convention" + 'parse-version version-string) + (return)) + (let* ((version-list + (mapcar #'parse-integer (split-string version-string :separator "."))) + (normalized-version (unparse-version version-list))) + (unless (equal version-string normalized-version) + (call-function on-error "~S: ~S contains leading zeros" 'parse-version version-string)) + version-list))) + + (defun next-version (version) + "When VERSION is not nil, it is a string, then parse it as a version, compute the next version +and return it as a string." + (when version + (let ((version-list (parse-version version))) + (incf (car (last version-list))) + (unparse-version version-list)))) + + (defun version< (version1 version2) + "Given two version strings, return T if the second is strictly newer" + (let ((v1 (parse-version version1 nil)) + (v2 (parse-version version2 nil))) + (lexicographic< '< v1 v2))) + + (defun version<= (version1 version2) + "Given two version strings, return T if the second is newer or the same" + (not (version< version2 version1)))) + + +(with-upgradability () + (define-condition deprecated-function-condition (condition) + ((name :initarg :name :reader deprecated-function-name))) + (define-condition deprecated-function-style-warning (deprecated-function-condition style-warning) ()) + (define-condition deprecated-function-warning (deprecated-function-condition warning) ()) + (define-condition deprecated-function-error (deprecated-function-condition error) ()) + (define-condition deprecated-function-should-be-deleted (deprecated-function-condition error) ()) + + (defun deprecated-function-condition-kind (type) + (ecase type + ((deprecated-function-style-warning) :style-warning) + ((deprecated-function-warning) :warning) + ((deprecated-function-error) :error) + ((deprecated-function-should-be-deleted) :delete))) + + (defmethod print-object ((c deprecated-function-condition) stream) + (let ((name (deprecated-function-name c))) + (cond + (*print-readably* + (let ((fmt "#.(make-condition '~S :name ~S)") + (args (list (type-of c) name))) + (if *read-eval* + (apply 'format stream fmt args) + (error "Can't print ~?" fmt args)))) + (*print-escape* + (print-unreadable-object (c stream :type t) (format stream ":name ~S" name))) + (t + (let ((*package* (find-package :cl)) + (type (type-of c))) + (format stream + (if (eq type 'deprecated-function-should-be-deleted) + "~A: Still defining deprecated function~:P ~{~S~^ ~} that promised to delete" + "~A: Using deprecated function ~S -- please update your code to use a newer API.~ +~@[~%The docstring for this function says:~%~A~%~]") + type name (when (symbolp name) (documentation name 'function)))))))) + + (defun notify-deprecated-function (status name) + (ecase status + ((nil) nil) + ((:style-warning) (style-warn 'deprecated-function-style-warning :name name)) + ((:warning) (warn 'deprecated-function-warning :name name)) + ((:error) (cerror "USE FUNCTION ANYWAY" 'deprecated-function-error :name name)))) + + (defun version-deprecation (version &key (style-warning nil) + (warning (next-version style-warning)) + (error (next-version warning)) + (delete (next-version error))) + "Given a VERSION string, and the starting versions for notifying the programmer of +various levels of deprecation, return the current level of deprecation as per WITH-DEPRECATION +that is the highest level that has a declared version older than the specified version. +Each start version for a level of deprecation can be specified by a keyword argument, or +if left unspecified, will be the NEXT-VERSION of the immediate lower level of deprecation." + (cond + ((and delete (version<= delete version)) :delete) + ((and error (version<= error version)) :error) + ((and warning (version<= warning version)) :warning) + ((and style-warning (version<= style-warning version)) :style-warning))) + + (defmacro with-deprecation ((level) &body definitions) + "Given a deprecation LEVEL (a form to be EVAL'ed at macro-expansion time), instrument the +DEFUN and DEFMETHOD forms in DEFINITIONS to notify the programmer of the deprecation of the function +when it is compiled or called. + +Increasing levels (as result from evaluating LEVEL) are: NIL (not deprecated yet), +:STYLE-WARNING (a style warning is issued when used), :WARNING (a full warning is issued when used), +:ERROR (a continuable error instead), and :DELETE (it's an error if the code is still there while +at that level). + +Forms other than DEFUN and DEFMETHOD are not instrumented, and you can protect a DEFUN or DEFMETHOD +from instrumentation by enclosing it in a PROGN." + (let ((level (eval level))) + (check-type level (member nil :style-warning :warning :error :delete)) + (when (eq level :delete) + (error 'deprecated-function-should-be-deleted :name + (mapcar 'second + (remove-if-not #'(lambda (x) (member x '(defun defmethod))) + definitions :key 'first)))) + (labels ((instrument (name head body whole) + (if level + (let ((notifiedp + (intern (format nil "*~A-~A-~A-~A*" + :deprecated-function level name :notified-p)))) + (multiple-value-bind (remaining-forms declarations doc-string) + (parse-body body :documentation t :whole whole) + `(progn + (defparameter ,notifiedp nil) + ;; tell some implementations to use the compiler-macro + (declaim (inline ,name)) + (define-compiler-macro ,name (&whole form &rest args) + (declare (ignore args)) + (notify-deprecated-function ,level ',name) + form) + (,@head ,@(when doc-string (list doc-string)) ,@declarations + (unless ,notifiedp + (setf ,notifiedp t) + (notify-deprecated-function ,level ',name)) + ,@remaining-forms)))) + `(progn + (eval-when (:compile-toplevel :load-toplevel :execute) + (setf (compiler-macro-function ',name) nil)) + (declaim (notinline ,name)) + (,@head ,@body))))) + `(progn + ,@(loop :for form :in definitions :collect + (cond + ((and (consp form) (eq (car form) 'defun)) + (instrument (second form) (subseq form 0 3) (subseq form 3) form)) + ((and (consp form) (eq (car form) 'defmethod)) + (let ((body-start (if (listp (third form)) 3 4))) + (instrument (second form) + (subseq form 0 body-start) + (subseq form body-start) + form))) + (t + form)))))))) diff --git a/uiop/version.lisp-expr b/uiop/version.lisp-expr deleted file mode 100644 index 6b28e26fe..000000000 --- a/uiop/version.lisp-expr +++ /dev/null @@ -1,2 +0,0 @@ -"3.1.7.40" - diff --git a/upgrade.lisp b/upgrade.lisp index e5e432b7a..e0afc0498 100644 --- a/upgrade.lisp +++ b/upgrade.lisp @@ -11,6 +11,7 @@ #:upgrading-p #:when-upgrading #:upgrade-asdf #:defparameter* #:*post-upgrade-cleanup-hook* #:cleanup-upgraded-asdf ;; There will be no symbol left behind! + #:with-asdf-deprecation #:intern*) (:import-from :uiop/package #:intern* #:find-symbol*)) (in-package :asdf/upgrade) @@ -163,4 +164,9 @@ previously-loaded version of ASDF." (let ((*load-print* nil) (*compile-print* nil)) (handler-bind (((or style-warning) #'muffle-warning)) - (symbol-call :asdf :load-system :asdf :verbose nil))))) + (symbol-call :asdf :load-system :asdf :verbose nil)))) + + (defmacro with-asdf-deprecation ((&rest keys &key &allow-other-keys) &body body) + `(with-upgradability () + (with-deprecation ((version-deprecation *asdf-version* ,@keys)) + ,@body)))) -- GitLab