-;;; This is asdf: Another System Definition Facility. $\Revision: 1.62 $
+;;; This is asdf: Another System Definition Facility. 1.65
;;;
;;; Feedback, bug reports, and patches are all welcome: please mail to
;;; <cclan-list@lists.sf.net>. But note first that the canonical
(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
#:operation ; operations
(in-package #:asdf)
-(defvar *asdf-revision* (let* ((v "$\Revision: 1.62 $")
- (colon (position #\: v))
+(defvar *asdf-revision* (let* ((v "1.65")
+ (colon (or (position #\: v) -1))
(dot (position #\. v)))
(and v colon dot
(list (parse-integer v :start (1+ colon)
(t (sysdef-error (formatter "~@<invalid component designator ~A~@:>")
name))))
+;;; for the sake of keeping things reasonably neat, we adopt a
+;;; convention that functions in this list are prefixed SYSDEF-
+
+(defvar *system-definition-search-functions*
+ '(sysdef-central-registry-search))
+
(defun system-definition-pathname (system)
(some (lambda (x) (funcall x system))
*system-definition-search-functions*))
+(defvar *central-registry*
+ '(*default-pathname-defaults*
+ #+nil "/home/dan/src/sourceforge/cclan/asdf/systems/"
+ #+nil "telent:asdf;systems;"))
+
(defun sysdef-central-registry-search (system)
(let ((name (coerce-name system)))
(block nil
(return file)))))))
-(defvar *central-registry*
- '(*default-pathname-defaults*
- #+nil "/home/dan/src/sourceforge/cclan/asdf/systems/"
- #+nil "telent:asdf;systems;"))
-
-;;; for the sake of keeping things reasonably neat, we adopt a
-;;; convention that functions in this list are prefixed SYSDEF-
-
-(defvar *system-definition-search-functions*
- '(sysdef-central-registry-search))
-
(defun find-system (name &optional (error-p t))
(let* ((name (coerce-name name))
(in-memory (gethash name *defined-systems*))
(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)))
- (or (slot-value component 'relative-pathname)
- (make-pathname :name (component-name component)
- :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)))))
+ (if (slot-value component 'relative-pathname)
+ (merge-pathnames
+ (slot-value component 'relative-pathname)
+ name-type)
+ name-type)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; operations
;;; one of these is instantiated whenever (operate ) is called
(defclass operation ()
- ((forced-p :initform nil :initarg :force :accessor operation-forced-p )
+ ((forced :initform nil :initarg :force :accessor operation-forced)
(original-initargs :initform nil :initarg :original-initargs
:accessor operation-original-initargs)
(visited-nodes :initform nil :accessor operation-visited-nodes)
(visiting-nodes :initform nil :accessor operation-visiting-nodes)
(parent :initform nil :initarg :parent :accessor operation-parent)))
+(defmethod print-object ((o operation) stream)
+ (print-unreadable-object (o stream :type t :identity t)
+ (ignore-errors
+ (prin1 (operation-original-initargs o) stream))))
+
(defmethod shared-initialize :after ((operation operation) slot-names
&key force
&allow-other-keys)
(operation-ancestor it)
operation))
-(defun make-sub-operation (o type)
- (let ((args (operation-original-initargs o)))
- (apply #'make-instance type :parent o :original-initargs args args)))
+
+(defun make-sub-operation (c o dep-c dep-o)
+ (let* ((args (copy-list (operation-original-initargs o)))
+ (force-p (getf args :force)))
+ ;; note explicit comparison with T: any other non-NIL force value
+ ;; (e.g. :recursive) will pass through
+ (cond ((and (null (component-parent c))
+ (null (component-parent dep-c))
+ (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
+ :original-initargs args args))
+ ((subtypep (type-of o) dep-o)
+ o)
+ (t
+ (apply #'make-instance dep-o
+ :parent o :original-initargs args args)))))
+
(defgeneric visit-component (operation component data))
(defmethod traverse ((operation operation) (c component))
(let ((forced nil))
(labels ((do-one-dep (required-op required-c required-v)
- (let ((op (if (subtypep (type-of operation) required-op)
- operation
- (make-sub-operation operation required-op)))
- (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))))
+ (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)))
+ (op (make-sub-operation c operation dep-c required-op)))
(traverse op dep-c)))
(do-dep (op dep)
(cond ((eq op 'feature)
forced))))
;; now the thing itself
(when (or forced module-ops
- (operation-forced-p (operation-ancestor operation))
- (not (operation-done-p operation c)))
+ (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
(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))
+
+
(pushnew :asdf *features*)
#+sbcl
projects / sbcl.git / commitdiff