add portable quicklisp

quicklisp/setup.lisp

@@ -0,0 +1,135 @@
+(defpackage #:ql-setup
+  (:use #:cl)
+  (:export #:*quicklisp-home*
+           #:qmerge
+           #:qenough))
+
+(in-package #:ql-setup)
+
+(unless *load-truename*
+  (error "This file must be LOADed to set up quicklisp."))
+
+(defvar *quicklisp-home*
+  (make-pathname :name nil :type nil
+                 :defaults *load-truename*))
+
+(defun qmerge (pathname)
+  "Return PATHNAME merged with the base Quicklisp directory."
+  (merge-pathnames pathname *quicklisp-home*))
+
+(defun qenough (pathname)
+  (enough-namestring pathname *quicklisp-home*))
+
+;;; ASDF is a hard requirement of quicklisp. Make sure it's either
+;;; already loaded or load it from quicklisp's bundled version.
+
+(defvar *required-asdf-version* "3.0")
+
+;;; Put ASDF's fasls in a separate directory
+
+(defun implementation-signature ()
+  "Return a string suitable for discriminating different
+implementations, or similar implementations with possibly-incompatible
+FASLs."
+  ;; XXX Will this have problems with stuff like threads vs
+  ;; non-threads fasls?
+  (let ((*print-pretty* nil))
+    (format nil "lisp-implementation-type: ~A~%~
+                 lisp-implementation-version: ~A~%~
+                 machine-type: ~A~%~
+                 machine-version: ~A~%"
+            (lisp-implementation-type)
+            (lisp-implementation-version)
+            (machine-type)
+            (machine-version))))
+
+(defun dumb-string-hash (string)
+  "Produce a six-character hash of STRING."
+  (let ((hash #xD13CCD13))
+    (loop for char across string
+          for value = (char-code char)
+          do
+          (setf hash (logand #xFFFFFFFF
+                             (logxor (ash hash 5)
+                                     (ash hash -27)
+                                     value))))
+    (subseq (format nil "~(~36,6,'0R~)" (mod hash 88888901))
+            0 6)))
+
+(defun asdf-fasl-pathname ()
+  "Return a pathname suitable for storing the ASDF FASL, separated
+from ASDF FASLs from incompatible implementations. Also, save a file
+in the directory with the implementation signature, if it doesn't
+already exist."
+  (let* ((implementation-signature (implementation-signature))
+         (original-fasl (compile-file-pathname (qmerge "asdf.lisp")))
+         (fasl
+          (qmerge (make-pathname
+                   :defaults original-fasl
+                   :directory
+                   (list :relative
+                         "cache"
+                         "asdf-fasls"
+                         (dumb-string-hash implementation-signature)))))
+         (signature-file (merge-pathnames "signature.txt" fasl)))
+    (ensure-directories-exist fasl)
+    (unless (probe-file signature-file)
+      (with-open-file (stream signature-file :direction :output)
+        (write-string implementation-signature stream)))
+    fasl))
+
+(defun ensure-asdf-loaded ()
+  "Try several methods to make sure that a sufficiently-new ASDF is
+loaded: first try (require \"asdf\"), then loading the ASDF FASL, then
+compiling asdf.lisp to a FASL and then loading it."
+  (let ((source (qmerge "asdf.lisp")))
+    (labels ((asdf-symbol (name)
+               (let ((asdf-package (find-package '#:asdf)))
+                 (when asdf-package
+                   (find-symbol (string name) asdf-package))))
+             (version-satisfies (version)
+               (let ((vs-fun (asdf-symbol '#:version-satisfies))
+                     (vfun (asdf-symbol '#:asdf-version)))
+                 (when (and vs-fun vfun
+                            (fboundp vs-fun)
+                            (fboundp vfun))
+                   (funcall vs-fun (funcall vfun) version)))))
+      (block nil
+        (macrolet ((try (&body asdf-loading-forms)
+                     `(progn
+                        (handler-bind ((warning #'muffle-warning))
+                          (ignore-errors
+                            ,@asdf-loading-forms))
+                        (when (version-satisfies *required-asdf-version*)
+                          (return t)))))
+          (try)
+          (try (require "asdf"))
+          (let ((fasl (asdf-fasl-pathname)))
+            (try (load fasl :verbose nil))
+            (try (load (compile-file source :verbose nil :output-file fasl))))
+          (error "Could not load ASDF ~S or newer" *required-asdf-version*))))))
+
+(ensure-asdf-loaded)
+
+;;;
+;;; Quicklisp sometimes must upgrade ASDF. Ugrading ASDF will blow
+;;; away existing ASDF methods, so e.g. FASL recompilation :around
+;;; methods would be lost. This config file will make it possible to
+;;; ensure ASDF can be configured before loading Quicklisp itself via
+;;; ASDF. Thanks to Nikodemus Siivola for pointing out this issue.
+;;;
+
+(let ((asdf-init (probe-file (qmerge "asdf-config/init.lisp"))))
+  (when asdf-init
+    (with-simple-restart (skip "Skip loading ~S" asdf-init)
+      (load asdf-init :verbose nil :print nil))))
+
+(push (qmerge "quicklisp/") asdf:*central-registry*)
+
+(let ((*compile-print* nil)
+      (*compile-verbose* nil)
+      (*load-verbose* nil)
+      (*load-print* nil))
+  (asdf:oos 'asdf:load-op "quicklisp" :verbose nil))
+
+(quicklisp:setup)