[armedbear-cvs] r14460 - trunk/abcl/src/org/armedbear/lisp

[ehuelsmann at common-lisp.net]

Author: ehuelsmann
Date: Wed Apr  3 14:34:53 2013
New Revision: 14460

Log:
* Rename FASL entry point inside the fasl from "<fasl>._" to "__loader__._"
  in case of zipped fasls. In case of "directory fasls", the loader
  is (still) called "<fasl>.abcl".
* Delete temporary directory after repackaging fasls.

Modified:
   trunk/abcl/src/org/armedbear/lisp/Load.java
   trunk/abcl/src/org/armedbear/lisp/compile-file.lisp
   trunk/abcl/src/org/armedbear/lisp/fasl-concat.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/Load.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Load.java	Wed Apr  3 14:28:32 2013	(r14459)
+++ trunk/abcl/src/org/armedbear/lisp/Load.java	Wed Apr  3 14:34:53 2013	(r14460)
@@ -323,6 +323,7 @@
             && truename.type.princToString().equals(COMPILE_FILE_TYPE) && Utilities.checkZipFile(truename))  {
             Pathname init = new Pathname(truename.getNamestring());
             init.type = COMPILE_FILE_INIT_FASL_TYPE;
+            init.name = new SimpleString("__loader__");
             LispObject t = Pathname.truename(init);
             if (t instanceof Pathname) {
                 truename = (Pathname)t;

Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp	Wed Apr  3 14:28:32 2013	(r14459)
+++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp	Wed Apr  3 14:34:53 2013	(r14460)
@@ -687,6 +687,7 @@
               (push resource pathnames))))))
     (setf pathnames (nreverse (remove nil pathnames)))
     (let ((load-file (make-pathname :defaults output-file
+                                    :name "__loader__"
                                     :type "_")))
       (rename-file output-file load-file)
       (push load-file pathnames))

Modified: trunk/abcl/src/org/armedbear/lisp/fasl-concat.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/fasl-concat.lisp	Wed Apr  3 14:28:32 2013	(r14459)
+++ trunk/abcl/src/org/armedbear/lisp/fasl-concat.lisp	Wed Apr  3 14:34:53 2013	(r14460)
@@ -44,44 +44,48 @@
 (defun load-concatenated-fasl (sub-fasl)
   (let ((fasl-path (merge-pathnames (make-pathname :directory (list :relative
                                                                     sub-fasl)
-                                                   :name sub-fasl
+                                                   :name "__loader__"
                                                    :type "_")
                                     *load-truename-fasl*)))
     (load fasl-path)))
 
 (defun concatenate-fasls (inputs output)
-  (let* ((directory (print (ext:make-temp-directory)))
-         (unpacked (mapcan #'(lambda (input)
-                               (sys:unzip (print input)
-                                          (ensure-directories-exist
-                                           (sub-directory directory
-                                                          (pathname-name (print input))))))
-                           inputs))
-         (chain-loader (make-pathname :name (pathname-name output)
-                                      :type "_"
-                                      :defaults directory)))
-    (with-open-file (f chain-loader
-                       :direction :output
-                       :if-does-not-exist :create
-                       :if-exists :overwrite)
-      (write-string
-       ";; loader code to delegate loading of the embedded fasls below" f)
-      (terpri f)
-      (sys::dump-form `(sys:init-fasl :version ,sys:*fasl-version*) f)
-      (terpri f)
-      (dolist (input inputs)
-        (sys::dump-form `(load-concatenated-fasl ,(pathname-name input)) f)
-        (terpri f)))
-    (let ((paths (remove-if #'pathname-directory-p
-                            (directory
-                             (merge-pathnames
-                              (make-pathname :directory '(:relative
-                                                          :wild-inferiors)
-                                             :name "*"
-                                             :type "*")
-                              directory)))))
-      (sys:zip output paths directory))
-    (values directory unpacked chain-loader)))
+  (let ((directory (ext:make-temp-directory))
+        paths)
+    (unwind-protect
+         (let* ((unpacked (mapcan #'(lambda (input)
+                                      (sys:unzip input
+                                                 (ensure-directories-exist
+                                                  (sub-directory directory
+                                                                 (pathname-name  input)))))
+                                   inputs))
+                (chain-loader (make-pathname :name "__loader__"
+                                             :type "_"
+                                             :defaults directory)))
+           (with-open-file (f chain-loader
+                              :direction :output
+                              :if-does-not-exist :create
+                              :if-exists :overwrite)
+             (write-string
+              ";; loader code to delegate loading of the embedded fasls below" f)
+             (terpri f)
+             (sys::dump-form `(sys:init-fasl :version ,sys:*fasl-version*) f)
+             (terpri f)
+             (dolist (input inputs)
+               (sys::dump-form `(load-concatenated-fasl ,(pathname-name input)) f)
+               (terpri f)))
+           (setf paths
+                 (directory (merge-pathnames
+                             (make-pathname :directory '(:relative
+                                                         :wild-inferiors)
+                                            :name "*"
+                                            :type "*")
+                             directory)))
+           (sys:zip output (remove-if #'pathname-directory-p paths) directory)
+           (values directory unpacked chain-loader))
+      (dolist (path paths)
+        (ignore-errors (delete-file path)))
+      (ignore-errors (delete-file directory)))))
 
 (defun sub-directory (directory name)
   (merge-pathnames (make-pathname :directory (list :relative name))