GopherProxy

	tbundle.lisp - clic - Clic is an command line interactive client for gopher wri…
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	tbundle.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))…