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.
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
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*)))