Forked from
asdf / asdf
1912 commits behind the upstream repository.
-
Robert P. Goldman authoredRobert P. Goldman authored
backward-internals.lisp 2.72 KiB
;;;; -------------------------------------------------------------------------
;;; Internal hacks for backward-compatibility
(uiop/package:define-package :asdf/backward-internals
(:recycle :asdf/backward-internals :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade
:asdf/system :asdf/component :asdf/operation
:asdf/find-system :asdf/action :asdf/lisp-action)
(:export ;; for internal use
#:load-sysdef #:make-temporary-package
#:%refresh-component-inline-methods
#:make-sub-operation
#:load-sysdef #:make-temporary-package))
(in-package :asdf/backward-internals)
;;;; Backward compatibility with "inline methods"
(with-upgradability ()
(defparameter* +asdf-methods+
'(perform-with-restarts perform explain output-files operation-done-p))
(defun %remove-component-inline-methods (component)
(dolist (name +asdf-methods+)
(map ()
;; this is inefficient as most of the stored
;; methods will not be for this particular gf
;; But this is hardly performance-critical
#'(lambda (m)
(remove-method (symbol-function name) m))
(component-inline-methods component)))
(component-inline-methods component) nil)
(defun %define-component-inline-methods (ret rest)
(loop* :for (key value) :on rest :by #'cddr
:for name = (and (keywordp key) (find key +asdf-methods+ :test 'string=))
:when name :do
(destructuring-bind (op &rest body) value
(loop :for arg = (pop body)
:while (atom arg)
:collect arg :into qualifiers
:finally
(destructuring-bind (o c) arg
(pushnew
(eval `(defmethod ,name ,@qualifiers ((,o ,op) (,c (eql ,ret))) ,@body))
(component-inline-methods ret)))))))
(defun %refresh-component-inline-methods (component rest)
;; clear methods, then add the new ones
(%remove-component-inline-methods component)
(%define-component-inline-methods component rest)))
(when-upgrading (:when (fboundp 'make-sub-operation))
(defun make-sub-operation (c o dep-c dep-o)
(declare (ignore c o dep-c dep-o)) (asdf-upgrade-error)))
;;;; load-sysdef
(with-upgradability ()
(defun load-sysdef (name pathname)
(load-asd pathname :name name))
(defun make-temporary-package ()
;; For loading a .asd file, we don't make a temporary package anymore,
;; but use ASDF-USER. I'd like to have this function do this,
;; but since whoever uses it is likely to delete-package the result afterwards,
;; this would be a bad idea, so preserve the old behavior.
(make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf))))