backward-internals.lisp 2.72 KB
Newer Older
1
;;;; -------------------------------------------------------------------------
2
;;; Internal hacks for backward-compatibility
3

4
(uiop/package:define-package :asdf/backward-internals
5
  (:recycle :asdf/backward-internals :asdf)
6
  (:use :uiop/common-lisp :uiop :asdf/upgrade
7 8
   :asdf/system :asdf/component :asdf/operation
   :asdf/find-system :asdf/action :asdf/lisp-action)
9
  (:export ;; for internal use
10
   #:load-sysdef #:make-temporary-package
11
   #:%refresh-component-inline-methods
12 13
   #:make-sub-operation
   #:load-sysdef #:make-temporary-package))
14 15 16
(in-package :asdf/backward-internals)

;;;; Backward compatibility with "inline methods"
17
(with-upgradability ()
18
  (defparameter* +asdf-methods+
19
    '(perform-with-restarts perform explain output-files operation-done-p))
20

21 22 23 24 25 26 27 28 29 30
  (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)
31

32
  (defun %define-component-inline-methods (ret rest)
33 34 35 36 37 38 39 40 41 42 43 44
    (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)))))))
45

46
  (defun %refresh-component-inline-methods (component rest)
47
    ;; clear methods, then add the new ones
48 49
    (%remove-component-inline-methods component)
    (%define-component-inline-methods component rest)))
50

51
(when-upgrading (:when (fboundp 'make-sub-operation))
52
  (defun make-sub-operation (c o dep-c dep-o)
53
    (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error)))
54 55 56


;;;; load-sysdef
57 58 59
(with-upgradability ()
  (defun load-sysdef (name pathname)
    (load-asd pathname :name name))
60

61
  (defun make-temporary-package ()
62
    ;; For loading a .asd file, we don't make a temporary package anymore,
63 64 65 66
    ;; 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))))
67 68