From: Gary K. <gw...@me...> - 2008-06-29 15:38:27
|
The patch below is a followup / altered version to my proposed patch of June 15th. Both patches ensure that ASDF treats systems _it_ can find using *system-definition-search-functions* the same way it treats systems that have been loaded by hand. The previous patch modified find-system; this one modifies system-definition-pathname which, to me at least, seems to be the "right" place to put the fix. I'm going to add a test or two of the behavior for both kinds of system loading and then I'd like to commit. Comments very welcome! Index: asdf.lisp =================================================================== RCS file: /cvsroot/cclan/asdf/asdf.lisp,v retrieving revision 1.122 diff -c -r1.122 asdf.lisp *** asdf.lisp 29 Jun 2008 15:10:16 -0000 1.122 --- asdf.lisp 29 Jun 2008 15:33:32 -0000 *************** *** 1,4 **** ! ;;; This is asdf: Another System Definition Facility. $Revision: 1.122 $ ;;; ;;; Feedback, bug reports, and patches are all welcome: please mail to ;;; <ccl...@li...>. But note first that the canonical --- 1,4 ---- ! ;;; This is asdf: Another System Definition Facility. $Revision: 1.121 $ ;;; ;;; Feedback, bug reports, and patches are all welcome: please mail to ;;; <ccl...@li...>. But note first that the canonical *************** *** 119,125 **** (in-package #:asdf) ! (defvar *asdf-revision* (let* ((v "$Revision: 1.122 $") (colon (or (position #\: v) -1)) (dot (position #\. v))) (and v colon dot --- 119,125 ---- (in-package #:asdf) ! (defvar *asdf-revision* (let* ((v "$Revision: 1.121 $") (colon (or (position #\: v) -1)) (dot (position #\. v))) (and v colon dot *************** *** 371,378 **** '(sysdef-central-registry-search)) (defun system-definition-pathname (system) ! (some (lambda (x) (funcall x system)) ! *system-definition-search-functions*)) (defvar *central-registry* '(*default-pathname-defaults* --- 371,383 ---- '(sysdef-central-registry-search)) (defun system-definition-pathname (system) ! (let ((system-name (coerce-name system))) ! (or ! (some (lambda (x) (funcall x system-name)) ! *system-definition-search-functions*) ! (let ((system-pair (gethash system-name *defined-systems*))) ! (and system-pair ! (system-source-file (cdr system-pair))))))) (defvar *central-registry* '(*default-pathname-defaults* *************** *** 701,708 **** (or (member (car dep) *features*) (error 'missing-dependency :required-by c ! :requires (car dep) ! :version nil))) (t (dolist (d dep) (cond ((consp d) --- 706,712 ---- (or (member (car dep) *features*) (error 'missing-dependency :required-by c ! :requires (car dep)))) (t (dolist (d dep) (cond ((consp d) *************** *** 1310,1322 **** (error "RUN-SHELL-PROGRAM not implemented for this Lisp") )) ! (defun system-source-file (system-name) ! (let ((system (asdf:find-system system-name))) ! (make-pathname ! :type "asd" ! :name (asdf:component-name system) ! :defaults (asdf:component-relative-pathname system)))) (defun system-source-directory (system-name) (make-pathname :name nil :type nil --- 1314,1334 ---- (error "RUN-SHELL-PROGRAM not implemented for this Lisp") )) ! (defgeneric system-source-file (system) ! (:documentation "Return the source file in which system is defined.")) + (defmethod system-source-file ((system-name t)) + (system-source-file (find-system system-name))) + + (defmethod system-source-file ((system system)) + (let ((pn (and (slot-boundp system 'relative-pathname) + (make-pathname + :type "asd" + :name (asdf:component-name system) + :defaults (asdf:component-relative-pathname system))))) + (when pn + (probe-file pn)))) + (defun system-source-directory (system-name) (make-pathname :name nil :type nil -- Gary Warren King, metabang.com Cell: (413) 559 8738 Fax: (206) 338-4052 gwkkwg on Skype * garethsan on AIM |