Commit 5f7af391 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

2.26.7: Merge asdf-bundle into asdf.

parent b541e0bb
......@@ -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 ()
((:file "asdf")))
;;; -*- 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 <>.
......@@ -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 @@
#:inherit-source-registry #:process-source-registry
#:compile-file* #:source-file-type)
#:compile-file* #:source-file-type #:trivial-system-p)
(#:*asdf-revision* #:around #:asdf-method-combination
#:split #:make-collector #:do-dep #:do-one-dep
......@@ -362,6 +362,8 @@
#: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)))
(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)))
(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)))
(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*)))
......@@ -4499,6 +4529,600 @@ with a different configuration, so the configuration would be re-read then."
(setf *ignored-configuration-form* nil))
;;; 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)
(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
(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)
(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)))
(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))))))
;;; 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.
;;; 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))
;;; 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)))
;;; 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)))
;;; 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)))
(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))
(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)))
(defmethod output-files ((o bundle-op) (c system))
(list (compile-file-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))
(defmethod operation-done-p ((o bundle-op) (c source-file))
(declare (ignorable o c))
(defun select-operation (monolithic type)
(ecase type
(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))
(if monolithic 'monolithic-fasl-op 'fasl-op))
(defun make-build (system &rest args &key (monolithic nil) (type :fasl)
(move-here nil move-here-p)
(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
(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)
;;; 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))
(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))
;;; 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))
(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))
(defmethod input-files (o (c compiled-file))
(declare (ignore o c))
(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))
;;; 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))
(defmethod bundle-sub-operations ((o lib-op) (c prebuilt-system))
(declare (ignorable o c))
(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))
(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))
(list (make-instance fasl-op :args (bundle-op-build-args o))
(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"
(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)))
(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)
: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)
(let (fasls)
(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))
,(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"
(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))
(defmethod input-files ((o fasl-op) (c source-file))
(declare (ignorable o c))
(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)