Skip to content
Snippets Groups Projects
Commit a5b8dfde authored by Daniel Barlow's avatar Daniel Barlow
Browse files

Introduce a new :verbose switch to OPERATE (defaults T, specifying NIL turns...

Introduce a new :verbose switch to OPERATE (defaults T, specifying NIL turns off all/most non-error output from ASDF)
parent 58db416b
No related branches found
No related tags found
No related merge requests found
;;; This is asdf: Another System Definition Facility. $Revision: 1.73 $ ;;; This is asdf: Another System Definition Facility. $Revision: 1.74 $
;;; ;;;
;;; Feedback, bug reports, and patches are all welcome: please mail to ;;; Feedback, bug reports, and patches are all welcome: please mail to
;;; <cclan-list@lists.sf.net>. But note first that the canonical ;;; <cclan-list@lists.sf.net>. But note first that the canonical
...@@ -71,6 +71,9 @@ ...@@ -71,6 +71,9 @@
#:component-property #:component-property
#:component-depends-on #:component-depends-on
#:operation-on-warnings
#:operation-on-failure
;#:*component-parent-pathname* ;#:*component-parent-pathname*
#:*central-registry* ; variables #:*central-registry* ; variables
...@@ -91,7 +94,7 @@ ...@@ -91,7 +94,7 @@
(in-package #:asdf) (in-package #:asdf)
(defvar *asdf-revision* (let* ((v "$Revision: 1.73 $") (defvar *asdf-revision* (let* ((v "$Revision: 1.74 $")
(colon (or (position #\: v) -1)) (colon (or (position #\: v) -1))
(dot (position #\. v))) (dot (position #\. v)))
(and v colon dot (and v colon dot
...@@ -103,6 +106,8 @@ ...@@ -103,6 +106,8 @@
(defvar *compile-file-warnings-behaviour* :warn) (defvar *compile-file-warnings-behaviour* :warn)
(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn) (defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn)
(defvar *verbose-out* *trace-output*)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; utility stuff ;; utility stuff
...@@ -349,7 +354,7 @@ and NIL NAME and TYPE components" ...@@ -349,7 +354,7 @@ and NIL NAME and TYPE components"
(< (car in-memory) (file-write-date on-disk)))) (< (car in-memory) (file-write-date on-disk))))
(let ((*package* (make-package (gensym (package-name #.*package*)) (let ((*package* (make-package (gensym (package-name #.*package*))
:use '(:cl :asdf)))) :use '(:cl :asdf))))
(format t (format *verbose-out*
(formatter "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%") (formatter "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%")
;; FIXME: This wants to be (ENOUGH-NAMESTRING ;; FIXME: This wants to be (ENOUGH-NAMESTRING
;; ON-DISK), but CMUCL barfs on that. ;; ON-DISK), but CMUCL barfs on that.
...@@ -363,7 +368,8 @@ and NIL NAME and TYPE components" ...@@ -363,7 +368,8 @@ and NIL NAME and TYPE components"
(if error-p (error 'missing-component :requires name)))))) (if error-p (error 'missing-component :requires name))))))
(defun register-system (name system) (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*) (setf (gethash (coerce-name name) *defined-systems*)
(cons (get-universal-time) system))) (cons (get-universal-time) system)))
...@@ -666,7 +672,7 @@ system.")) ...@@ -666,7 +672,7 @@ system."))
nil) nil)
(defmethod explain ((operation operation) (component component)) (defmethod explain ((operation operation) (component component))
(format *trace-output* "~&;;; ~A on ~A~%" (format *verbose-out* "~&;;; ~A on ~A~%"
operation component)) operation component))
;;; compile-op ;;; compile-op
...@@ -780,6 +786,10 @@ system.")) ...@@ -780,6 +786,10 @@ system."))
(defun operate (operation-class system &rest args) (defun operate (operation-class system &rest args)
(let* ((op (apply #'make-instance operation-class (let* ((op (apply #'make-instance operation-class
:original-initargs args args)) :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))) (system (if (typep system 'component) system (find-system system)))
(steps (traverse op system))) (steps (traverse op system)))
(with-compilation-unit () (with-compilation-unit ()
...@@ -977,40 +987,40 @@ Returns the new tree (which probably shares structure with the old one)" ...@@ -977,40 +987,40 @@ Returns the new tree (which probably shares structure with the old one)"
(defun run-shell-command (control-string &rest args) (defun run-shell-command (control-string &rest args)
"Interpolate ARGS into CONTROL-STRING as if by FORMAT, and "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
synchronously execute the result using a Bourne-compatible shell, with 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))) (let ((command (apply #'format nil control-string args)))
(format *trace-output* "; $ ~A~%" command) (format *verbose-out* "; $ ~A~%" command)
#+sbcl #+sbcl
(sb-impl::process-exit-code (sb-impl::process-exit-code
(sb-ext:run-program (sb-ext:run-program
"/bin/sh" "/bin/sh"
(list "-c" command) (list "-c" command)
:input nil :output *trace-output*)) :input nil :output *verbose-out*))
#+(or cmu scl) #+(or cmu scl)
(ext:process-exit-code (ext:process-exit-code
(ext:run-program (ext:run-program
"/bin/sh" "/bin/sh"
(list "-c" command) (list "-c" command)
:input nil :output *trace-output*)) :input nil :output *verbose-out*))
#+allegro #+allegro
(excl:run-shell-command command :input nil :output *trace-output*) (excl:run-shell-command command :input nil :output *verbose-out*)
#+lispworks #+lispworks
(system:call-system-showing-output (system:call-system-showing-output
command command
:shell-type "/bin/sh" :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) (ext:run-shell-command command :output :terminal :wait t)
#+openmcl #+openmcl
(nth-value 1 (nth-value 1
(ccl:external-process-status (ccl:external-process-status
(ccl:run-program "/bin/sh" (list "-c" command) (ccl:run-program "/bin/sh" (list "-c" command)
:input nil :output *trace-output* :input nil :output *verbose-out*
:wait t))) :wait t)))
#-(or openmcl clisp lispworks allegro scl cmu sbcl) #-(or openmcl clisp lispworks allegro scl cmu sbcl)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment