Updated asdf to 2.26.6 along with asdf-bundle.
authorJean-Claude Beaudoin <jean.claude.beaudoin@gmail.com>
Mon, 3 Dec 2012 07:18:29 +0000 (02:18 -0500)
committerJean-Claude Beaudoin <jean.claude.beaudoin@gmail.com>
Mon, 3 Dec 2012 07:18:29 +0000 (02:18 -0500)
contrib/asdf-bundle/asdf-bundle.asd
contrib/asdf-bundle/asdf-bundle.lisp [new file with mode: 0644]
contrib/asdf-bundle/build.xcvb
contrib/asdf/asdf.lisp

index fcf5f07..05af176 100644 (file)
@@ -1,8 +1,8 @@
 ;;; -*- Mode: Lisp ; Syntax: ANSI-Common-Lisp -*-
-;;; ASDF-Bundle, extension to ASDF to build "bundles",
+;;; ASDF-Bundle, an extension to ASDF to build "bundles",
 ;;; such as one big fasl or DLL for an entire system, or an executable.
 ;;;
-;;; Based on the asdf-ecl extension
+;;; Initially based on the asdf-ecl extension
 ;;; by Michael Goffioul and Juan Jose Garcia Ripoll.
 ;;;
 ;;; Free Software available under an MIT-style license.
 ;;; Copyright (c) 2008 - 2011, Juan Jose Garcia Ripoll
 ;;; Copyright (c) 2012 - 2012, Francois-Rene Rideau
 ;;;
-;;; Currently works on SBCL, CCL, maybe CCL. For ABCL, see the abcl-jar contrib instead.
+;;; Currently works on
+;;; Allegro, Clozure CL, CMUCL, ECL, GNU CLISP, LispWorks, MKCL, SBCL, SCL.
+;;; For ABCL, see the abcl-jar contrib instead.
 
 (defsystem :asdf-bundle
   :licence "MIT"
   :description "Bundle operations for ASDF"
   :long-description "Can bundle one or many asdf systems into one .fasl and/or one .so"
   :depends-on (:asdf)
-  :components
-  ((:file "specials")
-   (:file "bundle" :depends-on ("specials"))
-   #+(or clozure sbcl) (:file "fasl-concat" :depends-on ("bundle"))
-   #+ecl (:file "ecl" :depends-on ("specials"))
-   #+mkcl (:file "mkcl" :depends-on ("specials"))))
+  :components ((:file "asdf-bundle")))
diff --git a/contrib/asdf-bundle/asdf-bundle.lisp b/contrib/asdf-bundle/asdf-bundle.lisp
new file mode 100644 (file)
index 0000000..0d33be9
--- /dev/null
@@ -0,0 +1,627 @@
+;;; -*- 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 clozure allegro clisp cmu sbcl scl lispworks) (declare (ignore inputs output))
+  #+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 allegro clisp clozure cmu lispworks sbcl scl)
+  (error "~S is not supported on ~A" 'combine-fasls (implementation-type)))
+
+(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)))
+
+#| ;; 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)
index ab9d205..0423148 100644 (file)
@@ -2,10 +2,5 @@
 (module
  (:fullname "asdf-bundle"
   :build-depends-on ("/asdf")
-  :depends-on
-  ("specials"
-   "bundle"
-   (:cond
-     ((:featurep :ecl) "ecl")
-     ((:featurep (:or :sbcl :clozure)) "fasl-concat")))
+  :depends-on ("asdf-bundle")
   :supersedes-asdf ("asdf-bundle")))
index 43c29ec..670c0d5 100644 (file)
@@ -1,5 +1,5 @@
 ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
-;;; This is ASDF 2.24: Another System Definition Facility.
+;;; This is ASDF 2.26.6: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
 ;;; please mail to <asdf-devel@common-lisp.net>.
          ;; "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.24")
