Use an ASDF system-search-function hook instead of catching ASDF errors.

Author: attila-lendvai

quicklisp/client.lisp

@@ -34,7 +34,9 @@
         (setf systems (list systems)))
       (dolist (thing systems systems)
         (flet ((ql ()
-                 (autoload-system-and-dependencies thing :prompt prompt)))
+                 (let ((ql::*attempt-installing* t)
+                       (*quickload-prompt* prompt))
+                   (asdf:load-system thing))))
           (if verbose
               (ql)
               (call-with-quiet-compilation #'ql)))))))

quicklisp/dist.lisp

@@ -1022,15 +1022,6 @@ the given NAME."
     (when system
       (installed-asdf-system-file system))))
 
-(defun system-definition-searcher (name)
-  "Like FIND-ASDF-SYSTEM-FILE, but this function can be used in
-ASDF:*SYSTEM-DEFINITION-SEARCH-FUNCTIONS*; it will only return system
-file names if they match NAME."
-  (let ((system-file (find-asdf-system-file name)))
-    (when (and system-file
-               (string= (pathname-name system-file) name))
-      system-file)))
-
 (defun call-with-consistent-dists (fun)
   "Take a snapshot of the available dists and return the same list
 consistently each time ALL-DISTS is called in the dynamic scope of

quicklisp/package.lisp

@@ -240,7 +240,6 @@
   (:export #:standard-dist-enumeration-function
            #:*dist-enumeration-functions*
            #:find-asdf-system-file
-           #:system-definition-searcher
            #:system-apropos
            #:system-apropos-list
            #:dependency-tree

quicklisp/setup.lisp

@@ -61,6 +61,55 @@
   system given to load is not available via ASDF or a Quicklisp
   dist."))
 
+(defparameter *attempt-installing* nil)
+
+(defun system-definition-searcher (name)
+  "Like FIND-ASDF-SYSTEM-FILE, but this function can be used in
+ASDF:*SYSTEM-DEFINITION-SEARCH-FUNCTIONS*; it will only return system
+file names if they match NAME."
+  (declare (special *tried-so-far*))
+  (flet
+      ((body ()
+         (if (gethash name *tried-so-far*)
+             (error "Dependency looping -- already tried to load ~A" name)
+             (progn
+               (setf (gethash name *tried-so-far*) t)
+               (flet ((try-finding-it ()
+                        (let ((system-file (find-asdf-system-file name)))
+                          (when (and system-file
+                                     (string= (pathname-name system-file) name))
+                            system-file))))
+                 (or (try-finding-it)
+                     (when *attempt-installing*
+                       (let ((ql-system (find-system name)))
+                         (when (and ql-system
+                                    ;; TODO FIXME *quickload-prompt* is forward referenced
+                                    (or (not quicklisp-client::*quickload-prompt*)
+                                        (progn
+                                          (format t "About to install ~A.~%" ql-system)
+                                          (press-enter-to-continue))))
+                           (ensure-installed ql-system))
+                         (try-finding-it))
+                       ;; TODO this branch doesn't work because compute-load-strategy
+                       ;; calls find-system again and triggers the error above.
+                       #+nil
+                       (progn
+                         (let ((strategy (compute-load-strategy name)))
+                           (show-load-strategy strategy)
+                           ;; TODO FIXME *quickload-prompt* is forward referenced
+                           (when (or (not quicklisp-client::*quickload-prompt*)
+                                     (press-enter-to-continue))
+                             (apply-load-strategy strategy)))
+                         (try-finding-it)))))))))
+    (if (boundp '*tried-so-far*)
+        ;; we are getting nested
+        (body)
+        ;; only do these once
+        (with-simple-restart (abort "Give up on loading ~S" name)
+          (let ((*tried-so-far* (make-hash-table :test 'equalp)))
+            (declare (special *tried-so-far*))
+            (body))))))
+
 (defun compute-load-strategy (name)
   (setf name (string-downcase name))
   (let ((asdf-systems '())
@@ -160,42 +209,6 @@
      (format t "~&; Loading ~S~%" (name strategy))
      (asdf:oos 'asdf:load-op (name strategy) :verbose nil))))
 
-(defun autoload-system-and-dependencies (name &key prompt)
-  "Try to load the system named by NAME, automatically loading any
-Quicklisp-provided systems first, and catching ASDF missing
-dependencies too if possible."
-  (setf name (string-downcase name))
-  (with-simple-restart (abort "Give up on ~S" name)
-    (let ((strategy (compute-load-strategy name))
-          (tried-so-far (make-hash-table :test 'equalp)))
-      (show-load-strategy strategy)
-      (when (or (not prompt)
-                (press-enter-to-continue))
-        (tagbody
-         retry
-         (handler-case (apply-load-strategy strategy)
-           (asdf:missing-dependency-of-version (c)
-             ;; Nothing Quicklisp can do to recover from this, so just
-             ;; resignal
-             (error c))
-           (asdf:missing-dependency (c)
-             (let ((parent (asdf::missing-required-by c))
-                   (missing (asdf::missing-requires c)))
-               (typecase parent
-                 (asdf:system
-                  (if (gethash missing tried-so-far)
-                     (error "Dependency looping -- already tried to load ~
-                                 ~A" missing)
-                     (setf (gethash missing tried-so-far) missing))
-                  (autoload-system-and-dependencies missing
-                                                   :prompt prompt)
-                  (go retry))
-                 (t
-                  ;; Error isn't from a system dependency, so there's
-                  ;; nothing to autoload
-                  (error c)))))))))
-    name))
-
 (defvar *initial-dist-url*
   "http://beta.quicklisp.org/dist/quicklisp.txt")