-;;; This is asdf: Another System Definition Facility. 1.65
+;;; 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
#:hyperdocumentation #:hyperdoc
#:compile-op #:load-op #:load-source-op #:test-system-version
+ #:test-op
#:operation ; operations
#:feature ; sort-of operation
#:version ; metaphorically sort-of an operation
#: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
(in-package #:asdf)
-(defvar *asdf-revision* (let* ((v "1.65")
+(defvar *asdf-revision* (let* ((v "1.75")
(colon (or (position #\: v) -1))
(dot (position #\. v)))
(and v colon dot
(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
(< (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.
(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)))
(not (eql c dep-c)))
(when (eql force-p t)
(setf (getf args :force) nil))
- ;; note we lose the parent slot, because we don't want
- ;; forced to propagate backwards either (changes in depended-on
- ;; systems shouldn't force recompilation of the depending system)
(apply #'make-instance dep-o
- ;:parent o
+ :parent o
:original-initargs args args))
((subtypep (type-of o) dep-o)
o)
nil)
(defmethod explain ((operation operation) (component component))
- (format *trace-output* "~&;;; ~A on ~A~%"
+ (format *verbose-out* "~&;;; ~A on ~A~%"
operation component))
;;; compile-op
(component-property c 'last-loaded-as-source)))
nil t))
+(defclass test-op (operation) ())
+
+(defmethod perform ((operation test-op) (c component))
+ nil)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; invoking operations
(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 ()
depends-on serial in-order-to
;; list ends
&allow-other-keys) options
+ (check-component-input type name depends-on components in-order-to)
(let* ((other-args (remove-keys
'(components pathname default-component-class
perform explain output-files operation-done-p
(component-inline-methods ret))))
ret)))
+(defun check-component-input (type name depends-on components in-order-to)
+ "A partial test of the values of a component."
+ (unless (listp depends-on)
+ (sysdef-error-component ":depends-on must be a list."
+ type name depends-on))
+ (unless (listp components)
+ (sysdef-error-component ":components must be NIL or a list of components."
+ type name components))
+ (unless (and (listp in-order-to) (listp (car in-order-to)))
+ (sysdef-error-component ":in-order-to must be NIL or a list of components."
+ type name in-order-to)))
+
+(defun sysdef-error-component (msg type name value)
+ (sysdef-error (concatenate 'string msg
+ "~&The value specified for ~(~A~) ~A is ~W")
+ type name value))
(defun resolve-symlinks (path)
#-allegro (truename path)
(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)
#+(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)
- (provide name))))
+ (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/"
- (truename (sb-ext:posix-getenv "SBCL_HOME")))
+ '(merge-pathnames "systems/"
+ (truename (sb-ext:posix-getenv "SBCL_HOME")))
*central-registry*)
(pushnew
- (merge-pathnames "site-systems/"
- (truename (sb-ext:posix-getenv "SBCL_HOME")))
+ '(merge-pathnames "site-systems/"
+ (truename (sb-ext:posix-getenv "SBCL_HOME")))
*central-registry*)
(pushnew
- (merge-pathnames ".sbcl/systems/"
- (user-homedir-pathname))
+ '(merge-pathnames ".sbcl/systems/"
+ (user-homedir-pathname))
*central-registry*)
(pushnew 'module-provide-asdf sb-ext:*module-provider-functions*))
projects / sbcl.git / blobdiff