package-inferred-system.lisp 7.29 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.
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
  ;; The names of the recognized defpackage forms.
18
  (defparameter *defpackage-forms* '(defpackage define-package))
19

20
  (defun initial-package-inferred-systems-table ()
21
    ;; Mark all existing packages are preloaded.
22 23 24 25 26 27
    (let ((h (make-hash-table :test 'equal)))
      (dolist (p (list-all-packages))
        (dolist (n (package-names p))
          (setf (gethash n h) t)))
      h))

28
  ;; Mapping from package names to systems that provide them.
29
  (defvar *package-inferred-systems* (initial-package-inferred-systems-table))
30

31
  (defclass package-inferred-system (system)
32 33 34 35 36
    ()
    (:documentation "Class for primary systems for which secondary systems are automatically
in the one-file, one-file, one-system style: system names are mapped to files under the primary
system's system-source-directory, dependencies are inferred from the first defpackage form in
every such file"))
37

38
  ;; DEPRECATED. For backward compatibility only. To be removed in an upcoming release:
39 40
  (defclass package-system (package-inferred-system) ())

41
  ;; Is a given form recognizable as a defpackage form?
42 43 44 45
  (defun defpackage-form-p (form)
    (and (consp form)
         (member (car form) *defpackage-forms*)))

46
  ;; Find the first defpackage form in a stream, if any
47
  (defun stream-defpackage-form (stream)
48 49
    (loop :for form = (read stream nil nil) :while form
          :when (defpackage-form-p form) :return form))
50 51

  (defun file-defpackage-form (file)
Robert P. Goldman's avatar
Robert P. Goldman committed
52
    "Return the first DEFPACKAGE form in FILE."
53 54 55
    (with-input-file (f file)
      (stream-defpackage-form f)))

56
  (define-condition package-inferred-system-missing-package-error (system-definition-error)
57 58 59 60
    ((system :initarg :system :reader error-system)
     (pathname :initarg :pathname :reader error-pathname))
    (:report (lambda (c s)
               (format s (compatfmt "~@<No package form found while ~
61
                                     trying to define package-inferred-system ~A from file ~A~>")
62 63
                       (error-system c) (error-pathname c)))))

64
  (defun package-dependencies (defpackage-form)
Robert P. Goldman's avatar
Robert P. Goldman committed
65 66
    "Return a list of packages depended on by the package
defined in DEFPACKAGE-FORM.  A package is depended upon if
67
the DEFPACKAGE-FORM uses it or imports a symbol from it."
68 69 70 71 72 73 74 75 76 77 78 79 80
    (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)
81
    "Normalize a package designator to a string"
82 83 84 85 86 87
    (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
88
    "Register SYSTEM as providing PACKAGES."
89 90
    (let ((name (or (eq system t) (coerce-name system))))
      (dolist (p (ensure-list packages))
91
        (setf (gethash (package-designator-name p) *package-inferred-systems*) name))))
92 93

  (defun package-name-system (package-name)
Robert P. Goldman's avatar
Robert P. Goldman committed
94 95
    "Return the name of the SYSTEM providing PACKAGE-NAME, if such exists,
otherwise return a default system name computed from PACKAGE-NAME."
96
    (check-type package-name string)
97 98
    (or (gethash package-name *package-inferred-systems*)
        (string-downcase package-name)))
99

100
  ;; Given a file in package-inferred-system style, find its dependencies
101
  (defun package-inferred-system-file-dependencies (file &optional system)
102 103
    (if-let (defpackage-form (file-defpackage-form file))
      (remove t (mapcar 'package-name-system (package-dependencies defpackage-form)))
104
      (error 'package-inferred-system-missing-package-error :system system :pathname file)))
105

106 107
  ;; Given package-inferred-system object, check whether its specification matches
  ;; the provided parameters
108
  (defun same-package-inferred-system-p (system name directory subpath around-compile dependencies)
109
    (and (eq (type-of system) 'package-inferred-system)
110 111 112
         (equal (component-name system) name)
         (pathname-equal directory (component-pathname system))
         (equal dependencies (component-sideway-dependencies system))
113
         (equal around-compile (around-compile-hook system))
114 115 116 117 118 119 120 121
         (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))))))))

122
  ;; sysdef search function to push into *system-definition-search-functions*
123
  (defun sysdef-package-inferred-system-search (system)
124 125 126
    (let ((primary (primary-system-name system)))
      (unless (equal primary system)
        (let ((top (find-system primary nil)))
127
          (when (typep top 'package-inferred-system)
128
            (if-let (dir (component-pathname top))
129 130 131 132
              (let* ((sub (subseq system (1+ (length primary))))
                     (f (probe-file* (subpathname dir sub :type "lisp")
                                     :truename *resolve-symlinks*)))
                (when (file-pathname-p f)
133
                  (let ((dependencies (package-inferred-system-file-dependencies f system))
134
                        (previous (registered-system system))
135 136
                        (around-compile (around-compile-hook top)))
                    (if (same-package-inferred-system-p previous system dir sub around-compile dependencies)
137 138
                        previous
                        (eval `(defsystem ,system
139
                                 :class package-inferred-system
140 141 142
                                 :source-file nil
                                 :pathname ,dir
                                 :depends-on ,dependencies
143
                                 :around-compile ,around-compile
144 145 146
                                 :components ((cl-source-file "lisp" :pathname ,sub)))))))))))))))

(with-upgradability ()
147 148 149 150
  (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*)))