Skip to content
Snippets Groups Projects
Commit d8bd7cfb authored by Daniel Barlow's avatar Daniel Barlow
Browse files

shouldn't do global proclamations, that's bad karma (reported by Gary Byers)

modules maybe now can have no components (Matthew Danish, SF bug id 625738)
(added an :initform nil, haven't actually tested)

significant reworking to handle recompilation of dependencies properly
 - use of component properties for last-compiled/last-loaded is gone
 - new internal gf INPUT-FILES (COMPONENT OPERATION)
 - TRAVERSE doesn't actually perform anything, but it now has a defined
   return value: a list of the ops and components that need doing.
   OPERATE loops over answers from TRAVERSE
 - intended to have no user-visible effects, but ICBW!
   May break existing systems!
 - still doesn't do cross-module dependencies properly, sigh.  but we're
   closer
 - default output-files method now returns NIL instead of causing an error
parent 26bb1220
No related branches found
No related tags found
No related merge requests found
$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". ''
;;; 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)
......
......@@ -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)))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment