X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=contrib%2Fasdf%2Fasdf.lisp;h=da1b9bfb8d604498f716bb6b602c3012d51c41d1;hb=33353162b9fea0bf13a79f0860a9e91da1bbede3;hp=7cec55b9147ac7a916c40cd3b1bf58a7d5002c20;hpb=2add48f5ee524f8f2ed0098694f1358d910336aa;p=sbcl.git diff --git a/contrib/asdf/asdf.lisp b/contrib/asdf/asdf.lisp index 7cec55b..da1b9bf 100644 --- 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 ;;; . 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)