[armedbear-cvs] r13344 - trunk/abcl/contrib/asdf-jar

[mevenson at common-lisp.net]

Author: mevenson
Date: Fri Jun 17 04:57:33 2011
New Revision: 13344

Log:
Undebugged implementation of enumerating the source and fasls.

Using the SYSTEM:ZIP with a hashtable of source to fasl mappings
eliminates the need for any intermediate directory.

Modified:
   trunk/abcl/contrib/asdf-jar/asdf-jar.lisp

Modified: trunk/abcl/contrib/asdf-jar/asdf-jar.lisp
==============================================================================
--- trunk/abcl/contrib/asdf-jar/asdf-jar.lisp	Fri Jun 17 04:25:14 2011	(r13343)
+++ trunk/abcl/contrib/asdf-jar/asdf-jar.lisp	Fri Jun 17 04:57:33 2011	(r13344)
@@ -1,10 +1,9 @@
-(defpackage :asdf-jar
+(defpackage #:asdf-jar
   (:use :cl)
   (:export #:package))
 
 (in-package :asdf-jar)
 
-
 (defvar *systems*)
 (defmethod asdf:perform :before ((op asdf:compile-op) (c asdf:system))
   (push c *systems*))
@@ -27,21 +26,39 @@
     (when verbose 
       (format verbose "~&Packaging ASDF definition of ~A~&as ~A." system package-jar))
     (setf *systems* nil)
+    (when verbose
+      (format verbose "~&Forcing recursive compilation of ~A." package-jar))
     (asdf:compile-system system :force t)
-    (let* ((dir (asdf:component-pathname system))
-	   (wild-contents (merge-pathnames "**/*" dir))
-	   (contents (directory wild-contents))
-	   (topdir (truename (merge-pathnames "../" dir))))
-      (when verbose
-	(format verbose "~&Packaging contents in ~A." package-jar))
-      (dolist (system (append (list system) *systems*))
-        (let ((base (slot-value system 'asdf:absolute-pathname))
-              (name (slot-value system 'asdf:name))
-              (asdf (slot-value system source-file)))
-          (setf (gethash asdf mapping) (relative-path base name asdf))))
+    (when verbose
+      (format verbose "~&Packaging contents in ~A." package-jar))
+    (dolist (system (append (list system) *systems*))
+      (let ((base (slot-value system 'asdf::absolute-pathname))
+            (name (slot-value system 'asdf::name))
+            (asdf (slot-value system 'asdf::source-file)))
+        (setf (gethash asdf mapping) (relative-path base name asdf))
+        
           ;;; XXX iterate through the rest of the contents of the
           ;;; system, adding appropiate entries
-      (system:zip package-jar mapping))))
+        (let ((sources
+               (mapwalk (lambda (c) (typep c 'asdf::source-file))
+                        (lambda (c) (input-files c )))))
+          (loop :for source :in sources
+             :do (setf (gethash (pathname-namestring source) mapping)
+                       (make-pathname :defaults source
+                                      :type "abcl"))))))
+  (system:zip package-jar mapping)))
+
+;;; This more Map than Walk at this point ...
+(defun mapwalk (system test-if callable)
+  (declare (type system asdf:system))
+  (let ((components 
+         (loop 
+            :for component :being :each :hash-value
+              :of (slot-value system 'asdf::components-by-name)
+            :when (funcall test-if component)
+            :collect component)))
+    (loop :for component :in components
+       :collecting (apply callable component))))
 
 (defun relative-path (base dir file) 
   (let* ((relative