source: trunk/abcl/contrib/quicklisp/quicklisp-abcl.lisp @ 15384

Last change on this file since 15384 was 15384, checked in by Mark Evenson, 20 months ago

quicklisp-abcl: remove all Quicklisp fasls on failure

Emit more verbosity to the stream designated by CL:*LOAD-VERBOSE*.

TODO: find a reproducible failing test case to ensure we have fixed
this.

File size: 3.5 KB
Line 
1(in-package :cl-user)
2
3(defpackage quicklisp-abcl
4  (:nicknames :quicklisp-abcl)
5  (:use :cl
6        :asdf)
7  (:export
8   #:quicklisp/boot/fasls
9   #:ensure-installation
10   #:*quicklisp-parent-dir*))
11
12(in-package :quicklisp-abcl)
13
14;;;;
15;;;;  1. (ABCL) Download setup.lisp if necessary from the network,
16;;;;     running the Quicklisp setup routine
17;;;;
18;;;;  2.  Ensure that we cache the and use the fasl for
19;;;;        (merge-pathnames "setup.lisp" *quicklisp-parent-dir*
20;;;;
21
22(defvar *quicklisp-parent-dir* (user-homedir-pathname)
23  "Pathname reference to the parent directory of the local Quicklisp installation")
24
25(defun quicklisp/boot/fasls (&key (remove nil))
26  "Enumerate all Quicklisp fasls, including the one we shim for the loader"
27  ;;; TODO: ensure that this works for other implementations
28    (let* ((setup-base
29             (merge-pathnames "quicklisp/setup" *quicklisp-parent-dir*))
30           (setup-source
31             (make-pathname :defaults setup-base :type "lisp"))
32           (setup-fasl
33             (make-pathname :defaults setup-base :type "abcl"))
34           (asdf-output-root
35             (when (ignore-errors (asdf:find-system :quicklisp))
36               (asdf:apply-output-translations
37                (asdf:system-source-directory (asdf:find-system :quicklisp))))))
38      (let ((all-fasls (list setup-fasl
39                             (when asdf-output-root
40                               (directory 
41                                (merge-pathnames "**/*" asdf-output-root))))))
42        (when remove
43          (format *load-verbose* "~&;;quicklisp-abcl: deleting ~{~a ~}~%" all-fasls)
44          (mapcar #'delete-file all-fasls))
45        (values all-fasls
46                setup-base setup-source setup-fasl))))
47
48;;; After we have loaded this system, ensure Quicklisp is loaded
49(defun ensure-installation ()
50  (when (find :quicklisp *features*)
51    (return-from ensure-installation))
52  (multiple-value-bind (fasls
53                        setup-base setup-source setup-fasl)
54      (quicklisp/boot/fasls)
55    (if (probe-file setup-source)
56        ;; First try loading the Quicklisp setup as a compiled fasl if it exists
57        (if (probe-file setup-fasl)
58            (handler-case
59                (load setup-fasl)
60              ;; The fasl may be invalid (i.e. between abcl versions); if so, load source, and recompile
61              (error (e)
62                (format *load-verbose* "~&Failed to load Quicklisp setup fasl ~%~t~a~%because:~%~t~a~%" setup-fasl e)
63                (when setup-source
64                  (format *load-verbose* "Removing Quicklisp setup fasl and recompiling...")
65                  (quicklisp/boot/fasls :remove t)
66                  (load setup-source)
67                  (compile-file setup-source :output-file setup-fasl))))
68            ;; compilation only succeeds after Quicklisp has been fully loaded
69            (when (probe-file setup-source)
70              (load setup-source)
71              (compile-file setup-source :output-file setup-fasl)))
72          ;;; Otherwise download Quicklisp and run its installation sequence
73        (progn 
74          (handler-case 
75              (load "https://beta.quicklisp.org/quicklisp.lisp")
76            (error (e)
77              (warn "Using insecure transport for remote installation of Quicklisp:~&~A~&." e)
78              (load "http://beta.quicklisp.org/quicklisp.lisp")))
79          (uiop:symbol-call :quicklisp-quickstart '#:install
80                            :path (merge-pathnames "quicklisp/"
81                                                   *quicklisp-parent-dir*))))))
82
83
Note: See TracBrowser for help on using the repository browser.