Ensuring that ASDF reloads out of date system defs, take 2

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
   ;;; <[email protected]>.  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
   ;;; <[email protected]>.  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





-------------------------------------------------------------------------
Check out the new SourceForge.net Marketplace.
It's the best place to buy or sell services for
just about anything Open Source.
http://sourceforge.net/services/buy/index.php