diff --git a/README b/README index 2dfce40c3d0d6499349372aa2b9022f28e42cc1a..60f9b714b490060b38c0fef08eb3ea4603c9b062 100644 --- a/README +++ b/README @@ -1,4 +1,4 @@ -$Id: README,v 1.29 2003/02/08 15:31:15 dan_b Exp $ -*- Text -*- +$Id: README,v 1.30 2003/03/16 15:18:25 dan_b Exp $ -*- Text -*- asdf: another system definition facility @@ -706,4 +706,12 @@ recompile only one system. So it would be more useful to have make-sub-operation refuse to propagate ":force t" to other systems, and propagate only something like ":force :recursively". '' +Ideally what we actually want is some kind of criterion that says +to which systems (and which operations) a :force switch will propagate. + +(defgeneric operation-propagates-force-p (operation component)) + +make-sub-operation would call this + + diff --git a/asdf.lisp b/asdf.lisp index ba12d018ae3e59f29e00c480a4fb42a82b540401..f497345c911614fc89111e2b5bef9c337fee8fb4 100644 --- a/asdf.lisp +++ b/asdf.lisp @@ -1,4 +1,4 @@ -;;; This is asdf: Another System Definition Facility. $Revision: 1.62 $ +;;; This is asdf: Another System Definition Facility. $Revision: 1.63 $ ;;; ;;; Feedback, bug reports, and patches are all welcome: please mail to ;;; <cclan-list@lists.sf.net>. But note first that the canonical @@ -87,7 +87,7 @@ (in-package #:asdf) -(defvar *asdf-revision* (let* ((v "$Revision: 1.62 $") +(defvar *asdf-revision* (let* ((v "$Revision: 1.63 $") (colon (position #\: v)) (dot (position #\. v))) (and v colon dot @@ -308,10 +308,21 @@ and NIL NAME and TYPE components" (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 @@ -325,17 +336,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 +405,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 +423,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 +459,29 @@ 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)) + ;; 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)) @@ -550,18 +579,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 +636,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