diff --git a/README b/README index 18e050e6ad38b32612b75c57eabff490c4e74e6d..c1438db7559636a50107bbad3b642bd3c885f3a6 100644 --- a/README +++ b/README @@ -1,4 +1,4 @@ -$Id: README,v 1.25 2002/08/28 20:22:33 dan_b Exp $ -*- Text -*- +$Id: README,v 1.26 2002/11/08 01:54:23 dan_b Exp $ -*- Text -*- asdf: another system definition facility @@ -648,24 +648,30 @@ functionality? ** proclamations probably aren't ** when a system is reloaded with fewer components than it previously had, odd things happen -** circularities may not be being detected as they should -** now +we should do something inventive when processing a defsystem form, +like take the list of kids and setf the slot to nil, then transfer +children from old to new list as they're found -*** restarts may not be as visible as we'd like when chasing dependencies +** traverse may become a normal function and not generic -*** some reasonably neat way to deal with this-file-already-loaded +If you're defining methods on traverse (especially if they specialise +on the third arg, which we don't actually use any more) speak up. -perhaps compile-op/load-op perform after methods should be setting the -last-loaded and last-compiled properties? +** return list from traverse is not in final form yet -*** better integration of load-binary-ignoring-state-of-source-op +We'll probably make it have actual operations in it, not just the names. -** later +** a lot of load-op methods can be rewritten to use input-files + +so should be. + + +** (stuff that might happen later) *** david lichteblau's patch for symlink resolution? -*** Propagation of the :force option. I notice that +*** Propagation of the :force option. ``I notice that (oos 'compile-op :araneida :force t) @@ -674,5 +680,6 @@ depends on. This is rarely useful to me; usually, when I want to force recompilation of something more than a single source file, I want to 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". +propagate only something like ":force :recursively". '' + diff --git a/asdf.lisp b/asdf.lisp index 2075e39619ef372d197233523481e68b5e429387..ee23ce4d390a80837ca283013bb90cc7ff4689ac 100644 --- a/asdf.lisp +++ b/asdf.lisp @@ -1,4 +1,4 @@ -;;; This is asdf: Another System Definition Facility. $Revision: 1.49 $ +;;; This is asdf: Another System Definition Facility. $Revision: 1.50 $ ;;; ;;; Feedback, bug reports, and patches are all welcome: please mail to ;;; <cclan-list@lists.sf.net>. But note first that the canonical @@ -88,7 +88,7 @@ (in-package #:asdf) ;;; parse the cvs revision into something that might be vaguely useful. -(defvar *asdf-revision* (let* ((v "$Revision: 1.49 $") +(defvar *asdf-revision* (let* ((v "$Revision: 1.50 $") (colon (position #\: v)) (dot (position #\. v))) (and v colon dot @@ -97,9 +97,6 @@ (parse-integer v :start (1+ dot) :junk-allowed t))))) -(proclaim '(optimize (debug 3))) -(declaim (optimize (debug 3))) - (defvar *compile-file-warnings-behaviour* :warn) (defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn) @@ -114,6 +111,9 @@ and NIL NAME and TYPE components" (make-pathname :name nil :type nil :defaults pathname)) +(define-modify-macro appendf (&rest args) + append "Append onto list") + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; classes, condiitons @@ -166,11 +166,13 @@ and NIL NAME and TYPE components" ;; no direct accessor for pathname, we do this as a method to allow ;; it to default in funky ways if not supplied (relative-pathname :initarg :pathname) + (operation-times :initform (make-hash-table ) + :accessor component-operation-times) ;; XXX we should provide some atomic interface for updating the ;; component properties (properties :accessor component-properties :initarg :properties :initform nil))) - + ;;;; methods: conditions (defmethod print-object ((c missing-dependency) s) @@ -203,7 +205,7 @@ and NIL NAME and TYPE components" (prin1 (component-name c) stream)))) (defclass module (component) - ((components :accessor module-components :initarg :components) + ((components :initform nil :accessor module-components :initarg :components) ;; what to do if we can't satisfy a dependency of one of this module's ;; components. This allows a limited form of conditional processing (if-component-dep-fails :initform :fail @@ -384,6 +386,7 @@ system.")) (defmethod source-file-type ((c cl-source-file) (s module)) "lisp") (defmethod source-file-type ((c c-source-file) (s module)) "c") (defmethod source-file-type ((c java-source-file) (s module)) "java") +(defmethod source-file-type ((c html-file) (s module)) "html") (defmethod source-file-type ((c static-file) (s module)) nil) (defmethod component-relative-pathname ((component source-file)) @@ -419,6 +422,7 @@ system.")) (defgeneric operation-done-p (operation component)) (defgeneric explain (operation component)) (defgeneric output-files (operation component)) +(defgeneric input-files (operation component)) (defun node-for (o c) (cons (class-name (class-of o)) c)) @@ -435,19 +439,19 @@ system.")) (let ((args (operation-original-initargs o))) (apply #'make-instance type :parent o :original-initargs args args))) -(defgeneric visit-component (operation component)) +(defgeneric visit-component (operation component data)) -(defmethod visit-component ((o operation) (c component)) - (pushnew (node-for o c) - (operation-visited-nodes (operation-ancestor o)) - :test 'equal)) +(defmethod visit-component ((o operation) (c component) data) + (unless (component-visited-p o c) + (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)) - (member (node-for o c) - (operation-visited-nodes (operation-ancestor o)) - :test 'equal)) + (assoc (node-for o c) + (operation-visited-nodes (operation-ancestor o)) + :test 'equal)) (defgeneric (setf visiting-component) (new-value operation component)) @@ -470,28 +474,52 @@ system.")) (member node (operation-visiting-nodes (operation-ancestor o)) :test 'equal))) -;;; this needs a new name. should be operation-needs-doing-p -(defmethod operation-done-p ((o operation) (c source-file)) - (let ((binaries (output-files o c)) - (source-write-date - (and (probe-file (component-pathname c)) - (file-write-date (component-pathname c))))) - (and source-write-date binaries - (every (lambda (b) - (and (probe-file b) - (> (file-write-date b) source-write-date))) - binaries)))) - -(defmethod operation-done-p ((o operation) (c component)) - ;;; can't tell easily - nil) - (defgeneric component-depends-on (operation component)) (defmethod component-depends-on ((o operation) (c component)) (cdr (assoc (class-name (class-of o)) (slot-value c 'in-order-to)))) +(defmethod component-self-dependencies ((o operation) (c component)) + (let ((all-deps (component-depends-on o c))) + (remove-if-not (lambda (x) + (member (component-name c) (cdr x) :test #'string=)) + all-deps))) + +(defmethod input-files ((operation operation) (c component)) + (let ((parent (component-parent c)) + (self-deps (component-self-dependencies operation c))) + (if self-deps + (mapcan (lambda (dep) + (destructuring-bind (op name) dep + (output-files (make-instance op) + (find-component parent name)))) + self-deps) + ;; no previous operations needed? I guess we work with the + ;; original source file, then + (list (component-pathname c))))) + +(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)) )))))) ;;; So you look at this code and think "why isn't it a bunch of ;;; methods". And the answer is, because standard method combination @@ -504,69 +532,72 @@ system.")) (defgeneric traverse (operation component symbol)) (defmethod traverse ((operation operation) (c component) (function symbol)) - (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)))) - (traverse op dep-c function))) - (do-dep (op dep) - (cond ((eq op 'feature) - (or (member (car dep) *features*) - (error 'missing-dependency :required-by c - :requires (car dep) :version nil))) - (t (dolist (d dep) - (cond ((consp d) - (assert (string-equal - (symbol-name (first d)) - "VERSION")) - (do-one-dep op (second d) (third d))) - (t - (do-one-dep op d nil)))))))) - (when (component-visited-p operation c) - (return-from traverse nil)) ;; been here before - ;; dependencies - (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 - (when (typep c 'module) - (let ((at-least-one nil) - (error nil)) - (loop for kid in (module-components c) - do (handler-case - (traverse operation kid function) - (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)))) - ;; now the thing itself - (if (or (operation-forced-p operation) - (not (operation-done-p operation c))) - (loop - (restart-case - (progn (funcall function operation c) - (return)) - (retry-component ()) - (skip-component () (return))))) - (setf (visiting-component operation c) nil) - (visit-component operation c))) + (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)))) + (traverse op dep-c function))) + (do-dep (op dep) + (cond ((eq op 'feature) + (or (member (car dep) *features*) + (error 'missing-dependency :required-by c + :requires (car dep) :version nil))) + (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)))) + (t + (appendf forced (do-one-dep op d nil))))))))) + (aif (component-visited-p operation c) + (return-from traverse ; been here before + (if (cdr it) (list (cons 'pruned-op c)) nil))) + ;; dependencies + (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 + (when (typep c 'module) + (let ((at-least-one nil) + (error nil)) + (loop for kid in (module-components c) + do (handler-case + (appendf forced (traverse operation kid function)) + (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)))) + ;; now the thing itself + (if (or forced + (operation-forced-p (operation-ancestor operation)) + (not (operation-done-p operation c))) + (appendf forced (list (node-for operation c)))) + + (setf (visiting-component operation c) nil) + (visit-component operation c (and forced t)) + forced))) + (defmethod perform ((operation operation) (c source-file)) (sysdef-error @@ -595,13 +626,11 @@ system.")) :initform *compile-file-failure-behaviour*))) (defmethod perform :before ((operation compile-op) (c source-file)) - (setf (component-property c 'last-compiled) nil) (map nil #'ensure-directories-exist (output-files operation c))) -(defmethod perform :after ((operation compile-op) (c source-file)) - (when (output-files operation c) - (setf (component-property c 'last-compiled) - (file-write-date (car (output-files operation c)))))) +(defmethod perform :after ((operation operation) (c component)) + (setf (gethash (type-of operation) (component-operation-times c)) + (get-universal-time))) ;;; perform is required to check output-files to find out where to put ;;; its answers, in case it has been overridden for site policy @@ -640,40 +669,23 @@ system.")) (defclass load-op (operation) ()) -(defmethod perform :after ((o load-op) (c source-file)) - (let* ((co (make-sub-operation o 'compile-op)) - (output-files (output-files co c))) - (when output-files - (setf (component-property c 'last-loaded) - (file-write-date (car output-files)))))) - (defmethod perform ((o load-op) (c cl-source-file)) (let* ((co (make-sub-operation o 'compile-op)) - (output-files (output-files co c))) + (output-files (output-files co c))) (mapcar #'load output-files))) (defmethod perform ((operation load-op) (c static-file)) nil) +(defmethod operation-done-p ((operation load-op) (c static-file)) + t) -(defmethod output-files ((operation load-op) (c component)) +(defmethod output-files ((o operation) (c component)) nil) (defmethod component-depends-on ((operation load-op) (c component)) (cons (list 'compile-op (component-name c)) (call-next-method))) -;;; This is arguably an abuse of component properties; transient stuff -;;; like last-compiled-time is is not really what they're intended -;;; for. But I don't really have a better idea, and it's definitely -;;; useful functionality - -(defmethod operation-done-p ((o load-op) (c source-file)) - (if (or (not (component-property c 'last-loaded)) - (not (component-property c 'last-compiled)) - (> (component-property c 'last-compiled) - (component-property c 'last-loaded))) - nil t)) - ;;; load-source-op (defclass load-source-op (operation) ()) @@ -681,24 +693,29 @@ system.")) (defmethod perform ((o load-source-op) (c cl-source-file)) (load (component-pathname c))) -;;; morally dubious, this -(defmethod perform :after ((o load-source-op) (c source-file)) - (setf (component-property c 'last-loaded) - (file-write-date (component-pathname c)))) - -;;; TODO: operation-done-p for load-source-op, what _should_ the answer be? - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; invoking operations (defun operate (operation-class system &rest args) - (let ((op (apply #'make-instance operation-class - :original-initargs args args)) - (system (if (typep system 'component) system (find-system system)))) + (let* ((op (apply #'make-instance operation-class + :original-initargs args args)) + (system (if (typep system 'component) system (find-system system))) + (steps (traverse op system 'perform))) + ;; XXX this make-instance stuff is a little silly. really we should + ;; have traverse return operations directly instead of their types (with-compilation-unit () - (traverse op system 'perform)))) + (loop for (op-name . component) in steps + unless (eql op-name 'pruned-op) + do + (loop + (restart-case + (progn (perform + (apply #'make-instance op-name + :original-initargs args args) component) + (return)) + (retry-component ()) + (skip-component () (return)))))))) (defun oos (&rest args) "Alias of OPERATE function" @@ -814,7 +831,8 @@ Returns the new tree (which probably shares structure with the old one)" :parent parent :in-order-to (union-of-dependencies in-order-to - `((compile-op (load-op ,@depends-on)))) + `((compile-op (load-op ,@depends-on)) + (load-op (load-op ,@depends-on)))) other-args) (when (typep ret 'module) (setf (module-default-component-class ret) diff --git a/test/test1.script b/test/test1.script index 1778f3b26cf8a94b3b9f9dd5dafa7995ed49a0f2..c591e32c89317259b82ce7735a610c308fa36fa5 100644 --- a/test/test1.script +++ b/test/test1.script @@ -19,3 +19,14 @@ (asdf:oos 'asdf:load-op 'test1) (assert (= file1-date (file-write-date (compile-file-pathname "file1")))) (assert (file-write-date (compile-file-pathname "file2"))) + +;; now touch file1 and check that file2 _is_ also recompiled + +;; XXX run-shell-command loses if *default-pathname-defaults* is not the +;; unix cwd. this is not a problem for run-tests.sh, but can be in general + +(let ((before (file-write-date (compile-file-pathname "file2")))) + (asdf::run-shell-command "touch file1.lisp") + (sleep 1) + (asdf:operate 'asdf:load-op 'test1) + (assert (> (file-write-date (compile-file-pathname "file2")) before)))