mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-14 13:21:54 -08:00
asdf-bundle.lisp is no longer needed, since asdf.lisp integrates it.
This commit is contained in:
Juanjo Garcia-Ripoll
parent
343a73841b
commit
183762db91
2 changed files with 1 additions and 638 deletions
|
|
@ -1,636 +0,0 @@
|
|||
;;; -*- Mode: Lisp ; Syntax: ANSI-Common-Lisp -*-
|
||||
|
||||
#+xcvb (module ())
|
||||
|
||||
(in-package :asdf)
|
||||
|
||||
#+mkcl
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
;; Make sure we have strict ANSI class redefinition semantics.
|
||||
(setq clos::*redefine-class-in-place* t))
|
||||
|
||||
;;;
|
||||
;;; BUNDLE-OP
|
||||
;;;
|
||||
;;; This operation takes all components from one or more systems and
|
||||
;;; creates a single output file, which may be
|
||||
;;; a FASL, a statically linked library, a shared library, etc.
|
||||
;;; The different targets are defined by specialization.
|
||||
;;;
|
||||
|
||||
(defun fasl-type ()
|
||||
"pathname TYPE for lisp FASt Loading files"
|
||||
(#-ecl load-time-value #+ecl identity
|
||||
(pathname-type (compile-file-pathname "foo.lisp"))))
|
||||
|
||||
(defclass bundle-op (operation)
|
||||
((build-args :initarg :args :initform nil :accessor bundle-op-build-args)
|
||||
(name-suffix :initarg :name-suffix :initform nil)
|
||||
#+ecl (type :reader bundle-op-type)
|
||||
#+ecl (lisp-files :initform nil :accessor bundle-op-lisp-files)
|
||||
#+mkcl (do-fasb :initarg :do-fasb :initform t :reader bundle-op-do-fasb-p)
|
||||
#+mkcl (do-static-library :initarg :do-static-library :initform t :reader bundle-op-do-static-library-p)))
|
||||
|
||||
(defclass fasl-op (bundle-op)
|
||||
((type :initform :fasl)))
|
||||
|
||||
(defclass lib-op (bundle-op)
|
||||
((type :initform :lib)))
|
||||
|
||||
(defclass dll-op (bundle-op)
|
||||
((type :initform :dll)))
|
||||
|
||||
(defclass monolithic-bundle-op (bundle-op)
|
||||
((prologue-code :accessor monolithic-op-prologue-code)
|
||||
(epilogue-code :accessor monolithic-op-epilogue-code)))
|
||||
|
||||
(defun bundle-op-monolithic-p (op)
|
||||
(typep op 'monolithic-bundle-op))
|
||||
|
||||
(defclass monolithic-fasl-op (monolithic-bundle-op fasl-op) ())
|
||||
|
||||
(defclass monolithic-lib-op (monolithic-bundle-op lib-op)
|
||||
((type :initform :lib)))
|
||||
|
||||
(defclass monolithic-dll-op (monolithic-bundle-op dll-op)
|
||||
((type :initform :dll)))
|
||||
|
||||
(defclass program-op (monolithic-bundle-op)
|
||||
((type :initform :program)))
|
||||
|
||||
(defmethod initialize-instance :after ((instance bundle-op) &rest initargs
|
||||
&key (name-suffix nil name-suffix-p)
|
||||
&allow-other-keys)
|
||||
(declare (ignorable initargs name-suffix))
|
||||
(unless name-suffix-p
|
||||
(setf (slot-value instance 'name-suffix)
|
||||
(if (bundle-op-monolithic-p instance) ".system-and-dependencies" ".system")))
|
||||
(when (typep instance 'monolithic-bundle-op)
|
||||
(destructuring-bind (&rest original-initargs
|
||||
&key lisp-files prologue-code epilogue-code
|
||||
&allow-other-keys)
|
||||
(slot-value instance 'original-initargs)
|
||||
(setf (slot-value instance 'original-initargs)
|
||||
(remove-keys '(lisp-files epilogue-code prologue-code) original-initargs)
|
||||
(monolithic-op-prologue-code instance) prologue-code
|
||||
(monolithic-op-epilogue-code instance) epilogue-code)
|
||||
#-ecl (assert (null lisp-files))
|
||||
#+ecl (setf (bundle-op-lisp-files instance) lisp-files)))
|
||||
(setf (bundle-op-build-args instance)
|
||||
(remove-keys '(type monolithic name-suffix)
|
||||
(slot-value instance 'original-initargs))))
|
||||
|
||||
(defmethod bundle-op-build-args :around ((op lib-op))
|
||||
(declare (ignorable op))
|
||||
(let ((args (call-next-method)))
|
||||
(remf args :ld-flags)
|
||||
args))
|
||||
|
||||
(defvar *force-load-p* nil)
|
||||
|
||||
(defmethod operation-done-p :around ((operation load-op) c)
|
||||
(declare (ignorable operation c))
|
||||
(if *force-load-p* nil (call-next-method)))
|
||||
|
||||
(defun gather-components (op-type system &key filter-system filter-type include-self)
|
||||
;; This function creates a list of components,
|
||||
;; matched together with an operation.
|
||||
;; This list may be restricted to sub-components of SYSTEM
|
||||
;; if GATHER-ALL = NIL (default), and it may include the system itself.
|
||||
(let* ((operation (make-instance op-type))
|
||||
(*force-load-p* t)
|
||||
(tree (traverse (make-instance 'load-op) system)))
|
||||
(append
|
||||
(loop :for (op . component) :in tree
|
||||
:when (and (typep op 'load-op)
|
||||
(typep component filter-type)
|
||||
(or (not filter-system) (eq (component-system component) filter-system)))
|
||||
:collect (progn
|
||||
(when (eq component system) (setf include-self nil))
|
||||
(cons operation component)))
|
||||
(and include-self (list (cons operation system))))))
|
||||
|
||||
;;;
|
||||
;;; BUNDLE-SUB-OPERATIONS
|
||||
;;;
|
||||
;;; Builds a list of pairs (operation . component)
|
||||
;;; which contains all the dependencies of this bundle.
|
||||
;;; This list is used by TRAVERSE and also by INPUT-FILES.
|
||||
;;; The dependencies depend on the strategy, as explained below.
|
||||
;;;
|
||||
(defgeneric bundle-sub-operations (operation component))
|
||||
;;;
|
||||
;;; First we handle monolithic bundles.
|
||||
;;; These are standalone systems which contain everything,
|
||||
;;; including other ASDF systems required by the current one.
|
||||
;;; A PROGRAM is always monolithic.
|
||||
;;;
|
||||
;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL
|
||||
;;;
|
||||
;;; Gather the static libraries of all components.
|
||||
;;;
|
||||
(defmethod bundle-sub-operations ((o monolithic-bundle-op) c)
|
||||
(declare (ignorable o))
|
||||
(gather-components 'lib-op c :filter-type 'system :include-self t))
|
||||
|
||||
;;;
|
||||
;;; STATIC LIBRARIES
|
||||
;;;
|
||||
;;; Gather the object files of all components
|
||||
;;; and, if monolithic, also of systems and subsystems.
|
||||
;;;
|
||||
(defmethod bundle-sub-operations ((o lib-op) c)
|
||||
(gather-components 'compile-op c
|
||||
:filter-system (and (not (bundle-op-monolithic-p o)) c)
|
||||
:filter-type '(not system)))
|
||||
(defmethod bundle-sub-operations ((o monolithic-lib-op) c)
|
||||
(declare (ignorable o))
|
||||
(gather-components 'compile-op c
|
||||
:filter-system nil
|
||||
:filter-type '(not system)))
|
||||
;;;
|
||||
;;; SHARED LIBRARIES
|
||||
;;;
|
||||
;;; Gather the dynamically linked libraries of all components.
|
||||
;;; They will be linked into this new shared library,
|
||||
;;; together with the static library of this module.
|
||||
;;;
|
||||
(defmethod bundle-sub-operations ((o dll-op) c)
|
||||
(declare (ignorable o))
|
||||
(list (cons (make-instance 'lib-op) c)))
|
||||
;;;
|
||||
;;; FASL FILES
|
||||
;;;
|
||||
;;; Gather the statically linked library of this component.
|
||||
;;;
|
||||
(defmethod bundle-sub-operations ((o fasl-op) c)
|
||||
(declare (ignorable o))
|
||||
(list (cons (make-instance 'lib-op) c)))
|
||||
|
||||
#-mkcl
|
||||
(defmethod component-depends-on ((o bundle-op) (c system))
|
||||
(loop :for (op . dep) :in (bundle-sub-operations o c)
|
||||
:when (typep dep 'system)
|
||||
:collect (list (class-name (class-of op))
|
||||
(component-name dep))))
|
||||
|
||||
(defmethod component-depends-on ((o lib-op) (c system))
|
||||
(declare (ignorable o))
|
||||
(list (list 'compile-op (component-name c))))
|
||||
|
||||
(defmethod component-depends-on ((o bundle-op) c)
|
||||
(declare (ignorable o c))
|
||||
nil)
|
||||
|
||||
#-mkcl
|
||||
(defmethod input-files ((o bundle-op) (c system))
|
||||
(loop :for (sub-op . sub-c) :in (bundle-sub-operations o c)
|
||||
:nconc (output-files sub-op sub-c)))
|
||||
|
||||
#-mkcl
|
||||
(defmethod output-files ((o bundle-op) (c system))
|
||||
(list (compile-file-pathname
|
||||
(make-pathname
|
||||
:name (strcat (component-name c) (slot-value o 'name-suffix)
|
||||
#|"-" (string-downcase (implementation-type))|#)
|
||||
:type "lisp"
|
||||
:defaults (system-source-directory c))
|
||||
#+ecl :type #+ecl (bundle-op-type o))))
|
||||
|
||||
(defmethod perform ((o bundle-op) (c t))
|
||||
(declare (ignorable o c))
|
||||
t)
|
||||
|
||||
(defmethod operation-done-p ((o bundle-op) (c source-file))
|
||||
(declare (ignorable o c))
|
||||
t)
|
||||
|
||||
(defun select-operation (monolithic type)
|
||||
(ecase type
|
||||
((:binary)
|
||||
(if monolithic 'monolithic-binary-op 'binary-op))
|
||||
((:dll :shared-library)
|
||||
(if monolithic 'monolithic-dll-op 'dll-op))
|
||||
((:lib :static-library)
|
||||
(if monolithic 'monolithic-lib-op 'lib-op))
|
||||
((:fasl)
|
||||
(if monolithic 'monolithic-fasl-op 'fasl-op))
|
||||
((:program)
|
||||
'program-op)))
|
||||
|
||||
(defun make-build (system &rest args &key (monolithic nil) (type :fasl)
|
||||
(move-here nil move-here-p)
|
||||
&allow-other-keys)
|
||||
(let* ((operation-name (select-operation monolithic type))
|
||||
(move-here-path (if (and move-here
|
||||
(typep move-here '(or pathname string)))
|
||||
(pathname move-here)
|
||||
(merge-pathnames "./asdf-output/")))
|
||||
(operation (apply #'operate operation-name
|
||||
system
|
||||
(remove-keys '(monolithic type move-here) args)))
|
||||
(system (find-system system))
|
||||
(files (and system (output-files operation system))))
|
||||
(if (or move-here (and (null move-here-p)
|
||||
(member operation-name '(:program :binary))))
|
||||
(loop :with dest-path = (truename (ensure-directories-exist move-here-path))
|
||||
:for f :in files
|
||||
:for new-f = (make-pathname :name (pathname-name f)
|
||||
:type (pathname-type f)
|
||||
:defaults dest-path)
|
||||
:do (progn
|
||||
(when (probe-file new-f)
|
||||
(delete-file new-f))
|
||||
(rename-file f new-f))
|
||||
:collect new-f)
|
||||
files)))
|
||||
|
||||
;;;
|
||||
;;; LOAD-FASL-OP
|
||||
;;;
|
||||
;;; This is like ASDF's LOAD-OP, but using monolithic fasl files.
|
||||
;;;
|
||||
|
||||
(defclass load-fasl-op (operation) ())
|
||||
|
||||
(defmethod component-depends-on ((o load-fasl-op) (c system))
|
||||
(declare (ignorable o))
|
||||
(unless (trivial-system-p c)
|
||||
(subst 'load-fasl-op 'load-op
|
||||
(subst 'fasl-op 'compile-op
|
||||
(component-depends-on (make-instance 'load-op) c)))))
|
||||
|
||||
(defmethod input-files ((o load-fasl-op) (c system))
|
||||
(declare (ignore o))
|
||||
(unless (trivial-system-p c)
|
||||
(output-files (make-instance 'fasl-op) c)))
|
||||
|
||||
(defmethod perform ((o load-fasl-op) (c t))
|
||||
(declare (ignore o c))
|
||||
nil)
|
||||
|
||||
(defmethod perform ((o load-fasl-op) (c system))
|
||||
(let ((l (input-files o c)))
|
||||
(and l
|
||||
(load (first l))
|
||||
(loop :for i :in (module-components c)
|
||||
:do (setf (gethash 'load-op (component-operation-times i))
|
||||
(get-universal-time))))))
|
||||
|
||||
;;;
|
||||
;;; PRECOMPILED FILES
|
||||
;;;
|
||||
;;; This component can be used to distribute ASDF systems in precompiled form.
|
||||
;;; Only useful when the dependencies have also been precompiled.
|
||||
;;;
|
||||
|
||||
(defclass compiled-file (component)
|
||||
((type :initform nil)))
|
||||
|
||||
(defun trivial-system-p (c)
|
||||
(every #'(lambda (c) (typep c 'compiled-file)) (module-components c)))
|
||||
|
||||
(defmethod component-relative-pathname ((component compiled-file))
|
||||
(coerce-pathname
|
||||
(or (slot-value component 'relative-pathname)
|
||||
(component-name component))
|
||||
:type (fasl-type)
|
||||
:defaults (component-parent-pathname component)))
|
||||
|
||||
(defmethod output-files (o (c compiled-file))
|
||||
(declare (ignore o c))
|
||||
nil)
|
||||
(defmethod input-files (o (c compiled-file))
|
||||
(declare (ignore o c))
|
||||
nil)
|
||||
(defmethod perform ((o load-op) (c compiled-file))
|
||||
(declare (ignore o))
|
||||
(load (component-pathname c)))
|
||||
(defmethod perform ((o load-fasl-op) (c compiled-file))
|
||||
(declare (ignore o))
|
||||
(load (component-pathname c)))
|
||||
(defmethod perform (o (c compiled-file))
|
||||
(declare (ignore o c))
|
||||
nil)
|
||||
|
||||
;;;
|
||||
;;; Pre-built systems
|
||||
;;;
|
||||
(defclass prebuilt-system (system)
|
||||
((static-library :accessor prebuilt-system-static-library :initarg :lib)))
|
||||
|
||||
(defmethod output-files ((o lib-op) (c prebuilt-system))
|
||||
(declare (ignore o))
|
||||
(values (list (prebuilt-system-static-library c))
|
||||
t)) ; Advertise that we do not want this path renamed by asdf-output-translations
|
||||
|
||||
(defmethod perform ((o lib-op) (c prebuilt-system))
|
||||
(first (output-files o c)))
|
||||
|
||||
(defmethod component-depends-on ((o lib-op) (c prebuilt-system))
|
||||
(declare (ignorable o c))
|
||||
nil)
|
||||
|
||||
(defmethod bundle-sub-operations ((o lib-op) (c prebuilt-system))
|
||||
(declare (ignorable o c))
|
||||
nil)
|
||||
|
||||
(defmethod bundle-sub-operations ((o monolithic-lib-op) (c prebuilt-system))
|
||||
(declare (ignorable o))
|
||||
(error "Prebuilt system ~S shipped with ECL can not be used in a monolithic library operation." c))
|
||||
|
||||
(defmethod bundle-sub-operations ((o monolithic-bundle-op) (c prebuilt-system))
|
||||
(declare (ignorable o c))
|
||||
nil)
|
||||
|
||||
;;;
|
||||
;;; PREBUILT SYSTEM CREATOR
|
||||
;;;
|
||||
|
||||
(defclass binary-op (bundle-op)
|
||||
())
|
||||
|
||||
(defclass monolithic-binary-op (binary-op monolithic-bundle-op)
|
||||
())
|
||||
|
||||
(defun binary-op-dependencies (o s)
|
||||
(multiple-value-bind (lib-op fasl-op)
|
||||
(if (bundle-op-monolithic-p o)
|
||||
(values 'monolithic-lib-op 'monolithic-fasl-op)
|
||||
(values 'lib-op 'fasl-op))
|
||||
(list (list (make-instance lib-op :args (bundle-op-build-args o))
|
||||
s)
|
||||
(list (make-instance fasl-op :args (bundle-op-build-args o))
|
||||
s))))
|
||||
|
||||
(defmethod component-depends-on ((o binary-op) (s system))
|
||||
(loop :for dep :in (binary-op-dependencies o s)
|
||||
:append (apply #'component-depends-on dep)))
|
||||
|
||||
(defmethod input-files ((o binary-op) (s system))
|
||||
(loop :for dep :in (binary-op-dependencies o s)
|
||||
:append (apply #'input-files dep)))
|
||||
|
||||
(defmethod output-files ((o binary-op) (s system))
|
||||
(list* (merge-pathnames* (make-pathname :name (component-name s)
|
||||
:type "asd")
|
||||
(component-relative-pathname s))
|
||||
(loop :for dep :in (binary-op-dependencies o s)
|
||||
:append (apply #'output-files dep))))
|
||||
|
||||
(defmethod perform ((o binary-op) (s system))
|
||||
(let* ((dependencies (binary-op-dependencies o s))
|
||||
(library (first (apply #'output-files (first dependencies))))
|
||||
(fasl (first (apply #'output-files (second dependencies))))
|
||||
(filename (first (output-files o s)))
|
||||
(name (component-name s))
|
||||
(name-keyword (intern (string name) (find-package :keyword))))
|
||||
(dolist (dep dependencies)
|
||||
(apply #'perform dep))
|
||||
(with-open-file (s filename :direction :output :if-exists :supersede
|
||||
:if-does-not-exist :create)
|
||||
(format s ";;; Prebuilt ASDF definition for system ~A" name)
|
||||
(format s ";;; Built for ~A ~A on a ~A/~A ~A"
|
||||
(lisp-implementation-type)
|
||||
(lisp-implementation-version)
|
||||
(software-type)
|
||||
(machine-type)
|
||||
(software-version))
|
||||
(let ((*package* (find-package :keyword)))
|
||||
(pprint `(defsystem ,name-keyword
|
||||
:class asdf::prebuilt-system
|
||||
:components ((:compiled-file ,(pathname-name fasl)))
|
||||
:lib ,(make-pathname :name (pathname-name library)
|
||||
:type (pathname-type library)))
|
||||
s)))))
|
||||
|
||||
(defun copy-stream-to-stream (input output &key (element-type 'character) (buffer-size 8192))
|
||||
"Copy the contents of the INPUT stream into the OUTPUT stream,
|
||||
using WRITE-SEQUENCE and a sensibly sized buffer." ; copied from xcvb-driver
|
||||
(with-open-stream (input input)
|
||||
(loop
|
||||
:for buffer = (make-array (list buffer-size) :element-type element-type)
|
||||
:for end = (read-sequence buffer input)
|
||||
:until (zerop end)
|
||||
:do (write-sequence buffer output :end end)
|
||||
(when (< end buffer-size) (return)))))
|
||||
|
||||
(defun concatenate-files (inputs output)
|
||||
(with-open-file (o output :element-type '(unsigned-byte 8)
|
||||
:direction :output :if-exists :rename-and-delete)
|
||||
(dolist (input inputs)
|
||||
(with-open-file (i input :element-type '(unsigned-byte 8)
|
||||
:direction :input :if-does-not-exist :error)
|
||||
(copy-stream-to-stream i o :element-type '(unsigned-byte 8))))))
|
||||
|
||||
(defun* add-pathname-suffix (pathname suffix)
|
||||
(make-pathname :name (strcat (pathname-name pathname) suffix)
|
||||
:defaults pathname))
|
||||
|
||||
(defun combine-fasls (inputs output)
|
||||
#-(or allegro clisp clozure cmu lispworks sbcl scl)
|
||||
(declare (ignore inputs output))
|
||||
#-(or allegro clisp clozure cmu lispworks sbcl scl)
|
||||
(error "~S is not supported on ~A" 'combine-fasls (implementation-type))
|
||||
#+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede)
|
||||
#+(or allegro clisp cmu sbcl scl) (concatenate-files inputs output)
|
||||
#+lispworks
|
||||
(let (fasls)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(loop :for i :in inputs
|
||||
:for n :from 1
|
||||
:for f = (add-pathname-suffix
|
||||
output (format nil "-FASL~D" n))
|
||||
:do (lispworks:copy-file i f)
|
||||
(push f fasls))
|
||||
(ignore-errors (lispworks:delete-system :fasls-to-concatenate))
|
||||
(eval `(scm:defsystem :fasls-to-concatenate
|
||||
(:default-pathname ,(pathname-directory-pathname output))
|
||||
:members
|
||||
,(loop :for f :in (reverse fasls)
|
||||
:collect `(,(namestring f) :load-only t))))
|
||||
(scm:concatenate-system output :fasls-to-concatenate))
|
||||
(loop :for f :in fasls :do (ignore-errors (delete-file f)))
|
||||
(ignore-errors (lispworks:delete-system :fasls-to-concatenate)))))
|
||||
|
||||
(defun call-with-staging-pathname (pathname fun)
|
||||
"Calls fun with a staging pathname, and atomically
|
||||
renames the staging pathname to the pathname in the end.
|
||||
Note: this protects only against failure of the program,
|
||||
not against concurrent attempts.
|
||||
For the latter case, we ought pick random suffix and atomically open it."
|
||||
(let* ((pathname (pathname pathname))
|
||||
(staging (add-pathname-suffix pathname "-ASDF-TMP")))
|
||||
(unwind-protect
|
||||
(multiple-value-prog1
|
||||
(funcall fun staging)
|
||||
(rename-file staging pathname #+clozure :if-exists #+clozure :rename-and-delete))
|
||||
(when (probe-file* staging)
|
||||
(delete-file staging)))))
|
||||
|
||||
(defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body)
|
||||
`(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body)))
|
||||
|
||||
#-(or ecl mkcl)
|
||||
(defmethod perform ((o bundle-op) (c system))
|
||||
(let* ((input-files (input-files o c))
|
||||
(fasl-files (remove (fasl-type) input-files :key #'pathname-type :test-not #'string=))
|
||||
(non-fasl-files (remove (fasl-type) input-files :key #'pathname-type :test #'string=))
|
||||
(output-files (output-files o c))
|
||||
(output-file (first output-files)))
|
||||
(when input-files
|
||||
(assert output-files)
|
||||
(when non-fasl-files
|
||||
(error "On ~A, asdf-bundle can only bundle FASL files, but these were also produced: ~S"
|
||||
(implementation-type) non-fasl-files))
|
||||
(when (and (typep o 'monolithic-bundle-op)
|
||||
(or (monolithic-op-prologue-code o) (monolithic-op-epilogue-code o)))
|
||||
(error "prologue-code and epilogue-code are not supported on ~A"
|
||||
(implementation-type)))
|
||||
(ensure-directories-exist output-file)
|
||||
(with-staging-pathname (output-file)
|
||||
(combine-fasls fasl-files output-file)))))
|
||||
|
||||
(defmethod output-files ((o fasl-op) (c source-file))
|
||||
(declare (ignorable o c))
|
||||
nil)
|
||||
|
||||
(defmethod input-files ((o fasl-op) (c source-file))
|
||||
(declare (ignorable o c))
|
||||
nil)
|
||||
|
||||
(defclass precompiled-system (system)
|
||||
((fasl :initarg :fasl :reader %system-fasl)))
|
||||
|
||||
(defgeneric system-fasl (system)
|
||||
(:method ((system precompiled-system))
|
||||
(let* ((f (%system-fasl system))
|
||||
(p (etypecase f
|
||||
((or pathname string) f)
|
||||
(function (funcall f))
|
||||
(cons (eval f)))))
|
||||
(pathname p))))
|
||||
|
||||
(defmethod input-files ((o load-op) (s precompiled-system))
|
||||
(declare (ignorable o))
|
||||
(list (system-fasl s)))
|
||||
|
||||
(defmethod perform ((o load-op) (s precompiled-system))
|
||||
(declare (ignorable o))
|
||||
(load (system-fasl s)))
|
||||
|
||||
(defmethod input-files ((o load-fasl-op) (s precompiled-system))
|
||||
(declare (ignorable o))
|
||||
(input-files (make-instance 'load-op) s))
|
||||
|
||||
(defmethod perform ((o load-fasl-op) (s precompiled-system))
|
||||
(declare (ignorable o))
|
||||
(perform (make-instance 'load-op) s))
|
||||
|
||||
#| ;; Example use:
|
||||
(asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system :fasl (asdf:apply-output-translations (asdf:system-relative-pathname :asdf-utils "asdf-utils.system.fasl")))
|
||||
(asdf:load-system :precompiled-asdf-utils)
|
||||
|#
|
||||
|
||||
#+ecl
|
||||
(defmethod output-files ((o fasl-op) (c system))
|
||||
(declare (ignorable o c))
|
||||
(loop :for file :in (call-next-method)
|
||||
:collect (make-pathname :type "fasb" :defaults file)))
|
||||
|
||||
#+ecl
|
||||
(defmethod perform ((o bundle-op) (c system))
|
||||
(let* ((object-files (remove "fas" (input-files o c)
|
||||
:key #'pathname-type :test #'string=))
|
||||
(output (output-files o c)))
|
||||
(ensure-directories-exist (first output))
|
||||
(apply #'c::builder (bundle-op-type o) (first output)
|
||||
:lisp-files (append object-files (bundle-op-lisp-files o))
|
||||
(append (bundle-op-build-args o)
|
||||
(when (and (typep o 'monolithic-bundle-op)
|
||||
(monolithic-op-prologue-code o))
|
||||
`(:prologue-code ,(monolithic-op-prologue-code o)))
|
||||
(when (and (typep o 'monolithic-bundle-op)
|
||||
(monolithic-op-epilogue-code o))
|
||||
`(:epilogue-code ,(monolithic-op-epilogue-code o)))))))
|
||||
|
||||
#+mkcl
|
||||
(progn
|
||||
;;;
|
||||
;;; BUNDLE-SUB-OPERATIONS
|
||||
;;;
|
||||
;;; Builds a list of pairs (operation . component) which contains all the
|
||||
;;; dependencies of this bundle.
|
||||
;;;
|
||||
|
||||
(defun mkcl-bundle-sub-operations (sys)
|
||||
(gather-components 'compile-op sys
|
||||
:filter-system sys
|
||||
:filter-type '(not system)))
|
||||
|
||||
(defun files-to-bundle (sys)
|
||||
(loop :for (op . comp) :in (mkcl-bundle-sub-operations sys)
|
||||
:for sub-files = (output-files op comp)
|
||||
:when sub-files
|
||||
:collect (first sub-files)))
|
||||
|
||||
(defmethod component-depends-on ((o bundle-op) (c system))
|
||||
(cons `(compile-op ,(component-name c)) (call-next-method)))
|
||||
|
||||
(defmethod output-files ((o bundle-op) (c system))
|
||||
(let* ((name (component-name c))
|
||||
(static-lib-name (merge-pathnames
|
||||
(compiler::builder-internal-pathname name :static-library)
|
||||
(component-relative-pathname c)))
|
||||
(fasl-bundle-name (merge-pathnames
|
||||
(compiler::builder-internal-pathname name :fasb)
|
||||
(component-relative-pathname c))))
|
||||
(list static-lib-name fasl-bundle-name)))
|
||||
|
||||
(defmethod perform ((o bundle-op) (c system))
|
||||
(let* ((object-files (files-to-bundle c))
|
||||
(output (output-files o c)))
|
||||
(ensure-directories-exist (first output))
|
||||
(when (bundle-op-do-static-library-p o)
|
||||
(apply #'compiler::build-static-library (first output)
|
||||
:lisp-object-files object-files (bundle-op-build-args o)))
|
||||
(when (bundle-op-do-fasb-p o)
|
||||
(apply #'compiler::build-bundle (second output)
|
||||
:lisp-object-files object-files (bundle-op-build-args o)))))
|
||||
|
||||
(defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys)
|
||||
(declare (ignore force verbose version))
|
||||
(apply #'operate 'bundle-op system args))
|
||||
|
||||
;;;
|
||||
;;; BUNDLED FILES
|
||||
;;;
|
||||
;;; This component can be used to distribute ASDF libraries in bundled form.
|
||||
;;;
|
||||
|
||||
(defclass bundle (component) ())
|
||||
|
||||
(defmethod source-file-type ((c bundle) (s system))
|
||||
"fasb")
|
||||
|
||||
(defmethod perform ((o load-op) (c bundle))
|
||||
(load (component-pathname c)))
|
||||
|
||||
(defmethod perform (o (c bundle))
|
||||
(declare (ignore o))
|
||||
nil)
|
||||
|
||||
;; The ability to load a fasb bundle is separate from
|
||||
;; the ability to build a fasb bundle, so this is somewhat unrelated to what is above.
|
||||
);mkcl
|
||||
|
||||
;;;
|
||||
;;; Final integration steps
|
||||
;;;
|
||||
|
||||
(export '(load-fasl-op precompiled-system
|
||||
#+ecl make-build #+mkcl bundle-system))
|
||||
|
||||
#+(or ecl mkcl)
|
||||
(pushnew '("fasb" . si::load-binary) si:*load-hooks* :test 'equal :key 'car)
|
||||
|
|
@ -221,8 +221,7 @@
|
|||
;;;
|
||||
#+WANTS-ASDF
|
||||
(build-module "asdf"
|
||||
'("ext:asdf;asdf.lisp"
|
||||
"ext:asdf;asdf-bundle.lisp")
|
||||
'("ext:asdf;asdf.lisp")
|
||||
:dir "build:ext;"
|
||||
:prefix "EXT"
|
||||
:builtin #+:BUILTIN-ASDF t #-:BUILTIN-ASDF nil)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue