ASDF Patch for LispWorks

Consider the (silly) system definition below.

FILE S1.ASD

> (in-package #:common-lisp-user)
>
> (defpackage #:s1-system
> 	    (:use #:common-lisp #:asdf))
>
> (in-package #:s1-system)
>
> (defsystem s1
>   :components
>   ((:module "main"
>     :pathname ""
>     :components ((:file "f1")
> 		 )))
>   :perform
>   (load-op :after (op c)
> 	   (print (list :load :after op c))))

Loading this once in LispWorks 5.01 Personal (OS X Mactel) is fine;  
loading twice is unhappy.

>
> CL-USER 1 > (load "/repository/cclan/asdf/asdf")
> ; Loading text file /repository/cclan/asdf/asdf.lisp
> #P"/repository/cclan/asdf/asdf.lisp"
>
> CL-USER 2 > (load "/repository/other/ts-20/lisp/experimental/asdf- 
> problem/s1.asd")
> ; Loading text file /repository/other/ts-20/lisp/experimental/asdf- 
> problem/s1.asd
> #P"/repository/other/ts-20/lisp/experimental/asdf-problem/s1.asd"
>
> CL-USER 3 > (load "/repository/other/ts-20/lisp/experimental/asdf- 
> problem/s1.asd")
> ; Loading text file /repository/other/ts-20/lisp/experimental/asdf- 
> problem/s1.asd
>
> Error: No applicable methods for #<STANDARD-GENERIC-FUNCTION  
> HARLEQUIN-COMMON-LISP:GENERIC-FUNCTION-NAME 2091E0DA> with args (NIL)
>   1 (continue) Call #<STANDARD-GENERIC-FUNCTION HARLEQUIN-COMMON- 
> LISP:GENERIC-FUNCTION-NAME 2091E0DA> again
>   2 Try loading /repository/other/ts-20/lisp/experimental/asdf- 
> problem/s1.asd again.
>   3 Give up loading /repository/other/ts-20/lisp/experimental/asdf- 
> problem/s1.asd.
>   4 Try loading another file instead of /repository/other/ts-20/ 
> lisp/experimental/asdf-problem/s1.asd.
>   5 (abort) Return to level 0.
>   6 Return to top loop level 0.
>
> Type :b for backtrace, :c <option number> to proceed,  or :? for  
> other options
>
> S1-SYSTEM 4 : 1 >

The problem, as I see it, is in parse-component-form. It currently uses

>       (loop for (n v) in `((perform ,perform) (explain ,explain)
> 			   (output-files ,output-files)
> 			   (operation-done-p ,operation-done-p))
> 	    do (map 'nil
> 		    ;; this is inefficient as most of the stored
> 		    ;; methods will not be for this particular gf n
> 		    ;; But this is hardly performance-critical
> 		    (lambda (m) (remove-method (symbol-function n) m))
> 		    (component-inline-methods ret))
> 	  when v
> 	   (destructuring-bind (op qual (o c) &body body) v
> 		 (pushnew
> 		  (eval `(defmethod ,n ,qual ((,o ,op) (,c (eql ,ret)))
> 			  ,@body))
> 		  (component-inline-methods ret))))

to update the inline-methods (e.g., perform, explain, etc) of a  
system. Since component-inline-methods is never cleared, it can end  
up with methods that don't exist and (at least on LispWorks), these  
methods can be of the form

#<STANDARD-METHOD NIL (:AFTER) (#<STANDARD-CLASS ASDF:LOAD-OP  
21778B0C> (
      (EQL #<ASDF::SYSTEM-CONNECTION "bind-and-metatilities" 214F08F4>))

I.e., the method name is nil; this then causes LispWorks to complain  
when it tries to remove the method whose name is nil.

I propose the following patch:

1. Add

(defparameter +asdf-methods+
   '(perform explain output-files operation-done-p))

to prevent duplication

2. Replace the code above with:

> ;; remove old methods
>       (loop for name in +asdf-methods+
> 	    do (map 'nil
> 		    ;; this is inefficient as most of the stored
> 		    ;; methods will not be for this particular gf n
> 		    ;; But this is hardly performance-critical
> 		    (lambda (m)
> 		      (remove-method (symbol-function name) m))
> 		    (component-inline-methods ret)))
>       ;; clear methods, then add the new ones
>       (setf (component-inline-methods ret) nil)
>       (loop for name in +asdf-methods+
> 	   for v = (getf rest (intern name :keyword))
> 	 when v do
> 	   (destructuring-bind (op qual (o c) &body body) v
> 	     (pushnew
> 	      (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
> 				,@body))
> 	      (component-inline-methods ret))))

Patch attached.

If there is not discussion, I'll commit this in a few days.


--
Gary Warren King, metabang.com
Cell: (413) 885 9127
Fax: (206) 338-4052
gwkkwg on Skype * garethsan on AIM

(defvar *serial-depends-on*)
 
+(defparameter +asdf-methods+ 
+  '(perform explain output-files operation-done-p))
+
 (defun parse-component-form (parent options)
   (destructuring-bind
        (type name &rest rest &key
              ;; the following list of keywords is reproduced below in the
              ;; remove-keys form.  important to keep them in sync
+             ;; see also the +asdf-methods+ variable
              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 weakly-depends-on 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)
             ;; ignore the same object when rereading the defsystem
@@ -1018,11 +1032,12 @@
       (error 'duplicate-names :name name))
     
     (let* ((other-args (remove-keys
+                       +asdf-methods+
+                       (remove-keys
                        '(components pathname default-component-class
-                         perform explain output-files operation-done-p
                          weakly-depends-on
                          depends-on serial in-order-to)
-                       rest))
+                        rest)))
           (ret
            (or (find-component parent name)
                (make-instance (class-for-type parent type)))))
@@ -1068,20 +1083,23 @@
             `((compile-op (compile-op ,@depends-on))
               (load-op (load-op ,@depends-on))))
            (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on))))
-      
-      (loop for (n v) in `((perform ,perform) (explain ,explain)
-                          (output-files ,output-files)
-                          (operation-done-p ,operation-done-p))
+      ;; remove old methods
+      (loop for name in +asdf-methods+
            do (map 'nil
                    ;; this is inefficient as most of the stored
                    ;; methods will not be for this particular gf n
                    ;; But this is hardly performance-critical
-                   (lambda (m) (remove-method (symbol-function n) m))
-                   (component-inline-methods ret))
-           when v
-           do (destructuring-bind (op qual (o c) &body body) v
+                   (lambda (m) 
+                     (remove-method (symbol-function name) m))
+                   (component-inline-methods ret)))
+      ;; clear methods, then add the new ones
+      (setf (component-inline-methods ret) nil)
+      (loop for name in +asdf-methods+ 
+          for v = (getf rest (intern name :keyword)) 
+        when v do
+          (destructuring-bind (op qual (o c) &body body) v
                 (pushnew
-                 (eval `(defmethod ,n ,qual ((,o ,op) (,c (eql ,ret)))
+             (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
                          ,@body))
                  (component-inline-methods ret))))
       ret)))