X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fasdf%2Fasdf.lisp;h=4f7aff78f645102ff30559f8504e296e2ab72961;hb=1de341cf0652fb0eb8354f64d95acb0899811173;hp=7754100134950b02f776c34610369821e747261c;hpb=ac532354bd43951be10fac62911c1bc8e3160131;p=sbcl.git diff --git a/contrib/asdf/asdf.lisp b/contrib/asdf/asdf.lisp index 7754100..4f7aff7 100644 --- a/contrib/asdf/asdf.lisp +++ b/contrib/asdf/asdf.lisp @@ -1,4 +1,4 @@ -;;; This is asdf: Another System Definition Facility. $\Revision: 1.59 $ +;;; This is asdf: Another System Definition Facility. 1.68 ;;; ;;; Feedback, bug reports, and patches are all welcome: please mail to ;;; . But note first that the canonical @@ -40,8 +40,10 @@ (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 + #:test-op #:operation ; operations #:feature ; sort-of operation #:version ; metaphorically sort-of an operation @@ -87,8 +89,8 @@ (in-package #:asdf) -(defvar *asdf-revision* (let* ((v "$\Revision: 1.59 $") - (colon (position #\: v)) +(defvar *asdf-revision* (let* ((v "1.68") + (colon (or (position #\: v) -1)) (dot (position #\. v))) (and v colon dot (list (parse-integer v :start (1+ colon) @@ -308,10 +310,21 @@ and NIL NAME and TYPE components" (t (sysdef-error (formatter "~@") 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 @@ -325,17 +338,6 @@ and NIL NAME and TYPE components" (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*)) @@ -405,13 +407,17 @@ system.")) (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 @@ -419,13 +425,18 @@ system.")) ;;; 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) @@ -450,9 +461,26 @@ system.")) (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)) + (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)) @@ -550,18 +578,16 @@ system.")) (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) @@ -609,8 +635,13 @@ system.")) 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 @@ -709,8 +740,37 @@ system.")) (defclass load-source-op (operation) ()) (defmethod perform ((o load-source-op) (c cl-source-file)) - (load (component-pathname c))) + (let ((source (component-pathname c))) + (setf (component-property c 'last-loaded-as-source) + (and (load source) + (get-universal-time))))) +(defmethod perform ((operation load-source-op) (c static-file)) + nil) + +(defmethod output-files ((operation load-source-op) (c component)) + nil) + +;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right. +(defmethod component-depends-on ((o load-source-op) (c component)) + (let ((what-would-load-op-do (cdr (assoc 'load-op + (slot-value c 'in-order-to))))) + (mapcar (lambda (dep) + (if (eq (car dep) 'load-op) + (cons 'load-source-op (cdr dep)) + dep)) + what-would-load-op-do))) + +(defmethod operation-done-p ((o load-source-op) (c source-file)) + (if (or (not (component-property c 'last-loaded-as-source)) + (> (file-write-date (component-pathname c)) + (component-property c 'last-loaded-as-source))) + nil t)) + +(defclass test-op (operation) ()) + +(defmethod perform ((operation test-op) (c component)) + nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; invoking operations @@ -938,6 +998,15 @@ output to *trace-output*. Returns the shell's exit code." (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 @@ -954,18 +1023,18 @@ output to *trace-output*. Returns the shell's exit code." (provide name)))) (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*))