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

Heh, sure! I like diff -u better too but there's another project I  
work one that really wants diff -c's so sometimes I lose track. (have  
fun on vacation).

Index: asdf.lisp
===================================================================
RCS file: /cvsroot/cclan/asdf/asdf.lisp,v
retrieving revision 1.122
diff -u -w -u -r1.122 asdf.lisp
--- asdf.lisp	29 Jun 2008 15:10:16 -0000	1.122
+++ asdf.lisp	29 Jun 2008 19:09:33 -0000
@@ -1,4 +1,4 @@
-;;; This is asdf: Another System Definition Facility.  $Revision:  
1.122 $
+;;; 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,7 +119,7 @@

  (in-package #:asdf)

-(defvar *asdf-revision* (let* ((v "$Revision: 1.122 $")
+(defvar *asdf-revision* (let* ((v "$Revision: 1.121 $")
                                 (colon (or (position #\: v) -1))
                                 (dot (position #\. v)))
                            (and v colon dot
@@ -371,8 +371,13 @@
    '(sysdef-central-registry-search))

  (defun system-definition-pathname (system)
-  (some (lambda (x) (funcall x system))
-        *system-definition-search-functions*))
+  (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,8 +706,7 @@
                        (or (member (car dep) *features*)
                            (error 'missing-dependency
                                   :required-by c
-                                 :requires (car dep)
-                                 :version nil)))
+                                 :requires (car dep))))
                       (t
                        (dolist (d dep)
                          (cond ((consp d)
@@ -1310,12 +1314,20 @@
      (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
      ))

-(defun system-source-file (system-name)
-  (let ((system (asdf:find-system system-name)))
+(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))))
+		  :defaults (asdf:component-relative-pathname system)))))
+    (when pn
+      (probe-file pn))))

  (defun system-source-directory (system-name)
    (make-pathname :name nil
Index: test/run-tests.sh
===================================================================
RCS file: /cvsroot/cclan/asdf/test/run-tests.sh,v
retrieving revision 1.14
diff -u -w -u -r1.14 run-tests.sh
--- test/run-tests.sh	29 Jun 2008 15:10:16 -0000	1.14
+++ test/run-tests.sh	29 Jun 2008 19:09:33 -0000
@@ -19,13 +19,13 @@
  if [ -z "$2" ]; then
      scripts="*.script"
  else
-    scripts="$2.script"
+    scripts="$2"
  fi

  sok=1

  do_tests() {
-rm *.$2 || true
+rm -f *.$2 || true
  ( cd .. && echo '(load "test/compile-asdf.lisp")' | $1  )
  if [ $? -eq 0 ] ; then
      test_count=0
@@ -36,7 +36,7 @@
      do
        echo "Testing: $i" >&2
        test_count=`expr "$test_count" + 1`
-      rm *.$2 || true
+      rm -f *.$2 || true
        if  $1 < $i ; then
          echo "Using $1, $i passed" >&2
  	test_pass=`expr "$test_pass" + 1`
@@ -76,7 +76,7 @@
  elif [ "$lisp" = "clisp" ] ; then
      if type clisp ; then
  	fasl_ext="fas"
-	command=`where clisp`
+	command=`which clisp`
  	command="$command -norc -ansi -I - "
      fi
  elif [ "$lisp" = "allegro" ] ; then
Index: test/script-support.lisp
===================================================================
RCS file: /cvsroot/cclan/asdf/test/script-support.lisp,v
retrieving revision 1.1
diff -u -w -u -r1.1 script-support.lisp
Index: test/test1.script
===================================================================
RCS file: /cvsroot/cclan/asdf/test/test1.script,v
retrieving revision 1.4
diff -u -w -u -r1.4 test1.script
--- test/test1.script	13 Jun 2007 01:30:55 -0000	1.4
+++ test/test1.script	29 Jun 2008 19:09:33 -0000
@@ -17,7 +17,7 @@
   ;; recompiled
   (sleep 1) ; mtime has 1-second granularity, so pause here for fast  
machines

- (asdf::run-shell-command "rm ~A"
+ (asdf::run-shell-command "rm -f ~A"
  			  (namestring (compile-file-pathname "file2")))
   (asdf:operate 'asdf:load-op 'test1)
   (assert (= file1-date (file-write-date (compile-file-pathname  
"file1"))))
Index: test/test3.script
===================================================================
RCS file: /cvsroot/cclan/asdf/test/test3.script,v
retrieving revision 1.4
diff -u -w -u -r1.4 test3.script
--- test/test3.script	13 Jun 2007 01:30:55 -0000	1.4
+++ test/test3.script	29 Jun 2008 19:09:33 -0000
@@ -5,7 +5,7 @@
  (load "../asdf")
  (in-package :asdf)
  (cl-user::exit-on-error
- (asdf:run-shell-command "rm ~A ~A"
+ (asdf:run-shell-command "rm -f ~A ~A"
  			 (namestring (compile-file-pathname "file1"))
  			 (namestring (compile-file-pathname "file2")))
   (setf asdf:*central-registry* '(*default-pathname-defaults*))
@@ -18,7 +18,7 @@
   (asdf:oos 'asdf:load-op 'test3)
   (assert (probe-file (compile-file-pathname "file1")))
   (assert (not (probe-file (compile-file-pathname "file2"))))
- (run-shell-command "rm ~A" (namestring (compile-file-pathname  
"file1")))
+ (run-shell-command "rm -f ~A" (namestring (compile-file-pathname  
"file1")))
   (setf *features* (cons :f2 (cdr *features*)))
   (asdf:oos 'asdf:load-op 'test3)
   (assert (probe-file (compile-file-pathname "file2")))


--
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