0.9.11.6

[sbcl.git] / contrib / asdf / asdf.lisp

diff --git a/contrib/asdf/asdf.lisp b/contrib/asdf/asdf.lisp
index 7cec55b..da1b9bf 100644 (file)
--- a/contrib/asdf/asdf.lisp
+++ b/contrib/asdf/asdf.lisp
@@ -1,4 +1,4 @@
-;;; This is asdf: Another System Definition Facility.  1.87
+;;; This is asdf: Another System Definition Facility.  1.93
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome: please mail to
 ;;; <cclan-list@lists.sf.net>.  But note first that the canonical
@@ -109,7 +109,7 @@
 
 (in-package #:asdf)
 
-(defvar *asdf-revision* (let* ((v "1.87")
+(defvar *asdf-revision* (let* ((v "1.93")
                                (colon (or (position #\: v) -1))
                                (dot (position #\. v)))
                           (and v colon dot
@@ -359,6 +359,14 @@ and NIL NAME and TYPE components"
           (if (and file (probe-file file))
               (return file)))))))
 
+(defun make-temporary-package ()
+  (flet ((try (counter)
+           (ignore-errors
+                   (make-package (format nil "ASDF~D" counter)
+                                 :use '(:cl :asdf)))))
+    (do* ((counter 0 (+ counter 1))
+          (package (try counter) (try counter)))
+         (package package))))
 
 (defun find-system (name &optional (error-p t))
   (let* ((name (coerce-name name))
@@ -367,15 +375,18 @@ and NIL NAME and TYPE components"
     (when (and on-disk
                (or (not in-memory)
                    (< (car in-memory) (file-write-date on-disk))))
-      (let ((*package* (make-package (gensym #.(package-name *package*))
-                                     :use '(:cl :asdf))))
-        (format *verbose-out*
+      (let ((package (make-temporary-package)))
+        (unwind-protect
+             (let ((*package* package))
+               (format
+                *verbose-out*
                 "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
                 ;; FIXME: This wants to be (ENOUGH-NAMESTRING
                 ;; ON-DISK), but CMUCL barfs on that.
                 on-disk
                 *package*)
-        (load on-disk)))
+               (load on-disk))
+          (delete-package package))))
     (let ((in-memory (gethash name *defined-systems*)))
       (if in-memory
           (progn (if on-disk (setf (car in-memory) (file-write-date on-disk)))
@@ -429,17 +440,17 @@ system."))
 (defmethod source-file-type ((c static-file) (s module)) nil)
 
 (defmethod component-relative-pathname ((component source-file))
-  (let* ((*default-pathname-defaults* (component-parent-pathname component))
-         (name-type
-          (make-pathname
-           :name (component-name component)
-           :type (source-file-type component
-                                   (component-system component)))))
-    (if (slot-value component 'relative-pathname)
-        (merge-pathnames
-         (slot-value component 'relative-pathname)
-         name-type)
-        name-type)))
+  (let ((relative-pathname (slot-value component 'relative-pathname)))
+    (if relative-pathname
+        relative-pathname
+        (let* ((*default-pathname-defaults*
+                (component-parent-pathname component))
+               (name-type
+                (make-pathname
+                 :name (component-name component)
+                 :type (source-file-type component
+                                         (component-system component)))))
+          name-type))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; operations
@@ -930,10 +941,11 @@ Returns the new tree (which probably shares structure with the old one)"
               ;; remove-keys form.  important to keep them in sync
               components pathname default-component-class
               perform explain output-files operation-done-p
+              weakly-depends-on
               depends-on serial in-order-to
               ;; list ends
               &allow-other-keys) options
-    (check-component-input type name depends-on components in-order-to)
+    (check-component-input type name weakly-depends-on depends-on components in-order-to)
 
     (when (and parent
              (find-component parent name)
@@ -946,11 +958,14 @@ Returns the new tree (which probably shares structure with the old one)"
     (let* ((other-args (remove-keys
                         '(components pathname default-component-class
                           perform explain output-files operation-done-p
+                          weakly-depends-on
                           depends-on serial in-order-to)
                         rest))
            (ret
             (or (find-component parent name)
                 (make-instance (class-for-type parent type)))))
+      (when weakly-depends-on
+        (setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on))))
       (when (boundp '*serial-depends-on*)
         (setf depends-on
               (concatenate 'list *serial-depends-on* depends-on)))
@@ -974,7 +989,7 @@ Returns the new tree (which probably shares structure with the old one)"
                       do (push (component-name c) *serial-depends-on*))))
 
         ;; check for duplicate names
-        (let ((name-hash (make-hash-table :test #'equalp)))
+        (let ((name-hash (make-hash-table :test #'equal)))
           (loop for c in (module-components ret)
                 do
                 (if (gethash (component-name c)
@@ -1009,11 +1024,15 @@ Returns the new tree (which probably shares structure with the old one)"
                   (component-inline-methods ret))))
       ret)))
 
-(defun check-component-input (type name depends-on components in-order-to)
+(defun check-component-input (type name weakly-depends-on depends-on components in-order-to)
   "A partial test of the values of a component."
+  (when weakly-depends-on (warn "We got one! XXXXX"))
   (unless (listp depends-on)
     (sysdef-error-component ":depends-on must be a list."
                             type name depends-on))
+  (unless (listp weakly-depends-on)
+    (sysdef-error-component ":weakly-depends-on must be a list."
+                            type name weakly-depends-on))
   (unless (listp components)
     (sysdef-error-component ":components must be NIL or a list of components."
                             type name components))
@@ -1107,10 +1126,17 @@ output to *verbose-out*.  Returns the shell's exit code."
           (asdf:operate 'asdf:load-op name)
           t))))
 
-  (pushnew
-   '(merge-pathnames "systems/"
-     (truename (sb-ext:posix-getenv "SBCL_HOME")))
-   *central-registry*)
+  (defun contrib-sysdef-search (system)
+    (let* ((name (coerce-name system))
+           (home (truename (sb-ext:posix-getenv "SBCL_HOME")))
+           (contrib (merge-pathnames
+                     (make-pathname :directory `(:relative ,name)
+                                    :name name
+                                    :type "asd"
+                                    :case :local
+                                    :version :newest)
+                     home)))
+      (probe-file contrib)))
 
   (pushnew
    '(merge-pathnames "site-systems/"
@@ -1122,6 +1148,7 @@ output to *verbose-out*.  Returns the shell's exit code."
      (user-homedir-pathname))
    *central-registry*)
 
-  (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*))
+  (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*)
+  (pushnew 'contrib-sysdef-search *system-definition-search-functions*))
 
 (provide 'asdf)