Bundle asdf-bundle into a single Lisp file,
authorFrancois-Rene Rideau <tunes@google.com>
Thu, 29 Nov 2012 13:23:09 +0000 (08:23 -0500)
committerFrancois-Rene Rideau <tunes@google.com>
Thu, 29 Nov 2012 13:23:09 +0000 (08:23 -0500)
to make it easier to distribute it with ECL and/or Quicklisp.
Fix it and test it on SBCL, ECL.

asdf-bundle.asd
asdf-bundle.lisp [moved from bundle.lisp with 67% similarity]
build.xcvb
ecl.lisp [deleted file]
fasl-concat.lisp [deleted file]
mkcl.lisp [deleted file]
specials.lisp [deleted file]

index 7039eb1..6bb46fb 100644 (file)
@@ -18,9 +18,4 @@
   :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 allegro clisp clozure sbcl) (:file "fasl-concat" :depends-on ("bundle"))
-   #+ecl (:file "ecl" :depends-on ("specials"))
-   #+mkcl (:file "mkcl" :depends-on ("specials"))))
+  :components ((:file "asdf-bundle")))
similarity index 67%
rename from bundle.lisp
rename to asdf-bundle.lisp
index 5b149f4..4043a4c 100644 (file)
@@ -25,8 +25,8 @@
 
 (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 (name-suffix :initarg :name-suffix :initform nil)
    #+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)))
@@ -58,7 +58,6 @@
 (defclass program-op (monolithic-bundle-op)
   ((type :initform :program)))
 
-#+ecl
 (defmethod initialize-instance :after ((instance bundle-op) &rest initargs
                                        &key (name-suffix nil name-suffix-p)
                                        &allow-other-keys)
         (slot-value instance 'original-initargs)
       (setf (slot-value instance 'original-initargs)
             (remove-keys '(lisp-files epilogue-code prologue-code) original-initargs)
-            (bundle-op-lisp-files instance) lisp-files
             (monolithic-op-prologue-code instance) prologue-code
-            (monolithic-op-epilogue-code instance) epilogue-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))))
                         #|"-" (string-downcase (implementation-type))|#)
           :type "lisp"
           :defaults (system-source-directory c))
-          #+ecl :type #+ecl (bundle-op-type o))))
+         #+ecl :type #+ecl (bundle-op-type o))))
 
 (defmethod perform ((o bundle-op) (c t))
   (declare (ignorable o c))
                      :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)
+  #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede)
+  #+(or allegro clisp sbcl) (concatenate-files inputs output))
+
+(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 (make-pathname
+                   :name (strcat (pathname-name pathname) "-ASDF-TMP")
+                   :defaults 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)))
+
+#-(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)
+
+#+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 #+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")))
diff --git a/ecl.lisp b/ecl.lisp
deleted file mode 100644 (file)
index 7dc2ca4..0000000
--- a/ecl.lisp
+++ /dev/null
@@ -1,34 +0,0 @@
-;;; -*- Mode: Lisp ; Syntax: ANSI-Common-Lisp -*-
-
-#+xcvb (module (:depends-on ("specials")))
-
-(in-package :asdf)
-
-(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)))
-
-(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)))))))
-
-
-;;;
-;;; Final integration steps
-;;;
-
-(export '(make-build load-fasl-op))
-
-(pushnew '("fasb" . si::load-binary) ext:*load-hooks* :test 'equal :key 'car)
diff --git a/fasl-concat.lisp b/fasl-concat.lisp
deleted file mode 100644 (file)
index f0dd616..0000000
+++ /dev/null
@@ -1,77 +0,0 @@
-;;; -*- Mode: Lisp ; Syntax: ANSI-Common-Lisp -*-
-
-#+xcvb (module (:depends-on ("bundle")))
-
-(in-package :asdf)
-
-(declaim (optimize (debug 3) (safety 3) (speed 1)))
-
-(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)
-  #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede)
-  #+(or allegro clisp sbcl) (concatenate-files inputs output))
-
-(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 (make-pathname
-                   :name (strcat (pathname-name pathname) "-staging")
-                   :defaults 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)))
-
-(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 component))
-  (declare (ignorable o c))
-  nil)
-
-(defmethod input-files ((o fasl-op) (c component))
-  (declare (ignorable o c))
-  nil)
diff --git a/mkcl.lisp b/mkcl.lisp
deleted file mode 100644 (file)
index 60fc1b1..0000000
--- a/mkcl.lisp
+++ /dev/null
@@ -1,80 +0,0 @@
-;;; -*- Mode: Lisp ; Syntax: ANSI-Common-Lisp -*-
-
-#+xcvb (module (:depends-on ("specials")))
-
-(in-package :asdf)
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  ;; Make sure we have strict ANSI class redefinition semantics.
-  (setq clos::*redefine-class-in-place* t))
-
-;;;
-;;; 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))
-
-(export '(bundle-system))
-
-
-;;;
-;;; 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.
-(pushnew '("fasb" . si::load-binary) si:*load-hooks* :test 'equal :key 'car)
diff --git a/specials.lisp b/specials.lisp
deleted file mode 100644 (file)
index d624a33..0000000
+++ /dev/null
@@ -1,5 +0,0 @@
-;;; -*- Mode: Lisp ; Syntax: ANSI-Common-Lisp -*-
-
-#+xcvb (module ())
-
-(in-package :asdf)