From aa52ad229fa5b850d706c2b516cb63e0f3558544 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes <csr21@cantab.net> Date: Tue, 9 Sep 2008 13:02:44 +0000 Subject: [PATCH] Merging patch to allow asdf protocol functionality to be expressed in terms of primary and around methods, while still allowing users to write :around methods of their own (e.g. to deal with stalated fasls). --- asdf.lisp | 53 ++++++++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 44 insertions(+), 9 deletions(-) diff --git a/asdf.lisp b/asdf.lisp index 89d99297..bcc736bd 100644 --- a/asdf.lisp +++ b/asdf.lisp @@ -1,4 +1,4 @@ -;;; This is asdf: Another System Definition Facility. $Revision: 1.127 $ +;;; This is asdf: Another System Definition Facility. $Revision: 1.128 $ ;;; ;;; Feedback, bug reports, and patches are all welcome: please mail to ;;; <cclan-list@lists.sf.net>. But note first that the canonical @@ -104,6 +104,9 @@ #:try-recompiling #:retry #:accept ; restarts + + #:standard-asdf-method-combination + #:around ; protocol assistants ) ;; preference loading - to be expunged (:export @@ -119,7 +122,7 @@ (in-package #:asdf) -(defvar *asdf-revision* (let* ((v "$Revision: 1.127 $") +(defvar *asdf-revision* (let* ((v "$Revision: 1.128 $") (colon (or (position #\: v) -1)) (dot (position #\. v))) (and v colon dot @@ -518,11 +521,43 @@ system.")) ;; 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)) @@ -846,7 +881,7 @@ the head of the tree")) (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 @@ -866,7 +901,7 @@ the head of the tree")) (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 -- GitLab