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

README

+18 −11
Original line number Diff line number Diff line 
$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". ''

asdf.lisp

+152 −134
Original line number Diff line number Diff line 
;;; 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,6 +166,8 @@ 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
@@ -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,17 +439,17 @@ 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)

  (assoc (node-for o c)

	 (operation-visited-nodes (operation-ancestor o))

	 :test 'equal))
@@ -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,6 +532,7 @@ system.")) 
(defgeneric traverse (operation component symbol))

(defmethod traverse ((operation operation) (c component) (function

							  symbol))

  (let ((forced nil))

    (labels ((do-one-dep (required-op required-c required-v)

	       (let ((op (if (subtypep (type-of operation) required-op)

			     operation
@@ -523,16 +552,19 @@ system.")) 
		      (or (member (car dep) *features*)

			  (error 'missing-dependency :required-by c

				 :requires (car dep) :version nil)))

		   (t (dolist (d dep)

		     (t

		      (dolist (d dep)

                        (cond ((consp d)

                               (assert (string-equal

                                        (symbol-name (first d))

                                        "VERSION"))

			       (do-one-dep op (second d) (third d)))

                               (appendf forced

					(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

                               (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)))
@@ -545,7 +577,7 @@ system.")) 
	      (error nil))

	  (loop for kid in (module-components c)

		do (handler-case

		     (traverse operation kid function)		   

		       (appendf forced (traverse operation kid function))

		     (missing-dependency (condition)

		       (if (eq (module-if-component-dep-fails c) :fail)

			   (error condition))
@@ -557,16 +589,15 @@ system.")) 
		     (not at-least-one))

	    (error error))))

      ;; now the thing itself

    (if (or (operation-forced-p operation)

      (if (or forced

	      (operation-forced-p (operation-ancestor operation))

	      (not (operation-done-p operation c)))

	(loop

	 (restart-case 

	     (progn (funcall function operation c)

		    (return))

	   (retry-component ())

	   (skip-component () (return)))))

	  (appendf forced (list (node-for operation c))))

      

      (setf (visiting-component operation c) nil)

    (visit-component operation c)))

      (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,13 +669,6 @@ 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)))
@@ -654,26 +676,16 @@ system.")) 


(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

  (let* ((op (apply #'make-instance operation-class

		    :original-initargs args args))

	(system (if (typep system 'component) system (find-system system))))

	 (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)

test/test1.script

+11 −0
Original line number Diff line number Diff line
@@ -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)))