Skip to content
Snippets Groups Projects
Commit da20b5a9 authored by Robert P. Goldman's avatar Robert P. Goldman
Browse files

Documentation and commenting to asdf.lisp.

There is only one minor fix (substitution of string-equal for string= in a
component name comparison to avoid problems with mlisp).

The rest of this commit is all commenting and docstrings.  Trying to get
a handle on the bug about module dependencies.
parent 1250bbc5
No related branches found
No related tags found
No related merge requests found
...@@ -308,9 +308,28 @@ system.")) ...@@ -308,9 +308,28 @@ system."))
"Recursively chase the operation's parent pointer until we get to "Recursively chase the operation's parent pointer until we get to
the head of the tree")) the head of the tree"))
(defgeneric component-visited-p (operation component)) (defgeneric component-visited-p (operation component)
(:documentation "Returns the value stored by a call to
(defgeneric visit-component (operation component data)) VISIT-COMPONENT, if that has been called, otherwise NIL.
This value stored will be a cons cell, the first element
of which is a computed key, so not interesting. The
CDR wil be the DATA value stored by VISIT-COMPONENT; recover
it as \(cdr \(component-visited-p op c\)\).
There is no evidence that the DATA value is ever interesting.
It is only consumed as a boolean, and the only call to VISIT-COMPONENT
ensures that the DATA argument will always be a true value. Suspect
this was done in case someone mistakenly set DATA to NIL instead of
removing the record."))
(defgeneric visit-component (operation component data)
(:documentation "Record DATA as being associated with OPERATION
and COMPONENT. This is a side-effecting function: the association
will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the
OPERATION\).
No evidence that DATA is ever interesting, beyond just being
non-NIL. Using the data field is probably very risky; if there is
already a record for OPERATION X COMPONENT, DATA will be quietly
discarded instead of recorded."))
(defgeneric (setf visiting-component) (new-value operation component)) (defgeneric (setf visiting-component) (new-value operation component))
...@@ -977,7 +996,11 @@ to `~a` which is not a directory.~@:>" ...@@ -977,7 +996,11 @@ to `~a` which is not a directory.~@:>"
;;; one of these is instantiated whenever #'operate is called ;;; one of these is instantiated whenever #'operate is called
(defclass operation () (defclass operation ()
((forced :initform nil :initarg :force :accessor operation-forced) (
;; what is the TYPE of this slot? seems like it should be boolean,
;; but TRAVERSE checks to see if it's a list of component names...
;; [2010/02/07:rpg]
(forced :initform nil :initarg :force :accessor operation-forced)
(original-initargs :initform nil :initarg :original-initargs (original-initargs :initform nil :initarg :original-initargs
:accessor operation-original-initargs) :accessor operation-original-initargs)
(visited-nodes :initform nil :accessor operation-visited-nodes) (visited-nodes :initform nil :accessor operation-visited-nodes)
...@@ -1006,6 +1029,9 @@ to `~a` which is not a directory.~@:>" ...@@ -1006,6 +1029,9 @@ to `~a` which is not a directory.~@:>"
(defun make-sub-operation (c o dep-c dep-o) (defun make-sub-operation (c o dep-c dep-o)
"C is a component, O is an operation, DEP-C is another
component, and DEP-O, confusingly enough, is an operation
class NAME, not an operation."
(let* ((args (copy-list (operation-original-initargs o))) (let* ((args (copy-list (operation-original-initargs o)))
(force-p (getf args :force))) (force-p (getf args :force)))
;; note explicit comparison with T: any other non-NIL force value ;; note explicit comparison with T: any other non-NIL force value
...@@ -1108,8 +1134,10 @@ to `~a` which is not a directory.~@:>" ...@@ -1108,8 +1134,10 @@ to `~a` which is not a directory.~@:>"
;;; for our purposes. ;;; for our purposes.
(defmethod traverse ((operation operation) (c component)) (defmethod traverse ((operation operation) (c component))
(let ((forced nil)) (let ((forced nil)) ;return value -- everyone side-effects onto this
(labels ((%do-one-dep (required-op required-c required-v) (labels ((%do-one-dep (required-op required-c required-v)
;; returns a partial plan that results from performing required-op
;; on required-c, possibly with a required-vERSION
(let* ((dep-c (or (find-component (let* ((dep-c (or (find-component
(component-parent c) (component-parent c)
;; XXX tacky. really we should build the ;; XXX tacky. really we should build the
...@@ -1127,15 +1155,17 @@ to `~a` which is not a directory.~@:>" ...@@ -1127,15 +1155,17 @@ to `~a` which is not a directory.~@:>"
(op (make-sub-operation c operation dep-c required-op))) (op (make-sub-operation c operation dep-c required-op)))
(traverse op dep-c))) (traverse op dep-c)))
(do-one-dep (required-op required-c required-v) (do-one-dep (required-op required-c required-v)
;; this function is a thin, error-handling wrapper around
;; %do-one-dep. Returns a partial plan per that function.
(loop (loop
(restart-case (restart-case
(return (%do-one-dep required-op required-c required-v)) (return (%do-one-dep required-op required-c required-v))
(retry () (retry ()
:report (lambda (s) :report (lambda (s)
(format s "~@<Retry loading component ~S.~@:>" (format s "~@<Retry loading component ~S.~@:>"
required-c)) required-c))
:test :test
(lambda (c) (lambda (c)
#| #|
(print (list :c1 c (typep c 'missing-dependency))) (print (list :c1 c (typep c 'missing-dependency)))
(when (typep c 'missing-dependency) (when (typep c 'missing-dependency)
...@@ -1143,11 +1173,17 @@ to `~a` which is not a directory.~@:>" ...@@ -1143,11 +1173,17 @@ to `~a` which is not a directory.~@:>"
(equalp (missing-requires c) (equalp (missing-requires c)
required-c)))) required-c))))
|# |#
(or (null c) (or (null c)
(and (typep c 'missing-dependency) (and (typep c 'missing-dependency)
(equalp (missing-requires c) (equalp (missing-requires c)
required-c)))))))) required-c))))))))
(do-dep (op dep) (do-dep (op dep)
;; type of arguments uncertain: op seems to at least potentially be a
;; symbol, rather than an operation
;; dep is either a list of component names (?) or (we hope) a single
;; component name.
;; handle a single dependency, returns nothing of interest --- side-
;; effects onto the FORCED variable, which is scoped over TRAVERSE
(cond ((eq op 'feature) (cond ((eq op 'feature)
(or (member (car dep) *features*) (or (member (car dep) *features*)
(error 'missing-dependency (error 'missing-dependency
...@@ -1155,6 +1191,10 @@ to `~a` which is not a directory.~@:>" ...@@ -1155,6 +1191,10 @@ to `~a` which is not a directory.~@:>"
:requires (car dep)))) :requires (car dep))))
(t (t
(dolist (d dep) (dolist (d dep)
;; structured dependencies --- this parses keywords
;; the keywords could be broken out and cleanly (extensibly)
;; processed by EQL methods, but for the pervasive side-effecting
;; onto FORCED
(cond ((consp d) (cond ((consp d)
(cond ((string-equal (cond ((string-equal
(symbol-name (first d)) (symbol-name (first d))
...@@ -1162,6 +1202,9 @@ to `~a` which is not a directory.~@:>" ...@@ -1162,6 +1202,9 @@ to `~a` which is not a directory.~@:>"
(appendf (appendf
forced forced
(do-one-dep op (second d) (third d)))) (do-one-dep op (second d) (third d))))
;; this particular subform is not documented, indeed
;; clashes with the documentation, since it assumes a
;; third component
((and (string-equal ((and (string-equal
(symbol-name (first d)) (symbol-name (first d))
"FEATURE") "FEATURE")
...@@ -1171,7 +1214,7 @@ to `~a` which is not a directory.~@:>" ...@@ -1171,7 +1214,7 @@ to `~a` which is not a directory.~@:>"
forced forced
(do-one-dep op (second d) (third d)))) (do-one-dep op (second d) (third d))))
(t (t
(error "Bad dependency ~a. Dependencies must be (:version <version>), (:feature <feature>), or a name" d)))) (error "Bad dependency ~a. Dependencies must be (:version <version>), (:feature <feature> [version]), or a name" d))))
(t (t
(appendf forced (do-one-dep op d nil))))))))) (appendf forced (do-one-dep op d nil)))))))))
(aif (component-visited-p operation c) (aif (component-visited-p operation c)
...@@ -1182,50 +1225,63 @@ to `~a` which is not a directory.~@:>" ...@@ -1182,50 +1225,63 @@ to `~a` which is not a directory.~@:>"
(error 'circular-dependency :components (list c))) (error 'circular-dependency :components (list c)))
(setf (visiting-component operation c) t) (setf (visiting-component operation c) t)
(unwind-protect (unwind-protect
(progn (progn
(loop :for (required-op . deps) :in (loop :for (required-op . deps) :in
(component-depends-on operation c) (component-depends-on operation c)
:do (do-dep required-op deps)) :do (do-dep required-op deps))
;; constituent bits ;; constituent bits
(let ((module-ops (let ((module-ops
(when (typep c 'module) (when (typep c 'module)
(let ((at-least-one nil) (let ((at-least-one nil)
(forced nil) ;; if the operation isn't done on the module
(error nil)) ;; (some module dependency forces the operation),
(dolist (kid (module-components c)) ;; then the operation must be done on the kids.
(handler-case (forced nil)
(appendf forced (traverse operation kid)) (error nil))
(missing-dependency (condition) (dolist (kid (module-components c))
(if (eq (module-if-component-dep-fails c) (handler-case
:fail) (appendf forced (traverse operation kid))
(error condition)) (missing-dependency (condition)
(setf error condition)) (if (eq (module-if-component-dep-fails c)
(:no-error (c) :fail)
(declare (ignore c)) (error condition))
(setf at-least-one t)))) (setf error condition))
(when (and (eq (module-if-component-dep-fails c) (:no-error (c)
:try-next) (declare (ignore c))
(not at-least-one)) (setf at-least-one t))))
(error error)) (when (and (eq (module-if-component-dep-fails c)
forced)))) :try-next)
;; now the thing itself (not at-least-one))
(when (or forced module-ops (error error))
(not (operation-done-p operation c)) forced))))
(let ((f (operation-forced ;; now the thing itself
(operation-ancestor operation)))) ;; we perform this if it's forced, or some of the components
(and f (or (not (consp f)) ;; are done, or it's never been done before or ..
(member (component-name (when (or forced module-ops
(operation-ancestor operation)) (not (operation-done-p operation c))
(mapcar #'coerce-name f) (let ((f (operation-forced
:test #'string=))))) (operation-ancestor operation))))
(let ((do-first (cdr (assoc (class-name (class-of operation)) ;; does anyone fully understand the following condition?
(component-do-first c))))) ;; if so, please add a comment to explain it...
(loop :for (required-op . deps) :in do-first (and f (or (not (consp f))
:do (do-dep required-op deps))) (member (component-name
(setf forced (append (delete 'pruned-op forced :key #'car) (operation-ancestor operation))
(delete 'pruned-op module-ops :key #'car) (mapcar #'coerce-name f)
(list (cons operation c))))))) ;; this was string=, but for the benefit
;; of mlisp, we use string-equal for this
;; purpose.
:test #'string-equal)))))
(let ((do-first (cdr (assoc (class-name (class-of operation))
(component-do-first c)))))
(loop :for (required-op . deps) :in do-first
:do (do-dep required-op deps)))
(setf forced (append (delete 'pruned-op forced :key #'car)
(delete 'pruned-op module-ops :key #'car)
(list (cons operation c)))))))
(setf (visiting-component operation c) nil)) (setf (visiting-component operation c) nil))
;; this form is kinda misleading here --- we're caching some information about
;; the current subplan (forced) --- but we only ever treat this value as a
;; boolean
(visit-component operation c (and forced t)) (visit-component operation c (and forced t))
forced))) forced)))
......
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