Commit c66fa297 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau Committed by Francois-Rene Rideau

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).

Declare some things deprecated, including system names asdf-driver and
asdf-package-system.

Deprecation will start with 3.2.
Add deprecation TODO items.
parent ec88be65
......@@ -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/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/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)
......
......@@ -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.
......@@ -258,15 +258,19 @@ The class needs to be updated for ASDF 3.1 and specify appropriate propagation m
:format-arguments
(list (type-of o)))))
(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))))))
(with-asdf-deprecation (:style-warning "3.2.0")
(defun backward-compatible-depends-on (o c)
`(,@(sideway-operation-depends-on o c)
,@(when (typep c 'parent-component) (downward-operation-depends-on o c))))
(progn
(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))
(backward-compatible-depends-on o c))))))
(defmethod downward-operation ((o operation)) nil)
(defmethod sideway-operation ((o operation)) nil))
......
This diff is collapsed.
......@@ -7,7 +7,7 @@
(:export #:load-sysdef))
(in-package :asdf/backward-internals)
(with-upgradability ()
(with-asdf-deprecation (:style-warning "3.2.0" :warning "3.2.1")
(defun load-sysdef (name pathname)
(declare (ignore name pathname))
;; Needed for backward compatibility with swank-asdf from SLIME 2015-12-01 or older.
......
......@@ -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 \"", "\"\\)" ],
......
......@@ -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))))
......
......@@ -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*)))
......
......@@ -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\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\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
......
......@@ -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/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/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 () {
......
......@@ -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 \"" "\")")
......
;;;; -------------------------------------------------------------------------
;;; 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)))))))
......@@ -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/run-program :uiop/lisp-build :uiop/configuration :uiop/backward-driver))
......
......@@ -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"))
......@@ -45,5 +45,5 @@ you already have a matching UIOP loaded."
(:file "lisp-build" :depends-on ("image"))
(:file "run-program" :depends-on ("stream"))
(: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"))))
......@@ -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
......
(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
#:version-deprecation #:with-deprecation)) ;; obsolescence control
(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 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) ())
(defun deprecated-function-condition-kind (type)
(ecase type
((deprecated-function-style-warning) :style-warning)
((deprecated-function-warning) :warning)
((deprecated-function-error) :error)))
(defmethod print-object ((c deprecated-function-condition) stream)
(let ((name (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)))
(format stream "~A: Using deprecated function ~S -- please update your code to use a newer API"
(deprecated-function-condition-kind (type-of c)) name))))))
(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
((version<= delete version) :delete)
((version<= error version) :error)
((version<= warning version) :warning)
((version<= style-warning version) :style-warning)))
(defmacro with-deprecation ((level) &body definitions)
"Given a deprecation LEVEL, modify the function DEFINITIONS to notify the programmer
of the deprecation of the function when it is compiled or called. Increasing levels 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)."
(let ((level (eval level)))
(check-type level (member nil :style-warning :warning :error :delete))
(when (eq level :delete)
(error "Function~P ~{~S~^ ~} should have been deleted"
(length definitions) (mapcar 'second definitions)))
(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
(ecase (first form)
((progn)
form) ;; escape with-deprecation processing
((defun)
(instrument (second form) (subseq form 0 3) (subseq form 3) form))
((defmethod)
(let ((body-start (if (listp (third form)) 3 4)))
(instrument (second form)
(subseq form 0 body-start)
(subseq form body-start)
form)))
((defgeneric)
`(progn
,form
,(let ((name (second form))
(args (third form)))
(instrument name `(defmethod ,name :before ,args) '() form)))))))))))
......@@ -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))))
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