X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fasdf%2Fasdf.lisp;h=c8772b5af925c7618eddd5bd44330d271cfd67c8;hb=52632e03f75694e3780851896c3d5ec251f1f46b;hp=a2e61e18898c092d5ae4dc9dc4ff093d27c86392;hpb=9f8b254664d2864ae524c3a12c912437accfdb20;p=sbcl.git

diff --git a/contrib/asdf/asdf.lisp b/contrib/asdf/asdf.lisp
index a2e61e1..c8772b5 100644
--- a/contrib/asdf/asdf.lisp
+++ b/contrib/asdf/asdf.lisp
@@ -1,4 +1,4 @@
-;;; This is asdf: Another System Definition Facility.  1.72
+;;; This is asdf: Another System Definition Facility.  1.75
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome: please mail to
 ;;; <cclan-list@lists.sf.net>.  But note first that the canonical
@@ -71,9 +71,14 @@
 	   #:component-property
 	   
 	   #:component-depends-on
+
+	   #:operation-on-warnings
+	   #:operation-on-failure
 	   
 	   ;#:*component-parent-pathname* 
 	   #:*central-registry*		; variables
+	   #:*compile-file-warnings-behaviour*
+	   #:*compile-file-failure-behaviour*
 	   
 	   #:operation-error #:compile-failed #:compile-warned #:compile-error
 	   #:system-definition-error 
@@ -89,7 +94,7 @@
 
 (in-package #:asdf)
 
-(defvar *asdf-revision* (let* ((v "1.72")
+(defvar *asdf-revision* (let* ((v "1.75")
 			       (colon (or (position #\: v) -1))
 			       (dot (position #\. v)))
 			  (and v colon dot 
@@ -98,8 +103,10 @@
 				     (parse-integer v :start (1+ dot)
 						    :junk-allowed t)))))
 
-(defvar  *compile-file-warnings-behaviour* :warn)
-(defvar  *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn)
+(defvar *compile-file-warnings-behaviour* :warn)
+(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn)
+
+(defvar *verbose-out* *trace-output*)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; utility stuff
@@ -347,7 +354,7 @@ and NIL NAME and TYPE components"
 		   (< (car in-memory) (file-write-date on-disk))))
       (let ((*package* (make-package (gensym (package-name #.*package*))
 				     :use '(:cl :asdf))))
-	(format t
+	(format *verbose-out*
 		(formatter "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%")
 		;; FIXME: This wants to be (ENOUGH-NAMESTRING
 		;; ON-DISK), but CMUCL barfs on that.
@@ -361,7 +368,8 @@ and NIL NAME and TYPE components"
 	  (if error-p (error 'missing-component :requires name))))))
 
 (defun register-system (name system)
-  (format t (formatter "~&~@<; ~@;registering ~A as ~A~@:>~%") system name)
+  (format *verbose-out*
+	  (formatter "~&~@<; ~@;registering ~A as ~A~@:>~%") system name)
   (setf (gethash (coerce-name  name) *defined-systems*)
 	(cons (get-universal-time) system)))
 
@@ -664,7 +672,7 @@ system."))
   nil)
 
 (defmethod explain ((operation operation) (component component))
-  (format *trace-output* "~&;;; ~A on ~A~%"
+  (format *verbose-out* "~&;;; ~A on ~A~%"
 	  operation component))
 
 ;;; compile-op
@@ -778,6 +786,10 @@ system."))
 (defun operate (operation-class system &rest args)
   (let* ((op (apply #'make-instance operation-class
 		    :original-initargs args args))
+	 (*verbose-out*
+	  (if (getf args :verbose t)
+	      *verbose-out*
+	      (make-broadcast-stream)))
 	 (system (if (typep system 'component) system (find-system system)))
 	 (steps (traverse op system)))
     (with-compilation-unit ()
@@ -975,40 +987,40 @@ Returns the new tree (which probably shares structure with the old one)"
 (defun run-shell-command (control-string &rest args)
   "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
 synchronously execute the result using a Bourne-compatible shell, with
-output to *trace-output*.  Returns the shell's exit code."
+output to *verbose-out*.  Returns the shell's exit code."
   (let ((command (apply #'format nil control-string args)))
-    (format *trace-output* "; $ ~A~%" command)
+    (format *verbose-out* "; $ ~A~%" command)
     #+sbcl
     (sb-impl::process-exit-code
      (sb-ext:run-program  
       "/bin/sh"
       (list  "-c" command)
-      :input nil :output *trace-output*))
+      :input nil :output *verbose-out*))
     
     #+(or cmu scl)
     (ext:process-exit-code
      (ext:run-program  
       "/bin/sh"
       (list  "-c" command)
-      :input nil :output *trace-output*))
+      :input nil :output *verbose-out*))
 
     #+allegro
-    (excl:run-shell-command command :input nil :output *trace-output*)
+    (excl:run-shell-command command :input nil :output *verbose-out*)
     
     #+lispworks
     (system:call-system-showing-output
      command
      :shell-type "/bin/sh"
-     :output-stream *trace-output*)
+     :output-stream *verbose-out*)
     
-    #+clisp				;XXX not exactly *trace-output*, I know
+    #+clisp				;XXX not exactly *verbose-out*, I know
     (ext:run-shell-command  command :output :terminal :wait t)
 
     #+openmcl
     (nth-value 1
 	       (ccl:external-process-status
 		(ccl:run-program "/bin/sh" (list "-c" command)
-				 :input nil :output *trace-output*
+				 :input nil :output *verbose-out*
 				 :wait t)))
 
     #-(or openmcl clisp lispworks allegro scl cmu sbcl)
@@ -1034,10 +1046,12 @@ output to *trace-output*.  Returns the shell's exit code."
 #+(and sbcl sbcl-hooks-require)
 (progn
   (defun module-provide-asdf (name)
-    (let ((system (asdf:find-system name nil)))
-      (when system
-	(asdf:operate 'asdf:load-op name)
-	t)))
+    (handler-bind ((style-warning #'muffle-warning))
+      (let* ((*verbose-out* (make-broadcast-stream))
+	     (system (asdf:find-system name nil)))
+	(when system
+	  (asdf:operate 'asdf:load-op name)
+	  t))))
 
   (pushnew
    '(merge-pathnames "systems/"