package-inferred-system.lisp 7.26 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
  (:use :uiop/common-lisp :uiop
7
        :asdf/upgrade :asdf/session
8
        :asdf/component :asdf/system :asdf/system-registry :asdf/lisp-action
9
        :asdf/parse-defsystem)
10
  (:export
11 12
   #:package-inferred-system #:sysdef-package-inferred-system-search
   #:package-system ;; backward compatibility only. To be removed.
13
   #:register-system-packages
14 15
   #:*defpackage-forms* #:*package-inferred-systems* #:package-inferred-system-missing-package-error))
(in-package :asdf/package-inferred-system)
16 17

(with-upgradability ()
18
  ;; The names of the recognized defpackage forms.
19
  (defparameter *defpackage-forms* '(defpackage define-package))
20

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

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

32
  (defclass package-inferred-system (system)
33 34 35 36 37
    ()
    (: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"))
38

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

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

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

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

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

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

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

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

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

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

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