bundle.lisp - clic - Clic is an command line interactive client for gopher writ… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
bundle.lisp (27846B) | |
--- | |
1 ;;;; -------------------------------------------------------------------… | |
2 ;;;; ASDF-Bundle | |
3 | |
4 (uiop/package:define-package :asdf/bundle | |
5 (:recycle :asdf/bundle :asdf) | |
6 (:use :uiop/common-lisp :uiop :asdf/upgrade | |
7 :asdf/component :asdf/system :asdf/find-system :asdf/find-component :… | |
8 :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/defsyst… | |
9 (:export | |
10 #:bundle-op #:bundle-type #:program-system | |
11 #:bundle-system #:bundle-pathname-type #:direct-dependency-files | |
12 #:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p | |
13 #:basic-compile-bundle-op #:prepare-bundle-op | |
14 #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #… | |
15 #:lib-op #:monolithic-lib-op | |
16 #:dll-op #:monolithic-dll-op | |
17 #:deliver-asd-op #:monolithic-deliver-asd-op | |
18 #:program-op #:image-op #:compiled-file #:precompiled-system #:prebui… | |
19 #:user-system-p #:user-system #:trivial-system-p | |
20 #:prologue-code #:epilogue-code #:static-library)) | |
21 (in-package :asdf/bundle) | |
22 | |
23 (with-upgradability () | |
24 (defclass bundle-op (basic-compile-op) | |
25 ;; NB: use of instance-allocated slots for operations is DEPRECATED | |
26 ;; and only supported in a temporary fashion for backward compatibil… | |
27 ;; Supported replacement: Define slots on program-system instead. | |
28 ((bundle-type :initform :no-output-file :reader bundle-type :allocat… | |
29 (:documentation "base class for operations that bundle outputs from … | |
30 | |
31 (defclass monolithic-op (operation) () | |
32 (:documentation "A MONOLITHIC operation operates on a system *and al… | |
33 dependencies*. So, for example, a monolithic concatenate operation will | |
34 concatenate together a system's components and all of its dependencies, … | |
35 simple concatenate operation will concatenate only the components of the… | |
36 itself.")) | |
37 | |
38 (defclass monolithic-bundle-op (bundle-op monolithic-op) | |
39 ;; Old style way of specifying prologue and epilogue on ECL: in the … | |
40 ;; DEPRECATED. Supported replacement: Define slots on program-system… | |
41 ((prologue-code :initform nil :accessor prologue-code) | |
42 (epilogue-code :initform nil :accessor epilogue-code)) | |
43 (:documentation "operations that are both monolithic-op and bundle-o… | |
44 | |
45 (defclass program-system (system) | |
46 ;; New style (ASDF3.1) way of specifying prologue and epilogue on EC… | |
47 ((prologue-code :initform nil :initarg :prologue-code :reader prolog… | |
48 (epilogue-code :initform nil :initarg :epilogue-code :reader epilog… | |
49 (no-uiop :initform nil :initarg :no-uiop :reader no-uiop) | |
50 (prefix-lisp-object-files :initarg :prefix-lisp-object-files | |
51 :initform nil :accessor prefix-lisp-objec… | |
52 (postfix-lisp-object-files :initarg :postfix-lisp-object-files | |
53 :initform nil :accessor postfix-lisp-obj… | |
54 (extra-object-files :initarg :extra-object-files | |
55 :initform nil :accessor extra-object-files) | |
56 (extra-build-args :initarg :extra-build-args | |
57 :initform nil :accessor extra-build-args))) | |
58 | |
59 (defmethod prologue-code ((x system)) nil) | |
60 (defmethod epilogue-code ((x system)) nil) | |
61 (defmethod no-uiop ((x system)) nil) | |
62 (defmethod prefix-lisp-object-files ((x system)) nil) | |
63 (defmethod postfix-lisp-object-files ((x system)) nil) | |
64 (defmethod extra-object-files ((x system)) nil) | |
65 (defmethod extra-build-args ((x system)) nil) | |
66 | |
67 (defclass link-op (bundle-op) () | |
68 (:documentation "Abstract operation for linking files together")) | |
69 | |
70 (defclass gather-operation (bundle-op) | |
71 ((gather-operation :initform nil :allocation :class :reader gather-o… | |
72 (gather-type :initform :no-output-file :allocation :class :reader g… | |
73 (:documentation "Abstract operation for gathering many input files f… | |
74 | |
75 (defun operation-monolithic-p (op) | |
76 (typep op 'monolithic-op)) | |
77 | |
78 ;; Dependencies of a gather-op are the actions of the dependent operat… | |
79 ;; for all the (sorted) required components for loading the system. | |
80 ;; Monolithic operations typically use lib-op as the dependent operati… | |
81 ;; and all system-level dependencies as required components. | |
82 ;; Non-monolithic operations typically use compile-op as the dependent… | |
83 ;; and all transitive sub-components as required components (excluding… | |
84 (defmethod component-depends-on ((o gather-operation) (s system)) | |
85 (let* ((mono (operation-monolithic-p o)) | |
86 (go (make-operation (or (gather-operation o) 'compile-op))) | |
87 (bundle-p (typep go 'bundle-op)) | |
88 ;; In a non-mono operation, don't recurse to other systems. | |
89 ;; In a mono operation gathering bundles, don't recurse insid… | |
90 (component-type (if mono (if bundle-p 'system t) '(not system… | |
91 ;; In the end, only keep system bundles or non-system bundles… | |
92 (keep-component (if bundle-p 'system '(not system))) | |
93 (deps | |
94 ;; Required-components only looks at the dependencies of an … | |
95 ;; itself, so it may be safely used by an action recursing o… | |
96 ;; may or may not be an overdesigned API, since in practice … | |
97 ;; Therefore, if we use :goal-operation 'load-op :keep-opera… | |
98 ;; cleaner, we will miss the load-op on the requested system… | |
99 ;; matter for a regular system, but matters, a lot, for a pa… | |
100 ;; Using load-op as the goal operation and basic-compile-op … | |
101 ;; for our needs of gathering all the files we want to inclu… | |
102 ;; Note that we use basic-compile-op rather than compile-op … | |
103 ;; systems when *load-system-operation* is load-bundle-op. | |
104 (required-components | |
105 s :other-systems mono :component-type component-type :keep-… | |
106 :goal-operation 'load-op :keep-operation 'basic-compile-op)… | |
107 `((,go ,@deps) ,@(call-next-method)))) | |
108 | |
109 ;; Create a single fasl for the entire library | |
110 (defclass basic-compile-bundle-op (bundle-op) | |
111 ((gather-type :initform #-(or clasp ecl mkcl) :fasl #+(or clasp ecl … | |
112 :allocation :class) | |
113 (bundle-type :initform :fasl :allocation :class)) | |
114 (:documentation "Base class for compiling into a bundle")) | |
115 | |
116 ;; Analog to prepare-op, for load-bundle-op and compile-bundle-op | |
117 (defclass prepare-bundle-op (sideway-operation) | |
118 ((sideway-operation | |
119 :initform #+(or clasp ecl mkcl) 'load-bundle-op #-(or clasp ecl mk… | |
120 :allocation :class)) | |
121 (:documentation "Operation class for loading the bundles of a system… | |
122 | |
123 (defclass lib-op (link-op gather-operation non-propagating-operation) | |
124 ((gather-type :initform :object :allocation :class) | |
125 (bundle-type :initform :lib :allocation :class)) | |
126 (:documentation "Compile the system and produce a linkable static li… | |
127 for all the linkable object files associated with the system. Compare wi… | |
128 | |
129 On most implementations, these object files only include extensions to t… | |
130 written in C or another language with a compiler producing linkable obje… | |
131 On CLASP, ECL, MKCL, these object files _also_ include the contents of L… | |
132 themselves. In any case, this operation will produce what you need to fu… | |
133 a static runtime for your system, or a dynamic library to load in an exi… | |
134 | |
135 ;; What works: on ECL, CLASP(?), MKCL, we link the many .o files from … | |
136 ;; on other implementations, we combine (usually concatenate) the .fas… | |
137 (defclass compile-bundle-op (basic-compile-bundle-op selfward-operatio… | |
138 #+(or clasp ecl m… | |
139 ((selfward-operation :initform '(prepare-bundle-op) :allocation :cla… | |
140 (:documentation "This operator is an alternative to COMPILE-OP. Buil… | |
141 and all of its dependencies, but build only a single (\"monolithic\") FA… | |
142 of one per source file, which may be more resource efficient. That mono… | |
143 FASL should be loaded with LOAD-BUNDLE-OP, rather than LOAD-OP.")) | |
144 | |
145 (defclass load-bundle-op (basic-load-op selfward-operation) | |
146 ((selfward-operation :initform '(prepare-bundle-op compile-bundle-op… | |
147 (:documentation "This operator is an alternative to LOAD-OP. Build a… | |
148 and all of its dependencies, using COMPILE-BUNDLE-OP. The difference with | |
149 respect to LOAD-OP is that it builds only a single FASL, which may be | |
150 faster and more resource efficient.")) | |
151 | |
152 ;; NB: since the monolithic-op's can't be sideway-operation's, | |
153 ;; if we wanted lib-op, dll-op, deliver-asd-op to be sideway-operation… | |
154 ;; we'd have to have the monolithic-op not inherit from the main op, | |
155 ;; but instead inherit from a basic-FOO-op as with basic-compile-bundl… | |
156 | |
157 (defclass dll-op (link-op gather-operation non-propagating-operation) | |
158 ((gather-type :initform :object :allocation :class) | |
159 (bundle-type :initform :dll :allocation :class)) | |
160 (:documentation "Compile the system and produce a dynamic loadable l… | |
161 for all the linkable object files associated with the system. Compare wi… | |
162 | |
163 (defclass deliver-asd-op (basic-compile-op selfward-operation) | |
164 ((selfward-operation | |
165 ;; TODO: implement link-op on all implementations, and make that | |
166 ;; '(compile-bundle-op lib-op #-(or clasp ecl mkcl) dll-op) | |
167 :initform '(compile-bundle-op #+(or clasp ecl mkcl) lib-op) | |
168 :allocation :class)) | |
169 (:documentation "produce an asd file for delivering the system as a … | |
170 | |
171 | |
172 (defclass monolithic-deliver-asd-op (deliver-asd-op monolithic-bundle-… | |
173 ((selfward-operation | |
174 ;; TODO: implement link-op on all implementations, and make that | |
175 ;; '(monolithic-compile-bundle-op monolithic-lib-op #-(or clasp ec… | |
176 :initform '(monolithic-compile-bundle-op #+(or clasp ecl mkcl) mon… | |
177 :allocation :class)) | |
178 (:documentation "produce fasl and asd files for combined system and … | |
179 | |
180 (defclass monolithic-compile-bundle-op | |
181 (basic-compile-bundle-op monolithic-bundle-op | |
182 #+(or clasp ecl mkcl) link-op gather-operation non-propagating-op… | |
183 () | |
184 (:documentation "Create a single fasl for the system and its depende… | |
185 | |
186 (defclass monolithic-load-bundle-op (load-bundle-op monolithic-bundle-… | |
187 ((selfward-operation :initform 'monolithic-compile-bundle-op :alloca… | |
188 (:documentation "Load a single fasl for the system and its dependenc… | |
189 | |
190 (defclass monolithic-lib-op (lib-op monolithic-bundle-op non-propagati… | |
191 ((gather-type :initform :object :allocation :class)) | |
192 (:documentation "Compile the system and produce a linkable static li… | |
193 for all the linkable object files associated with the system or its depe… | |
194 | |
195 (defclass monolithic-dll-op (dll-op monolithic-bundle-op non-propagati… | |
196 ((gather-type :initform :object :allocation :class)) | |
197 (:documentation "Compile the system and produce a dynamic loadable l… | |
198 for all the linkable object files associated with the system or its depe… | |
199 | |
200 (defclass image-op (monolithic-bundle-op selfward-operation | |
201 #+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl… | |
202 ((bundle-type :initform :image :allocation :class) | |
203 (gather-operation :initform 'lib-op :allocation :class) | |
204 #+(or clasp ecl mkcl) (gather-type :initform :static-library :alloc… | |
205 (selfward-operation :initform '(#-(or clasp ecl mkcl) load-op) :all… | |
206 (:documentation "create an image file from the system and its depend… | |
207 | |
208 (defclass program-op (image-op) | |
209 ((bundle-type :initform :program :allocation :class)) | |
210 (:documentation "create an executable file from the system and its d… | |
211 | |
212 ;; From the ASDF-internal bundle-type identifier, get a filesystem-usa… | |
213 (defun bundle-pathname-type (bundle-type) | |
214 (etypecase bundle-type | |
215 ((or null string) ;; pass through nil or string literal | |
216 bundle-type) | |
217 ((eql :no-output-file) ;; marker for a bundle-type that has NO out… | |
218 (error "No output file, therefore no pathname type")) | |
219 ((eql :fasl) ;; the type of a fasl | |
220 #-(or clasp ecl mkcl) (compile-file-type) ; on image-based platfo… | |
221 #+(or clasp ecl mkcl) "fasb") ; on C-linking platforms, only used… | |
222 ((member :image) | |
223 #+allegro "dxl" | |
224 #+(and clisp os-windows) "exe" | |
225 #-(or allegro (and clisp os-windows)) "image") | |
226 ;; NB: on CLASP and ECL these implementations, we better agree with | |
227 ;; (compile-file-type :type bundle-type)) | |
228 ((eql :object) ;; the type of a linkable object file | |
229 (os-cond ((os-unix-p) "o") | |
230 ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) … | |
231 ((member :lib :static-library) ;; the type of a linkable library | |
232 (os-cond ((os-unix-p) "a") | |
233 ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) … | |
234 ((member :dll :shared-library) ;; the type of a shared library | |
235 (os-cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-… | |
236 ((eql :program) ;; the type of an executable program | |
237 (os-cond ((os-unix-p) nil) ((os-windows-p) "exe"))))) | |
238 | |
239 ;; Compute the output-files for a given bundle action | |
240 (defun bundle-output-files (o c) | |
241 (let ((bundle-type (bundle-type o))) | |
242 (unless (or (eq bundle-type :no-output-file) ;; NIL already means … | |
243 (and (null (input-files o c)) (not (member bundle-type… | |
244 (let ((name (or (component-build-pathname c) | |
245 (let ((suffix | |
246 (unless (typep o 'program-op) | |
247 ;; "." is no good separator for Logical… | |
248 (if (operation-monolithic-p o) | |
249 "--all-systems" | |
250 ;; These use a different type .fasb… | |
251 #-(or clasp ecl mkcl) "--system")))) | |
252 (format nil "~A~@[~A~]" (component-name c) suf… | |
253 (type (bundle-pathname-type bundle-type))) | |
254 (values (list (subpathname (component-pathname c) name :type t… | |
255 (eq (class-of o) (coerce-class (component-build-operat… | |
256 :package :asdf/interface | |
257 :super 'operation | |
258 :error nil))))))) | |
259 | |
260 (defmethod output-files ((o bundle-op) (c system)) | |
261 (bundle-output-files o c)) | |
262 | |
263 #-(or clasp ecl mkcl) | |
264 (progn | |
265 (defmethod perform ((o image-op) (c system)) | |
266 (dump-image (output-file o c) :executable (typep o 'program-op))) | |
267 (defmethod perform :before ((o program-op) (c system)) | |
268 (setf *image-entry-point* (ensure-function (component-entry-point … | |
269 | |
270 (defclass compiled-file (file-component) | |
271 ((type :initform #-(or clasp ecl mkcl) (compile-file-type) #+(or cla… | |
272 (:documentation "Class for a file that is already compiled, | |
273 e.g. as part of the implementation, of an outer build system that calls … | |
274 or of opaque libraries shipped along the source code.")) | |
275 | |
276 (defclass precompiled-system (system) | |
277 ((build-pathname :initarg :fasl)) | |
278 (:documentation "Class For a system that is delivered as a precompil… | |
279 | |
280 (defclass prebuilt-system (system) | |
281 ((build-pathname :initarg :static-library :initarg :lib | |
282 :accessor prebuilt-system-static-library)) | |
283 (:documentation "Class for a system delivered with a linkable static… | |
284 | |
285 | |
286 ;;; | |
287 ;;; BUNDLE-OP | |
288 ;;; | |
289 ;;; This operation takes all components from one or more systems and | |
290 ;;; creates a single output file, which may be | |
291 ;;; a FASL, a statically linked library, a shared library, etc. | |
292 ;;; The different targets are defined by specialization. | |
293 ;;; | |
294 (when-upgrading (:version "3.2.0") | |
295 ;; Cancel any previously defined method | |
296 (defmethod initialize-instance :after ((instance bundle-op) &rest init… | |
297 (declare (ignore initargs)))) | |
298 | |
299 (with-upgradability () | |
300 (defgeneric trivial-system-p (component)) | |
301 | |
302 (defun user-system-p (s) | |
303 (and (typep s 'system) | |
304 (not (builtin-system-p s)) | |
305 (not (trivial-system-p s))))) | |
306 | |
307 (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) | |
308 (deftype user-system () '(and system (satisfies user-system-p)))) | |
309 | |
310 ;;; | |
311 ;;; First we handle monolithic bundles. | |
312 ;;; These are standalone systems which contain everything, | |
313 ;;; including other ASDF systems required by the current one. | |
314 ;;; A PROGRAM is always monolithic. | |
315 ;;; | |
316 ;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL | |
317 ;;; | |
318 (with-upgradability () | |
319 (defun direct-dependency-files (o c &key (test 'identity) (key 'output… | |
320 ;; This function selects output files from direct dependencies; | |
321 ;; your component-depends-on method must gather the correct dependen… | |
322 (while-collecting (collect) | |
323 (map-direct-dependencies | |
324 t o c #'(lambda (sub-o sub-c) | |
325 (loop :for f :in (funcall key sub-o sub-c) | |
326 :when (funcall test f) :do (collect f)))))) | |
327 | |
328 (defun pathname-type-equal-function (type) | |
329 #'(lambda (p) (equalp (pathname-type p) type))) | |
330 | |
331 (defmethod input-files ((o gather-operation) (c system)) | |
332 (unless (eq (bundle-type o) :no-output-file) | |
333 (direct-dependency-files | |
334 o c :key 'output-files | |
335 :test (pathname-type-equal-function (bundle-pathname-type (ga… | |
336 | |
337 ;; Find the operation that produces a given bundle-type | |
338 (defun select-bundle-operation (type &optional monolithic) | |
339 (ecase type | |
340 ((:dll :shared-library) | |
341 (if monolithic 'monolithic-dll-op 'dll-op)) | |
342 ((:lib :static-library) | |
343 (if monolithic 'monolithic-lib-op 'lib-op)) | |
344 ((:fasl) | |
345 (if monolithic 'monolithic-compile-bundle-op 'compile-bundle-op)) | |
346 ((:image) | |
347 'image-op) | |
348 ((:program) | |
349 'program-op)))) | |
350 | |
351 ;;; | |
352 ;;; LOAD-BUNDLE-OP | |
353 ;;; | |
354 ;;; This is like ASDF's LOAD-OP, but using bundle fasl files. | |
355 ;;; | |
356 (with-upgradability () | |
357 (defmethod component-depends-on ((o load-bundle-op) (c system)) | |
358 `((,o ,@(component-sideway-dependencies c)) | |
359 (,(if (user-system-p c) 'compile-bundle-op 'load-op) ,c) | |
360 ,@(call-next-method))) | |
361 | |
362 (defmethod input-files ((o load-bundle-op) (c system)) | |
363 (when (user-system-p c) | |
364 (output-files (find-operation o 'compile-bundle-op) c))) | |
365 | |
366 (defmethod perform ((o load-bundle-op) (c system)) | |
367 (when (input-files o c) | |
368 (perform-lisp-load-fasl o c))) | |
369 | |
370 (defmethod mark-operation-done :after ((o load-bundle-op) (c system)) | |
371 (mark-operation-done (find-operation o 'load-op) c))) | |
372 | |
373 ;;; | |
374 ;;; PRECOMPILED FILES | |
375 ;;; | |
376 ;;; This component can be used to distribute ASDF systems in precompiled… | |
377 ;;; Only useful when the dependencies have also been precompiled. | |
378 ;;; | |
379 (with-upgradability () | |
380 (defmethod trivial-system-p ((s system)) | |
381 (every #'(lambda (c) (typep c 'compiled-file)) (component-children s… | |
382 | |
383 (defmethod input-files ((o operation) (c compiled-file)) | |
384 (list (component-pathname c))) | |
385 (defmethod perform ((o load-op) (c compiled-file)) | |
386 (perform-lisp-load-fasl o c)) | |
387 (defmethod perform ((o load-source-op) (c compiled-file)) | |
388 (perform (find-operation o 'load-op) c)) | |
389 (defmethod perform ((o operation) (c compiled-file)) | |
390 nil)) | |
391 | |
392 ;;; | |
393 ;;; Pre-built systems | |
394 ;;; | |
395 (with-upgradability () | |
396 (defmethod trivial-system-p ((s prebuilt-system)) | |
397 t) | |
398 | |
399 (defmethod perform ((o link-op) (c prebuilt-system)) | |
400 nil) | |
401 | |
402 (defmethod perform ((o basic-compile-bundle-op) (c prebuilt-system)) | |
403 nil) | |
404 | |
405 (defmethod perform ((o lib-op) (c prebuilt-system)) | |
406 nil) | |
407 | |
408 (defmethod perform ((o dll-op) (c prebuilt-system)) | |
409 nil) | |
410 | |
411 (defmethod component-depends-on ((o gather-operation) (c prebuilt-syst… | |
412 nil) | |
413 | |
414 (defmethod output-files ((o lib-op) (c prebuilt-system)) | |
415 (values (list (prebuilt-system-static-library c)) t))) | |
416 | |
417 | |
418 ;;; | |
419 ;;; PREBUILT SYSTEM CREATOR | |
420 ;;; | |
421 (with-upgradability () | |
422 (defmethod output-files ((o deliver-asd-op) (s system)) | |
423 (list (make-pathname :name (component-name s) :type "asd" | |
424 :defaults (component-pathname s)))) | |
425 | |
426 (defmethod perform ((o deliver-asd-op) (s system)) | |
427 (let* ((inputs (input-files o s)) | |
428 (fasl (first inputs)) | |
429 (library (second inputs)) | |
430 (asd (first (output-files o s))) | |
431 (name (if (and fasl asd) (pathname-name asd) (return-from per… | |
432 (version (component-version s)) | |
433 (dependencies | |
434 (if (operation-monolithic-p o) | |
435 ;; We want only dependencies, and we use basic-load-op … | |
436 ;; this will keep working on systems when *load-system-… | |
437 (remove-if-not 'builtin-system-p | |
438 (required-components s :component-type '… | |
439 :keep-operation '… | |
440 (while-collecting (x) ;; resolve the sideway-dependenci… | |
441 (map-direct-dependencies | |
442 t 'load-op s | |
443 #'(lambda (o c) | |
444 (when (and (typep o 'load-op) (typep c 'system)) | |
445 (x c))))))) | |
446 (depends-on (mapcar 'coerce-name dependencies))) | |
447 (when (pathname-equal asd (system-source-file s)) | |
448 (cerror "overwrite the asd file" | |
449 "~/asdf-action:format-action/ is going to overwrite the … | |
450 which is probably not what you want; you probably need to tweak your out… | |
451 (cons o s) asd)) | |
452 (with-open-file (s asd :direction :output :if-exists :supersede | |
453 :if-does-not-exist :create) | |
454 (format s ";;; Prebuilt~:[~; monolithic~] ASDF definition for sy… | |
455 (operation-monolithic-p o) name) | |
456 (format s ";;; Built for ~A ~A on a ~A/~A ~A~%" | |
457 (lisp-implementation-type) | |
458 (lisp-implementation-version) | |
459 (software-type) | |
460 (machine-type) | |
461 (software-version)) | |
462 (let ((*package* (find-package :asdf-user))) | |
463 (pprint `(defsystem ,name | |
464 :class prebuilt-system | |
465 :version ,version | |
466 :depends-on ,depends-on | |
467 :components ((:compiled-file ,(pathname-name fasl))) | |
468 ,@(when library `(:lib ,(file-namestring library)))) | |
469 s) | |
470 (terpri s))))) | |
471 | |
472 #-(or clasp ecl mkcl) | |
473 (defmethod perform ((o basic-compile-bundle-op) (c system)) | |
474 (let* ((input-files (input-files o c)) | |
475 (fasl-files (remove (compile-file-type) input-files :key #'pa… | |
476 (non-fasl-files (remove (compile-file-type) input-files :key … | |
477 (output-files (output-files o c)) | |
478 (output-file (first output-files))) | |
479 (assert (eq (not input-files) (not output-files))) | |
480 (when input-files | |
481 (when non-fasl-files | |
482 (error "On ~A, asdf/bundle can only bundle FASL files, but the… | |
483 (implementation-type) non-fasl-files)) | |
484 (when (or (prologue-code c) (epilogue-code c)) | |
485 (error "prologue-code and epilogue-code are not supported on ~… | |
486 (implementation-type))) | |
487 (with-staging-pathname (output-file) | |
488 (combine-fasls fasl-files output-file))))) | |
489 | |
490 (defmethod input-files ((o load-op) (s precompiled-system)) | |
491 (bundle-output-files (find-operation o 'compile-bundle-op) s)) | |
492 | |
493 (defmethod perform ((o load-op) (s precompiled-system)) | |
494 (perform-lisp-load-fasl o s)) | |
495 | |
496 (defmethod component-depends-on ((o load-bundle-op) (s precompiled-sys… | |
497 #+xcl (declare (ignorable o)) | |
498 `((load-op ,s) ,@(call-next-method)))) | |
499 | |
500 #| ;; Example use: | |
501 (asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system … | |
502 (asdf:load-system :precompiled-asdf-utils) | |
503 |# | |
504 | |
505 #+(or clasp ecl mkcl) | |
506 (with-upgradability () | |
507 | |
508 #+ecl ;; doesn't work on clasp or mkcl (yet?). | |
509 (unless (use-ecl-byte-compiler-p) | |
510 (setf *load-system-operation* 'load-bundle-op)) | |
511 | |
512 (defun system-module-pathname (module) | |
513 (let ((name (coerce-name module))) | |
514 (some | |
515 'file-exists-p | |
516 (list | |
517 #+clasp (compile-file-pathname (make-pathname :name name :defaul… | |
518 #+ecl (compile-file-pathname (make-pathname :name name :defaults… | |
519 #+ecl (compile-file-pathname (make-pathname :name name :defaults… | |
520 #+mkcl (make-pathname :name name :type (bundle-pathname-type :li… | |
521 #+mkcl (make-pathname :name name :type (bundle-pathname-type :li… | |
522 | |
523 (defun make-prebuilt-system (name &optional (pathname (system-module-p… | |
524 "Creates a prebuilt-system if PATHNAME isn't NIL." | |
525 (when pathname | |
526 (make-instance 'prebuilt-system | |
527 :name (coerce-name name) | |
528 :static-library (resolve-symlinks* pathname)))) | |
529 | |
530 (defmethod component-depends-on :around ((o image-op) (c system)) | |
531 (destructuring-bind ((lib-op . deps)) (call-next-method) | |
532 (labels ((has-it-p (x) (find x deps :test 'equal :key 'coerce-name… | |
533 (ensure-linkable-system (x) | |
534 (unless (has-it-p x) | |
535 (or (if-let (s (find-system x)) | |
536 (and (system-source-directory x) | |
537 (list s))) | |
538 (if-let (p (system-module-pathname x)) | |
539 (list (make-prebuilt-system x p))))))) | |
540 `((,lib-op | |
541 ,@(unless (no-uiop c) | |
542 (append (ensure-linkable-system "cmp") | |
543 (or (ensure-linkable-system "uiop") | |
544 (ensure-linkable-system "asdf")))) | |
545 ,@deps))))) | |
546 | |
547 (defmethod perform ((o link-op) (c system)) | |
548 (let* ((object-files (input-files o c)) | |
549 (output (output-files o c)) | |
550 (bundle (first output)) | |
551 (programp (typep o 'program-op)) | |
552 (kind (bundle-type o))) | |
553 (when output | |
554 (apply 'create-image | |
555 bundle (append | |
556 (when programp (prefix-lisp-object-files c)) | |
557 object-files | |
558 (when programp (postfix-lisp-object-files c))) | |
559 :kind kind | |
560 :prologue-code (when programp (prologue-code c)) | |
561 :epilogue-code (when programp (epilogue-code c)) | |
562 :build-args (when programp (extra-build-args c)) | |
563 :extra-object-files (when programp (extra-object-files c)) | |
564 :no-uiop (no-uiop c) | |
565 (when programp `(:entry-point ,(component-entry-point c))… |