[cclan-list] small patch for asdf output

[Gary K. <gw...@me...>]

The patch below moves asdf status output into a single function, asdf- 
message, and uses this to print whatever ASDF prints.

It also moves a comment about CMUCL out into a separate function and  
uses enough-namestring when not running on CMUCL.

If no-one has objections, I'll commit in a few days.

Index: asdf.lisp
===================================================================
RCS file: /cvsroot/cclan/asdf/asdf.lisp,v
retrieving revision 1.129
diff -u -w -r1.129 asdf.lisp
--- asdf.lisp	4 Oct 2008 22:41:04 -0000	1.129
+++ asdf.lisp	5 Oct 2008 19:46:02 -0000
@@ -150,6 +150,10 @@
  (define-modify-macro appendf (&rest args)
    append "Append onto list")

+(defun asdf-message (message &rest args)
+  (declare (dynamic-extent args))
+  (apply #'format *verbose-out* message args))
+
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; classes, condiitons

@@ -399,6 +403,15 @@
            (package (try counter) (try counter)))
           (package package))))

+;;; special handling for cmucl
+;; FIXME: This wants to be (ENOUGH-NAMESTRING
+;; ON-DISK), but CMUCL barfs on that.
+(defun asdf-enough-namestring (it)
+  #+cmucl
+  it
+  #-cmucl
+  (enough-namestring it))
+
  (defun find-system (name &optional (error-p t))
    (let* ((name (coerce-name name))
           (in-memory (system-registered-p name))
@@ -409,12 +422,9 @@
        (let ((package (make-temporary-package)))
          (unwind-protect
               (let ((*package* package))
-               (format
-                *verbose-out*
+	       (asdf-message
                  "~&~@<; ~@;loading system definition from ~A into  
~A~@:>~%"
-                ;; FIXME: This wants to be (ENOUGH-NAMESTRING
-                ;; ON-DISK), but CMUCL barfs on that.
-                on-disk
+                (asdf-enough-namestring on-disk)
                  *package*)
                 (load on-disk))
            (delete-package package))))
@@ -425,7 +435,7 @@
            (if error-p (error 'missing-component :requires name))))))

  (defun register-system (name system)
-  (format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system  
name)
+  (asdf-message "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
    (setf (gethash (coerce-name name) *defined-systems*)
          (cons (get-universal-time) system)))

@@ -812,7 +822,7 @@
    nil)

  (defmethod explain ((operation operation) (component component))
-  (format *verbose-out* "~&;;; ~A on ~A~%" operation component))
+  (asdf-message "~&;;; ~A on ~A~%" operation component))

  ;;; compile-op


--
Gary Warren King, metabang.com
Cell: (413) 559 8738
Fax: (206) 338-4052
gwkkwg on Skype * garethsan on AIM