asdf patch that converts operate into a generic method
"Attila Lendvai" <[email protected]>
| Newsgroups | gmane.lisp.cclan.general |
|---|---|
| Message-ID | <[email protected]> |
hi! as the subject sais, with some additional small cleanups. this was needed for metacop, to be able to load the same lisp files into two different packages with and without contextl integration. i hope you find it useful, -- - attila "- The truth is that I've been too considerate, and so became unintentionally cruel... - I understand. - No, you don't understand! We don't speak the same language!" (Ingmar Bergman - Smultronstället) ------------------------------------------------------------------------- Using Tomcat but need to do more? Need to support web services, security? Get stuff done quickly with pre-integrated technology to make your job easier Download IBM WebSphere Application Server v.1.0.1 based on Apache Geronimo http://sel.as-us.falkag.net/sel?cmd=lnk&kid=120709&bid=263057&dat=121642 _______________________________________________ cclan-list mailing list [email protected] https://lists.sourceforge.net/lists/listinfo/cclan-list
asdf.diff
(text/plain, 5.6 KB)
Index: asdf.lisp
===================================================================
RCS file: /cvsroot/cclan/asdf/asdf.lisp,v
retrieving revision 1.101
diff -u -r1.101 asdf.lisp
--- asdf.lisp 21 Aug 2006 10:52:32 -0000 1.101
+++ asdf.lisp 25 Oct 2006 09:46:52 -0000
@@ -140,6 +140,16 @@
(define-modify-macro appendf (&rest args)
append "Append onto list")
+(defun remove-keywords (plist &rest keywords)
+ "Creates a copy of PLIST without the listed KEYWORDS."
+ (loop for cell = plist :then (cddr cell)
+ for el = (car cell)
+ while cell
+ unless (member el keywords :test #'eq)
+ collect el
+ and collect (cadr cell)
+ and do (assert (cdr cell) () "Not a proper plist")))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; classes, condiitons
@@ -729,6 +739,9 @@
(on-failure :initarg :on-failure :accessor operation-on-failure
:initform *compile-file-failure-behaviour*)))
+(defmethod operation-done-p ((operation compile-op) (c static-file))
+ t)
+
(defmethod perform :before ((operation compile-op) (c source-file))
(map nil #'ensure-directories-exist (output-files operation c)))
@@ -867,38 +880,51 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; invoking operations
-(defun operate (operation-class system &rest args &key (verbose t) version
- &allow-other-keys)
- (let* ((op (apply #'make-instance operation-class
- :original-initargs args
- args))
- (*verbose-out* (if verbose *trace-output* (make-broadcast-stream)))
- (system (if (typep system 'component) system (find-system system))))
- (unless (version-satisfies system version)
- (error 'missing-component :requires system :version version))
- (let ((steps (traverse op system)))
- (with-compilation-unit ()
- (loop for (op . component) in steps do
- (loop
- (restart-case
- (progn (perform op component)
- (return))
- (retry ()
- :report
- (lambda (s)
- (format s "~@<Retry performing ~S on ~S.~@:>"
- op component)))
- (accept ()
- :report
- (lambda (s)
- (format s
- "~@<Continue, treating ~S on ~S as ~
- having been successful.~@:>"
- op component))
- (setf (gethash (type-of op)
- (component-operation-times component))
- (get-universal-time))
- (return)))))))))
+(defgeneric operate (operation system &key verbose version &allow-other-keys)
+ (:method :around (operation-class system &rest args)
+ (if (and (typep operation-class 'operation)
+ (typep system 'component))
+ (call-next-method)
+ (funcall #'operate
+ (if (typep operation-class 'operation)
+ operation-class
+ (apply #'make-instance operation-class
+ :original-initargs args
+ args))
+ (if (typep system 'component)
+ system
+ (find-system system)))))
+
+ (:method (op system &key &allow-other-keys)
+ (error "Don't know how to operate ~A on ~A" op system))
+
+ (:method ((op operation) (system component) &key (verbose t) version &allow-other-keys)
+ (let* ((*verbose-out* (if verbose *trace-output* (make-broadcast-stream))))
+ (unless (version-satisfies system version)
+ (error 'missing-component :requires system :version version))
+ (let ((steps (traverse op system)))
+ (with-compilation-unit ()
+ (loop for (op . component) in steps do
+ (loop named inner do
+ (restart-case
+ (progn (perform op component)
+ (return-from inner))
+ (retry ()
+ :report
+ (lambda (s)
+ (format s "~@<Retry performing ~S on ~S.~@:>"
+ op component)))
+ (accept ()
+ :report
+ (lambda (s)
+ (format s
+ "~@<Continue, treating ~S on ~S as ~
+ having been successful.~@:>"
+ op component))
+ (setf (gethash (type-of op)
+ (component-operation-times component))
+ (get-universal-time))
+ (return-from inner))))))))))
(defun oos (&rest args)
"Alias of OPERATE function"
@@ -907,18 +933,9 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; syntax
-(defun remove-keyword (key arglist)
- (labels ((aux (key arglist)
- (cond ((null arglist) nil)
- ((eq key (car arglist)) (cddr arglist))
- (t (cons (car arglist) (cons (cadr arglist)
- (remove-keyword
- key (cddr arglist))))))))
- (aux key arglist)))
-
(defmacro defsystem (name &body options)
(destructuring-bind (&key pathname (class 'system) &allow-other-keys) options
- (let ((component-options (remove-keyword :class options)))
+ (let ((component-options (remove-keywords options :class)))
`(progn
;; system must be registered before we parse the body, otherwise
;; we recur when trying to find an existing system of the same name