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
$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
;;; 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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment