package-inferred-system.lisp 6.24 KB
Newer Older
1 2 3
;;;; -------------------------------------------------------------------------
;;;; Package systems in the style of quick-build or faslpath

4 5
(uiop:define-package :asdf/package-inferred-system
  (:recycle :asdf/package-inferred-system :asdf/package-system :asdf)
6 7 8 9
  (:use :uiop/common-lisp :uiop
        :asdf/defsystem ;; Using the old name of :asdf/parse-defsystem for compatibility
        :asdf/upgrade :asdf/component :asdf/system :asdf/find-system :asdf/lisp-action)
  (:export
10 11
   #:package-inferred-system #:sysdef-package-inferred-system-search
   #:package-system ;; backward compatibility only. To be removed.
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
12
   #:register-system-packages
13 14
   #:*defpackage-forms* #:*package-inferred-systems* #:package-inferred-system-missing-package-error))
(in-package :asdf/package-inferred-system)
15 16

(with-upgradability ()
17
  (defparameter *defpackage-forms* '(defpackage define-package))
18

19
  (defun initial-package-inferred-systems-table ()
20 21 22 23 24 25
    (let ((h (make-hash-table :test 'equal)))
      (dolist (p (list-all-packages))
        (dolist (n (package-names p))
          (setf (gethash n h) t)))
      h))

26
  (defvar *package-inferred-systems* (initial-package-inferred-systems-table))
27

28
  (defclass package-inferred-system (system)
29 30
    ())

31 32 33
  ;; For backward compatibility only. To be removed in an upcoming release:
  (defclass package-system (package-inferred-system) ())

34 35 36 37 38
  (defun defpackage-form-p (form)
    (and (consp form)
         (member (car form) *defpackage-forms*)))

  (defun stream-defpackage-form (stream)
39 40
    (loop :for form = (read stream nil nil) :while form
          :when (defpackage-form-p form) :return form))
41 42

  (defun file-defpackage-form (file)
Robert P. Goldman's avatar
Robert P. Goldman committed
43
    "Return the first DEFPACKAGE form in FILE."
44 45 46
    (with-input-file (f file)
      (stream-defpackage-form f)))

47
  (define-condition package-inferred-system-missing-package-error (system-definition-error)
48 49 50 51
    ((system :initarg :system :reader error-system)
     (pathname :initarg :pathname :reader error-pathname))
    (:report (lambda (c s)
               (format s (compatfmt "~@<No package form found while ~
52
                                     trying to define package-inferred-system ~A from file ~A~>")
53 54
                       (error-system c) (error-pathname c)))))

55
  (defun package-dependencies (defpackage-form)
Robert P. Goldman's avatar
Robert P. Goldman committed
56 57
    "Return a list of packages depended on by the package
defined in DEFPACKAGE-FORM.  A package is depended upon if
58
the DEFPACKAGE-FORM uses it or imports a symbol from it."
59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77
    (assert (defpackage-form-p defpackage-form))
    (remove-duplicates
     (while-collecting (dep)
       (loop* :for (option . arguments) :in (cddr defpackage-form) :do
              (ecase option
                ((:use :mix :reexport :use-reexport :mix-reexport)
                 (dolist (p arguments) (dep (string p))))
                ((:import-from :shadowing-import-from)
                 (dep (string (first arguments))))
                ((:nicknames :documentation :shadow :export :intern :unintern :recycle)))))
     :from-end t :test 'equal))

  (defun package-designator-name (package)
    (etypecase package
      (package (package-name package))
      (string package)
      (symbol (string package))))

  (defun register-system-packages (system packages)
Robert P. Goldman's avatar
Robert P. Goldman committed
78
    "Register SYSTEM as providing PACKAGES."
79 80
    (let ((name (or (eq system t) (coerce-name system))))
      (dolist (p (ensure-list packages))
81
        (setf (gethash (package-designator-name p) *package-inferred-systems*) name))))
82 83

  (defun package-name-system (package-name)
Robert P. Goldman's avatar
Robert P. Goldman committed
84 85
    "Return the name of the SYSTEM providing PACKAGE-NAME, if such exists,
otherwise return a default system name computed from PACKAGE-NAME."
86
    (check-type package-name string)
87
    (if-let ((system-name (gethash package-name *package-inferred-systems*)))
88 89 90
      system-name
      (string-downcase package-name)))

91
  (defun package-inferred-system-file-dependencies (file &optional system)
92 93
    (if-let (defpackage-form (file-defpackage-form file))
      (remove t (mapcar 'package-name-system (package-dependencies defpackage-form)))
94
      (error 'package-inferred-system-missing-package-error :system system :pathname file)))
95

96 97
  (defun same-package-inferred-system-p (system name directory subpath dependencies)
    (and (eq (type-of system) 'package-inferred-system)
98 99 100 101 102 103 104 105 106 107 108
         (equal (component-name system) name)
         (pathname-equal directory (component-pathname system))
         (equal dependencies (component-sideway-dependencies system))
         (let ((children (component-children system)))
           (and (length=n-p children 1)
                (let ((child (first children)))
                  (and (eq (type-of child) 'cl-source-file)
                       (equal (component-name child) "lisp")
                       (and (slot-boundp child 'relative-pathname)
                            (equal (slot-value child 'relative-pathname) subpath))))))))

109
  (defun sysdef-package-inferred-system-search (system)
110 111 112
    (let ((primary (primary-system-name system)))
      (unless (equal primary system)
        (let ((top (find-system primary nil)))
113
          (when (typep top 'package-inferred-system)
114 115 116 117 118
            (if-let (dir (system-source-directory top))
              (let* ((sub (subseq system (1+ (length primary))))
                     (f (probe-file* (subpathname dir sub :type "lisp")
                                     :truename *resolve-symlinks*)))
                (when (file-pathname-p f)
119
                  (let ((dependencies (package-inferred-system-file-dependencies f system))
120
                        (previous (cdr (system-registered-p system))))
121
                    (if (same-package-inferred-system-p previous system dir sub dependencies)
122 123
                        previous
                        (eval `(defsystem ,system
124
                                 :class package-inferred-system
125 126 127 128 129 130
                                 :source-file nil
                                 :pathname ,dir
                                 :depends-on ,dependencies
                                 :components ((cl-source-file "lisp" :pathname ,sub)))))))))))))))

(with-upgradability ()
131 132 133 134
  (pushnew 'sysdef-package-inferred-system-search *system-definition-search-functions*)
  (setf *system-definition-search-functions*
        (remove (find-symbol* :sysdef-package-system-search :asdf/package-system nil)
                *system-definition-search-functions*)))