+         (asdf-version "2.26.6")
          (existing-asdf (find-class 'component nil))
          (existing-version *asdf-version*)
          (already-there (equal asdf-version existing-version)))
            (ensure-package (name &key nicknames use unintern
                                  shadow export redefined-functions)
              (let* ((p (ensure-exists name nicknames use)))
-               (ensure-unintern p (append unintern #+cmu redefined-functions))
+               (ensure-unintern p unintern)
                (ensure-shadow p shadow)
                (ensure-export p export)
-               #-cmu (ensure-fmakunbound p redefined-functions)
+               (ensure-fmakunbound p redefined-functions)
                p)))
         (macrolet
             ((pkgdcl (name &key nicknames use export
                    :redefined-functions ',redefined-functions)))
           (pkgdcl
            :asdf
-           :nicknames (:asdf-utilities) ;; DEPRECATED! Do not use, for backward compatibility only.
            :use (:common-lisp)
            :redefined-functions
            (#:perform #:explain #:output-files #:operation-done-p
             #:user-source-registry-directory
             #:system-source-registry-directory
 
-            ;; Utilities
+            ;; Utilities: please use asdf-utils instead
+            #|
             ;; #:aif #:it
-            #:appendf #:orf
+            ;; #:appendf #:orf
             #:length=n-p
             #:remove-keys #:remove-keyword
             #:first-char #:last-char #:string-suffix-p
             #:while-collecting
             #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors*
             #:*wild-path* #:wilden
-            #:directorize-pathname-host-device
+            #:directorize-pathname-host-device|#
             )))
         #+genera (import 'scl:boolean :asdf)
         (setf *asdf-version* asdf-version
@@ -462,6 +462,7 @@ or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.")
 (progn
   (deftype logical-pathname () nil)
   (defun make-broadcast-stream () *error-output*)
+  (defun translate-logical-pathname (x) x)
   (defun file-namestring (p)
     (setf p (pathname p))
     (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
@@ -1211,8 +1212,8 @@ processed in order by OPERATE."))
   ((component :reader error-component :initarg :component)
    (operation :reader error-operation :initarg :operation))
   (:report (lambda (c s)
-               (format s (compatfmt "~@<Error while invoking ~A on ~A~@:>")
-                       (error-operation c) (error-component c)))))
+               (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>")
+                       (type-of c) (error-operation c) (error-component c)))))
 (define-condition compile-error (operation-error) ())
 (define-condition compile-failed (compile-error) ())
 (define-condition compile-warned (compile-error) ())
@@ -1460,8 +1461,7 @@ and implementation-defined external-format's")
    (maintainer :accessor system-maintainer :initarg :maintainer)
    (licence :accessor system-licence :initarg :licence
             :accessor system-license :initarg :license)
-   (source-file :reader %system-source-file :initarg :source-file ; for CLISP upgrade
-                :writer %set-system-source-file)
+   (source-file :initarg :source-file :writer %set-system-source-file) ; upgrade issues on CLISP, CMUCL
    (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
 
 ;;;; -------------------------------------------------------------------------
@@ -1635,12 +1635,8 @@ Note that this does NOT in any way cause the code of the system to be unloaded."
 
 FN should be a function of one argument. It will be
 called with an object of type asdf:system."
-  (maphash #'(lambda (_ datum)
-               (declare (ignore _))
-               (destructuring-bind (_ . def) datum
-                 (declare (ignore _))
-                 (funcall fn def)))
-           *defined-systems*))
+  (loop :for (nil . system) :being :the hash-values :of *defined-systems*
+        :do (funcall fn system)))
 
 ;;; for the sake of keeping things reasonably neat, we adopt a
 ;;; convention that functions in this list are prefixed SYSDEF-
@@ -1794,6 +1790,8 @@ Going forward, we recommend new users should be using the source-registry.
 
 (defvar *systems-being-defined* nil
   "A hash-table of systems currently being defined keyed by name, or NIL")
+(defvar *systems-being-operated* nil
+  "A boolean indicating that some systems are being operated on")
 
 (defun* find-system-if-being-defined (name)
   (when *systems-being-defined*
@@ -2003,10 +2001,10 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
   ;; the &allow-other-keys disables initarg validity checking
   (declare (ignorable operation slot-names force force-not))
   (macrolet ((frob (x) ;; normalize forced and forced-not slots
-               `(when (consp (,x operation))
-                  (setf (,x operation)
-                        (mapcar #'coerce-name (,x operation))))))
-    (frob operation-forced) (frob operation-forced-not))
+               `(when (consp (slot-value operation ',x))
+                  (setf (slot-value operation ',x)
+                        (mapcar #'coerce-name (slot-value operation ',x))))))
+    (frob forced) (frob forced-not))
   (values))
 
 (defun* node-for (o c)
@@ -2356,7 +2354,7 @@ recursive calls to traverse.")
                    (r* (svref x 0))
                    (c x)))
              (r* (l)
-               (dolist (x l) (r x))))
+               (map () #'r l)))
       (r* l))))
 
 (defmethod traverse ((operation operation) (c component))
@@ -2457,11 +2455,11 @@ recursive calls to traverse.")
                                (let ((*package* (find-package package)))
                                  (read-from-string fun))))))))
 
-(defmethod call-with-around-compile-hook ((c component) thunk)
-  (let ((hook (around-compile-hook c)))
-    (if hook
-        (funcall (ensure-function hook) thunk)
-        (funcall thunk))))
+(defun call-around-hook (hook function)
+  (funcall (or (ensure-function hook) 'funcall) function))
+
+(defmethod call-with-around-compile-hook ((c component) function)
+  (call-around-hook (around-compile-hook c) function))
 
 ;;; perform is required to check output-files to find out where to put
 ;;; its answers, in case it has been overridden for site policy
@@ -2617,10 +2615,9 @@ recursive calls to traverse.")
 
 (defmethod operation-done-p ((o load-source-op) (c source-file))
   (declare (ignorable o))
-  (if (or (not (component-property c 'last-loaded-as-source))
-          (> (safe-file-write-date (component-pathname c))
-             (component-property c 'last-loaded-as-source)))
-      nil t))
+  (and (component-property c 'last-loaded-as-source)
+       (<= (safe-file-write-date (component-pathname c))
+           (component-property c 'last-loaded-as-source))))
 
 (defmethod operation-description ((operation load-source-op) component)
   (declare (ignorable operation))
@@ -2656,6 +2653,7 @@ recursive calls to traverse.")
 
 (defgeneric* operate (operation-class system &key &allow-other-keys))
 (defgeneric* perform-plan (plan &key))
+(defgeneric* plan-operates-on-p (plan component))
 
 ;;;; Separating this into a different function makes it more forward-compatible
 (defun* cleanup-upgraded-asdf (old-version)
@@ -2690,6 +2688,10 @@ recursive calls to traverse.")
       (operate 'load-op :asdf :verbose nil))
     (cleanup-upgraded-asdf version)))
 
+(defmethod plan-operates-on-p ((plan list) (component-path list))
+  (find component-path (mapcar 'cdr plan)
+        :test 'equal :key 'component-find-path))
+
 (defmethod perform-plan ((steps list) &key)
   (let ((*package* *package*)
         (*readtable* *readtable*))
@@ -2698,38 +2700,44 @@ recursive calls to traverse.")
         (perform-with-restarts op component)))))
 
 (defmethod operate (operation-class system &rest args
-                    &key ((:verbose *asdf-verbose*) *asdf-verbose*) version force
-                    &allow-other-keys)
-  (declare (ignore force))
+                    &key force force-not verbose version &allow-other-keys)
+  (declare (ignore force force-not))
   (with-system-definitions ()
-    (let* ((op (apply 'make-instance operation-class
-                      :original-initargs args
-                      args))
-           (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream)))
+    (let* ((*asdf-verbose* verbose)
+           (*verbose-out* (if verbose *standard-output* (make-broadcast-stream)))
+           (op (apply 'make-instance operation-class
+                      :original-initargs args args))
            (system (etypecase system
                      (system system)
-                     ((or string symbol) (find-system system)))))
-      (unless (version-satisfies system version)
-        (error 'missing-component-of-version :requires system :version version))
-      (let ((steps (traverse op system)))
-        (when (and (not (equal '("asdf") (component-find-path system)))
-                   (find '("asdf") (mapcar 'cdr steps)
-                         :test 'equal :key 'component-find-path)
-                   (upgrade-asdf))
-          ;; If we needed to upgrade ASDF to achieve our goal,
-          ;; then do it specially as the first thing, then
-          ;; invalidate all existing system
-          ;; retry the whole thing with the new OPERATE function,
-          ;; which on some implementations
-          ;; has a new symbol shadowing the current one.
-          (return-from operate
-            (apply (find-symbol* 'operate :asdf) operation-class system args)))
-        (perform-plan steps)
-        (values op steps)))))
-
-(defun* oos (operation-class system &rest args &key force verbose version
-            &allow-other-keys)
-  (declare (ignore force verbose version))
+                     ((or string symbol) (find-system system))))
+           (systems-being-operated *systems-being-operated*)
+           (*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal))))
+      (check-type system system)
+      (setf (gethash (coerce-name system) *systems-being-operated*) system)
+      (flet ((upgrade ()
+               ;; If we needed to upgrade ASDF to achieve our goal,
+               ;; then do it specially as the first thing,
+               ;; which will invalidate all existing systems;
+               ;; afterwards, retry the whole thing with the new OPERATE function,
+               ;; which on some implementations
+               ;; has a new symbol shadowing the current one.
+               (unless (gethash "asdf" *systems-being-operated*)
+                 (upgrade-asdf)
+                 (return-from operate
+                   (apply (find-symbol* 'operate :asdf) operation-class system args)))))
+        (when systems-being-operated ;; Upgrade if loading a system from another one.
+          (upgrade))
+        (unless (version-satisfies system version)
+          (error 'missing-component-of-version :requires system :version version))
+        (let ((plan (traverse op system)))
+          (when (plan-operates-on-p plan '("asdf"))
+            (upgrade)) ;; Upgrade early if the plan involves upgrading asdf at any time.
+          (perform-plan plan)
+          (values op plan))))))
+
+(defun* oos (operation-class system &rest args
+             &key force force-not verbose version &allow-other-keys)
+  (declare (ignore force force-not verbose version))
   (apply 'operate operation-class system args))
 
 (let ((operate-docstring
@@ -3182,11 +3190,11 @@ if that's whay you mean." ;;)
   (unless (slot-boundp system 'source-file)
     (%set-system-source-file
      (probe-asd (component-name system) (component-pathname system)) system))
-  (%system-source-file system))
+  (slot-value system 'source-file))
 (defmethod system-source-file ((system-name string))
-  (%system-source-file (find-system system-name)))
+  (system-source-file (find-system system-name)))
 (defmethod system-source-file ((system-name symbol))
-  (%system-source-file (find-system system-name)))
+  (system-source-file (find-system system-name)))
 
 (defun* system-source-directory (system-designator)
   "Return a pathname object corresponding to the
@@ -3321,8 +3329,9 @@ located."
 (defun* user-homedir ()
   (truenamize
    (pathname-directory-pathname
+    #+cormanlisp (ensure-directory-pathname (user-homedir-pathname))
     #+mcl (current-user-homedir-pathname)
-    #-mcl (user-homedir-pathname))))
+    #-(or cormanlisp mcl) (user-homedir-pathname))))
 
 (defun* ensure-pathname* (x want-absolute want-directory fmt &rest args)
   (when (plusp (length x))
@@ -3347,6 +3356,15 @@ located."
 (defun* getenv-absolute-directories (x)
   (getenv-pathnames x :want-absolute t :want-directory t))
 
+(defun* get-folder-path (folder)
+  (or ;; this semi-portably implements a subset of the functionality of lispworks' sys:get-folder-path
+   #+(and lispworks mswindows) (sys:get-folder-path folder)
+   ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
+   (ecase folder
+    (:local-appdata (getenv-absolute-directory "LOCALAPPDATA"))
+    (:appdata (getenv-absolute-directory "APPDATA"))
+    (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA")
+                        (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))))))
 
 (defun* user-configuration-directories ()
   (let ((dirs
@@ -3356,13 +3374,8 @@ located."
                 (loop :for dir :in (getenv-absolute-directories "XDG_CONFIG_DIRS")
                   :collect (subpathname* dir "common-lisp/"))))
            ,@(when (os-windows-p)
-               `(,(subpathname* (or #+lispworks (sys:get-folder-path :local-appdata)
-                                    (getenv-absolute-directory "LOCALAPPDATA"))
-                               "common-lisp/config/")
-                 ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
-                 ,(subpathname* (or #+lispworks (sys:get-folder-path :appdata)
-                                    (getenv-absolute-directory "APPDATA"))
-                                "common-lisp/config/")))
+               `(,(subpathname* (get-folder-path :local-appdata) "common-lisp/config/")
+                 ,(subpathname* (get-folder-path :appdata) "common-lisp/config/")))
            ,(subpathname (user-homedir) ".config/common-lisp/"))))
     (remove-duplicates (remove-if-not #'absolute-pathname-p dirs)
                        :from-end t :test 'equal)))
@@ -3373,10 +3386,7 @@ located."
     ((os-windows-p)
      (aif
       ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
-      (subpathname* (or #+lispworks (sys:get-folder-path :common-appdata)
-                        (getenv-absolute-directory "ALLUSERSAPPDATA")
-                        (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))
-                    "common-lisp/config/")
+      (subpathname* (get-folder-path :common-appdata) "common-lisp/config/")
       (list it)))))
 
 (defun* in-first-directory (dirs x &key (direction :input))
@@ -3501,10 +3511,8 @@ and the order is by decreasing length of namestring of the source pathname.")
     (or
      (try (getenv-absolute-directory "XDG_CACHE_HOME") "common-lisp" :implementation)
      (when (os-windows-p)
-       (try (or #+lispworks (sys:get-folder-path :local-appdata)
-                (getenv-absolute-directory "LOCALAPPDATA")
-                #+lispworks (sys:get-folder-path :appdata)
-                (getenv-absolute-directory "APPDATA"))
+       (try (or (get-folder-path :local-appdata)
+                (get-folder-path :appdata))
             "common-lisp" "cache" :implementation))
      '(:home ".cache" "common-lisp" :implementation))))
 
@@ -3909,16 +3917,15 @@ effectively disabling the output translation facility."
   (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)))
-             (defaults (make-pathname
-                        :type type :defaults (merge-pathnames* input-file))))
-        (merge-pathnames* output-file defaults))
+            (defaults (make-pathname
+                       :type type :defaults (merge-pathnames* input-file))))
+       (merge-pathnames* output-file defaults))
       (apply-output-translations
-       (apply 'compile-file-pathname input-file keys))))
+       (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))
+  (make-pathname :name (strcat "ASDF-TMP-" (pathname-name x)) :defaults x))
 
 (defun* delete-file-if-exists (x)
   (when (and x (probe-file* x))
@@ -3956,16 +3963,29 @@ effectively disabling the output translation facility."
 #+abcl
 (defun* translate-jar-pathname (source wildcard)
   (declare (ignore wildcard))
-  (let* ((p (pathname (first (pathname-device source))))
-         (root (format nil "/___jar___file___root___/~@[~A/~]"
-                       (and (find :windows *features*)
-                            (pathname-device p)))))
-    (apply-output-translations
-     (merge-pathnames*
-      (relativize-pathname-directory source)
-      (merge-pathnames*
-       (relativize-pathname-directory (ensure-directory-pathname p))
-       root)))))
+  (flet ((normalize-device (pathname)
+           (if (find :windows *features*)
+               pathname
+               (make-pathname :defaults pathname :device :unspecific))))
+    (let* ((jar
+             (pathname (first (pathname-device source))))
+           (target-root-directory-namestring
+             (format nil "/___jar___file___root___/~@[~A/~]"
+                     (and (find :windows *features*)
+                          (pathname-device jar))))
+           (relative-source
+             (relativize-pathname-directory source))
+           (relative-jar
+             (relativize-pathname-directory (ensure-directory-pathname jar)))
+           (target-root-directory
+             (normalize-device
+              (pathname-directory-pathname
+               (parse-namestring target-root-directory-namestring))))
+           (target-root
+             (merge-pathnames* relative-jar target-root-directory))
+           (target
+             (merge-pathnames* relative-source target-root)))
+      (normalize-device (apply-output-translations target)))))
 
 ;;;; -----------------------------------------------------------------
 ;;;; Compatibility mode for ASDF-Binary-Locations
@@ -4006,6 +4026,8 @@ call that function where you would otherwise have loaded and configured A-B-L.")
     (initialize-output-translations
      `(:output-translations
        ,@source-to-target-mappings
+       #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
+       #+abcl (#p"/___jar___file___root___/**/*.*" (,@destination-directory))
        ((:root ,*wild-inferiors* ,mapped-files)
         (,@destination-directory ,mapped-files))
        (t t)
@@ -4131,9 +4153,7 @@ with a different configuration, so the configuration would be re-read then."
       (collect-sub*directories subdir collectp recursep collector))))
 
 (defun* collect-sub*directories-asd-files
-    (directory &key
-     (exclude *default-source-registry-exclusions*)
-     collect)
+    (directory &key (exclude *default-source-registry-exclusions*) collect)
   (collect-sub*directories
    directory
    (constantly t)
@@ -4226,6 +4246,7 @@ with a different configuration, so the configuration would be re-read then."
 
 (defun* wrapping-source-registry ()
   `(:source-registry
+    #+ecl (:tree ,(translate-logical-pathname "SYS:"))
     #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:"))
     #+sbcl (:tree ,(truenamize (getenv-pathname "SBCL_HOME" :want-directory t)))
     :inherit-configuration
@@ -4242,13 +4263,7 @@ with a different configuration, so the configuration would be re-read then."
                 ,@(or (getenv-absolute-directories "XDG_DATA_DIRS")
                       '("/usr/local/share" "/usr/share"))))
           ,@(when (os-windows-p)
-              `(,(or #+lispworks (sys:get-folder-path :local-appdata)
-                     (getenv-absolute-directory "LOCALAPPDATA"))
-                ,(or #+lispworks (sys:get-folder-path :appdata)
-                     (getenv-absolute-directory "APPDATA"))
-                ,(or #+lispworks (sys:get-folder-path :common-appdata)
-                     (getenv-absolute-directory "ALLUSERSAPPDATA")
-                     (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/")))))
+              (mapcar 'get-folder-path '(:local-appdata :appdata :common-appdata))))
         :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
         :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
     :inherit-configuration))
@@ -4490,19 +4505,16 @@ with a different configuration, so the configuration would be re-read then."
   (asdf-message ";; ASDF, version ~a~%" (asdf-version)))
 
 #+mkcl
-(progn
-  (defvar *loading-asdf-bundle* nil)
-  (unless *loading-asdf-bundle*
-    (let ((*central-registry*
-           (cons (translate-logical-pathname #P"CONTRIB:asdf-bundle;") *central-registry*))
-         (*loading-asdf-bundle* t))
-      (clear-system :asdf-bundle) ;; we hope to force a reload.
-      (multiple-value-bind (result bundling-error)
-          (ignore-errors (asdf:oos 'asdf:load-op :asdf-bundle))
-        (unless result
-         (format *error-output*
-                 "~&;;; ASDF: Failed to load package 'asdf-bundle'!~%;;; ASDF: Reason is: ~A.~%"
-                 bundling-error))))))
+(handler-case
+    (progn
+      (load-sysdef "asdf-bundle"
+                   (subpathname (translate-logical-pathname #P"CONTRIB:")
+                                "asdf-bundle/asdf-bundle.asd"))
+      (load-system "asdf-bundle"))
+  (error (e)
+    (format *error-output*
+            "~&;;; ASDF: Failed to load package 'asdf-bundle'!~%;;; ~A~%"
+            e)))
 
 #+allegro
 (eval-when (:compile-toplevel :execute)