Skip to content

Commit 96f26b8

Browse files
Use an ASDF system-search-function hook instead of catching ASDF errors.
1 parent 690b3a0 commit 96f26b8

File tree

2 files changed

+36
-37
lines changed

2 files changed

+36
-37
lines changed

quicklisp/client.lisp

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -34,7 +34,11 @@
3434
(setf systems (list systems)))
3535
(dolist (thing systems systems)
3636
(flet ((ql ()
37-
(autoload-system-and-dependencies thing :prompt prompt)))
37+
(let ((asdf:*system-definition-search-functions*
38+
(append asdf:*system-definition-search-functions*
39+
'(ql::system-definition-searcher/auto-download)))
40+
(*quickload-prompt* prompt))
41+
(asdf:load-system thing))))
3842
(if verbose
3943
(ql)
4044
(call-with-quiet-compilation #'ql)))))))

quicklisp/setup.lisp

Lines changed: 31 additions & 36 deletions
Original file line numberDiff line numberDiff line change
@@ -61,6 +61,37 @@
6161
system given to load is not available via ASDF or a Quicklisp
6262
dist."))
6363

64+
;; Internal variable to keep track of which systems we have tried to load already.
65+
(defvar *searching/seen-asdf-systems*)
66+
67+
(defun system-definition-searcher/auto-download (name)
68+
"An ASDF system definition search function. It's used internally to hook into ASDF:FIND-SYSTEM to automatically download systems."
69+
(flet
70+
((body ()
71+
(unless (gethash name *searching/seen-asdf-systems*)
72+
(setf (gethash name *searching/seen-asdf-systems*) t)
73+
(flet ((try-finding-it ()
74+
(let ((system-file (find-asdf-system-file name)))
75+
(when (and system-file
76+
(string= (pathname-name system-file) name))
77+
system-file))))
78+
(or (try-finding-it)
79+
(progn
80+
(let ((strategy (compute-load-strategy name)))
81+
(show-load-strategy strategy)
82+
;; TODO FIXME *quickload-prompt* is forward referenced
83+
(when (or (not quicklisp-client::*quickload-prompt*)
84+
(press-enter-to-continue))
85+
(apply-load-strategy strategy)))
86+
(try-finding-it)))))))
87+
(if (boundp '*searching/seen-asdf-systems*)
88+
;; we are getting nested
89+
(body)
90+
;; only do these once
91+
(with-simple-restart (abort "Give up on loading ~S" name)
92+
(let ((*searching/seen-asdf-systems* (make-hash-table :test 'equalp)))
93+
(body))))))
94+
6495
(defun compute-load-strategy (name)
6596
(setf name (string-downcase name))
6697
(let ((asdf-systems '())
@@ -160,42 +191,6 @@
160191
(format t "~&; Loading ~S~%" (name strategy))
161192
(asdf:oos 'asdf:load-op (name strategy) :verbose nil))))
162193

163-
(defun autoload-system-and-dependencies (name &key prompt)
164-
"Try to load the system named by NAME, automatically loading any
165-
Quicklisp-provided systems first, and catching ASDF missing
166-
dependencies too if possible."
167-
(setf name (string-downcase name))
168-
(with-simple-restart (abort "Give up on ~S" name)
169-
(let ((strategy (compute-load-strategy name))
170-
(tried-so-far (make-hash-table :test 'equalp)))
171-
(show-load-strategy strategy)
172-
(when (or (not prompt)
173-
(press-enter-to-continue))
174-
(tagbody
175-
retry
176-
(handler-case (apply-load-strategy strategy)
177-
(asdf:missing-dependency-of-version (c)
178-
;; Nothing Quicklisp can do to recover from this, so just
179-
;; resignal
180-
(error c))
181-
(asdf:missing-dependency (c)
182-
(let ((parent (asdf::missing-required-by c))
183-
(missing (asdf::missing-requires c)))
184-
(typecase parent
185-
(asdf:system
186-
(if (gethash missing tried-so-far)
187-
(error "Dependency looping -- already tried to load ~
188-
~A" missing)
189-
(setf (gethash missing tried-so-far) missing))
190-
(autoload-system-and-dependencies missing
191-
:prompt prompt)
192-
(go retry))
193-
(t
194-
;; Error isn't from a system dependency, so there's
195-
;; nothing to autoload
196-
(error c)))))))))
197-
name))
198-
199194
(defvar *initial-dist-url*
200195
"http://beta.quicklisp.org/dist/quicklisp.txt")
201196

0 commit comments

Comments
 (0)