From 4a27b93af41453be1fed86c64d37ad34f54ddc0a Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <fare@tunes.org> Date: Sun, 15 Nov 2009 21:25:15 -0500 Subject: [PATCH] Transform some ugly macro with bad loop that warns under clisp into clean higher-order function. Add TODO item. --- INCREMENTAL-TODO | 7 ++++-- asdf-ops.lisp | 60 +++++++++++++++++++++++++++++++++++++----------- 2 files changed, 52 insertions(+), 15 deletions(-) diff --git a/INCREMENTAL-TODO b/INCREMENTAL-TODO index 04e607d..ed06790 100644 --- a/INCREMENTAL-TODO +++ b/INCREMENTAL-TODO @@ -8,5 +8,8 @@ why things depend on each other. -* rewrite ADG to use a fully instrumented code-walker + CL-in-CL implementation - so we don't have to approximate dependencies when we can trace them directly. +* rewrite ADG to use SB-COVER, + so we don't have to approximate dependencies when we can trace them + directly. + More difficult would be to writ your own fully instrumented + code-walker and coverage CL-in-CL implementation. diff --git a/asdf-ops.lisp b/asdf-ops.lisp index f2b659c..ee9395b 100644 --- a/asdf-ops.lisp +++ b/asdf-ops.lisp @@ -172,14 +172,14 @@ to the base of the system." "Component spec ~S in ~S didn't find a component." compspec system) (apply #'reinitialize-instance component args)))) - (loop for (system compspec . initargs) in additional-initargs - do (assert (member (asdf::coerce-name system) systems - :key #'asdf::coerce-name - :test #'equal) - () - "Component translation in System ~A which is not a member of the ~ - systems to merge." system) - do (add-initargs system compspec initargs)))) + (loop :for (system compspec . initargs) in additional-initargs :do + (assert (member (asdf::coerce-name system) systems + :key #'asdf::coerce-name + :test #'equal) + () + "Component translation in System ~A which is not a member of the ~ + systems to merge." system) + (add-initargs system compspec initargs)))) (defmethod asdf:perform ((op dependency-op) (c component-file)) (let ((tmp-file-name (format nil "~A-~A" @@ -231,10 +231,43 @@ to the base of the system." ;;; Reading the component list back into asdf defsystems +(defun %comp-file-reader (pathname system-names collector) + (with-open-file (f pathname :direction :input) + (let ((systems (read f)) + (done-systems nil)) + (labels ((do-1-system (system-name) + (unless (position system-name done-systems + :test #'string-equal) + (let ((system (assoc system-name systems + :test #'string-equal))) + (funcall collector system) + (push system-name done-systems) + (getf (cdr system) :depends-on))))) + (loop :while system-names :do + (let ((system-name (pop system-names))) + (setf system-names (append system-names (do-1-system system-name))))))))) + +(defun read-component-file (pathname &rest system-names) + (let ((component-list nil)) + (%comp-file-reader + pathname system-names + (lambda (system) + (setf component-list + (append component-list (getf (cdr system) :components))))))) + +(defun systems-in-configuration (pathname &rest system-names) + (let ((component-names nil)) + (%comp-file-reader + pathname system-names + (lambda (system) + (when system + (push (first system) component-names)))))) + +#| +;; Old macro-ish version by antifuchs: (macrolet ((define-comp-file-reader (fname (1-system-var return-var) &body 1-system-body) - (let ((system-name (gensym)) (system-names (gensym)) (done-systems (gensym)) @@ -252,10 +285,10 @@ to the base of the system." (progn ,@1-system-body) (push ,system-name ,done-systems) (getf (cdr ,1-system-var) :depends-on))))) - (loop while ,system-names - for ,system-name = (pop ,system-names) - do (setf ,system-names (append ,system-names - (do-1-system ,system-name)))) + (loop :while ,system-names :do + (let ((,system-name (pop ,system-names))) + (setf ,system-names (append ,system-names + (do-1-system ,system-name))))) ,return-var))))))) (define-comp-file-reader read-component-file (system component-list) (setf component-list @@ -263,6 +296,7 @@ to the base of the system." (define-comp-file-reader systems-in-configuration (system component-names) (when system (push (first system) component-names)))) +|# ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -- GitLab