Re: :around methods on LOAD-OP and COMPILE-OP

Christophe Rhodes <[email protected]> Thu, 04 Sep 2008 10:05:45 +0100
Newsgroups gmane.lisp.cclan.general
Message-ID <[email protected]> 
Gary King <[email protected]> writes:

> Hi Nikodemus,
>
>> ...or perhaps rather, such user tweaks stomp on the TRY-RECOMPILING
>> restarts. Maybe they could be hung on (unexported) BASIC-LOAD-OP and
>> (to be added) BASIC-COMPILE-OP instead, so that users can still do
>> their thing without nuking bits of the official ASDF?
>
>
> This sounds good to me. I'll send out a proposed patch with the change  
> later today.

I don't think a patch came out, did it?  In any case, I prefer the
approach (attached) of using a slightly non-standard method
combination, which we can now do because all CLs anyone cares about
support them.  The idea is that asdf:around methods are for internal
use, and ordinary :around methods are the user-frobbable protocol
hooks.

I also think that the try-recompiling restart for compile-op is
useless, because asdf already sets up a retry restart; I'd like to
delete it, but I have a sneaking suspicion that someone will complain
if I do.  If I don't hear confirmation about that, I'll delete it
anyway and suck up the consequences.

When testing these changes (which also include Richard Kreuter's
circularity detection patch), test5.script failed for me, saying that
:load-only-p was an unknown initarg.  I don't know who did what, but I
could find no reference to :load-only-p other than the test script; I
presume this is a broken test, but if someone knows otherwise could
they please shout?

Best,

Christophe

-------------------------------------------------------------------------
This SF.Net email is sponsored by the Moblin Your Move Developer's challenge
Build the coolest Linux based applications with Moblin SDK & win great prizes
Grand prize is a trip for two to an Open Source event anywhere in the world
http://moblin-contest.org/redirect.php?banner_id=100&url=/

_______________________________________________
cclan-list mailing list
[email protected]
https://lists.sourceforge.net/lists/listinfo/cclan-list
mc.diff (text/x-diff, 3.5 KB) 
? asdf.fasl
Index: asdf.lisp
===================================================================
RCS file: /cvsroot/cclan/asdf/asdf.lisp,v
retrieving revision 1.123
diff -u -r1.123 asdf.lisp
--- asdf.lisp	5 Jul 2008 02:57:20 -0000	1.123
+++ asdf.lisp	4 Sep 2008 08:56:52 -0000
@@ -104,6 +104,9 @@
 	   #:try-recompiling
            #:retry
            #:accept                     ; restarts
+
+           #:standard-asdf-method-combination
+           #:around                     ; protocol assistants
 	   )
   ;; preference loading - to be expunged
   (:export
@@ -517,11 +520,43 @@
   ;; empty method to disable initarg validity checking
   )
 
-(defgeneric perform (operation component))
-(defgeneric operation-done-p (operation component))
-(defgeneric explain (operation component))
-(defgeneric output-files (operation component))
-(defgeneric input-files (operation component))
+(define-method-combination standard-asdf-method-combination ()
+  ((around-asdf (around))
+   (around (:around))
+   (before (:before))
+   (primary () :required t)
+   (after (:after)))
+  (flet ((call-methods (methods)
+           (mapcar #'(lambda (method)
+                       `(call-method ,method))
+                   methods)))
+    (let* ((form (if (or before after (rest primary))
+                     `(multiple-value-prog1
+                          (progn ,@(call-methods before)
+                                 (call-method ,(first primary)
+                                              ,(rest primary)))
+                        ,@(call-methods (reverse after)))
+                     `(call-method ,(first primary))))
+           (standard-form (if around
+                              `(call-method ,(first around)
+                                            (,@(rest around)
+                                               (make-method ,form)))
+                              form)))
+      (if around-asdf
+          `(call-method ,(first around-asdf)
+                        (,@(rest around-asdf) (make-method ,standard-form)))
+          standard-form))))
+
+(defgeneric perform (operation component)
+  (:method-combination standard-asdf-method-combination))
+(defgeneric operation-done-p (operation component)
+  (:method-combination standard-asdf-method-combination))
+(defgeneric explain (operation component)
+  (:method-combination standard-asdf-method-combination))
+(defgeneric output-files (operation component)
+  (:method-combination standard-asdf-method-combination))
+(defgeneric input-files (operation component)
+  (:method-combination standard-asdf-method-combination))
 
 (defun node-for (o c)
   (cons (class-name (class-of o)) c))
@@ -588,7 +623,7 @@
 (defgeneric component-visiting-p (operation component))
 
 (defmethod component-visiting-p ((o operation) (c component))
-  (let ((node (cons o c)))
+  (let ((node (node-for o c)))
     (member node (operation-visiting-nodes (operation-ancestor o))
             :test 'equal)))
 
@@ -845,7 +880,7 @@
 (defmethod perform ((o load-op) (c cl-source-file))
   (mapcar #'load (input-files o c)))
 
-(defmethod perform :around ((o load-op) (c cl-source-file))
+(defmethod perform around ((o load-op) (c cl-source-file))
   (let ((state :initial))
     (loop until (or (eq state :success)
 		    (eq state :failure)) do
@@ -865,7 +900,7 @@
 	      (call-next-method)
 	      (setf state :success)))))))
 
-(defmethod perform :around ((o compile-op) (c cl-source-file))
+(defmethod perform around ((o compile-op) (c cl-source-file))
   (let ((state :initial))
     (loop until (or (eq state :success)
 		    (eq state :failure)) do