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

More frobbing of TRAVERSE

 - now it takes two arguments not three
 - and returns (operation . component) pairs
 - which don't include pruned-ops

Sorted out some load-op methods to use input-files instead of faking their
own compile-ops just to find out what the input files are
parent ac9f529f
No related branches found
No related tags found
No related merge requests found
$Id: README,v 1.26 2002/11/08 01:54:23 dan_b Exp $ -*- Text -*- $Id: README,v 1.27 2002/11/12 12:53:26 dan_b Exp $ -*- Text -*-
asdf: another system definition facility asdf: another system definition facility
...@@ -653,14 +653,10 @@ we should do something inventive when processing a defsystem form, ...@@ -653,14 +653,10 @@ we should do something inventive when processing a defsystem form,
like take the list of kids and setf the slot to nil, then transfer like take the list of kids and setf the slot to nil, then transfer
children from old to new list as they're found children from old to new list as they're found
** traverse may become a normal function and not generic ** traverse may become a normal function
If you're defining methods on traverse (especially if they specialise If you're defining methods on traverse, speak up.
on the third arg, which we don't actually use any more) speak up.
** return list from traverse is not in final form yet
We'll probably make it have actual operations in it, not just the names.
** a lot of load-op methods can be rewritten to use input-files ** a lot of load-op methods can be rewritten to use input-files
......
;;; This is asdf: Another System Definition Facility. $Revision: 1.50 $ ;;; This is asdf: Another System Definition Facility. $Revision: 1.51 $
;;; ;;;
;;; Feedback, bug reports, and patches are all welcome: please mail to ;;; Feedback, bug reports, and patches are all welcome: please mail to
;;; <cclan-list@lists.sf.net>. But note first that the canonical ;;; <cclan-list@lists.sf.net>. But note first that the canonical
...@@ -88,7 +88,7 @@ ...@@ -88,7 +88,7 @@
(in-package #:asdf) (in-package #:asdf)
;;; parse the cvs revision into something that might be vaguely useful. ;;; parse the cvs revision into something that might be vaguely useful.
(defvar *asdf-revision* (let* ((v "$Revision: 1.50 $") (defvar *asdf-revision* (let* ((v "$Revision: 1.51 $")
(colon (position #\: v)) (colon (position #\: v))
(dot (position #\. v))) (dot (position #\. v)))
(and v colon dot (and v colon dot
...@@ -527,11 +527,8 @@ system.")) ...@@ -527,11 +527,8 @@ system."))
;;; for our purposes. And CLISP doesn't have non-standard method ;;; for our purposes. And CLISP doesn't have non-standard method
;;; combinations, so let's keep it simple and aspire to portability ;;; combinations, so let's keep it simple and aspire to portability
;;; we enforce that function is a symbol to allow us to specialize on (defgeneric traverse (operation component))
;;; (eql 'perform) and (eql 'explain) for :before and :after (defmethod traverse ((operation operation) (c component))
(defgeneric traverse (operation component symbol))
(defmethod traverse ((operation operation) (c component) (function
symbol))
(let ((forced nil)) (let ((forced nil))
(labels ((do-one-dep (required-op required-c required-v) (labels ((do-one-dep (required-op required-c required-v)
(let ((op (if (subtypep (type-of operation) required-op) (let ((op (if (subtypep (type-of operation) required-op)
...@@ -546,7 +543,7 @@ system.")) ...@@ -546,7 +543,7 @@ system."))
(error 'missing-dependency :required-by c (error 'missing-dependency :required-by c
:version required-v :version required-v
:requires required-c)))) :requires required-c))))
(traverse op dep-c function))) (traverse op dep-c)))
(do-dep (op dep) (do-dep (op dep)
(cond ((eq op 'feature) (cond ((eq op 'feature)
(or (member (car dep) *features*) (or (member (car dep) *features*)
...@@ -563,7 +560,7 @@ system.")) ...@@ -563,7 +560,7 @@ system."))
(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)
(return-from traverse ; been here before (return-from traverse
(if (cdr it) (list (cons 'pruned-op c)) nil))) (if (cdr it) (list (cons 'pruned-op c)) nil)))
;; dependencies ;; dependencies
(if (component-visiting-p operation c) (if (component-visiting-p operation c)
...@@ -577,7 +574,7 @@ system.")) ...@@ -577,7 +574,7 @@ system."))
(error nil)) (error nil))
(loop for kid in (module-components c) (loop for kid in (module-components c)
do (handler-case do (handler-case
(appendf forced (traverse operation kid function)) (appendf forced (traverse operation kid ))
(missing-dependency (condition) (missing-dependency (condition)
(if (eq (module-if-component-dep-fails c) :fail) (if (eq (module-if-component-dep-fails c) :fail)
(error condition)) (error condition))
...@@ -589,11 +586,11 @@ system.")) ...@@ -589,11 +586,11 @@ system."))
(not at-least-one)) (not at-least-one))
(error error)))) (error error))))
;; now the thing itself ;; now the thing itself
(if (or forced (when (or forced
(operation-forced-p (operation-ancestor operation)) (operation-forced-p (operation-ancestor operation))
(not (operation-done-p operation c))) (not (operation-done-p operation c)))
(appendf forced (list (node-for operation c)))) (setf forced (append (delete 'pruned-op forced :key #'car)
(list (cons operation c)))))
(setf (visiting-component operation c) nil) (setf (visiting-component operation c) nil)
(visit-component operation c (and forced t)) (visit-component operation c (and forced t))
forced))) forced)))
...@@ -670,9 +667,7 @@ system.")) ...@@ -670,9 +667,7 @@ system."))
(defclass load-op (operation) ()) (defclass load-op (operation) ())
(defmethod perform ((o load-op) (c cl-source-file)) (defmethod perform ((o load-op) (c cl-source-file))
(let* ((co (make-sub-operation o 'compile-op)) (mapcar #'load (input-files o c)))
(output-files (output-files co c)))
(mapcar #'load output-files)))
(defmethod perform ((operation load-op) (c static-file)) (defmethod perform ((operation load-op) (c static-file))
nil) nil)
...@@ -701,18 +696,12 @@ system.")) ...@@ -701,18 +696,12 @@ system."))
(let* ((op (apply #'make-instance operation-class (let* ((op (apply #'make-instance operation-class
:original-initargs args args)) :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))) (steps (traverse op system)))
;; XXX this make-instance stuff is a little silly. really we should
;; have traverse return operations directly instead of their types
(with-compilation-unit () (with-compilation-unit ()
(loop for (op-name . component) in steps (loop for (op . component) in steps do
unless (eql op-name 'pruned-op)
do
(loop (loop
(restart-case (restart-case
(progn (perform (progn (perform op component)
(apply #'make-instance op-name
:original-initargs args args) component)
(return)) (return))
(retry-component ()) (retry-component ())
(skip-component () (return)))))))) (skip-component () (return))))))))
......
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