From a91af0986f6c46919194baadaf3ea760e3e41e25 Mon Sep 17 00:00:00 2001 From: Gary King <gwking@franz.com> Date: Sat, 27 Jun 2009 10:33:42 -0400 Subject: [PATCH] fixed defsystem parsing bug defsystem was using `getf` to extract data from a component's parameters which meant that it only found the first item of a given type rather than all of them. I.e., if your component had several :perform methods, then only the first one was being seen. --- asdf.lisp | 36 +++++++++++++++++++++++------------- 1 file changed, 23 insertions(+), 13 deletions(-) diff --git a/asdf.lisp b/asdf.lisp index c514c3ba..8ee028ab 100644 --- a/asdf.lisp +++ b/asdf.lisp @@ -1247,7 +1247,7 @@ Returns the new tree (which probably shares structure with the old one)" (sysdef-error-component ":in-order-to must be NIL or a list of components." type name in-order-to))) -(defun %remove-component-inline-methods (ret rest) +(defun %remove-component-inline-methods (component) (loop for name in +asdf-methods+ do (map 'nil ;; this is inefficient as most of the stored @@ -1255,18 +1255,28 @@ Returns the new tree (which probably shares structure with the old one)" ;; But this is hardly performance-critical (lambda (m) (remove-method (symbol-function name) m)) - (component-inline-methods ret))) + (component-inline-methods component))) ;; clear methods, then add the new ones - (setf (component-inline-methods ret) nil) - (loop for name in +asdf-methods+ - for v = (getf rest (intern (symbol-name 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))))) - + (setf (component-inline-methods component) nil)) + +(defun %define-component-inline-methods (ret rest) + (loop for name in +asdf-methods+ do + (let ((keyword (intern (symbol-name name) :keyword))) + (loop for data = rest then (cddr data) + while data + for key = (first data) + for value = (second data) + when (eq key keyword) do + (destructuring-bind (op qual (o c) &body body) value + (pushnew + (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret))) + ,@body)) + (component-inline-methods ret))))))) + +(defun %refresh-component-inline-methods (component rest) + (%remove-component-inline-methods component) + (%define-component-inline-methods component rest)) + (defun parse-component-form (parent options) (destructuring-bind @@ -1341,7 +1351,7 @@ Returns the new tree (which probably shares structure with the old one)" (load-op (load-op ,@depends-on)))) (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on)))) - (%remove-component-inline-methods ret rest) + (%refresh-component-inline-methods ret rest) ret))) -- GitLab