Commit e7e46819 authored by Gary King's avatar Gary King

2009-01-10 gwking@metabang.com

	added make-defined-systems-table (unexported)
	(re)applied Luis Oliveria's patch to add a restart for missing
	components. This patch works in SBCL but not in Allegro Common
	Lisp or CLISP. The problem has to do with the computation of
	restarts and I'm still trying to figure it out. Since the
	failure doesn't cause any _new_ problems (it just means that
	the putative new restart isn't listed), I'm still committing.

	* asdf.lisp

	tests for the above

	(new) test/test-retry-loading-component-1.script
	(new) test/try-reloading-1.asd
	(new) test/try-reloading-dependency.hidden
parent 5e0b9c2f
;;; This is asdf: Another System Definition Facility. $Revision: 1.130 $
;;; This is asdf: Another System Definition Facility. $Revision: 1.131 $
;;;
;;; Feedback, bug reports, and patches are all welcome: please mail to
;;; <cclan-list@lists.sf.net>. But note first that the canonical
......@@ -118,7 +118,7 @@
(in-package #:asdf)
(defvar *asdf-revision* (let* ((v "$Revision: 1.130 $")
(defvar *asdf-revision* (let* ((v "$Revision: 1.131 $")
(colon (or (position #\: v) -1))
(dot (position #\. v)))
(and v colon dot
......@@ -350,7 +350,11 @@ and NIL NAME and TYPE components"
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; finding systems
(defvar *defined-systems* (make-hash-table :test 'equal))
(defun make-defined-systems-table ()
(make-hash-table :test 'equal))
(defvar *defined-systems* (make-defined-systems-table))
(defun coerce-name (name)
(typecase name
(component (component-name name))
......@@ -711,7 +715,7 @@ the head of the tree"))
(defgeneric traverse (operation component))
(defmethod traverse ((operation operation) (c component))
(let ((forced nil))
(labels ((do-one-dep (required-op required-c required-v)
(labels ((%do-one-dep (required-op required-c required-v)
(let* ((dep-c (or (find-component
(component-parent c)
;; XXX tacky. really we should build the
......@@ -728,6 +732,26 @@ the head of the tree"))
:requires required-c))))
(op (make-sub-operation c operation dep-c required-op)))
(traverse op dep-c)))
(do-one-dep (required-op required-c required-v)
(loop
(restart-case
(return (%do-one-dep required-op required-c required-v))
(retry ()
:report (lambda (s)
(format s "~@<Retry loading component ~S.~@:>"
required-c))
:test
(lambda (c)
#|
(print (list :c1 c (typep c 'missing-dependency)))
(when (typep c 'missing-dependency)
(print (list :c2 (missing-requires c) required-c
(equalp (missing-requires c)
required-c))))
|#
(and (typep c 'missing-dependency)
(equalp (missing-requires c)
required-c)))))))
(do-dep (op dep)
(cond ((eq op 'feature)
(or (member (car dep) *features*)
......@@ -737,11 +761,22 @@ the head of the tree"))
(t
(dolist (d dep)
(cond ((consp d)
(assert (string-equal
(symbol-name (first d))
"VERSION"))
(appendf forced
(do-one-dep op (second d) (third d))))
(cond ((string-equal
(symbol-name (first d))
"VERSION")
(appendf
forced
(do-one-dep op (second d) (third d))))
((and (string-equal
(symbol-name (first d))
"FEATURE")
(find (second d) *features*
:test 'string-equal))
(appendf
forced
(do-one-dep op (second d) (third d))))
(t
(error "Dependencies must be (:version <version>), (:feature <feature>), or a name"))))
(t
(appendf forced (do-one-dep op d nil)))))))))
(aif (component-visited-p operation c)
......@@ -755,7 +790,7 @@ the head of the tree"))
(progn
(loop for (required-op . deps) in
(component-depends-on operation c)
do (do-dep required-op deps))
do (do-dep required-op deps))
;; constituent bits
(let ((module-ops
(when (typep c 'module)
......
;;; -*- Lisp -*-
;;; test asdf:try-recompiling restart
(load "script-support")
(load "../asdf")
;(trace asdf::find-component)
(exit-on-error
(when (probe-file "try-reloading-dependency.asd")
(asdf:run-shell-command "rm -f ~A"
(namestring "try-reloading-dependency.asd")))
(defvar *caught-error* nil)
(setf asdf:*central-registry* '(*default-pathname-defaults*))
(setf asdf::*defined-systems* (asdf::make-defined-systems-table))
(handler-bind ((error (lambda (c)
(setf *caught-error* t)
(asdf:run-shell-command
"cp try-reloading-dependency.hidden try-reloading-dependency.asd")
(multiple-value-bind (name mode)
(find-symbol (symbol-name 'retry) :asdf)
(assert (eq mode :external))
(let ((restart (find-restart name c)))
(assert restart)
(when restart (invoke-restart restart)))))))
(asdf:oos 'asdf:load-op 'try-reloading-1))
(assert *caught-error*)
)
;;; -*- Lisp -*-
(asdf:defsystem try-reloading-1
:components ((:file "file1"))
:depends-on ("try-reloading-dependency"))
;;; -*- Lisp -*-
(asdf:defsystem try-reloading-dependency
:components ((:file "file3")))
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