From 5f7af391ecf6a2e1a43aaa442ffe74bacf66e514 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <tunes@google.com> Date: Thu, 6 Dec 2012 07:44:20 -0500 Subject: [PATCH] 2.26.7: Merge asdf-bundle into asdf. --- asdf.asd | 2 +- asdf.lisp | 646 +++++++++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 637 insertions(+), 11 deletions(-) diff --git a/asdf.asd b/asdf.asd index 9d13df84..6f753250 100644 --- a/asdf.asd +++ b/asdf.asd @@ -14,7 +14,7 @@ :licence "MIT" :description "Another System Definition Facility" :long-description "ASDF builds Common Lisp software organized into defined systems." - :version "2.26.6" ;; to be automatically updated by bin/bump-revision + :version "2.26.7" ;; to be automatically updated by bin/bump-revision :depends-on () :components ((:file "asdf"))) diff --git a/asdf.lisp b/asdf.lisp index 670c0d5b..bcbf0604 100644 --- a/asdf.lisp +++ b/asdf.lisp @@ -1,5 +1,5 @@ ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- -;;; This is ASDF 2.26.6: Another System Definition Facility. +;;; This is ASDF 2.26.7: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel@common-lisp.net>. @@ -118,7 +118,7 @@ ;; "2.345.6" would be a development version in the official upstream ;; "2.345.0.7" would be your seventh local modification of official release 2.345 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 - (asdf-version "2.26.6") + (asdf-version "2.26.7") (existing-asdf (find-class 'component nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) @@ -239,7 +239,7 @@ #:system-relative-pathname #:inherit-source-registry #:process-source-registry #:process-source-registry-directive - #:compile-file* #:source-file-type) + #:compile-file* #:source-file-type #:trivial-system-p) :unintern (#:*asdf-revision* #:around #:asdf-method-combination #:split #:make-collector #:do-dep #:do-one-dep @@ -362,6 +362,8 @@ #:system-source-registry #:user-source-registry-directory #:system-source-registry-directory + #:load-fasl-op #:precompiled-system + #+ecl #:make-build #+mkcl #:bundle-system ;; Utilities: please use asdf-utils instead #| @@ -1022,6 +1024,31 @@ with given pathname and if it exists return its truename." :defaults pathname))) pathname))) +(defun* add-pathname-suffix (pathname suffix) + (make-pathname :name (strcat (pathname-name pathname) suffix) + :defaults pathname)) + +(defun* tmpize-pathname (x) + (add-pathname-suffix x "-ASDF-TMP")) + +(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 (tmpize-pathname pathname))) + (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))) + ;;;; ------------------------------------------------------------------------- ;;;; ASDF Interface, in terms of generic functions. (defgeneric* find-system (system &optional error-p)) @@ -3913,10 +3940,16 @@ effectively disabling the output translation facility." (mapcar #'apply-output-translations files))) t)) +(defun fasl-type (&rest keys) + "pathname TYPE for lisp FASt Loading files" + (declare (ignorable keys)) + #-ecl (load-time-value (pathname-type (compile-file-pathname "foo.lisp"))) + #+ecl (pathname-type (apply 'compile-file-pathname "foo.lisp" keys))) + (defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys) (if (absolute-pathname-p output-file) ;; what cfp should be doing, w/ mp* instead of mp - (let* ((type (pathname-type (apply 'compile-file-pathname "x.lisp" keys))) + (let* ((type (pathname-type (apply 'fasl-type keys))) (defaults (make-pathname :type type :defaults (merge-pathnames* input-file)))) (merge-pathnames* output-file defaults)) @@ -3924,9 +3957,6 @@ effectively disabling the output translation facility." (apply 'compile-file-pathname input-file (if output-file keys (remove-keyword :output-file keys)))))) -(defun* tmpize-pathname (x) - (make-pathname :name (strcat "ASDF-TMP-" (pathname-name x)) :defaults x)) - (defun* delete-file-if-exists (x) (when (and x (probe-file* x)) (delete-file x))) @@ -4013,7 +4043,7 @@ call that function where you would otherwise have loaded and configured A-B-L.") #+(or clisp ecl mkcl) (when (null map-all-source-files) (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL")) - (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp"))) + (let* ((fasl-type (fasl-type)) (mapped-files (if map-all-source-files *wild-file* (make-pathname :type fasl-type :defaults *wild-file*))) (destination-directory @@ -4499,6 +4529,600 @@ with a different configuration, so the configuration would be re-read then." (clear-configuration) (setf *ignored-configuration-form* nil)) +;;; +;;; 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. +;;; + + +(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) ()) + +(defgeneric trivial-system-p (component)) + +(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))) + +(defmethod trivial-system-p ((s module)) + (every #'(lambda (c) (typep c 'compiled-file)) (module-components s))) + +(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 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))))) + +#-(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 + + + ;;;; ----------------------------------------------------------------- ;;;; Done! (when *load-verbose* @@ -4513,14 +5137,16 @@ with a different configuration, so the configuration would be re-read then." (load-system "asdf-bundle")) (error (e) (format *error-output* - "~&;;; ASDF: Failed to load package 'asdf-bundle'!~%;;; ~A~%" - e))) + "~&;;; ASDF: Failed to load package 'asdf-bundle'!~%;;; ~A~%" e))) #+allegro (eval-when (:compile-toplevel :execute) (when (boundp 'excl:*warn-on-nested-reader-conditionals*) (setf excl:*warn-on-nested-reader-conditionals* *acl-warn-save*))) +#+(or ecl mkcl) +(pushnew '("fasb" . si::load-binary) si:*load-hooks* :test 'equal :key 'car) + (pushnew :asdf *features*) (pushnew :asdf2 *features*) -- GitLab