Commit e0d02781 authored by Daniel Barlow's avatar Daniel Barlow
Browse files

Fix component-relative-pathname so that it merges the correct type in

if unsupplied

Shuffle some definitions around to reduce 'not defined yet' complaints

Changes to :force option on operations -

 ':force t' is no longer passed onto dependent systems
 ':force (system1 system2 ...systemn)' is a list of system names to be forced
 ':force :all' is the original force-everything-recursively behaviour
parent b4baf218
Loading
Loading
Loading
Loading
+9 −1
Original line number Diff line number Diff line
$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


+70 −38
Original line number Diff line number Diff line
;;; 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