Changeset 13344


Ignore:
Timestamp:
06/17/11 11:57:33 (10 years ago)
Author:
Mark Evenson
Message:

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.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/contrib/asdf-jar/asdf-jar.lisp

    r13337 r13344  
    1 (defpackage :asdf-jar
     1(defpackage #:asdf-jar
    22  (:use :cl)
    33  (:export #:package))
    44
    55(in-package :asdf-jar)
    6 
    76
    87(defvar *systems*)
     
    2827      (format verbose "~&Packaging ASDF definition of ~A~&as ~A." system package-jar))
    2928    (setf *systems* nil)
     29    (when verbose
     30      (format verbose "~&Forcing recursive compilation of ~A." package-jar))
    3031    (asdf:compile-system system :force t)
    31     (let* ((dir (asdf:component-pathname system))
    32      (wild-contents (merge-pathnames "**/*" dir))
    33      (contents (directory wild-contents))
    34      (topdir (truename (merge-pathnames "../" dir))))
    35       (when verbose
    36   (format verbose "~&Packaging contents in ~A." package-jar))
    37       (dolist (system (append (list system) *systems*))
    38         (let ((base (slot-value system 'asdf:absolute-pathname))
    39               (name (slot-value system 'asdf:name))
    40               (asdf (slot-value system source-file)))
    41           (setf (gethash asdf mapping) (relative-path base name asdf))))
     32    (when verbose
     33      (format verbose "~&Packaging contents in ~A." package-jar))
     34    (dolist (system (append (list system) *systems*))
     35      (let ((base (slot-value system 'asdf::absolute-pathname))
     36            (name (slot-value system 'asdf::name))
     37            (asdf (slot-value system 'asdf::source-file)))
     38        (setf (gethash asdf mapping) (relative-path base name asdf))
     39       
    4240          ;;; XXX iterate through the rest of the contents of the
    4341          ;;; system, adding appropiate entries
    44       (system:zip package-jar mapping))))
     42        (let ((sources
     43               (mapwalk (lambda (c) (typep c 'asdf::source-file))
     44                        (lambda (c) (input-files c )))))
     45          (loop :for source :in sources
     46             :do (setf (gethash (pathname-namestring source) mapping)
     47                       (make-pathname :defaults source
     48                                      :type "abcl"))))))
     49  (system:zip package-jar mapping)))
     50
     51;;; This more Map than Walk at this point ...
     52(defun mapwalk (system test-if callable)
     53  (declare (type system asdf:system))
     54  (let ((components
     55         (loop
     56            :for component :being :each :hash-value
     57              :of (slot-value system 'asdf::components-by-name)
     58            :when (funcall test-if component)
     59            :collect component)))
     60    (loop :for component :in components
     61       :collecting (apply callable component))))
    4562
    4663(defun relative-path (base dir file)
Note: See TracChangeset for help on using the changeset viewer.