-;;; This is asdf: Another System Definition Facility. $Revision$
+;;; This is asdf: Another System Definition Facility.
+;;; hash - $Format:%H$
;;;
;;; Feedback, bug reports, and patches are all welcome: please mail to
-;;; <cclan-list@lists.sf.net>. But note first that the canonical
-;;; source for asdf is presently the cCLan CVS repository at
-;;; <URL:http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/>
+;;; <asdf-devel@common-lisp.net>. But note first that the canonical
+;;; source for asdf is presently on common-lisp.net at
+;;; <URL:http://common-lisp.net/project/asdf/>
;;;
;;; If you obtained this copy from anywhere else, and you experience
;;; trouble using it, or find bugs, you may want to check at the
;;; location above for a more recent version (and for documentation
;;; and test files, if your copy came without them) before reporting
-;;; bugs. There are usually two "supported" revisions - the CVS HEAD
+;;; bugs. There are usually two "supported" revisions - the git HEAD
;;; is the latest development version, whereas the revision tagged
;;; RELEASE may be slightly older but is considered `stable'
-;;; Copyright (c) 2001-2003 Daniel Barlow and contributors
+;;; Copyright (c) 2001-2009 Daniel Barlow and contributors
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining
;;; a copy of this software and associated documentation files (the
(defpackage #:asdf
(:export #:defsystem #:oos #:operate #:find-system #:run-shell-command
#:system-definition-pathname #:find-component ; miscellaneous
- #:hyperdocumentation #:hyperdoc
-
- #:compile-op #:load-op #:load-source-op #:test-system-version
+ #:compile-system #:load-system #:test-system
+ #:compile-op #:load-op #:load-source-op
#:test-op
- #:operation ; operations
- #:feature ; sort-of operation
- #:version ; metaphorically sort-of an operation
+ #:operation ; operations
+ #:feature ; sort-of operation
+ #:version ; metaphorically sort-of an operation
- #:input-files #:output-files #:perform ; operation methods
+ #:input-files #:output-files #:perform ; operation methods
#:operation-done-p #:explain
#:component #:source-file
#:system-author
#:system-maintainer
#:system-license
+ #:system-licence
+ #:system-source-file
+ #:system-relative-pathname
#:operation-on-warnings
#:operation-on-failure
- ;#:*component-parent-pathname*
+ ;#:*component-parent-pathname*
#:*system-definition-search-functions*
#:*central-registry* ; variables
#:*compile-file-warnings-behaviour*
#:error-component #:error-operation
#:system-definition-error
#:missing-component
+ #:missing-component-of-version
#:missing-dependency
+ #:missing-dependency-of-version
#:circular-dependency ; errors
+ #:duplicate-names
+ #:try-recompiling
#:retry
#:accept ; restarts
+ #:standard-asdf-method-combination
+ #:around ; protocol assistants
)
(:use :cl))
-#+nil
-(error "The author of this file habitually uses #+nil to comment out forms. But don't worry, it was unlikely to work in the New Implementation of Lisp anyway")
+#+nil
+(error "The author of this file habitually uses #+nil to comment out ~
+ forms. But don't worry, it was unlikely to work in the New ~
+ Implementation of Lisp anyway")
(in-package #:asdf)
-(defvar *asdf-revision* (let* ((v "$Revision$")
- (colon (or (position #\: v) -1))
- (dot (position #\. v)))
- (and v colon dot
- (list (parse-integer v :start (1+ colon)
- :junk-allowed t)
- (parse-integer v :start (1+ dot)
- :junk-allowed t)))))
+(defvar *asdf-revision*
+ ;; find first tag that looks like /tags/[0-9]*\.[0-9]*. E.g., /tags/1.34
+ ;; return nil or a list of the major and minor version numbers
+ (let* ((v "$Format:%d$")
+ (to-find "tags/")
+ (start 0))
+ (when v
+ (loop for tag-start = (search to-find v :test #'char= :start2 start)
+ while tag-start do
+ (when tag-start
+ (let ((dot (position #\. v :start tag-start))
+ (space (position #\space v :start tag-start)))
+ (when (and dot (or (not space) (< dot space)))
+ ;; success
+ (return
+ (list (parse-integer v :start (+ tag-start (length to-find))
+ :junk-allowed t)
+ (parse-integer v :start (1+ dot)
+ :junk-allowed t))))
+ (setf start (1+ tag-start))))))))
(defvar *compile-file-warnings-behaviour* :warn)
+
(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn)
(defvar *verbose-out* nil)
+(defparameter +asdf-methods+
+ '(perform explain output-files operation-done-p))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; utility stuff
(make-pathname :name nil :type nil :defaults pathname))
(define-modify-macro appendf (&rest args)
- append "Append onto list")
+ append "Append onto list")
+
+(defun asdf-message (format-string &rest format-args)
+ (declare (dynamic-extent format-args))
+ (apply #'format *verbose-out* format-string format-args))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; classes, condiitons
(define-condition circular-dependency (system-definition-error)
((components :initarg :components :reader circular-dependency-components)))
+(define-condition duplicate-names (system-definition-error)
+ ((name :initarg :name :reader duplicate-names-name)))
+
(define-condition missing-component (system-definition-error)
((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
- (version :initform nil :reader missing-version :initarg :version)
(parent :initform nil :reader missing-parent :initarg :parent)))
+(define-condition missing-component-of-version (missing-component)
+ ((version :initform nil :reader missing-version :initarg :version)))
+
(define-condition missing-dependency (missing-component)
((required-by :initarg :required-by :reader missing-required-by)))
+(define-condition missing-dependency-of-version (missing-dependency
+ missing-component-of-version)
+ ())
+
(define-condition operation-error (error)
((component :reader error-component :initarg :component)
(operation :reader error-operation :initarg :operation))
"Component name: designator for a string composed of portable pathname characters")
(version :accessor component-version :initarg :version)
(in-order-to :initform nil :initarg :in-order-to)
- ;;; XXX crap name
+ ;; XXX crap name
(do-first :initform nil :initarg :do-first)
;; methods defined using the "inline" style inside a defsystem form:
;; need to store them somewhere so we can delete them when the system
;;;; methods: components
(defmethod print-object ((c missing-component) s)
- (format s "~@<component ~S not found~
- ~@[ or does not match version ~A~]~
+ (format s "~@<component ~S not found~
~@[ in ~A~]~@:>"
(missing-requires c)
- (missing-version c)
(when (missing-parent c)
(component-name (missing-parent c)))))
+(defmethod print-object ((c missing-component-of-version) s)
+ (format s "~@<component ~S does not match version ~A~
+ ~@[ in ~A~]~@:>"
+ (missing-requires c)
+ (missing-version c)
+ (when (missing-parent c)
+ (component-name (missing-parent c)))))
+
(defgeneric component-system (component)
(:documentation "Find the top-level system containing COMPONENT"))
:accessor system-long-description :initarg :long-description)
(author :accessor system-author :initarg :author)
(maintainer :accessor system-maintainer :initarg :maintainer)
- (licence :accessor system-licence :initarg :licence)))
+ (licence :accessor system-licence :initarg :licence
+ :accessor system-license :initarg :license)))
;;; version-satisfies
(nreverse
(let ((list nil) (start 0) (words 0) end)
(loop
- (when (and max (>= words (1- max)))
- (return (cons (subseq string start) list)))
- (setf end (position-if #'is-ws string :start start))
- (push (subseq string start end) list)
- (incf words)
- (unless end (return list))
- (setf start (1+ end)))))))
+ (when (and max (>= words (1- max)))
+ (return (cons (subseq string start) list)))
+ (setf end (position-if #'is-ws string :start start))
+ (push (subseq string start end) list)
+ (incf words)
+ (unless end (return list))
+ (setf start (1+ end)))))))
(defgeneric version-satisfies (component version))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; finding systems
-(defvar *defined-systems* (make-hash-table :test 'equal))
+(defun make-defined-systems-table ()
+ (make-hash-table :test 'equal))
+
+(defvar *defined-systems* (make-defined-systems-table))
+
(defun coerce-name (name)
- (typecase name
- (component (component-name name))
- (symbol (string-downcase (symbol-name name)))
- (string name)
- (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
+ (typecase name
+ (component (component-name name))
+ (symbol (string-downcase (symbol-name name)))
+ (string name)
+ (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
+
+(defun system-registered-p (name)
+ (gethash (coerce-name name) *defined-systems*))
+
;;; for the sake of keeping things reasonably neat, we adopt a
;;; convention that functions in this list are prefixed SYSDEF-
'(sysdef-central-registry-search))
(defun system-definition-pathname (system)
- (some (lambda (x) (funcall x system))
- *system-definition-search-functions*))
+ (let ((system-name (coerce-name system)))
+ (or
+ (some (lambda (x) (funcall x system-name))
+ *system-definition-search-functions*)
+ (let ((system-pair (system-registered-p system-name)))
+ (and system-pair
+ (system-source-file (cdr system-pair)))))))
(defvar *central-registry*
- '(*default-pathname-defaults*
- #+nil "/home/dan/src/sourceforge/cclan/asdf/systems/"
- #+nil "telent:asdf;systems;"))
+ '(*default-pathname-defaults*)
+"A list of 'system directory designators' ASDF uses to find systems.
+
+A 'system directory designator' is a pathname or a function
+which evaluates to a pathname. For example:
+
+ (setf asdf:*central-registry*
+ (list '*default-pathname-defaults*
+ #p\"/home/me/cl/systems/\"
+ #p\"/usr/share/common-lisp/systems/\"))
+")
(defun sysdef-central-registry-search (system)
(let ((name (coerce-name system)))
(if (and file (probe-file file))
(return file)))))))
+(defun make-temporary-package ()
+ (flet ((try (counter)
+ (ignore-errors
+ (make-package (format nil "ASDF~D" counter)
+ :use '(:cl :asdf)))))
+ (do* ((counter 0 (+ counter 1))
+ (package (try counter) (try counter)))
+ (package package))))
(defun find-system (name &optional (error-p t))
(let* ((name (coerce-name name))
- (in-memory (gethash name *defined-systems*))
+ (in-memory (system-registered-p name))
(on-disk (system-definition-pathname name)))
(when (and on-disk
(or (not in-memory)
(< (car in-memory) (file-write-date on-disk))))
- (let ((*package* (make-package (gensym #.(package-name *package*))
- :use '(:cl :asdf))))
- (format *verbose-out*
+ (let ((package (make-temporary-package)))
+ (unwind-protect
+ (let ((*package* package))
+ (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
*package*)
- (load on-disk)))
- (let ((in-memory (gethash name *defined-systems*)))
+ (load on-disk))
+ (delete-package package))))
+ (let ((in-memory (system-registered-p name)))
(if in-memory
(progn (if on-disk (setf (car in-memory) (file-write-date on-disk)))
(cdr in-memory))
(if error-p (error 'missing-component :requires name))))))
(defun register-system (name system)
- (format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
- (setf (gethash (coerce-name name) *defined-systems*)
+ (asdf-message "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
+ (setf (gethash (coerce-name name) *defined-systems*)
(cons (get-universal-time) system)))
-(defun system-registered-p (name)
- (gethash (coerce-name name) *defined-systems*))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; finding components
(defmethod source-file-type ((c static-file) (s module)) nil)
(defmethod component-relative-pathname ((component source-file))
- (let* ((*default-pathname-defaults* (component-parent-pathname component))
- (name-type
- (make-pathname
- :name (component-name component)
- :type (source-file-type component
- (component-system component)))))
- (if (slot-value component 'relative-pathname)
+ (let ((relative-pathname (slot-value component 'relative-pathname)))
+ (if relative-pathname
(merge-pathnames
- (slot-value component 'relative-pathname)
- name-type)
- name-type)))
+ relative-pathname
+ (make-pathname
+ :type (source-file-type component (component-system component))))
+ (let* ((*default-pathname-defaults*
+ (component-parent-pathname component))
+ (name-type
+ (make-pathname
+ :name (component-name component)
+ :type (source-file-type component
+ (component-system component)))))
+ name-type))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; operations
;; empty method to disable initarg validity checking
)
-(defgeneric perform (operation component))
-(defgeneric operation-done-p (operation component))
-(defgeneric explain (operation component))
-(defgeneric output-files (operation component))
-(defgeneric input-files (operation component))
+(define-method-combination standard-asdf-method-combination ()
+ ((around-asdf (around))
+ (around (:around))
+ (before (:before))
+ (primary () :required t)
+ (after (:after)))
+ (flet ((call-methods (methods)
+ (mapcar #'(lambda (method)
+ `(call-method ,method))
+ methods)))
+ (let* ((form (if (or before after (rest primary))
+ `(multiple-value-prog1
+ (progn ,@(call-methods before)
+ (call-method ,(first primary)
+ ,(rest primary)))
+ ,@(call-methods (reverse after)))
+ `(call-method ,(first primary))))
+ (standard-form (if around
+ `(call-method ,(first around)
+ (,@(rest around)
+ (make-method ,form)))
+ form)))
+ (if around-asdf
+ `(call-method ,(first around-asdf)
+ (,@(rest around-asdf) (make-method ,standard-form)))
+ standard-form))))
+
+(defgeneric perform (operation component)
+ (:method-combination standard-asdf-method-combination))
+(defgeneric operation-done-p (operation component)
+ (:method-combination standard-asdf-method-combination))
+(defgeneric explain (operation component)
+ (:method-combination standard-asdf-method-combination))
+(defgeneric output-files (operation component)
+ (:method-combination standard-asdf-method-combination))
+(defgeneric input-files (operation component)
+ (:method-combination standard-asdf-method-combination))
(defun node-for (o c)
(cons (class-name (class-of o)) c))
(defgeneric operation-ancestor (operation)
- (:documentation "Recursively chase the operation's parent pointer until we get to the head of the tree"))
+ (:documentation
+ "Recursively chase the operation's parent pointer until we get to
+the head of the tree"))
(defmethod operation-ancestor ((operation operation))
(aif (operation-parent operation)
:parent o :original-initargs args args)))))
+(defgeneric component-visited-p (operation component))
+
(defgeneric visit-component (operation component data))
(defmethod visit-component ((o operation) (c component) data)
(push (cons (node-for o c) data)
(operation-visited-nodes (operation-ancestor o)))))
-(defgeneric component-visited-p (operation component))
-
(defmethod component-visited-p ((o operation) (c component))
(assoc (node-for o c)
(operation-visited-nodes (operation-ancestor o))
(defgeneric component-visiting-p (operation component))
(defmethod component-visiting-p ((o operation) (c component))
- (let ((node (cons o c)))
+ (let ((node (node-for o c)))
(member node (operation-visiting-nodes (operation-ancestor o))
:test 'equal)))
-(defgeneric component-depends-on (operation component))
+(defgeneric component-depends-on (operation component)
+ (:documentation
+ "Returns a list of dependencies needed by the component to perform
+ the operation. A dependency has one of the following forms:
+
+ (<operation> <component>*), where <operation> is a class
+ designator and each <component> is a component
+ designator, which means that the component depends on
+ <operation> having been performed on each <component>; or
+
+ (FEATURE <feature>), which means that the component depends
+ on <feature>'s presence in *FEATURES*.
+
+ Methods specialized on subclasses of existing component types
+ should usually append the results of CALL-NEXT-METHOD to the
+ list."))
+
+(defmethod component-depends-on ((op-spec symbol) (c component))
+ (component-depends-on (make-instance op-spec) c))
(defmethod component-depends-on ((o operation) (c component))
(cdr (assoc (class-name (class-of o))
(defmethod input-files ((operation operation) (c module)) nil)
(defmethod operation-done-p ((o operation) (c component))
- (let ((out-files (output-files o c))
- (in-files (input-files o c)))
- (cond ((and (not in-files) (not out-files))
- ;; arbitrary decision: an operation that uses nothing to
- ;; produce nothing probably isn't doing much
- t)
- ((not out-files)
- (let ((op-done
- (gethash (type-of o)
- (component-operation-times c))))
- (and op-done
- (>= op-done
- (or (apply #'max
- (mapcar #'file-write-date in-files)) 0)))))
- ((not in-files) nil)
- (t
- (and
- (every #'probe-file out-files)
- (> (apply #'min (mapcar #'file-write-date out-files))
- (apply #'max (mapcar #'file-write-date in-files)) ))))))
+ (flet ((fwd-or-return-t (file)
+ ;; if FILE-WRITE-DATE returns NIL, it's possible that the
+ ;; user or some other agent has deleted an input file. If
+ ;; that's the case, well, that's not good, but as long as
+ ;; the operation is otherwise considered to be done we
+ ;; could continue and survive.
+ (let ((date (file-write-date file)))
+ (cond
+ (date)
+ (t
+ (warn "~@<Missing FILE-WRITE-DATE for ~S: treating ~
+ operation ~S on component ~S as done.~@:>"
+ file o c)
+ (return-from operation-done-p t))))))
+ (let ((out-files (output-files o c))
+ (in-files (input-files o c)))
+ (cond ((and (not in-files) (not out-files))
+ ;; arbitrary decision: an operation that uses nothing to
+ ;; produce nothing probably isn't doing much
+ t)
+ ((not out-files)
+ (let ((op-done
+ (gethash (type-of o)
+ (component-operation-times c))))
+ (and op-done
+ (>= op-done
+ (apply #'max
+ (mapcar #'fwd-or-return-t in-files))))))
+ ((not in-files) nil)
+ (t
+ (and
+ (every #'probe-file out-files)
+ (> (apply #'min (mapcar #'file-write-date out-files))
+ (apply #'max (mapcar #'fwd-or-return-t in-files)))))))))
;;; So you look at this code and think "why isn't it a bunch of
;;; methods". And the answer is, because standard method combination
;;; runs :before methods most->least-specific, which is back to front
-;;; for our purposes. And CLISP doesn't have non-standard method
-;;; combinations, so let's keep it simple and aspire to portability
+;;; for our purposes.
(defgeneric traverse (operation component))
(defmethod traverse ((operation operation) (c component))
(let ((forced nil))
- (labels ((do-one-dep (required-op required-c required-v)
+ (labels ((%do-one-dep (required-op required-c required-v)
(let* ((dep-c (or (find-component
(component-parent c)
;; XXX tacky. really we should build the
;; in-order-to slot with canonicalized
;; names instead of coercing this late
(coerce-name required-c) required-v)
- (error 'missing-dependency :required-by c
- :version required-v
- :requires required-c)))
+ (if required-v
+ (error 'missing-dependency-of-version
+ :required-by c
+ :version required-v
+ :requires required-c)
+ (error 'missing-dependency
+ :required-by c
+ :requires required-c))))
(op (make-sub-operation c operation dep-c required-op)))
(traverse op dep-c)))
+ (do-one-dep (required-op required-c required-v)
+ (loop
+ (restart-case
+ (return (%do-one-dep required-op required-c required-v))
+ (retry ()
+ :report (lambda (s)
+ (format s "~@<Retry loading component ~S.~@:>"
+ required-c))
+ :test
+ (lambda (c)
+#|
+ (print (list :c1 c (typep c 'missing-dependency)))
+ (when (typep c 'missing-dependency)
+ (print (list :c2 (missing-requires c) required-c
+ (equalp (missing-requires c)
+ required-c))))
+|#
+ (and (typep c 'missing-dependency)
+ (equalp (missing-requires c)
+ required-c)))))))
(do-dep (op dep)
(cond ((eq op 'feature)
(or (member (car dep) *features*)
- (error 'missing-dependency :required-by c
- :requires (car dep) :version nil)))
+ (error 'missing-dependency
+ :required-by c
+ :requires (car dep))))
(t
(dolist (d dep)
(cond ((consp d)
- (assert (string-equal
- (symbol-name (first d))
- "VERSION"))
- (appendf forced
- (do-one-dep op (second d) (third d))))
+ (cond ((string-equal
+ (symbol-name (first d))
+ "VERSION")
+ (appendf
+ forced
+ (do-one-dep op (second d) (third d))))
+ ((and (string-equal
+ (symbol-name (first d))
+ "FEATURE")
+ (find (second d) *features*
+ :test 'string-equal))
+ (appendf
+ forced
+ (do-one-dep op (second d) (third d))))
+ (t
+ (error "Dependencies must be (:version <version>), (:feature <feature>), or a name"))))
(t
(appendf forced (do-one-dep op d nil)))))))))
(aif (component-visited-p operation c)
(if (component-visiting-p operation c)
(error 'circular-dependency :components (list c)))
(setf (visiting-component operation c) t)
- (loop for (required-op . deps) in (component-depends-on operation c)
- do (do-dep required-op deps))
- ;; constituent bits
- (let ((module-ops
- (when (typep c 'module)
- (let ((at-least-one nil)
- (forced nil)
- (error nil))
- (loop for kid in (module-components c)
- do (handler-case
- (appendf forced (traverse operation kid ))
- (missing-dependency (condition)
- (if (eq (module-if-component-dep-fails c) :fail)
- (error condition))
- (setf error condition))
- (:no-error (c)
- (declare (ignore c))
- (setf at-least-one t))))
- (when (and (eq (module-if-component-dep-fails c) :try-next)
- (not at-least-one))
- (error error))
- forced))))
- ;; now the thing itself
- (when (or forced module-ops
- (not (operation-done-p operation c))
- (let ((f (operation-forced (operation-ancestor operation))))
- (and f (or (not (consp f))
- (member (component-name
- (operation-ancestor operation))
- (mapcar #'coerce-name f)
- :test #'string=)))))
- (let ((do-first (cdr (assoc (class-name (class-of operation))
- (slot-value c 'do-first)))))
- (loop for (required-op . deps) in do-first
- do (do-dep required-op deps)))
- (setf forced (append (delete 'pruned-op forced :key #'car)
- (delete 'pruned-op module-ops :key #'car)
- (list (cons operation c))))))
- (setf (visiting-component operation c) nil)
+ (unwind-protect
+ (progn
+ (loop for (required-op . deps) in
+ (component-depends-on operation c)
+ do (do-dep required-op deps))
+ ;; constituent bits
+ (let ((module-ops
+ (when (typep c 'module)
+ (let ((at-least-one nil)
+ (forced nil)
+ (error nil))
+ (loop for kid in (module-components c)
+ do (handler-case
+ (appendf forced (traverse operation kid ))
+ (missing-dependency (condition)
+ (if (eq (module-if-component-dep-fails c)
+ :fail)
+ (error condition))
+ (setf error condition))
+ (:no-error (c)
+ (declare (ignore c))
+ (setf at-least-one t))))
+ (when (and (eq (module-if-component-dep-fails c)
+ :try-next)
+ (not at-least-one))
+ (error error))
+ forced))))
+ ;; now the thing itself
+ (when (or forced module-ops
+ (not (operation-done-p operation c))
+ (let ((f (operation-forced
+ (operation-ancestor operation))))
+ (and f (or (not (consp f))
+ (member (component-name
+ (operation-ancestor operation))
+ (mapcar #'coerce-name f)
+ :test #'string=)))))
+ (let ((do-first (cdr (assoc (class-name (class-of operation))
+ (slot-value c 'do-first)))))
+ (loop for (required-op . deps) in do-first
+ do (do-dep required-op deps)))
+ (setf forced (append (delete 'pruned-op forced :key #'car)
+ (delete 'pruned-op module-ops :key #'car)
+ (list (cons operation c)))))))
+ (setf (visiting-component operation c) nil))
(visit-component operation c (and forced t))
forced)))
nil)
(defmethod explain ((operation operation) (component component))
- (format *verbose-out* "~&;;; ~A on ~A~%" operation component))
+ (asdf-message "~&;;; ~A on ~A~%" operation component))
;;; compile-op
(let ((source-file (component-pathname c))
(output-file (car (output-files operation c))))
(multiple-value-bind (output warnings-p failure-p)
- (compile-file source-file
- :output-file output-file)
- ;(declare (ignore output))
+ (compile-file source-file :output-file output-file)
(when warnings-p
(case (operation-on-warnings operation)
(:warn (warn
(defmethod output-files ((operation compile-op) (c static-file))
nil)
+(defmethod input-files ((op compile-op) (c static-file))
+ nil)
+
+
;;; load-op
-(defclass load-op (operation) ())
+(defclass basic-load-op (operation) ())
+
+(defclass load-op (basic-load-op) ())
(defmethod perform ((o load-op) (c cl-source-file))
(mapcar #'load (input-files o c)))
+(defmethod perform around ((o load-op) (c cl-source-file))
+ (let ((state :initial))
+ (loop until (or (eq state :success)
+ (eq state :failure)) do
+ (case state
+ (:recompiled
+ (setf state :failure)
+ (call-next-method)
+ (setf state :success))
+ (:failed-load
+ (setf state :recompiled)
+ (perform (make-instance 'asdf:compile-op) c))
+ (t
+ (with-simple-restart
+ (try-recompiling "Recompile ~a and try loading it again"
+ (component-name c))
+ (setf state :failed-load)
+ (call-next-method)
+ (setf state :success)))))))
+
+(defmethod perform around ((o compile-op) (c cl-source-file))
+ (let ((state :initial))
+ (loop until (or (eq state :success)
+ (eq state :failure)) do
+ (case state
+ (:recompiled
+ (setf state :failure)
+ (call-next-method)
+ (setf state :success))
+ (:failed-compile
+ (setf state :recompiled)
+ (perform (make-instance 'asdf:compile-op) c))
+ (t
+ (with-simple-restart
+ (try-recompiling "Try recompiling ~a"
+ (component-name c))
+ (setf state :failed-compile)
+ (call-next-method)
+ (setf state :success)))))))
+
(defmethod perform ((operation load-op) (c static-file))
nil)
+
(defmethod operation-done-p ((operation load-op) (c static-file))
t)
;;; load-source-op
-(defclass load-source-op (operation) ())
+(defclass load-source-op (basic-load-op) ())
(defmethod perform ((o load-source-op) (c cl-source-file))
(let ((source (component-pathname c)))
(defmethod perform ((operation test-op) (c component))
nil)
+(defmethod operation-done-p ((operation test-op) (c system))
+ "Testing a system is _never_ done."
+ 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)
- *trace-output*
- (make-broadcast-stream)))
- (system (if (typep system 'component) system (find-system system)))
- (steps (traverse op system)))
- (with-compilation-unit ()
- (loop for (op . component) in steps do
- (loop
- (restart-case
- (progn (perform op component)
- (return))
- (retry ()
- :report
- (lambda (s)
- (format s "~@<Retry performing ~S on ~S.~@:>"
- op component)))
- (accept ()
- :report
- (lambda (s)
- (format s
- "~@<Continue, treating ~S on ~S as ~
- having been successful.~@:>"
- op component))
- (setf (gethash (type-of op)
- (component-operation-times component))
- (get-universal-time))
- (return))))))))
-
-(defun oos (&rest args)
- "Alias of OPERATE function"
- (apply #'operate args))
+(defun operate (operation-class system &rest args &key (verbose t) version force
+ &allow-other-keys)
+ (declare (ignore force))
+ (let* ((*package* *package*)
+ (*readtable* *readtable*)
+ (op (apply #'make-instance operation-class
+ :original-initargs args
+ args))
+ (*verbose-out* (if verbose *standard-output* (make-broadcast-stream)))
+ (system (if (typep system 'component) system (find-system system))))
+ (unless (version-satisfies system version)
+ (error 'missing-component-of-version :requires system :version version))
+ (let ((steps (traverse op system)))
+ (with-compilation-unit ()
+ (loop for (op . component) in steps do
+ (loop
+ (restart-case
+ (progn (perform op component)
+ (return))
+ (retry ()
+ :report
+ (lambda (s)
+ (format s "~@<Retry performing ~S on ~S.~@:>"
+ op component)))
+ (accept ()
+ :report
+ (lambda (s)
+ (format s "~@<Continue, treating ~S on ~S as ~
+ having been successful.~@:>"
+ op component))
+ (setf (gethash (type-of op)
+ (component-operation-times component))
+ (get-universal-time))
+ (return)))))))))
+
+(defun oos (operation-class system &rest args &key force (verbose t) version
+ &allow-other-keys)
+ (declare (ignore force verbose version))
+ (apply #'operate operation-class system args))
+
+(let ((operate-docstring
+ "Operate does three things:
+
+1. It creates an instance of `operation-class` using any keyword parameters
+as initargs.
+2. It finds the asdf-system specified by `system` (possibly loading
+it from disk).
+3. It then calls `traverse` with the operation and system as arguments
+
+The traverse operation is wrapped in `with-compilation-unit` and error
+handling code. If a `version` argument is supplied, then operate also
+ensures that the system found satisfies it using the `version-satisfies`
+method."))
+ (setf (documentation 'oos 'function)
+ (format nil
+ "Short for _operate on system_ and an alias for the [operate][] function. ~&~&~a"
+ operate-docstring))
+ (setf (documentation 'operate 'function)
+ operate-docstring))
+
+(defun load-system (system &rest args &key force (verbose t) version)
+ "Shorthand for `(operate 'asdf:load-op system)`. See [operate][] for details."
+ (declare (ignore force verbose version))
+ (apply #'operate 'load-op system args))
+
+(defun compile-system (system &rest args &key force (verbose t) version)
+ "Shorthand for `(operate 'asdf:compile-op system)`. See [operate][] for details."
+ (declare (ignore force verbose version))
+ (apply #'operate 'compile-op system args))
+
+(defun test-system (system &rest args &key force (verbose t) version)
+ "Shorthand for `(operate 'asdf:test-op system)`. See [operate][] for details."
+ (declare (ignore force verbose version))
+ (apply #'operate 'test-op system args))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; syntax
(aux key arglist)))
(defmacro defsystem (name &body options)
- (destructuring-bind (&key pathname (class 'system) &allow-other-keys) options
+ (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
+ &allow-other-keys)
+ options
(let ((component-options (remove-keyword :class options)))
`(progn
- ;; system must be registered before we parse the body, otherwise
- ;; we recur when trying to find an existing system of the same name
- ;; to reuse options (e.g. pathname) from
- (let ((s (system-registered-p ',name)))
- (cond ((and s (eq (type-of (cdr s)) ',class))
- (setf (car s) (get-universal-time)))
- (s
- #+clisp
- (sysdef-error "Cannot redefine the existing system ~A with a different class" s)
- #-clisp
- (change-class (cdr s) ',class))
- (t
- (register-system (quote ,name)
- (make-instance ',class :name ',name)))))
- (parse-component-form nil (apply
- #'list
- :module (coerce-name ',name)
- :pathname
- (or ,pathname
- (pathname-sans-name+type
- (resolve-symlinks *load-truename*))
- *default-pathname-defaults*)
- ',component-options))))))
+ ;; system must be registered before we parse the body, otherwise
+ ;; we recur when trying to find an existing system of the same name
+ ;; to reuse options (e.g. pathname) from
+ (let ((s (system-registered-p ',name)))
+ (cond ((and s (eq (type-of (cdr s)) ',class))
+ (setf (car s) (get-universal-time)))
+ (s
+ (change-class (cdr s) ',class))
+ (t
+ (register-system (quote ,name)
+ (make-instance ',class :name ',name)))))
+ (parse-component-form nil (apply
+ #'list
+ :module (coerce-name ',name)
+ :pathname
+ ;; to avoid a note about unreachable code
+ ,(if pathname-arg-p
+ pathname
+ `(or (when *load-truename*
+ (pathname-sans-name+type
+ (resolve-symlinks
+ *load-truename*)))
+ *default-pathname-defaults*))
+ ',component-options))))))
(defun class-for-type (parent type)
- (let ((class
- (find-class
- (or (find-symbol (symbol-name type) *package*)
- (find-symbol (symbol-name type) #.(package-name *package*)))
- nil)))
+ (let* ((extra-symbols (list (find-symbol (symbol-name type) *package*)
+ (find-symbol (symbol-name type)
+ (load-time-value
+ (package-name :asdf)))))
+ (class (dolist (symbol (if (keywordp type)
+ extra-symbols
+ (cons type extra-symbols)))
+ (when (and symbol
+ (find-class symbol nil)
+ (subtypep symbol 'component))
+ (return (find-class symbol))))))
(or class
(and (eq type :file)
(or (module-default-component-class parent)
(defvar *serial-depends-on*)
+(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 check-component-input (type name weakly-depends-on depends-on components in-order-to)
+ "A partial test of the values of a component."
+ (when weakly-depends-on (warn "We got one! XXXXX"))
+ (unless (listp depends-on)
+ (sysdef-error-component ":depends-on must be a list."
+ type name depends-on))
+ (unless (listp weakly-depends-on)
+ (sysdef-error-component ":weakly-depends-on must be a list."
+ type name weakly-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 %remove-component-inline-methods (ret rest)
+ (loop for name in +asdf-methods+
+ do (map 'nil
+ ;; this is inefficient as most of the stored
+ ;; methods will not be for this particular gf n
+ ;; But this is hardly performance-critical
+ (lambda (m)
+ (remove-method (symbol-function name) m))
+ (component-inline-methods ret)))
+ ;; clear methods, then add the new ones
+ (setf (component-inline-methods ret) nil)
+ (loop for name in +asdf-methods+
+ for v = (getf rest (intern (symbol-name name) :keyword))
+ when v do
+ (destructuring-bind (op qual (o c) &body body) v
+ (pushnew
+ (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
+ ,@body))
+ (component-inline-methods ret)))))
+
(defun parse-component-form (parent options)
+
(destructuring-bind
(type name &rest rest &key
;; the following list of keywords is reproduced below in the
;; remove-keys form. important to keep them in sync
components pathname default-component-class
perform explain output-files operation-done-p
+ weakly-depends-on
depends-on serial in-order-to
;; list ends
&allow-other-keys) options
- (check-component-input type name depends-on components in-order-to)
+ (declare (ignorable perform explain output-files operation-done-p))
+ (check-component-input type name weakly-depends-on depends-on components in-order-to)
+
+ (when (and parent
+ (find-component parent name)
+ ;; ignore the same object when rereading the defsystem
+ (not
+ (typep (find-component parent name)
+ (class-for-type parent type))))
+ (error 'duplicate-names :name name))
+
(let* ((other-args (remove-keys
'(components pathname default-component-class
perform explain output-files operation-done-p
+ weakly-depends-on
depends-on serial in-order-to)
rest))
(ret
(or (find-component parent name)
(make-instance (class-for-type parent type)))))
+ (when weakly-depends-on
+ (setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on))))
(when (boundp '*serial-depends-on*)
(setf depends-on
(concatenate 'list *serial-depends-on* depends-on)))
- (apply #'reinitialize-instance
- ret
+ (apply #'reinitialize-instance ret
:name (coerce-name name)
:pathname pathname
:parent parent
for c = (parse-component-form ret c-form)
collect c
if serial
- do (push (component-name c) *serial-depends-on*)))))
+ do (push (component-name c) *serial-depends-on*))))
+
+ ;; check for duplicate names
+ (let ((name-hash (make-hash-table :test #'equal)))
+ (loop for c in (module-components ret)
+ do
+ (if (gethash (component-name c)
+ name-hash)
+ (error 'duplicate-names
+ :name (component-name c))
+ (setf (gethash (component-name c)
+ name-hash)
+ t)))))
(setf (slot-value ret 'in-order-to)
(union-of-dependencies
(load-op (load-op ,@depends-on))))
(slot-value ret 'do-first) `((compile-op (load-op ,@depends-on))))
- (loop for (n v) in `((perform ,perform) (explain ,explain)
- (output-files ,output-files)
- (operation-done-p ,operation-done-p))
- do (map 'nil
- ;; this is inefficient as most of the stored
- ;; methods will not be for this particular gf n
- ;; But this is hardly performance-critical
- (lambda (m) (remove-method (symbol-function n) m))
- (component-inline-methods ret))
- when v
- do (destructuring-bind (op qual (o c) &body body) v
- (pushnew
- (eval `(defmethod ,n ,qual ((,o ,op) (,c (eql ,ret)))
- ,@body))
- (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)))
+ (%remove-component-inline-methods ret rest)
-(defun sysdef-error-component (msg type name value)
- (sysdef-error (concatenate 'string msg
- "~&The value specified for ~(~A~) ~A is ~W")
- type name value))
+ ret)))
(defun resolve-symlinks (path)
#-allegro (truename path)
;;; is ambiguous, send a bug report
(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
-output to *verbose-out*. 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 *verbose-out* "; $ ~A~%" command)
+ (asdf-message "; $ ~A~%" command)
#+sbcl
- (sb-impl::process-exit-code
+ (sb-ext:process-exit-code
(sb-ext:run-program
- "/bin/sh"
+ #+win32 "sh" #-win32 "/bin/sh"
(list "-c" command)
+ #+win32 #+win32 :search t
:input nil :output *verbose-out*))
#+(or cmu scl)
:input nil :output *verbose-out*))
#+allegro
- (excl:run-shell-command command :input nil :output *verbose-out*)
+ ;; will this fail if command has embedded quotes - it seems to work
+ (multiple-value-bind (stdout stderr exit-code)
+ (excl.osi:command-output
+ (format nil "~a -c \"~a\""
+ #+mswindows "sh" #-mswindows "/bin/sh" command)
+ :input nil :whole nil
+ #+mswindows :show-window #+mswindows :hide)
+ (format *verbose-out* "~{~&; ~a~%~}~%" stderr)
+ (format *verbose-out* "~{~&; ~a~%~}~%" stdout)
+ exit-code)
#+lispworks
(system:call-system-showing-output
:shell-type "/bin/sh"
:output-stream *verbose-out*)
- #+clisp ;XXX not exactly *verbose-out*, I know
+ #+clisp ;XXX not exactly *verbose-out*, I know
(ext:run-shell-command command :output :terminal :wait t)
#+openmcl
(ccl:run-program "/bin/sh" (list "-c" command)
:input nil :output *verbose-out*
:wait t)))
+
#+ecl ;; courtesy of Juan Jose Garcia Ripoll
(si:system command)
+
#-(or openmcl clisp lispworks allegro scl cmu sbcl ecl)
(error "RUN-SHELL-PROGRAM not implemented for this Lisp")
))
-
-(defgeneric hyperdocumentation (package name doc-type))
-(defmethod hyperdocumentation ((package symbol) name doc-type)
- (hyperdocumentation (find-package package) name doc-type))
-
-(defun hyperdoc (name doc-type)
- (hyperdocumentation (symbol-package name) name doc-type))
-
+(defgeneric system-source-file (system)
+ (:documentation "Return the source file in which system is defined."))
+
+(defmethod system-source-file ((system-name t))
+ (system-source-file (find-system system-name)))
+
+(defmethod system-source-file ((system system))
+ (let ((pn (and (slot-boundp system 'relative-pathname)
+ (make-pathname
+ :type "asd"
+ :name (asdf:component-name system)
+ :defaults (asdf:component-relative-pathname system)))))
+ (when pn
+ (probe-file pn))))
+
+(defun system-source-directory (system-name)
+ (make-pathname :name nil
+ :type nil
+ :defaults (system-source-file system-name)))
+
+(defun system-relative-pathname (system pathname &key name type)
+ ;; you're not allowed to muck with the return value of pathname-X
+ (let ((directory (copy-list (pathname-directory pathname))))
+ (when (eq (car directory) :absolute)
+ (setf (car directory) :relative))
+ (merge-pathnames
+ (make-pathname :name (or name (pathname-name pathname))
+ :type (or type (pathname-type pathname))
+ :directory directory)
+ (system-source-directory system))))
(pushnew :asdf *features*)
(asdf:operate 'asdf:load-op name)
t))))
- (pushnew
- '(merge-pathnames "systems/"
- (truename (sb-ext:posix-getenv "SBCL_HOME")))
- *central-registry*)
+ (defun contrib-sysdef-search (system)
+ (let ((home (sb-ext:posix-getenv "SBCL_HOME")))
+ (when (and home (not (string= home "")))
+ (let* ((name (coerce-name system))
+ (home (truename home))
+ (contrib (merge-pathnames
+ (make-pathname :directory `(:relative ,name)
+ :name name
+ :type "asd"
+ :case :local
+ :version :newest)
+ home)))
+ (probe-file contrib)))))
(pushnew
- '(merge-pathnames "site-systems/"
- (truename (sb-ext:posix-getenv "SBCL_HOME")))
+ '(let ((home (sb-ext:posix-getenv "SBCL_HOME")))
+ (when (and home (not (string= home "")))
+ (merge-pathnames "site-systems/" (truename home))))
*central-registry*)
(pushnew
(user-homedir-pathname))
*central-registry*)
- (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*))
+ (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*)
+ (pushnew 'contrib-sysdef-search *system-definition-search-functions*))
+
+(if *asdf-revision*
+ (asdf-message ";; ASDF, revision ~a" *asdf-revision*)
+ (asdf-message ";; ASDF, revision unknown; possibly a development version"))
(provide 'asdf)