1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
|
;;;; -------------------------------------------------------------------------
;;;; Package systems in the style of quick-build or faslpath
(uiop:define-package :asdf/package-inferred-system
(:recycle :asdf/package-inferred-system :asdf/package-system :asdf)
(:use :uiop/common-lisp :uiop
:asdf/upgrade :asdf/session
:asdf/component :asdf/system :asdf/system-registry :asdf/lisp-action
:asdf/parse-defsystem)
(:export
#:package-inferred-system #:sysdef-package-inferred-system-search
#:package-system ;; backward compatibility only. To be removed.
#:register-system-packages
#:*defpackage-forms* #:*package-inferred-systems*
#:package-inferred-system-missing-package-error
#:package-inferred-system-unknown-defpackage-option-error))
(in-package :asdf/package-inferred-system)
(with-upgradability ()
;; The names of the recognized defpackage forms.
(defparameter *defpackage-forms* '(defpackage define-package))
(defun initial-package-inferred-systems-table ()
;; Mark all existing packages are preloaded.
(let ((h (make-hash-table :test 'equal)))
(dolist (p (list-all-packages))
(dolist (n (package-names p))
(setf (gethash n h) t)))
h))
;; Mapping from package names to systems that provide them.
(defvar *package-inferred-systems* (initial-package-inferred-systems-table))
(defclass package-inferred-system (system)
()
(: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"))
;; DEPRECATED. For backward compatibility only. To be removed in an upcoming release:
(defclass package-system (package-inferred-system) ())
;; Is a given form recognizable as a defpackage form?
(defun defpackage-form-p (form)
(and (consp form)
(member (car form) *defpackage-forms*)))
;; Find the first defpackage form in a stream, if any
(defun stream-defpackage-form (stream)
(loop :for form = (read stream nil nil) :while form
:when (defpackage-form-p form) :return form))
(defun file-defpackage-form (file)
"Return the first DEFPACKAGE form in FILE."
(with-input-file (f file)
(stream-defpackage-form f)))
(define-condition package-inferred-system-missing-package-error (system-definition-error)
((system :initarg :system :reader error-system)
(pathname :initarg :pathname :reader error-pathname))
(:report (lambda (c s)
(format s (compatfmt "~@<No package form found while ~
trying to define package-inferred-system ~A from file ~A~>")
(error-system c) (error-pathname c)))))
(define-condition package-inferred-system-unknown-defpackage-option-error (system-definition-error)
((system :initarg :system :reader error-system)
(pathname :initarg :pathname :reader error-pathname)
(option :initarg :clause-head :reader error-option)
(arguments :initarg :clause-rest :reader error-arguments))
(:report (lambda (c s)
(format s (compatfmt "~@<Don't know how to infer package dependencies ~
for non-standard option ~S ~
while trying to define package-inferred-system ~A ~
from file ~A~>")
(cons (error-option c)
(error-arguments c))
(error-system c)
(error-pathname c)))))
(defun package-dependencies (defpackage-form &optional system pathname)
"Return a list of packages depended on by the package
defined in DEFPACKAGE-FORM. A package is depended upon if
the DEFPACKAGE-FORM uses it or imports a symbol from it.
SYSTEM should be the name of the system being defined, and
PATHNAME should be the file which contains the DEFPACKAGE-FORM.
These will be used to report errors when encountering an unknown defpackage argument."
(assert (defpackage-form-p defpackage-form))
(remove-duplicates
(while-collecting (dep)
(loop :for (option . arguments) :in (cddr defpackage-form) :do
(case option
((:use :mix :reexport :use-reexport :mix-reexport)
(dolist (p arguments) (dep (string p))))
((:import-from :shadowing-import-from)
(dep (string (first arguments))))
#+package-local-nicknames
((:local-nicknames)
(loop :for (nil actual-package-name) :in arguments :do
(dep (string actual-package-name))))
((:nicknames :documentation :shadow :export :intern :unintern :recycle))
;;; SBCL extensions to defpackage relating to package locks.
;; See https://www.sbcl.org/manual/#Implementation-Packages .
#+(or sbcl ecl) ;; MKCL too?
((:lock)
;; A :LOCK clause introduces no dependencies.
nil)
#+sbcl
((:implement)
;; A :IMPLEMENT clause introduces dependencies on the listed packages,
;; as it's not meaningful to :IMPLEMENT a package which hasn't yet been defined.
(dolist (p arguments) (dep (string p))))
#+lispworks
((:add-use-defaults) nil)
#+allegro
((:implementation-packages :alternate-name :flat) nil)
;; When encountering an unknown OPTION, signal a continuable error.
;; We cannot in general know whether the unknown clause should introduce any dependencies,
;; so we cannot do anything other than signal an error here,
;; but users may know that certain extensions do not introduce dependencies,
;; and may wish to manually continue building.
(otherwise (cerror "Treat the unknown option as introducing no package dependencies"
'package-inferred-system-unknown-defpackage-option-error
:system system
:pathname pathname
:option option
:arguments arguments)))))
:from-end t :test 'equal))
(defun package-designator-name (package)
"Normalize a package designator to a string"
(etypecase package
(package (package-name package))
(string package)
(symbol (string package))))
(defun register-system-packages (system packages)
"Register SYSTEM as providing PACKAGES."
(let ((name (or (eq system t) (coerce-name system))))
(dolist (p (ensure-list packages))
(setf (gethash (package-designator-name p) *package-inferred-systems*) name))))
(defun package-name-system (package-name)
"Return the name of the SYSTEM providing PACKAGE-NAME, if such exists,
otherwise return a default system name computed from PACKAGE-NAME."
(check-type package-name string)
(or (gethash package-name *package-inferred-systems*)
(string-downcase package-name)))
;; Given a file in package-inferred-system style, find its dependencies
(defun package-inferred-system-file-dependencies (file &optional system)
(if-let (defpackage-form (file-defpackage-form file))
(remove t (mapcar 'package-name-system (package-dependencies defpackage-form)))
(error 'package-inferred-system-missing-package-error :system system :pathname file)))
;; Given package-inferred-system object, check whether its specification matches
;; the provided parameters
(defun same-package-inferred-system-p (system name directory subpath around-compile dependencies)
(and (eq (type-of system) 'package-inferred-system)
(equal (component-name system) name)
(pathname-equal directory (component-pathname system))
(equal dependencies (component-sideway-dependencies system))
(equal around-compile (around-compile-hook 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))))))))
;; sysdef search function to push into *system-definition-search-functions*
(defun sysdef-package-inferred-system-search (system-name)
"Takes SYSTEM-NAME and returns an initialized SYSTEM object, or NIL. Made to be added to
*SYSTEM-DEFINITION-SEARCH-FUNCTIONS*."
(let ((primary (primary-system-name system-name)))
;; this function ONLY does something if the primary system name is NOT the same as
;; SYSTEM-NAME. It is used to find the systems with names that are relative to
;; the primary system's name, and that are not explicitly specified in the system
;; definition
(unless (equal primary system-name)
(let ((top (find-system primary nil)))
(when (typep top 'package-inferred-system)
(if-let (dir (component-pathname top))
(let* ((sub (subseq system-name (1+ (length primary))))
(component-type (class-for-type top :file))
(file-type (file-type (make-instance component-type)))
(f (probe-file* (subpathname dir sub :type file-type)
:truename *resolve-symlinks*)))
(when (file-pathname-p f)
(let ((dependencies (package-inferred-system-file-dependencies f system-name))
(previous (registered-system system-name))
(around-compile (around-compile-hook top)))
(if (same-package-inferred-system-p previous system-name dir sub around-compile dependencies)
previous
(eval `(defsystem ,system-name
:class package-inferred-system
:default-component-class ,component-type
:source-file ,(system-source-file top)
:pathname ,dir
:depends-on ,dependencies
:around-compile ,around-compile
:components ((,component-type file-type :pathname ,sub)))))))))))))))
(with-upgradability ()
(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*)))
|
