Add CCL support.

diff --git a/asdf-bundle.asd b/asdf-bundle.asd
index fb40c46..3767ebc 100644 (file)
--- a/asdf-bundle.asd
+++ b/asdf-bundle.asd
@@ -16,6 +16,7 @@
   :long-description "Can bundle one or many asdf systems into one .fasl and/or one .so"
   :depends-on (:asdf)
   :components
-  ((:file "bundle")
-   #+sbcl (:file "sbcl")
-   #+ecl (:file "ecl")))
+  ((:file "specials")
+   (:file "bundle" :depends-on ("specials"))
+   #+(or clozure sbcl) (:file "fasl-concat" :depends-on ("specials"))
+   #+ecl (:file "ecl" :depends-on ("specials"))))

diff --git a/fasl-concat.lisp b/fasl-concat.lisp
new file mode 100644 (file)
index 0000000..612730e
--- /dev/null
+++ b/fasl-concat.lisp
@@ -0,0 +1,75 @@
+;;; -*- Mode: Lisp ; Syntax: ANSI-Common-Lisp -*-
+
+#+xcvb (module (:depends-on ("bundle")))
+
+(in-package :asdf)
+
+(declaim (optimize (debug 3) (safety 3) (speed 1)))
+
+#+sbcl
+(defun concatenate-files (inputs output)
+  (let ((infiles (mapcar #'sb-ext:native-namestring inputs))
+        (outfile (sb-ext:native-namestring output)))
+    (assert
+     (= 0 (sb-ext:process-exit-code 
+           #+win32
+           (sb-ext:run-program
+            "copy" `("/b" ,@(loop :for (i . morep) :on infiles
+                                  :collect i :when morep :collect "+") ,output)
+            :input nil :output nil :error nil :wait t)
+           #-win32
+           (sb-ext:run-program
+            "cat" infiles :output outfile
+            :if-output-exists :supersede :external-format :latin1
+            :input nil :error nil :search t :wait t))))))
+
+(defun combine-fasls (inputs output)
+  #+ccl (ccl:fasl-concatenate output inputs :if-exists :supersede)
+  #+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/sbcl.lisp b/sbcl.lisp
deleted file mode 100644 (file)
index 194cc2d..0000000
--- a/sbcl.lisp
+++ /dev/null
@@ -1,54 +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 concatenate-files (inputs output)
-  (let ((infiles (mapcar #'sb-ext:native-namestring inputs))
-        (outfile (sb-ext:native-namestring output)))
-    (assert
-     (= 0 (sb-ext:process-exit-code 
-           #+win32
-           (sb-ext:run-program
-            "copy" `("/b" ,@(loop :for (i . morep) :on infiles
-                                  :collect i :when morep :collect "+") ,output)
-            :input nil :output nil :error nil :wait t)
-           #-win32
-           (sb-ext:run-program
-            "cat" infiles :output outfile
-            :if-output-exists :supersede :external-format :latin1
-            :input nil :error nil :search t :wait t))))))
-
-(defun combine-fasls (inputs outputs)
-  (assert (length=n-p outputs 1))
-  (ensure-directories-exist (first outputs))
-  (concatenate-files inputs (first outputs)))
-
-(defmethod perform ((o bundle-op) (c system))
-  (let* ((input-files (input-files o c))
-         (fasl-files (remove "fasl" input-files :key #'pathname-type :test-not #'string=))
-         (non-fasl-files (remove "fasl" 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 SBCL, asdf-bundle can only bundle FASL files, but these were also produced: ~S" 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 SBCL"))
-      (ensure-directories-exist output-file)
-      (combine-fasls fasl-files output-files))))
-
-
-;;; On SBCL, everything happens in the lib-op dependency
-(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/specials.lisp b/specials.lisp
new file mode 100644 (file)
index 0000000..c3e30fc
--- /dev/null
+++ b/specials.lisp
@@ -0,0 +1,8 @@
+;;; -*- Mode: Lisp ; Syntax: ANSI-Common-Lisp -*-
+
+#+xcvb (module ())
+
+(in-package :asdf)
+
+(defparameter *fasl-type* (pathname-type (compile-file-pathname "foo.lisp"))
+  "pathname TYPE for lisp FASt Loading files")